Skip to content

Commit

Permalink
touch event handling; not working quite yet :(
Browse files Browse the repository at this point in the history
  • Loading branch information
@noinia
noinia committed Dec 31, 2023
1 parent 46b1af8 commit c52e144
Show file tree
Hide file tree
Showing 3 changed files with 118 additions and 130 deletions.
71 changes: 44 additions & 27 deletions hgeometry-examples/polyLineDrawing/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
--------------------------------------------------------------------------------
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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&currentPoly .~ 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
Expand All @@ -208,6 +209,18 @@ updateModel m = \case
&quickColors.ix i .~ c

where
startMouseDown = case m^.mode of
PolyLineMode -> noEff m
PenMode -> noEff $ m&currentPoly .~ extend Nothing
mouseMove = case m^.mode of
PolyLineMode -> noEff m
PenMode -> noEff $ m&currentPoly %~ \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&currentPoly %~ extend

Expand All @@ -218,9 +231,7 @@ updateModel m = \case
Just (PartialPolyLine x) -> insertPoly (x :+ m^.currentAttrs)
_ -> id

mouseMoveAction = noEff $ m&currentPoly %~ \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)
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
16 changes: 8 additions & 8 deletions hgeometry/svg/src/HGeometry/Miso/Svg/Canvas.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

--------------------------------------------------------------------------------
Expand Down
161 changes: 66 additions & 95 deletions hgeometry/web/src/Miso/Subscription/MouseExtra.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant lambda" #-}
module Miso.Subscription.MouseExtra
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
}

0 comments on commit c52e144

Please sign in to comment.