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 type Color = Gtk.Color
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)
41 -- | Some predefined colours
45 white = rgb 0xff 0xff 0xff
47 -- | Helper functions for creating a Point
48 point, pt :: Int -> Int -> Point
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
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
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
83 type TinaStep s = s -> Response -> (s,[Request])
84 data TinaProgram = forall s. Main
86 , initialRequests :: [Request]
87 , eventHandler :: TinaStep s
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)])
100 data IState = forall s. IS
101 { window :: Gtk.Window
102 , buffer :: IORef Cairo.Surface
103 , postponed :: IORef [Request]
104 , usrState :: IORef s
105 , usrProg :: TinaStep s
108 processPostponed :: IState -> IO ()
109 processPostponed s@IS {..} = do
110 ps <- readIORef postponed
111 unless (null ps) $ do
112 writeIORef postponed (tail ps)
113 rs <- handle s (head ps)
114 mapM (stepUserProgram s) rs
117 post s r = stepUserProgram s r >> processPostponed s
119 stepUserProgram :: IState -> Response -> IO ()
120 stepUserProgram IS {..} r = do
121 state <- readIORef usrState
122 let (state',reqs) = usrProg state r
123 writeIORef usrState state'
124 readIORef postponed >>= writeIORef postponed . (++ reqs)
126 handle :: IState -> Request -> IO [Response]
127 handle s@IS {..} r = do
128 resps <- maybe (fail $ "No handler for request " ++ show r) id $
129 fmap (>> return []) (gfxHandler s r <|> winHandler s r <|> miscHandler s r)
132 runTina :: TinaProgram -> IO ()
133 runTina Main {..} = do
134 usrState <- newIORef initialState
135 postponed <- newIORef (GfxText (rgb 0 0 0) (pt 50 50) "foo" : GfxClear :initialRequests)
136 let state = IS { window = undefined, buffer = undefined, usrProg = eventHandler, .. }
137 runGUI windowWidth windowHeight state
139 runGUI :: Int -> Int -> IState -> IO ()
140 runGUI w h (IS { .. }) = do
144 -- Create a window, which will make the mainloop terminated when
146 window <- Gtk.windowNew
148 Gtk.set window [ Gtk.containerBorderWidth := 10
149 , Gtk.windowTitle := "FP Practicum"
150 , Gtk.windowDefaultWidth := w
151 , Gtk.windowDefaultHeight := h
153 Gtk.onDestroy window Gtk.mainQuit
155 -- Create a buffer to draw on (name the actual buffer buffer', so we
156 -- can use IS { .. } syntax below to pack the state. Using a record update
157 -- wouldn't work, probably because Cairo.Surface contains an existential
159 -- We put the buffer in an IORef, so we can change it for a new one
160 -- later on (on window resizes).
161 buffer' <- Cairo.createImageSurface Cairo.FormatARGB32 w h
162 buffer <- newIORef buffer'
164 -- Register the expose event
165 Gtk.on window Gtk.exposeEvent $ onExpose buffer
168 let state = IS { .. }
170 -- Process any initial requests
171 processPostponed state
173 -- Show the window and start the Gtk mainloop.
174 Gtk.widgetShowAll window
178 -- | Copy the given surface to the exposed window on an expose event.
179 onExpose :: IORef Cairo.Surface -> EventM.EventM EventM.EExpose Bool
181 current_buffer <- liftIO $ readIORef buffer
182 dw <- EventM.eventWindow
183 -- Copy the buffer to the window
184 liftIO $ Gtk.renderWithDrawable dw $ do
185 Cairo.setSourceSurface current_buffer 0 0
187 return True -- No clue what this means
190 runGUI s IS {..} = do
192 [ text := "FP Practicum"
195 buffer <- memoryDCCreate
196 bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
197 withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
200 [ fontFace := "Courier New"
202 , brushColor := rgb 0 0 0
203 , brushKind := BrushSolid
204 , penColor := rgb 0 0 0
205 , penKind := PenSolid
207 sPanel <- panel sFrame [ size := s ]
210 [ on paint := onPaint state
211 , on doubleClick := post state . MouseDoubleClick
212 , on click := post state . MouseDown
213 , on drag := post state . MouseDragged
214 , on unclick := post state . MouseUp
215 , on anyKey := transKey (post state . KeyIn)
218 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
219 , on anyKey := transKey (post state . KeyIn)
220 , layout := widget sPanel
222 windowSetFocus sFrame
223 processPostponed state
224 onPaint :: IState -> DC a -> Rect -> IO ()
225 onPaint IS {..} dest va = do
226 dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
228 transKey :: (Char -> IO ()) -> Key -> IO ()
229 transKey prod (KeyChar c) = prod c
230 transKey prod KeySpace = prod ' '
231 transKey prod KeyEscape = prod '\ESC'
232 transKey prod KeyReturn = prod '\n'
233 transKey prod KeyTab = prod '\t'
234 transKey _ _ = return ()
239 miscHandler s@IS {..} (FRead fn ) = Just $ readFile fn >>= post s . FileContents fn
240 miscHandler IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts
241 miscHandler IS {..} ReqQuit = Just $ putStrLn "Quiting" >> wxcAppExit
243 miscHandler IS {..} _ = Nothing
246 winHandler s@IS {..} (WinPrompt st1 st2 st3) = Just $ textDialog sFrame st1 st2 st3 >>= post s . PromptResponse st1 st2
247 winHandler IS {..} (WinTitle st) = Just $ sFrame `set` [text := st]
248 winHandler s@IS {..} (WinMenu ms) = Just $ mkMenu >>= \ms' -> sFrame `set` [menuBar := ms']
252 p <- menuPane [ text := name ]
255 i <- menuItem p [ text := item ]
256 sFrame `set` [on (menu i) := post s (MenuItem name item)]
259 | (name,items) <- ms ]
261 winHandler _ _ = Nothing
263 gfxHandler s req = case gfxHandler' s req of
265 Just render -> Just $ do
266 buf <- readIORef (buffer s)
267 Cairo.renderWith buf render
268 Gtk.widgetQueueDraw (window s)
271 gfxHandler IS {..} (GfxLines col ps) = Just $ polyline buffer ps [penColor := col] >> dirtyPts sPanel ps
272 gfxHandler IS {..} (GfxPolygon col ps) = Just $ polygon buffer ps [penColor := col, brushColor := col] >> dirtyPts sPanel ps
273 gfxHandler IS {..} (GfxText col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy
274 gfxHandler IS {..} (GfxRectangle col rt) = Just $ drawRect buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
275 gfxHandler IS {..} (GfxEllipse col rt) = Just $ ellipse buffer rt [penColor := col, brushKind := BrushTransparent] >> dirtyRect sPanel rt
276 gfxHandler IS {..} (GfxDisc col rt) = Just $ ellipse buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
277 gfxHandler IS {..} (GfxFont st sz) = Just $ buffer `set` [ fontSize := sz, fontFace := st ]
278 gfxHandler IS {..} (GfxPicture fd pt) = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt
280 gfxHandler' IS {..} GfxClear = Just $ Cairo.setSourceRGB 1 1 1 >> Cairo.paint
281 gfxHandler' _ _ = Nothing
284 dirtyPts :: Window a -> [Point] -> IO ()
285 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
291 sizeW = maximum xs - x
292 sizeH = maximum ys - y
294 dirtyRect' :: Window a -> Point -> Size -> IO ()
295 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
297 dirtyRect :: Window a -> Rect -> IO ()
298 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
300 rectanglify :: Point -> Size -> Rect
301 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
303 grow :: Int -> Rect -> Rect
304 grow n Rect {..} = Rect
305 { rectLeft = rectLeft - n
306 , rectTop = rectTop - n
307 , rectWidth = rectWidth + 2 * n
308 , rectHeight = rectHeight + 2 * n }