;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                    ;;
;;                          gatocout.scm                              ;;
;;                                                                    ;;
;; Gatomorphism conversion functions (for output).                    ;;
;; Written by Antti Karttunen (firstname.surname@iki.fi) April, 2002  ;;
;;                                                                    ;;
;; The functions convert s-expressions (which can be viewed either as ;;
;; parenthesizations or (planar & rooted) car/cdr-binary trees)       ;;
;; to structures better suited for the output of the certain          ;;
;; manifestations of Stanley's exercise 19.                           ;;
;; This module is independent of the actual graphics library/output   ;;
;; device used.                                                       ;;
;;                                                                    ;;
;; This file is located under:                                        ;;
;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm  ;;
;;                                                                    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; From http://www.swiss.ai.mit.edu/projects/scheme/documentation/user_5.html
;;
;; If you redefine some global name in your code, for example, car, cdr
;; and cons, you should indicate it in the declaration as:
;; (declare (usual-integrations car cdr cons))

;; (Beware of using an argument name like list in the function definitions?)

;; (declare (usual-integrations))  ;; For compilation in MIT Scheme.


;; Transferred from gatorank.scm:
;; (p->Lw p) converts a parenthesization 'p'to Lukasiewicz word
;; (in car-branch first, depth-first order, discarding the last zero).
;;

;; (output_seq (map (lambda (L) (baselist->n 10 L)) (map p->Lw (map BinTree2Tree (map binexp->parenthesization (map A014486 (iota0 64)))))))
;; --> 0,20,2020,2200,202020,202200,220020,220200,222000,... gives A071152.

;; (output_seq (map (lambda (L) (baselist->n 10 L)) (map p->Lw (map binexp->parenthesization (map A014486 (iota0 64))))))
;; --> 0,1,20,11,300,201,210,120,111,... gives A071153.

;; (output_seq (sort (map (lambda (L) (baselist->n 10 L)) (map p->Lw (map binexp->parenthesization (map A014486 (iota0 64))))) <))
;; -> 0,1,11,20,111,120,201,210,300,... gives A071154.

;; Calling this for the Figure 1: (A plane tree) shown in Stanley's
;; Hipparchus, Plutarch, Schröder and Hough, Am. Math. Monthly, Vol. 104,
;; No. 4, p. 344, 1997. (See http://www-math.mit.edu/~rstan/papers.html)
;; we obtain:
;;
;; (p->Lw '((() ()) ( (()()()()()) () (()()) ) (() () (() ()))))
;; (3 2 0 0 3 5 0 0 0 0 0 0 2 0 0 3 0 0 2 0)

(define (p->Lw p)
  (reverse! (cdr (reverse
    (let recurse ((p p))
           (cond ((null? p) (list 0))
                 (else ;; it is a list.
                    (append! (list (length p))
                             (apply append! (map recurse p))
                    )
                 )
           )
    )
  )))
)



;; From the interpretation d (plane binary trees with 2n+1 vertices (i.e. n+1 endpoints))
;; to the interpretation a (triangularizations of a convex (n + 2)-gon
;; into n triangles by n-1 diagonals that do not intersect in their interiors).
;;
;; (binexp->parenthesization (A014486 1)) --> (())
;; (bt->pt '(()))       --> ((1 . 2) (2 . 3) (1 . 3))
;; (binexp->parenthesization (A014486 2)) --> (() ())
;; (bt->pt '(() ()))    --> ((1 . 2) (2 . 3) (3 . 4) (2 . 4) (1 . 4))
;; (binexp->parenthesization (A014486 3)) --> ((()))
;; (bt->pt '((())))     --> ((1 . 2) (2 . 3) (1 . 3) (3 . 4) (1 . 4))
;; (binexp->parenthesization (A014486 4)) --> (() () ())
;; (bt->pt '(() () ())) --> ((1 . 2) (2 . 3) (3 . 4) (4 . 5) (3 . 5) (2 . 5) (1 . 5))

;; Note that the recursion order is important
;; (car-branch before the cdr-branch) because
;; of the side-effects of c we are playing with.
;; The largest n upto which we have drawn the edge segments
;; can always be found from the cdr-part of the first
;; pair in c, i.e. with (cdar c)
;;
;; The corners of the polygon are numbered clockwise
;; from 1 to n (where n = the number of leaves (here: ()'s)
;; in the binary tree + 1 for the root fork), so that
;; the corner 1 is at the left end and the corner n is
;; at the right end of the bottom ('root') edge
;; of the polygon.

(define (bt->pt bt)
  (let ((c (list (cons 0 1))))
     (let recurse ((bt bt) (sel +)) ;; + is playing the role of id. Not used.
        (cond ((not (pair? bt)) ;; A leaf -> The next onto edge.
                 (attach! (cons (cdar c) (1+ (cdar c))) c)
              )
              (else ;; It's a fork, so we need a diameter.
                 (let ((left-min (recurse (car bt) min)))
                    (attach! (cons left-min (recurse (cdr bt) max)) c)
                 )
              )
        )
        (sel (caar c) (cdar c))
     )
     (cdr (reverse! c))
  )
)

;; From the interpretation n (non-crossing handshakes, i.e. nonintersecting
;; chords joining 2n points on the circumference of a circle) to the
;; interpretation kk (fixed-point free and non-crossing involutions of [2n]):

;; (sexp->hs '())             -> ()
;; (sexp->hs '(()))           -> ((1 . 2))
;; (sexp->hs '(() ()))        -> ((1 . 2) (3 . 4))
;; (sexp->hs '((())))         -> ((1 . 4) (2 . 3))
;; (sexp->hs '(() () ()))     -> ((1 . 2) (3 . 4) (5 . 6))
;; (sexp->hs '(() (())))      -> ((1 . 2) (3 . 6) (4 . 5))
;; (sexp->hs '((()) ()))      -> ((1 . 4) (2 . 3) (5 . 6))
;; (sexp->hs '((() ())))      -> ((1 . 6) (2 . 3) (4 . 5))
;; (sexp->hs '(((()))))       -> ((1 . 6) (2 . 5) (3 . 4))

;; Could be cleaner, probably:

(define (sexp->hs p)
  (let ((c (list (cons 0 0)))
        (maxnode (list 0))
       )
     (let recurse ((p p))
        (cond ((pair? p)
                 (let ((this-trans (cons (1+ (car maxnode)) 0)))
                    (set-car! maxnode (1+ (car maxnode)))
                    (attach! this-trans c)
                    (recurse (car p))
                    (set-car! maxnode (1+ (car maxnode)))
                    (set-cdr! this-trans (car maxnode))
                    (recurse (cdr p))
                 )
              )
        )
     ) ; let recurse
     (cdr (reverse! c))
  ) ; let
)

;; Does either of these implement (accidentally) any of the
;; algorithms mentioned in "Drawing trees nicely with TeX",
;; by A. Brüggemann-Klein and D. Wood, available at:
;; http://cajun.cs.nott.ac.uk/compsci/epo/papers/volume2/issue2/epabk022.pdf ??
;;
 
;; For the "optimized" output of the binary trees we first construct
;; a breadth-first-wise "spread-tree" (cf. spreadsheet) of the
;; car/cdr-tree to be output (with the function construct-coordinate-tree),
;; and then "instantiate" its nodes with clash-free X-coordinates
;; using the function fill-cordtree-x-coordinates!

;;
;; Construct a list structure like:
;; (construct-coordinate-tree '(a . (b . c)))
;; --> (((0 . 0)) (((0 . 0)) ((0 . 0))) ((((0 . 0))) (((0 . 0)))))
;;
;; (construct-coordinate-tree '((a . b) . c))
;; --> (((0 . 0)) (((0 . 0)) ((0 . 0))) ((((0 . 0)) ((0 . 0))) (((0 . 0)) ((0 . 0)))))
;;

(define (construct-coordinate-tree bt)
  (let ((cs (list (list (cons 0 0))))) ;; The root at x-position 0.
   ((lambda (recfun)
      (cond ((pair? bt)
        (recfun (cdr bt) 1)
        (recfun (car bt) 1)
      ))
      cs
    )
     (letrec ((recurse (lambda (bt depth)
                (let ((this-level (nthcdr depth cs))
                      (prev-level (list-ref cs (- depth 1)))
                     )

                 (if (pair? this-level) ;; Not the first of this level.
                     (set-car! this-level (cons prev-level (car this-level)))
                     (append! cs (list (list prev-level)))
                 )
                 (cond ((pair? bt)
                          (recurse (cdr bt) (1+ depth))
                          (recurse (car bt) (1+ depth))
                       )
                 ) ; cond
                ) ; let
             )))
           recurse
     ) ; letrec
   ) ; lambda
  ) ; let
)


(define (repl-parent-pointers-with-coord-pairs! lista x-displ)
   (cond ((pair? lista)
            (set-car! lista (cons (+ (caaar lista) x-displ) (caaar lista)))
            (repl-parent-pointers-with-coord-pairs! (cdr lista) (- x-displ))
         )
   )
)

(define (add-displ-to-each-child-x! lista x-displ)
   (cond ((pair? lista)
            (set-car! (car lista) (+ (caar lista) x-displ))
            (add-displ-to-each-child-x! (cdr lista) (- x-displ))
         )
   )
)

(define (clash-free? level)
   (or (null? level)
       (null? (cdr level))
       (apply < (map car level))
   )
)


;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '()) 1)
;; --> (((0 . 0)))
;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '(a . b)) 1)
;; --> (((0 . 0)) ((-1 . 0) (1 . 0)))
;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '(a . (b . c))) 1)
;; --> (((0 . 0)) ((-1 . 0) (1 . 0)) ((0 . 1) (2 . 1)))
;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '((a . b) . c)) 1)
;; --> (((0 . 0)) ((-1 . 0) (1 . 0)) ((-2 . -1) (0 . -1)))
;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '((a . b) . (c . d))) 1)
;; --> (((0 . 0)) ((-1 . 0) (1 . 0)) ((-3/2 . -1) (-1/2 . -1) (1/2 . 1) (3/2 . 1)))
;;  (fill-cordtree-x-coordinates! (construct-coordinate-tree '((a . (b . c)) . ((d . e) . f))) 1)
;; --> (((0 . 0)) ((-1 . 0) (1 . 0)) ((-3/2 . -1) (-1/2 . -1) (1/2 . 1) (3/2 . 1)) ((-3/4 . -1/2) (-1/4 . -1/2) (1/4 . 1/2) (3/4 . 1/2)))
;; 


;; Call as (fill-cordtree-x-coordinates! (construct-coordinate-tree bt) x-displ)
(define (fill-cordtree-x-coordinates! ct x-displ)
  (cond ((pair? ct)
           (cond ((not (number? (caaar ct))) ;; Still pointers to parents at this level.
                   (repl-parent-pointers-with-coord-pairs! (car ct) (- x-displ))
                   (fill-cordtree-x-coordinates! ct x-displ) ;; And check again.
                 )
                 ((clash-free? (car ct)) ;; If this level is clash-free, then continue
                   (fill-cordtree-x-coordinates! (cdr ct) x-displ)
                 )
                 (else ;; We have to contract the branches at this level.
                   (add-displ-to-each-child-x! (car ct) (/ x-displ 2))
                   (fill-cordtree-x-coordinates! ct (/ x-displ 2)) ;; And try again.
                 )
           )
        )
  )
  ct
)



;; (p->tree-x-coordinates '())       --> (1)
;; (p->tree-x-coordinates '(()))     --> (1 (1))
;; (p->tree-x-coordinates '((())))   --> (1 (1 (1)))
;; (p->tree-x-coordinates '(()()))   --> (3/2 (1) (2))
;; (p->tree-x-coordinates '(()()())) --> (2 (1) (2) (3))
;; (p->tree-x-coordinates '((())())) --> (3/2 (1 (1)) (2))
;; (p->tree-x-coordinates '(()(()))) --> (3/2 (1) (2 (2)))
;; (p->tree-x-coordinates '((()()))) --> (3/2 (3/2 (1) (2)))
;; (p->tree-x-coordinates '(((())))) --> (1 (1 (1 (1))))


(define (incr x) (set-car! x (+ (car x) 1)) (car x))


(define (average-x-of branches)
   (/ (apply + (map car branches)) (length branches))
)

(define (p->tree-x-coordinates p)
  (let ((max_x (list 0)))
    (let recurse ((p p))
       (cond ((not (pair? p)) (list (incr max_x)))
             (else
               (let ((branches (map recurse p)))
                  (cons (average-x-of branches) branches)
               )
             )
       )
    )
  )
)



;; (normalize-root-to-zero-and-scale! (p->tree-x-coordinates '(()((())()))) 12)
;; --> (0 (-9) (9 (3 (3)) (15)))

(define (normalize-root-to-zero-and-scale! tx x-scale)
   (let ((off (car tx)))
      (let recurse ((tx tx))
         (cond ((pair? tx)
                    (if (number? (car tx))
                        (set-car! tx (* (- (car tx) off) x-scale))
                        (recurse (car tx))
                    )
                    (recurse (cdr tx))
               )
         )
      )
      tx
   )
)