Add subset of SVG path DSL.

1 files changed, 110 insertions, 1 deletions

diff --git a/pict.scm b/pict.scm
index b853c47..54f0ce0 100644
--- a/pict.scm
+++ b/pict.scm
@@ -59,6 +59,12 @@
             frame
 
             ;; graphics primitives
+            move-to
+            close-path
+            curve
+            line-to
+            path
+
             line
             polyline
             polygon
@@ -360,7 +366,7 @@ strings that are built from the list of attributes LST."
   (make-pict
    (foldt (lambda (thing)
             (let ((tag (car thing)))
-              (if (member tag '(rect polygon polyline circle ellipse text))
+              (if (member tag '(path rect polygon polyline circle ellipse text))
                   (proc thing) thing)))
           identity
           (pict-sxml pict))))
@@ -547,6 +553,109 @@ full transparency) and 1 (for full opacity)."
 ;;; Each shape is wrapped in an SVG tag that records the width,
 ;;; height, and the coordinates.
 
+;; This is a record for path draw instruction
+(define-record-type <instruction>
+  (make-instruction type absolute? points compile)
+  instruction?
+  (type      instruction-type)
+  (absolute? instruction-absolute?)
+  (points    instruction-points)
+  (compile   instruction-compile))
+
+(define* (move-to point #:key absolute?)
+  (make-instruction
+   'move absolute?
+   (list point)
+   (lambda ()
+     (format #false "~a ~a,~a"
+             (if absolute? "M" "m")
+             (car point) (cdr point)))))
+
+(define (close-path)
+  (make-instruction
+   'close #false
+   (list)
+   (const "z")))
+
+(define* (line-to point #:key absolute?)
+  (make-instruction
+   'line-to absolute?
+   (list point)
+   (lambda ()
+     (format #false "~a ~a,~a"
+             (if absolute? "L" "l")
+             (car point) (cdr point)))))
+
+;; The last point is the target
+(define* (curve points #:key absolute?)
+  (call-with-values
+      (lambda ()
+        (match points
+          ((one)
+           (values "s" (list one one)))
+          ((one two)
+           (values "s" (list one two)))
+          ((and (one two . more) points)
+           (values "c" points))))
+    (lambda (command points)
+      (make-instruction
+       'curveto absolute?
+       points
+       (lambda ()
+         (format #false "~a ~{~a~^ ~}"
+                 (if absolute? (string-upcase command) command)
+                 (map (lambda (point)
+                        (format #false "~a,~a"
+                                (car point) (cdr point)))
+                      points)))))))
+
+(define* (path instructions
+               #:key
+               (color "black")
+               (stroke-width 1))
+  "TODO"
+  (match (fold
+          (lambda (instruction acc)
+            (match (instruction-points instruction)
+              (() acc)
+              (lst
+               (let ((point (last lst)))
+                 (match acc
+                   ((cursor-x cursor-y min-x max-x min-y max-y)
+                    (match point
+                      ((x . y)
+                       (if (instruction-absolute? instruction)
+                           (list x y
+                                 (min x min-x)
+                                 (max x max-x)
+                                 (min y min-y)
+                                 (max y max-y))
+                           (list (+ x cursor-x)
+                                 (+ y cursor-y)
+                                 (min (+ cursor-x x) min-x)
+                                 (max (+ cursor-x x) max-x)
+                                 (min (+ cursor-y y) min-y)
+                                 (max (+ cursor-y y) max-y)))))))))))
+          (list 0 0 0 0 0 0)
+          instructions)
+    ((cursor-x cursor-y min-x max-x min-y max-y)
+     (make-pict
+      `(svg (@ (width ,(+ (abs min-x)
+                          (abs max-x)))
+               (height ,(+ (abs min-y)
+                           (abs max-y)))
+               (x 0)
+               (y 0))
+            (path (@ (d ,(string-join
+                          (map (lambda (instruction)
+                                 ((instruction-compile instruction)))
+                               instructions)))
+                     (style ,(style-list->string
+                              `(("fill" "none")
+                                ("stroke" ,color)
+                                ("stroke-width"
+                                 ,(number->string stroke-width))))))))))))
+
 (define* (line x1 y1 x2 y2
                #:optional (maxw 0) (maxh 0)
                #:key