FPPrac.hs

   1 {-# LANGUAGE RecordWildCards, ExistentialQuantification #-}
   2 module FPPrac (
   3         Request(..),
   4         Response(..),
   5         TinaProgram(..),
   6         Color, Rect(..), Point(..),
   7         rgb, pt, point,
   8         runTina
   9 ) where
  10
  11 import qualified Graphics.UI.Gtk as Gtk
  12 import Graphics.UI.Gtk (AttrOp(..)) -- For the := constructor
  13 import qualified Graphics.Rendering.Cairo as Cairo
  14 import qualified Graphics.UI.Gtk.Gdk.EventM as EventM
  15
  16 import Control.Monad.Trans -- for liftIO
  17 import Data.IORef
  18 import Control.Applicative
  19 import Control.Monad
  20 import Char
  21 import System.Exit
  22
  23 -- | A rectangle in two dimensional space
  24 data Rect = Rect
  25         { rectLeft :: !Int
  26         , rectTop :: !Int
  27         , rectWidth :: !Int
  28         , rectHeight :: !Int
  29 } deriving (Show, Eq)
  30
  31 data Point = Point !Int !Int deriving (Show, Eq)
  32
  33 -- A color, with RGB values from 0 to 1
  34 data Color = Color Double Double Double deriving (Show, Eq)
  35
  36 -- Create a Color from Red, Green and Blue values. The inputs should be
  37 -- between 0 and 255 (inclusive).
  38 rgb :: Int -> Int -> Int -> Color
  39 rgb r g b = Color (conv r) (conv g) (conv b)
  40         where conv = (/256) . fromIntegral
  41
  42 -- | Some predefined colours
  43 red = rgb 0xff 0 0
  44 green = rgb 0 0xff 0
  45 blue = rgb 0 0 0xff
  46 white = rgb 0xff 0xff 0xff
  47
  48 -- | Helper functions for creating a Point
  49 point, pt :: Int -> Int -> Point
  50 point = Point
  51 pt = Point
  52
  53 data Request
  54         = GfxLines      Color   [Point]                 -- coloured line through a list of points
  55         | GfxPolygon    Color   [Point]                 -- filled polygon of given colour
  56         | GfxPicture    FilePath Point                  -- shows a picture
  57         | GfxText       Color    Point  String          -- coloured string on position Point
  58         | GfxRectangle  Color    Rect                   -- filled rectangle of given colour
  59         | GfxEllipse    Color    Rect                   -- ellipse within given rectangle
  60         | GfxDisc       Color    Rect                   -- filled ellipse within given rectangle
  61         | GfxClear                                      -- clears the graphical window
  62         -- | GfxInstance   Bool
  63         | GfxFont       String   Int                    -- changes to fontname of given size
  64         | WinPrompt     String   String String          -- pops up a window with an edit field
  65         -- | WinFilePrompt Bool
  66         | WinMenu       [(String,[String])]             -- adds a menu list to the graphical window
  67         | WinTitle      String                          -- gives a title to the graphical window
  68         | FRead         String                          -- read file with a given name
  69         | FWrite        String   String                 -- writes a text file with a given filename
  70         | ReqQuit                                       -- quits the graphical system
  71         deriving Show
  72
  73 data Response
  74         = KeyIn            Char                         -- touched key with given character
  75         | MouseDoubleClick Point                        -- mouse event on position Point
  76         | MouseDragged     Point                        -- ibid
  77         | MouseDown        Point                        -- ibid
  78         | MouseUp          Point                        -- ibid
  79         | MenuItem         String String                -- selected item from WinMenu with a given name
  80         | PromptResponse   String String String         -- response to WinPrompt request
  81         | FileContents     String String                -- response to FRead request
  82         deriving Show
  83
  84 type TinaStep s = s -> Response -> (s,[Request])
  85 data TinaProgram = forall s. Main
  86         { initialState    :: s
  87         , initialRequests :: [Request]
  88         , eventHandler    :: TinaStep s
  89         , windowWidth
  90         , windowHeight    :: Int
  91         }
  92
  93 testProg = Main
  94         { initialState    = 1
  95         , initialRequests = [GfxText red (pt 0 0) "foo", GfxText blue (pt 100 100) "bar"]
  96         , eventHandler    = \s e -> (s+1,[GfxText green (pt 50 50) $ show (s,e)])
  97         , windowWidth     = 200
  98         , windowHeight    = 200
  99         }
 100
 101 data IState = forall s. IS
 102         { window    :: Gtk.Window
 103         , buffer    :: IORef Cairo.Surface
 104         , postponed :: IORef [Request]
 105         , usrState  :: IORef s
 106         , usrProg   :: TinaStep s
 107         }
 108
 109 processPostponed :: IState -> IO ()
 110 processPostponed s@IS {..} = do
 111         ps <- readIORef postponed
 112         unless (null ps) $ do
 113                 writeIORef postponed (tail ps)
 114                 rs  <- handle s (head ps)
 115                 mapM (stepUserProgram s) rs
 116                 processPostponed s
 117
 118 post s r = stepUserProgram s r >> processPostponed s
 119
 120 stepUserProgram :: IState -> Response -> IO ()
 121 stepUserProgram IS {..} r = do
 122         state <- readIORef usrState
 123         let (state',reqs) = usrProg state r
 124         writeIORef usrState state'
 125         readIORef postponed >>= writeIORef postponed . (++ reqs)
 126
 127 handle :: IState -> Request -> IO [Response]
 128 handle s@IS {..} r = do
 129         resps <- maybe (fail $ "No handler for request " ++ show r) id $
 130                 fmap (>> return []) (gfxHandler s r <|> winHandler s r <|> miscHandler s r)
 131         return resps
 132
 133 runTina :: TinaProgram -> IO ()
 134 runTina Main {..} = do
 135         usrState  <- newIORef initialState
 136         postponed <- newIORef (GfxText (rgb 0 0 0) (pt 50 50) "foo" : GfxClear :initialRequests)
 137         let state = IS { window = undefined, buffer = undefined, usrProg = eventHandler, .. }
 138         runGUI windowWidth windowHeight state
 139
 140 runGUI :: Int -> Int -> IState -> IO ()
 141 runGUI w h (IS { .. }) = do
 142         -- Init GTK.
 143         Gtk.initGUI
 144
 145         -- Create a window, which will make the mainloop terminated when
 146         -- it is closed.
 147         window <- Gtk.windowNew
 148
 149         Gtk.set window [ Gtk.containerBorderWidth := 10
 150                        , Gtk.windowTitle := "FP Practicum"
 151                        , Gtk.windowDefaultWidth := w
 152                        , Gtk.windowDefaultHeight := h
 153                        ]
 154         Gtk.onDestroy window Gtk.mainQuit
 155
 156         -- Create a buffer to draw on (name the actual buffer buffer', so we
 157         -- can use IS { .. } syntax below to pack the state. Using a record update
 158         -- wouldn't work, probably because Cairo.Surface contains an existential
 159         -- type...
 160         -- We put the buffer in an IORef, so we can change it for a new one
 161         -- later on (on window resizes).
 162         buffer' <- Cairo.createImageSurface Cairo.FormatARGB32 w h
 163         buffer <- newIORef buffer'
 164
 165         -- Register the expose event
 166         Gtk.on window Gtk.exposeEvent $ onExpose buffer
 167
 168         -- Repack state
 169         let state = IS { .. }
 170
 171         -- Process any initial requests
 172         processPostponed state
 173
 174         -- Show the window and start the Gtk mainloop.
 175         Gtk.widgetShowAll window
 176         Gtk.mainGUI
 177
 178
 179 -- | Copy the given surface to the exposed window on an expose event.
 180 onExpose :: IORef Cairo.Surface -> EventM.EventM EventM.EExpose Bool
 181 onExpose buffer = do
 182         current_buffer <- liftIO $ readIORef buffer
 183         dw <- EventM.eventWindow
 184         -- Copy the buffer to the window
 185         liftIO $ Gtk.renderWithDrawable dw $ do
 186                 Cairo.setSourceSurface current_buffer 0 0
 187                 Cairo.paint
 188         return True -- No clue what this means
 189
 190 {-
 191 runGUI s IS {..} = do
 192         sFrame <- frame
 193                 [ text       := "FP Practicum"
 194                 , size       := s
 195                 ]
 196         buffer <- memoryDCCreate
 197         bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
 198         withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
 199         dcClear buffer
 200         buffer `set`
 201                 [ fontFace   := "Courier New"
 202                 , fontSize   := 10
 203                 , brushColor := rgb 0 0 0
 204                 , brushKind  := BrushSolid
 205                 , penColor   := rgb 0 0 0
 206                 , penKind    := PenSolid
 207                 ]
 208         sPanel <- panel sFrame [ size := s ]
 209         let state = IS {..}
 210         sPanel `set`
 211                 [ on paint       := onPaint state
 212                 , on doubleClick := post state . MouseDoubleClick
 213                 , on click       := post state . MouseDown
 214                 , on drag        := post state . MouseDragged
 215                 , on unclick     := post state . MouseUp
 216                 , on anyKey      := transKey (post state . KeyIn)
 217                 ]
 218         sFrame `set`
 219                 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
 220                 , on anyKey  := transKey (post state . KeyIn)
 221                 , layout     := widget sPanel
 222                 ]
 223         windowSetFocus sFrame
 224         processPostponed state
 225 onPaint :: IState -> DC a -> Rect -> IO ()
 226 onPaint IS {..} dest va = do
 227         dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
 228
 229 transKey :: (Char -> IO ()) -> Key -> IO ()
 230 transKey prod (KeyChar c) = prod c
 231 transKey prod  KeySpace   = prod ' '
 232 transKey prod  KeyEscape  = prod '\ESC'
 233 transKey prod  KeyReturn  = prod '\n'
 234 transKey prod  KeyTab     = prod '\t'
 235 transKey _ _ = return ()
 236
 237 -}
 238
 239 -- | Handlers for various requests.
 240 miscHandler, winHandler, gfxHandler :: IState -> Request -> Maybe (IO ())
 241 {-
 242 miscHandler s@IS {..} (FRead  fn     ) = Just $ readFile fn >>= post s . FileContents fn
 243 miscHandler   IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts
 244 miscHandler   IS {..} ReqQuit = Just $ putStrLn "Quiting" >> wxcAppExit
 245 -}
 246 miscHandler   IS {..} _ = Nothing
 247
 248 {-
 249 winHandler s@IS {..} (WinPrompt st1 st2 st3) = Just $ textDialog sFrame st1 st2 st3 >>= post s . PromptResponse st1 st2
 250 winHandler   IS {..} (WinTitle     st) = Just $ sFrame `set` [text := st]
 251 winHandler s@IS {..} (WinMenu      ms) = Just $ mkMenu >>= \ms' -> sFrame `set` [menuBar := ms']
 252         where
 253         mkMenu = sequence
 254                 [ do
 255                         p  <- menuPane [ text := name ]
 256                         sequence
 257                                 [ do
 258                                         i <- menuItem p [ text := item ]
 259                                         sFrame `set` [on (menu i) := post s (MenuItem name item)]
 260                                  | item <- items ]
 261                         return p
 262                  | (name,items) <- ms ]
 263 -}
 264 winHandler _        _                = Nothing
 265
 266 gfxHandler s req = case gfxHandler' req of
 267         Nothing -> Nothing
 268         Just render -> Just $ do
 269                 buf <- readIORef (buffer s)
 270                 Cairo.renderWith buf render
 271                 Gtk.widgetQueueDraw (window s)
 272
 273 {-
 274 gfxHandler IS {..} (GfxLines     col ps)    = Just $ polyline buffer ps [penColor := col] >> dirtyPts sPanel ps
 275 gfxHandler IS {..} (GfxPolygon   col ps)    = Just $ polygon  buffer ps [penColor := col, brushColor := col] >> dirtyPts sPanel ps
 276 gfxHandler IS {..} (GfxText      col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy
 277 gfxHandler IS {..} (GfxRectangle col rt)    = Just $ drawRect buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
 278 gfxHandler IS {..} (GfxEllipse   col rt)    = Just $ ellipse buffer rt [penColor := col, brushKind := BrushTransparent] >> dirtyRect sPanel rt
 279 gfxHandler IS {..} (GfxDisc      col rt)    = Just $ ellipse buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
 280 gfxHandler IS {..} (GfxFont      st  sz)    = Just $ buffer `set` [ fontSize := sz, fontFace := st ]
 281 gfxHandler IS {..} (GfxPicture   fd  pt)    = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt
 282 -}
 283 -- | Helper function for gfxHanlder
 284 gfxHandler' :: Request -> Maybe (Cairo.Render ())
 285 gfxHandler' (GfxText col (Point x y) st) = Just $ do
 286         -- Set the source color, move to the requested position and draw the
 287         -- text
 288         setSourceColor col
 289         Cairo.moveTo (fromIntegral x) (fromIntegral y)
 290         Cairo.showText st
 291 gfxHandler' GfxClear = Just $ do
 292         -- Set the source to white and paint the entire surface with it
 293         Cairo.setSourceRGB 1 1 1
 294         Cairo.paint
 295 gfxHandler' _ = Nothing
 296
 297 -- | Sets the source to a pattern fill of the given color
 298 setSourceColor :: Color -> Cairo.Render ()
 299 setSourceColor (Color r g b) =
 300         Cairo.setSourceRGB r g b
 301
 302 {-
 303 dirtyPts :: Window a -> [Point] -> IO ()
 304 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
 305         where
 306         xs     = map pointX ps
 307         ys     = map pointY ps
 308         x      = minimum xs
 309         y      = minimum ys
 310         sizeW  = maximum xs - x
 311         sizeH  = maximum ys - y
 312
 313 dirtyRect' :: Window a -> Point -> Size -> IO ()
 314 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
 315
 316 dirtyRect :: Window a -> Rect -> IO ()
 317 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
 318
 319 rectanglify :: Point -> Size -> Rect
 320 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
 321
 322 grow :: Int -> Rect -> Rect
 323 grow n Rect {..} = Rect
 324         { rectLeft   = rectLeft   - n
 325         , rectTop    = rectTop    - n
 326         , rectWidth  = rectWidth  + 2 * n
 327         , rectHeight = rectHeight + 2 * n }
 328
 329 -}