From d74990940958fbdc706ab6ef5beef180c154c7b7 Mon Sep 17 00:00:00 2001 From: Annwan Date: Sun, 23 Jul 2023 14:58:40 +0200 Subject: [PATCH] We got display, kinda --- app/Board.hs | 116 ++++++++++++++++++++++++++++++++++++++++++++++++ app/Main.hs | 40 ++++++++++++++++- app/State.hs | 16 +++++++ app/UI.hs | 64 ++++++++++++++++++++++++++ noteboard.cabal | 8 +++- 5 files changed, 241 insertions(+), 3 deletions(-) create mode 100644 app/Board.hs create mode 100644 app/State.hs create mode 100644 app/UI.hs diff --git a/app/Board.hs b/app/Board.hs new file mode 100644 index 0000000..3a9b85a --- /dev/null +++ b/app/Board.hs @@ -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" + diff --git a/app/Main.hs b/app/Main.hs index 65ae4a0..0b39f36 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 + ) + ) + ) + diff --git a/app/State.hs b/app/State.hs new file mode 100644 index 0000000..15b0053 --- /dev/null +++ b/app/State.hs @@ -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 diff --git a/app/UI.hs b/app/UI.hs new file mode 100644 index 0000000..6b9c3d4 --- /dev/null +++ b/app/UI.hs @@ -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 () diff --git a/noteboard.cabal b/noteboard.cabal index 8728992..bd6fe58 100644 --- a/noteboard.cabal +++ b/noteboard.cabal @@ -64,13 +64,17 @@ executable noteboard main-is: Main.hs -- Modules included in this executable, other than Main. - -- other-modules: + other-modules: Board + , State + , UI -- LANGUAGE extensions used by modules in this package. -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base ^>=4.18.0.0 + build-depends: base ^>= 4.18.0.0 + , h-raylib ^>= 4.6.0.0 + , aeson ^>= 2.2.0.0 -- Directories containing source files. hs-source-dirs: app