From d77bdc8a794ca56d4068377c326ddc29b5da79ec Mon Sep 17 00:00:00 2001 From: Frank Staals Date: Sat, 30 Sep 2023 20:54:22 +0200 Subject: [PATCH] svg canvas --- hgeometry/hgeometry.cabal | 2 + hgeometry/kernel/src/HGeometry/Viewport.hs | 8 +- .../svg/src/HGeometry/Miso/Svg/Canvas.hs | 137 ++++++++++++++++ .../src/HGeometry/Miso/Svg/StaticCanvas.hs | 148 +++++++++++------- 4 files changed, 235 insertions(+), 60 deletions(-) create mode 100644 hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs diff --git a/hgeometry/hgeometry.cabal b/hgeometry/hgeometry.cabal index da98c607b..b50fee2b5 100644 --- a/hgeometry/hgeometry.cabal +++ b/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: diff --git a/hgeometry/kernel/src/HGeometry/Viewport.hs b/hgeometry/kernel/src/HGeometry/Viewport.hs index 138cffaa3..992fc70d3 100644 --- a/hgeometry/kernel/src/HGeometry/Viewport.hs +++ b/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) diff --git a/hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs b/hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs new file mode 100644 index 000000000..e4e436b36 --- /dev/null +++ b/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 diff --git a/hgeometry/svg/src/HGeometry/Miso/Svg/StaticCanvas.hs b/hgeometry/svg/src/HGeometry/Miso/Svg/StaticCanvas.hs index 042eee584..3b5a19b93 100644 --- a/hgeometry/svg/src/HGeometry/Miso/Svg/StaticCanvas.hs +++ b/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] ]