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 type Color = Gtk.Color
  34
  35 -- Create a Color from Red, Green and Blue values. The inputs should be
  36 -- between 0 and 255 (inclusive).
  37 rgb :: Int -> Int -> Int -> Color
  38 rgb r g b = Gtk.Color (conv r) (conv g) (conv b)
  39         where conv = fromInteger . toInteger . (*256)
  40
  41 -- | Some predefined colours
  42 red = rgb 0xff 0 0
  43 green = rgb 0 0xff 0
  44 blue = rgb 0 0 0xff
  45 white = rgb 0xff 0xff 0xff
  46
  47 -- | Helper functions for creating a Point
  48 point, pt :: Int -> Int -> Point
  49 point = Point
  50 pt = Point
  51
  52 data Request
  53         = GfxLines      Color   [Point]                 -- coloured line through a list of points
  54         | GfxPolygon    Color   [Point]                 -- filled polygon of given colour
  55         | GfxPicture    FilePath Point                  -- shows a picture
  56         | GfxText       Color    Point  String          -- coloured string on position Point
  57         | GfxRectangle  Color    Rect                   -- filled rectangle of given colour
  58         | GfxEllipse    Color    Rect                   -- ellipse within given rectangle
  59         | GfxDisc       Color    Rect                   -- filled ellipse within given rectangle
  60         | GfxClear                                      -- clears the graphical window
  61         -- | GfxInstance   Bool
  62         | GfxFont       String   Int                    -- changes to fontname of given size
  63         | WinPrompt     String   String String          -- pops up a window with an edit field
  64         -- | WinFilePrompt Bool
  65         | WinMenu       [(String,[String])]             -- adds a menu list to the graphical window
  66         | WinTitle      String                          -- gives a title to the graphical window
  67         | FRead         String                          -- read file with a given name
  68         | FWrite        String   String                 -- writes a text file with a given filename
  69         | ReqQuit                                       -- quits the graphical system
  70         deriving Show
  71
  72 data Response
  73         = KeyIn            Char                         -- touched key with given character
  74         | MouseDoubleClick Point                        -- mouse event on position Point
  75         | MouseDragged     Point                        -- ibid
  76         | MouseDown        Point                        -- ibid
  77         | MouseUp          Point                        -- ibid
  78         | MenuItem         String String                -- selected item from WinMenu with a given name
  79         | PromptResponse   String String String         -- response to WinPrompt request
  80         | FileContents     String String                -- response to FRead request
  81         deriving Show
  82
  83 type TinaStep s = s -> Response -> (s,[Request])
  84 data TinaProgram = forall s. Main
  85         { initialState    :: s
  86         , initialRequests :: [Request]
  87         , eventHandler    :: TinaStep s
  88         , windowWidth
  89         , windowHeight    :: Int
  90         }
  91
  92 testProg = Main
  93         { initialState    = 1
  94         , initialRequests = [GfxText red (pt 0 0) "foo", GfxText blue (pt 100 100) "bar"]
  95         , eventHandler    = \s e -> (s+1,[GfxText green (pt 50 50) $ show (s,e)])
  96         , windowWidth     = 200
  97         , windowHeight    = 200
  98         }
  99
 100 data IState = forall s. IS
 101         { window    :: Gtk.Window
 102         , postponed :: IORef [Request]
 103         , usrState  :: IORef s
 104         , usrProg   :: TinaStep s
 105         }
 106
 107 processPostponed :: IState -> IO ()
 108 processPostponed s@IS {..} = do
 109         ps <- readIORef postponed
 110         unless (null ps) $ do
 111                 writeIORef postponed (tail ps)
 112                 rs  <- handle s (head ps)
 113                 mapM (stepUserProgram s) rs
 114                 processPostponed s
 115
 116 post s r = stepUserProgram s r >> processPostponed s
 117
 118 stepUserProgram :: IState -> Response -> IO ()
 119 stepUserProgram IS {..} r = do
 120         state <- readIORef usrState
 121         let (state',reqs) = usrProg state r
 122         writeIORef usrState state'
 123         readIORef postponed >>= writeIORef postponed . (++ reqs)
 124
 125 handle :: IState -> Request -> IO [Response]
 126 handle s@IS {..} r = do
 127         resps <- maybe (fail $ "No handler for request " ++ show r) id $
 128                 fmap (>> return []) (gfxHandler s r <|> winHandler s r <|> miscHandler s r)
 129         return resps
 130
 131 runTina :: TinaProgram -> IO ()
 132 runTina Main {..} = do
 133         usrState  <- newIORef initialState
 134         postponed <- newIORef (GfxText (rgb 0 0 0) (pt 50 50) "foo" : GfxClear :initialRequests)
 135         let state = IS { window = undefined, usrProg = eventHandler, .. }
 136         runGUI windowWidth windowHeight state
 137
 138 runGUI :: Int -> Int -> IState -> IO ()
 139 runGUI w h s = do
 140         -- Init GTK.
 141         Gtk.initGUI
 142
 143         -- Create a window, which will make the mainloop terminated when
 144         -- it is closed.
 145         window <- Gtk.windowNew
 146
 147         Gtk.set window [ Gtk.containerBorderWidth := 10
 148                        , Gtk.windowTitle := "FP Practicum"
 149                        , Gtk.windowDefaultWidth := w
 150                        , Gtk.windowDefaultHeight := h
 151                        ]
 152         Gtk.onDestroy window Gtk.mainQuit
 153
 154         -- Add the window to the state
 155         let state = s { window = window }
 156
 157         -- Show the window and start the Gtk mainloop.
 158         Gtk.widgetShowAll window
 159         Gtk.mainGUI
 160
 161
 162 {-
 163 runGUI s IS {..} = do
 164         sFrame <- frame
 165                 [ text       := "FP Practicum"
 166                 , size       := s
 167                 ]
 168         buffer <- memoryDCCreate
 169         bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
 170         withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
 171         dcClear buffer
 172         buffer `set`
 173                 [ fontFace   := "Courier New"
 174                 , fontSize   := 10
 175                 , brushColor := rgb 0 0 0
 176                 , brushKind  := BrushSolid
 177                 , penColor   := rgb 0 0 0
 178                 , penKind    := PenSolid
 179                 ]
 180         sPanel <- panel sFrame [ size := s ]
 181         let state = IS {..}
 182         sPanel `set`
 183                 [ on paint       := onPaint state
 184                 , on doubleClick := post state . MouseDoubleClick
 185                 , on click       := post state . MouseDown
 186                 , on drag        := post state . MouseDragged
 187                 , on unclick     := post state . MouseUp
 188                 , on anyKey      := transKey (post state . KeyIn)
 189                 ]
 190         sFrame `set`
 191                 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
 192                 , on anyKey  := transKey (post state . KeyIn)
 193                 , layout     := widget sPanel
 194                 ]
 195         windowSetFocus sFrame
 196         processPostponed state
 197 onPaint :: IState -> DC a -> Rect -> IO ()
 198 onPaint IS {..} dest va = do
 199         dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
 200
 201 transKey :: (Char -> IO ()) -> Key -> IO ()
 202 transKey prod (KeyChar c) = prod c
 203 transKey prod  KeySpace   = prod ' '
 204 transKey prod  KeyEscape  = prod '\ESC'
 205 transKey prod  KeyReturn  = prod '\n'
 206 transKey prod  KeyTab     = prod '\t'
 207 transKey _ _ = return ()
 208
 209 -}
 210
 211 {-
 212 miscHandler s@IS {..} (FRead  fn     ) = Just $ readFile fn >>= post s . FileContents fn
 213 miscHandler   IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts
 214 miscHandler   IS {..} ReqQuit = Just $ putStrLn "Quiting" >> wxcAppExit
 215 -}
 216 miscHandler   IS {..} _ = Nothing
 217
 218 {-
 219 winHandler s@IS {..} (WinPrompt st1 st2 st3) = Just $ textDialog sFrame st1 st2 st3 >>= post s . PromptResponse st1 st2
 220 winHandler   IS {..} (WinTitle     st) = Just $ sFrame `set` [text := st]
 221 winHandler s@IS {..} (WinMenu      ms) = Just $ mkMenu >>= \ms' -> sFrame `set` [menuBar := ms']
 222         where
 223         mkMenu = sequence
 224                 [ do
 225                         p  <- menuPane [ text := name ]
 226                         sequence
 227                                 [ do
 228                                         i <- menuItem p [ text := item ]
 229                                         sFrame `set` [on (menu i) := post s (MenuItem name item)]
 230                                  | item <- items ]
 231                         return p
 232                  | (name,items) <- ms ]
 233 -}
 234 winHandler _        _                = Nothing
 235
 236 {-
 237 gfxHandler IS {..} (GfxLines     col ps)    = Just $ polyline buffer ps [penColor := col] >> dirtyPts sPanel ps
 238 gfxHandler IS {..} (GfxPolygon   col ps)    = Just $ polygon  buffer ps [penColor := col, brushColor := col] >> dirtyPts sPanel ps
 239 gfxHandler IS {..} (GfxText      col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy
 240 gfxHandler IS {..} (GfxRectangle col rt)    = Just $ drawRect buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
 241 gfxHandler IS {..} (GfxEllipse   col rt)    = Just $ ellipse buffer rt [penColor := col, brushKind := BrushTransparent] >> dirtyRect sPanel rt
 242 gfxHandler IS {..} (GfxDisc      col rt)    = Just $ ellipse buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
 243 gfxHandler IS {..} (GfxFont      st  sz)    = Just $ buffer `set` [ fontSize := sz, fontFace := st ]
 244 gfxHandler IS {..}  GfxClear                = Just $ dcClear buffer >> windowRefresh sPanel False
 245 gfxHandler IS {..} (GfxPicture   fd  pt)    = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt
 246 -}
 247 gfxHandler _        _                       = Nothing
 248
 249 {-
 250 dirtyPts :: Window a -> [Point] -> IO ()
 251 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
 252         where
 253         xs     = map pointX ps
 254         ys     = map pointY ps
 255         x      = minimum xs
 256         y      = minimum ys
 257         sizeW  = maximum xs - x
 258         sizeH  = maximum ys - y
 259
 260 dirtyRect' :: Window a -> Point -> Size -> IO ()
 261 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
 262
 263 dirtyRect :: Window a -> Rect -> IO ()
 264 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
 265
 266 rectanglify :: Point -> Size -> Rect
 267 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
 268
 269 grow :: Int -> Rect -> Rect
 270 grow n Rect {..} = Rect
 271         { rectLeft   = rectLeft   - n
 272         , rectTop    = rectTop    - n
 273         , rectWidth  = rectWidth  + 2 * n
 274         , rectHeight = rectHeight + 2 * n }
 275
 276 -}