Example application that uses Skia/Canvaskit to render/draw (#234)

* updating jsaddle

* fiddling with skia

* more rendering stuff + hookign into JS more

* drawing from haskell

* buttons + more acutal skia canvas loading

* refactoring the canvaskit stuff into its own module

* rendering points seems to work (but still rendered on the wrong pos)

* SkiaCanvas rendering :)

* cleaning + drawing polylines

* colors

* cleaning a bit

* css fiddling

* refactoring/cleaning

* modes + buttons

* fiddling with layers

* fiddling with colors

* colors

* polylines

* splitting into multiple files

* some more refactoring

* refactoring

* more drawing stuff / more work on plyline mode

* bunch of refactoring to have common miso helpers in a separate public hgeometry library

* dealing with a modal

* color modal editing

* some small fixes to the panel

* we can draw rectangles as well now :)

* an add layer button

* automatically close the color modal after doing something

* a bunch of refactoring to support more selctMode stuff

* completing selection (and rendering it somehow)

* progress on computing selections

* some refactoring

* even more refactoring

* storing more refs

* mostly getting rid of useless imports

* fiddling with storing/rendering pictures. Does not really work yet

* fixed the bug I've been looking for all afternoon...

* rendering (now with some caching :))

* common stuff about zooming

* fixing some warnings + removed duplicate module

* starting with polygon mode

* some refactoring

* drawing simple polygons :)

* drawing polygons :)

cabal.project

@@ -5,38 +5,22 @@ packages:
   hgeometry-combinatorial
   hgeometry
   hgeometry-examples
-  -- ../hiraffe
+  ../hiraffe
+  ../miso-bulma
 
 allow-newer:
     vector-circular:vector,
     vector-circular:base,
     vector-circular:template-haskell,
     vector-circular:semigroupoids,
-    -- miso:servant,
-    servant-lucid:servant,
-    servant:base,
-    vault:base,
-    singleton-bool:base,
-    lucid-svg:transformers,text,
-    pretty:deepseq,
-    pretty:dlist,
-    hexpat:deepseq,
-    -- servant:all,
-    -- lucid-svg:text,
-    -- hexpat:all,
-    -- pretty:all,
-    -- dlist:all,
-    -- aeson:all,
-    -- primitive:all,
     vector-circular:primitive,
     vector-circular:deepseq,
-    websockets:all,
-    jsaddle-warp:all
-
+    all:jsaddle,
+    lucid-svg:transformers,text,
 
-source-repository-package
-    type: git
-    location: https://github.com/noinia/hiraffe
+-- source-repository-package
+--     type: git
+--     location: https://github.com/noinia/hiraffe
 
 source-repository-package
     type: git

hgeometry-examples/bapc2012/Gunslinger.hs

@@ -117,8 +117,9 @@ distanceToHatch :: NonEmpty (Point 2 Int :+ Kind) -> Answer
 distanceToHatch = maybe Impossible (Possible . distanceAlong) . toHatch
 
 readPoint   :: String -> Point 2 Int
-readPoint s = let [x,y] = map read . words $ s in Point2 x y
-
+readPoint s = case map read . words $ s of
+                [x,y] -> Point2 x y
+                _     -> error "readPoint: wrong number of args"
 
 readInput                 :: [String] -> [Input]
 readInput []              = []
@@ -131,7 +132,7 @@ readInput (ls:hs:ns:rest) = let n            = read ns
 readInput _                = error "readInput: wrong number of args"
 
 gunslinger :: String -> String
-gunslinger = unlines . map (show . escape) . readInput . tail . lines
+gunslinger = unlines . map (show . escape) . readInput . drop 1 . lines
 
 main :: IO ()
 main = interact gunslinger

hgeometry-examples/bapc2014/Armybase.lhs

@@ -236,7 +236,7 @@ Input & Output
 
 
 > armybase :: String -> String
-> armybase = unlines . map (showValue . maxBaseArea) . readInput . tail . lines
+> armybase = unlines . map (showValue . maxBaseArea) . readInput . drop 1 . lines
 
 
 > main :: IO ()

hgeometry-examples/bapc2014/frank.lhs

@@ -19,7 +19,7 @@ $O(n^2 \log n)$ solution.
 > import Data.Monoid
 > import Data.Ix
 
->
+
 > import qualified Data.Array   as A
 
 > import qualified Data.List     as L
@@ -47,7 +47,7 @@ A value of type Half should still be halved. I.e. 'Half 2x = x'
 
 > newtype Half = Half Int
 >                        deriving (Show,Eq,Ord)
->
+
 > instance Num Half where
 >   (Half a) + (Half b) = Half $ a + b
 >   (Half a) - (Half b) = Half $ a - b
@@ -98,8 +98,8 @@ points in $O(n \log n)$ time.
 > convexHull []  = ConvexHull []
 > convexHull [p] = ConvexHull [p]
 > convexHull ps  = let ps' = L.sortBy incXdecY ps
->                      uh  = tail . hull . Sorted $         ps'
->                      lh  = tail . hull . Sorted $ reverse ps'
+>                      uh  = drop 1 . hull . Sorted $         ps'
+>                      lh  = drop 1 . hull . Sorted $ reverse ps'
 >                  in ConvexHull $ lh ++ uh
 
 > incXdecY (Point (px,py)) (Point (qx,qy)) =
@@ -115,7 +115,7 @@ points in $O(n \log n)$ time.
 >   where
 >     hull' h  []    = h
 >     hull' h (p:ps) = hull' (cleanMiddle (p:h)) ps
->
+
 >     cleanMiddle [b,a]          = [b,a]
 >     cleanMiddle h@(c:b:a:rest)
 >       | rightTurn a b c       = h
@@ -177,7 +177,7 @@ the function `allChains` finds all alowed pairs $p$ and $q$, and the chains of
 vertices (along the convex hull) connecting $p$ to $q$ and $q$ to $p$.
 
 > type Chain = Array Int Point
->
+
 > allChains                 :: ConvexHull -> [(Point,Point,(Chain,Chain))]
 > allChains (ConvexHull ch) =
 >     [ (chA ! i, chA ! j, chains chA i j) | i <- [1..n-2], j <- rest i ]
@@ -316,11 +316,11 @@ Input & Output
 
 > main :: IO ()
 > main = interact $
->          unlines . map (showValue . maxBaseArea) . readInput . tail . lines
+>          unlines . map (showValue . maxBaseArea) . readInput . drop 1 . lines
 
 -- > main :: IO ()
 -- > main = readFile "testdata_ipe.in" >>=
--- >        putStr . unlines . map (showValue . maxBaseArea) . readInput . tail . lines
+-- >        putStr . unlines . map (showValue . maxBaseArea) . readInput . drop 1 . lines
 
 
 > show' (p,q,(a,b)) = (p,q,elems a, elems b)

hgeometry-examples/hgeometry-examples.cabal

@@ -44,6 +44,7 @@ common setup
       , hgeometry:kernel
       , hgeometry:ipe
       , hgeometry:svg
+      , hgeometry:miso
       , hiraffe                   >= 0.1
       , containers                >= 0.6
       , vector                    >= 0.13
@@ -59,7 +60,13 @@ common setup
       , array                     >= 0.5
       , aeson                     >= 2.0
       , colour                    >= 2.3.6
-      -- , miso-bulma                >= 0.1.0.0   && < 1
+      , bytestring                >= 0.11
+      , miso-bulma                >= 0.1.0.0       && < 1
+      , file-embed                >= 0.0.15        && < 0.1
+      , mtl                       >= 2.3.1
+      , transformers              >= 0.6.0.0
+      , infinite-list             >= 0.1.1         && < 0.2
+
 
       , ghc-typelits-natnormalise >= 0.7.7
       , ghc-typelits-knownnat     >= 0.7.6
@@ -87,8 +94,8 @@ common setup
 common miso-setup
   build-depends:
         miso
-      , jsaddle
-      , jsaddle-warp
+      , jsaddle                   >= 0.9.9.0       && < 0.10
+      , jsaddle-warp              >= 0.9.9.0       && < 0.10
 
 common quickcheck-setup
     ghc-options:
@@ -169,5 +176,41 @@ executable hgeometry-polyLineDrawing
   import:         setup, miso-setup
   hs-source-dirs: polyLineDrawing
   main-is:        Main.hs
+  -- other-modules:
+  --      Miso.Event.Extra
+
+--------------------------------------------------------------------------------
+-- * Polyline Drawing
+
+executable hgeometry-skia
+  import:         setup, miso-setup
+  hs-source-dirs: skia
+  main-is:        Main.hs
   other-modules:
-       Miso.Event.Extra
+        Options
+        SkiaCanvas
+        SkiaCanvas.Core
+        SkiaCanvas.Render
+        SkiaCanvas.CanvasKit
+        SkiaCanvas.CanvasKit.Core
+        SkiaCanvas.CanvasKit.Color
+        SkiaCanvas.CanvasKit.GeomPrims
+        SkiaCanvas.CanvasKit.Paint
+        SkiaCanvas.CanvasKit.Path
+        SkiaCanvas.CanvasKit.Picture
+        SkiaCanvas.CanvasKit.PictureRecorder
+        SkiaCanvas.CanvasKit.Render
+        SkiaCanvas.CanvasKit.Initialize
+        Modes
+        Layers
+        StrokeAndFill
+        Attributes
+        Color
+        PolyLineMode
+        PolygonMode
+        RectangleMode
+        SelectMode
+        Model
+        Action
+        ToolMenu
+        Base

hgeometry-examples/polyLineDrawing/Main.hs

@@ -40,7 +40,7 @@ import           HGeometry.Sequence.NonEmpty
 import           HGeometry.Vector
 import qualified Language.Javascript.JSaddle.Warp as JSaddle
 import           Miso hiding (onMouseUp, onMouseDown)
-import           Miso.Event.Extra
+import           HGeometry.Miso.Event.Extra
 import qualified Miso.Html.Element as Html
 import           Miso.String (MisoString,ToMisoString(..), ms)
 import           Miso.Svg hiding (height_, id_, style_, width_)

hgeometry-examples/skia/.ghci

@@ -0,0 +1,2 @@
+:set -fno-break-on-exception
+:def! reload (const $ return "::reload\nMiso.Bulma.JSAddle.debug 8080 mainJSM")

hgeometry-examples/skia/Action.hs

@@ -0,0 +1,55 @@
+module Action
+  ( Action(..)
+  , ColorAction(..)
+  ) where
+
+import           Color
+import           Control.Lens hiding (view, element)
+import           HGeometry.Miso.OrphanInstances ()
+import           Layers
+import           Miso.String (MisoString)
+import           Model
+import           Modes
+import           RectangleMode (Rectangle')
+import qualified SkiaCanvas
+import           SkiaCanvas.CanvasKit hiding (Style(..))
+
+--------------------------------------------------------------------------------
+
+data Action = Id
+            | OnLoad
+            | CanvasKitAction InitializeSkCanvasAction
+            | CanvasResizeAction SkiaCanvas.CanvasResizeAction
+            | CanvasAction SkiaCanvas.InternalCanvasAction
+            | CanvasClicked
+            | CanvasRightClicked
+            -- | AddPoint
+            | Draw
+
+            | ReDraw
+            | StoreCached {-# UNPACK #-}!SkPictureRef
+
+            -- | SetStrokeColor (Maybe Color)
+            -- | SetFillColor   (Maybe Color)
+            | NotifyError !MisoString
+            | SwitchMode !Mode
+            | ToggleLayerStatus !(Index Layers)
+
+            | StrokeAction !ColorAction
+            | FillAction !ColorAction
+
+            | AddLayer
+
+
+            | ComputeSelection (Rectangle' R)
+
+            | SaveSkpFile
+            | LoadSkpFile
+
+
+
+-- | Actions one can do with the stroke or fill color
+data ColorAction = ToggleModal
+                 | ToggleColor
+                 | SetColor !Color
+                 deriving (Show,Eq)