62 lines
2.2 KiB
Haskell
62 lines
2.2 KiB
Haskell
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 }
|
|
|