You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/pitfall/pitfall/path.rkt

81 lines
3.2 KiB
Racket

#lang pitfall/racket
(require brag/support sugar/list)
(provide parse-svg-path)
(define (parse-svg-path doc path)
(define commands (parse path))
(apply-commands commands doc))
(define (parse path)
(define lex-1
(lexer
[(eof) eof]
[alphabetic (string->symbol lexeme)]
[(:: (:? "-") (:* numeric) (:? ".") (:+ numeric)) (string->number lexeme)]
[(:or whitespace ",") (lex-1 input-port)]))
(slicef-at (for/list ([tok (in-port lex-1 (open-input-string path))])
tok) symbol?))
(module+ test
(require rackunit)
(check-equal?
(parse "M 0,20 L 100,160 Q 130,200 150,120 C 190,-40 200,200 300,150 L 400,90")
'((M 0 20)
(L 100 160)
(Q 130 200 150 120)
(C 190 -40 200 200 300 150)
(L 400 90)))
(check-equal?
(parse "M-122.304 84.285C-122.304 84.285 -122.203 86.179 -123.027 86.16C-123.851 86.141 -140.305 38.066 -160.833 40.309C-160.833 40.309 -143.05 32.956 -122.304 84.285z")
'((M -122.304 84.285)
(C -122.304 84.285 -122.203 86.179 -123.027 86.16)
(C -123.851 86.141 -140.305 38.066 -160.833 40.309)
(C -160.833 40.309 -143.05 32.956 -122.304 84.285)
(z)))
(check-equal? (parse "L100-160") '((L 100 -160))))
(define (apply-commands commands doc)
(for/fold ([cx 0][cy 0][px 0][py 0][sx 0][sy 0])
([cmd (in-list commands)])
(match-define (cons cmd-name cmd-args) cmd)
(let loop ([cmd-name cmd-name][cmd-args cmd-args])
(match-define (list a0 a1 a2 a3 a4 a5)
(append cmd-args (make-list (- 6 (length cmd-args)) #f)))
(case cmd-name
[(M) (send doc moveTo . cmd-args)
(values a0 a1 #f #f a0 a1)]
[(m) (loop 'M (list (+ cx a0) (+ cy a1)))]
[(C) (send doc bezierCurveTo . cmd-args)
(values a4 a5 a2 a3 sx sy)]
[(c) (loop 'C (list (+ cx a0) (+ cy a1)
(+ cx a2) (+ cy a3)
(+ cx a4) (+ cy a5)))]
[(S) (match-let ([(list px py) (if (not px)
(list cx cy)
(list px py))])
(send doc bezierCurveyTo (- cx (- px cx)) (- cy (- py cy)) a0 a1 a2 a3)
(values a2 a3 a0 a1 sx sy))]
[(s) (loop 'S (list (+ cx a0) (+ cy a1)
(+ cx a2) (+ cy a3)))]
[(L) (send doc lineTo . cmd-args)
(values a0 a1 #f #f sx sy)]
[(l) (loop 'L (list (+ cx a0) (+ cy a1)))]
[(H) (loop 'L (list a0 cy))]
[(h) (loop 'L (list (+ cx a0) cy))]
[(V) (loop 'L (list cx a0))]
[(v) (loop 'L (list cx (+ cy a0)))]
[(Q) (send doc quadraticCurveTo . cmd-args)
(values a2 a3 a0 a1 sx sy)]
[(q) (loop 'Q (list (+ cx a0) (+ cy a1)
(+ cx a2) (+ cy a3)))]
[(T) (match-define (list px py)
(if (not px)
(list cx py)
(list (- cx (- px cx) (- cy (- py cy))))))
(send doc quadraticCurveTo . cmd-args)]
;; todo other path ops
[(z) (send doc closePath . cmd-args)
(values sx sy px py sx sy)]
[else (raise-argument-error 'apply-commands "valid command name" cmd-name)]))))