X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fprojects%2Ffpprac.git;a=blobdiff_plain;f=FPPrac.hs;h=306f048001dca25e62b2864c98e2b01fda06af78;hp=628962b09bd7de2b5585f5eaddf8b200d55f5783;hb=HEAD;hpb=ae1ef2b0b9dbb48141e140945152f39910c1a91a diff --git a/FPPrac.hs b/FPPrac.hs index 628962b..306f048 100644 --- a/FPPrac.hs +++ b/FPPrac.hs @@ -1,21 +1,55 @@ {-# 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) + +-- 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 = Color (conv r) (conv g) (conv b) + where conv = (/256) . fromIntegral + +-- | 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 @@ -59,23 +93,19 @@ 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 () + { 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 +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' -runGUI :: Size -> IState -> IO () + -- 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 sFrame <- frame [ text := "FP Practicum" @@ -144,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 () @@ -157,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'] @@ -179,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 @@ -188,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 @@ -218,4 +363,4 @@ grow n Rect {..} = Rect , rectWidth = rectWidth + 2 * n , rectHeight = rectHeight + 2 * n } - +-}