X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=FPPrac.hs;h=79a6a0ac9405b167d0c76b931c9292bdc49462c4;hb=ea597e505a69974dfd35dd2728b1e9f3bb109fa9;hp=628962b09bd7de2b5585f5eaddf8b200d55f5783;hpb=ae1ef2b0b9dbb48141e140945152f39910c1a91a;p=matthijs%2Fprojects%2Ffpprac.git diff --git a/FPPrac.hs b/FPPrac.hs index 628962b..79a6a0a 100644 --- a/FPPrac.hs +++ b/FPPrac.hs @@ -1,21 +1,54 @@ {-# LANGUAGE RecordWildCards, ExistentialQuantification #-} module FPPrac ( - module Graphics.UI.WXCore.WxcTypes, Request(..), Response(..), TinaProgram(..), + Color, Rect(..), Point(..), + rgb, pt, point, runTina ) where -import Graphics.UI.WXCore.WxcTypes -import Graphics.UI.WX hiding (empty) -import Graphics.UI.WXCore hiding (empty) +import qualified Graphics.UI.Gtk as Gtk +import Graphics.UI.Gtk (AttrOp(..)) -- For the := constructor +import qualified Graphics.Rendering.Cairo as Cairo +import qualified Graphics.UI.Gtk.Gdk.EventM as EventM + +import Control.Monad.Trans -- for liftIO import Data.IORef import Control.Applicative import Control.Monad import Char import System.Exit +-- | A rectangle in two dimensional space +data Rect = Rect + { rectLeft :: !Int + , rectTop :: !Int + , rectWidth :: !Int + , rectHeight :: !Int +} deriving (Show, Eq) + +data Point = Point !Int !Int deriving (Show, Eq) + +type Color = Gtk.Color + +-- Create a Color from Red, Green and Blue values. The inputs should be +-- between 0 and 255 (inclusive). +rgb :: Int -> Int -> Int -> Color +rgb r g b = Gtk.Color (conv r) (conv g) (conv b) + where conv = fromInteger . toInteger . (*256) + +-- | Some predefined colours +red = rgb 0xff 0 0 +green = rgb 0 0xff 0 +blue = rgb 0 0 0xff +white = rgb 0xff 0xff 0xff + +-- | Helper functions for creating a Point +point, pt :: Int -> Int -> Point +point = Point +pt = Point + data Request = GfxLines Color [Point] -- coloured line through a list of points | GfxPolygon Color [Point] -- filled polygon of given colour @@ -65,17 +98,13 @@ testProg = Main } data IState = forall s. IS - { sFrame :: Frame () - , sPanel :: Panel () - , buffer :: MemoryDC () + { window :: Gtk.Window + , buffer :: IORef Cairo.Surface , postponed :: IORef [Request] , usrState :: IORef s , usrProg :: TinaStep s } -dbgLog IS {..} s = do - return () - processPostponed :: IState -> IO () processPostponed s@IS {..} = do ps <- readIORef postponed @@ -104,12 +133,56 @@ runTina :: TinaProgram -> IO () runTina Main {..} = do usrState <- newIORef initialState postponed <- newIORef (GfxText (rgb 0 0 0) (pt 50 50) "foo" : GfxClear :initialRequests) - let state = IS { sFrame = undefined, sPanel = undefined, buffer = undefined, usrProg = eventHandler, .. } - run $ runGUI (sz windowWidth windowHeight) state - putStrLn "XX" - runGUI (sz windowWidth windowHeight) state + let state = IS { window = undefined, buffer = undefined, usrProg = eventHandler, .. } + runGUI windowWidth windowHeight state -runGUI :: Size -> IState -> IO () +runGUI :: Int -> Int -> IState -> IO () +runGUI w h (IS { .. }) = do + -- Init GTK. + Gtk.initGUI + + -- Create a window, which will make the mainloop terminated when + -- it is closed. + window <- Gtk.windowNew + + Gtk.set window [ Gtk.containerBorderWidth := 10 + , Gtk.windowTitle := "FP Practicum" + , Gtk.windowDefaultWidth := w + , Gtk.windowDefaultHeight := h + ] + Gtk.onDestroy window Gtk.mainQuit + + -- Create a buffer to draw on (name the actual buffer buffer', so we + -- can use IS { .. } syntax below to pack the state. Using a record update + -- wouldn't work, probably because Cairo.Surface contains an existential + -- type... + -- We put the buffer in an IORef, so we can change it for a new one + -- later on (on window resizes). + buffer' <- Cairo.createImageSurface Cairo.FormatARGB32 w h + buffer <- newIORef buffer' + + -- Register the expose event + Gtk.on window Gtk.exposeEvent $ onExpose buffer + + -- Repack state + let state = IS { .. } + + -- Show the window and start the Gtk mainloop. + Gtk.widgetShowAll window + Gtk.mainGUI + +-- | Copy the given surface to the exposed window on an expose event. +onExpose :: IORef Cairo.Surface -> EventM.EventM EventM.EExpose Bool +onExpose buffer = do + current_buffer <- liftIO $ readIORef buffer + dw <- EventM.eventWindow + -- Copy the buffer to the window + liftIO $ Gtk.renderWithDrawable dw $ do + Cairo.setSourceSurface current_buffer 0 0 + Cairo.paint + return True -- No clue what this means + +{- runGUI s IS {..} = do sFrame <- frame [ text := "FP Practicum" @@ -144,7 +217,6 @@ runGUI s IS {..} = do ] windowSetFocus sFrame processPostponed state - onPaint :: IState -> DC a -> Rect -> IO () onPaint IS {..} dest va = do dcBlit dest va buffer (Point 0 0) wxCOPY False >> return () @@ -157,14 +229,16 @@ transKey prod KeyReturn = prod '\n' transKey prod KeyTab = prod '\t' transKey _ _ = return () +-} - - +{- miscHandler s@IS {..} (FRead fn ) = Just $ readFile fn >>= post s . FileContents fn miscHandler IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts miscHandler IS {..} ReqQuit = Just $ putStrLn "Quiting" >> wxcAppExit +-} miscHandler IS {..} _ = Nothing +{- winHandler s@IS {..} (WinPrompt st1 st2 st3) = Just $ textDialog sFrame st1 st2 st3 >>= post s . PromptResponse st1 st2 winHandler IS {..} (WinTitle st) = Just $ sFrame `set` [text := st] winHandler s@IS {..} (WinMenu ms) = Just $ mkMenu >>= \ms' -> sFrame `set` [menuBar := ms'] @@ -179,8 +253,10 @@ winHandler s@IS {..} (WinMenu ms) = Just $ mkMenu >>= \ms' -> sFrame `set` | item <- items ] return p | (name,items) <- ms ] +-} winHandler _ _ = Nothing +{- gfxHandler IS {..} (GfxLines col ps) = Just $ polyline buffer ps [penColor := col] >> dirtyPts sPanel ps gfxHandler IS {..} (GfxPolygon col ps) = Just $ polygon buffer ps [penColor := col, brushColor := col] >> dirtyPts sPanel ps gfxHandler IS {..} (GfxText col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy @@ -190,8 +266,10 @@ gfxHandler IS {..} (GfxDisc col rt) = Just $ ellipse buffer rt [penColor gfxHandler IS {..} (GfxFont st sz) = Just $ buffer `set` [ fontSize := sz, fontFace := st ] gfxHandler IS {..} GfxClear = Just $ dcClear buffer >> windowRefresh sPanel False gfxHandler IS {..} (GfxPicture fd pt) = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt +-} gfxHandler _ _ = Nothing +{- dirtyPts :: Window a -> [Point] -> IO () dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..} where @@ -218,4 +296,4 @@ grow n Rect {..} = Rect , rectWidth = rectWidth + 2 * n , rectHeight = rectHeight + 2 * n } - +-}