{-# LANGUAGE RecordWildCards, ExistentialQuantification #-} module FPPrac ( Request(..), Response(..), TinaProgram(..), Color, Rect(..), Point(..), rgb, pt, point, runTina ) 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 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 | GfxPicture FilePath Point -- shows a picture | GfxText Color Point String -- coloured string on position Point | GfxRectangle Color Rect -- filled rectangle of given colour | GfxEllipse Color Rect -- ellipse within given rectangle | GfxDisc Color Rect -- filled ellipse within given rectangle | GfxClear -- clears the graphical window -- | GfxInstance Bool | GfxFont String Int -- changes to fontname of given size | WinPrompt String String String -- pops up a window with an edit field -- | WinFilePrompt Bool | WinMenu [(String,[String])] -- adds a menu list to the graphical window | WinTitle String -- gives a title to the graphical window | FRead String -- read file with a given name | FWrite String String -- writes a text file with a given filename | ReqQuit -- quits the graphical system deriving Show data Response = KeyIn Char -- touched key with given character | MouseDoubleClick Point -- mouse event on position Point | MouseDragged Point -- ibid | MouseDown Point -- ibid | MouseUp Point -- ibid | MenuItem String String -- selected item from WinMenu with a given name | PromptResponse String String String -- response to WinPrompt request | FileContents String String -- response to FRead request deriving Show type TinaStep s = s -> Response -> (s,[Request]) data TinaProgram = forall s. Main { initialState :: s , initialRequests :: [Request] , eventHandler :: TinaStep s , windowWidth , windowHeight :: Int } 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)]) , windowWidth = 200 , windowHeight = 200 } data IState = forall s. IS { window :: Gtk.Window , buffer :: IORef Cairo.Surface , postponed :: IORef [Request] , usrState :: IORef s , usrProg :: TinaStep s } processPostponed :: IState -> IO () processPostponed s@IS {..} = do ps <- readIORef postponed unless (null ps) $ do writeIORef postponed (tail ps) rs <- handle s (head ps) mapM (stepUserProgram s) rs processPostponed s post s r = stepUserProgram s r >> processPostponed s stepUserProgram :: IState -> Response -> IO () stepUserProgram IS {..} r = do state <- readIORef usrState let (state',reqs) = usrProg state r writeIORef usrState state' readIORef postponed >>= writeIORef postponed . (++ reqs) handle :: IState -> Request -> IO [Response] handle s@IS {..} r = do resps <- maybe (fail $ "No handler for request " ++ show r) id $ fmap (>> return []) (gfxHandler s r <|> winHandler s r <|> miscHandler s r) return resps 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 { 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' -- Register the expose event Gtk.on window Gtk.exposeEvent $ onExpose buffer -- Repack state let state = IS { .. } -- Process any initial requests processPostponed state -- 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" , size := s ] buffer <- memoryDCCreate bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer) dcClear buffer buffer `set` [ fontFace := "Courier New" , fontSize := 10 , brushColor := rgb 0 0 0 , brushKind := BrushSolid , penColor := rgb 0 0 0 , penKind := PenSolid ] sPanel <- panel sFrame [ size := s ] let state = IS {..} sPanel `set` [ on paint := onPaint state , on doubleClick := post state . MouseDoubleClick , on click := post state . MouseDown , on drag := post state . MouseDragged , on unclick := post state . MouseUp , on anyKey := transKey (post state . KeyIn) ] sFrame `set` [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit , on anyKey := transKey (post state . KeyIn) , layout := widget sPanel ] 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 () transKey :: (Char -> IO ()) -> Key -> IO () transKey prod (KeyChar c) = prod c transKey prod KeySpace = prod ' ' transKey prod KeyEscape = prod '\ESC' 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'] where mkMenu = sequence [ do p <- menuPane [ text := name ] sequence [ do i <- menuItem p [ text := item ] sFrame `set` [on (menu i) := post s (MenuItem name item)] | item <- items ] return p | (name,items) <- ms ] -} winHandler _ _ = Nothing gfxHandler s req = case gfxHandler' s 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 gfxHandler IS {..} (GfxRectangle col rt) = Just $ drawRect buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt 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 {..} (GfxPicture fd pt) = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt -} gfxHandler' IS {..} (GfxText col (Point x y) st) = Just $ do setSourceColor col Cairo.moveTo (fromIntegral x) (fromIntegral y) Cairo.showText st gfxHandler' IS {..} GfxClear = Just $ 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 xs = map pointX ps ys = map pointY ps x = minimum xs y = minimum ys sizeW = maximum xs - x sizeH = maximum ys - y dirtyRect' :: Window a -> Point -> Size -> IO () dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH dirtyRect :: Window a -> Rect -> IO () dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect) rectanglify :: Point -> Size -> Rect rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH grow :: Int -> Rect -> Rect grow n Rect {..} = Rect { rectLeft = rectLeft - n , rectTop = rectTop - n , rectWidth = rectWidth + 2 * n , rectHeight = rectHeight + 2 * n } -}