;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                       ;;
;;                          gatomain.scm                                 ;;
;;                                                                       ;;
;;  Antti Karttunen's collection of rotation-automorphisms and other     ;;
;;             mappings of Catalan-enumerated objects                    ;;
;;                         ('Gatomorphisms')                             ;;
;; ('Catamorphism' is already reserved by Constructive Algorithmics)     ;;
;;                                                                       ;;
;;  This code runs 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             ;;
;;                                                                       ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; Porting from Maple to Scheme started by Antti Karttunen
;; (E-mail: my_firstname.my_surname@iki.fi)
;; in March 2002. These functions are in public domain.

;; Last edited 23. April 2002

;; Works in MIT Scheme, release 7.6.0.

;; To be done: output of the objects with their rotations
;; Use either MIT Scheme native Win32 graphics routines and/or
;; FPS (functional PostScript) library at
;; ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/fps.html
;; (and maybe write an article about the whole project)

(load "c:\\matikka\\Schemuli\\definecd.scm")
(load "c:\\matikka\\Schemuli\\intfuns1.scm")
(load "c:\\matikka\\Schemuli\\lstfuns1.scm")

(load "c:\\matikka\\Nekomorphisms\\gatomorf.scm")
(load "c:\\matikka\\Nekomorphisms\\gatochek.scm")
(load "c:\\matikka\\Nekomorphisms\\gatoleff.scm")
(load "c:\\matikka\\Nekomorphisms\\gatorank.scm")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                    ;;
;;           xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx                 ;;
;;                                                                    ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (catfun0 morphism) ;; only for self-embeddable automorphisms, like df->bf
     (letrec ((cache (make-vector 21))
              (fun (lambda (y)
                 (cond ((null? y) cache) ; For debugging, reveal our cache for nothing.
                       (else
                           (if (fix:>= y (vector-length cache))
                               (set! cache (vector-grow cache
                                             (max (1+ y)
                                                  (* 2 (vector-length cache))
                                             )
                                           )
                               )
                           )
                           (or (vector-ref cache y)
                               (vector-set-and-return-value! cache y
                                     (CatalanRankLocal
                                       (parenthesization->binexp
                                         (morphism
                                           (binexp->parenthesization
                                             (CatalanUnrank (safe_w/2 y) y)
                                           )
                                         )
                                       )
                                     )
                               )
                           )
                       )
                 )
                )
              )
             )
         fun
     )
)


(define (catfun1 morphism)
     (letrec ((cache (make-vector 21))
              (fun (lambda (y)
                 (cond ((null? y) cache) ; For debugging, reveal our cache for nothing.
                       (else
                           (if (fix:>= y (vector-length cache))
                               (set! cache (vector-grow cache
                                             (max (1+ y)
                                                  (* 2 (vector-length cache))
                                             )
                                           )
                               )
                           )
                           (or (vector-ref cache y)
                               (vector-set-and-return-value! cache y
                                     (CatalanRankGlobal
                                       (parenthesization->binexp
                                         (morphism
                                           (binexp->parenthesization
                                             (A014486 y)))))
                               )
                           )
                       )
                 )
                )
              )
             )
         fun
     )
)


(define (apply_upto_n upto_n morphism) ;; For testing.
   (map CatalanRankGlobal
       (map parenthesization->binexp
            (map morphism
                 (map binexp->parenthesization
                      (map A014486 (iota0 upto_n))))))
)


(define (binseqs_of_size size)
    (map (lambda (r) (CatalanUnrank size r))
         (cons 0 (iota (-1+ (A000108 size))))
    )
)

(define (partition_by_gatomorphism size gatomorphism)
   (let ((src_set (map binexp->parenthesization (binseqs_of_size size)))
        )
     (let loop ((cur (car src_set)) (src src_set) (res (list (list))))
        (cond ((null? src) (reverse! (map reverse! res)))
              ((member cur src)
                 (loop (gatomorphism cur)
                       (delete! cur src)
                       (cons (cons cur (car res)) (cdr res))
                 )
              )
              (else
;; Completed one whole cycle, let's begin the next one with the first
;; parenthesization we have left:
                 (loop (car src) src (cons (list) res))
              )
        ) ; cond
     ) ; let loop
   )
)

;; Return a Cycle-Count function for a particular gatomorphism.
;; (This one is quite ineffective).

(define (cc-fun gatomorphism)
  (lambda (n)
    (length (partition_by_gatomorphism n gatomorphism))
  )
)


;; Don't use destructive version here!
;; (output-gatomorphism-partitions "A057161.sxp" "RotateTriangularization" RotateTriangularization 5)
;; (output-gatomorphism-partitions "A057501.sxp" "RotateHandshakes" RotateHandshakes 5)

;; To be read in with gato-fps.scm's function:
;; (output-sexp-file-as-ps-file "a057161.sxp" "a057161.ps" 8)
;;

(define (output-gatomorphism-partitions filename gatoname gatomorphism upto_n)
   (call-with-output-file filename
     (lambda (outport)
        (write (list gatoname upto_n) outport)
        (newline outport)
        (let loop ((i 0))
           (cond ((<= i upto_n)
                    (write (partition_by_gatomorphism i gatomorphism) outport)
                    (newline outport)
                    (flush-output outport)
                    (loop (1+ i))
                 )
           )
        )
     )
   )
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                          ;;
;; Define the corresponding induced integer sequences (which most are       ;;
;; permutations of the natural non-negative integers) from the              ;;
;; gatomorphisms given in the file:                                         ;;
;;                                                                          ;;
;;  http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.scm       ;;
;;                                                                          ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define A070041   (compose-funlist (list 1+ (catfun0 df->bf)))) ;; inverse of A038776.

(define A057118   (catfun1 df->bf))
(define A057161   (catfun1 RotateTriangularization))
(define A057161!  (catfun1 RotateTriangularization!))
(define A057161v1 (catfun1 RotateHandshakesD1))
(define A057162   (catfun1 RotateTriangularizationInv))
(define A057162!  (catfun1 RotateTriangularizationInv!))
(define A057163   (catfun1 ReflectBinTree))
(define A057163!  (catfun1 ReflectBinTree!))
(define A057164   (catfun1 DeepRev))
(define A057164!  (catfun1 DeepRev1!))
(define A057501   (catfun1 RotateHandshakes))
(define A057501!  (catfun1 RotateHandshakes!))
(define A057502   (catfun1 (lambda (p) (RotateHandshakesInv! (copy-tree p)))))
(define A057502!  (catfun1 RotateHandshakesInv!))
(define A057503   (catfun1 RotateHandshakesD2))
(define A057505   (catfun1 DeepRotateTriangularization))
(define A057505v1 (catfun1 RotateHandshakesD3))
(define A057506   (catfun1 DeepRotateTriangularizationInv))
(define A057508   (catfun1 reverse))
(define A057508!  (catfun1 Rev1!))
(define A057508!! (catfun1 Rev2!))
(define A057509   (catfun1 Rol))
(define A057509!  (catfun1 Rol!))
(define A057510!  (catfun1 Ror!))
(define A057510   (catfun1 (lambda (p) (Ror! (copy-tree p)))))
(define A057511   (catfun1 DeepRol))

;; injections, not bijections
(define A057123 (catfun1 BinTree2Tree))
(define A057548 (catfun1 list))
(define A057518 (catfun1 AllTrees2DoubleTrunked))
;; --> (0 2 5 6 12 13 15 16 19 31 32 34 35 36 40 41 43 44 47 52 53 56 60 87 88 90 91 92 96 97 99 100 101 103 104 105 106 115 116 118 119 120 124 125 127 128 131 136 137 140 144 152 153 155 156 159 164 165 168 172 178 179 182 186 191 261 262 264 265 266 270 271 273 274 275 277 278 279 280 289 290 292 293 294 298 299 301 302 303 305 306 307 308 312 313 315 316 317 319 320 321 322 324 325 326 327 328 351 352 354 355 356 360 361 363 364 365 367 368 369 370)
;; (map A014486 (map Argh (cons 0 (iota 30)))) gives A057517: (Change to offset=0)
; --> (0 10 44 50 180 184 204 210 226 724 728 740 744 752 820 824 844 850 866 908 914 930 962 2900 2904 2916 2920 2928 2964 2968 2980)

;; New ones:



(define A069767! (catfun1 SwapDownCar!)) ;; Inverses of each ...
(define A069768! (catfun1 SwapDownCdr!)) ;;   ... other
(define A069767  (catfun1 (lambda (p) (SwapDownCar! (copy-tree p)))))
(define A069768  (catfun1 (lambda (p) (SwapDownCdr! (copy-tree p)))))
(define A069769! (catfun1 Rev1CarSide!)) ;; Self-inverse
(define A069769  (catfun1 CarReverse)) ;; Selt-inverse
(define A069770  (catfun1 SwapBinTree))
(define A069770! (catfun1 SwapBinTree!)) ;; Self-inverse
(define A069771  (catfun1 RotateHandshakes180)) ;; Self-inverse
(define A069772  (catfun1 xReflectHandshakes)) ;; Self-inverse
(define A069773! (catfun1 RoblDownCar_et_Swap!))
(define A069774! (catfun1 RoblDownCar_et_SwapInv!))
(define A069775! (catfun1 RolCarSide!))
(define A069776! (catfun1 RorCarSide!))
(define A069787! (catfun1 DeepRev1CarSide!))

(define A069888! (catfun1 DeepReverse_et_RotateHandshakes!)) ;; Self-inverse, Wouter Meeussen's "mirroring through the corners", ncflipskew
(define A069889! (catfun1 RotateHandshakes_et_DeepReverse!)) ;; Self-inverse

;; And non-destructive variants:
(define A069773  (catfun1 (lambda (p) (RoblDownCar_et_Swap! (copy-tree p)))))
(define A069774  (catfun1 (lambda (p) (RoblDownCar_et_SwapInv! (copy-tree p)))))
(define A069775  (catfun1 (lambda (p) (RolCarSide! (copy-tree p)))))
(define A069776  (catfun1 (lambda (p) (RorCarSide! (copy-tree p)))))
(define A069787  (catfun1 (lambda (p) (DeepRev1CarSide! (copy-tree p)))))
(define A069888  (catfun1 (lambda (p) (DeepReverse_et_RotateHandshakes! (copy-tree p)))))
(define A069889  (catfun1 (lambda (p) (RotateHandshakes_et_DeepReverse! (copy-tree p)))))


(define check-these
 (list
       (list 57161 A057161! A057162 (list A057163 A057162 A057163) (list A069767 A069769))
       (list 57162 A057162! A057161 (list A057163 A057161 A057163) (list A069768 A057508))
       (list 57163 A057163! A057163)
       (list 57164 A057164! A057164 (list A057163 A069787 A057163))
       (list 57501 A057501! A057502 (list A057163 A069773 A057163))
       (list 57502 A057502  A057501 (list A057163 A069774 A057163))
       (list 57508 A057508! A057508 (list A057163 A069769 A057163))
       (list 57509 A057509! A057510 (list A057163 A069775 A057163) (list A057501 A069770))
       (list 57510 A057510! A057509 (list A057163 A069776 A057163) (list A069770 A057502))
       (list 69767 A069767! A069768 (list A057163 A069768 A057163))
       (list 69768 A069768! A069767 (list A057163 A069767 A057163))
       (list 69769 A069769! A069769 (list A057163 A057508 A057163))
       (list 69770 A069770  A069770 (list A057163 A069770 A057163))
       (list 69771 A069771  A069771)
       (list 69772 A069772  A069772 (list A057164 A069771) (list A069771 A057164))
       (list 69773 A069773! A069774 (list A057163 A057501 A057163))
       (list 69774 A069774! A069773 (list A057163 A057502 A057163))
       (list 69775 A069775! A069776 (list A057163 A057509 A057163) (list A069773 A069770))
       (list 69776 A069776! A069775 (list A057163 A057510 A057163) (list A069770 A069774))
       (list 69787 A069787! A069787 (list A057163 A057164 A057163))
       (list 69888 A069888! A069888 (list A057501 A057164))
       (list 69889 A069889! A069889 (list A057164 A057501))
       (list 57118 A057118 A057118) ;; Not the correct inverse, but
       (list 70041 A070041 A070041) ;;  .. just something.... This one is 1-based.
 )
)