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

Extend the mousehandlers with coordinates

See merge request !327

Examples/Applications/ShipAdventure/C2/Apps/ShipAdventure/Images.icl

@@ -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)

Examples/Games/Ligretto/Ligretto/UI.icl

@@ -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

Examples/Games/Trax/Trax/UI.icl

@@ -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)]

Examples/Graphics/BasicImagesExamples/Circles.icl

+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
+

Libraries/iTasks/Extensions/SVG/SVGEditor.icl

@@ -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