;; © 2022 Idiomdrottning. LGPL, see COPYING for details (define ((wrap cs) x) (strse cs (only second "") x)) (define (lex path) (string->read (string-append "(" (strse path "," " " 'alpha (wrap " ") (: (=> prev (~ " ")) "-") (conc prev " -") (: alpha (+ (~ alpha))) (wrap "()") (: (? "-") (+ (or numeric "."))) (conc "#e" (m 0))) ")"))) (define (arity sym) (case sym ((Z z) 0) ((H h V v) 1) ((M m L l T t) 2) ((S s Q q) 4) ((C c) 6) ((A a) 7) (else (error sym " isn't a path operator")))) (define ((sep n) head bod) (cons head ((sep n) bod))) (define ((sep n) head ()) (list head)) (define ((sep n) bod) (->* bod (split-at n) ((sep n)))) (define (split-op (op . params)) ((over (cons op x)) ((sep (arity op)) params))) (define (opify ops) (append-map split-op ops)) (define string->path (o opify lex)) ;; r: relative, a: absolute, !: update pen (define r->a! (call-table* initial: 0 proc: +)) (define a->a! (call-table)) (a->a! update: (r->a!)) (define (r->a s n) (+ n (a->a! s))) (define (a->r s n) (- n (a->a! s))) (define (a->r! s n) (keep r->a! s (a->r s n))) (define (r->r! s n) (r->a! s n) n) (define (l? x) (strse?* x 'lower)) (define (u? x) (strse?* x 'upper)) (define upcase (as-list (c map char-upcase))) (define downcase (as-list (c map char-downcase))) (define (op->abs op) (map a->a! '(x y) (take-right op 2)) op) (define (op->abs ((? l? op) . (= (sep 2) params))) (cons (upcase op) (append (append-map (c map r->a '(x y)) (butlast params)) (map r->a! '(x y) (last params))))) (define (op->abs ((or 'z 'Z))) '(Z)) (define (op->abs ('h x)) (list 'H (r->a! 'x x))) (define (op->abs ('H x)) (list 'H (a->a! 'x x))) (define (op->abs ('v y)) (list 'V (r->a! 'y y))) (define (op->abs ('V y)) (list 'V (a->a! 'y y))) (define (op->abs ('a rx ry tilt size sweep x y)) (list 'A rx ry tilt size sweep (r->a! 'x x) (r->a! 'y y))) (define (op->rel op) (map r->r! '(x y) (take-right op 2)) op) (define (op->rel ((? u? op) . (= (sep 2) params))) (cons (downcase op) (append (append-map (c map a->r '(x y)) (butlast params)) (map a->r! '(x y) (last params))))) (define (op->rel ((or 'z 'Z))) '(z)) (define (op->rel ('h x)) (list 'h (r->r! 'x x))) (define (op->rel ('H x)) (list 'h (a->r! 'x x))) (define (op->rel ('v y)) (list 'v (r->r! 'y y))) (define (op->rel ('V y)) (list 'v (a->r! 'y y))) (define (op->rel ('A rx ry tilt size sweep x y)) (list 'a rx ry tilt size sweep (a->r! 'x x) (a->r! 'y y))) (define ((m0-> sym) ((or 'm 'M) . params)) (map a->a! '(x y) (take-right params 2)) (cons sym params)) (import tree) (define (inexactify tree) (tree-map (fn (if (and (number? x) (not (integer? x))) (exact->inexact x) x)) tree)) (define previous-op (make-parameter #f)) ;; Restore pen after calculating results: (define-syntax-rule (save-excursion body ...) (let* ((it (hash-table-copy (r->a!))) (ret (begin body ...))) (a->a! update: it) (r->a! update: it) ret)) (define (op->min op) (let* ((ex (memoize (fn (-> x inexactify ->string (strse " -" "-") string-length)))) (rel (save-excursion (op->rel op))) (abs (op->abs op))) (cond ((< (ex abs) (ex rel)) abs) ((> (ex abs) (ex rel)) rel) ((eq? (previous-op) (car op)) (if (l? (car op)) rel abs)) (else (previous-op (car op)) rel)))) (define (harmonize-open x) x) (define (harmonize-open ('M . params) ('m . np) . rest) (cons (cons 'm (append params np)) rest)) (define ((ign-atts proc) op) (proc op)) (define ((ign-atts proc) (op (and atts ('@ . _)) . params)) (with (proc (cons op params)) (cons* (car it) atts (cdr it)))) (define (strip-atts op) op) (define (strip-atts (op ('@ . _) . params)) (cons op params)) (define ((path-in-order fproc rproc) (= (?-> string? string->path) (first . rest))) (cons (fproc first) (map-in-order rproc rest))) (define ((->path-skele fproc rproc) ops) (path-in-order (ign-atts fproc) (ign-atts rproc) ops)) (define ->apath (->path-skele (m0-> 'M) op->abs)) (define ->rpath (->path-skele (m0-> 'm) op->rel)) (define ->mpath (->path-skele (m0-> 'M) op->min)) (define (add-coord (and all (op . params))) (add-coord (cons* op '(@) params))) (define (add-coord (and all (op ('@ . atts) . params))) (op->abs (cons op params)) `(,op (@ ,@(alist-update 'coords `((x ,(a->a! 'x)) (y ,(a->a! 'y))) atts)) ,@params)) (define add-coords (path-in-order (o add-coord (m0-> 'M)) add-coord)) (define (get-coords (= (c alist-ref 'coords) atts)) (list (car (alist-ref 'x atts)) (car (alist-ref 'y atts)))) (define (coordless? ops) (not (every (fn (tree-find (is? 'coords) x #f)) ops))) (define (hypothenuse w h) (inexact->exact (abs (sqrt (+ (* h h) (* w w)))))) (define (distance (= get-coords (x1 y1)) (= get-coords (x2 y2))) (hypothenuse (- x1 x2) (- y1 y2))) (define att-stack (call-key*)) (define (add-distance op atts next-atts params) `(,op (@ ,@(alist-update 'distance (list (distance atts next-atts)) atts)) ,@params)) (define (add-distances* ((op ('@ . atts) . params))) (list (add-distance op atts (last (att-stack)) params))) (define (add-distances* ((op ('@ . atts) . params) . (and future ((_ ('@ . next-atts) . _) . _)))) (att-stack atts) `(,(add-distance op atts next-atts params) ,@(add-distances* future))) (define (add-distances (= (?-> coordless? add-coords) ops)) (att-stack update: '()) (add-distances* ops)) (define (unopify x) x) (define (unopify (op . future)) (cons op (unopify future))) (define (unopify ((op . oldp) (op . params) . future)) (cons* (cons op (append oldp params)) (unopify future))) (define (path->string path) (-> path ->mpath ((c map strip-atts)) harmonize-open unopify inexactify (strse* (: ") (") "" '(+ ("()")) "" (: (=> op alpha) " ") op " -" "-")))