X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fprojects%2Ffpprac.git;a=blobdiff_plain;f=FPPrac.hs;h=306f048001dca25e62b2864c98e2b01fda06af78;hp=61fd9ef9b183f630a1ead0f1a7611880c950aeac;hb=HEAD;hpb=e04540efe8801c7462e85906d0c359ad95ad08ef diff --git a/FPPrac.hs b/FPPrac.hs index 61fd9ef..306f048 100644 --- a/FPPrac.hs +++ b/FPPrac.hs @@ -9,6 +9,11 @@ module FPPrac ( ) where 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 @@ -25,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 @@ -44,9 +50,6 @@ point, pt :: Int -> Int -> Point point = Point pt = Point -runTina :: TinaProgram -> IO () -runTina p = return () - data Request = GfxLines Color [Point] -- coloured line through a list of points | GfxPolygon Color [Point] -- filled polygon of given colour @@ -90,22 +93,18 @@ 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 } -{- -dbgLog IS {..} s = do - return () processPostponed :: IState -> IO () processPostponed s@IS {..} = do @@ -135,12 +134,97 @@ 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 :: 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' + + -- 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 -runGUI :: Size -> IState -> IO () + -- 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 sFrame <- frame [ text := "FP Practicum" @@ -175,7 +259,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 () @@ -188,14 +271,18 @@ transKey prod KeyReturn = prod '\n' transKey prod KeyTab = prod '\t' 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 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'] @@ -210,8 +297,17 @@ winHandler s@IS {..} (WinMenu ms) = Just $ mkMenu >>= \ms' -> sFrame `set` | item <- items ] return p | (name,items) <- ms ] +-} 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 gfxHandler IS {..} (GfxText col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy @@ -219,10 +315,28 @@ 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 () dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..} where