diff --git a/hgeometry-examples/polyLineDrawing/Main.hs b/hgeometry-examples/polyLineDrawing/Main.hs index 91953a866..c8ba00a0e 100644 --- a/hgeometry-examples/polyLineDrawing/Main.hs +++ b/hgeometry-examples/polyLineDrawing/Main.hs @@ -25,7 +25,7 @@ import qualified HGeometry.Miso.Svg.Canvas as Canvas import HGeometry.Number.Real.Rational import HGeometry.Point import HGeometry.PolyLine -import HGeometry.PolyLine.Simplification.DouglasPeucker +-- import HGeometry.PolyLine.Simplification.DouglasPeucker import HGeometry.Sequence.NonEmpty import HGeometry.Vector import qualified Language.Javascript.JSaddle.Warp as JSaddle @@ -34,7 +34,6 @@ import Miso.Event.Extra import qualified Miso.Html.Element as Html import Miso.String (MisoString,ToMisoString(..), ms) import Miso.Svg hiding (height_, id_, style_, width_) -import Miso.Util ((=:)) import Debug.Trace -------------------------------------------------------------------------------- @@ -105,6 +104,7 @@ backgroundColor = RGB 246 246 246 data Thickness = Thin | Normal | Thick deriving (Show,Read,Eq,Ord) +toInt :: Thickness -> MisoString toInt = ms @Int . \case Thin -> 1 Normal -> 2 @@ -156,8 +156,8 @@ initialModel = Model { _canvas = blankCanvas 400 400 data Action = Id - | CanvasAction Canvas.InternalCanvasAction - | WindowResize (Vector 2 Int) + | CanvasAction !Canvas.InternalCanvasAction + | WindowResize !(Vector 2 Int) | SwitchMode | CanvasClicked | CanvasRightClicked @@ -172,12 +172,18 @@ data Action = Id | SelectColor {-# UNPACK #-}!Int {-# UNPACK #-}!Color deriving (Show,Eq) +windowDeltas :: Vector 2 Int windowDeltas = Vector2 50 200 + + + + updateModel :: Model -> Action -> Effect Action Model updateModel m = \case Id -> noEff m - CanvasAction ca -> m&canvas %%~ flip Canvas.handleInternalCanvasAction ca + CanvasAction ca -> traceShow ("canvas act: ",ca) $ + m&canvas %%~ flip Canvas.handleInternalCanvasAction ca WindowResize dims -> noEff $ m&canvas.dimensions .~ (dims ^-^ windowDeltas) SwitchMode -> noEff $ m&mode %~ switchMode CanvasClicked -> case m^.mode of @@ -186,20 +192,15 @@ updateModel m = \case CanvasRightClicked -> case m^.mode of PolyLineMode -> m <# pure AddPoly PenMode -> noEff m - StartMouseDown -> case m^.mode of - PolyLineMode -> noEff m - PenMode -> noEff $ m¤tPoly .~ extend Nothing - StopMouseDown -> case m^.mode of - PolyLineMode -> noEff m - PenMode -> m <# pure AddPoly - - StartTouch -> m <# pure StartMouseDown - TouchMove -> m <# pure MouseMove - EndTouch -> m <# pure StopMouseDown - - MouseMove -> case m^.mode of - PolyLineMode -> noEff m - PenMode -> mouseMoveAction + + StartMouseDown -> startMouseDown + MouseMove -> mouseMove + StopMouseDown -> stopMouseDown + + StartTouch -> traceShow ("startTouch",m^.canvas.mouseCoordinates) startMouseDown + TouchMove -> traceShow ("touchMove",m^.canvas.mouseCoordinates) mouseMove + EndTouch -> traceShow ("endTouch",m^.canvas.mouseCoordinates) stopMouseDown + AddPoint -> addPoint AddPoly -> addPoly SelectColor i c -> let setColor a = a&color .~ c @@ -208,6 +209,18 @@ updateModel m = \case &quickColors.ix i .~ c where + startMouseDown = case m^.mode of + PolyLineMode -> noEff m + PenMode -> noEff $ m¤tPoly .~ extend Nothing + mouseMove = case m^.mode of + PolyLineMode -> noEff m + PenMode -> noEff $ m¤tPoly %~ \mp -> case mp of + Nothing -> Nothing + Just _ -> extend mp + stopMouseDown = case m^.mode of + PolyLineMode -> noEff m + PenMode -> m <# pure AddPoly + extend = extendWith (m^.canvas.mouseCoordinates) addPoint = noEff $ m¤tPoly %~ extend @@ -218,9 +231,7 @@ updateModel m = \case Just (PartialPolyLine x) -> insertPoly (x :+ m^.currentAttrs) _ -> id - mouseMoveAction = noEff $ m¤tPoly %~ \mp -> case mp of - Nothing -> Nothing - Just _ -> extend mp + -- | Extend the current partial polyline with the given point (if it is on the canvas.) extendWith :: Eq r => Maybe (Point 2 r) @@ -246,14 +257,16 @@ insertPoly p m = let k = case IntMap.lookupMax m of viewModel :: Model -> View Action viewModel m = - div_ [ + div_ [ styleM_ [ "display" =: "flex" + , "flex-direction" =: "column" + ] ] [ theToolbar m , theCanvas m , iconLink ] - +singleton :: a -> [a] singleton = (:[]) buttonGroup :: Foldable f @@ -341,7 +354,11 @@ colorPickerButton selected i c = theCanvas :: Model -> View Action theCanvas m = - div_ [ id_ "canvas" ] + div_ [ id_ "canvas" + , styleM_ [ "margin-left" =: "auto" + , "margin-right" =: "auto" + ] + ] [ either CanvasAction id <$> Canvas.svgCanvas_ (m^.canvas) [ onClick CanvasClicked @@ -366,8 +383,8 @@ theCanvas m = [ text . ms . show $ m^.mode ] , div_ [] [text . ms . show $ m^.canvas.mouseCoordinates ] - -- , div_ [] - -- [text . ms . show $ m^.polyLines ] + , div_ [] + [text . ms . show $ m^.currentPoly ] , Html.style_ [] $ unlines' [ "html { overscroll-behavior: none; }" -- prevent janky scrolling on ipad , "html body { overflow: hidden; }" -- more weird scrolling prevent diff --git a/hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs b/hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs index a5e50f785..11e893233 100644 --- a/hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs +++ b/hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs @@ -83,22 +83,22 @@ blankCanvas w h = let v = Vector2 w h -- * The Controller -- | Actions that CanvasAction will handle itself. -data InternalCanvasAction = MouseEnter (Point 2 Int) - | MouseMove (Point 2 Int) +data InternalCanvasAction = MouseEnter !(Point 2 Int) + | MouseMove !(Point 2 Int) | MouseLeave - | TouchStart (Point 2 Int) - | TouchMove (Point 2 Int) + | TouchStart !(Point 2 Int) + | TouchMove !(Point 2 Int) | TouchEnd deriving (Show,Eq) -- | Handles InternalCanvas Actions handleInternalCanvasAction :: Canvas r -> InternalCanvasAction -> Effect action (Canvas r) handleInternalCanvasAction canvas = noEff . \case - MouseEnter p -> canvas&mousePosition .~ Just p - MouseMove p -> canvas&mousePosition .~ Just p + MouseEnter p -> canvas&mousePosition ?~ p + MouseMove p -> canvas&mousePosition ?~ p MouseLeave -> canvas&mousePosition .~ Nothing - TouchStart p -> canvas&mousePosition .~ Just p - TouchMove p -> canvas&mousePosition .~ Just p + TouchStart p -> canvas&mousePosition ?~ p + TouchMove p -> canvas&mousePosition ?~ p TouchEnd -> canvas&mousePosition .~ Nothing -------------------------------------------------------------------------------- diff --git a/hgeometry/web/src/Miso/Subscription/MouseExtra.hs b/hgeometry/web/src/Miso/Subscription/MouseExtra.hs index e2ba0b6f3..06ed44371 100644 --- a/hgeometry/web/src/Miso/Subscription/MouseExtra.hs +++ b/hgeometry/web/src/Miso/Subscription/MouseExtra.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant lambda" #-} module Miso.Subscription.MouseExtra @@ -10,9 +11,10 @@ module Miso.Subscription.MouseExtra , onTouchEnd ) where +import Control.Monad ((<=<)) import Control.Monad.IO.Class import Data.Aeson (withObject, withArray, (.:), Value) -import Data.Aeson.Types (Parser) +import Data.Aeson.Types (Parser, parseEither) import qualified Data.Foldable as F import GHCJS.Marshal import HGeometry.Point @@ -22,9 +24,10 @@ import JavaScript.Object.Internal import Language.Javascript.JSaddle (JSVal) import Miso import Miso.FFI.Extra -import Miso.String (MisoString) +import Miso.String (MisoString, unpack) -import Debug.Trace + +import Debug.Trace -------------------------------------------------------------------------------- -- | onMouseMove event, the position is relative to the target of the event @@ -51,11 +54,11 @@ mousePositionDecoder = Decoder dec dt -- | On start of a touch event, onTouchStartAt :: (Point 2 Int -> action) -> Attribute action -onTouchStartAt = on "touchstart" touchDecoder +onTouchStartAt = onRelativeTo "touchstart" touchDecoder -- | On touchMove event onTouchMoveAt :: (Point 2 Int -> action) -> Attribute action -onTouchMoveAt = on "touchmove" touchDecoder +onTouchMoveAt = onRelativeTo "touchmove" touchDecoder -- | onTouchEnd event onTouchEnd :: action -> Attribute action @@ -69,102 +72,70 @@ touchDecoder = Decoder dec dt dec :: Value -> Parser (Point 2 Int) dec = withArray "targetTouches" $ \arr -> case F.toList arr of (tv:_) -> flip (withObject "touch") tv $ \t -> - Point2 <$> t .: "pageX" <*> t .: "pageY" + Point2 <$> t .: "clientX" <*> t .: "clientY" _ -> fail "touchDecoder: expected at least one targetTouches" -------------------------------------------------------------------------------- --- | A DOMRect -data DOMRect = DOMRect { top :: {-# UNPACK #-} !Int - , left :: {-# UNPACK #-} !Int - , width :: {-# UNPACK #-} !Int - , height :: {-# UNPACK #-} !Int - } deriving (Show,Eq) - -getBoundingRect :: JSVal -> JSM DOMRect -getBoundingRect elem' = do - rect <- Object <$> getBoundingClientRect elem' - Just l <- fromJSVal =<< getProp "left" rect - Just t <- fromJSVal =<< getProp "top" rect - Just w <- fromJSVal =<< getProp "width" rect - Just h <- fromJSVal =<< getProp "height" 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) +-- -- | A DOMRect +-- data DOMRect = DOMRect { top :: {-# UNPACK #-} !Int +-- , left :: {-# UNPACK #-} !Int +-- , width :: {-# UNPACK #-} !Int +-- , height :: {-# UNPACK #-} !Int +-- } deriving (Show,Eq) + +-- getBoundingRect :: JSVal -> JSM DOMRect +-- getBoundingRect elem' = do +-- rect <- Object <$> getBoundingClientRect elem' +-- Just l <- fromJSVal =<< getProp "left" rect +-- Just t <- fromJSVal =<< getProp "top" rect +-- Just w <- fromJSVal =<< getProp "width" rect +-- Just h <- fromJSVal =<< getProp "height" 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) -------------------------------------------------------------------------------- - --- touchDecoder :: Decoder (Point 2 Int) --- touchDecoder = Decoder dec dt --- where --- dt = DecodeTarget ["targetTouches"] --- dec :: Value -> Parser (Point 2 Int) --- dec = withArray "targetTouches" $ \arr -> case F.toList arr of --- (tv:_) -> flip (withObject "touch") tv $ \t -> do --- clientXY <- Point2 <$> t .: "clientX" <*> t .: "clientY" --- target <- traceShow arr $ t .: "target" --- clientLR <- clientCoords target --- pure $ clientXY .-^ clientLR - --- _ -> fail "touchDecoder: expected at least one targetTouches" - --- clientCoords = withObject "target-client" $ \o -> --- Vector2 <$> o .: "clientLeft" <*> o .: "clientTop" - - --- -- | The decoder of touch events, gets the touchTarget of the input --- touchDecoder :: Decoder (Point 2 Int) --- touchDecoder = Decoder dec dt --- where --- dt = DecodeTarget mempty --- dec = withObject "event" $ \e -> traceShow e $ --- do --target <- e .:" target" --- -- Vector2 cl ct <- clientCoords target --- tts <- e .: "targetTouches" --- f tts - --- f :: Value -> Parser (Point 2 Int) --- f = withArray "targetTouches-array" $ \arr -> case F.toList arr of --- (tv:_) -> flip (withObject "touch") tv $ \o -> --- Point2 <$> o .: "clientX" <*> o .: "clientY" --- _ -> fail "touchDecoder: expected at least one targetTouches" - - - -- clientCoords = withObject "target-client" $ \o -> - -- Vector2 <$> o .: "clientLeft" <*> o .: "clientTop" - - - --- onWithOptions --- :: Options --- -> MisoString --- -> Decoder r --- -> (r -> action) --- -> Attribute action --- onWithOptions options eventName Decoder{..} toAction = --- E $ \sink n -> do --- eventObj <- getProp "events" n --- eventHandlerObject@(Object eo) <- create --- jsOptions <- toJSVal options --- decodeAtVal <- toJSVal decodeAt --- cb <- callbackToJSVal <=< asyncCallback1 $ \e -> do --- Just v <- fromJSVal =<< objectToJSON decodeAtVal e --- case parseEither decoder v of --- Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s --- Right r -> liftIO (sink (toAction r)) --- set "runEvent" cb eventHandlerObject --- registerCallback cb --- set "options" jsOptions eventHandlerObject --- set eventName eo (Object eventObj) +-- | A version of onWithOptions that also decodes the left, top, and clientLeft and clientTop +-- values of the target element. +onRelativeTo :: MisoString -> Decoder (Point 2 Int) -> (Point 2 Int -> action) + -> Attribute action +onRelativeTo eventName Decoder{..} toAction = + E $ \sink n -> do + eventObj <- getProp "events" n + eventHandlerObject@(Object eo) <- create + jsOptions <- toJSVal options + decodeAtVal <- toJSVal decodeAt + cb <- callbackToJSVal <=< asyncCallback1 $ \event -> do + Just target <- fromJSVal =<< unsafeGetProp "target" (Object event) + rect <- Object <$> getBoundingClientRect target + Just l <- fromJSVal =<< unsafeGetProp "left" rect + Just t <- fromJSVal =<< unsafeGetProp "top" rect + Just cl <- fromJSVal =<< unsafeGetProp "clientLeft" (Object target) + Just ct <- fromJSVal =<< unsafeGetProp "clientTop" (Object target) + Just v <- fromJSVal =<< objectToJSON decodeAtVal event + case parseEither decoder v of + Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s + Right p -> do let p' = p .-^ Vector2 (l+cl) (t+ct) + liftIO $ print $ show eventName <> show (l,t,cl,ct,p, p') + liftIO $ sink (toAction p') + set "runEvent" cb eventHandlerObject + registerCallback cb + set "options" jsOptions eventHandlerObject + set eventName eo (Object eventObj) + where + options = defaultOptions { preventDefault = True + , stopPropagation = False + }