FPPrac.hs

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