Added grid and some basic keyboard handling
Getty Ritter
7 years ago
| 1 | {-# LANGUAGE LambdaCase #-} | |
| 2 | ||
| 1 | 3 | module Main where |
| 2 | 4 | |
| 3 | 5 | import qualified Data.ByteString.Lazy as BS |
| 4 | 6 | import Data.IORef |
| 5 | 7 | import Graphics.UI.Gtk.Cairo |
| 6 | import Graphics.UI.Gtk hiding (eventButton) | |
| 7 | import Graphics.UI.Gtk.Gdk.Events(eventX,eventY,eventButton) | |
| 8 | import Graphics.UI.Gtk hiding (eventButton, eventKeyVal) | |
| 9 | import Graphics.UI.Gtk.Gdk.Events(Event(..),eventX,eventY,eventButton) | |
| 8 | 10 | import qualified Graphics.Rendering.Cairo as C |
| 9 | 11 | import qualified Image.VK as VK |
| 10 | 12 | |
| 42 | 44 | render d state = do |
| 43 | 45 | dw <- widgetGetDrawWindow d |
| 44 | 46 | (w, h) <- drawableGetSize dw |
| 47 | region <- regionRectangle (Rectangle 0 0 w h) | |
| 48 | drawWindowBeginPaintRegion dw region | |
| 45 | 49 | renderWithDrawable dw $ do |
| 46 | 50 | C.setSourceRGB 1.0 1.0 1.0 |
| 47 | 51 | C.rectangle 0 0 (fromIntegral w) (fromIntegral h) |
| 48 | 52 | C.fill |
| 53 | case apGrid state of | |
| 54 | Nothing -> return () | |
| 55 | Just (xW, yW) -> do | |
| 56 | C.setSourceRGB 0.8 0.8 0.8 | |
| 57 | C.setLineWidth 2 | |
| 58 | C.setLineCap C.LineCapRound | |
| 59 | sequence_ [ dot (fromIntegral (x * xW)) (fromIntegral (y * yW)) | |
| 60 | | x <- [0..(w `div` xW)] | |
| 61 | , y <- [0..(h `div` yW)] | |
| 62 | ] | |
| 49 | 63 | C.setSourceRGB 0.0 0.0 0.0 |
| 50 | 64 | mapM_ dLine (apLines state) |
| 51 | 65 | case apLines state of |
| 60 | 74 | Just (x, y) -> do |
| 61 | 75 | C.arc (fromIntegral x) (fromIntegral y) 5.0 0.0 (2 * pi) |
| 62 | 76 | C.stroke |
| 63 |
|
|
| 77 | drawWindowEndPaint dw | |
| 78 | ||
| 79 | dot :: Double -> Double -> C.Render () | |
| 80 | dot x y = do | |
| 81 | C.moveTo x y | |
| 82 | C.lineTo x y | |
| 83 | C.stroke | |
| 64 | 84 | |
| 65 | 85 | main :: IO () |
| 66 | 86 | main = do |
| 67 | 87 | _ <- initGUI |
| 68 | 88 | window <- windowNew |
| 89 | vbox <- vBoxNew False 10 | |
| 69 | 90 | da <- drawingAreaNew |
| 70 |
|
|
| 91 | minibuf <- labelNew (Just ":" :: Maybe String) | |
| 92 | stRef <- newIORef (ApplicationState [[]] Nothing (800, 800) (Just (10, 10))) | |
| 71 | 93 | set window [ windowDefaultWidth := 800 |
| 72 | 94 | , windowDefaultHeight := 800 |
| 73 |
, containerChild := |
|
| 95 | , containerChild := vbox | |
| 74 | 96 | , containerBorderWidth := 10 |
| 75 | 97 | ] |
| 98 | boxPackStart vbox da PackGrow 0 | |
| 99 | boxPackStart vbox minibuf PackRepel 0 | |
| 76 | 100 | _ <- onMotionNotify da True $ \ event -> do |
| 77 | 101 | st <- readIORef stRef |
| 78 | 102 | let (x, y) = (rnd (eventX event), rnd (eventY event)) |
| 94 | 118 | writeIORef stRef st' |
| 95 | 119 | render da st' |
| 96 | 120 | return True |
| 121 | _ <- onKeyPress window $ \ case | |
| 122 | Key { eventKeyChar = Just 'c' } -> do | |
| 123 | modifyIORef stRef (\ st -> st { apLines = [[]] }) | |
| 124 | readIORef stRef >>= render da | |
| 125 | return True | |
| 126 | Key { eventKeyChar = Just ':' } -> do | |
| 127 | labelSetText minibuf ("command" :: String) | |
| 128 | return True | |
| 129 | _ -> return True | |
| 97 | 130 | _ <- window `onDestroy` (saveFile stRef >> mainQuit) |
| 98 | 131 | widgetShowAll window |
| 99 | 132 | mainGUI |