svg canvas

hgeometry/hgeometry.cabal

@@ -451,6 +451,8 @@ library svg
     exposed-modules:
         HGeometry.Miso.Svg
         HGeometry.Miso.OrphanInstances
+        HGeometry.Miso.Svg.StaticCanvas
+        HGeometry.Miso.Svg.Canvas
         HGeometry.Svg
 
     other-modules:

hgeometry/kernel/src/HGeometry/Viewport.hs

@@ -39,7 +39,7 @@ data Viewport r = Viewport { _viewPort    :: Rectangle (Point 2 r)
                              -- ^ in host world
                            , _worldToHost :: Transformation 2 r
                              -- ^ Transformation that turns world
-                           -- coordinates into host coordinats.
+                           -- coordinates into host coordinates.
 
                            -- _hostToWorld :: Transformation 2 r
                            }
@@ -94,8 +94,10 @@ fromSize   :: ( Num r, Vector_ vector 2 r
 fromSize v = Viewport (Box origin (Point $ v^._Vector)) identity
 
 -- | Flips the y-coordinate so that the origin is in the bottom left.
-flipY    :: ( Num r, Vector_ vector 2 r
-            ) => vector -> Viewport r
+--
+flipY    :: ( Num r, Vector_ vector 2 r)
+         => vector -- ^ the dimensions of the viewport
+         -> Viewport r
 flipY v = Viewport (Box origin (Point $ v^._Vector))
                    (flipY' $ v^.yComponent)
 

hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE OverloadedStrings          #-}
+module HGeometry.Miso.Svg.Canvas
+  ( Canvas
+  , blankCanvas
+  , HasDimensions(..)
+
+  , HasMousePosition(..)
+  , mouseCoordinates
+
+  , InternalCanvasAction
+  , handleInternalCanvasAction
+
+  , svgCanvas_
+  ) where
+
+import           Control.Lens hiding (elements)
+import           HGeometry.Miso.Svg.StaticCanvas
+import           HGeometry.Point
+import           HGeometry.Transformation
+import           HGeometry.Vector
+import           HGeometry.Viewport
+import           Miso (Attribute, View, Effect, height_, width_, noEff, onMouseLeave)
+import           Miso.String (ms)
+import           Miso.Svg (svg_, g_, transform_)
+
+--------------------------------------------------------------------------------
+-- *A Canvas
+
+-- | Svg Canvas that has a "proper" Coordinate system whose origin is in the bottom left.
+data Canvas r =
+  Canvas { _theViewport :: !(Viewport r)
+         -- ^ the viewport
+         , _dimensions  :: !(Vector 2 Int)
+         -- ^ dimensions (width,height) in pixels, of the canvas
+         , _mousePosition     :: Maybe (Point 2 Int)
+         -- ^ the mouse position, in raw pixel coordinates
+         }
+  deriving stock (Eq)
+
+-- | Lens to access the viewport
+theViewport :: Lens (Canvas r) (Canvas s) (Viewport r) (Viewport s)
+theViewport = lens _theViewport (\c vp -> c { _theViewport = vp })
+
+instance HasDimensions (Canvas r) (Vector 2 Int) where
+  dimensions = lens _dimensions (\c d -> c { _dimensions = d })
+  {-# INLINE dimensions #-}
+
+-- | Class for types that have a mouse position
+class HasMousePosition s a | s -> a where
+  -- | Lens to access the raw mouse position
+  mousePosition :: Lens' s a
+
+instance HasMousePosition (Canvas r) (Maybe (Point 2 Int)) where
+  mousePosition = lens _mousePosition (\c m -> c { _mousePosition = m })
+  {-# INLINE mousePosition #-}
+
+-- | Getter to access the mouse coordinates (in terms of the coordinate system as used by
+-- the canvas). Returns a Nothing if the mouse is not currently on/over the canvas.
+mouseCoordinates :: Fractional r => Getter (Canvas r) (Maybe (Point 2 r))
+mouseCoordinates = to $ \m -> toWorldIn' (m^.theViewport) <$> m^.mousePosition
+  where
+    toWorldIn' vp p = toWorldIn vp (p&coordinates %~ fromIntegral)
+
+-- center     :: Lens' (Canvas r) (Point 2 r)
+-- center     = lens _center     (\cv c -> cv { _center     = c } )
+
+-- zoomLevel  :: Lens' (Canvas r) r
+-- zoomLevel  = lens _zoomLevel      (\cv c -> cv { _zoomLevel      = c } )
+
+--------------------------------------------------------------------------------
+
+-- | Crate a blank canvas, that has the origin in the bottom-left.
+blankCanvas     :: (Num r)
+                 => Int -> Int -> Canvas r
+blankCanvas w h = let v = Vector2 w h
+                  in Canvas (flipY (fromIntegral <$> v)) v Nothing
+
+--------------------------------------------------------------------------------
+-- * The Controller
+
+-- | Actions that CanvasAction will handle itself.
+data InternalCanvasAction = MouseMove (Int,Int)
+                          | MouseLeave
+                          deriving (Show,Eq)
+
+-- | Handles InternalCanvas Actions
+handleInternalCanvasAction        :: Canvas r -> InternalCanvasAction -> Effect action (Canvas r)
+handleInternalCanvasAction canvas = noEff . \case
+  MouseMove (x,y) -> canvas&mousePosition ?~ Point2 x y
+  MouseLeave      -> canvas&mousePosition .~ Nothing
+
+--------------------------------------------------------------------------------
+-- * The View
+
+-- | Draws the actual canvas
+svgCanvas_               :: (RealFrac r, ToSvgCoordinate r)
+                         => Canvas r
+                         -> [Attribute action] -> [View action]
+                         -> View (Either InternalCanvasAction action)
+svgCanvas_ canvas ats vs =
+  svg_ ([ width_   . ms $ w
+        , height_  . ms $ h
+        , onMouseLeave $ Left MouseLeave
+        ] <> (fmap Right <$> ats))
+        [ g_ [ transform_ ts ] (fmap Right <$> vs)
+        ]
+  where
+    (Vector2 w h) = canvas^.dimensions
+    ts = matrixToMisoString $ canvas^.theViewport.worldToHost.transformationMatrix
+
+
+-- | To be used instead of the text_ combinator in Miso
+-- textAt                     :: ToSvgCoordinate r
+--                            => Point 2 r -- ^ position where to draw (in world coordinates)
+--                            -> [Attribute action]
+--                            -> MisoString -> View action
+-- textAt (Point2 x y) ats t = g_ [ transform_ $ mconcat [ "translate("
+--                                                        , ms x
+--                                                        , ", "
+--                                                        , ms y
+--                                                        , ")scale(1,-1)"
+--                                                        ]
+--                                 ] [ Miso.text_ ats [text t] ]
+
+
+
+-- class RenderWebSvg t where
+--   renderWith :: t -> [Attribute action] -> [View action] -> View action
+
+-- render       :: RenderWebSvg t => t -> [Attribute action] -> View action
+-- render x ats = renderWith x ats []
+
+-- instance ToSvgCoordinate r => RenderWebSvg (Point 2 r) where
+--   renderWith (Point2 x y) ats = ellipse_ $ [ cx_ $ ms x, cy_ $ ms y
+--                                            , rx_ "5", ry_ "5"
+--                                            , fill_ "black"
+--                                            ] <> ats

hgeometry/svg/src/HGeometry/Miso/Svg/StaticCanvas.hs

@@ -1,90 +1,124 @@
 {-# LANGUAGE OverloadedStrings          #-}
 module HGeometry.Miso.Svg.StaticCanvas
-  ( Canvas(..)
-  , center, dimensions, zoomLevel, createCanvas
-  , staticCanvas_, textAt
-  , realWorldCoordinates
+  ( StaticCanvas
+  , staticCanvas
+  , HasDimensions(..)
+  -- , center, dimensions, zoomLevel
+  , staticCanvas_
+  -- , textAt
+  -- , realWorldCoordinates
   , ToSvgCoordinate
+
+
+  , matrixToMisoString
   ) where
 
-import           Control.Lens
+import           Control.Lens hiding (elements)
 import qualified Data.Map as Map
+import           HGeometry.Matrix
 import           HGeometry.Point
-import           HGeometry.Svg.MathCoordinateSystem ( Canvas(..)
-                                                    , center
-                                                    , dimensions
-                                                    , zoomLevel
-                                                    , createCanvas
-                                                    , realWorldCoordinates
-                                                    )
+import           HGeometry.Transformation
 import           HGeometry.Vector
-import           Miso
+import           HGeometry.Viewport
+import           Miso (Attribute, View, height_, width_)
 import           Miso.String (MisoString, ToMisoString, ms)
 import qualified Miso.String.Util as MisoString
-import qualified Miso.Svg as Miso
-import           Miso.Svg (svg_, g_, transform_, viewBox_)
+import           Miso.Svg (svg_, g_, transform_)
 
 --------------------------------------------------------------------------------
+-- *A Canvas
 
-type ToSvgCoordinate = ToMisoString
+-- | Svg Canvas that has a "proper" Coordinate system whose origin is in the bottom left.
+data StaticCanvas r =
+  Canvas { _theViewport :: !(Viewport r)
+         -- ^ the viewport
+         , _dimensions  :: !(Vector 2 Int)
+         -- ^ dimensions (width,height) in pixels, of the canvas
+         }
+  deriving stock (Eq)
 
+theViewport :: Lens (StaticCanvas r) (StaticCanvas s) (Viewport r) (Viewport s)
+theViewport = lens _theViewport (\c vp -> c { _theViewport = vp })
 
+class HasDimensions s a | s -> a where
+  dimensions :: Lens' s a
 
+instance HasDimensions (StaticCanvas r) (Vector 2 Int) where
+  dimensions = lens _dimensions (\c d -> c { _dimensions = d})
+  {-# INLINE dimensions #-}
 
 
+-- class HasTheViewport s a | s -> a where
+--   theViewport :: Lens' s a
 
+-- instance HasTheViewport (Canvas r) (Viewport r) where
+--   {-# INLINE theViewport #-}
+--   theViewport f (Canvas vp d) = fmap (\ vp' -> Canvas vp' d) (f vp)
 
+-- center     :: Lens' (Canvas r) (Point 2 r)
+-- center     = lens _center     (\cv c -> cv { _center     = c } )
 
+-- dimensions :: Lens' (Canvas r) (Vector 2 Int)
+-- dimensions = lens _dimensions (\cv c -> cv { _dimensions = c } )
 
--- | Draws the actual canvas
-staticCanvas_           :: (RealFrac r, ToSvgCoordinate r)
-                       =>  Canvas r -> [Attribute action] -> [View action] -> View action
-staticCanvas_ cv ats vs = div_ [ style_ $ Map.fromList [ ("margin", "0")
-                                                       , ("padding", "0")
-                                                       , ("height",  ms h <> "px")
-                                                       ]
-                               ]
-                               [ svg_ ([ width_   . ms $ w
-                                       , height_  . ms $ h
-                                       , viewBox_      $ outerVB
-                                       ] <> ats
-                                      )
-                                      [ g_ [ transform_ "scale(1,-1)" ]
-                                           [ svg_ [ width_  . ms $ w
-                                                  , height_ . ms $ h
-                                                  , viewBox_ $ innerVB
-                                                  ]  vs
-                                           ]
-                                      ]
-                               ]
+-- zoomLevel  :: Lens' (Canvas r) r
+-- zoomLevel  = lens _zoomLevel      (\cv c -> cv { _zoomLevel      = c } )
 
-  where
-    dims@(Vector2 w h) = cv^.dimensions
-    Point2 cx cy       = round <$> cv^.center
+--------------------------------------------------------------------------------
+-- | Create a canvas
+staticCanvas     :: Num r
+                 => Int -> Int -> StaticCanvas r
+staticCanvas w h = let v = Vector2 w h
+                   in Canvas (flipY (fromIntegral <$> v)) v
+
+--------------------------------------------------------------------------------
+-- * The Controller
 
-    Vector2 vw vh = round  <$> (1 / cv^.zoomLevel) *^ (fromIntegral <$> dims)
 
+--------------------------------------------------------------------------------
+-- * The View
+
+type ToSvgCoordinate = ToMisoString
+
+
+-- | Draws the actual canvas
+staticCanvas_               :: (RealFrac r, ToSvgCoordinate r)
+                            => StaticCanvas r
+                            -> [Attribute action] -> [View action] -> View action
+staticCanvas_ canvas ats vs =
+    svg_ ([ width_   . ms $ w
+          , height_  . ms $ h
+            -- , viewBox_      $ outerVB
+          ] <> ats)
+         [ g_ [ transform_ ts ] vs
+         ]
+  where
+    (Vector2 w h) = canvas^.dimensions
+    ts = matrixToMisoString $ canvas^.theViewport.worldToHost.transformationMatrix
+
+matrixToMisoString   :: ToSvgCoordinate r => Matrix 3 3 r -> MisoString
+matrixToMisoString m = "matrix(" <> MisoString.unwords [a,b,c,e,d,f] <> ")"
+  where
+    (Vector3 (Vector3 a b c)
+             (Vector3 d e f)
+             _              ) = (m&elements %~ ms :: Matrix 3 3 MisoString)^.rows
+                              -- this last vector has to be 0 0 1
 
-    toVB = MisoString.unwords . map ms
-    outerVB = toVB [0, (-1) * h, w, h]
-      -- role of the outer viewBox is to flip the coordinate system s.t. the origin
-      -- is in the bottom left rather than the top-left
 
-    innerVB = toVB [(cx - (vw `div` 2)), (cy - (vh `div` 2)), vw, vh]
 
 
 -- | To be used instead of the text_ combinator in Miso
-textAt                     :: ToSvgCoordinate r
-                           => Point 2 r -- ^ position where to draw (in world coordinates)
-                           -> [Attribute action]
-                           -> MisoString -> View action
-textAt (Point2 x y) ats t = g_ [ transform_ $ mconcat [ "translate("
-                                                       , ms x
-                                                       , ", "
-                                                       , ms y
-                                                       , ")scale(1,-1)"
-                                                       ]
-                                ] [ Miso.text_ ats [text t] ]
+-- textAt                     :: ToSvgCoordinate r
+--                            => Point 2 r -- ^ position where to draw (in world coordinates)
+--                            -> [Attribute action]
+--                            -> MisoString -> View action
+-- textAt (Point2 x y) ats t = g_ [ transform_ $ mconcat [ "translate("
+--                                                        , ms x
+--                                                        , ", "
+--                                                        , ms y
+--                                                        , ")scale(1,-1)"
+--                                                        ]
+--                                 ] [ Miso.text_ ats [text t] ]