Add FPPrac module from Teletop.

diff --git a/FPPrac.hs b/FPPrac.hs
new file mode 100644 (file)
index 0000000..628962b
--- /dev/null
+++ b/FPPrac.hs
@@ -0,0 +1,221 @@
+{-# 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 }
+
+