61fd9ef9b183f630a1ead0f1a7611880c950aeac
[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 Data.IORef
13 import Control.Applicative
14 import Control.Monad
15 import Char
16 import System.Exit
17
18 -- | A rectangle in two dimensional space
19 data Rect = Rect 
20         { rectLeft :: !Int
21         , rectTop :: !Int
22         , rectWidth :: !Int
23         , rectHeight :: !Int
24 } deriving (Show, Eq)
25
26 data Point = Point !Int !Int deriving (Show, Eq)
27
28 type Color = Gtk.Color
29
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)
35
36 -- | Some predefined colours
37 red = rgb 0xff 0 0
38 green = rgb 0 0xff 0
39 blue = rgb 0 0 0xff
40 white = rgb 0xff 0xff 0xff
41
42 -- | Helper functions for creating a Point
43 point, pt :: Int -> Int -> Point
44 point = Point
45 pt = Point
46
47 runTina :: TinaProgram -> IO ()
48 runTina p = return ()
49
50 data Request
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
59         -- | GfxInstance   Bool
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
68         deriving Show
69
70 data Response
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
79         deriving Show
80
81 type TinaStep s = s -> Response -> (s,[Request])
82 data TinaProgram = forall s. Main
83         { initialState    :: s
84         , initialRequests :: [Request]
85         , eventHandler    :: TinaStep s
86         , windowWidth
87         , windowHeight    :: Int
88         }
89
90 testProg = Main
91         { initialState    = 1
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)])
94         , windowWidth     = 200
95         , windowHeight    = 200
96         }
97
98 data IState = forall s. IS
99         { {-sFrame    :: Frame    ()
100         , sPanel    :: Panel    ()
101         , buffer    :: MemoryDC ()
102         , -}postponed :: IORef [Request]
103         , usrState  :: IORef s
104         , usrProg   :: TinaStep s
105         }
106 {-
107 dbgLog IS {..} s = do
108         return ()
109
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
117                 processPostponed s
118
119 post s r = stepUserProgram s r >> processPostponed s
120
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)
127
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)
132         return resps
133
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
140         putStrLn "XX"
141         runGUI (sz windowWidth windowHeight) state
142
143 runGUI :: Size -> IState -> IO ()
144 runGUI s IS {..} = do
145         sFrame <- frame
146                 [ text       := "FP Practicum"
147                 , size       := s
148                 ]
149         buffer <- memoryDCCreate
150         bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
151         withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
152         dcClear buffer
153         buffer `set`
154                 [ fontFace   := "Courier New"
155                 , fontSize   := 10
156                 , brushColor := rgb 0 0 0
157                 , brushKind  := BrushSolid
158                 , penColor   := rgb 0 0 0
159                 , penKind    := PenSolid
160                 ]
161         sPanel <- panel sFrame [ size := s ]
162         let state = IS {..}
163         sPanel `set`
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)
170                 ]
171         sFrame `set`
172                 [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
173                 , on anyKey  := transKey (post state . KeyIn)
174                 , layout     := widget sPanel
175                 ]
176         windowSetFocus sFrame
177         processPostponed state
178
179 onPaint :: IState -> DC a -> Rect -> IO ()
180 onPaint IS {..} dest va = do
181         dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
182
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 ()
190
191
192
193
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
198
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']
202         where
203         mkMenu = sequence
204                 [ do
205                         p  <- menuPane [ text := name ]
206                         sequence
207                                 [ do
208                                         i <- menuItem p [ text := item ]
209                                         sFrame `set` [on (menu i) := post s (MenuItem name item)]
210                                  | item <- items ]
211                         return p
212                  | (name,items) <- ms ]
213 winHandler _        _                = Nothing
214
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
225
226 dirtyPts :: Window a -> [Point] -> IO ()
227 dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
228         where
229         xs     = map pointX ps
230         ys     = map pointY ps
231         x      = minimum xs
232         y      = minimum ys
233         sizeW  = maximum xs - x
234         sizeH  = maximum ys - y
235
236 dirtyRect' :: Window a -> Point -> Size -> IO ()
237 dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
238
239 dirtyRect :: Window a -> Rect -> IO ()
240 dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
241
242 rectanglify :: Point -> Size -> Rect
243 rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
244
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 }
251
252 -}