1 {-# LANGUAGE RecordWildCards, ExistentialQuantification #-}
6 Color, Rect(..), Point(..),
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
16 import Control.Monad.Trans -- for liftIO
18 import Control.Applicative
23 -- | A rectangle in two dimensional space
31 data Point = Point !Int !Int deriving (Show, Eq)
33 -- A color, with RGB values from 0 to 1
34 data Color = Color Double Double Double deriving (Show, Eq)
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
42 -- | Some predefined colours
46 white = rgb 0xff 0xff 0xff
48 -- | Helper functions for creating a Point
49 point, pt :: Int -> Int -> Point
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
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
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
84 type TinaStep s = s -> Response -> (s,[Request])
85 data TinaProgram = forall s. Main
87 , initialRequests :: [Request]
88 , eventHandler :: TinaStep s
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)])
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
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
118 post s r = stepUserProgram s r >> processPostponed s
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)
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)
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
140 runGUI :: Int -> Int -> IState -> IO ()
141 runGUI w h (IS { .. }) = do
145 -- Create a window, which will make the mainloop terminated when
147 window <- Gtk.windowNew
149 Gtk.set window [ Gtk.containerBorderWidth := 10
150 , Gtk.windowTitle := "FP Practicum"
151 , Gtk.windowDefaultWidth := w
152 , Gtk.windowDefaultHeight := h
154 Gtk.onDestroy window Gtk.mainQuit
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
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'
166 let state = IS { .. }
169 Gtk.on window Gtk.exposeEvent $ onExpose buffer
170 Gtk.on window Gtk.configureEvent $ onResize buffer
171 Gtk.on window Gtk.keyPressEvent $ onKeyDown state
173 -- Process any initial requests
174 processPostponed state
176 -- Show the window and start the Gtk mainloop.
177 Gtk.widgetShowAll window
180 -- | Called when a key is pressed.
181 onKeyDown :: IState -> EventM.EventM EventM.EKey Bool
183 keyval <- EventM.eventKeyVal
184 case Gtk.keyToChar keyval of
185 Just c -> liftIO $ post s (KeyIn c)
187 return True -- No clue what this means
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
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
199 return True -- No clue what this means
201 -- | Called when the window is resized. Resize the given buffer if needed.
202 onResize :: IORef Cairo.Surface -> EventM.EventM EventM.EConfigure Bool
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
218 Cairo.setSourceSurface current_buffer 0 0
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
228 runGUI s IS {..} = do
230 [ text := "FP Practicum"
233 buffer <- memoryDCCreate
234 bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
235 withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
238 [ fontFace := "Courier New"
240 , brushColor := rgb 0 0 0
241 , brushKind := BrushSolid
242 , penColor := rgb 0 0 0
243 , penKind := PenSolid
245 sPanel <- panel sFrame [ size := s ]
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)
256 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
257 , on anyKey := transKey (post state . KeyIn)
258 , layout := widget sPanel
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 ()
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 ()
276 -- | Handlers for various requests.
277 miscHandler, winHandler, gfxHandler :: IState -> Request -> Maybe (IO ())
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
283 miscHandler IS {..} _ = Nothing
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']
292 p <- menuPane [ text := name ]
295 i <- menuItem p [ text := item ]
296 sFrame `set` [on (menu i) := post s (MenuItem name item)]
299 | (name,items) <- ms ]
301 winHandler _ _ = Nothing
303 gfxHandler s req = case gfxHandler' req of
305 Just render -> Just $ do
306 buf <- readIORef (buffer s)
307 Cairo.renderWith buf render
308 Gtk.widgetQueueDraw (window s)
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
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
326 Cairo.moveTo (fromIntegral x) (fromIntegral y)
328 gfxHandler' GfxClear = Just $ do
329 -- Set the source to white and paint the entire surface with it
330 Cairo.setSourceRGB 1 1 1
332 gfxHandler' _ = Nothing
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
340 dirtyPts :: Window a -> [Point] -> IO ()
341 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
347 sizeW = maximum xs - x
348 sizeH = maximum ys - y
350 dirtyRect' :: Window a -> Point -> Size -> IO ()
351 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
353 dirtyRect :: Window a -> Rect -> IO ()
354 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
356 rectanglify :: Point -> Size -> Rect
357 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
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 }