{-# LANGUAGE OverloadedStrings          #-}
module HGeometry.Miso.Svg.Canvas
  ( Canvas
  , theViewport
  , blankCanvas
  , HasDimensions(..)

  , HasMousePosition(..)
  , mouseCoordinates

  , InternalCanvasAction
  , handleInternalCanvasAction
  , withCanvasEvents

  , svgCanvas_
  ) where

import           Control.Lens hiding (elements)
import qualified Data.Map as Map
-- import           HGeometry.Miso.Subscription.MouseExtra
import           HGeometry.Miso.Svg.StaticCanvas
import           HGeometry.Point
import           HGeometry.Transformation
import           HGeometry.Vector
import           HGeometry.Viewport
import           Miso ( Attribute, View, Effect
                      , put
                      )
import           Miso.String (ms)
import           Miso.Svg (svg_, g_, rect_)
import           Miso.Svg.Property (transform_, fill_, pointerEvents_)
import           Miso.Html.Property (width_,height_) -- not sure if this is correct (namespace)!
import           Miso.Event.Types ( PointerEvent(..), Events
                                  , pointerEvents
                                  , touchEvents
                                  , Phase(..)
                                  )
import           Miso.Html.Event ( onPointerLeave
                                 , onPointerMove
                                 , onPointerEnter
                                 )
--------------------------------------------------------------------------------
-- *A Canvas

-- | Svg Canvas that has a "proper" Coordinate system whose origin is in the bottom left.
data Canvas r =
  Canvas { forall r. Canvas r -> Viewport r
_theViewport :: !(Viewport r)
         -- ^ the viewport
         , forall r. Canvas r -> Vector 2 Int
_dimensions  :: !(Vector 2 Int)
         -- ^ dimensions (width,height) in pixels, of the canvas
         , forall r. Canvas r -> Maybe (Point 2 Int)
_mousePosition     :: Maybe (Point 2 Int)
         -- ^ the mouse position, in raw pixel coordinates
         }
  deriving stock (Canvas r -> Canvas r -> Bool
(Canvas r -> Canvas r -> Bool)
-> (Canvas r -> Canvas r -> Bool) -> Eq (Canvas r)
forall r. Eq r => Canvas r -> Canvas r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall r. Eq r => Canvas r -> Canvas r -> Bool
== :: Canvas r -> Canvas r -> Bool
$c/= :: forall r. Eq r => Canvas r -> Canvas r -> Bool
/= :: Canvas r -> Canvas r -> Bool
Eq,Int -> Canvas r -> ShowS
[Canvas r] -> ShowS
Canvas r -> String
(Int -> Canvas r -> ShowS)
-> (Canvas r -> String) -> ([Canvas r] -> ShowS) -> Show (Canvas r)
forall r. Show r => Int -> Canvas r -> ShowS
forall r. Show r => [Canvas r] -> ShowS
forall r. Show r => Canvas r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> Canvas r -> ShowS
showsPrec :: Int -> Canvas r -> ShowS
$cshow :: forall r. Show r => Canvas r -> String
show :: Canvas r -> String
$cshowList :: forall r. Show r => [Canvas r] -> ShowS
showList :: [Canvas r] -> ShowS
Show)

-- | Lens to access the viewport
theViewport :: Lens (Canvas r) (Canvas s) (Viewport r) (Viewport s)
theViewport :: forall r s (f :: * -> *).
Functor f =>
(Viewport r -> f (Viewport s)) -> Canvas r -> f (Canvas s)
theViewport = (Canvas r -> Viewport r)
-> (Canvas r -> Viewport s -> Canvas s)
-> Lens (Canvas r) (Canvas s) (Viewport r) (Viewport s)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Canvas r -> Viewport r
forall r. Canvas r -> Viewport r
_theViewport (\Canvas r
c Viewport s
vp -> Canvas r
c { _theViewport = vp })

instance HasDimensions (Canvas r) (Vector 2 Int) where
  dimensions :: Lens' (Canvas r) (Vector 2 Int)
dimensions = (Canvas r -> Vector 2 Int)
-> (Canvas r -> Vector 2 Int -> Canvas r)
-> Lens' (Canvas r) (Vector 2 Int)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Canvas r -> Vector 2 Int
forall r. Canvas r -> Vector 2 Int
_dimensions (\Canvas r
c Vector 2 Int
d -> Canvas r
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' (Canvas r) (Maybe (Point 2 Int))
mousePosition = (Canvas r -> Maybe (Point 2 Int))
-> (Canvas r -> Maybe (Point 2 Int) -> Canvas r)
-> Lens' (Canvas r) (Maybe (Point 2 Int))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Canvas r -> Maybe (Point 2 Int)
forall r. Canvas r -> Maybe (Point 2 Int)
_mousePosition (\Canvas r
c Maybe (Point 2 Int)
m -> Canvas r
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 :: forall r. Fractional r => Getter (Canvas r) (Maybe (Point 2 r))
mouseCoordinates = (Canvas r -> Maybe (Point 2 r))
-> Optic' (->) f (Canvas r) (Maybe (Point 2 r))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ((Canvas r -> Maybe (Point 2 r))
 -> Optic' (->) f (Canvas r) (Maybe (Point 2 r)))
-> (Canvas r -> Maybe (Point 2 r))
-> Optic' (->) f (Canvas r) (Maybe (Point 2 r))
forall a b. (a -> b) -> a -> b
$ \Canvas r
m -> Viewport (NumType (Point 2 r)) -> Point 2 Int -> Point 2 r
forall {g} {a}.
(Dimension g ~ 2, Dimension a ~ 2, IsTransformable g,
 Fractional (NumType g), HasCoordinates a g,
 Integral (NumType a)) =>
Viewport (NumType g) -> a -> g
toWorldIn' (Canvas r
mCanvas r
-> Getting (Viewport r) (Canvas r) (Viewport r) -> Viewport r
forall s a. s -> Getting a s a -> a
^.Getting (Viewport r) (Canvas r) (Viewport r)
forall r s (f :: * -> *).
Functor f =>
(Viewport r -> f (Viewport s)) -> Canvas r -> f (Canvas s)
theViewport) (Point 2 Int -> Point 2 r)
-> Maybe (Point 2 Int) -> Maybe (Point 2 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canvas r
mCanvas r
-> Getting (Maybe (Point 2 Int)) (Canvas r) (Maybe (Point 2 Int))
-> Maybe (Point 2 Int)
forall s a. s -> Getting a s a -> a
^.Getting (Maybe (Point 2 Int)) (Canvas r) (Maybe (Point 2 Int))
forall s a. HasMousePosition s a => Lens' s a
Lens' (Canvas r) (Maybe (Point 2 Int))
mousePosition
  where
    toWorldIn' :: Viewport (NumType g) -> a -> g
toWorldIn' Viewport (NumType g)
vp a
p = Viewport (NumType g) -> g -> g
forall g r.
(IsTransformable g, NumType g ~ r, Dimension g ~ 2,
 Fractional r) =>
Viewport r -> g -> g
toWorldIn Viewport (NumType g)
vp (a
pa -> (a -> g) -> g
forall a b. a -> (a -> b) -> b
&(NumType a -> Identity (NumType g)) -> a -> Identity g
forall point point'.
HasCoordinates point point' =>
IndexedTraversal1 Int point point' (NumType point) (NumType point')
IndexedTraversal1 Int a g (NumType a) (NumType g)
coordinates ((NumType a -> Identity (NumType g)) -> a -> Identity g)
-> (NumType a -> NumType g) -> a -> g
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ NumType a -> NumType g
forall a b. (Integral a, Num b) => a -> b
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 :: forall r. Num r => Int -> Int -> Canvas r
blankCanvas Int
w Int
h = let v :: Vector 2 Int
v = Int -> Int -> Vector 2 Int
forall r. r -> r -> Vector 2 r
Vector2 Int
w Int
h
                  in Viewport r -> Vector 2 Int -> Maybe (Point 2 Int) -> Canvas r
forall r.
Viewport r -> Vector 2 Int -> Maybe (Point 2 Int) -> Canvas r
Canvas (Vector 2 r -> Viewport r
forall r vector.
(Num r, Vector_ vector 2 r) =>
vector -> Viewport r
flipY (Int -> r
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> r) -> Vector 2 Int -> Vector 2 r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector 2 Int
v)) Vector 2 Int
v Maybe (Point 2 Int)
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- * The Controller

-- | Actions that CanvasAction will handle itself.
data InternalCanvasAction = PointerEnter PointerEvent
                          | PointerMove  PointerEvent
                          | PointerLeave PointerEvent
                          -- | TouchStart !(Point 2 Int)
                          -- | TouchMove  !(Point 2 Int)
                          -- | TouchEnd
                          deriving (Int -> InternalCanvasAction -> ShowS
[InternalCanvasAction] -> ShowS
InternalCanvasAction -> String
(Int -> InternalCanvasAction -> ShowS)
-> (InternalCanvasAction -> String)
-> ([InternalCanvasAction] -> ShowS)
-> Show InternalCanvasAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InternalCanvasAction -> ShowS
showsPrec :: Int -> InternalCanvasAction -> ShowS
$cshow :: InternalCanvasAction -> String
show :: InternalCanvasAction -> String
$cshowList :: [InternalCanvasAction] -> ShowS
showList :: [InternalCanvasAction] -> ShowS
Show,InternalCanvasAction -> InternalCanvasAction -> Bool
(InternalCanvasAction -> InternalCanvasAction -> Bool)
-> (InternalCanvasAction -> InternalCanvasAction -> Bool)
-> Eq InternalCanvasAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InternalCanvasAction -> InternalCanvasAction -> Bool
== :: InternalCanvasAction -> InternalCanvasAction -> Bool
$c/= :: InternalCanvasAction -> InternalCanvasAction -> Bool
/= :: InternalCanvasAction -> InternalCanvasAction -> Bool
Eq)

offset' :: PointerEvent -> (Int,Int)
offset' :: PointerEvent -> (Int, Int)
offset' = (Double -> Int)
-> (Double -> Int) -> (Double, Double) -> (Int, Int)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor ((Double, Double) -> (Int, Int))
-> (PointerEvent -> (Double, Double)) -> PointerEvent -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PointerEvent -> (Double, Double)
offset -- changed this from client;

-- | Handles InternalCanvas Actions
handleInternalCanvasAction        :: Canvas r -> InternalCanvasAction
                                  -> Effect parent (Canvas r) action
handleInternalCanvasAction :: forall r parent action.
Canvas r -> InternalCanvasAction -> Effect parent (Canvas r) action
handleInternalCanvasAction Canvas r
canvas = Canvas r
-> RWST
     (ComponentInfo parent) [Schedule action] (Canvas r) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Canvas r
 -> RWST
      (ComponentInfo parent) [Schedule action] (Canvas r) Identity ())
-> (InternalCanvasAction -> Canvas r)
-> InternalCanvasAction
-> RWST
     (ComponentInfo parent) [Schedule action] (Canvas r) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  PointerEnter PointerEvent
pe  -> Canvas r
canvasCanvas r -> (Canvas r -> Canvas r) -> Canvas r
forall a b. a -> (a -> b) -> b
&(Maybe (Point 2 Int) -> Identity (Maybe (Point 2 Int)))
-> Canvas r -> Identity (Canvas r)
forall s a. HasMousePosition s a => Lens' s a
Lens' (Canvas r) (Maybe (Point 2 Int))
mousePosition ((Maybe (Point 2 Int) -> Identity (Maybe (Point 2 Int)))
 -> Canvas r -> Identity (Canvas r))
-> Point 2 Int -> Canvas r -> Canvas r
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Int -> Int -> Point 2 Int) -> (Int, Int) -> Point 2 Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 (PointerEvent -> (Int, Int)
offset' PointerEvent
pe)
  PointerMove  PointerEvent
pe  -> Canvas r
canvasCanvas r -> (Canvas r -> Canvas r) -> Canvas r
forall a b. a -> (a -> b) -> b
&(Maybe (Point 2 Int) -> Identity (Maybe (Point 2 Int)))
-> Canvas r -> Identity (Canvas r)
forall s a. HasMousePosition s a => Lens' s a
Lens' (Canvas r) (Maybe (Point 2 Int))
mousePosition ((Maybe (Point 2 Int) -> Identity (Maybe (Point 2 Int)))
 -> Canvas r -> Identity (Canvas r))
-> Point 2 Int -> Canvas r -> Canvas r
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (Int -> Int -> Point 2 Int) -> (Int, Int) -> Point 2 Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 (PointerEvent -> (Int, Int)
offset' PointerEvent
pe)
  PointerLeave PointerEvent
_   -> Canvas r
canvasCanvas r -> (Canvas r -> Canvas r) -> Canvas r
forall a b. a -> (a -> b) -> b
&(Maybe (Point 2 Int) -> Identity (Maybe (Point 2 Int)))
-> Canvas r -> Identity (Canvas r)
forall s a. HasMousePosition s a => Lens' s a
Lens' (Canvas r) (Maybe (Point 2 Int))
mousePosition ((Maybe (Point 2 Int) -> Identity (Maybe (Point 2 Int)))
 -> Canvas r -> Identity (Canvas r))
-> Maybe (Point 2 Int) -> Canvas r -> Canvas r
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Point 2 Int)
forall a. Maybe a
Nothing
  -- TouchStart p     -> canvas&mousePosition ?~ p
  -- TouchMove p     -> canvas&mousePosition ?~ p
  -- TouchEnd        -> canvas&mousePosition .~ Nothing



--------------------------------------------------------------------------------
-- * The View

-- | Draws the actual canvas using an svg tag
svgCanvas_               :: (RealFrac r, ToSvgCoordinate r)
                         => Canvas r
                         -> [Attribute action] -> [View model action]
                         -> View model (Either InternalCanvasAction action)
svgCanvas_ :: forall r action model.
(RealFrac r, ToSvgCoordinate r) =>
Canvas r
-> [Attribute action]
-> [View model action]
-> View model (Either InternalCanvasAction action)
svgCanvas_ Canvas r
canvas [Attribute action]
ats [View model action]
vs =
  [Attribute (Either InternalCanvasAction action)]
-> [View model (Either InternalCanvasAction action)]
-> View model (Either InternalCanvasAction action)
forall action model.
[Attribute action] -> [View model action] -> View model action
svg_ ([ Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
width_    (Text -> Attribute (Either InternalCanvasAction action))
-> (Int -> Text)
-> Int
-> Attribute (Either InternalCanvasAction action)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
forall str. ToMisoString str => str -> Text
ms (Int -> Attribute (Either InternalCanvasAction action))
-> Int -> Attribute (Either InternalCanvasAction action)
forall a b. (a -> b) -> a -> b
$ Int
w
        , Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
height_   (Text -> Attribute (Either InternalCanvasAction action))
-> (Int -> Text)
-> Int
-> Attribute (Either InternalCanvasAction action)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
forall str. ToMisoString str => str -> Text
ms (Int -> Attribute (Either InternalCanvasAction action))
-> Int -> Attribute (Either InternalCanvasAction action)
forall a b. (a -> b) -> a -> b
$ Int
h
        , Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
pointerEvents_ Text
"all"
        ] [Attribute (Either InternalCanvasAction action)]
-> [Attribute (Either InternalCanvasAction action)]
-> [Attribute (Either InternalCanvasAction action)]
forall a. Semigroup a => a -> a -> a
<> ((action -> Either InternalCanvasAction action)
-> Attribute action
-> Attribute (Either InternalCanvasAction action)
forall a b. (a -> b) -> Attribute a -> Attribute b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap action -> Either InternalCanvasAction action
forall a b. b -> Either a b
Right (Attribute action
 -> Attribute (Either InternalCanvasAction action))
-> [Attribute action]
-> [Attribute (Either InternalCanvasAction action)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attribute action]
ats))
       [ [Attribute (Either InternalCanvasAction action)]
-> [View model (Either InternalCanvasAction action)]
-> View model (Either InternalCanvasAction action)
forall action model.
[Attribute action] -> [View model action] -> View model action
svg_ [ Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
width_          Text
"100%"
              , (PointerEvent -> Either InternalCanvasAction action)
-> Attribute (Either InternalCanvasAction action)
forall action. (PointerEvent -> action) -> Attribute action
onPointerLeave ((PointerEvent -> Either InternalCanvasAction action)
 -> Attribute (Either InternalCanvasAction action))
-> (PointerEvent -> Either InternalCanvasAction action)
-> Attribute (Either InternalCanvasAction action)
forall a b. (a -> b) -> a -> b
$ InternalCanvasAction -> Either InternalCanvasAction action
forall a b. a -> Either a b
Left (InternalCanvasAction -> Either InternalCanvasAction action)
-> (PointerEvent -> InternalCanvasAction)
-> PointerEvent
-> Either InternalCanvasAction action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PointerEvent -> InternalCanvasAction
PointerLeave
              , (PointerEvent -> Either InternalCanvasAction action)
-> Attribute (Either InternalCanvasAction action)
forall action. (PointerEvent -> action) -> Attribute action
onPointerEnter ((PointerEvent -> Either InternalCanvasAction action)
 -> Attribute (Either InternalCanvasAction action))
-> (PointerEvent -> Either InternalCanvasAction action)
-> Attribute (Either InternalCanvasAction action)
forall a b. (a -> b) -> a -> b
$ InternalCanvasAction -> Either InternalCanvasAction action
forall a b. a -> Either a b
Left (InternalCanvasAction -> Either InternalCanvasAction action)
-> (PointerEvent -> InternalCanvasAction)
-> PointerEvent
-> Either InternalCanvasAction action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PointerEvent -> InternalCanvasAction
PointerEnter
              , (PointerEvent -> Either InternalCanvasAction action)
-> Attribute (Either InternalCanvasAction action)
forall action. (PointerEvent -> action) -> Attribute action
onPointerMove  ((PointerEvent -> Either InternalCanvasAction action)
 -> Attribute (Either InternalCanvasAction action))
-> (PointerEvent -> Either InternalCanvasAction action)
-> Attribute (Either InternalCanvasAction action)
forall a b. (a -> b) -> a -> b
$ InternalCanvasAction -> Either InternalCanvasAction action
forall a b. a -> Either a b
Left (InternalCanvasAction -> Either InternalCanvasAction action)
-> (PointerEvent -> InternalCanvasAction)
-> PointerEvent
-> Either InternalCanvasAction action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PointerEvent -> InternalCanvasAction
PointerMove
              -- , onTouchStartAt $ Left . TouchStart
              -- , onTouchMoveAt  $ Left . TouchMove
              -- , onTouchEnd     $ Left TouchEnd
              ]
              [ [Attribute (Either InternalCanvasAction action)]
-> View model (Either InternalCanvasAction action)
forall action model. [Attribute action] -> View model action
rect_ [Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
width_ Text
"100%", Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
height_ Text
"100%", Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
fill_ Text
"none"]
              , [Attribute (Either InternalCanvasAction action)]
-> [View model (Either InternalCanvasAction action)]
-> View model (Either InternalCanvasAction action)
forall action model.
[Attribute action] -> [View model action] -> View model action
g_ [Text -> Attribute (Either InternalCanvasAction action)
forall action. Text -> Attribute action
transform_ Text
ts] ((action -> Either InternalCanvasAction action)
-> View model action
-> View model (Either InternalCanvasAction action)
forall a b. (a -> b) -> View model a -> View model b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap action -> Either InternalCanvasAction action
forall a b. b -> Either a b
Right (View model action
 -> View model (Either InternalCanvasAction action))
-> [View model action]
-> [View model (Either InternalCanvasAction action)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [View model action]
vs)
              ]
       ]
    -- note; we use the two nested svgs so that we can handle additional mouseMove, Enter,
    -- and leave events specified in ats. The pointerEvents=all in the outer svg is needed
    -- so that we can also capture the mousemove etc events in the inner svg. The rect
    -- is so that the inner svg is actually forced to be the full size.
  where
    (Vector2 Int
w Int
h) = Canvas r
canvasCanvas r
-> Getting (Vector 2 Int) (Canvas r) (Vector 2 Int) -> Vector 2 Int
forall s a. s -> Getting a s a -> a
^.Getting (Vector 2 Int) (Canvas r) (Vector 2 Int)
forall s a. HasDimensions s a => Lens' s a
Lens' (Canvas r) (Vector 2 Int)
dimensions
    ts :: Text
ts = Matrix 3 3 r -> Text
forall r. ToSvgCoordinate r => Matrix 3 3 r -> Text
matrixToMisoString (Matrix 3 3 r -> Text) -> Matrix 3 3 r -> Text
forall a b. (a -> b) -> a -> b
$ Canvas r
canvasCanvas r
-> Getting (Matrix 3 3 r) (Canvas r) (Matrix 3 3 r) -> Matrix 3 3 r
forall s a. s -> Getting a s a -> a
^.(Viewport r -> Const (Matrix 3 3 r) (Viewport r))
-> Canvas r -> Const (Matrix 3 3 r) (Canvas r)
forall r s (f :: * -> *).
Functor f =>
(Viewport r -> f (Viewport s)) -> Canvas r -> f (Canvas s)
theViewport((Viewport r -> Const (Matrix 3 3 r) (Viewport r))
 -> Canvas r -> Const (Matrix 3 3 r) (Canvas r))
-> ((Matrix 3 3 r -> Const (Matrix 3 3 r) (Matrix 3 3 r))
    -> Viewport r -> Const (Matrix 3 3 r) (Viewport r))
-> Getting (Matrix 3 3 r) (Canvas r) (Matrix 3 3 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Transformation 2 r -> Const (Matrix 3 3 r) (Transformation 2 r))
-> Viewport r -> Const (Matrix 3 3 r) (Viewport r)
forall r (f :: * -> *).
Functor f =>
(Transformation 2 r -> f (Transformation 2 r))
-> Viewport r -> f (Viewport r)
worldToHost((Transformation 2 r -> Const (Matrix 3 3 r) (Transformation 2 r))
 -> Viewport r -> Const (Matrix 3 3 r) (Viewport r))
-> ((Matrix 3 3 r -> Const (Matrix 3 3 r) (Matrix 3 3 r))
    -> Transformation 2 r -> Const (Matrix 3 3 r) (Transformation 2 r))
-> (Matrix 3 3 r -> Const (Matrix 3 3 r) (Matrix 3 3 r))
-> Viewport r
-> Const (Matrix 3 3 r) (Viewport r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Matrix 3 3 r -> Const (Matrix 3 3 r) (Matrix 3 3 r))
-> Transformation 2 r -> Const (Matrix 3 3 r) (Transformation 2 r)
(Matrix (2 + 1) (2 + 1) r
 -> Const (Matrix 3 3 r) (Matrix (2 + 1) (2 + 1) r))
-> Transformation 2 r -> Const (Matrix 3 3 r) (Transformation 2 r)
forall (d :: Nat) r s (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (Matrix (d + 1) (d + 1) r) (f (Matrix (d + 1) (d + 1) s))
-> p (Transformation d r) (f (Transformation d s))
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 model 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 model action] -> View model action

-- render       :: RenderWebSvg t => t -> [Attribute action] -> View model 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

--------------------------------------------------------------------------------
-- * Canvas events that we should isten to

-- | Events a canvas wants to listen to
withCanvasEvents :: Events -> Events
withCanvasEvents :: Events -> Events
withCanvasEvents = ((Events
touchEvents Events -> Events -> Events
forall a. Semigroup a => a -> a -> a
<> Events
pointerEvents Events -> Events -> Events
forall a. Semigroup a => a -> a -> a
<> Events
custom) Events -> Events -> Events
forall a. Semigroup a => a -> a -> a
<>)
  where
    custom :: Events
custom = [(Text, Phase)] -> Events
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
             [ (Text
"contextmenu" , Phase
CAPTURE)
             ]

-- -- | Subscription needed for the iCanvas. In particular, captures the
-- -- mouse position
-- subs     :: MisoString -- ^ The id of the iCanvas
--                 -> (InternalCanvasAction -> action)
--                 -> [Sub action]
-- subs i f = [ relativePointerSub   i (f . PointerMove)
--            , relativeTouchedSub i (f . TouchMove)
--                   -- , arrowsSub          (f . ArrowPress)
--            ]