We got display, kinda

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"
+

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
+            )
+          )
+    )
+

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

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 ()

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
+                 , h-raylib ^>= 4.6.0.0
+                 , aeson    ^>= 2.2.0.0
 
     -- Directories containing source files.
     hs-source-dirs:   app