Annwan
1 year ago
5 changed files with 241 additions and 3 deletions
-
116app/Board.hs
-
40app/Main.hs
-
16app/State.hs
-
64app/UI.hs
-
6noteboard.cabal
@ -0,0 +1,116 @@ |
|||
{-# LANGUAGE OverloadedStrings #-} |
|||
module Board where |
|||
|
|||
import Raylib.Types (Vector2(..), Color(..)) |
|||
import Data.Aeson |
|||
import Data.Aeson.Types |
|||
|
|||
newtype BoardColor = BoardColor { unBoardColor :: Color } deriving Show |
|||
newtype Point = Point { unPoint :: Vector2 } deriving Show |
|||
|
|||
data Path = Path { path'points :: [Point] |
|||
, path'thickness :: Float |
|||
, path'color :: BoardColor |
|||
} deriving Show |
|||
|
|||
data BackgroundPattern = BGPatternPlain { bg'fillColor :: BoardColor } |
|||
| BGPatternDots { bg'fillColor :: BoardColor |
|||
, bg'drawColor :: BoardColor |
|||
, bg'hSpacing :: Int |
|||
, bg'vSpacing :: Int |
|||
, bg'thickness :: Float |
|||
} |
|||
| BGPatternGrid { bg'fillColor :: BoardColor |
|||
, bg'drawColor :: BoardColor |
|||
, bg'hSpacing :: Int |
|||
, bg'vSpacing :: Int |
|||
, bg'thickness :: Float |
|||
} |
|||
deriving Show |
|||
|
|||
data Board = Board { boardTitle :: String |
|||
, boardBackground :: BackgroundPattern |
|||
, boardPaths :: [Path] |
|||
} deriving Show |
|||
|
|||
instance ToJSON BoardColor where |
|||
toJSON (BoardColor c) = |
|||
object [ "r" .= color'r c, "g" .= color'g c, "b" .= color'b c, "a" .= color'a c ] |
|||
|
|||
instance FromJSON BoardColor where |
|||
parseJSON = withObject "color" $ \o -> do |
|||
c <- Color <$> o .: "r" |
|||
<*> o .: "g" |
|||
<*> o .: "b" |
|||
<*> o .: "a" |
|||
return $ BoardColor c |
|||
|
|||
instance ToJSON Point where |
|||
toJSON (Point v) = |
|||
object [ "x" .= vector2'x v, "y" .= vector2'y v ] |
|||
|
|||
instance FromJSON Point where |
|||
parseJSON = withObject "point" $ \o -> do |
|||
v2 <- Vector2 <$> o .: "x" |
|||
<*> o .: "y" |
|||
return $ Point v2 |
|||
|
|||
instance ToJSON Path where |
|||
toJSON (Path pts thk clr) = |
|||
object [ "points" .= pts |
|||
, "thickness" .= thk |
|||
, "color" .= clr |
|||
] |
|||
|
|||
instance FromJSON Path where |
|||
parseJSON = withObject "path" $ \o -> |
|||
Path <$> o .: "thickness" |
|||
<*> o .: "color" |
|||
<*> o .: "points" |
|||
|
|||
instance ToJSON BackgroundPattern where |
|||
toJSON (BGPatternPlain fc) = |
|||
object [ "type" .= ("plain" :: String), "fillColor" .= fc ] |
|||
toJSON (BGPatternDots fc dc hs vs th) = |
|||
object [ "type" .= ("dots" :: String) |
|||
, "fillColor" .= fc |
|||
, "drawColor" .= dc |
|||
, "hSpacing" .= hs |
|||
, "vSpacing" .= vs |
|||
, "thickness" .= th |
|||
] |
|||
toJSON (BGPatternGrid fc dc hs vs th) = |
|||
object [ "type" .= ("grid" :: String) |
|||
, "fillColor" .= fc |
|||
, "drawColor" .= dc |
|||
, "hSpacing" .= hs |
|||
, "vSpacing" .= vs |
|||
, "thickness" .= th |
|||
] |
|||
|
|||
instance FromJSON BackgroundPattern where |
|||
parseJSON = withObject "backgroundPattern" $ \o -> do |
|||
pType <- (o .: "type" :: Parser String) |
|||
case pType of |
|||
"plain" -> BGPatternPlain <$> o .: "fillColor" |
|||
"grid" -> BGPatternGrid <$> o .: "fillColor" |
|||
<*> o .: "drawColor" |
|||
<*> o .: "hSpacing" |
|||
<*> o .: "vSpacing" |
|||
<*> o .: "thickness" |
|||
"dots" -> BGPatternDots <$> o .: "fillColor" |
|||
<*> o .: "drawColor" |
|||
<*> o .: "hSpacing" |
|||
<*> o .: "vSpacing" |
|||
<*> o .: "thickness" |
|||
x -> error $ "Unknown background type: " ++ x |
|||
|
|||
instance ToJSON Board where |
|||
toJSON (Board t b p) = object ["title" .= t , "background" .= b, "paths" .= p] |
|||
|
|||
instance FromJSON Board where |
|||
parseJSON = withObject "board" $ \o -> |
|||
Board <$> o .: "title" |
|||
<*> o .: "background" |
|||
<*> o .: "paths" |
|||
|
@ -1,4 +1,42 @@ |
|||
module Main where |
|||
|
|||
import Raylib.Core |
|||
import Raylib.Types |
|||
import Raylib.Util |
|||
import Raylib.Core.Text |
|||
import Raylib.Util.Colors |
|||
import Data.IORef |
|||
|
|||
import State |
|||
import Board |
|||
import UI |
|||
|
|||
main :: IO () |
|||
main = putStrLn "Hello, Haskell!" |
|||
main = do |
|||
let pattern = BGPatternGrid { bg'vSpacing = 25 |
|||
, bg'thickness = 1 |
|||
, bg'hSpacing = 25 |
|||
, bg'fillColor = BoardColor rayWhite |
|||
, bg'drawColor = BoardColor lightGray |
|||
} |
|||
let pathTest = Path { path'thickness= 3 |
|||
, path'points= map (Point . (uncurry Vector2)) |
|||
[(0,0), (1, 3), (0.5, 2)] |
|||
, path'color= BoardColor purple |
|||
} |
|||
appState <- newIORef $ AppState (ActionDraw (Path [] 1.0 $ BoardColor black)) |
|||
(Board "Untitled" pattern [pathTest]) |
|||
"" |
|||
(Point $ Vector2 0.0 0.0) |
|||
1.1 |
|||
withWindow 800 600 "Noteboard" 60 |
|||
(\_ -> do |
|||
setWindowState [WindowResizable, WindowMaximized] |
|||
whileWindowOpen0 |
|||
( drawing |
|||
( do |
|||
drawUI appState |
|||
) |
|||
) |
|||
) |
|||
|
@ -0,0 +1,16 @@ |
|||
module State where |
|||
|
|||
import Board |
|||
|
|||
data Action = ActionDraw { act'currentPath :: Path } |
|||
| ActionErase |
|||
| ActionSave |
|||
deriving Show |
|||
|
|||
data AppState = AppState { state'action :: Action |
|||
, state'board :: Board |
|||
, state'path :: String |
|||
, state'offset :: Point |
|||
, state'zoom :: Float |
|||
} |
|||
deriving Show |
@ -0,0 +1,64 @@ |
|||
module UI (drawUI) where |
|||
|
|||
import State |
|||
import Data.IORef |
|||
import Board |
|||
import Raylib.Core |
|||
import Raylib.Types |
|||
import Raylib.Core.Shapes |
|||
import Raylib.Util.Math |
|||
|
|||
drawUI :: IORef AppState -> IO () |
|||
drawUI r = do |
|||
state <- readIORef r |
|||
winW <- getRenderWidth |
|||
winH <- getRenderHeight |
|||
let act = state'action state |
|||
brd = state'board state |
|||
pth = state'path state |
|||
(Point off) = state'offset state |
|||
zoom = state'zoom state |
|||
(Board ti bg pths) = brd |
|||
drawBG off zoom winW winH bg |
|||
mapM_ (drawPath off zoom) pths |
|||
case act of |
|||
ActionDraw p -> drawPath off zoom p |
|||
_ -> return () |
|||
drawInterface act pth ti winW winH |
|||
|
|||
drawPath :: Vector2 -> Float -> Path -> IO () |
|||
drawPath offset zoom path = |
|||
let points = path'points path |
|||
segments = zip points (init points) |
|||
col = unBoardColor $ path'color path |
|||
thick = (path'thickness path) * zoom |
|||
in |
|||
mapM_ (\(s, e) -> |
|||
let s' = (offset |+| unPoint s) |* zoom |
|||
e' = (offset |+| unPoint e) |* zoom |
|||
in |
|||
drawLineEx s' e' thick col |
|||
) segments |
|||
|
|||
drawBG :: Vector2 -> Float -> Int -> Int -> BackgroundPattern -> IO () |
|||
drawBG _ _ _ _ (BGPatternPlain (BoardColor col)) = clearBackground col |
|||
drawBG off zoom maxx' maxy' (BGPatternGrid fc' dc' hs' vs' th) = |
|||
let fc = unBoardColor fc' |
|||
dc = unBoardColor dc' |
|||
hs = fromIntegral hs' * zoom |
|||
vs = fromIntegral vs' * zoom |
|||
offx = fromIntegral ((truncate $ vector2'x off) `rem` hs') * zoom |
|||
offy = fromIntegral ((truncate $ vector2'y off) `rem` vs') * zoom |
|||
maxx = fromIntegral maxx' |
|||
maxy = fromIntegral maxy' |
|||
in do |
|||
clearBackground fc |
|||
mapM_ (\x -> drawLineEx (Vector2 x 0) (Vector2 x maxy) th dc) |
|||
[offx, offx+hs .. maxx] |
|||
mapM_ (\y -> drawLineEx (Vector2 0 y) (Vector2 maxx y) th dc) |
|||
[offy, offy+vs .. maxy] |
|||
drawBG _ _ _ _ _ = undefined |
|||
|
|||
drawInterface :: Action -> String -> String -> Int -> Int -> IO () |
|||
drawInterface act pth ti winW winH = do |
|||
return () |
Write
Preview
Loading…
Cancel
Save
Reference in new issue