Make testProg produce readable (non-overlapping) output.
[matthijs/projects/fpprac.git] / 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 + 10 * s)) $ 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         -- Repack state
166         let state = IS { .. }
167         
168         -- Register events
169         Gtk.on window Gtk.exposeEvent $ onExpose buffer
170         Gtk.on window Gtk.configureEvent $ onResize buffer
171         Gtk.on window Gtk.keyPressEvent $ onKeyDown state
172
173         -- Process any initial requests
174         processPostponed state
175
176         -- Show the window and start the Gtk mainloop.
177         Gtk.widgetShowAll window
178         Gtk.mainGUI
179
180 -- | Called when a key is pressed.
181 onKeyDown :: IState -> EventM.EventM EventM.EKey Bool
182 onKeyDown s = do
183         keyval <- EventM.eventKeyVal
184         case Gtk.keyToChar keyval of
185                 Just c -> liftIO $ post s (KeyIn c)
186                 Nothing -> return ()
187         return True -- No clue what this means
188
189 -- | Called when (part of) the window should be redrawn. Copy the given surface
190 --   to the exposed window on an expose event.
191 onExpose :: IORef Cairo.Surface -> EventM.EventM EventM.EExpose Bool
192 onExpose buffer = do
193         current_buffer <- liftIO $ readIORef buffer
194         dw <- EventM.eventWindow
195         -- Copy the buffer to the window
196         liftIO $ Gtk.renderWithDrawable dw $ do
197                 Cairo.setSourceSurface current_buffer 0 0
198                 Cairo.paint
199         return True -- No clue what this means
200
201 -- | Called when the window is resized. Resize the given buffer if needed.
202 onResize :: IORef Cairo.Surface -> EventM.EventM EventM.EConfigure Bool
203 onResize buffer = do
204         -- Get the current buffer and see if it's still big enough
205         current_buffer <- liftIO $ readIORef buffer
206         sw <- Cairo.imageSurfaceGetWidth current_buffer
207         sh <- Cairo.imageSurfaceGetHeight current_buffer
208         -- Get the current drawwindow and its size
209         dw <- EventM.eventWindow
210         (w, h) <- liftIO $ Gtk.drawableGetSize dw
211         when (w > sw || h > sh) $ liftIO $ do
212                 -- Buffer is too small, expand it.
213                 new_buffer <- Cairo.createImageSurface Cairo.FormatARGB32 w h
214                 -- Fill it with white and copy the old buffer
215                 Cairo.renderWith new_buffer $ do
216                         Cairo.setSourceRGB 1 1 1
217                         Cairo.paint
218                         Cairo.setSourceSurface current_buffer 0 0
219                         Cairo.paint
220                 -- Clean up the old buffer
221                 Cairo.surfaceFinish current_buffer
222                 -- Store and return the new buffer
223                 writeIORef buffer new_buffer
224         return True -- No clue what this means
225                                 
226
227 {-
228 runGUI s IS {..} = do
229         sFrame <- frame
230                 [ text       := "FP Practicum"
231                 , size       := s
232                 ]
233         buffer <- memoryDCCreate
234         bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
235         withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
236         dcClear buffer
237         buffer `set`
238                 [ fontFace   := "Courier New"
239                 , fontSize   := 10
240                 , brushColor := rgb 0 0 0
241                 , brushKind  := BrushSolid
242                 , penColor   := rgb 0 0 0
243                 , penKind    := PenSolid
244                 ]
245         sPanel <- panel sFrame [ size := s ]
246         let state = IS {..}
247         sPanel `set`
248                 [ on paint       := onPaint state
249                 , on doubleClick := post state . MouseDoubleClick
250                 , on click       := post state . MouseDown
251                 , on drag        := post state . MouseDragged
252                 , on unclick     := post state . MouseUp
253                 , on anyKey      := transKey (post state . KeyIn)
254                 ]
255         sFrame `set`
256                 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
257                 , on anyKey  := transKey (post state . KeyIn)
258                 , layout     := widget sPanel
259                 ]
260         windowSetFocus sFrame
261         processPostponed state
262 onPaint :: IState -> DC a -> Rect -> IO ()
263 onPaint IS {..} dest va = do
264         dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
265
266 transKey :: (Char -> IO ()) -> Key -> IO ()
267 transKey prod (KeyChar c) = prod c
268 transKey prod  KeySpace   = prod ' '
269 transKey prod  KeyEscape  = prod '\ESC'
270 transKey prod  KeyReturn  = prod '\n'
271 transKey prod  KeyTab     = prod '\t'
272 transKey _ _ = return ()
273
274 -}
275
276 -- | Handlers for various requests.
277 miscHandler, winHandler, gfxHandler :: IState -> Request -> Maybe (IO ())
278 {-
279 miscHandler s@IS {..} (FRead  fn     ) = Just $ readFile fn >>= post s . FileContents fn
280 miscHandler   IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts
281 miscHandler   IS {..} ReqQuit = Just $ putStrLn "Quiting" >> wxcAppExit
282 -}
283 miscHandler   IS {..} _ = Nothing
284
285 {-
286 winHandler s@IS {..} (WinPrompt st1 st2 st3) = Just $ textDialog sFrame st1 st2 st3 >>= post s . PromptResponse st1 st2
287 winHandler   IS {..} (WinTitle     st) = Just $ sFrame `set` [text := st]
288 winHandler s@IS {..} (WinMenu      ms) = Just $ mkMenu >>= \ms' -> sFrame `set` [menuBar := ms']
289         where
290         mkMenu = sequence
291                 [ do
292                         p  <- menuPane [ text := name ]
293                         sequence
294                                 [ do
295                                         i <- menuItem p [ text := item ]
296                                         sFrame `set` [on (menu i) := post s (MenuItem name item)]
297                                  | item <- items ]
298                         return p
299                  | (name,items) <- ms ]
300 -}
301 winHandler _        _                = Nothing
302
303 gfxHandler s req = case gfxHandler' req of
304         Nothing -> Nothing
305         Just render -> Just $ do
306                 buf <- readIORef (buffer s)
307                 Cairo.renderWith buf render
308                 Gtk.widgetQueueDraw (window s)
309                 
310 {-
311 gfxHandler IS {..} (GfxLines     col ps)    = Just $ polyline buffer ps [penColor := col] >> dirtyPts sPanel ps
312 gfxHandler IS {..} (GfxPolygon   col ps)    = Just $ polygon  buffer ps [penColor := col, brushColor := col] >> dirtyPts sPanel ps
313 gfxHandler IS {..} (GfxText      col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy
314 gfxHandler IS {..} (GfxRectangle col rt)    = Just $ drawRect buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
315 gfxHandler IS {..} (GfxEllipse   col rt)    = Just $ ellipse buffer rt [penColor := col, brushKind := BrushTransparent] >> dirtyRect sPanel rt
316 gfxHandler IS {..} (GfxDisc      col rt)    = Just $ ellipse buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
317 gfxHandler IS {..} (GfxFont      st  sz)    = Just $ buffer `set` [ fontSize := sz, fontFace := st ]
318 gfxHandler IS {..} (GfxPicture   fd  pt)    = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt
319 -}
320 -- | Helper function for gfxHanlder
321 gfxHandler' :: Request -> Maybe (Cairo.Render ())
322 gfxHandler' (GfxText col (Point x y) st) = Just $ do
323         -- Set the source color, move to the requested position and draw the
324         -- text
325         setSourceColor col
326         Cairo.moveTo (fromIntegral x) (fromIntegral y)
327         Cairo.showText st 
328 gfxHandler' GfxClear = Just $ do
329         -- Set the source to white and paint the entire surface with it
330         Cairo.setSourceRGB 1 1 1
331         Cairo.paint
332 gfxHandler' _ = Nothing
333
334 -- | Sets the source to a pattern fill of the given color
335 setSourceColor :: Color -> Cairo.Render ()
336 setSourceColor (Color r g b) =
337         Cairo.setSourceRGB r g b
338
339 {-
340 dirtyPts :: Window a -> [Point] -> IO ()
341 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
342         where
343         xs     = map pointX ps
344         ys     = map pointY ps
345         x      = minimum xs
346         y      = minimum ys
347         sizeW  = maximum xs - x
348         sizeH  = maximum ys - y
349
350 dirtyRect' :: Window a -> Point -> Size -> IO ()
351 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
352
353 dirtyRect :: Window a -> Rect -> IO ()
354 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
355
356 rectanglify :: Point -> Size -> Rect
357 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
358
359 grow :: Int -> Rect -> Rect
360 grow n Rect {..} = Rect
361         { rectLeft   = rectLeft   - n
362         , rectTop    = rectTop    - n
363         , rectWidth  = rectWidth  + 2 * n
364         , rectHeight = rectHeight + 2 * n }
365
366 -}