SVGEditor.icl 83.5 KB
Newer Older
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
1
implementation module iTasks.API.Extensions.SVG.SVGEditor
2 3 4

import qualified Data.Map as DM
import Graphics.Scalable
5
import Graphics.Scalable.Internal
6
import iTasks
7
import iTasks.UI.Definition, iTasks.UI.Editor
8
import iTasks.UI.JS.Interface
Bas Lijnse's avatar
Bas Lijnse committed
9
import iTasks._Framework.Serialization
10
from StdOrdList import minList, maxList
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
11
import StdOverloaded
12
import StdArray
13
import StdMisc
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
14
import Data.Array
15 16
import Data.List
import Data.Func
17
from Data.Set import :: Set, instance == (Set a), instance < (Set a)
18
import qualified Data.Set as DS
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
19
from StdFunc import `bind`, flip
20
import Text
21
from Data.IntMap.Strict import :: IntMap, instance Functor IntMap
22
import qualified Data.IntMap.Strict as DIS
23
import Data.Matrix
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
24
import iTasks.API.Extensions.Platform
Bas Lijnse's avatar
Bas Lijnse committed
25
import Text.HTML
26

27 28 29 30 31
derive class iTask Image, Span, LookupSpan, FontDef, ImageTransform, ImageAttr
derive class iTask ImageContent, BasicImage, CompositeImage, LineImage, Markers
derive class iTask LineContent, Compose, XAlign, YAlign, OnMouseOutAttr, OnMouseMoveAttr
derive class iTask OpacityAttr, FillAttr, XRadiusAttr, YRadiusAttr, StrokeWidthAttr, StrokeAttr
derive class iTask Slash, DraggableAttr, OnMouseOverAttr, OnMouseUpAttr, DashAttr
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
32
derive class iTask OnMouseDownAttr, OnClickAttr
33

34

35
CLICK_DELAY :== 225
36 37 38 39 40 41 42 43 44 45 46 47 48 49
svgns =: "http://www.w3.org/2000/svg"

//Predefined object methods
(`addEventListener`)       obj args :== obj .# "addEventListener"       .$ args
(`setAttribute`)           obj args :== obj .# "setAttribute"           .$ args
(`setAttributeNS`)         obj args :== obj .# "setAttributeNS"         .$ args
(`createElementNS`)        obj args :== obj .# "createElementNS"        .$ args
(`appendChild`)            obj args :== obj .# "appendChild"            .$ args
(`removeChild`)            obj args :== obj .# "removeChild"            .$ args
(`getComputedTextLength`)  obj args :== obj .# "getComputedTextLength"  .$ args
(`createSVGPoint`)         obj args :== obj .# "createSVGPoint"         .$ args
(`getScreenCTM`)           obj args :== obj .# "getScreenCTM"           .$ args
(`inverse`)                obj args :== obj .# "inverse"                .$ args
(`matrixTransform`)        obj args :== obj .# "matrixTransform"        .$ args
50

51
:: *GenSVGStVal s =
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
52
  { uniqueIdCounter :: !Int
53
  , genStates       :: !*SpanEnvs
54 55
  }

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
56
:: DropTarget = DropTarget
57
:: MousePos = MouseUp | MouseDown
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
58

59 60
:: SVGDragState v = 
  { svgMousePos     :: !MousePos
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
61
  , svgDropCallback :: !Maybe ((Maybe (Set ImageTag)) Real Real v -> v)
62 63 64 65
  , svgTrueCoordsX  :: !Real
  , svgTrueCoordsY  :: !Real
  , svgGrabPointX   :: !Real
  , svgGrabPointY   :: !Real
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
66
  , svgDragTarget   :: !Maybe (JSObj DropTarget)
67 68
  }

69
derive class iTask Set, DropTarget, MousePos, ImageTag
70

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
71 72
fromSVGEditor :: (SVGEditor s v) -> Editor s | iTask s 
fromSVGEditor svglet = fromEditlet (svgRenderer svglet)
73

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
74
svgRenderer :: (SVGEditor s v) -> Editlet s | iTask s
75
svgRenderer svglet=:{initView,renderImage,updView,updModel}
76 77 78
  = { genUI   = genUI
	, initUI  = initUI
    , onEdit  = onEdit
79
    , onRefresh = onRefresh
80
    }
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
81
  where
82
	genUI dp val world
83
		# attr = 'DM'.unions [sizeAttr FlexSize FlexSize, valueAttr (toJSON val)]
84
		= (Ok (uia UIComponent attr,newFieldMask), world)
85 86 87 88

	initUI me world
		//Set attributes
        # world = (me .# "clickCount" .= (toJSVal 0)) world
89
  		# world = jsPutCleanVal "dragState" initDragState me world
90 91 92 93 94 95 96
		//Set methods	
		# (jsOnAttributeChange,world) = jsWrapFun (onAttributeChange me) world
		# world = (me .# "onAttributeChange" .= jsOnAttributeChange) world
		# (jsInitDOMEl,world) = jsWrapFun (initDOMEl me) world
		# world = (me .# "initDOMEl" .= jsInitDOMEl) world
		= world

97 98 99
	initDragState = {SVGDragState|svgMousePos=MouseUp,svgDropCallback=Nothing,svgTrueCoordsX=0.0,svgTrueCoordsY=0.0
                                 ,svgGrabPointX=0.0,svgGrabPointY=0.0,svgDragTarget=Nothing}

100 101 102 103 104 105 106 107
	initDOMEl me args world
		# (value,world) = .? (me .# "value") world
		# (json,world) = jsValToJSONNode value world
		= case fromJSON json of
			Nothing = (jsNull,world)
			Just s 	= (jsNull,onNewState me svglet s world)

	onAttributeChange me args world
108
		| jsArgToString (args !! 0) == "stateChange"
109 110 111 112 113 114 115
			# (json,world)  = jsValToJSONNode (toJSVal (args !! 1)) world
			= case fromJSON json of
				Nothing = (jsNull,world)
				Just s  = (jsNull,onNewState me svglet s world)
		| otherwise
			= (jsNull,jsTrace "Unknown attribute change" world)

116 117 118
  	onRefresh _ new old mask vst 
		= (Ok (if (old === new) NoChange (ChangeUI [SetAttribute "stateChange" (toJSON new)] []),mask),new,vst)

Bas Lijnse's avatar
Bas Lijnse committed
119 120 121 122
  	onEdit _ (_,json) st m ust 
		= case fromJSON json of 	
			Just nst = (Ok (NoChange,m),nst,ust)
			Nothing  = (Ok (NoChange,m),st,ust)
123

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
124
onNewState :: !(JSVal a) !(SVGEditor s v) !s !*JSWorld -> *JSWorld | JSONEncode{|*|} s
125
onNewState me svglet=:{initView,renderImage} s world
126
	#! cid                  = "FIXME_SOME_UNIQUE_STRING"
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
	#! v                    = initView s
	#! world 				= jsPutCleanVal "view" v me world  //Store the view value on the component
	#! world 				= jsPutCleanVal "model" s me world  //Store the model value on the component
  	#! image                = renderImage s v [(ImageTagUser no cid, ImageTagUser no cid) \\ no <- [0..]]
	// Determine the fonts used in the image, measure text sizes and adjust the image using the known sizes
  	#! fontMap              = gatherFonts image
    #! (realFontMap, world) = if ('DM'.null fontMap) ('DM'.newMap, world) (calcTextLengths fontMap world)
    #! (image, spanEnvs)    = imageFromState image realFontMap
    #! fixVal               = fixEnvs {FixSpansSt | fixSpansDidChange = False, fixSpansSpanEnvs = spanEnvs}
	// Create the new SVG content from the image
    #! (syn, clval)         = genSVG image { uniqueIdCounter = 0, genStates = fixVal.fixSpansSpanEnvs }
    #! (imXSp, imYSp)       = syn.genSVGSyn_imageSpanReal
    #! (imXSp, imYSp)       = (toString (to2dec imXSp), toString (to2dec imYSp))
    #! svgStr               = browserFriendlySVGEltToString (SVGElt [WidthAttr imXSp, HeightAttr imYSp, XmlnsAttr svgns]
                                             [VersionAttr "1.1", ViewBoxAttr "0" "0" imXSp imYSp]
                                             syn.genSVGSyn_svgElts)
    #! svgStr               = replaceSubString editletId cid svgStr
	// Update the DOM element with the new SVG content
    #! (parser, world)      = new "DOMParser" () world
    #! (doc, world)         = (parser .# "parseFromString" .$ (svgStr, "image/svg+xml")) world
    #! (newSVG, world)      = .? (doc .# "firstChild") world
    #! (domEl, world)       = .? (me .# "domEl") world
  	#! (currSVG, world)     = .? (domEl .# "firstChild") world
  	#! (_, world)           = if (jsIsNull currSVG)
                              ((domEl `appendChild` newSVG) world)
                              ((domEl .# "replaceChild" .$ (newSVG, currSVG)) world)
	// Register javascript event handlers for all event handlers in the image
    #! world                = registerSVGEvents me svglet cid newSVG syn.genSVGSyn_events world
155
    #! world                = registerDraggables me svglet cid newSVG syn.genSVGSyn_draggable syn.genSVGSyn_idMap world
156 157 158
 	= world

imageFromState :: !(Image v) !(Map FontDef (Map String Real)) -> *(!Image v, !*SpanEnvs)
159
imageFromState img env
160
  #! spanEnvs  = { spanEnvImageTagPostTrans  = 'DIS'.newMap
161
                 , spanEnvImageSpanPostTrans = 'DIS'.newMap
162
                 , spanEnvGridTag            = 'DIS'.newMap
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
163 164
                 , spanEnvGridSpan           = 'DIS'.newMap
                 , spanEnvFonts              = env
165 166 167 168 169
                 }
  #! (img, st) = desugarAndTag img { desugarAndTagCounter  = 0
                                   , desugarAndTagSpanEnvs = spanEnvs}
  = (img, st.desugarAndTagSpanEnvs)

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
170
registerSVGEvents :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !(Map String (ImageAttr v)) !*JSWorld -> *JSWorld | JSONEncode{|*|} s
171 172 173
registerSVGEvents me svglet cid svg onclicks world
  = 'DM'.foldrWithKey (registerEvent me svglet cid svg) world onclicks
  where
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
174
  registerEvent :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !String !(ImageAttr v) !*JSWorld -> *JSWorld | JSONEncode{|*|} s
175 176 177
  registerEvent me svglet cid svg elemId (ImageOnClickAttr {local,onclick}) world
    = registerNClick me svglet cid svg elemId onclick local world
  registerEvent me svglet cid svg elemId (ImageOnMouseDownAttr {local, onmousedown}) world
178
    = actuallyRegister me svglet cid svg elemId "mousedown" onmousedown local world
179
  registerEvent me svglet cid svg elemId (ImageOnMouseUpAttr   {local, onmouseup}) world
180
    = actuallyRegister me svglet cid svg elemId "mouseup" onmouseup local world
181
  registerEvent me svglet cid svg elemId (ImageOnMouseOverAttr {local, onmouseover}) world
182
    = actuallyRegister me svglet cid svg elemId "mouseover" onmouseover local world
183
  registerEvent me svglet cid svg elemId (ImageOnMouseMoveAttr {local, onmousemove}) world
184
    = actuallyRegister me svglet cid svg elemId "mousemove" onmousemove local world
185
  registerEvent me svglet cid svg elemId (ImageOnMouseOutAttr  {local, onmouseout}) world
186 187
    = actuallyRegister me svglet cid svg elemId "mouseout"  onmouseout  local world

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
188
registerNClick :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !String !(Int v -> v) !Bool *JSWorld -> *JSWorld | JSONEncode{|*|} s
189 190 191 192 193 194 195
registerNClick me svglet cid svg elemId sttf local world
  #! elemId        = replaceSubString editletId cid elemId
  #! (elem, world) = (svg .# "getElementById" .$ elemId) world
  #! (cb, world)   = jsWrapFun (mkNClickCB me svglet svg elemId sttf local cid) world
  #! (_, world)    = (elem `addEventListener` ("click", cb, False)) world
  = world

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
196
actuallyRegister :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !String !String !(v -> v) !Bool! *JSWorld -> *JSWorld | JSONEncode{|*|} s
197 198 199 200 201 202 203
actuallyRegister me svglet cid svg elemId evt sttf local world
  #! elemId        = replaceSubString editletId cid elemId
  #! (elem, world) = (svg .# "getElementById" .$ elemId) world
  #! (cb,world)    = jsWrapFun (doImageEvent me svglet svg elemId sttf local) world
  #! (_, world)    = (elem `addEventListener` (evt, cb, True)) world
  = world

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
204
mkNClickCB :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(Int v -> v) !Bool !String ![JSArg] !*JSWorld-> *(JSVal (), !*JSWorld) | JSONEncode{|*|} s
205 206 207 208 209 210
mkNClickCB me svglet svg elemId sttf local cid args world
  #! world            = case args of [a:_] = snd (((toJSVal a) .# "stopPropagation" .$ ()) world) ; _ = world
  //If another click already registered a timeout, clear that timeout
  #! (to,world)      = .? (me .# "clickTimeOut") world
  #! world           = if (jsIsUndefined to || jsIsNull to) world (snd (("clearTimeout" .$ to) world))
  //Register a callback for the click after a small timeout
211
  #! (cb,world)      = jsWrapFun (doNClickEvent me svglet svg elemId sttf local) world
212 213 214 215 216 217 218
  #! (to,world)  	 =  ("setTimeout" .$ (cb, CLICK_DELAY)) world
  #! world           = (me .# "clickTimeOut" .= to) world
  //Increase click counter, so we can determine how many times the element was clicked when the timeout passes
  #! (nc,world)      = .? (me .# "clickCount") world
  #! world           = (me .# "clickCount" .= (toJSVal (jsValToInt nc + 1))) world
  = (jsNull,world)

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
219
doNClickEvent :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(Int v -> v) !Bool ![JSArg] !*JSWorld-> *(JSVal (), !*JSWorld) | JSONEncode{|*|} s
220
doNClickEvent me svglet svg elemId sttf local args world
221 222
  // Get click count
  #! (nc,world)      = .? (me .# "clickCount") world
223 224 225 226 227
  ///Reset click count
  #! world           = (me .# "clickCount" .= (toJSVal 0)) world
  #! nc              = jsValToInt nc
  = doImageEvent me svglet svg elemId (sttf nc) local args world

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
228
doImageEvent :: !(JSVal a) !(SVGEditor s v) !(JSObj svg) !String !(v -> v) !Bool [JSArg] !*JSWorld -> *(!JSVal (), !*JSWorld) | JSONEncode{|*|} s
229
doImageEvent me svglet svg elemId sttf local _ world
230 231 232 233
  // Get model & view value 
  #! (view,world) 	 = jsGetCleanVal "view" me world
  #! (model,world) 	 = jsGetCleanVal "model" me world
  // Update the view & the model
234
  #! view  			 = sttf view
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
235
  #! model           = svglet.SVGEditor.updModel model view
236 237 238 239 240 241 242 243 244 245 246 247 248 249
  #! world           = jsPutCleanVal "view" view me world
  #! world           = jsPutCleanVal "model" model me world
  // If not local, fire an itasks edit event 
  | local
  	//Don't trigger an event, just re-render
  	= (jsNull,onNewState me svglet model world)
  //Send edit event
  #! (json,world)     = (jsWindow .# "JSON.parse" .$ (toString (toJSON model))) world //TODO: Should not really print+parse here
  #! (taskId,world)   = .? (me .# "taskId") world
  #! (editorId,world) = .? (me .# "editorId") world
  #! (_,world)  	  = (me .# "doEditEvent" .$ (taskId,editorId,json)) world
  //Re-render
  = (jsNull,onNewState me svglet model world)

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
250
registerDraggables :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !(Map String (ImageAttr v)) !(Map String (Set ImageTag)) !*JSWorld -> *JSWorld 
251 252 253 254 255 256 257 258 259 260 261 262
registerDraggables me svglet cid svg draggables idMap world
  #! (domEl, world)       = .? (me .# "domEl") world
  #! (svgRoot, world)     = .? (domEl .# "firstChild") world
  #! idMap                = 'DM'.foldrWithKey (\k v m -> 'DM'.put (replaceSubString editletId cid k) v m) 'DM'.newMap idMap
  //All draggable elements share a common mousemove and mouseup event
  #! (cbMove,world)       = jsWrapFun (doMouseDragMove me svglet cid svgRoot) world
  #! (cbUp,world)         = jsWrapFun (doMouseDragUp me svglet cid svgRoot idMap) world
  #! (_, world)            = (svgRoot `addEventListener` ("mousemove", cbMove, True)) world
  #! (_, world)            = (svgRoot `addEventListener` ("mouseup",   cbUp,   True)) world
  //Register individual mousedown events
  = 'DM'.foldrWithKey (registerDraggable me svglet cid svg) world draggables

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
263
registerDraggable :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !String !(ImageAttr v) !*JSWorld -> *JSWorld 
264 265 266 267 268 269
registerDraggable me svglet cid svg elemId (ImageDraggableAttr {draggable = Nothing}) world = world
registerDraggable me svglet cid svg elemId (ImageDraggableAttr {draggable = Just sttf}) world
  #! elemId          = replaceSubString editletId cid elemId
  #! (elem, world)   = (svg .# "getElementById" .$ elemId) world
  #! (cbDown, world) = jsWrapFun (doMouseDragDown me svglet cid svg sttf elemId elem) world
  #! (_, world)      = (elem `addEventListener` ("mousedown", cbDown, True)) world
270 271
  = world

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
272
doMouseDragDown :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) ((Maybe (Set ImageTag)) Real Real v -> v) !String !(JSObj o) [JSArg] !*JSWorld
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
                   -> *(!JSVal (), !*JSWorld) 
doMouseDragDown me svglet cid svgRoot sttf elemId elem args world
  #! (ds,world)             = jsGetCleanVal "dragState" me world
  #! (targetElement, world) = (svgRoot .# "getElementById" .$ elemId) world
  #! (_, world)             = (targetElement .# "setAttributeNS" .$ (jsNull, "pointer-events", "none")) world
  #! (boundingRect, world)  = (targetElement .# "getBoundingClientRect" .$ ()) world
  #! (left, world)          = .? (boundingRect .# "left") world
  #! (top, world)           = .? (boundingRect .# "top") world
  #! (p, world)             = (svgRoot `createSVGPoint` ()) world
  #! world                  = (p .# "x" .= left) world
  #! world                  = (p .# "y" .= top) world
  #! (m, world)             = (svgRoot `getScreenCTM` ()) world
  #! (inv, world)           = (m `inverse` ()) world
  #! (p, world)             = (p `matrixTransform` inv) world
  #! (px, world)            = .? (p .# "x") world
  #! (py, world)            = .? (p .# "y") world
  #! (e, f)                 = (jsValToReal px, jsValToReal py)
  #! ds = {SVGDragState|ds & svgDropCallback = Just sttf, svgMousePos = MouseDown, svgDragTarget = Just targetElement
          ,svgGrabPointX = ds.SVGDragState.svgTrueCoordsX - e, svgGrabPointY = ds.SVGDragState.svgTrueCoordsY - f}
  #! world                  = jsPutCleanVal "dragState" ds me world
  = (jsNull,world)
294

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
295
doMouseDragMove :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) [JSArg] !*JSWorld -> *(!JSVal (), !*JSWorld) 
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316
doMouseDragMove me svglet cid svgRoot args world
  #! (ds,world)  = jsGetCleanVal "dragState" me world
  #! evt         = toJSVal (args !! 0)
  #! (newTrueCoordsX, newTrueCoordsY, world) = getNewTrueCoords me evt world
  | ds.SVGDragState.svgMousePos =!= MouseDown || ds.SVGDragState.svgDragTarget =: Nothing
 	#! ds = {SVGDragState|ds & svgTrueCoordsX = newTrueCoordsX, svgTrueCoordsY = newTrueCoordsY}
    #! world  = jsPutCleanVal "dragState" ds me world
    = (jsNull,world)
  #! dragTarget           = fromJust ds.SVGDragState.svgDragTarget
  #! (domEl, world)       = .? (me .# "domEl") world
  #! (svgRoot, world)     = .? (domEl .# "firstChild") world
  // Append the dragTarget to the root of the SVG element for two reasons:
  //   1. To allow it to be dragged over all other elements
  //   2. To not be bothered by the offsets of one or more groups it might initially be in
  #! (_, world) = (svgRoot `appendChild` dragTarget) world
  #! newX       = newTrueCoordsX - ds.SVGDragState.svgGrabPointX
  #! newY       = newTrueCoordsY - ds.SVGDragState.svgGrabPointY
  #! (_, world) = (dragTarget `setAttribute` ("transform", "translate(" +++ toString newX +++ "," +++ toString newY +++ ")")) world
  #! ds = {SVGDragState|ds & svgTrueCoordsX = newTrueCoordsX, svgTrueCoordsY = newTrueCoordsY}
  #! world  = jsPutCleanVal "dragState" ds me world
  = (jsNull,world)
317

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
318
doMouseDragUp :: !(JSVal a) !(SVGEditor s v) !String !(JSObj svg) !(Map String (Set ImageTag)) [JSArg] !*JSWorld -> *(!JSVal (), !*JSWorld) 
319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337
doMouseDragUp me svglet cid svgRoot idMap args world
  #! evt                   = toJSVal (args !! 0)
  #! (ds,world)  = jsGetCleanVal "dragState" me world
  | ds.SVGDragState.svgDragTarget =: Nothing
    #! ds     = {SVGDragState|ds & svgMousePos = MouseUp, svgDragTarget = Nothing}
    #! world  = jsPutCleanVal "dragState" ds me world
  	= (jsNull,world)
  #! (evtTarget, world)    = .? (evt .# "target") world
  #! dragTarget            = fromJust ds.SVGDragState.svgDragTarget
  #! (_, world)            = (dragTarget .# "setAttributeNS" .$ (jsNull, "pointer-events", "none")) world
  #! (parentId, world)     = firstIdentifiableParentId evtTarget world
  // Get model & view value 
  #! (view,world) 	 = jsGetCleanVal "view" me world
  #! (model,world) 	 = jsGetCleanVal "model" me world
  #! (view,model)    = case ds.SVGDragState.svgDropCallback of
                         Just sttf
                              # xdiff  = ds.SVGDragState.svgTrueCoordsX - ds.SVGDragState.svgGrabPointX
                              # ydiff  = ds.SVGDragState.svgTrueCoordsY - ds.SVGDragState.svgGrabPointY
                              # view`  = sttf ('DM'.get parentId idMap) xdiff ydiff view 
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
338
                              # model` = svglet.SVGEditor.updModel model view
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
                              = (view,model)
                         Nothing
                              = (view,model)
  #! ds    = {SVGDragState|ds & svgMousePos = MouseUp, svgDragTarget = Nothing}
  #! world = jsPutCleanVal "view" view me world
  #! world = jsPutCleanVal "model" model me world
  #! world = jsPutCleanVal "dragState" ds me world
  = (jsNull,world)

firstIdentifiableParentId :: !(JSObj a) *JSWorld -> *(String, *JSWorld)
firstIdentifiableParentId elem world
  #! (idval, world) = .? (elem .# "id") world
  | jsIsNull idval
      #! (parent, world) = .? (elem .# "parentNode") world
      = firstIdentifiableParentId parent world
  #! idval = jsValToString idval
  | idval == ""
      #! (parent, world) = .? (elem .# "parentNode") world
      = firstIdentifiableParentId parent world
  | otherwise = (idval, world)

getNewTrueCoords :: !(JSVal a) !(JSObj JSEvent) !*JSWorld -> *(!Real, !Real, !*JSWorld)
getNewTrueCoords me evt world
  #! (domEl, world)        = .? (me .# "domEl") world
  #! (svgRoot, world)      = .? (domEl .# "firstChild") world
  #! (newScale, world)     = .? (svgRoot .# "currentScale") world
  #! newScale              = jsValToReal newScale
  #! (translation, world)  = .? (svgRoot .# "currentTranslate") world
  #! (translationX, world) = .? (translation .# "x") world
  #! (translationY, world) = .? (translation .# "y") world
  #! (translationX, translationY) = (jsValToReal translationX, jsValToReal translationY)
  #! (clientX, world)      = .? (evt .# "clientX") world
  #! (clientY, world)      = .? (evt .# "clientY") world
  #! (clientX, clientY)    = (jsValToReal clientX, jsValToReal clientY)
  #! newTrueCoordsX        = (clientX - translationX) / newScale
  #! newTrueCoordsY        = (clientY - translationY) / newScale
  = (newTrueCoordsX, newTrueCoordsY, world)
376

377
calcTextLengths :: !(Map FontDef (Set String)) !*JSWorld -> *(!Map FontDef (Map String Real), !*JSWorld)
378
calcTextLengths fontdefs world
379 380 381 382
  #! (svg, world)  = (jsDocument `createElementNS` (svgns, "svg")) world
  #! (body, world) = .? (jsDocument .# "body") world
  #! (_, world)    = (body `appendChild` svg) world
  #! (elem, world) = (jsDocument `createElementNS` (svgns, "text")) world
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
383
  #! (_, world)    = (elem `setAttributeNS` ("http://www.w3.org/XML/1998/namespace", "xml:space", "preserve")) world
384 385 386 387
  #! (_, world)    = (svg `appendChild` elem) world
  #! (res, world)  = 'DM'.foldrWithKey (f elem) ('DM'.newMap, world) fontdefs
  #! (_, world)    = (svg `removeChild` elem) world
  #! (_, world)    = (body `removeChild` svg) world
388
  = (res, world)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
389
  where
390
  f :: !(JSVal (JSObject a)) !FontDef !(Set String) !*(!Map FontDef (Map String Real), !*JSWorld) -> *(!Map FontDef (Map String Real), !*JSWorld)
391
  f elem fontdef strs (acc, world)
392 393 394 395 396 397
    #! fontAttrs   = [ ("font-family",  fontdef.fontfamily)
                     , ("font-size",    toString fontdef.fontysize)
                     , ("font-stretch", fontdef.fontstretch)
                     , ("font-style",   fontdef.fontstyle)
                     , ("font-variant", fontdef.fontvariant)
                     , ("font-weight",  fontdef.fontweight)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
398 399
                     , ("alignment-baseline", "auto")
                     , ("dominant-baseline", "auto")
400
                     , ("x", "-10000")
401
                     , ("y", "-10000")
402
                     ]
403
    #! world       = strictFoldl (\world args -> snd ((elem `setAttribute` args) world)) world fontAttrs
404
    #! (ws, world) = 'DS'.fold (g elem) ('DM'.newMap, world) strs
405
    = ('DM'.put fontdef ws acc, world)
406
  g :: !(JSVal (JSObject a)) !String !*(!Map String Real, !*JSWorld) -> *(!Map String Real, !*JSWorld)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
407
  g elem str (acc, world)
408 409
    #! world        = (elem .# "textContent" .= str) world
    #! (ctl, world) = (elem `getComputedTextLength` ()) world
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
410
    = ('DM'.put str (jsValToReal ctl) acc, world)
411

412
:: *FixSpansSt =
413
  { fixSpansDidChange :: !Bool
414
  , fixSpansSpanEnvs  :: !*SpanEnvs
415 416
  }

417
:: DesugarAndTagSt a :== State *DesugarAndTagStVal a
418

419
:: *DesugarAndTagStVal =
420
  { desugarAndTagCounter  :: !Int
421
  , desugarAndTagSpanEnvs :: !*SpanEnvs
422 423
  }

424
class nextNo a :: !*a -> *(!Int, !*a)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
425

426
instance nextNo (GenSVGStVal s) where
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
427 428
  nextNo st = (st.uniqueIdCounter, {st & uniqueIdCounter = st.uniqueIdCounter + 1})

429 430
instance nextNo DesugarAndTagStVal where
  nextNo st = (st.desugarAndTagCounter, {st & desugarAndTagCounter = st.desugarAndTagCounter + 1})
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
431

432
:: State s a :== s -> *(!a, !s)
433

434
:: ErrorMessage :== String
435

436 437 438 439 440 441 442
:: DesugarAndTagSyn s =
  { desugarAndTagSyn_ImageContent        :: !ImageContent s
  , desugarAndTagSyn_TotalSpan_PreTrans  :: !ImageSpan
  , desugarAndTagSyn_TotalSpan_PostTrans :: !ImageSpan
  , desugarAndTagSyn_OffsetCorrection    :: !ImageOffset
  }

443
cacheImageSpanPostTrans :: !Int !(Set ImageTag) !ImageSpan !*DesugarAndTagStVal -> *DesugarAndTagStVal
444 445
cacheImageSpanPostTrans n imTas sp st
  #! spanEnvs = st.desugarAndTagSpanEnvs
446
  #! spanEnvs = {spanEnvs & spanEnvImageSpanPostTrans = 'DIS'.put n sp spanEnvs.spanEnvImageSpanPostTrans}
447
  #! env      = 'DS'.fold (putImgTag n) spanEnvs.spanEnvImageTagPostTrans imTas
448 449
  #! spanEnvs = {spanEnvs & spanEnvImageTagPostTrans = env}
  = {st & desugarAndTagSpanEnvs = spanEnvs}
450

451
cacheGridSpans :: !Int !(Set ImageTag) ![Span] ![Span] !*DesugarAndTagStVal -> *DesugarAndTagStVal
452
cacheGridSpans n imTas xsps ysps st
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
453 454
  #! xsps`    = 'DIS'.fromList (strictTRZip2 [0..] xsps)
  #! ysps`    = 'DIS'.fromList (strictTRZip2 [0..] ysps)
455
  #! spanEnvs = st.desugarAndTagSpanEnvs
456
  #! spanEnvs = {spanEnvs & spanEnvGridSpan = 'DIS'.put n (xsps`, ysps`) spanEnvs.spanEnvGridSpan}
457
  #! env      = 'DS'.fold (putImgTag n) spanEnvs.spanEnvGridTag imTas
458 459
  #! spanEnvs = {spanEnvs & spanEnvGridTag = env}
  = {st & desugarAndTagSpanEnvs = spanEnvs}
460 461 462

putImgTag :: !Int !ImageTag !(IntMap Int) -> IntMap Int
putImgTag n t env = 'DIS'.put (numTag t) n env
463

464 465 466
point2Vec :: !(!Span, !Span) -> Vector Span
point2Vec (x, y) = {x, y, px 1.0}

Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
467 468 469 470 471
appTF :: !(Matrix Span) !(!Span, !Span) -> (!Span, !Span)
appTF m p
  #! m = mulMatrixVec m (point2Vec p)
  = (m.[0].[0], m.[1].[0])

472 473
translateTF :: !Span !Span !(!Span, !Span) -> (!Span, !Span)
translateTF sx sy p
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
474 475 476 477
  = appTF { {px 1.0, px 0.0, sx}
          , {px 0.0, px 1.0, sy}
          , {px 0.0, px 0.0, px 1.0}
          } p
478 479 480

scaleTF :: !Span !Span !(!Span, !Span) -> (!Span, !Span)
scaleTF sx sy p
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
481 482 483 484
  = appTF { {sx,     px 0.0, px 0.0}
          , {px 0.0, sy,     px 0.0}
          , {px 0.0, px 0.0, px 1.0}
          } p
485 486 487 488

rotateTF :: !Angle !(!Span, !Span) -> (!Span, !Span)
rotateTF a p
  #! a = toRad a
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
489 490 491 492
  = appTF { {px (cos a), px (0.0 - sin a), px 0.0}
          , {px (sin a), px (cos a),       px 0.0}
          , {px 0.0,     px 0.0,           px 1.0}
          } p
493 494 495

skewXTF :: !Angle !(!Span, !Span) -> (!Span, !Span)
skewXTF a p
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
496 497 498 499
  = appTF { {px 1.0, px (tan (toRad a)), px 0.0}
          , {px 0.0, px 1.0,             px 0.0}
          , {px 0.0, px 0.0,             px 1.0}
          } p
500 501 502

skewYTF :: !Angle !(!Span, !Span) -> (!Span, !Span)
skewYTF a p
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
503 504 505 506 507 508 509
  = appTF { {px 1.0,             px 0.0, px 0.0}
          , {px (tan (toRad a)), px 1.0, px 0.0}
          , {px 0.0,             px 0.0, px 1.0}
          } p

revFstsSnds :: ![(!a, !b)] -> (![a], ![b])
revFstsSnds xs = strictFoldl (\(xs, ys) (x, y) -> ([x:xs], [y:ys])) ([], []) xs
510

511
applyTransforms :: ![ImageTransform] !ImageSpan -> (!ImageSpan, !ImageOffset)
512
applyTransforms ts (xsp, ysp)
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
513
  #! origPoints     = [(zero, zero), (xsp, zero), (zero, ysp), (xsp, ysp)]
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
514
  #! newPoints      = strictFoldr f origPoints ts
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
515 516 517 518 519
  #! (allXs, allYs) = revFstsSnds newPoints
  #! minX           = minSpan allXs
  #! maxX           = maxSpan allXs
  #! minY           = minSpan allYs
  #! maxY           = maxSpan allYs
520
  = ((maxX - minX, maxY - minY), (zero - minX, zero - minY))
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
521
  where
522 523
  f :: !ImageTransform ![(!Span, !Span)] -> [(!Span, !Span)]
  f (RotateImage th) coords
Jurriën Stutterheim's avatar
 
Jurriën Stutterheim committed
524 525 526 527 528 529 530 531 532
    #! (allXs, allYs) = revFstsSnds coords
    #! minX           = minSpan allXs
    #! maxX           = maxSpan allXs
    #! minY           = minSpan allYs
    #! maxY           = maxSpan allYs
    #! cx             = (maxX - minX) /. 2.0
    #! cy             = (maxY - minY) /. 2.0
    #! translated     = strictTRMap (translateTF (zero - cx) (zero - cy)) coords
    #! rotated        = strictTRMap (rotateTF th) translated
533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549
    = strictTRMap (translateTF cx cy) rotated
  f (SkewXImage th)      coords = strictTRMap (skewXTF th) coords
  f (SkewYImage th)      coords = strictTRMap (skewYTF th) coords
  f (FitImage xsp` ysp`) coords
    = case coords of
        [(tlX, tlY), _, _, (brX, brY)]
          = strictTRMap (scaleTF (xsp` / (brX - tlX)) (ysp` / (brY - tlX))) coords
  f (FitXImage xsp`)     coords
    = case coords of
        [(tlX, tlY), _, _, (brX, brY)]
          #! factor  = xsp` / (brX - tlX)
          = strictTRMap (scaleTF factor factor) coords
  f (FitYImage ysp`)     coords
    = case coords of
        [(tlX, tlY), _, _, (brX, brY)]
          #! factor  = ysp` / (brY - tlY)
          = strictTRMap (scaleTF factor factor) coords
550 551 552 553 554 555
  f (ScaleImage xsp` ysp`) coords
    = strictTRMap (scaleTF (px xsp`) (px ysp`)) coords
  f (ScaleXImage xsp`)     coords
    = strictTRMap (scaleTF (px xsp`) (px 1.0)) coords
  f (ScaleYImage ysp`)     coords
    = strictTRMap (scaleTF (px 1.0) (px ysp`)) coords
556
  f _ coords = coords
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
557

558
gatherFonts :: !(Image s) -> Map FontDef (Set String)
559 560 561 562 563 564
gatherFonts {content, mask, attribs, transform}
  = gatherFontsUnions [ gatherFontsImageContent content
                      , gatherFontsMask mask
                      , gatherFontsAttribs attribs
                      , gatherFontsTransforms transform
                      ]
565
  where
566 567 568
  gatherFontsImageContent :: !(ImageContent m) -> Map FontDef (Set String)
  gatherFontsImageContent (Basic _ (l, r)) = gatherFontsUnions [gatherFontsSpan l, gatherFontsSpan r]
  gatherFontsImageContent (Line {lineSpan = (l, r), lineContent, markers}) = gatherFontsUnions [gatherFontsSpan l, gatherFontsSpan r, gatherFontsMarkers markers, gatherFontsLineContent lineContent]
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
569
    where
570 571 572 573 574 575 576 577
    gatherFontsMarkers :: !(Maybe (Markers m)) -> Map FontDef (Set String)
    gatherFontsMarkers (Just {markerStart, markerMid, markerEnd}) = gatherFontsUnions (strictTRMapRev gatherFonts (maybeToList markerStart ++ maybeToList markerMid ++ maybeToList markerEnd))
    gatherFontsMarkers _ = 'DM'.newMap
    gatherFontsLineContent :: !LineContent -> Map FontDef (Set String)
    gatherFontsLineContent (PolygonImage ios)  = gatherFontsUnions (gatherFontsPairs ios)
    gatherFontsLineContent (PolylineImage ios) = gatherFontsUnions (gatherFontsPairs ios)
    gatherFontsLineContent _                   = 'DM'.newMap
  gatherFontsImageContent (Composite {host, compose}) = gatherFontsUnions [gatherFontsCompose compose : strictTRMapRev gatherFonts (maybeToList host)]
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
578
    where
579 580 581 582 583 584 585 586 587
    gatherFontsCompose :: !(Compose m) -> Map FontDef (Set String)
    gatherFontsCompose (AsGrid    _ offss _ imgss) = gatherFontsUnions (strictTRMapRev gatherFonts (flattenTR imgss) ++ (gatherFontsPairs (flattenTR offss)))
    gatherFontsCompose (AsCollage   offs    imgs)  = gatherFontsUnions (strictTRMapRev gatherFonts imgs ++ gatherFontsPairs offs)
    gatherFontsCompose (AsOverlay   offs  _ imgs)  = gatherFontsUnions (strictTRMapRev gatherFonts imgs ++ gatherFontsPairs offs)
  gatherFontsMask :: !(Maybe (Image m)) -> Map FontDef (Set String)
  gatherFontsMask (Just img) = gatherFonts img
  gatherFontsMask _          = 'DM'.newMap
  gatherFontsAttribs :: !(Set (ImageAttr m )) -> Map FontDef (Set String)
  gatherFontsAttribs attribs = gatherFontsUnions (strictTRMapRev gatherFontsAttrib ('DS'.toList attribs))
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
588
    where
589 590 591 592 593 594 595
    gatherFontsAttrib :: !(ImageAttr m) -> Map FontDef (Set String)
    gatherFontsAttrib (ImageStrokeWidthAttr {strokewidth}) = gatherFontsSpan strokewidth
    gatherFontsAttrib (ImageXRadiusAttr     {xradius})     = gatherFontsSpan xradius
    gatherFontsAttrib (ImageYRadiusAttr     {yradius})     = gatherFontsSpan yradius
    gatherFontsAttrib _                                    = 'DM'.newMap
  gatherFontsTransforms :: ![ImageTransform] -> Map FontDef (Set String)
  gatherFontsTransforms transforms = gatherFontsUnions (strictTRMapRev gatherFontsTransform transforms)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
596
    where
597 598 599 600 601 602 603 604 605 606 607
    gatherFontsTransform :: !ImageTransform -> Map FontDef (Set String)
    gatherFontsTransform (FitImage l r) = gatherFontsUnions [gatherFontsSpan l, gatherFontsSpan r]
    gatherFontsTransform (FitXImage l)  = gatherFontsSpan l
    gatherFontsTransform (FitYImage l)  = gatherFontsSpan l
    gatherFontsTransform _              = 'DM'.newMap

gatherFontsPairs :: ![(!Span, !Span)] -> [Map FontDef (Set String)]
gatherFontsPairs pairs = strictFoldl f [] pairs
  where
  f :: ![Map FontDef (Set String)] !(!Span, !Span) -> [Map FontDef (Set String)]
  f acc (x, y) = [gatherFontsSpan x : gatherFontsSpan y : acc]
608 609

gatherFontsSpan :: !Span -> Map FontDef (Set String)
610 611 612 613 614 615 616 617 618
gatherFontsSpan (AddSpan l r)                   = gatherFontsUnions [gatherFontsSpan l, gatherFontsSpan r]
gatherFontsSpan (SubSpan l r)                   = gatherFontsUnions [gatherFontsSpan l, gatherFontsSpan r]
gatherFontsSpan (MulSpan l r)                   = gatherFontsUnions [gatherFontsSpan l, gatherFontsSpan r]
gatherFontsSpan (DivSpan l r)                   = gatherFontsUnions [gatherFontsSpan l, gatherFontsSpan r]
gatherFontsSpan (AbsSpan x)                     = gatherFontsSpan x
gatherFontsSpan (MinSpan xs)                    = gatherFontsUnions (strictTRMapRev gatherFontsSpan xs)
gatherFontsSpan (MaxSpan xs)                    = gatherFontsUnions (strictTRMapRev gatherFontsSpan xs)
gatherFontsSpan (LookupSpan (TextXSpan fd str)) = 'DM'.singleton fd ('DS'.singleton str)
gatherFontsSpan _                               = 'DM'.newMap
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
619 620 621

gatherFontsUnions :: ![Map FontDef (Set String)] -> Map FontDef (Set String)
gatherFontsUnions m = 'DM'.unionsWith 'DS'.union m
622

623
desugarAndTagMaybeImage :: !(Maybe (Image s)) !*DesugarAndTagStVal -> (!Maybe (Image s), !*DesugarAndTagStVal)
624 625 626 627 628
desugarAndTagMaybeImage (Just img) st
  #! (img, st) = desugarAndTag img st
  = (Just img, st)
desugarAndTagMaybeImage n st = (n, st)

629 630 631 632 633
mkTotalSpanPostTrans :: !(Image s) -> (!Span, !Span)
mkTotalSpanPostTrans {uniqId}
  #! newTag = ImageTagSystem uniqId
  = (LookupSpan (ImageXSpan newTag), LookupSpan (ImageYSpan newTag)) 

634
desugarAndTag :: !(Image s) !*DesugarAndTagStVal -> *(!Image s, !*DesugarAndTagStVal)
635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652
desugarAndTag {content, mask, attribs, transform, tags} st
  #! (mask, st)      = desugarAndTagMaybeImage mask st
  #! (no, st)        = nextNo st
  #! newTag          = ImageTagSystem no
  #! (syn, st)       = desugarAndTagImageContent content transform tags st
  #! tags            = 'DS'.insert newTag tags
  #! st              = cacheImageSpanPostTrans no tags syn.desugarAndTagSyn_TotalSpan_PostTrans st
  #! img             = { Image
                       | content             = syn.desugarAndTagSyn_ImageContent
                       , mask                = mask
                       , attribs             = attribs
                       , transform           = transform
                       , tags                = tags
                       , uniqId              = no
                       , totalSpanPreTrans   = syn.desugarAndTagSyn_TotalSpan_PreTrans  // TODO Get rid of these fields in favor of cached spans
                       , transformCorrection = syn.desugarAndTagSyn_OffsetCorrection    // TODO Get rid of these fields in favor of cached spans
                       }
  = (img, st)
653
  where
654
  desugarAndTagImageContent :: !(ImageContent s) ![ImageTransform] !(Set ImageTag) !*DesugarAndTagStVal
655
                            -> *(!DesugarAndTagSyn s, !*DesugarAndTagStVal)
656 657 658 659 660 661
  desugarAndTagImageContent (Basic bi imSp) transform tags st
    #! (imSp`, imOff) = applyTransforms transform imSp
    = ({ desugarAndTagSyn_ImageContent        = Basic bi imSp
       , desugarAndTagSyn_TotalSpan_PreTrans  = imSp
       , desugarAndTagSyn_TotalSpan_PostTrans = imSp`
       , desugarAndTagSyn_OffsetCorrection    = imOff
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
662
       }, st)
663 664 665 666 667 668 669 670 671 672
  desugarAndTagImageContent (Line {lineSpan, lineContent, markers}) transform tags st
    #! (markers, st)  = desugarAndTagMarkers markers st
    #! (imSp`, imOff) = applyTransforms transform lineSpan
    = ({ desugarAndTagSyn_ImageContent        = Line { LineImage
                                                     | lineSpan    = lineSpan
                                                     , markers     = markers
                                                     , lineContent = lineContent }
       , desugarAndTagSyn_TotalSpan_PreTrans  = lineSpan
       , desugarAndTagSyn_TotalSpan_PostTrans = imSp`
       , desugarAndTagSyn_OffsetCorrection    = imOff
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
673
       }, st)
674
    where
675
    desugarAndTagMarkers :: !(Maybe (Markers s)) !*DesugarAndTagStVal
676
                         -> *(!(Maybe (Markers s)), !*DesugarAndTagStVal)
677 678 679 680 681 682 683 684
    desugarAndTagMarkers (Just {markerStart, markerMid, markerEnd}) st
      #! (markerStart, st) = desugarAndTagMaybeImage markerStart st
      #! (markerMid, st)   = desugarAndTagMaybeImage markerMid st
      #! (markerEnd, st)   = desugarAndTagMaybeImage markerEnd st
      = (Just {markerStart = markerStart, markerMid = markerMid, markerEnd = markerEnd}, st)
    desugarAndTagMarkers n st = (n, st)
  desugarAndTagImageContent (Composite {host, compose}) transform tags st
    #! (host, st)                   = desugarAndTagMaybeImage host st
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
685
    #! ((compose, composeSpan), st) = desugarAndTagCompose compose host tags st
686 687
    #! (host, span)                 = case host of
                                       Just hostImg
688
                                          -> (host, mkTotalSpanPostTrans hostImg)
689 690 691 692 693 694 695 696 697
                                       _  -> (Nothing, composeSpan)
    #! (span`, corr)                = applyTransforms transform span
    = ({ desugarAndTagSyn_ImageContent        = Composite { CompositeImage
                                                          | host    = host
                                                          , compose = compose
                                                          }
       , desugarAndTagSyn_TotalSpan_PreTrans  = span
       , desugarAndTagSyn_TotalSpan_PostTrans = span`
       , desugarAndTagSyn_OffsetCorrection    = corr
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
698
       }, st)
699
    where
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
700
    desugarAndTagCompose :: !(Compose s) !(Maybe (Image s)) !(Set ImageTag) !*DesugarAndTagStVal
701
                         -> *(!(!Compose s, !ImageSpan), !*DesugarAndTagStVal)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
702
    desugarAndTagCompose (AsGrid (numcols, numrows) offsetss iass imgss) host tags st
703 704 705 706 707 708 709 710
      #! (imgss, st) = strictTRMapSt (strictTRMapSt desugarAndTag) imgss st
      #! (tag, st)   = nextNo st
      #! sysTags     = ImageTagSystem tag
      #! colIndices  = [0 .. numcols - 1]
      #! rowIndices  = [0 .. numrows - 1]
      #! gridSpan    = maybe ( strictFoldl (\acc n -> LookupSpan (ColumnXSpan sysTags n) + acc) (px 0.0) colIndices
                             , strictFoldl (\acc n -> LookupSpan (RowYSpan sysTags n)    + acc) (px 0.0) rowIndices
                             )
711 712
                             mkTotalSpanPostTrans host
      #! spanss      = strictTRMap (strictTRMap mkTotalSpanPostTrans) imgss
713 714 715 716 717 718
      #! st          = cacheGridSpans tag ('DS'.insert sysTags tags)
                                      (strictTRMap (maxSpan o strictTRMap fst) (transpose spanss))
                                      (strictTRMap (maxSpan o strictTRMap snd) spanss) st
      #! offsets`    = calculateGridOffsets (strictTRMap (\n -> LookupSpan (ColumnXSpan sysTags n)) colIndices)
                                            (strictTRMap (\n -> LookupSpan (RowYSpan sysTags n))    rowIndices) iass imgss offsetss
      #! offsets`    = reverseTR (flattenTR offsets`)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
719
      = (( AsCollage offsets` (flattenTR imgss)
720
         , gridSpan), st)
721
      where
722
      calculateGridOffsets :: ![Span] ![Span] ![[ImageAlign]] ![[Image s]] ![[(!Span, !Span)]] -> [[(!Span, !Span)]]
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
723
      calculateGridOffsets cellXSpans cellYSpans alignss imagess offsetss
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
724
        = fst (strictFoldl (mkRows cellXSpans) ([], zero) (strictTRZip4 alignss imagess cellYSpans offsetss))
725
        where
726
        mkRows :: ![Span] !(![[(!Span, !Span)]], !Span) !(![(!XAlign, !YAlign)], ![Image s], !Span, ![(!Span, !Span)])
727
               -> (![[(!Span, !Span)]], !Span)
728
        mkRows cellXSpans (acc, yoff) (aligns, imgs, cellYSpan, offsets)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
729
          = ( [fst (strictFoldl (mkCols cellYSpan yoff) ([], zero) (strictTRZip4 aligns imgs cellXSpans offsets)) : acc]
730
            , yoff + cellYSpan)
731
        mkCols :: !Span !Span !(![(!Span, !Span)], !Span) !(!(!XAlign, !YAlign), !Image s, !Span, !(!Span, !Span))
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
732
               -> (![(!Span, !Span)], !Span)
733 734
        mkCols cellYSpan yoff (acc, xoff) (align, img=:{transformCorrection = (tfXCorr, tfYCorr)}, cellXSpan, (manXOff, manYOff))
          #! (alignXOff, alignYOff) = calcAlignOffset cellXSpan cellYSpan (mkTotalSpanPostTrans img) align
735 736
          = ([( xoff + alignXOff + manXOff + tfXCorr
              , yoff + alignYOff + manYOff + tfYCorr) : acc], xoff + cellXSpan)
737

Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
738
    desugarAndTagCompose (AsCollage offsets imgs) host tags st
739
      #! (imgs, st) = strictTRMapSt desugarAndTag imgs st
740
      = (( AsCollage offsets imgs
741
         , maybe (calculateComposedSpan (strictTRMap mkTotalSpanPostTrans imgs) offsets) mkTotalSpanPostTrans host), st)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
742
    desugarAndTagCompose (AsOverlay offsets ias imgs) host tags st
743
      #! (imgs, st)     = strictTRMapSt desugarAndTag imgs st
744
      #! spans          = strictTRMap mkTotalSpanPostTrans imgs
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
745 746
      #! (  maxXSpan
          , maxYSpan)   = maybe (maxSpan (strictTRMap fst spans), maxSpan (strictTRMap snd spans))
747
                                (\x -> x.totalSpanPreTrans) host
748 749
      #! alignOffsets   = strictTRZipWith (calcAlignOffset maxXSpan maxYSpan) spans ias
      #! placingOffsets = strictTRZipWith3 addOffset alignOffsets offsets imgs
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
750
      = ( ( AsCollage placingOffsets imgs
751
          , maybe (calculateComposedSpan spans placingOffsets) mkTotalSpanPostTrans host)
752
        , st)
753
      where
754
      addOffset :: !(!Span, !Span) !(!Span, !Span) !(Image s) -> (!Span, !Span)
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
755
      addOffset (x1, y1) (x2, y2) {transformCorrection = (xoff, yoff)} = (x1 + x2 + xoff, y1 + y2 + yoff)
756

757
:: *SpanEnvs =
758
  { spanEnvImageTagPostTrans  :: !IntMap Int
759
  , spanEnvImageSpanPostTrans :: !IntMap ImageSpan
760
  , spanEnvGridTag            :: !IntMap Int
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
761
  , spanEnvGridSpan           :: !IntMap (!IntMap Span, !IntMap Span)
762 763 764 765 766 767
  , spanEnvFonts              :: !Map FontDef (Map String Real)
  }

fixEnvs :: !*FixSpansSt -> *FixSpansSt
fixEnvs st
  = fixEnvs` True {FixSpansSt | st & fixSpansDidChange = False}
768
  where
769
  fixEnvs` :: !Bool !*FixSpansSt -> *FixSpansSt
770 771
  fixEnvs` False st=:{fixSpansDidChange = False} = st
  fixEnvs` _ st
772 773
    #! st = fixImageSpansPostTrans st
    #! st = fixGridSpans           st
774
    = fixEnvs` False st
775 776 777 778 779 780 781
  fixImageSpansPostTrans :: !*FixSpansSt -> *FixSpansSt
  fixImageSpansPostTrans st
    #! fixSpansSpanEnvs          = st.fixSpansSpanEnvs