1 {-# LANGUAGE RecordWildCards, ExistentialQuantification #-}
3 module Graphics.UI.WXCore.WxcTypes,
10 import Graphics.UI.WXCore.WxcTypes
11 import Graphics.UI.WX hiding (empty)
12 import Graphics.UI.WXCore hiding (empty)
14 import Control.Applicative
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
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
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
50 type TinaStep s = s -> Response -> (s,[Request])
51 data TinaProgram = forall s. Main
53 , initialRequests :: [Request]
54 , eventHandler :: TinaStep s
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)])
67 data IState = forall s. IS
70 , buffer :: MemoryDC ()
71 , postponed :: IORef [Request]
73 , usrProg :: TinaStep s
79 processPostponed :: IState -> IO ()
80 processPostponed s@IS {..} = do
81 ps <- readIORef postponed
83 writeIORef postponed (tail ps)
84 rs <- handle s (head ps)
85 mapM (stepUserProgram s) rs
88 post s r = stepUserProgram s r >> processPostponed s
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)
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)
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
110 runGUI (sz windowWidth windowHeight) state
112 runGUI :: Size -> IState -> IO ()
113 runGUI s IS {..} = do
115 [ text := "FP Practicum"
118 buffer <- memoryDCCreate
119 bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
120 withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
123 [ fontFace := "Courier New"
125 , brushColor := rgb 0 0 0
126 , brushKind := BrushSolid
127 , penColor := rgb 0 0 0
128 , penKind := PenSolid
130 sPanel <- panel sFrame [ size := s ]
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)
141 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
142 , on anyKey := transKey (post state . KeyIn)
143 , layout := widget sPanel
145 windowSetFocus sFrame
146 processPostponed state
148 onPaint :: IState -> DC a -> Rect -> IO ()
149 onPaint IS {..} dest va = do
150 dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
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 ()
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
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']
174 p <- menuPane [ text := name ]
177 i <- menuItem p [ text := item ]
178 sFrame `set` [on (menu i) := post s (MenuItem name item)]
181 | (name,items) <- ms ]
182 winHandler _ _ = Nothing
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
195 dirtyPts :: Window a -> [Point] -> IO ()
196 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
202 sizeW = maximum xs - x
203 sizeH = maximum ys - y
205 dirtyRect' :: Window a -> Point -> Size -> IO ()
206 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
208 dirtyRect :: Window a -> Rect -> IO ()
209 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
211 rectanglify :: Point -> Size -> Rect
212 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
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 }