Commit eb7fd96f authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'coordinates-mouseevents-svg' into 'master'

Extend the mousehandlers with coordinates

See merge request !327
parents be08aea5 dab3c31e
Pipeline #30016 passed with stage
in 4 minutes and 36 seconds
......@@ -166,7 +166,7 @@ sectionImage disabledSections hilite mngmnt zoomed exitLocks hopLocks inventoryM
= { fill = toSVGColor (if isLocked "black" "white") }
doorClick :: !Bool !Coord3D !Dir !(Image (a, MapAction SectionStatus)) -> Image (a, MapAction SectionStatus)
doorClick False c3d dir img = img
doorClick _ c3d dir img = img <@< { onclick = \(x, _) -> (x, ToggleDoor c3d dir), local = False}
doorClick _ c3d dir img = img <@< { onclick = \_ (x, _) -> (x, ToggleDoor c3d dir), local = False}
sectionImage` :: !(Bool Coord3D [Object ObjectType] [Device] Real (Image a) [Image a] (Image b) (Image (Maps2D, MapAction SectionStatus))
(Image d) (Image e) (Image f) (Image g) -> Image (Maps2D, MapAction SectionStatus))
......@@ -388,9 +388,9 @@ editSectionImage hilite mngmnt zoomed allDevices network inventoryMap doorDims s
<@< {onclick = onClick (FocusOnSection (floorIdx, c)), local = False}
) )
rotateWall :: !Int Coord2D Dir !(!Maps2D, MapAction SectionStatus)
rotateWall :: !Int Coord2D Dir (Span,Span) !(!Maps2D, MapAction SectionStatus)
-> (!Maps2D, !MapAction SectionStatus)
rotateWall m c d (maps, edit)
rotateWall m c d _ (maps, edit)
= case getMap2D m maps of
Just map
= case getSection c map of
......@@ -406,5 +406,5 @@ rotateWall m c d (maps, edit)
rotate Wall = Door
rotate Door = Open
onClick :: !(MapAction SectionStatus) !(!a, MapAction SectionStatus) -> (!a, !MapAction SectionStatus)
onClick clck (m, _) = (m, clck)
onClick :: !(MapAction SectionStatus) (Span,Span) !(!a, MapAction SectionStatus) -> (!a, !MapAction SectionStatus)
onClick clck _ (m, _) = (m, clck)
......@@ -74,7 +74,7 @@ pile_image side pile
row_images :: !Bool !RowPlayer -> [Image GameSt]
row_images interactive row
= [ tuneIf interactive (card_image Front row_card)
{onclick = play_row_card row_card.back no, local = False}
{onclick = \_ st -> play_row_card row_card.back no st, local = False}
\\ row_card <- row
& no <- [1..]
]
......@@ -83,8 +83,8 @@ hand_images :: !Bool !Hand !Color -> [Image GameSt]
hand_images interactive {conceal,discard} color
#! conceal_pile = pile_image Back conceal
#! discard_pile = pile_image Front discard
= [ tuneIf interactive conceal_pile {onclick = play_concealed_pile color, local = False}
, tuneIf interactive discard_pile {onclick = play_hand_card color, local = False}
= [ tuneIf interactive conceal_pile {onclick = \_ st -> play_concealed_pile color st, local = False}
, tuneIf interactive discard_pile {onclick = \_ st -> play_hand_card color st, local = False}
]
player_arc :== 0.45 * pi
......
......@@ -44,7 +44,7 @@ board :: Bool Span TraxSt -> Image TraxSt
board it_is_my_turn d st=:{trax}
| no_of_tiles trax == zero
| it_is_my_turn = grid (Rows 2) (RowMajor, LeftToRight, TopToBottom) [] [] [] []
[ tileImage d tile <@< {onclick = start_with_this tile, local = False}
[ tileImage d tile <@< {onclick = \_ st -> start_with_this tile st, local = False}
\\ tile <- gFDomain{|*|}
] NoHost
| otherwise = voidImage d
......@@ -73,9 +73,9 @@ unselectedImage d = tileShape d <@< {fill = freeTileColor}
freeImage :: Span Coordinate TraxSt -> Image TraxSt
freeImage d coord {trax,choice}
| isEmpty candidates = illegalImage d
| maybe True ((<>) coord) choice = unselectedImage d <@< {onclick = setcell coord, local = False}
| maybe True ((<>) coord) choice = unselectedImage d <@< {onclick = \_ st -> setcell coord st, local = False}
| otherwise = above (repeat AtMiddleX) [] (Just d) []
[tileImage (d /. no_of_candidates) tile <@< {onclick = settile coord tile, local = False} \\ tile <- candidates]
[tileImage (d /. no_of_candidates) tile <@< {onclick = \_ st -> settile coord tile st, local = False} \\ tile <- candidates]
(Host (unselectedImage d))
where
candidates = [tile \\ tile <- possible_tiles trax coord | isJust (mandatory_moves (add_tile coord tile trax) coord)]
......
module Circles
import iTasks => qualified grid
import Data.Func
from Graphics.Scalable.Internal.Types import :: LookupSpan
import iTasks.Extensions.SVG.SVGEditor
Start w = doTasks gui6 w
gui6 :: Task [(Span, Span, Span)]
gui6 = updateInformation
[UpdateUsing id (const id) (fromSVGEditor svged)]
[(px 5.0, px 5.0, px 5.0)]
svged :: SVGEditor [(Span, Span, Span)] [(Span, Span, Span)]
svged = {initView=id, renderImage=renderImage, updModel= \m v->v}
where
renderImage _ images ts
= overlay [(AtMiddleX, AtMiddleY)] [(px 0.0, px 0.0)] [img]
$ Host $ rect (px 1000.0) (px 1000.0) <@< {fill=toSVGColor "white"}
where
img = collage [(x, y)\\(_, x, y)<-images] [circle r\\(r, _, _)<-images]
$ Host $ rect (px 100.0) (px 100.0)
<@< {fill=toSVGColor "white"}
<@< {onclick= \(x, y) m->[(px 5.0, x, y):m],local=False}
derive gEditor FontDef`
derive gText FontDef`
derive class iTask Span, LookupSpan, ImageTag
......@@ -723,7 +723,7 @@ where
= doMouseEvent` svglet me svg elemId uniqId p (MouseOnClickData nc) local args world
doMouseEvent` :: !(SVGEditor s v) !JSVal !JSObj !String !ImgTagNo !ImgNodePath !MouseCallbackData !Bool !{!JSVal} !*JSWorld -> *JSWorld | JSONEncode{|*|} s
doMouseEvent` svglet=:{SVGEditor | initView,renderImage,updModel} me svg elemId uniqId p cb_data local _ world
doMouseEvent` svglet=:{SVGEditor | initView,renderImage,updModel} me svg elemId uniqId p cb_data local args world
#! world = jsTrace` ("doMouseEvent` " +++ "[" +++ join "," (map toString p) +++ "] " +++ toString cb_data) world
#! world = timeTrace "doMouseEvent` started at " world
#! (cidJS,world) = me .# "attributes.taskId" .? world
......@@ -734,8 +734,29 @@ where
= case getImgEventhandler image` p of
Nothing = timeTrace "doMouseEvent` reached illegal code section ended at " world // this code should never be reached
Just f
// Translate the raw DOM coordinates to SVG coordinates relative to the image of the handler
// https://www.sitepoint.com/how-to-translate-from-dom-to-svg-coordinates-and-back-again
// Get the absolute coordinates for the viewport
#! (point, world) = (svg `createSVGPoint` ()) world
#! world = (point .# "x" .= args.[0] .# "clientX") world
#! world = (point .# "y" .= args.[0] .# "clientY") world
#! (m, world) = (svg `getScreenCTM` ()) world
#! (inv, world) = (m `inverse` ()) world
#! (point, world) = (point `matrixTransform` inv) world
#! (ax, world) = point .# "x" .? world
#! (ay, world) = point .# "y" .? world
#! (ax, ay) = (jsValToReal` 0.0 ax, jsValToReal` 0.0 ay)
// Get the coordinates for the image that was clicked in
#! (bRect, world) = (args.[0] .# "target" .# "getBoundingClientRect" .$ ()) world
#! (ix, world) = bRect .# "left" .? world
#! (iy, world) = bRect .# "top" .? world
#! (ix, iy) = (jsValToReal` 0.0 ix, jsValToReal` 0.0 iy)
// Compensate for the scrolling
#! (sx, world) = jsWindow .# "scrollX" .? world
#! (sy, world) = jsWindow .# "scrollY" .? world
#! (sx, sy) = (jsValToReal` 0.0 sx, jsValToReal` 0.0 sy)
// Update the view & the model
#! view = applyImgEventhandler f cb_data view
#! view = applyImgEventhandler (px (ax - (ix + sx)), px (ay - (iy + sy))) f cb_data view
#! model = updModel model view
#! (jsView,world) = jsMakeCleanReference view me world
#! (jsModel,world)= jsMakeCleanReference model me world
......@@ -750,15 +771,15 @@ where
#! world = timeTrace "doMouseEvent` calls server round trip started at " world
= world // rendering is completed by clientHandleAttributeChange
where
applyImgEventhandler :: !(ImgEventhandler m) !MouseCallbackData m -> m
applyImgEventhandler (ImgEventhandlerOnClickAttr {OnClickAttr | onclick = f}) _ m = f m
applyImgEventhandler (ImgEventhandlerOnNClickAttr {OnNClickAttr | onNclick = f}) (MouseOnClickData n) m = f n m
applyImgEventhandler (ImgEventhandlerOnMouseDownAttr {OnMouseDownAttr | onmousedown = f}) _ m = f m
applyImgEventhandler (ImgEventhandlerOnMouseUpAttr {OnMouseUpAttr | onmouseup = f}) _ m = f m
applyImgEventhandler (ImgEventhandlerOnMouseOverAttr {OnMouseOverAttr | onmouseover = f}) _ m = f m
applyImgEventhandler (ImgEventhandlerOnMouseMoveAttr {OnMouseMoveAttr | onmousemove = f}) _ m = f m
applyImgEventhandler (ImgEventhandlerOnMouseOutAttr {OnMouseOutAttr | onmouseout = f}) _ m = f m
applyImgEventhandler _ _ m = m // this case should never be reached (including ImgEventhandlerDraggableAttr)
applyImgEventhandler :: (!Span, !Span) !(ImgEventhandler m) !MouseCallbackData m -> m
applyImgEventhandler span (ImgEventhandlerOnClickAttr {OnClickAttr | onclick = f}) _ m = f span m
applyImgEventhandler _ (ImgEventhandlerOnNClickAttr {OnNClickAttr | onNclick = f}) (MouseOnClickData n) m = f n m
applyImgEventhandler span (ImgEventhandlerOnMouseDownAttr {OnMouseDownAttr | onmousedown = f}) _ m = f span m
applyImgEventhandler span (ImgEventhandlerOnMouseUpAttr {OnMouseUpAttr | onmouseup = f}) _ m = f span m
applyImgEventhandler span (ImgEventhandlerOnMouseOverAttr {OnMouseOverAttr | onmouseover = f}) _ m = f span m
applyImgEventhandler span (ImgEventhandlerOnMouseMoveAttr {OnMouseMoveAttr | onmousemove = f}) _ m = f span m
applyImgEventhandler span (ImgEventhandlerOnMouseOutAttr {OnMouseOutAttr | onmouseout = f}) _ m = f span m
applyImgEventhandler _ _ _ m = m // this case should never be reached (including ImgEventhandlerDraggableAttr)
// client side entire rendering of model value:
clientHandleModel :: !(SVGEditor s v) !JSVal !s !v !*JSWorld -> *JSWorld | JSONEncode{|*|} s
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment