diff --git a/hgeometry-examples/convexHull/Main.hs b/hgeometry-examples/convexHull/Main.hs index feac7ec9f..2a1f52069 100644 --- a/hgeometry-examples/convexHull/Main.hs +++ b/hgeometry-examples/convexHull/Main.hs @@ -84,7 +84,6 @@ viewModel m = div_ [ ] [ either CanvasAction id <$> Canvas.svgCanvas_ (m^.canvas) [ onClick AddPoint - , id_ "mySvg" , styleInline_ "border: 1px solid black" ] canvasBody @@ -109,7 +108,7 @@ viewModel m = div_ [ ] , textAt p [] (ms i) ] | (i,p) <- m^..points.ifolded.withIndex ] - <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] + -- <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] -------------------------------------------------------------------------------- @@ -119,11 +118,8 @@ main = JSaddle.run 8080 $ App { model = initialModel , update = flip updateModel , view = viewModel - , subs = Canvas.subs "mySvg" CanvasAction - , events = Map.insert "touchstart" False - . Map.insert "touchmove" False - . Map.insert "mousemove" False - $ defaultEvents + , subs = mempty + , events = Canvas.withCanvasEvents defaultEvents , initialAction = Id , mountPoint = Nothing , logLevel = Off diff --git a/hgeometry-examples/duality/Main.hs b/hgeometry-examples/duality/Main.hs index 4d780eecc..cdd323c1e 100644 --- a/hgeometry-examples/duality/Main.hs +++ b/hgeometry-examples/duality/Main.hs @@ -106,14 +106,12 @@ viewModel m = div_ [ ] [ either PrimalCanvasAction id <$> Canvas.svgCanvas_ (m^.primalCanvas) [ onClick PrimalClick - , id_ "primalSvg" , styleInline_ "border: 1px solid black" ] primalBody , either DualCanvasAction id <$> Canvas.svgCanvas_ (m^.dualCanvas) [ onClick DualClick - , id_ "dualSvg" , styleInline_ "border: 1px solid black" ] dualBody @@ -142,7 +140,7 @@ viewModel m = div_ [ ] ] ] | l :+ color <- m^..lines.folded ] - <> [ draw p [ fill_ "blue" ] | Just p <- [mousePos] ] + -- <> [ draw p [ fill_ "blue" ] | Just p <- [mousePos] ] instance Drawable (LineEQ R) where draw l = let maxP = Point2 large large @@ -161,12 +159,8 @@ main = JSaddle.run 8080 $ App { model = initialModel , update = flip updateModel , view = viewModel - , subs = Canvas.subs "primalSvg" PrimalCanvasAction - <> Canvas.subs "dualSvg" DualCanvasAction - , events = Map.insert "touchstart" False - . Map.insert "touchmove" False - . Map.insert "mousemove" False - $ defaultEvents + , subs = mempty + , events = Canvas.withCanvasEvents defaultEvents , initialAction = Id , mountPoint = Nothing , logLevel = Off diff --git a/hgeometry-examples/lineSegmentIntersection/Main.hs b/hgeometry-examples/lineSegmentIntersection/Main.hs index 3d9f5082c..019d63046 100644 --- a/hgeometry-examples/lineSegmentIntersection/Main.hs +++ b/hgeometry-examples/lineSegmentIntersection/Main.hs @@ -4,7 +4,6 @@ module Main(main) where import Control.Lens hiding (view, element) import qualified Data.IntMap as IntMap -import qualified Data.Map as Map import GHC.TypeNats import HGeometry.Ext import HGeometry.LineSegment @@ -111,7 +110,7 @@ viewModel m = div_ [ ] <> [ g_ [] [ draw p [ fill_ "red"] ] | p <- m^..intersections.to intersectionPoints.folded ] - <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] + -- <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] partialSegment p q = [ClosedLineSegment <$> p <*> q ] @@ -126,14 +125,8 @@ mainJSM = do let myApp = App { model = initialModel , update = flip updateModel , view = viewModel - , subs = Canvas.subs "mySvg" CanvasAction - <> [ - -- arrowsSub (CanvasAction . ArrowPress) - ] - , events = Map.insert "touchstart" False - . Map.insert "touchmove" False - . Map.insert "mousemove" False - $ defaultEvents + , subs = mempty + , events = Canvas.withCanvasEvents defaultEvents , initialAction = Id , mountPoint = Nothing , logLevel = Off diff --git a/hgeometry-examples/polyLineDrawing/Main.hs b/hgeometry-examples/polyLineDrawing/Main.hs index fd918c9e1..82c3417db 100644 --- a/hgeometry-examples/polyLineDrawing/Main.hs +++ b/hgeometry-examples/polyLineDrawing/Main.hs @@ -185,6 +185,7 @@ viewModel m = div_ [ ] [ "html { overscroll-behavior: none; }" , "html body { overflow: hidden; }" ] + -- these two lines prevent weird janky scrolling on ipad ] where unlines' = mconcat . List.intersperse "\n" diff --git a/hgeometry-examples/polygonTriangulation/Main.hs b/hgeometry-examples/polygonTriangulation/Main.hs index af6d435c8..0a089f406 100644 --- a/hgeometry-examples/polygonTriangulation/Main.hs +++ b/hgeometry-examples/polygonTriangulation/Main.hs @@ -107,7 +107,7 @@ viewModel m = div_ [ ] , textAt p [] (ms i) ] | (i,p) <- m^..points.ifolded.withIndex ] - <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] + -- <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] -------------------------------------------------------------------------------- @@ -117,11 +117,8 @@ main = JSaddle.run 8080 $ App { model = initialModel , update = flip updateModel , view = viewModel - , subs = Canvas.subs "mySvg" CanvasAction - , events = Map.insert "touchstart" False - . Map.insert "touchmove" False - . Map.insert "mousemove" False - $ defaultEvents + , subs = mempty + , events = Canvas.withCanvasEvents defaultEvents , initialAction = Id , mountPoint = Nothing , logLevel = Off diff --git a/hgeometry-examples/voronoiDiagram/Main.hs b/hgeometry-examples/voronoiDiagram/Main.hs index b4bca26d9..cc6470ab6 100644 --- a/hgeometry-examples/voronoiDiagram/Main.hs +++ b/hgeometry-examples/voronoiDiagram/Main.hs @@ -87,7 +87,6 @@ viewModel m = div_ [ ] [ either CanvasAction id <$> Canvas.svgCanvas_ (m^.canvas) [ onClick AddPoint - , id_ "mySvg" , styleInline_ "border: 1px solid black" ] canvasBody @@ -108,7 +107,7 @@ viewModel m = div_ [ ] , textAt p [] (ms i) ] | (i,p) <- m^..points.ifolded.withIndex ] - <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] + -- <> [ draw p [ fill_ "blue" ] | Just p <- [m^.canvas.mouseCoordinates] ] -------------------------------------------------------------------------------- @@ -118,11 +117,8 @@ main = JSaddle.run 8080 $ App { model = initialModel , update = flip updateModel , view = viewModel - , subs = Canvas.subs "mySvg" CanvasAction - , events = Map.insert "touchstart" False - . Map.insert "touchmove" False - . Map.insert "mousemove" False - $ defaultEvents + , subs = mempty + , events = Canvas.withCanvasEvents defaultEvents , initialAction = Id , mountPoint = Nothing , logLevel = Off diff --git a/hgeometry/hgeometry.cabal b/hgeometry/hgeometry.cabal index 36312ea26..c993847a5 100644 --- a/hgeometry/hgeometry.cabal +++ b/hgeometry/hgeometry.cabal @@ -467,9 +467,8 @@ library svg HGeometry.Miso.Svg.Canvas HGeometry.Svg - Miso.Subscription.MouseExtra - other-modules: + Miso.Subscription.MouseExtra HGeometry.Miso.Svg.Writer Miso.String.Util Miso.FFI.Extra diff --git a/hgeometry/web/src/Miso/Subscription/MouseExtra.hs b/hgeometry/web/src/Miso/Subscription/MouseExtra.hs index 38219784d..e9626d931 100644 --- a/hgeometry/web/src/Miso/Subscription/MouseExtra.hs +++ b/hgeometry/web/src/Miso/Subscription/MouseExtra.hs @@ -2,12 +2,9 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant lambda" #-} module Miso.Subscription.MouseExtra - ( relativeMouseSub - , relativeTouchedSub - , onMouseEnterAt + ( onMouseEnterAt , onMouseMoveAt , onMouseClickAt - , onTouchStartAt , onTouchMoveAt , onTouchEnd @@ -26,8 +23,6 @@ import Miso import Miso.FFI.Extra import Miso.String (MisoString) -import Debug.Trace - -------------------------------------------------------------------------------- -- | onMouseMove event, the position is relative to the target of the event @@ -52,15 +47,19 @@ mousePositionDecoder = Decoder dec dt -------------------------------------------------------------------------------- +-- | On start of a touch event, onTouchStartAt :: (Point 2 Int -> action) -> Attribute action onTouchStartAt = on "touchstart" touchDecoder +-- | On touchMove event onTouchMoveAt :: (Point 2 Int -> action) -> Attribute action onTouchMoveAt = on "touchmove" touchDecoder +-- | onTouchEnd event onTouchEnd :: action -> Attribute action onTouchEnd act = on "touchend" emptyDecoder (const act) +-- | The decoder of touch events, gets the touchTarget of the input touchDecoder :: Decoder (Point 2 Int) touchDecoder = Decoder dec dt where @@ -70,109 +69,3 @@ touchDecoder = Decoder dec dt (tv:_) -> withObject "touch" (\o -> Point2 <$> o .: "pageX" <*> o .: "pageY") tv _ -> fail "touchDecoder: expected at least one targetTouches" - - --- -- | touchmove event --- onTouchMove :: (TouchEvent -> action) -> Attribute action --- onTouchMove = on "touchmove" touchDecoder - - - - - --------------------------------------------------------------------------------- - --- | Gets the mouse position relative to the element named by the first argument -relativeMouseSub :: MisoString -> (Maybe (Point 2 Int) -> action) -> Sub action -relativeMouseSub elemId f = \sink -> do - windowAddEventListener "mousemove" $ relativeMouseSubImpl elemId f sink - --- | the implementation of the relative Mouse sub -relativeMouseSubImpl :: MisoString -> (Maybe (Point 2 Int) -> action) - -> Sink action - -> JSVal -> JSM () -relativeMouseSubImpl elemId f sink = \mouseEvent -> do - elem' <- getElementById elemId - rect <- getInnerRect elem' - Just x <- fromJSVal =<< getProp "clientX" (Object mouseEvent) - Just y <- fromJSVal =<< getProp "clientY" (Object mouseEvent) - let mp = inDOMRect (Point2 x y) rect - -- see https://stackoverflow.com/questions/10298658/mouse-position-inside-autoscaled-svg - liftIO (sink $ f mp) - --- | Get touchmove events on the given elementId, in coordinates relative to the --- element. -relativeTouchedSub :: MisoString -> (Maybe (Point 2 Int) -> action) -> Sub action -relativeTouchedSub elemId f = \sink -> do - windowAddEventListener "touchmove" $ relativeTouchSubImpl elemId f sink - - --- | the implementation of the relative Mouse sub -relativeTouchSubImpl :: MisoString -> (Maybe (Point 2 Int) -> action) - -> Sink action - -> JSVal -> JSM () -relativeTouchSubImpl elemId f sink = \mouseEvent -> do - elem' <- getElementById elemId - rect <- getInnerRect elem' - Just (x :: Double) <- fromJSVal =<< getProp "pageX" (Object mouseEvent) - Just (y :: Double) <- fromJSVal =<< getProp "pageY" (Object mouseEvent) - let mp = inDOMRect (Point2 (round x) (round y)) rect - -- liftIO (print (rect,x,y,px,py,mp)) - -- see https://stackoverflow.com/questions/10298658/mouse-position-inside-autoscaled-svg - liftIO (sink $ f mp) - --------------------------------------------------------------------------------- - --- | A DOMRect -data DOMRect = DOMRect { top :: {-# UNPACK #-} !Int - , left :: {-# UNPACK #-} !Int - , width :: {-# UNPACK #-} !Int - , height :: {-# UNPACK #-} !Int - } deriving (Show,Eq) - --- | Given a point and a rect, both in global coordinates, returns the relative --- coordinates of the point inside the rect (if the point lies inside the rectangle) (with --- respect to the top-left corner of the rectangle). -inDOMRect :: Point 2 Int -> DOMRect -> Maybe (Point 2 Int) -inDOMRect (Point2 x y) (DOMRect t l w h) - | inInterval x l w && inInterval y t h = Just $ Point2 (x-l) (y-t) - | otherwise = Nothing - where - inInterval q s len = s <= q && q <= s+len - - --- -- | Get the bounding rectangle of the given element, relative to the viewport --- getBoundingBoxOf :: MisoString -> JSM DOMRect --- getBoundingBoxOf elemId = do --- elem' <- getElementById elemId --- getBoundingRect elem' - --- | Get the bounding rectangle of the given element, relative to the viewport - -getBoundingRect :: JSVal -> JSM DOMRect -getBoundingRect elem' = do - rect <- getBoundingClientRect elem' - Just l <- fromJSVal =<< getProp "left" (Object rect) - Just t <- fromJSVal =<< getProp "top" (Object rect) - Just w <- fromJSVal =<< getProp "width" (Object rect) - Just h <- fromJSVal =<< getProp "height" (Object rect) - pure $ DOMRect l t w h - --- | Get the inner rectangle of an element (i.e. without its border) relative to the --- viewport. -getInnerRect :: JSVal -> JSM DOMRect -getInnerRect elem' = do - Just cl <- fromJSVal =<< getProp "clientLeft" (Object elem') - Just ct <- fromJSVal =<< getProp "clientTop" (Object elem') - Just cr <- fromJSVal =<< getProp "clientRight" (Object elem') - Just cb <- fromJSVal =<< getProp "clientBottom" (Object elem') - DOMRect l t w h <- getBoundingRect elem' - pure $ DOMRect (l-cl) (t-ct) (w - cr) (h - cb) - - --- relativePositionIn :: MisoString --- -> --- relativePositionIn elemId f = - - ---------------------------------------------------------------------------------