1 {-# LANGUAGE RecordWildCards, ExistentialQuantification #-}
6 Color, Rect(..), Point(..),
11 import qualified Graphics.UI.Gtk as Gtk
13 import Control.Applicative
18 -- | A rectangle in two dimensional space
26 data Point = Point !Int !Int deriving (Show, Eq)
28 type Color = Gtk.Color
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)
36 -- | Some predefined colours
40 white = rgb 0xff 0xff 0xff
42 -- | Helper functions for creating a Point
43 point, pt :: Int -> Int -> Point
47 runTina :: TinaProgram -> IO ()
51 = GfxLines Color [Point] -- coloured line through a list of points
52 | GfxPolygon Color [Point] -- filled polygon of given colour
53 | GfxPicture FilePath Point -- shows a picture
54 | GfxText Color Point String -- coloured string on position Point
55 | GfxRectangle Color Rect -- filled rectangle of given colour
56 | GfxEllipse Color Rect -- ellipse within given rectangle
57 | GfxDisc Color Rect -- filled ellipse within given rectangle
58 | GfxClear -- clears the graphical window
60 | GfxFont String Int -- changes to fontname of given size
61 | WinPrompt String String String -- pops up a window with an edit field
62 -- | WinFilePrompt Bool
63 | WinMenu [(String,[String])] -- adds a menu list to the graphical window
64 | WinTitle String -- gives a title to the graphical window
65 | FRead String -- read file with a given name
66 | FWrite String String -- writes a text file with a given filename
67 | ReqQuit -- quits the graphical system
71 = KeyIn Char -- touched key with given character
72 | MouseDoubleClick Point -- mouse event on position Point
73 | MouseDragged Point -- ibid
74 | MouseDown Point -- ibid
75 | MouseUp Point -- ibid
76 | MenuItem String String -- selected item from WinMenu with a given name
77 | PromptResponse String String String -- response to WinPrompt request
78 | FileContents String String -- response to FRead request
81 type TinaStep s = s -> Response -> (s,[Request])
82 data TinaProgram = forall s. Main
84 , initialRequests :: [Request]
85 , eventHandler :: TinaStep s
92 , initialRequests = [GfxText red (pt 0 0) "foo", GfxText blue (pt 100 100) "bar"]
93 , eventHandler = \s e -> (s+1,[GfxText green (pt 50 50) $ show (s,e)])
98 data IState = forall s. IS
99 { {-sFrame :: Frame ()
101 , buffer :: MemoryDC ()
102 , -}postponed :: IORef [Request]
103 , usrState :: IORef s
104 , usrProg :: TinaStep s
107 dbgLog IS {..} s = do
110 processPostponed :: IState -> IO ()
111 processPostponed s@IS {..} = do
112 ps <- readIORef postponed
113 unless (null ps) $ do
114 writeIORef postponed (tail ps)
115 rs <- handle s (head ps)
116 mapM (stepUserProgram s) rs
119 post s r = stepUserProgram s r >> processPostponed s
121 stepUserProgram :: IState -> Response -> IO ()
122 stepUserProgram IS {..} r = do
123 state <- readIORef usrState
124 let (state',reqs) = usrProg state r
125 writeIORef usrState state'
126 readIORef postponed >>= writeIORef postponed . (++ reqs)
128 handle :: IState -> Request -> IO [Response]
129 handle s@IS {..} r = do
130 resps <- maybe (fail $ "No handler for request " ++ show r) id $
131 fmap (>> return []) (gfxHandler s r <|> winHandler s r <|> miscHandler s r)
134 runTina :: TinaProgram -> IO ()
135 runTina Main {..} = do
136 usrState <- newIORef initialState
137 postponed <- newIORef (GfxText (rgb 0 0 0) (pt 50 50) "foo" : GfxClear :initialRequests)
138 let state = IS { sFrame = undefined, sPanel = undefined, buffer = undefined, usrProg = eventHandler, .. }
139 run $ runGUI (sz windowWidth windowHeight) state
141 runGUI (sz windowWidth windowHeight) state
143 runGUI :: Size -> IState -> IO ()
144 runGUI s IS {..} = do
146 [ text := "FP Practicum"
149 buffer <- memoryDCCreate
150 bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
151 withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
154 [ fontFace := "Courier New"
156 , brushColor := rgb 0 0 0
157 , brushKind := BrushSolid
158 , penColor := rgb 0 0 0
159 , penKind := PenSolid
161 sPanel <- panel sFrame [ size := s ]
164 [ on paint := onPaint state
165 , on doubleClick := post state . MouseDoubleClick
166 , on click := post state . MouseDown
167 , on drag := post state . MouseDragged
168 , on unclick := post state . MouseUp
169 , on anyKey := transKey (post state . KeyIn)
172 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
173 , on anyKey := transKey (post state . KeyIn)
174 , layout := widget sPanel
176 windowSetFocus sFrame
177 processPostponed state
179 onPaint :: IState -> DC a -> Rect -> IO ()
180 onPaint IS {..} dest va = do
181 dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
183 transKey :: (Char -> IO ()) -> Key -> IO ()
184 transKey prod (KeyChar c) = prod c
185 transKey prod KeySpace = prod ' '
186 transKey prod KeyEscape = prod '\ESC'
187 transKey prod KeyReturn = prod '\n'
188 transKey prod KeyTab = prod '\t'
189 transKey _ _ = return ()
194 miscHandler s@IS {..} (FRead fn ) = Just $ readFile fn >>= post s . FileContents fn
195 miscHandler IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts
196 miscHandler IS {..} ReqQuit = Just $ putStrLn "Quiting" >> wxcAppExit
197 miscHandler IS {..} _ = Nothing
199 winHandler s@IS {..} (WinPrompt st1 st2 st3) = Just $ textDialog sFrame st1 st2 st3 >>= post s . PromptResponse st1 st2
200 winHandler IS {..} (WinTitle st) = Just $ sFrame `set` [text := st]
201 winHandler s@IS {..} (WinMenu ms) = Just $ mkMenu >>= \ms' -> sFrame `set` [menuBar := ms']
205 p <- menuPane [ text := name ]
208 i <- menuItem p [ text := item ]
209 sFrame `set` [on (menu i) := post s (MenuItem name item)]
212 | (name,items) <- ms ]
213 winHandler _ _ = Nothing
215 gfxHandler IS {..} (GfxLines col ps) = Just $ polyline buffer ps [penColor := col] >> dirtyPts sPanel ps
216 gfxHandler IS {..} (GfxPolygon col ps) = Just $ polygon buffer ps [penColor := col, brushColor := col] >> dirtyPts sPanel ps
217 gfxHandler IS {..} (GfxText col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy
218 gfxHandler IS {..} (GfxRectangle col rt) = Just $ drawRect buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
219 gfxHandler IS {..} (GfxEllipse col rt) = Just $ ellipse buffer rt [penColor := col, brushKind := BrushTransparent] >> dirtyRect sPanel rt
220 gfxHandler IS {..} (GfxDisc col rt) = Just $ ellipse buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
221 gfxHandler IS {..} (GfxFont st sz) = Just $ buffer `set` [ fontSize := sz, fontFace := st ]
222 gfxHandler IS {..} GfxClear = Just $ dcClear buffer >> windowRefresh sPanel False
223 gfxHandler IS {..} (GfxPicture fd pt) = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt
224 gfxHandler _ _ = Nothing
226 dirtyPts :: Window a -> [Point] -> IO ()
227 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
233 sizeW = maximum xs - x
234 sizeH = maximum ys - y
236 dirtyRect' :: Window a -> Point -> Size -> IO ()
237 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
239 dirtyRect :: Window a -> Rect -> IO ()
240 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
242 rectanglify :: Point -> Size -> Rect
243 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
245 grow :: Int -> Rect -> Rect
246 grow n Rect {..} = Rect
247 { rectLeft = rectLeft - n
248 , rectTop = rectTop - n
249 , rectWidth = rectWidth + 2 * n
250 , rectHeight = rectHeight + 2 * n }