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