;; © 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
       " -" "-")))