X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fprojects%2Ffpprac.git;a=blobdiff_plain;f=FPPrac.hs;h=306f048001dca25e62b2864c98e2b01fda06af78;hp=e56c60458dd3fa75e655bd00c7505969b9dd922f;hb=HEAD;hpb=68c76988596d764cc11eb7b7d9c7d25823892b78 diff --git a/FPPrac.hs b/FPPrac.hs index e56c604..306f048 100644 --- a/FPPrac.hs +++ b/FPPrac.hs @@ -30,13 +30,14 @@ data Rect = Rect data Point = Point !Int !Int deriving (Show, Eq) -type Color = Gtk.Color +-- A color, with RGB values from 0 to 1 +data Color = Color Double Double Double deriving (Show, Eq) -- 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) +rgb r g b = Color (conv r) (conv g) (conv b) + where conv = (/256) . fromIntegral -- | Some predefined colours red = rgb 0xff 0 0 @@ -92,16 +93,15 @@ data TinaProgram = forall s. Main testProg = Main { initialState = 1 , initialRequests = [GfxText red (pt 0 0) "foo", GfxText blue (pt 100 100) "bar"] - , eventHandler = \s e -> (s+1,[GfxText green (pt 50 50) $ show (s,e)]) + , eventHandler = \s e -> (s+1,[GfxText green (pt 50 (50 + 10 * s)) $ show (s,e)]) , windowWidth = 200 , windowHeight = 200 } data IState = forall s. IS - { {-sFrame :: Frame () - , sPanel :: Panel () - , buffer :: MemoryDC () - , -}postponed :: IORef [Request] + { window :: Gtk.Window + , buffer :: IORef Cairo.Surface + , postponed :: IORef [Request] , usrState :: IORef s , usrProg :: TinaStep s } @@ -134,25 +134,95 @@ 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 { usrProg = eventHandler, .. } - runGUI {-(sz windowWidth windowHeight) -}state + let state = IS { window = undefined, buffer = undefined, usrProg = eventHandler, .. } + runGUI windowWidth windowHeight state -runGUI :: {-Size ->-} IState -> IO () -runGUI s = do +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.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' + + -- Repack state + let state = IS { .. } + + -- Register events + Gtk.on window Gtk.exposeEvent $ onExpose buffer + Gtk.on window Gtk.configureEvent $ onResize buffer + Gtk.on window Gtk.keyPressEvent $ onKeyDown state + + -- Process any initial requests + processPostponed state + -- Show the window and start the Gtk mainloop. Gtk.widgetShowAll window Gtk.mainGUI +-- | Called when a key is pressed. +onKeyDown :: IState -> EventM.EventM EventM.EKey Bool +onKeyDown s = do + keyval <- EventM.eventKeyVal + case Gtk.keyToChar keyval of + Just c -> liftIO $ post s (KeyIn c) + Nothing -> return () + return True -- No clue what this means + +-- | Called when (part of) the window should be redrawn. 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 + +-- | Called when the window is resized. Resize the given buffer if needed. +onResize :: IORef Cairo.Surface -> EventM.EventM EventM.EConfigure Bool +onResize buffer = do + -- Get the current buffer and see if it's still big enough + current_buffer <- liftIO $ readIORef buffer + sw <- Cairo.imageSurfaceGetWidth current_buffer + sh <- Cairo.imageSurfaceGetHeight current_buffer + -- Get the current drawwindow and its size + dw <- EventM.eventWindow + (w, h) <- liftIO $ Gtk.drawableGetSize dw + when (w > sw || h > sh) $ liftIO $ do + -- Buffer is too small, expand it. + new_buffer <- Cairo.createImageSurface Cairo.FormatARGB32 w h + -- Fill it with white and copy the old buffer + Cairo.renderWith new_buffer $ do + Cairo.setSourceRGB 1 1 1 + Cairo.paint + Cairo.setSourceSurface current_buffer 0 0 + Cairo.paint + -- Clean up the old buffer + Cairo.surfaceFinish current_buffer + -- Store and return the new buffer + writeIORef buffer new_buffer + return True -- No clue what this means + {- runGUI s IS {..} = do @@ -203,6 +273,8 @@ transKey _ _ = return () -} +-- | Handlers for various requests. +miscHandler, winHandler, gfxHandler :: IState -> Request -> Maybe (IO ()) {- miscHandler s@IS {..} (FRead fn ) = Just $ readFile fn >>= post s . FileContents fn miscHandler IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts @@ -228,6 +300,13 @@ winHandler s@IS {..} (WinMenu ms) = Just $ mkMenu >>= \ms' -> sFrame `set` -} winHandler _ _ = Nothing +gfxHandler s req = case gfxHandler' req of + Nothing -> Nothing + Just render -> Just $ do + buf <- readIORef (buffer s) + Cairo.renderWith buf render + Gtk.widgetQueueDraw (window s) + {- 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 @@ -236,10 +315,26 @@ gfxHandler IS {..} (GfxRectangle col rt) = Just $ drawRect buffer rt [penColo gfxHandler IS {..} (GfxEllipse col rt) = Just $ ellipse buffer rt [penColor := col, brushKind := BrushTransparent] >> dirtyRect sPanel rt gfxHandler IS {..} (GfxDisc col rt) = Just $ ellipse buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt 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 +-- | Helper function for gfxHanlder +gfxHandler' :: Request -> Maybe (Cairo.Render ()) +gfxHandler' (GfxText col (Point x y) st) = Just $ do + -- Set the source color, move to the requested position and draw the + -- text + setSourceColor col + Cairo.moveTo (fromIntegral x) (fromIntegral y) + Cairo.showText st +gfxHandler' GfxClear = Just $ do + -- Set the source to white and paint the entire surface with it + Cairo.setSourceRGB 1 1 1 + Cairo.paint +gfxHandler' _ = Nothing + +-- | Sets the source to a pattern fill of the given color +setSourceColor :: Color -> Cairo.Render () +setSourceColor (Color r g b) = + Cairo.setSourceRGB r g b {- dirtyPts :: Window a -> [Point] -> IO ()