diff options
| -rw-r--r-- | pict.scm | 111 |
1 files changed, 110 insertions, 1 deletions
@@ -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 |