;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                      ;;
;;  http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatosima.scm   ;;
;;  - System for automatically constructing simple recursive            ;;
;;    gatomorphisms of type A starting from the basic primitives        ;;
;;    swap!, exch2first-cdr!                                            ;;
;;                                                                      ;;
;;  This Scheme-code is coded 2002 by Antti Karttunen,                  ;;
;;  (E-mail: my_firstname.my_surname@iki.fi) and is placed in           ;;
;;  Public Domain.                                                      ;;
;;                                                                      ;;
;;  All the examples run at least in MIT Scheme Release 7.6.0, for      ;;
;;  which one can find documentation and the pre-compiled binaries      ;;
;;  (for various OS's running in Intel x86 architecture) under the URL: ;;
;;                                                                      ;;
;;  http://www.swiss.ai.mit.edu/projects/scheme/                        ;;
;;                                                                      ;;
;;  The main pointer for this code collection is:                       ;;
;;  http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm   ;;
;;                                                                      ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                       ;;
;; Gatomorphism (noun) = any bijection from a set of parenthesizations   ;;
;; of size n to the same set (of size n), which is well-defined for      ;;
;; all the sizes n (for sizes n=0 and 1 we have an identity mapping).    ;;
;; In place of parenthesizations we can assume any other manifestation   ;;
;; of the exercise 19 by Stanley.                                        ;;
;;                                                                       ;;
;; See R. P. Stanley, Exercises on Catalan and Related Numbers,          ;;
;; located at: http://www-math.mit.edu/~rstan/ec/catalan.pdf             ;;
;;                                                                       ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


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


;; Later I will code this caching with a more efficient method,
;; but right now a simple association list, where the new stuff
;; is added to the END suffices to us.
;;
;; Here the car keeps the pointer to the beginning of the assoc list,
;; and cdr to the last pair of it, which is updated when
;; new stuff is added with store-to-memo! to the end:

(define (new-memo)
  (let ((empty-a-list (list (cons (list) (list)))))
    (cons empty-a-list empty-a-list)
  )
)

(define (fetch-from-memo memo s)
   (cond ((assoc s (car memo)) => cdr)
         (else #f)
   )
)

(define (store-to-memo! memo s val)
  (let ((new-node  (list (cons s val))))
   (set-cdr! (cdr memo) new-node) ;; Add the new node to the end.
   (set-cdr! memo (cddr memo))    ;; and update the pointer to that end.
   val
  )
)


;; The types of recursion we use:

;; 0: (foo! s), (recurse (cdr s))
;;   Inverse is obtained by substituting foo!'s inverse into case 3.
;;   Form (foo! s), (recurse (car s)) is obtainable as the car/cdr-flipped
;;   conjugate of this case applied to foo!'s car/cdr-flipped conjugate.
;;
;; 1: (foo! s), (recurse (car s)), (recurse (cdr s))
;;   Recursing both branches. Inverse is obtained by substituting foo!'s
;;   inverse into case 2.
;;
;; 2: (recurse (cdr s)), (recurse (car s)), (foo! s)
;;   See case 1.
;;
;; 3: (recurse (cdr s)), (foo! s)
;;   See case 0.
;;
;; Now we leave out this case:
;; 4: (recurse (car s)), (foo! s), (recurse (cdr s))
;;   Recursing car-branch first, and then applying foo! before
;;   recursing the cdr-branch.
;;   Form (recurse (cdr s)), (foo! s), (recurse (car s))
;;   is obtainable as the car/cdr-flipped conjugate of this case
;;   applied to foo!'s car/cdr-flipped conjugate.
;;
;;   Inverse is obtained by applying that case to foo!'s inverse,
;;   i.e. as the car/cdr-flipped conjugate of the case
;;   (recurse (car s)), (foo! s), (recurse (cdr s))
;;   applied to the car/cdr-flipped conjugate of foo!'s inverse.
;;   (or the inverse of car/cdr-flipped conjugate of foo!, which
;;    is the same thing).


(define (compose-recursive-sima-fun foo type)
  (letrec
    ((memo (new-memo))
     (recurse
       (lambda (s)
         (cond ((eq? #t s) memo) ; For debugging, reveal our memo.
               ((or (null? s) (equal? '(()) s)) s)
               ((fetch-from-memo memo s))
               (else
                  (store-to-memo! memo s
                     (case type
                        ((0) ;; (foo! s) (recurse (cdr s))
                            (let ((t (foo s)))
                              (cons (car t) (recurse (cdr t)))
                            )
                        )
                        ((1) ;; (foo! s) (recurse (car s)) (recurse (cdr s))
                            (let ((t (foo s)))
                              (cons (recurse (car t)) (recurse (cdr t)))
                            )
                        )
                        ((2) ;; (recurse (cdr s)) (recurse (car s)) (foo! s)
                             (foo (cons (recurse (car s)) (recurse (cdr s))))
                        )
                        ((3) ;; (recurse (cdr s)) (foo! s)
                             (foo (cons (car s) (recurse (cdr s))))
                        )
                     )
                  )
               ) ;; else
         ) ;; cond
       ) ;; lambda
     ) ;; (recurse ..)
    ) ;; ((memo ...) ...)
    recurse ;; return our new recursive composition.
  ) ;; letrec
)


(define (compose-two-sima-funs foo bar)
  (letrec
    ((memo (new-memo))
     (composition
       (lambda (s)
         (cond ((eq? #t s) memo) ; For debugging, reveal our memo.
               ((or (null? s) (equal? '(()) s)) s)
               ((fetch-from-memo memo s))
               (else (store-to-memo! memo s (foo (bar s))))
         ) ;; cond
       ) ;; lambda
     ) ;; (composition ..)
    ) ;; ((memo ...) ...)
    composition ;; return our new composition.
  ) ;; letrec
)

;; The percentage of junk grows steadily as the n grows.
;; Most of the compositions (odd n's) are mostly trash.

;;   0: SwapBinTree
;;   1: exch2first-cdr
;;   2: A069767 (SwapDownCar, type-0 recursive composition of SwapBinTree)
;;   3: SwapBinTree o exch2first-cdr
;;   4: A057163 (ReflectBinTree, type-1 recursive composition of SwapBinTree)
;;   5: exch2first-cdr o SwapBinTree
;;   6: A057163 (ReflectBinTree, DUPLICATE, type-2 recursive composition of SwapBinTree)
;;   7: A001477 (id, composition of the involution exch2first-cdr with itself)
;;   8: A069768 (SwapDownCdr, type-3 recursive composition of SwapBinTree)
;;   9: SwapBinTree o SwapDownCar
;;  10: A057509 (Rol, type-0 recursive composition of exch2first-cdr)
;;  11: DUPLICATE of exch2first-cdr (composition of 0 and 3)
;;  12: A057511 (DeepRol, type-1 recursive composition of exch2first-cdr)
;;  13: exch2first-cdr o SwapDownCar
;;  14: A057512 (DeepRor, type-2 recursive composition of exch2first-cdr)
;;  15: exch2first-cdr o SwapBinTree o exch2first-cdr (forms 1 and 3)
;;  16: A057510 (Ror, type-3 recursive composition of exch2first-cdr)
;;  17: SwapDownCar o SwapBinTree (not duplicate of simaform 9 ?)
;;  18: type-0 recursive composition of SwapDownCar, not in OEIS yet.
;;  19: SwapDownCar o exch2first-cdr
;;  20: A069768 SwapDownCdr DUPLICATE?, type-1 recursive composition of SwapDownCar
;;  21: ReflectBinTree o SwapBinTree (i.e. reflect everywhere except at the root)
;;  22: A069768 SwapDownCdr, 2nd DUPLICATE?, type-2 recursive composition of SwapDownCar
;;  23: ReflectBinTree o exch2first-cdr
;;  24: type-3 recursive composition of SwapDownCar, not in OEIS yet.
;;  25: SwapDownCar^2
;;  26: type-0 recursive composition of simaform 3 (SwapBinTree o exch2first-cdr)
;;  27: SwapDownCar o (SwapBinTree o exch2first-cdr)
;;  28: type-1 recursive composition of simaform 3 (SwapBinTree o exch2first-cdr)
;;  29: ReflectBinTree o SwapDownCar
;;  30: type-2 recursive composition of simaform 3 (SwapBinTree o exch2first-cdr)
;;  31: ReflectBinTree o (SwapBinTree o exch2first-cdr)
;;  32: type-3 recursive composition of simaform 3 (SwapBinTree o exch2first-cdr)

;;  77: Duplicate of id, composition of simaforms 8 and 2 (SwapDownCdr o SwapDownCar)

;;  81: A057501 RotateHandshakes, composition of simaforms 10 and 0 (Rol o SwapBinTree)
;;  82. is recursively (type 0) composed from the simaform 10 (Rol), not in OEIS.
;;  84. is recursively (type 1) composed from the simaform 10 (Rol), not in OEIS.
;;  86. A057164 DeepRev, recursively (type 2) composed from the simaform 10 (Rol)
;;  88. A057508 Reverse, recursively (type 3) composed from the simaform 10 (Rol)

;; 130: A057508 DUPLICATE, type 0 recursive composition of the form 16 (Ror)
;; 132: A057164 DUPLICATE, type 1 recursive composition of the form 16 (Ror)
;; 134: type 2 recursive composition of the form 16 (Ror) (not duplicate of 84?)
;; 136: type 3 recursive composition of the form 16 (Ror) (not duplicate of 82?)

;; 137: Not in OEIS,  composition of simaforms 0 and 10 (SwapBinTree o Rol)
;; 261: Not in OEIS,  composition of simaforms 16 and 0 (Ror o SwapBinTree)
;; 513: A057502 RotateHandshakesInv, composition of forms 0 and 16 (SwapBinTree o Ror)

;; 4449. A057505, is a composition of the forms 86. (DeepRev) and 4. (ReflectBinTree)
;; 4453. is a composition of the simaforms 88. (Reverse) and 4. (ReflectBinTree)

;; 8761. is a composition of the simaforms 2. (SwapDownCar) and 86. (DeepRev)
;; 8765. A057506, is a composition of the forms 4. (ReflectBinTree) and 86. (DeepRev)

;; 8901: A057162 RotateTriangularizationInv, is a composition of the forms 8. and 88.
;;                                       (SwapDownCdr o Reverse)
;; 13161: Duplicate of ID, a square of the form 86. (DeepRev)
;; 13165: reverse all levels except the top-level,
;;            a composition of the simaforms 88. (Reverse) and 86. (DeepRev)
;; 13205: is an ordinary composition of the simaforms 84. and 88.




(define *SIMA-VEC* (vector SwapBinTree exch2first-cdr))

(define (add-to-sima-vec! n what)
   (if (>= n (vector-length *SIMA-VEC*))
       (set! *SIMA-VEC* (vector-grow *SIMA-VEC* (1+ n)))
   )
   (vector-set-and-return-value! *SIMA-VEC* n what)
)

(define (left-side-ref n)
  (let ((v (A059905 (fix:lsh n -2))))
     (cond ((< v 3) v) ;; 0->0, 1->1, 2->2, 3->4, 4->6, 5->8, 6->10, 7->12, etc.
           (else (* 2 (-1+ v)))
     )
  )
)

(define right-side-ref A059906) ;; The odd-positioned bits (bit-1, 3, 5, etc.)

(load-option 'format) ;; To use format, do this.

(define (obtain-sima-function! n)
  (cond ((and (< n (vector-length *SIMA-VEC*)) (vector-ref *SIMA-VEC* n)))
        ((zero? (modulo n 2))
;; Even n's reserved for recursively composed simaforms.
           (let* ((foo-index (fix:lsh (- n 2) -3))
                  (type (fix:lsh (fix:and (- n 2) 7) -1))
                 )
              (format #t
    "The simaform ~A. is recursively (type ~A) composed from the simaform ~A.~%"
                    n type foo-index
              )
              (add-to-sima-vec!
                    n
                    (compose-recursive-sima-fun
                       (obtain-sima-function! foo-index)
                       type
                    )
              )
           )
        )
        (else
;; Odd n's reserved for ordinarily composed simaforms.
;; At the left side we use only the primitives SwapBinTree (0), exch2first-cdr (1)
;; or any recursively composed simaform in even position (2,4,6,8,10,...)
;; At the right side we can use any simaform we like.
           (let ((foo-index (left-side-ref n))
                 (bar-index (right-side-ref n))
                )
              (format #t
    "The simaform ~A. is an ordinary composition of the simaforms ~A. and ~A.~%"
                    n foo-index bar-index
              )
              (add-to-sima-vec!
                      n
                      (compose-two-sima-funs
                         (obtain-sima-function! foo-index)
                         (obtain-sima-function! bar-index)
                      )
              )
           ) ;; let
        ) ;; else
  )
)



(define (load-precomputed-vec filename size max-elem)
   (format #t "Loading a vector of size ~A from the file ~A ..." size filename)
   (let ((vec (make-vector size))
        )
     (call-with-input-file filename
        (lambda (inport)
           (let loop ((nextnum (read inport)) (n 0) (inserted 0))
              (cond ((or (eq? n size) (eof-object? nextnum))
                       (format #t " inserted ~A items~%" inserted)
                       (flush-output (current-output-port))
                       vec
                    )
                    (else
                          (if (or (negative? max-elem) (<= nextnum max-elem))
                              (vector-set! vec n nextnum)
                          )
                          (loop (read inport)
                                (1+ n)
                                (if (or (negative? max-elem) (<= nextnum max-elem))
                                    (1+ inserted)
                                    inserted
                                )
                          )
                    )
              )
           )
        )
     )
   )
)

(define (gatosima upto-n)
   (let* ((vec-size (A014137 upto-n)) ;; I.e. 290512 for upto-n = 12.
          (constab-size (/ (* 2080 2081) 2))
          (VecA014486 (load-precomputed-vec "c:\\matikka\\Nekomorphisms\\vA014486.lst" vec-size -1))
          (VecA069770 (load-precomputed-vec "c:\\matikka\\Nekomorphisms\\vA069770.lst" vec-size -1))
          (VecA072771 (load-precomputed-vec "c:\\matikka\\Nekomorphisms\\vA072771.lst" vec-size -1))
          (VecA072772 (load-precomputed-vec "c:\\matikka\\Nekomorphisms\\vA072772.lst" vec-size -1))
          (VecA072796 (load-precomputed-vec "c:\\matikka\\Nekomorphisms\\vA072796.lst" vec-size -1))
          (VecA072764 (load-precomputed-vec "c:\\matikka\\Nekomorphisms\\vA072764.lst" constab-size (-1+ vec-size)))
         )
      VecA072764
   )
)

  
(define (fix_binwidth n) ;; A029837 (with a(0)=0 instead of 1)
  (let loop ((n n) (i 0)) ;;  or A036377 (with offset=0 instead of 1)
     (if (fix:zero? n)
         i
         (loop (fix:lsh n -1) (1+ i))
     )
  )
)

(define (fix_ConsTBBS a b) ;; "cons" two totally balanced binary sequences
   (let ((aw (fix_binwidth a))
         (bw (fix_binwidth b))
        )
     (+ (fix:lsh 1 (+ 1 aw bw)) (fix:lsh a (1+ bw)) b)
   )
)


(define (precompute_A072764 filename upto_diagonal)
   (with-output-to-file filename
     (lambda ()
        (let outloop ((n 0))
           (cond ((<= n upto_diagonal)
                    (let inloop ((x n) (y 0))
                       (write (CatalanRankGlobal (consTBBS (A014486 x) (A014486 y))))
                       (newline)
                       (if (zero? x)
                           (outloop (1+ n))
                           (inloop (-1+ x) (1+ y))
                       )
                    )
                 )
           )
        )
     )
   )
)


;; pref11 is 0 if tbs begins as 10.., 1 if it begins as 11...
;; Start searching from [lowlim,uplim[ range with a simple binary
;; search.

(define (QuickRank tbs VecA014486)
   (if (zero? tbs)
       0
       (let* ((bw (fix_binwidth tbs))
              (size_1 (-1+ (fix:lsh bw -1)))
              (pref11 (fix:and (fix:lsh tbs (- 2 bw)) 1))
              (lowlim (+ (A014137 size_1) (* pref11 (A000108 size_1))))
              (uplim  (+ (A014137 (+ size_1 pref11))
                         (* (fix:and (1+ pref11) 1) (A000108 size_1))
                      )
              )
             )
         (cons lowlim uplim)
       )
   )
)