; =>man/svg-extensions.sdoc


;;;; .title       The SVG Extension Library
;;;; .author      Kurt Nørmark
;;;; .affiliation Department of Computer Science, Aalborg University
;;;; This library provides a number of SVG abstractions on top of the SVG mirror library.
;;;; The primary abstractions are related to drawing of graph-like structures, composed of
;;;; nodes and edges.  
;;;; There exists a set of <a href="../../examples/svg-extensions/index.html">examples</a> which accompany
;;;; the paper <a href = "http://www.cs.auc.dk/~normark/laml/papers/svg-open-2007/paper.html"> A Graph Library Extension of SVG</a>.
; General XML-in-LAML settings
(set! compact-end-tag-rendering? #f)
(set! use-empty-tags-for-elements-without-contents #t)


; Determines the currently used animation type.
; One of the symbols none, step-buttons-reveal, step-buttons-walk-through, node-emphasize, or edge-emphasize.
; May also be a list of these symbols.
(define current-animation-type 'none)

; An additional propertype for the auto animation type.
; The time before the first step.
; (define auto-animation-type-start 0)

; An additional propertype for the auto animation type.
; The number of seconds per step.
; (define auto-animation-type-seconds-per-step 1)


;;; SVG configuration constants.
;;; A number of constants. Most of the constant details of the graph library extension of SVG.
 
(define svg-language 'svg11)

 
(define standard-svg-1-1-element-attributes
  (list 'version "1.1"
        'baseProfile "full"
        'xmlns "http://www.w3.org/2000/svg"
        'xmlns:xlink "http://www.w3.org/1999/xlink"))

 
(define emphasis-color "red")

 
(define button-color "grey")

 
(define expl-dur "1s")

 
(define node-dur "1s")

 
(define edge-dur "1s")

 
(define edge-move-dur "3s")

 
(define disappear-dur "0.5s")

(define infinite 1000000)

;;; Graph Abstractions.
;;; The major SVG abstractions of this library allows convenient drawing of graphs, in terms of (text) nodes and edges.
 
(define svg-graph 
 (xml-in-laml-abstraction
   (lambda (cont attr)
     (let* ((from-step (as-number (defaulted-get-prop 'from-step attr 0)))   ; svg-graph attributes
            (to-step (as-number (defaulted-get-prop 'to-step attr 0)))
            (button-x (as-number (defaulted-get-prop 'button-x attr 0)))
            (button-y (as-number (defaulted-get-prop 'button-y attr 24)))
            
            ; Information from explanations
            (explanations-ast (traverse-and-collect-first-from-ast cont (ast-of-type? 'element-name "explanations") id-1))
            (explanation-font-size (if explanations-ast (ast-attribute explanations-ast 'font-size 20) #f))
            (explanation-x (if explanations-ast (as-number (ast-attribute explanations-ast 'x 100)) #f))
            (explanation-y (if explanations-ast (as-number (ast-attribute explanations-ast 'y 24 )) #f))
            (explanation-width (if explanations-ast (as-number (ast-attribute explanations-ast 'width 500)) #f))
            (explanation-height (if explanations-ast (as-number (ast-attribute explanations-ast 'height 50)) #f))
            (explanation-list 
             (if explanations-ast 
              (traverse-and-collect-all-from-ast explanations-ast (ast-of-type? 'element-name "explanation")
                 (lambda (expl-ast)
                   (list (as-number (ast-attribute expl-ast 'step)) (ast-subtrees expl-ast))))
              '()))
            (explanation-clause 
              (cond ((and explanations-ast 
                       (or (animation-includes? 'step-buttons-reveal) (animation-includes? 'step-buttons-walk-through) 
                           (animation-includes? 'step-buttons-walk-through-edge-motion)))
                        (make-explanation-clause explanation-list explanation-x explanation-y explanation-width explanation-height
                                           explanation-font-size from-step to-step))
                    ((and explanations-ast (animation-includes? 'auto))
                        (make-explanation-clause-auto explanation-list explanation-x explanation-y explanation-width explanation-height
                                           explanation-font-size from-step to-step))
                   (else '())))

            (animation-control 
              (cond ((or (animation-includes? 'step-buttons-reveal) (animation-includes? 'step-buttons-walk-through) (animation-includes? 'step-buttons-walk-through-edge-motion))
                       (make-animation-control-clause button-x button-y from-step to-step))
                    (else '())))

            (g-attributes (property-subset attr '()))  ; the empty list of attribute
            (g-cont   ; Content without explanations
              (filter (lambda (cnt) (not (and (ast? cnt) (equal? (ast-element-name cnt) "explanations")))) cont))
           )
    (g (open-arrow-def 20 15)  (open-diamond-def 30 22.5) (filled-arrow-def 20 15)  (filled-diamond-def 30 22.5)
       animation-control explanation-clause
       g-cont g-attributes)
   ))
   (required-implied-attributes '() '(from-step to-step button-x button-y)
                                      "svg-graph"
    )
   "svg-graph"
   svg-language))




; Define the triangular backward and forward control. 
; Place first button at x,y.
(define (make-animation-control-clause x y from-step to-step)
   (let ((y (- y 8)))  ; for nicer alignment with explanation
    (list 
     (g   ; FIRST BUTTON

       ; forward triangle
      (let ((x (+ x 50))
           )

         (triangle x (- y 12)  (+ x 24) y x (+ y 12) 
           'fill button-color 'id (animation-forward-button-name from-step) 'css:visibility "visible"
           (show-setting-upon (+ from-step 1) 'backward) ; click on (+ from-step 1) button in backward direction will
; make this triangle visible
           (hide-setting-upon from-step 'forward)        ; click on from-step (this) button in forward direction will
; hide this button 
          )))

     ; MIDDLE SECTION BUTTONS - initially all hidden
     (map (lambda (step)
             (g
               ; backward triangle
               (triangle x y  (+ x 24) (- y 12) (+ x 24) (+ y 12) 
                         'fill button-color 'id (animation-backward-button-name step) 'css:visibility "hidden"
                 (show-setting-upon (- step 1) 'forward) (show-setting-upon (+ step 1) 'backward)                         
                 (hide-setting-upon step 'forward) (hide-setting-upon step 'backward) 
              )

              ; forward triangle
              (let ((x (+ x 50)))
                 (triangle x (- y 12)  (+ x 24) y x (+ y 12) 
                           'fill button-color 'id (animation-forward-button-name step) 'css:visibility "hidden"
                   (show-setting-upon (- step 1) 'forward) (show-setting-upon (+ step 1) 'backward)                         
                   (hide-setting-upon step 'forward) (hide-setting-upon step 'backward)                         
               ))

            ))
           (number-interval (+ from-step 1) to-step)) ; (- to-step 1)

     (g ; LAST BUTTON
; backward triangle
        (triangle x y  (+ x 24) (- y 12) (+ x 24) (+ y 12) 
                 'fill button-color 'id (animation-backward-button-name (+ to-step 1)) 'css:visibility "hidden"
                 (show-setting-upon to-step 'forward) ; (- to-step 1)
                 (hide-setting-upon (+ to-step 1) 'backward)
        )

     )
   )))

; set clause that causes controls to be shown when at step in direction.
(define (show-setting-upon step direction)
  (set 'attributeType "CSS" 
                'attributeName "visibility" 'to "visible"
                'begin 
                (string-append
                    (cond ((eq? direction 'forward) (animation-forward-button-name step))
                          ((eq? direction 'backward) (animation-backward-button-name step))
                          (else (laml-error "show-setting-upon: direction must be either forward or backward" direction)))
                     "." "click") 'fill "freeze"))

(define (hide-setting-upon step direction) 
  (set 'attributeType "CSS" 
                'attributeName "visibility" 'to "hidden"
                'begin 
                (string-append
                    (cond ((eq? direction 'forward) (animation-forward-button-name step))
                          ((eq? direction 'backward) (animation-backward-button-name step))
                          (else (laml-error "show-setting-upon: direction must be either forward or backward" direction)))
                     "." "click") 'fill "freeze"))


 
(define svg-node
 (xml-in-laml-positional-abstraction 3 0
   (lambda (shape-path-function x y cont attr)
     (let* ((id (defaulted-get-prop 'id attr #f))
            (font-size (as-number (defaulted-get-prop 'font-size attr 30)))     ; Abstraction specific attributes
            (font-family (defaulted-get-prop 'font-family attr "times-roman"))  ; "courier-new"
            (text-color (defaulted-get-prop 'text-color attr "black"))
            (text-align (defaulted-get-prop 'text-align attr "cc"))
            (bg-color (defaulted-get-prop 'bg-color attr "white"))
            (locator (defaulted-get-prop 'lc attr "cc"))
            (min-width (as-number (defaulted-get-prop 'min-width attr 0)))
            (min-height (as-number (defaulted-get-prop 'min-height attr 0)))
            (delta-width (as-number (defaulted-get-prop 'delta-width attr 0)))
            (delta-height (as-number (defaulted-get-prop 'delta-height attr 0)))
            (step (as-number (defaulted-get-prop 'step attr 0)))
            (rect-attributes (property-subset attr '(stroke-width stroke stroke-dasharray stroke-offset opacity stroke-opacity rx ry)))   ; SVG attributes
            (text-attributes (property-subset attr '(font-style)))

            (label-dx (as-number (defaulted-get-prop 'ldx attr 0)))
            (label-dy (as-number (defaulted-get-prop 'ldy attr 0)))

            (w (+ (max (measured-text-width cont font-size font-family) min-width) delta-width))     ; Width and height
            (h (+ (max (measured-text-height cont font-size font-family) min-height) delta-height))

            (displacement-vector (rectangle-adjustment locator w h))
            (dx (car displacement-vector))
            (dy (cdr displacement-vector))

            (cr-x (+ x dx))    ; Calculated x and y coordinates of rectangle
            (cr-y (+ y dy))

            (text-x-y-clause (text-x-y cr-x cr-y w h font-size text-align label-dx label-dy))
            (group-animation-clause
             (let* ((step-from (as-number (defaulted-get-prop 'step-from attr step)))    ; step-from .. step-to:  reaveal in this interval
                    (step-to   (as-number (defaulted-get-prop 'step-to attr infinite)))  
                   )
              (if (> step-from step-to) (laml-error "step-from must be less than or equal to step-to" step-from step-to))
              (cond ((animation-includes? 'step-buttons-reveal) ; only step, not steps
                       (list
                        (if (> step-from 0) 
                            (list 'css:visibility "visible" 'css:opacity 0)
                            (list 'css:visibility "visible" 'css:opacity 1))
                        ; going forward
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; APPEARING
                                (list 'from 0 'to 1) 'dur edge-dur  'fill "freeze" 
                                'begin (string-append (animation-forward-button-name step-from) "." "click"))
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; DISAPPEARING
                                (list 'from 1 'to 0) 'dur edge-dur  'fill "freeze" 
                                'begin (string-append (animation-forward-button-name step-to) "." "click"))

                       ; going backward
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; APPEARING
                                (list 'from 0 'to 1) 'dur disappear-dur  'fill "freeze" 
                                'begin (string-append (animation-backward-button-name (+ step-to 1)) "." "click"))
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; DISAPPEARING
                                (list 'from 1 'to 0) 'dur disappear-dur  'fill "freeze" 
                                'begin (string-append (animation-backward-button-name (+ step-from 1)) "." "click"))
                        ))

                     ((animation-includes? 'auto)
                       (let ((start-time (as-number (second current-animation-type)))
                             (seconds-pr-step (as-number (third current-animation-type))))
                        (list
			 (if (> step-from 0) 
			     (list 'css:visibility "visible" 'css:opacity 0)
			     (list 'css:visibility "visible" 'css:opacity 1))
					; going forward
			 (animate 'attributeType "CSS" 'attributeName "opacity"	; APPEARING
				  (list 'from 0 'to 1) 'dur edge-dur  'fill "freeze" 
				  'begin (+ start-time (* step-from seconds-pr-step)))

			 )))
                    (else '()))))
            (rect-animation-clause-node-emphasize 
              (cond ((animation-includes? 'node-emphasize)
                       (list
                         (animate 'attributeType "XML" 'attributeName "fill" 'from bg-color 'to emphasis-color 'dur node-dur 
                                  'begin "mouseover" 'fill "freeze")
                         (animate 'attributeType "XML" 'attributeName "fill" 'from emphasis-color 'to bg-color 'dur disappear-dur
                                  'begin "mouseout" 'fill "freeze")
                       ))
                    (else '())))
            (rect-animation-clause-buttons-walk-through
             (let* ((steps-given (as-number-list (defaulted-get-prop 'steps attr ""))) ; the empty list if steps not supplied.
                    (steps (cond ((not (null? steps-given)) steps-given)
                                (else (list step)))))
               (cond ((or (animation-includes? 'step-buttons-walk-through) (animation-includes? 'step-buttons-walk-through-edge-motion))
                      (map (lambda (step)
                             (list
                              (node-emphasize bg-color (animation-forward-button-name step))

                              (if (>= step 1) 
                                  (node-deemphasize bg-color (animation-forward-button-name (+ step 1)))
                                  '())

                              (node-deemphasize bg-color (animation-backward-button-name (+ step 1)))

                              (if (>= step 1) 
                                  (node-emphasize bg-color (animation-backward-button-name (+ step 2)))
                                  '())
                              )) steps))
                     (else '())))
            
           ))
       (g group-animation-clause
          (shape-path-function cr-x cr-y w h 
             rect-attributes                           ; LAML flattens all lists passed as rest parameters to shape-path-function
             'stroke-width "1" 'stroke "black" 'fill bg-color (if id (list 'id id) '()) 
              rect-animation-clause-node-emphasize rect-animation-clause-buttons-walk-through)
          (text  text-attributes 'font-family font-family 'font-size font-size
                 'stroke text-color 'color text-color 'fill text-color
                 text-x-y-clause 
                 cont
                 )
          )))
    (required-implied-attributes '() '(id font-size font-family text-color text-align bg-color lc min-width min-height delta-width delta-height
                                       stroke-width stroke stroke-dasharray stroke-offset rx ry font-style step steps step-from step-to)
                                      "svg-node"
    )
    "svg-node"
    svg-language))



; (define shaped-svg-node 
; (xml-in-laml-positional-abstraction 3 0
;   (lambda (x y shape-path-fn cont attr)
;     ...)))

 
(define empty-svg-node
 (xml-in-laml-positional-abstraction 2 0
   (lambda (x y cont attr)
      (svg-node rectangular x y "" 'stroke "none" attr))))

; Convert a string of the form "n-m" to the list '(n m). n and m are both positive integers.
; (define (string-to-number-interval str)
;  (map as-number (split-on #\- str)))
  


(define (node-emphasize bg-color-before but)
  (animate 'attributeType "XML" 'attributeName "fill" 
           'from bg-color-before 'to emphasis-color 'dur node-dur 'fill "freeze" 
           'begin (string-append but "." "click")))

(define (node-deemphasize bg-color-after but)
  (animate 'attributeType "XML" 'attributeName "fill" 
           'to bg-color-after 'from emphasis-color 'dur disappear-dur 'fill "freeze" 
           'begin (string-append but "." "click")))

; Given a comma separated string of numbers, such as "1,2,3" return a list of numbers, such as (1 2 3).
(define (as-number-list comma-string)
  (map as-number (string-to-list comma-string (list #\,))))

 
(define svg-composite-node
 (xml-in-laml-positional-abstraction 3 0
   (lambda (x y inner-graph cont attr)
     (let* (
            (bg-color (defaulted-get-prop 'bg-color attr "white"))      ; Abstraction specific attributes
            (locator (defaulted-get-prop 'lc attr "cc"))
            (padding (as-number (defaulted-get-prop 'padding attr 0)))
            (step (as-number (defaulted-get-prop 'step attr 0)))
            (steps-given (as-number-list (defaulted-get-prop 'steps attr "")))  ; the empty list if steps not supplied.
            (steps (cond ((not (null? steps-given)) steps-given)
                         (else (list step))))

            (rect-attributes (property-subset attr '(stroke-width stroke stroke-dasharray stroke-offset rx ry)))     ; SVG attributes

            (min-max-x-y (find-min-max-x-y inner-graph)) ; a list of four numbers: the minimum left-top coordinate and the maximum right-bottom coordinates
            (inner-x (first min-max-x-y))
            (inner-y (second min-max-x-y))
            (width-of-inner-graph (- (third min-max-x-y) (first min-max-x-y)))     ; Width and height
            (height-of-inner-graph (- (fourth min-max-x-y) (second min-max-x-y)))

            (width-of-composite (as-number (defaulted-get-prop 'width attr width-of-inner-graph)))      ; Given attribute. The exact width of the composite node. Not required.
            (height-of-composite (* height-of-inner-graph (divide width-of-composite width-of-inner-graph)))  ; Calcuated - preserves the aspect ratio.

            (displacement-vector (rectangle-adjustment locator (+ width-of-composite (* 2 padding)) (+ height-of-composite (* 2 padding))))
            (dx (car displacement-vector))
            (dy (cdr displacement-vector))

            (cr-x (+ x dx))    ; Calculated x and y coordinates of rectangle
            (cr-y (+ y dy))

            (group-animation-clause
              (cond ((animation-includes? 'step-buttons-reveal) ; only step, not steps
                       (list
                        (if (> step 0) 
                            (list 'css:visibility "visible" 'css:opacity 0)
                            (list 'css:visibility "visible" 'css:opacity 1))
                        (animate 'attributeType "CSS" 'attributeName "opacity" ; APPEARING
                                 'from 0 'to 1 'dur node-dur 'fill "freeze" 
                                 'begin (string-append (animation-forward-button-name step) "." "click"))
                        (animate 'attributeType "CSS" 'attributeName "opacity" ; DISAPPEARING
                                 'from 1 'to 0 'dur disappear-dur  'fill "freeze"
                                 'begin (string-append (animation-backward-button-name (+ step 1)) "." "click"))
                        ))
                    (else '())))
            (rect-animation-clause-buttons-walk-through
              (cond ((or (animation-includes? 'step-buttons-walk-through) (animation-includes? 'step-buttons-walk-through-edge-motion))
                      (map (lambda (step)
                       (list
                        (node-emphasize bg-color (animation-forward-button-name step))

                        (if (>= step 1) 
                            (node-deemphasize bg-color (animation-forward-button-name (+ step 1)))
                            '())

                        (node-deemphasize bg-color (animation-backward-button-name (+ step 1)))

                        (if (>= step 1) 
                            (node-emphasize bg-color (animation-backward-button-name (+ step 2)))
                            '())
                        )) steps)   
                    )
                    (else '())))

           )
         (g group-animation-clause
          (rect rect-attributes 'x cr-x 'y cr-y
                'width (+ width-of-composite (* 2 padding)) 'height (+ height-of-composite (* 2 padding))
                'stroke-width "1" 'stroke "black" 'fill bg-color
                rect-animation-clause-buttons-walk-through
               )
          (g 'transform (svg-translate (+ cr-x padding) (+ cr-y padding) )
            (g 'transform (svg-scale (divide width-of-composite width-of-inner-graph))  
               (g 'transform (svg-translate (- inner-x) (- inner-y)) inner-graph))))))
          

    (required-implied-attributes '() '(step steps padding width bg-color lc min-width min-height 
                                       stroke-width stroke stroke-dasharray stroke-offset rx ry font-style)
                                      "svg-compositie-node"
    )
    "svg-composite-node"
    svg-language))


 
(define (svg-edge . parameters)
  (cond ((and (>= (length parameters) 4)
                  (ast? (first parameters)) (string? (second parameters))
                  (ast? (third parameters)) (string? (fourth parameters)))
           (apply svg-edge-original parameters))
        ((and (>= (length parameters) 2) (ast? (first parameters)) (ast? (second parameters)))
           (apply svg-edge-new parameters))
        (else (laml-error "svg-edge: Either (svg-edge node con node con ...) or (svg-edge node node ...)."))))

; The variant of svg-edge, with four required, position parameters. No optional connectors can be supplied in attributes.
(define svg-edge-original
 (xml-in-laml-positional-abstraction 4 0
   (lambda (from-node from-connector to-node to-connector cont attr)
     (let* ((arrow (defaulted-get-prop 'arrow attr "no"))   ; Abstraction specific attributes
            (from-id (defaulted-get-prop 'from-id attr #f))
            (to-id (defaulted-get-prop 'to-id attr #f))
            (step (as-number (defaulted-get-prop 'step attr 0)))

            (font-size (as-number (defaulted-get-prop 'font-size attr 30)))     ; Label attributes
            (font-family (defaulted-get-prop 'font-family attr "times-roman"))
            (font-style (defaulted-get-prop 'font-style attr "normal"))  
            (text-color (defaulted-get-prop 'text-color attr "black")) 

            (label-dx (as-number (defaulted-get-prop 'ldx attr 0)))
            (label-dy (as-number (defaulted-get-prop 'ldy attr 0)))

            (edge-style (as-symbol (defaulted-get-prop 'style attr "straight")))
            (dx (as-number (defaulted-get-prop 'dx attr 0)))
            (dy (as-number (defaulted-get-prop 'dy attr 0)))

            (from-pair (x-y-of-node from-node from-id from-connector))
            (x1 (+ (car from-pair) dx)) (y1 (+ (cdr from-pair) dy))
            (to-pair (x-y-of-node to-node to-id to-connector))
            (x2 (+ (car to-pair) dx)) (y2 (+ (cdr to-pair) dy))
            (break-path (defaulted-get-prop 'break-path attr #f))
            (edge-break-segment (defaulted-get-prop 'break-path attr (edge-break-segment edge-style x1 y1 x2 y2)))
            (line-attr (property-subset attr '(stroke stroke-width stroke-dasharray stroke-dashoffset stroke-linecap)))   ; 
            (forward-line-id (unique-symbol "line"))
            (reverse-line-id (unique-symbol "line"))
            (stroke-width (as-number (defaulted-get-prop 'stroke-width attr 1)))
            (stroke (defaulted-get-prop 'stroke attr "black"))
            (duration (ensure-as-seconds (defaulted-get-prop 'dur attr edge-move-dur))) 

            (arrow-clause
               (cond ((or (equal? arrow "yes") (equal? arrow "true") (equal? arrow "filled-triangle") (equal? arrow "triangle")) (list 'marker-end "url(#FilledArrowhead)"))
                     ((equal? arrow "open-triangle") (list 'marker-end "url(#OpenArrowhead)") )
                     ((or (equal? arrow "diamond") (equal? arrow "filled-diamond")) (list 'marker-end "url(#FilledDiamond)"))
                     ((equal? arrow "open-diamond") (list 'marker-end "url(#OpenDiamond)"))
                     (else '())) )

            (group-animation-clause
             (let ((step-from (as-number (defaulted-get-prop 'step-from attr step)))    ; step-from .. step-to:  reaveal in this interval
                   (step-to   (as-number (defaulted-get-prop 'step-to attr infinite)))    
                  )
              (if (> step-from step-to) (laml-error "step-from must be less than or equal to step-to" step-from step-to))
              (cond ((animation-includes? 'step-buttons-reveal)  ; only step, not steps
                      (list  
                       (if (> step-from 0)
                           (list 'css:visibility "visible" 'css:opacity 0)
                           (list 'css:visibility "visible" 'css:opacity 1))

                       ; going forward
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; APPEARING
                                (list 'from 0 'to 1) 'dur edge-dur  'fill "freeze" 
                                'begin (string-append (animation-forward-button-name step-from) "." "click"))
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; DISAPPEARING
                                (list 'from 1 'to 0) 'dur edge-dur  'fill "freeze" 
                                'begin (string-append (animation-forward-button-name step-to) "." "click"))

                       ; going backward
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; APPEARING
                                (list 'from 0 'to 1) 'dur disappear-dur  'fill "freeze" 
                                'begin (string-append (animation-backward-button-name (+ step-to 1)) "." "click"))
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; DISAPPEARING
                                (list 'from 1 'to 0) 'dur disappear-dur  'fill "freeze" 
                                'begin (string-append (animation-backward-button-name (+ step-from 1)) "." "click"))

                       ))
                    ((animation-includes? 'auto)
                     (let ((start-time (as-number (second current-animation-type)))
                           (seconds-pr-step (as-number (third current-animation-type))))
                       (list
                        (if (> step-from 0) 
                            (list 'css:visibility "visible" 'css:opacity 0)
                            (list 'css:visibility "visible" 'css:opacity 1))
                       (animate 'attributeType "CSS" 'attributeName "opacity" ; APPEARING
                                (list 'from 0 'to 1) 'dur edge-dur  'fill "freeze" 
                                'begin (+ start-time (* step-from seconds-pr-step))))

                        ))
                    (else '()))))
            (line-animation-clause-edge-emphasize
              (cond ((animation-includes? 'edge-emphasize)
                      (list
                         (animate 'attributeType "XML" 'attributeName "stroke-width" 'from stroke-width 'to (* 4 stroke-width) 
                                  'dur edge-dur 'begin "mouseover" 'fill "freeze")
                         (animate 'attributeType "XML" 'attributeName "stroke-width" 'to stroke-width 'from (* 4 stroke-width)
                                  'dur disappear-dur 'begin "mouseout" 'fill "freeze")

                         (animate 'attributeType "XML" 'attributeName "stroke" 'from stroke 'to emphasis-color 
                                  'dur edge-dur 'begin "mouseover" 'fill "freeze")
                         (animate 'attributeType "XML" 'attributeName "stroke" 'to stroke 'from emphasis-color
                                  'dur disappear-dur 'begin "mouseout" 'fill "freeze")
                       ))
                    (else '())))
            (line-animation-clause-buttons-walk-through
             (let* ((steps-given (as-number-list (defaulted-get-prop 'steps attr ""))) ; the empty list if steps not supplied.
                    (steps (cond ((not (null? steps-given)) steps-given)
                                (else (list step))))
                  )
               (cond ((animation-includes? 'step-buttons-walk-through)
                      (map (lambda (step)
                             (list 
                              (edge-emphasize stroke stroke-width (animation-forward-button-name step))
                              (if (>= step 1) 
                                  (edge-deemphasize stroke stroke-width (animation-forward-button-name (+ step 1)))
                                  '())
                              (edge-deemphasize stroke stroke-width (animation-backward-button-name (+ step 1)))
                              (if (>= step 1)
                                  (edge-emphasize stroke stroke-width (animation-backward-button-name (+ step 2)))
                                  '())
                              )) steps))
                     (else '()))))
            (group-animation-clause-edge-motion
             (let* ((steps-given (as-number-list (defaulted-get-prop 'steps attr ""))) ; the empty list if steps not supplied.
                    (steps (cond ((not (null? steps-given)) steps-given)
                                (else (list step))))
                  )
              (cond ((animation-includes? 'step-buttons-walk-through-edge-motion)
                      (map (lambda (step)
                       (list 
                        (edge-move forward-line-id  (animation-forward-button-name step) duration)
                        (edge-move reverse-line-id  (animation-backward-button-name (+ step 1)) duration)
                        )) steps)
                     )
                    (else '()))))

           )
       (g group-animation-clause group-animation-clause-edge-motion
          (path 'id forward-line-id line-attr 'fill "none"
                'd (am-p x1 y1 (append-path edge-break-segment (al-p x2 y2 (e-p))))
                'stroke stroke 'stroke-width stroke-width                                                               ; defaults due to keep-first attributes in SVG
                arrow-clause line-animation-clause-edge-emphasize line-animation-clause-buttons-walk-through)
          (path 'id reverse-line-id line-attr 'fill "none" 'css:visibility "hidden"
                'd (am-p x2 y2 (append-path edge-break-segment (al-p x1 y1 (e-p)))) 
                'stroke stroke 'stroke-width stroke-width
                arrow-clause line-animation-clause-edge-emphasize line-animation-clause-buttons-walk-through)
          (text 'font-family font-family 'font-size font-size 'font-style font-style
                'stroke text-color 'color text-color 'fill text-color
                'x (+ (+ x1 (divide (- x2 x1) 2)) label-dx) 'y (+ (+ y1 (divide (- y2 y1) 2)) label-dy)
                cont)
       )))

   (required-implied-attributes '() '(from-id to-id arrow stroke-width stroke stroke-dasharray
                                      stroke-linecap stroke-dashoffset step steps step-from step-to
                                      dx dy ldx ldy break-path style font-size font-style text-color dur)
                                "svg-edge"
   )
   "svg-edge"
   svg-language))

; The variant of svg-edge, with two required, position parameters and optional connectors supplied in attributes.
(define svg-edge-new
 (xml-in-laml-positional-abstraction 2 0
   (lambda (from-node to-node cont attr)
    (let* ((from-id (defaulted-get-prop 'from-id attr #f))   ; ids: only in case of composite nodes. Not central. 
           (to-id (defaulted-get-prop 'to-id attr #f))
           (from-connector (defaulted-get-prop 'from-connector attr (default-connection-between from-node from-id to-node to-id)))
           (to-connector   (defaulted-get-prop 'to-connector attr   (default-connection-between to-node to-id from-node from-id))) )
       (svg-edge from-node from-connector to-node to-connector cont attr)))))

; Return a connection point of node, calculated in relation to the (x,y) coordinate of other-node.
; Redefined below.
(define (default-connection-between node node-id other-node other-id)
  (let* ((node-xy (basis-x-y-of-node node node-id))
         (x (car node-xy))  ; (x,y) of bounding rectangle
         (y (cdr node-xy))

         (other-xy (basis-x-y-of-node other-node other-id))
         (ox (car other-xy))
         (oy (cdr other-xy))
        )
    (string-append
      (cond ((= x ox) "c")
            ((> x ox) "l")
            ((< x ox) "r"))
      (cond ((= y oy) "c")
            ((> y oy) "t")
            ((< y oy) "b")))))

; Redefined.
; Return a connection point of node, calculated in relation to the (x,y) coordinate of other-node.
; 45 degree version of the version above.
(define (default-connection-between node node-id other-node other-id)
  (let* ((node-xy (basis-x-y-of-node node node-id))
         (x (car node-xy))
         (y (cdr node-xy))

         (other-xy (basis-x-y-of-node other-node other-id))
         (ox (car other-xy))
         (oy (cdr other-xy))
 
         (xot (- ox x))  ; (ox,oy) translated such that (x,y) is origo
         (yot (- oy y))
        )
    (string-append
      (cond ((and (>= xot (- yot)) (>= xot yot))     "rc")  ; 1
            ((and (<= xot yot)     (>= xot (- yot))) "cb")  ; 2
            ((and (<= xot yot)     (<= xot (- yot))) "lc")  ; 3
            ((and (<= xot (- yot)) (>= xot yot))     "ct")  ; 4
            (else (laml-error "default-connection-between: Should not happen"))))))
   

 
(define svg-edge-broken
 (xml-in-laml-positional-abstraction 5 0
   (lambda (from-node from-connector to-node to-connector node-break-list cont attr)
     (let ((break-path (node-list-to-edge-break-path node-break-list)))
       (svg-edge from-node from-connector to-node to-connector cont attr 'break-path break-path)))))


; Given edge-style (a symbol: straight, hv, or vh) return an appropriate edge-break-segment
(define (edge-break-segment edge-style x1 y1 x2 y2)
  (cond ((eq? edge-style 'straight) (e-p))
        ((eq? edge-style 'hv) (rh-p (- x2 x1) (e-p)))
        ((eq? edge-style 'vh) (rv-p (- y2 y1) (e-p)))
        (else (laml-error "edge-break-segment: Unknown edge style" edge-style))))

; Transform a list nodes to an (absolute) SVG path through the center points of the nodes in svg-node-list.
(define (node-list-to-edge-break-path node-list)
  (cond ((null? node-list) (e-p))
        (else (let* ((node (car node-list))
                     (x-y (x-y-of-node node #f "cc")))
                (al-p (car x-y) (cdr x-y)
                      (node-list-to-edge-break-path (cdr node-list)))))))

(define (edge-move line-id but-name duration)
 (let ((anim-id (string-append "anim-" line-id)))
  (circle 'r 8 'cx 0 'cy 0 'fill emphasis-color 'stroke emphasis-color 'css:visibility "hidden"
    (set 'attributeType "CSS" 'attributeName "visibility" 'to "visible" 'begin (string-append but-name "." "click"))
    (animateMotion 'id anim-id 'dur duration 'rotate "auto" ; 'repeatCount "indefinite"  'fill "freeze"
      'begin (string-append but-name "." "click")  ;  
      (mpath 'xlink:href (string-append "#" line-id)))
    (set 'attributeType "CSS" 'attributeName "visibility" 'to "hidden" 'begin (string-append anim-id ".end")))))


(define (edge-emphasize stroke-before stroke-width-before but-name)
 (list
  (animate 'attributeType "XML" 'attributeName "stroke" 'from stroke-before 'to emphasis-color 
           'dur edge-dur 'fill "freeze" 
           'begin (string-append but-name "." "click"))
  (animate 'attributeType "XML" 'attributeName "stroke-width" 'from stroke-width-before 'to (max 5 (* 2 stroke-width-before)) 
           'dur edge-dur 'fill "freeze" 
           'begin (string-append but-name "." "click"))))

(define (edge-deemphasize stroke-before stroke-width-before but-name)
 (list
   (animate 'attributeType "XML"  'attributeName "stroke" 'to stroke-before 
            'from emphasis-color 'dur disappear-dur 'fill "freeze" 
            'begin (string-append but-name "." "click"))
   (animate 'attributeType "XML"  'attributeName "stroke-width" 'to stroke-width-before 
            'from (max 5 (* 2 stroke-width-before)) 'dur disappear-dur 'fill "freeze" 
            'begin (string-append but-name "." "click"))
 )
)
  


; This function positions the text in a rect-node.
; Calculcate the text x, y coordinate relative to the rectangles x,y coordinates (cr-x, cr-y), width w, and height h,
; and the text alignment locator.
; ldx and ldy reflex manual fine tuning of the text position
; Return an svg attribute list of x, y and text-anchor.
(define (text-x-y cr-x cr-y w h font-size text-align-locator ldx ldy)
  (let* ((hl (horizontal-locator text-align-locator))
         (vl (vertical-locator text-align-locator))
         (wh (divide w 2))
         (hh (divide h 2))
         (hor-contribution 
           (cond ((eq? hl 'c) (list 'x (+ (+ cr-x wh) ldx) 'text-anchor "middle"))
                 ((eq? hl 'l) (list 'x (+ (+ cr-x 5) ldx) 'text-anchor "start"))
                 ((eq? hl 'r) (list 'x (+ (+ cr-x w (- 5)) ldx) 'text-anchor "end"))))
         (ver-contribution 
           (cond ((eq? vl 'c) (list 'y (+ (+ cr-y hh (+ (quotient font-size 2))  (- 5)) ldy)))
                 ((eq? vl 't) (list 'y (+ (+ cr-y font-size) ldy)))
                 ((eq? vl 'b) (list 'y (+  (+ cr-y h (- 5)) ldy)))))
        )
    (append hor-contribution ver-contribution)))

; -----------------------------------------------------------------------------------------------------
; defs clauses with various arrow definition.
; Not a good solution to the arrow problem, because all arrows will be identical (and of the same color).  

(define (open-arrow-def w h)
  (defs
    (marker 'id "OpenArrowhead"
            'viewBox "0 0 10 10" 'refX "10" 'refY "5"
            'stroke "black" 'stroke-width "1" 'fill "white"
            'markerUnits "userSpaceOnUse" 
            'markerWidth w 'markerHeight h
            'orient "auto" 'preserveAspectRatio "none"
            (path 'd "M 0 0 L 10 5 L 0 10 z"))))

(define (filled-arrow-def w h)
  (defs
    (marker 'id "FilledArrowhead"
            'viewBox "0 0 10 10" 'refX "10" 'refY "5" 'fill "black"
            'fill "black"
            'markerUnits "userSpaceOnUse" ; "strokeWidth"   
            'markerWidth w 'markerHeight h
            'orient "auto" 'preserveAspectRatio "none"
            (path 'd "M 0 0 L 10 5 L 0 10 z"))))

(define (open-diamond-def w h)
  (defs
    (marker 'id "OpenDiamond"
            'viewBox "0 -5 10 10" 'refX "10" 'refY "0" 
            'stroke "black" 'stroke-width "1" 'fill "white"
            'markerUnits "userSpaceOnUse" ; "strokeWidth"   
            'markerWidth w 'markerHeight h
            'orient "auto" 'preserveAspectRatio "none"
            (path 'd "M 0 0 L 5 -5 L 10 0 L 5 5 z"))))

(define (filled-diamond-def w h)
  (defs
    (marker 'id "FilledDiamond"
            'viewBox "0 -5 10 10" 'refX "10" 'refY "0" 
            'fill "black"
            'markerUnits "userSpaceOnUse" ; "strokeWidth"   
            'markerWidth w 'markerHeight h
            'orient "auto" 'preserveAspectRatio "none"
            (path 'd "M 0 0 L 5 -5 L 10 0 L 5 5 z"))))

; -----------------------------------------------------------------------------------------------------

; Extract the x, y, width, and height attributes of a rect AST.
; Useful in relation to definition of edges of SVG graphs.
; Return the cons pair of x and y coordinates of the connection point of node-ast relative to the connector con
(define (x-y-of-node node-ast id con)
 (letrec ((node-interesting? (lambda (node-ast) 
                               (and ((ast-of-type? 'element-name "rect") node-ast) 
                                    (equal? (ast-attribute node-ast 'id #f) id))))) 
  (let* ((rect-ast-1 (find-first-ast node-ast "rect"))
         (rect-ast-2 (traverse-and-collect-first-from-ast node-ast node-interesting? id-1))
         (rect-ast (if (and id rect-ast-2) ; still experimental
                       rect-ast-2
                       rect-ast-1))
         (rect-attr (ast-attributes rect-ast))

         (x (as-number (get-prop 'x rect-attr)))
         (y (as-number (get-prop 'y rect-attr)))
         (w (as-number (get-prop 'width rect-attr)))
         (h (as-number (get-prop 'height rect-attr)))
 
         (hl (horizontal-locator con))
         (vl (vertical-locator con))
        )

       (cons
        (cond ((eq? hl 'c) (+ x (divide w 2)))
              ((eq? hl 'l) x)
              ((eq? hl 'r) (+ x w)))
        (cond ((eq? vl 'c) (+ y (divide h 2)))
              ((eq? vl 't) y)
              ((eq? vl 'b) (+ y h)))))))

; A variant of x-y-of-node without use of connectors. 
; Returns a cons pair of (x,y) of node-ast
(define (basis-x-y-of-node node-ast id)
 (letrec ((node-interesting? (lambda (node-ast) 
                               (and ((ast-of-type? 'element-name "rect") node-ast) 
                                    (equal? (ast-attribute node-ast 'id #f) id))))) 
  (let* ((rect-ast-1 (find-first-ast node-ast "rect"))
         (rect-ast-2 (traverse-and-collect-first-from-ast node-ast node-interesting? id-1))
         (rect-ast (if (and id rect-ast-2) ; still experimental
                       rect-ast-2
                       rect-ast-1))
         (rect-attr (ast-attributes rect-ast))

         (x (as-number (get-prop 'x rect-attr)))
         (y (as-number (get-prop 'y rect-attr)))
         (w (as-number (get-prop 'width rect-attr)))
         (h (as-number (get-prop 'height rect-attr)))
        )
     (cons (+ x (divide w 2)) (+ y (divide h 2))))))

; Return delta adjustment to x and y from given-x and given-y relative to the locator.
(define (rectangle-adjustment locator-string width height)
  (let ((hl (horizontal-locator locator-string))
        (vl (vertical-locator locator-string))
       )
    (cons
     (cond ((eq? hl 'c) (- (divide width 2)))
           ((eq? hl 'l) 0)
           ((eq? hl 'r) (- width)))
     (cond ((eq? vl 'c) (- (divide height 2)))
           ((eq? vl 't) 0)
           ((eq? vl 'b) (- height))))))

; Locate all rectangles in svg-graph and find the minimal bounding box that surrounds it.
; Return a list of four coordinates (top-left-x, top-left-y, bottom-right-x, bottom-right-y).
(define (find-min-max-x-y svg-graph-ast)
  (letrec ((reduce-right (lambda (f lst)
                           (if (null? (cdr lst))
                               (car lst)
                               (f (car lst) 
                                  (reduce-right f (cdr lst)))))) 

           (x-y-w-h (lambda (rect-ast)
                      (let ((rect-attr (ast-attributes rect-ast)))
                        (list (as-number (get-prop 'x rect-attr)) (as-number (get-prop 'y rect-attr)) (as-number (get-prop 'width rect-attr)) (as-number (get-prop 'height rect-attr))))))

           (min-list (lambda (lst) (reduce-right min lst)))
           (max-list (lambda (lst) (reduce-right max lst)))
           )
    (let* ((rect-list (find-asts svg-graph-ast "rect"))
           (x-y-w-h-list (map x-y-w-h rect-list))
           (x1-y1-x2-y2-list (map (lambda (x-y-w-y-entry) (list (first x-y-w-y-entry) (second x-y-w-y-entry)
                                                           (+ (first x-y-w-y-entry) (third x-y-w-y-entry)) (+ (second x-y-w-y-entry) (fourth x-y-w-y-entry))))
                                  x-y-w-h-list))

           )
      (list 
       (min-list (map first x1-y1-x2-y2-list)) ; min left top x,y
       (min-list (map second x1-y1-x2-y2-list))
       (max-list (map third x1-y1-x2-y2-list)) ; max right bottom x, y
       (max-list (map fourth x1-y1-x2-y2-list))))))

; ------------------------------------------------------------------
; Locator functions.

(define (horizontal-locator locator-string)
  (let ((ls (as-string locator-string)))
    (check-locator-string! ls)
    (as-symbol (string-ref ls 0))))

(define (vertical-locator locator-string)
  (let ((ls (as-string locator-string)))
    (check-locator-string! ls)
    (as-symbol (string-ref ls 1))))

(define (locator-string? x)
  (and (string? x)
       (= 2 (string-length x))
       (let ((a (string-ref x 0))
             (b (string-ref x 1)))
         (and (or (eqv? a #\c) (eqv? a #\l) (eqv? a #\r))
              (or (eqv? b #\c) (eqv? b #\t) (eqv? b #\b))))))

(define (check-locator-string! ls)
  (if (not (locator-string? ls))
      (laml-error "Invalid locator string:" ls ". " "First char either c, l, or t. Second char either c, t, or b.")))


; Does animation, as defined in the global variable current-animation-type, prescribe animation-kind (a symbol)
(define (animation-includes? animation-kind)
  (cond ((symbol? current-animation-type)
          (eq? animation-kind current-animation-type))
        ((list? current-animation-type)
          (memq animation-kind current-animation-type))
        (else (laml-error "animation-includes?: animation-kind must be a symbol or a list of symbols:" animation-kind))))


 
(define explanations
  (xml-in-laml-abstraction
    (lambda (cont attr)
      (make-ast "explanations" cont attr 'double svg-language))
    (required-implied-attributes '() '(x y font-size width height)
                                      "explanations"
    )
    "explanations"
    svg-language))

 
(define explanation
  (xml-in-laml-abstraction
    (lambda (cont attr)
      (make-ast "explanation" cont attr 'double svg-language))
    (required-implied-attributes '() '(step)
                                      "explanation"
    )
    "explanation"
    svg-language))

; Make the (overlapping) explanations at x,y. Explanation-list is a list of (step explanation) entries.
(define (make-explanation-clause explanation-list x y width height font-size from-step to-step)
 (let ((explanation-list-completed (complete-explanation-list explanation-list to-step)))
  (map 
   (lambda (step-expl)
    (let ((step (car step-expl))
          (expl (cadr step-expl))
          (text-color "black")
         )
     (g 'css:visibility "visible" 'css:opacity (if (= step 0) 1 0)
        (show-explanation-upon step 'forward)
        (show-explanation-upon (+ 2 step) 'backward)
        (hide-explanation-upon (+ step 1) 'forward)
        (hide-explanation-upon (+ step 1) 'backward)

;        (text-box 'x x 'y y 'width ? 'height ?
;                  'font-family "times-roman" 'font-size font-size
;                  'stroke text-color 'color text-color 'fill text-color
;                  expl)

        (text  'font-family "times-roman" 'font-size font-size
                 'stroke text-color 'color text-color 'fill text-color
                 'x x 'y y expl))))
   explanation-list-completed)))

(define (make-explanation-clause-auto explanation-list x y width height font-size from-step to-step)
 (let ((explanation-list-completed (complete-explanation-list explanation-list to-step)))
  (map 
   (lambda (step-expl)
    (let ((step (car step-expl))
          (expl (cadr step-expl))
          (text-color "black")
          (start-time (as-number (second current-animation-type)))
          (seconds-pr-step (as-number (third current-animation-type)))
         )
     (g 'css:visibility "visible" 'css:opacity (if (= step 0) 1 0)
       (animate 'attributeType "CSS" 'attributeName "opacity" 'from 0 'to 1 'dur expl-dur 'fill "freeze" 
		'begin (+ start-time (* step seconds-pr-step)))
       (animate 'attributeType "CSS" 'attributeName "opacity" 'from 1 'to 0 'dur "0.1s" 'fill "freeze" 
                 'begin (+ start-time (* (+ step 1) seconds-pr-step)))
       (text  'font-family "times-roman" 'font-size font-size
                 'stroke text-color 'color text-color 'fill text-color
                 'x x 'y y expl))))
   explanation-list-completed)))

(define (complete-explanation-list explanation-list to-step)
 (let ((sorted-explanation-list (sort-list explanation-list (lambda (x y) (<= (car x) (car y))))))
   (complete-explanation-list-1 sorted-explanation-list 0 to-step)))

(define (complete-explanation-list-1 sorted-explanation-list i to-step)
 (let ((empty-expl ""))
  (cond ((and (> i to-step) (null? sorted-explanation-list)) '())
        ((and (<= i to-step) (null? sorted-explanation-list))
           (cons (list i empty-expl) (complete-explanation-list-1 sorted-explanation-list (+ i 1) to-step)))
        ((= i (car (car sorted-explanation-list)))
           (cons (car sorted-explanation-list) (complete-explanation-list-1 (cdr sorted-explanation-list) (+ i 1) to-step)))
        (else
           (cons (list i empty-expl) (complete-explanation-list-1 sorted-explanation-list (+ i 1) to-step))))))

(define  (show-explanation-upon step direction)
  (animate 'attributeType "CSS" 'attributeName "opacity" 'from 0 'to 1 'dur expl-dur 'fill "freeze" 
                 'begin (string-append 
                         (cond ((eq? direction 'forward) (animation-forward-button-name step))
                               ((eq? direction 'backward) (animation-backward-button-name step))
                               (else (laml-error "show-explanation-upon: direction must be either forward or backward" direction)))
                         "." "click")))

(define  (hide-explanation-upon step direction)
  (animate 'attributeType "CSS" 'attributeName "opacity" 'from 1 'to 0 'dur "0.1s" 'fill "freeze" 
                 'begin (string-append
                         (cond ((eq? direction 'forward) (animation-forward-button-name step))
                               ((eq? direction 'backward) (animation-backward-button-name step))
                               (else (laml-error "hide-explanation-upon: direction must be either forward or backward" direction)))
                         "." "click")))


;;; SVG node shape path functions.
;;; The shape path functions are used as the first parameter to the svg-node function.
;;; The svg-node function calls the shape path function, which is passed as the first parameter to svg-node.
;;; A shape path function is supposed to draw a path that serves as the boundary around the svg node.
;;; The first four parameters of an SVG node shape path function receives a bounding box in terms of x, y, w, and h.
;;; (x,y) is the upper left corner of the bounding box. w is the width (pixels), and h the height (pixels).
;;; Internally a shape path function MUST draw a visible or hidden SVG rect, possibly together with another path inside a group element.
;;; .section-id shape-path-functions
 
(define (rectangular x y w h . attributes)
  (rect  'x x 'y y 'width w 'height h
          attributes  ; earlier attributes overwrites later attributes - controlled by SVG mirror
         'stroke-width "1" 'stroke "black"))

 
(define (circular x y w h . attributes)
  (rect  'x x 'y y 'width w 'height h   'rx (divide w 2) 'ry (divide h 2)   attributes  'stroke-width "1" 'stroke "black"))

 
(define (diamond x y w h . attributes)
  (let* ((hh (divide h 2)) (wh (divide w 2))          ; half height and width
         (sx x) (sy (+ y hh)))       ; diamond start (x,y) coordinates
    (g
      (rect 'css:visibility "hidden" 'x x 'y y 'width w 'height h  attributes  'stroke-width "1" 'stroke "black")  ; hidden boundary rect
      (path attributes 'd (am-p sx sy (rl-p wh (- hh) (rl-p wh hh (rl-p (- wh) hh (rl-p (- wh) (- hh) (e-p))))))))))

 
(define (triangular x y w h . attributes)
  (let* ((hh (divide h 2)) (wh (divide w 2))          ; half height and width
         (sx x) (sy (+ y h)))       ; diamond start (x,y) coordinates
    (g
      (rect 'css:visibility "hidden"  'x x 'y y 'width w 'height h  attributes  'stroke-width "1" 'stroke "black")  ; hidden boundary rect
      (path attributes 'd (am-p sx sy (rl-p wh (- h) (rl-p wh h (rl-p (- w) 0 (e-p)))))))))

 
(define (cloud x y w h . attributes)
  (let* ((h2 (divide h 2)) (w2 (divide w 2))          ; half height and width
         (h4 (divide h2 2)) (w4 (divide w2 2))        ; quarts height and width
         (sx x) (sy (+ y h2))       ; cloud start (x,y) coordinates
         (c (divide (+ w h) 8)) (c2 (divide c 2)) (cm (- c)) (cm2 (- c2))
        )
    (g
      (rect 'css:visibility "hidden" 'x x 'y y 'width w 'height h  attributes  'stroke-width "1" 'stroke "black")  ; hidden boundary rect
      (path attributes
        'd (am-p sx sy 
            (rq-p 0 cm  w4 (- h4)
             (rq-p 0 cm w4 (- h4)
              (rq-p c cm2 w4 h4
               (rq-p c cm w4 h4
                (rq-p c c (- w4) h4
                 (rq-p c c (- w4) h4
                  (rq-p cm2 c (- w4) (- h4)
                   (rq-p cm2 c (- w4) (- h4) 
                    (e-p))))))))))))))

;;; Graph Animations.
;;; Svg graphs can be animated in a number of different ways. 
;;; Use the syntactic form with-animation around an svg-graph form to specify the kind of animation to use.
;;; The following kinds are supported:
;;; <ul>
;;;   <li> none. Do not use any animation at all.
;;;   <li> node-emphasize: Emphasize the node with a particular color when it gets focus with the mouse.
;;;   <li> edge-emphasize: Emphasize the edge with a particular color and thickness when it gets focus with the mouse.
;;;   <li> step-buttons-reveal: 
;;;         The nodes and edges are revealed one after the other, controlled by triangular shaped buttons.
;;;         The step attribute tells when to reveal the graph node or edge.
;;;         A given step attribute value should only appear once with this kind of animation.
;;;         As an alternative to the step attribute, you can use the step-from and step-to attributes to given step interval.
;;;         The node or edge is revealed at step step-to and and hidden at step step-from.
;;;         Several nodes or edges can have the same step value. This leads to simultaneous revealing of these nodes and edges.
;;;   <li> step-buttons-walk-through: The nodes and edges are highlighted in a given order, controlled by triangular shaped buttons. 
;;;        By means of the steps attribute (plural) a given node or edge can be highlighted more than once during the walk through.
;;;        Several nodes or edges can have the same step value. 
;;;   <li> step-buttons-walk-through-edge-motion: The nodes are highlighted in a given order. The edges are animated with a moving token.
;;;        The animation is controlled by triangular shaped buttons. 
;;; </ul>
;;; Within with-animation, you can use node-emphasize and edge-emphasize together. 
;;; You can also use node-emphasize or edge-emphasize (or both) together with step-buttons-reveal and step-buttons-walk-through.
;;; step-buttons-reveal and step-buttons-walk-through cannot be used together.<p>
;;;
;;;
;;; The non-animated part of the graph has implicitly assigned step number 0. 
;;; You can Assign step numbers higher than 0 to selected nodes and edges.
;;; Use the svg-graph attributes to from-step and to-step to control the animated step interval. 

 
(define-syntax with-animation
 (syntax-rules ()
   ((with-animation animation-type form ...)
    (let ((old-animation-type current-animation-type))
      (set! current-animation-type animation-type) 
      (let ((result (begin form ...)))
        (set! current-animation-type old-animation-type)
        result)))))




; ---------------------------------------------------------------------------------------------------
;;; Transform attribute functions.
;;; SVG uses a little language for values of transform attributes. In this section you will find Scheme
;;; counterparts of such expresssions.
 
(define (svg-translate tx ty)
  (string-append "translate" "(" (as-string tx) "," (as-string ty) ")"))

 
(define (svg-scale sx . optional-parameter-list)
 (let ((sy (optional-parameter 1 optional-parameter-list sx)))
  (string-append "scale" "(" (as-string sx) "," (as-string sy) ")")))

 
(define (svg-rotate angle . optional-parameter-list)
 (let ((cx (optional-parameter 1 optional-parameter-list #f))
       (cy (optional-parameter 2 optional-parameter-list #f)))
  (if (and cx cy)
      (string-append "rotate" "(" (as-string angle) "," (as-string cx) "," (as-string cy) ")")
      (string-append "rotate" "(" (as-string angle) ")"))))

 
(define (svg-skewX angle)
  (string-append "skewX" "(" (as-string angle) ")"))

 
(define (svg-skewY angle)
  (string-append "skewY" "(" (as-string angle) ")"))



; ---------------------------------------------------------------------------------------------------
;;; Path functions.
;;; Functions for definition of SVG paths. 
;;; You can think of the functions as constructors of SVG paths.
;;; The functions in this section can be used as the value of d attributes of the SVG path element. 
;;; The functions model a path as a linear recursive structures for instance in the style of lists in Lisp.
;;; All functions return strings.
;;; As a naming convention, the first letter in the prefix tells if we draw in absolute or relative mode ('a' or 'r').
;;; The next letter in the prefix mimics the type of the path ('l' for line, 'm' for move). This letter corresponds to the (lower case) SVG path letter name.
;;; The suffix of the name is always "-p", which is a short name for "-path".
;;; If you dislike the functions you can use native SVG path strings, or you can program your own set of path constructors.
 
(define (e-p) "")

 
(define (al-p x y path) (p-exp "L" path x y))

 
(define (rl-p x y path) (p-exp "l" path x y))

 
(define (ah-p x path) (p-exp "H" path x))

 
(define (rh-p x path) (p-exp "h" path x))

 
(define (av-p y path) (p-exp "V" path y))

 
(define (rv-p y path) (p-exp "v" path y))

 
(define (rm-p x y path) (p-exp "m" path x y))

 
(define (am-p x y path) (p-exp "M" path x y))

 
(define (ra-p rx ry x-axis-rotation large-arc? sweep? x y path)
  (let ((large-arc-number (as-01-boolean large-arc?))
        (sweep-number (as-01-boolean sweep?)))
    (p-exp "a" path rx ry x-axis-rotation large-arc-number sweep-number x y)))

 
(define (aa-p rx ry x-axis-rotation large-arc? sweep? x y path)
  (let ((large-arc-number (as-01-boolean large-arc?))
        (sweep-number (as-01-boolean sweep?)))
    (p-exp "A" path rx ry x-axis-rotation large-arc-number sweep-number x y)))

 
(define (rq-p cx cy x y path)
  (p-exp "q" path cx cy x y))

 
(define (aq-p cx cy x y path)
  (p-exp "Q" path cx cy x y))

 
(define (rt-p x y path)
  (p-exp "t" path x y))

 
(define (at-p x y path)
  (p-exp "T" path x y))

 
(define (rc-p cx1 cy1 cx2 cy2 x y path)
  (p-exp "c" path cx1 cy1 cx2 cy2 x y))

 
(define (ac-p cx1 cy1 cx2 cy2 x y path)
  (p-exp "C" path cx1 cy1 cx2 cy2 x y))

 
(define (rs-p cx2 cy2 x y path)
  (p-exp "s" path cx2 cy2 x y))

 
(define (as-p cx2 cy2 x y path)
  (p-exp "S" path cx2 cy2 x y))

 
(define (z-p) "Z")



 
(define (append-path p1 p2)
  (string-append p1 p2))

; SVG render path
(define (p-exp letter path . coordinates)
  (string-append 
    letter " " 
    (list-to-string (map as-string coordinates) " ") 
    " " path))

; Temporary definition. Strengthen it.
(define (svg-path? x) (string? x))


; ---------------------------------------------------------------------------------------------------

; Misc functions

; Used to prevent rational numbers to appear in SVG, for instance.
(define (divide x y)
  (/ (exact->inexact x) (exact->inexact y)))


(define unique-number 0)

(define (unique-symbol prefix)
  (set! unique-number (+ unique-number 1)) 
  (string-append prefix "-" (as-string unique-number)))


; Generate and return an id of the button that activates step in a button controlled animation.
(define (animation-forward-button-name step-number)
  (string-append "forward-button-id" "-" (as-string step-number)))

(define (animation-backward-button-name step-number)
  (string-append "backward-button-id" "-" (as-string step-number)))

; Generate and return an id of the button text that activates step in a button controlled animation. NOT USED.
(define (animation-button-text-name step-number)
  (string-append "button-text-id" "-" (as-string step-number)))

; ---------------------------------------------------------------------------------------------------

;;; Aditional basic shapes
 
(define triangle 
  (xml-in-laml-positional-abstraction 6 0
    (lambda (x1 y1 x2 y2 x3 y3 cont attr)
     (path 'd (am-p x1 y1 (al-p x2 y2 (al-p x3 y3 (z-p)))) cont attr))))


;;; Extended text management.
;;; Not yet completed. Please disregard this function.
 
(define text-box
  (xml-in-laml-abstraction
   (lambda (cont attr)
     (let* ((x (get-prop 'x attr))
            (y (get-prop 'y attr))
            (width (get-prop 'width attr))
            (height (get-prop 'width attr))
            (font-family (defaulted-get-prop 'font-family attr "times-roman"))
            (font-size   (as-number (defaulted-get-prop 'font-size attr "30")))
           )
        (do-text-box x y width height font-family font-size cont)
     )
   )
   (required-implied-attributes '(x y width height) '(text-color font-family font-size)
                                 "text-box"
   )
   "text-box"
   svg-language))


(define (do-text-box x y width height font-family font-size text-list)
  (laml-error "STOP")
)

(define text-width-factor 1.9)  ; maybe 1.7

; Determines the width of text-contents, relative to a given font size and familiy.
; Conservative and approximate
; The font-size is given in points.
(define (measured-text-width text-contents font-size font-family)
 (let* ((textual? (textual-contents? text-contents))
        (txt (if textual? (string-of-textual-contents text-contents) #f))
        (basis-width (as-number font-size))  ; A width added as the basis width.
; Without it nodes with short labels become too narrow.
       )
 
   (if textual? 
       (+ (* (/ font-size text-width-factor) (string-length txt)) basis-width)    ; earlier (quotient font-size 2)
       0)  ; rely on min-width in this case
   ))

; Determines the height of text-contents, relative to a given font size and familiy.
; Conservative and approximate
; The font-size is given in points.
(define (measured-text-height text-contents font-size font-family)
  (+ font-size 10))

; A predicate which determines if x is considered as textual contents. 
(define (textual-contents? x)
  (cond ((string? x) #t)
        ((list? x)
           (not (find-in-list ast? x)))
        (else (laml-error "textual-contents?: Unknown type of parameter:" x))))

; Return the string from x. x can be a string or the content of an XML-in-LAML AST node.
; Precondition: x satisfies the predicate textual-contents?
(define (string-of-textual-contents x)
 (if (string? x)
     x
    (aggregated-ast-cdata-contents-1 x "") ; undocumented function from xml-in-laml
 ))

; ---------------------------------------------------------------------------------------------------------------

(define (ensure-as-seconds x)
  (cond ((number? x) (string-append (as-string x) "s"))
        ((and (string? x) (eqv? #\s (string-ref x (- (string-length x) 1)))) x)
        ((string? x) (string-append x "s"))
        (else (laml-error "ensure-as-seconds: Cannot ensure x as seconds:" x))))