;; © 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-node (op . params)) ((over (cons op x)) ((sep (arity op)) params))) (define (nodify nodes) (append-map split-node nodes)) (define string->path (o nodify 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 (over (char-upcase x))) (define downcase (over (char-downcase x))) (define (node->abs node) (map a->a! '(x y) (take-right node 2)) node) (define (node->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 (node->abs ((or 'z 'Z))) '(Z)) (define (node->abs ('h x)) (list 'H (r->a! 'x x))) (define (node->abs ('H x)) (list 'H (a->a! 'x x))) (define (node->abs ('v y)) (list 'V (r->a! 'y y))) (define (node->abs ('V y)) (list 'V (a->a! 'y y))) (define (node->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 (node->rel node) (map r->r! '(x y) (take-right node 2)) node) (define (node->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 (node->rel ((or 'z 'Z))) '(z)) (define (node->rel ('h x)) (list 'h (r->r! 'x x))) (define (node->rel ('H x)) (list 'h (a->r! 'x x))) (define (node->rel ('v y)) (list 'v (r->r! 'y y))) (define (node->rel ('V y)) (list 'v (a->r! 'y y))) (define (node->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 (node->min node) (let* ((ex (memoize (fn (-> x inexactify ->string (strse " -" "-") string-length)))) (rel (save-excursion (node->rel node))) (abs (node->abs node))) (cond ((< (ex abs) (ex rel)) abs) ((> (ex abs) (ex rel)) rel) ((eq? (previous-op) (car node)) (if (l? (car node)) rel abs)) (else (previous-op (car node)) 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) node) (proc node)) (define ((ign-atts proc) (op (and atts ('@ . _)) . params)) (with (proc (cons op params)) (cons* (car it) atts (cdr it)))) (define (strip-atts node) node) (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) nodes) ((path-in-order (ign-atts fproc) (ign-atts rproc)) nodes)) (define ->apath (->path-skele (m0-> 'M) node->abs)) (define ->rpath (->path-skele (m0-> 'm) node->rel)) (define ->mpath (->path-skele (m0-> 'M) node->min)) (define ((get-attribute key) node) (eif ((sxpath `(@ ,key)) node) (cdar it) #f)) (define ((add-attribute key value) (op . params)) ((add-attribute key value) (cons* op '(@) params))) (define ((add-attribute key value) (op ('@ . atts) . params)) `(,op (@ ,@(alist-update key ((?-> atom? list) value) atts)) ,@params)) (define (add-coord node) ((ign-atts node->abs) node) ((add-attribute 'coords `((x ,(a->a! 'x)) (y ,(a->a! 'y)))) node)) (define add-coords (path-in-order (o add-coord (m0-> 'M)) add-coord)) (define (get-coords (= (get-attribute 'coords) alis)) ((over (car (alist-ref x alis))) '(x y))) (define (coordless? nodes) (not (every (fn (tree-find (is? 'coords) x #f)) nodes))) (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 node next-node) ((add-attribute 'distance (distance node next-node)) node)) (define (add-distances* first-node (node)) (list (add-distance node first-node))) (define (add-distances* first-node (node . (and future (next-node . _)))) (cons (add-distance node next-node) (add-distances* first-node future))) (define (add-distances (= (?-> coordless? add-coords) nodes)) (add-distances* (first nodes) nodes)) (define (unnodify x) x) (define (unnodify (op . future)) (cons op (unnodify future))) (define (unnodify ((op . oldp) (op . params) . future)) (cons* (cons op (append oldp params)) (unnodify future))) (define (path->string path) (-> path ->mpath ((c map strip-atts)) harmonize-open unnodify inexactify (strse* (: ") (") "" '(+ ("()")) "" (: (=> op alpha) " ") op " -" "-")))