amaranth/src/Canvas.hs

module Canvas where

import Graphics.Gloss.Data.Picture ( Picture (Text, Blank), pictures, scale, translate, rectangleSolid, circle )
import Graphics.Gloss.Interface.IO.Interact ( Event (EventKey, EventMotion), KeyState (Down, Up), Key (Char, MouseButton), MouseButton (LeftButton) )

type Dimension  = (Int, Int)
type Position   = (Float, Float)
type TipSize    = Float

data Canvas = Canvas {
    items   ::  [Picture]
,   mode    ::  Mode
,   drawing ::  Bool
,   pos     ::  Position
,   tip     ::  Tip
}

data Mode = Brush | Eraser deriving (Eq, Show)

data Tip = Tip {
    shape   :: Shape
,   size    :: TipSize
}

data Shape = Rectangular | Circular

nextPicture :: Canvas -> Picture
nextPicture (Canvas _ Brush True position (Tip Rectangular size)) = uncurry translate position $ rectangleSolid size size
nextPicture (Canvas _ Brush True position (Tip Circular size)) = uncurry translate position $ circle size
nextPicture _ = Blank

windowSize :: Dimension
windowSize = (500, 500)

leftCornerize :: Picture -> Picture
leftCornerize = translate (fromIntegral $ (-(fst windowSize)) `div` 2 + (fst windowSize `div` 10))
                          (fromIntegral $ (snd windowSize)    `div` 2 - (snd windowSize `div` 10))

rightCornerize :: Picture -> Picture
rightCornerize = translate (fromIntegral $ (fst windowSize)    `div` 2 - (fst windowSize `div` 5))
                           (fromIntegral $ (snd windowSize)    `div` 2 - (snd windowSize `div` 10))

showInfo :: Canvas -> Picture
showInfo canv = leftCornerize
                $ scale 0.15 0.15
                $ Text ( show (mode canv) ++ " - " ++ show (pos canv))

render :: Canvas -> Picture
render canv = pictures ( showInfo canv : items canv )

handle :: Event -> Canvas -> Canvas
handle (EventKey (Char 'b') Down _ _ ) canv               = canv { mode = Brush }
handle (EventKey (Char 'e') Down _ _ ) canv               = canv { mode = Eraser }
handle (EventKey (MouseButton LeftButton) Down _ mouse ) canv = canv { drawing = True }
handle (EventKey (MouseButton LeftButton) Up   _ mouse ) canv = canv { drawing = False }
handle (EventMotion (x, y)) canv                          = canv { pos = (x, y)}
handle _ canv = canv

update :: Float -> Canvas -> Canvas
update _ canv = canv { items = nextPicture canv : items canv }