From ae1ef2b0b9dbb48141e140945152f39910c1a91a Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Sun, 23 Aug 2009 15:24:56 +0200 Subject: [PATCH] Add FPPrac module from Teletop. --- FPPrac.hs | 221 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 221 insertions(+) create mode 100644 FPPrac.hs diff --git a/FPPrac.hs b/FPPrac.hs new file mode 100644 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 } + + -- 2.30.2