+{-# LANGUAGE RecordWildCards, ExistentialQuantification #-}
+module FPPrac (
+ module Graphics.UI.WXCore.WxcTypes,
+ Request(..),
+ Response(..),
+ TinaProgram(..),
+ runTina
+) where
+
+import Graphics.UI.WXCore.WxcTypes
+import Graphics.UI.WX hiding (empty)
+import Graphics.UI.WXCore hiding (empty)
+import Data.IORef
+import Control.Applicative
+import Control.Monad
+import Char
+import System.Exit
+
+data Request
+ = GfxLines Color [Point] -- coloured line through a list of points
+ | GfxPolygon Color [Point] -- filled polygon of given colour
+ | GfxPicture FilePath Point -- shows a picture
+ | GfxText Color Point String -- coloured string on position Point
+ | GfxRectangle Color Rect -- filled rectangle of given colour
+ | GfxEllipse Color Rect -- ellipse within given rectangle
+ | GfxDisc Color Rect -- filled ellipse within given rectangle
+ | GfxClear -- clears the graphical window
+ -- | GfxInstance Bool
+ | GfxFont String Int -- changes to fontname of given size
+ | WinPrompt String String String -- pops up a window with an edit field
+ -- | WinFilePrompt Bool
+ | WinMenu [(String,[String])] -- adds a menu list to the graphical window
+ | WinTitle String -- gives a title to the graphical window
+ | FRead String -- read file with a given name
+ | FWrite String String -- writes a text file with a given filename
+ | ReqQuit -- quits the graphical system
+ deriving Show
+
+data Response
+ = KeyIn Char -- touched key with given character
+ | MouseDoubleClick Point -- mouse event on position Point
+ | MouseDragged Point -- ibid
+ | MouseDown Point -- ibid
+ | MouseUp Point -- ibid
+ | MenuItem String String -- selected item from WinMenu with a given name
+ | PromptResponse String String String -- response to WinPrompt request
+ | FileContents String String -- response to FRead request
+ deriving Show
+
+type TinaStep s = s -> Response -> (s,[Request])
+data TinaProgram = forall s. Main
+ { initialState :: s
+ , initialRequests :: [Request]
+ , eventHandler :: TinaStep s
+ , windowWidth
+ , windowHeight :: Int
+ }
+
+testProg = Main
+ { initialState = 1
+ , initialRequests = [GfxText red (pt 0 0) "foo", GfxText blue (pt 100 100) "bar"]
+ , eventHandler = \s e -> (s+1,[GfxText green (pt 50 50) $ show (s,e)])
+ , windowWidth = 200
+ , windowHeight = 200
+ }
+
+data IState = forall s. IS
+ { sFrame :: Frame ()
+ , sPanel :: Panel ()
+ , buffer :: MemoryDC ()
+ , postponed :: IORef [Request]
+ , usrState :: IORef s
+ , usrProg :: TinaStep s
+ }
+
+dbgLog IS {..} s = do
+ return ()
+
+processPostponed :: IState -> IO ()
+processPostponed s@IS {..} = do
+ ps <- readIORef postponed
+ unless (null ps) $ do
+ writeIORef postponed (tail ps)
+ rs <- handle s (head ps)
+ mapM (stepUserProgram s) rs
+ processPostponed s
+
+post s r = stepUserProgram s r >> processPostponed s
+
+stepUserProgram :: IState -> Response -> IO ()
+stepUserProgram IS {..} r = do
+ state <- readIORef usrState
+ let (state',reqs) = usrProg state r
+ writeIORef usrState state'
+ readIORef postponed >>= writeIORef postponed . (++ reqs)
+
+handle :: IState -> Request -> IO [Response]
+handle s@IS {..} r = do
+ resps <- maybe (fail $ "No handler for request " ++ show r) id $
+ fmap (>> return []) (gfxHandler s r <|> winHandler s r <|> miscHandler s r)
+ return resps
+
+runTina :: TinaProgram -> IO ()
+runTina Main {..} = do
+ usrState <- newIORef initialState
+ postponed <- newIORef (GfxText (rgb 0 0 0) (pt 50 50) "foo" : GfxClear :initialRequests)
+ let state = IS { sFrame = undefined, sPanel = undefined, buffer = undefined, usrProg = eventHandler, .. }
+ run $ runGUI (sz windowWidth windowHeight) state
+ putStrLn "XX"
+ runGUI (sz windowWidth windowHeight) state
+
+runGUI :: Size -> IState -> IO ()
+runGUI s IS {..} = do
+ sFrame <- frame
+ [ text := "FP Practicum"
+ , size := s
+ ]
+ buffer <- memoryDCCreate
+ bitmapCreateEmpty s 24 >>= memoryDCSelectObject buffer
+ withBrushStyle (BrushStyle BrushSolid white) (dcSetBackground buffer)
+ dcClear buffer
+ buffer `set`
+ [ fontFace := "Courier New"
+ , fontSize := 10
+ , brushColor := rgb 0 0 0
+ , brushKind := BrushSolid
+ , penColor := rgb 0 0 0
+ , penKind := PenSolid
+ ]
+ sPanel <- panel sFrame [ size := s ]
+ let state = IS {..}
+ sPanel `set`
+ [ on paint := onPaint state
+ , on doubleClick := post state . MouseDoubleClick
+ , on click := post state . MouseDown
+ , on drag := post state . MouseDragged
+ , on unclick := post state . MouseUp
+ , on anyKey := transKey (post state . KeyIn)
+ ]
+ sFrame `set`
+ [ on closing := sFrame `set` [ visible := False ] >> wxcAppExit
+ , on anyKey := transKey (post state . KeyIn)
+ , layout := widget sPanel
+ ]
+ windowSetFocus sFrame
+ processPostponed state
+
+onPaint :: IState -> DC a -> Rect -> IO ()
+onPaint IS {..} dest va = do
+ dcBlit dest va buffer (Point 0 0) wxCOPY False >> return ()
+
+transKey :: (Char -> IO ()) -> Key -> IO ()
+transKey prod (KeyChar c) = prod c
+transKey prod KeySpace = prod ' '
+transKey prod KeyEscape = prod '\ESC'
+transKey prod KeyReturn = prod '\n'
+transKey prod KeyTab = prod '\t'
+transKey _ _ = return ()
+
+
+
+
+miscHandler s@IS {..} (FRead fn ) = Just $ readFile fn >>= post s . FileContents fn
+miscHandler IS {..} (FWrite fn cnts) = Just $ writeFile fn cnts
+miscHandler IS {..} ReqQuit = Just $ putStrLn "Quiting" >> wxcAppExit
+miscHandler IS {..} _ = Nothing
+
+winHandler s@IS {..} (WinPrompt st1 st2 st3) = Just $ textDialog sFrame st1 st2 st3 >>= post s . PromptResponse st1 st2
+winHandler IS {..} (WinTitle st) = Just $ sFrame `set` [text := st]
+winHandler s@IS {..} (WinMenu ms) = Just $ mkMenu >>= \ms' -> sFrame `set` [menuBar := ms']
+ where
+ mkMenu = sequence
+ [ do
+ p <- menuPane [ text := name ]
+ sequence
+ [ do
+ i <- menuItem p [ text := item ]
+ sFrame `set` [on (menu i) := post s (MenuItem name item)]
+ | item <- items ]
+ return p
+ | (name,items) <- ms ]
+winHandler _ _ = Nothing
+
+gfxHandler IS {..} (GfxLines col ps) = Just $ polyline buffer ps [penColor := col] >> dirtyPts sPanel ps
+gfxHandler IS {..} (GfxPolygon col ps) = Just $ polygon buffer ps [penColor := col, brushColor := col] >> dirtyPts sPanel ps
+gfxHandler IS {..} (GfxText col xy st) = Just $ drawText buffer st xy [textColor := col] >> getTextExtent buffer st >>= dirtyRect' sPanel xy
+gfxHandler IS {..} (GfxRectangle col rt) = Just $ drawRect buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
+gfxHandler IS {..} (GfxEllipse col rt) = Just $ ellipse buffer rt [penColor := col, brushKind := BrushTransparent] >> dirtyRect sPanel rt
+gfxHandler IS {..} (GfxDisc col rt) = Just $ ellipse buffer rt [penColor := col, brushColor := col] >> dirtyRect sPanel rt
+gfxHandler IS {..} (GfxFont st sz) = Just $ buffer `set` [ fontSize := sz, fontFace := st ]
+gfxHandler IS {..} GfxClear = Just $ dcClear buffer >> windowRefresh sPanel False
+gfxHandler IS {..} (GfxPicture fd pt) = Just $ bitmapCreateFromFile fd >>= \bm -> drawBitmap buffer bm pt False [] >> bitmapGetSize bm >>= dirtyRect' sPanel pt
+gfxHandler _ _ = Nothing
+
+dirtyPts :: Window a -> [Point] -> IO ()
+dirtyPts dc ps = dirtyRect' dc (pt x y) Size {..}
+ where
+ xs = map pointX ps
+ ys = map pointY ps
+ x = minimum xs
+ y = minimum ys
+ sizeW = maximum xs - x
+ sizeH = maximum ys - y
+
+dirtyRect' :: Window a -> Point -> Size -> IO ()
+dirtyRect' dc Point {..} Size {..} = dirtyRect dc $ Rect pointX pointY sizeW sizeH
+
+dirtyRect :: Window a -> Rect -> IO ()
+dirtyRect dc rect = windowRefreshRect dc False (grow 2 rect)
+
+rectanglify :: Point -> Size -> Rect
+rectanglify Point {..} Size {..} = Rect pointX pointY sizeW sizeH
+
+grow :: Int -> Rect -> Rect
+grow n Rect {..} = Rect
+ { rectLeft = rectLeft - n
+ , rectTop = rectTop - n
+ , rectWidth = rectWidth + 2 * n
+ , rectHeight = rectHeight + 2 * n }
+
+