# This is a shell archive. Save it in a file, remove anything before
# this line, and then unpack it by entering "sh file". Note, it may
# create directories; files and directories will be owned by you and
# have default permissions.
#
# This archive contains:
#
# gato-fps.scm
# gatochek.scm
# gatocout.scm
# gatoleff.scm
# gatomain.scm
# gatomorf.scm
# gatorank.scm
# gatouse1.scm
#
echo x - gato-fps.scm
sed 's/^X//' >gato-fps.scm << 'END-of-gato-fps.scm'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; gato-fps.scm ;;
X;; ;;
X;; Gatomorphism output functions for FPS package. ;;
X;; ;;
X;; This Scheme-code is Copyright (C) 2002 by Antti Karttunen ;;
X;; (E-mail: my_firstname.my_surname@iki.fi) and is placed under ;;
X;; the GPL (Gnu Public License), so you are free to copy it. ;;
X;; ;;
X;; Note: this module runs only in scsh (Scheme Shell) and uses ;;
X;; the FPS (functional PostScript) library by Wandy Sae-Tan and ;;
X;; Olin Shivers, located at http://www.scsh.net/resources/fps.html or ;;
X;; ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/fps.html ;;
X;; ;;
X;; The latest scsh (Scheme Shell) can be found at http://www.scsh.net/ ;;
X;; ;;
X;; The main pointer for this code collection is: ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm ;;
X;; ;;
X;; Start as: ;;
X;; % scsh ;;
X;; Welcome to scsh 0.6.1 (Combinatorial Algorithms) ;;
X;; Type ,? for help. ;;
X;; > ,config ,load fps-package.scm ;;
X;; fps-package.scm ;;
X;; > ,open fps ;;
X;; Load structure fps (y/n)? y ;;
X;; > ,load gato-fps.scm ;;
X;; gato-fps.scm ;;
X;; ../Schemuli/lstfuns1.scm ;;
X;; gatocout.scm ;;
X;; > ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X(load "../Schemuli/lstfuns1.scm") ;; Load useful functions, like attach! and nthcdr
X
X;; Load the conversion routines from parenthesizations (sexp's)
X;; to appropriate manifestations of the Catalan's family.
X
X(load "gatocout.scm")
X
X(define (1+ n) (+ 1 n))
X(define (-1+ n) (- n 1))
X
X(define (monus1 n) (if (> n 0) (-1+ n) n))
X
X
X(define (find-max a)
X (cond ((not (pair? a))
X (if (number? a) a 0)
X )
X (else (max (find-max (car a)) (find-max (cdr a))))
X )
X)
X
X(define (pin-headed-line pt1 pt2)
X (compose (line pt1 pt2)
X (arc pt1 1 0 2pi)
X (arc pt2 1 0 2pi)
X )
X)
X
X;; Test:
X;; (define pentagon (draw-polygon-triangularization '((() ())) 24 100 300))
X;; (define handshakes (draw-chord-arrangement '((() ())) 24 200 300))
X;; (define both (compose pentagon handshakes))
X;; (out both "esim1.ps")
X;; Or:
X;; (define hexadecigon (draw-polygon-triangularization '((() ((()) ()) ((() ()))) (() (()))) 48 100 300))
X;; (define handshakes2 (draw-chord-arrangement '((() ((()) ()) ((() ()))) (() (()))) 48 200 300))
X;; (define both2 (compose hexadecigon handshakes2))
X;; (out both2 "esim2.ps")
X;;
X
X
X
X(define (draw-binary-tree sexp ox oy x_displ y_displ)
X (with-attrib ((:line-width 0.6) (:line-cap 'round))
X (translate ox oy
X;; (with-attrib ((:color (rgb 1 .1 .1)))
X (compose
X (draw-bincordtree
X (fill-cordtree-x-coordinates! (construct-coordinate-tree sexp) x_displ)
X 0 0 y_displ
X )
X )
X;; )
X )
X )
X)
X
X
X(define (draw-n-ary-tree sexp ox oy x_displ y_displ)
X (with-attrib ((:line-width 0.6) (:line-cap 'round))
X (translate ox oy
X;; (with-attrib ((:color (rgb 1 .1 .1)))
X (compose
X (draw-cordtree
X (normalize-root-to-zero-and-scale! (p->tree-x-coordinates sexp) x_displ)
X 0 0 y_displ
X )
X )
X;; )
X )
X )
X)
X
X
X(define (draw-one-level-of-bincordtree level ox oy ny)
X (let loop ((level level))
X (cond ((pair? level)
X (compose
X (pin-headed-line
X (pt (+ ox (caar level)) ny)
X (pt (+ ox (cdar level)) oy)
X )
X (loop (cdr level))
X )
X )
X (else the-empty-path)
X )
X )
X)
X
X(define (draw-bincordtree cot ox oy y_displ)
X (stroke
X (let loop ((ct (cdr cot)) (y oy))
X (cond ((pair? ct)
X (compose
X (draw-one-level-of-bincordtree (car ct) ox y (+ y y_displ))
X (loop (cdr ct) (+ y y_displ))
X )
X )
X (else the-empty-path)
X )
X )
X )
X)
X
X;; (normalize-root-to-zero-and-scale! (p->tree-x-coordinates '(()((())()))) 12)
X;; --> (0 (-9) (9 (3 (3)) (15)))
X
X(define (draw-cordtree ct ox oy y_displ)
X (stroke
X (let recurse ((ct ct) (y oy) (prev_y oy) (prev_x (car ct)))
X (cond ((pair? ct)
X (compose
X (cond ((number? (car ct)) ;; At the beginning of branch-list?
X (compose
X (pin-headed-line
X (pt (+ ox prev_x) prev_y)
X (pt (+ ox (car ct)) y)
X )
X (recurse (cdr ct) (+ y y_displ) y (car ct)) ;; Start scanning sub-branches.
X )
X )
X (else ;; Still scanning the sub-branches.
X (compose
X (recurse (car ct) y prev_y prev_x) ;; Draw this branch.
X (recurse (cdr ct) y prev_y prev_x) ;; Continue sub-branches.
X )
X )
X ) ;; cond
X ) ;; compose
X )
X (else the-empty-path)
X )
X )
X )
X)
X
X
X(define (draw-dyck-path sexp ox oy scale)
X (with-attrib ((:line-width 0.6) (:line-cap 'round))
X (let ((x_now (list ox)))
X (stroke
X (let recurse ((s sexp) (level 0))
X (cond ((not (null? s))
X (compose
X (pin-headed-line ;; Upward slope /
X (pt (car x_now) (+ oy (* scale level)))
X (pt (+ (car x_now) scale) (+ oy (* scale (+ 1 level))))
X )
X (begin (set-car! x_now (+ (car x_now) scale))
X (recurse (car s) (+ level 1)) ;; Recurse between.
X )
X (pin-headed-line ;; Downward slope \
X (pt (car x_now) (+ oy (* scale (+ 1 level))))
X (pt (+ (car x_now) scale) (+ oy (* scale level)))
X )
X (begin (set-car! x_now (+ (car x_now) scale))
X (recurse (cdr s) level) ;; Recurse the rest.
X )
X ) ;; compose
X )
X (else the-empty-path)
X )
X )
X ) ;; stroke
X ) ;; let
X ) ;; with-attrib
X)
X
X(define (draw-polygon-triangularization sexp ox oy radius)
X (draw-chords-with-or-without-circle (bt->pt sexp) radius ox oy #f)
X)
X
X
X(define (draw-chord-arrangement sexp ox oy radius)
X (draw-chords-with-or-without-circle (sexp->hs sexp) radius ox oy #t)
X)
X
X
X
X(define (draw-chords-with-or-without-circle chords radius ox oy circle?)
X (with-attrib ((:line-width 0.5))
X (translate ox (+ oy radius) ;; According to the bottom, not the center.
X;; (with-attrib ((:color (rgb 1 .1 .1)))
X (compose
X (if circle?
X (stroke (with-attrib ((:color (rgb 1 0.1 0.1)))
X (arc origin radius 0 2pi)
X )
X )
X the-empty-pict
X )
X (draw-chords chords radius circle?)
X )
X;; )
X )
X )
X)
X
X
X;;
X;; The point 1 is a half-angle clockwise from the angle 3/2 pi
X;; The point 2 is one angle and half clockwise from the angle 3/2 pi
X;; The point n is a half-angle counter-clockwise from the angle 3/2 pi.
X;;
X;;
X;;
X
X;; angle = (3/2 pi + pi/n) - (v * (2pi/n))
X
X(define (compute-vert-angle v n)
X (let ((a (- (+ (/ (* 3 pi) 2) (/ pi n)) ;; Subtract from the angle of n
X (* v (/ 2pi n)) ;; ... the v * angle used.
X )
X ))
X (if (< a 0) (+ a 2pi) a) ;; Ensure that it is positive angle.
X )
X)
X
X
X(define (get-edge-point v n radius)
X (let ((angle (compute-vert-angle v n)))
X (pt (* radius (cos angle)) (* radius (sin angle)))
X )
X)
X
X;; g1 and g2 are angles from the origo to the vertices v1 and v2
X;; respectively.
X;; angle = the mean of the angles g1 and g2, the angle from origo
X;; to antiorigo.
X;; h = height of equilateral triangle whose base is the line segment v1-v2,
X;; and 2h is distance between the origo and the antiorigo
X
X;; The angle between the first and the last vertices is straight down.
X
X(define (draw-anti-arc v1 v2 n radius)
X (let* ((g1 (compute-vert-angle
X ((if (eq? (abs (- v1 v2)) (- n 1)) min max) v1 v2) n))
X (g2 (compute-vert-angle
X ((if (eq? (abs (- v1 v2)) (- n 1)) max min) v1 v2) n))
X (h (* radius (cos (/ pi n))))
X;; (angle (/ (+ g1 g2) 2)) ;; Doesn't work that way...
X (angle (compute-vert-angle
X (if (eq? (abs (- v1 v2)) (- n 1)) ;; First & the last vert?
X (/ 1 2) ;; Then straight down.
X (/ (+ v1 v2) 2) ;; Otherwise their average.
X )
X n
X )
X )
X (antiorigo (pt (* 2 h (cos angle)) (* 2 h (sin angle))))
X )
X (arc antiorigo radius (+ pi g1) (+ pi g2))
X )
X)
X
X
X(define (draw-chords chords radius curved?)
X (stroke
X (let ((n (find-max chords)))
X (let loop ((chords chords))
X (cond ((and (pair? chords) (pair? (car chords)))
X (compose
X (cond
X ((and curved?
X (> n 2)
X (memq (abs (- (caar chords) (cdar chords)))
X (list 1 (- n 1)) ;; Neighbours?
X )
X )
X (draw-anti-arc (caar chords) (cdar chords) n radius)
X )
X (else ;; A straight line.
X (line (get-edge-point (caar chords) n radius)
X (get-edge-point (cdar chords) n radius)
X )
X )
X ) ;; cond
X (loop (cdr chords))
X ) ;; compose
X )
X (else the-empty-path)
X )
X )
X )
X )
X)
X
X
X;;; A simple test driver that outputs to test.ps.
X
X(define (out pict filename) (show-w/ps2-text-channel filename pict))
X
X
X(define (read-lists-from infile)
X (call-with-input-file infile
X (lambda (inport)
X (let loop ((sexp (read inport)) (res (list)))
X (cond ((eof-object? sexp) (reverse! res))
X (else (loop (read inport) (cons sexp res)))
X )
X )
X )
X )
X)
X
X
X;; (define pentagon (draw-polygon-triangularization '((() ())) 100 300 24))
X;; (define handshakes (draw-chord-arrangement '((() ())) 200 300 24))
X;; (define both (compose pentagon handshakes))
X;; (out both "esim1.ps")
X
X;; The following functions contain some very ugly constants, until I
X;; invent something better...
X
X(define (compose-one-cycle sexps radius x_start x_displ y_now)
X (let loop ((sexps sexps) (x x_start))
X (cond ((not (null? sexps))
X (compose
X (draw-n-ary-tree (car sexps) x (car y_now) (/ radius 2) (/ radius 2))
X (draw-binary-tree (car sexps) x (- (car y_now) (* 3 radius)) (/ radius 2) (/ radius 2))
X (draw-polygon-triangularization (car sexps) x (- (car y_now) (* 6 radius)) radius)
X (draw-chord-arrangement (car sexps) x (- (car y_now) (* 9 radius)) radius)
X (loop (cdr sexps) (+ x x_displ))
X )
X )
X (else the-empty-pict)
X )
X )
X)
X
X(define (compose-one-partition partition radius x_start x_displ y_displ y_now)
X (let loop ((part partition))
X (cond ((not (null? part))
X (compose (compose-one-cycle (car part) radius x_start x_displ y_now)
X (begin (set-car! y_now (- (car y_now) y_displ))
X (loop (cdr part))
X )
X )
X )
X (else the-empty-pict)
X )
X )
X)
X
X
X(define (compose-pictures-of-partition lists radius x_start x_displ y_start y_displ)
X;; Skip first comment list.
X (let ((y_now (list y_start)))
X (let loop ((lists (cdr lists)))
X (cond ((not (null? lists))
X (compose (compose-one-partition (car lists) radius x_start x_displ y_displ y_now)
X (loop (cdr lists))
X )
X )
X (else the-empty-pict)
X )
X )
X )
X)
X
X
X
X(define (compose-one-instance-per-line! sexps outchannel radius x_start y_now y_displ)
X (let loop () ;; (sexps (cdr sexps)))
X (cond ((and (pair? sexps) (pair? (cdr sexps)) ;; Still something to print?
X (> (car y_now) (+ (* 2 radius) y_displ)) ;; Still fits in this page?
X )
X (compose
X (draw-dyck-path (cadr sexps) x_start (car y_now) (/ radius 2))
X (draw-n-ary-tree (cadr sexps) (+ x_start (* 8 radius)) (car y_now) (/ radius 2) (/ radius 2))
X (draw-binary-tree (cadr sexps) (+ x_start (* 16 radius)) (car y_now) (/ radius 2) (/ radius 2))
X (draw-polygon-triangularization
X (cadr sexps) (+ x_start (* 24 radius)) (car y_now) radius)
X (draw-chord-arrangement
X (cadr sexps) (+ x_start (* 32 radius)) (car y_now) radius)
X (begin
X (set-car! y_now (- (car y_now) y_displ))
X (delete! (cadr sexps) sexps)
X (loop)
X )
X )
X )
X (else the-empty-pict)
X )
X )
X)
X
X;; Use as:
X;; (output-part-file-as-ps-file "a057161.sxp" "a057161.ps" 8)
X;; (output-part-file-as-ps-file "a057501.sxp" "a057501.ps" 8)
X
X
X(define (output-part-file-as-ps-file infile outfile radius)
X (let* ((lists (read-lists-from infile))
X (page (compose-pictures-of-partition lists radius (* 4 radius) (* 7 radius) 800 (* 12 radius)))
X )
X (out page outfile)
X )
X)
X
X;; Use as:
X;; (output-sexp-file-as-ps-file "a014486.sxp" "a014486.ps" 12)
X(define (output-sexp-file-as-ps-file infile outfile radius)
X (let* ((lists (read-lists-from infile)) ;; Keep the header all the time. Because this is modified with delete!
X (y_now (list 750))
X (outchannel (ps2-text-channel outfile))
X )
X (let loop ((pageno 1))
X (cond ((not (null? (cdr lists)))
X (format #t "Doing page ~S, (length lists)=~S, (car lists)=~S, (cadr lists)=~S~%"
X pageno (length lists) (car lists) (cadr lists))
X (force-output (current-output-port))
X (show outchannel (compose-one-instance-per-line! lists outchannel radius (* 4 radius) y_now (* 6 radius)))
X (set-car! y_now 750)
X (loop (+ 1 pageno))
X )
X )
X )
X (close-channel outchannel)
X )
X)
X
END-of-gato-fps.scm
echo x - gatochek.scm
sed 's/^X//' >gatochek.scm << 'END-of-gatochek.scm'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatochek.scm ;;
X;; - Functions for checking gatomorphism-induced permutations ;;
X;; against Neil Sloane's OEIS ;;
X;; http://www.research.att.com/~njas/sequences/ ;;
X;; and also for cursorily checking that the various composition ;;
X;; identities hold. ;;
X;; ;;
X;; This Scheme-code is coded 2002 by Antti Karttunen, ;;
X;; (E-mail: my_firstname.my_surname@iki.fi) and is placed in ;;
X;; Public Domain. ;;
X;; ;;
X;; This should run at least in MIT Scheme Release 7.6.0, for ;;
X;; which one can find documentation and the pre-compiled binaries ;;
X;; (for various OS's running in Intel x86 architecture) under the URL: ;;
X;; ;;
X;; http://www.swiss.ai.mit.edu/projects/scheme/ ;;
X;; ;;
X;; The main pointer for this code collection is: ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X
X(define output_seq
X (lambda (seq)
X (cond ((null? seq)) ;; No (newline) this time!
X (else (write (car seq))
X (if (not (null? (cdr seq))) (write-string ","))
X (output_seq (cdr seq))
X )
X )
X )
X)
X
X;; Quite ugly, disposal code:
X(define (output-seq-link x upto_n)
X (let* ((Anum (car x))
X (fun (cadr x))
X (fun_et_inv_comp (compose-funlist (list fun (caddr x))))
X (compositions (cdddr x))
X (res-seq (map fun (cons 0 (iota upto_n))))
X )
X (write-string "
A00")
X (write Anum)
X (write-string " := [")
X (output_seq res-seq)
X (write-string "];\n");
X (let ((test-seq (cons 0 (iota upto_n)))
X (nth-comp 1)
X )
X (cond ((not (null? (first-dislocated (map fun_et_inv_comp test-seq))))
X (write-string "The inverse is not correct!\n")
X )
X )
X (for-each (lambda (complist)
X (let ((comp (compose-funlist complist)))
X (cond ((not (equal? (map comp test-seq) res-seq))
X (write-string "The ") (write nth-comp)
X (write-string ". composition is not correct!")
X )
X )
X )
X (set! nth-comp (1+ nth-comp))
X )
X compositions
X ) ; for-each
X ) ; let
X ) ; let*
X)
X
X;; Call-as
X;; (output-check-html "C:\\karttu\\nekomorphisms\\test6918.htm" check-these 6918)
X
X(define (output-check-html filename seqfuns upto_n)
X (with-output-to-file filename
X (lambda ()
X (write-string
X "Check-up of sequences:")
X (for-each (lambda (x) (write-string " A0") (write (car x))) seqfuns)
X (write-string "\n")
X (for-each (lambda (x) (output-seq-link x upto_n)) seqfuns)
X (write-string "")
X )
X )
X)
X
END-of-gatochek.scm
echo x - gatocout.scm
sed 's/^X//' >gatocout.scm << 'END-of-gatocout.scm'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; gatocout.scm ;;
X;; ;;
X;; Gatomorphism conversion functions (for output). ;;
X;; Written by Antti Karttunen (firstname.surname@iki.fi) April, 2002 ;;
X;; ;;
X;; The functions convert s-expressions (which can be viewed either as ;;
X;; parenthesizations or (planar & rooted) car/cdr-binary trees) ;;
X;; to structures better suited for the output of the certain ;;
X;; manifestations of Stanley's exercise 19. ;;
X;; This module is independent of the actual graphics library/output ;;
X;; device used. ;;
X;; ;;
X;; This file is located under: ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;; From the interpretation d (plane binary trees with 2n+1 vertices (i.e. n+1 endpoints))
X;; to the interpretation a (triangularizations of a convex (n + 2)-gon
X;; into n triangles by n-1 diagonals that do not intersect in their interiors).
X;;
X;; (binexp->parenthesization (A014486 1)) --> (())
X;; (bt->pt '(())) --> ((1 . 2) (2 . 3) (1 . 3))
X;; (binexp->parenthesization (A014486 2)) --> (() ())
X;; (bt->pt '(() ())) --> ((1 . 2) (2 . 3) (3 . 4) (2 . 4) (1 . 4))
X;; (binexp->parenthesization (A014486 3)) --> ((()))
X;; (bt->pt '((()))) --> ((1 . 2) (2 . 3) (1 . 3) (3 . 4) (1 . 4))
X;; (binexp->parenthesization (A014486 4)) --> (() () ())
X;; (bt->pt '(() () ())) --> ((1 . 2) (2 . 3) (3 . 4) (4 . 5) (3 . 5) (2 . 5) (1 . 5))
X
X;; Note that the recursion order is important
X;; (car-branch before the cdr-branch) because
X;; of the side-effects of c we are playing with.
X;; The largest n upto which we have drawn the edge segments
X;; can always be found from the cdr-part of the first
X;; pair in c, i.e. with (cdar c)
X;;
X;; The corners of the polygon are numbered clockwise
X;; from 1 to n (where n = the number of leaves (here: ()'s)
X;; in the binary tree + 1 for the root fork), so that
X;; the corner 1 is at the left end and the corner n is
X;; at the right end of the bottom ('root') edge
X;; of the polygon.
X
X(define (bt->pt bt)
X (let ((c (list (cons 0 1))))
X (let recurse ((bt bt) (sel +)) ;; + is playing the role of id. Not used.
X (cond ((not (pair? bt)) ;; A leaf -> The next onto edge.
X (attach! (cons (cdar c) (1+ (cdar c))) c)
X )
X (else ;; It's a fork, so we need a diameter.
X (let ((left-min (recurse (car bt) min)))
X (attach! (cons left-min (recurse (cdr bt) max)) c)
X )
X )
X )
X (sel (caar c) (cdar c))
X )
X (cdr (reverse! c))
X )
X)
X
X;; From the interpretation n (non-crossing handshakes, i.e. nonintersecting
X;; chords joining 2n points on the circumference of a circle) to the
X;; interpretation kk (fixed-point free and non-crossing involutions of [2n]):
X
X;; (sexp->hs '()) -> ()
X;; (sexp->hs '(())) -> ((1 . 2))
X;; (sexp->hs '(() ())) -> ((1 . 2) (3 . 4))
X;; (sexp->hs '((()))) -> ((1 . 4) (2 . 3))
X;; (sexp->hs '(() () ())) -> ((1 . 2) (3 . 4) (5 . 6))
X;; (sexp->hs '(() (()))) -> ((1 . 2) (3 . 6) (4 . 5))
X;; (sexp->hs '((()) ())) -> ((1 . 4) (2 . 3) (5 . 6))
X;; (sexp->hs '((() ()))) -> ((1 . 6) (2 . 3) (4 . 5))
X;; (sexp->hs '(((())))) -> ((1 . 6) (2 . 5) (3 . 4))
X
X;; Could be cleaner, probably:
X
X(define (sexp->hs p)
X (let ((c (list (cons 0 0)))
X (maxnode (list 0))
X )
X (let recurse ((p p))
X (cond ((pair? p)
X (let ((this-trans (cons (1+ (car maxnode)) 0)))
X (set-car! maxnode (1+ (car maxnode)))
X (attach! this-trans c)
X (recurse (car p))
X (set-car! maxnode (1+ (car maxnode)))
X (set-cdr! this-trans (car maxnode))
X (recurse (cdr p))
X )
X )
X )
X ) ; let recurse
X (cdr (reverse! c))
X ) ; let
X)
X
X
X;; For the "optimized" output of the binary trees we first construct
X;; a breadth-first-wise "spread-tree" (cf. spreadsheet) of the
X;; car/cdr-tree to be output (with the function construct-coordinate-tree),
X;; and then "instantiate" its nodes with clash-free X-coordinates
X;; using the function fill-cordtree-x-coordinates!
X
X;;
X;; Construct a list structure like:
X;; (construct-coordinate-tree '(a . (b . c)))
X;; --> (((0 . 0)) (((0 . 0)) ((0 . 0))) ((((0 . 0))) (((0 . 0)))))
X;;
X;; (construct-coordinate-tree '((a . b) . c))
X;; --> (((0 . 0)) (((0 . 0)) ((0 . 0))) ((((0 . 0)) ((0 . 0))) (((0 . 0)) ((0 . 0)))))
X;;
X
X(define (construct-coordinate-tree bt)
X (let ((cs (list (list (cons 0 0))))) ;; The root at x-position 0.
X ((lambda (recfun)
X (cond ((pair? bt)
X (recfun (cdr bt) 1)
X (recfun (car bt) 1)
X ))
X cs
X )
X (letrec ((recurse (lambda (bt depth)
X (let ((this-level (nthcdr depth cs))
X (prev-level (list-ref cs (- depth 1)))
X )
X
X (if (pair? this-level) ;; Not the first of this level.
X (set-car! this-level (cons prev-level (car this-level)))
X (append! cs (list (list prev-level)))
X )
X (cond ((pair? bt)
X (recurse (cdr bt) (1+ depth))
X (recurse (car bt) (1+ depth))
X )
X ) ; cond
X ) ; let
X )))
X recurse
X ) ; letrec
X ) ; lambda
X ) ; let
X)
X
X
X(define (repl-parent-pointers-with-coord-pairs! lista x-displ)
X (cond ((pair? lista)
X (set-car! lista (cons (+ (caaar lista) x-displ) (caaar lista)))
X (repl-parent-pointers-with-coord-pairs! (cdr lista) (- x-displ))
X )
X )
X)
X
X(define (add-displ-to-each-child-x! lista x-displ)
X (cond ((pair? lista)
X (set-car! (car lista) (+ (caar lista) x-displ))
X (add-displ-to-each-child-x! (cdr lista) (- x-displ))
X )
X )
X)
X
X(define (clash-free? level)
X (or (null? level)
X (null? (cdr level))
X (apply < (map car level))
X )
X)
X
X
X;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '()) 1)
X;; --> (((0 . 0)))
X;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '(a . b)) 1)
X;; --> (((0 . 0)) ((-1 . 0) (1 . 0)))
X;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '(a . (b . c))) 1)
X;; --> (((0 . 0)) ((-1 . 0) (1 . 0)) ((0 . 1) (2 . 1)))
X;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '((a . b) . c)) 1)
X;; --> (((0 . 0)) ((-1 . 0) (1 . 0)) ((-2 . -1) (0 . -1)))
X;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '((a . b) . (c . d))) 1)
X;; --> (((0 . 0)) ((-1 . 0) (1 . 0)) ((-3/2 . -1) (-1/2 . -1) (1/2 . 1) (3/2 . 1)))
X;; (fill-cordtree-x-coordinates! (construct-coordinate-tree '((a . (b . c)) . ((d . e) . f))) 1)
X;; --> (((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)))
X;;
X
X
X;; Call as (fill-cordtree-x-coordinates! (construct-coordinate-tree bt) x-displ)
X(define (fill-cordtree-x-coordinates! ct x-displ)
X (cond ((pair? ct)
X (cond ((not (number? (caaar ct))) ;; Still pointers to parents at this level.
X (repl-parent-pointers-with-coord-pairs! (car ct) (- x-displ))
X (fill-cordtree-x-coordinates! ct x-displ) ;; And check again.
X )
X ((clash-free? (car ct)) ;; If this level is clash-free, then continue
X (fill-cordtree-x-coordinates! (cdr ct) x-displ)
X )
X (else ;; We have to contract the branches at this level.
X (add-displ-to-each-child-x! (car ct) (/ x-displ 2))
X (fill-cordtree-x-coordinates! ct (/ x-displ 2)) ;; And try again.
X )
X )
X )
X )
X ct
X)
X
X
X
X;; (p->tree-x-coordinates '()) --> (1)
X;; (p->tree-x-coordinates '(())) --> (1 (1))
X;; (p->tree-x-coordinates '((()))) --> (1 (1 (1)))
X;; (p->tree-x-coordinates '(()())) --> (3/2 (1) (2))
X;; (p->tree-x-coordinates '(()()())) --> (2 (1) (2) (3))
X;; (p->tree-x-coordinates '((())())) --> (3/2 (1 (1)) (2))
X;; (p->tree-x-coordinates '(()(()))) --> (3/2 (1) (2 (2)))
X;; (p->tree-x-coordinates '((()()))) --> (3/2 (3/2 (1) (2)))
X;; (p->tree-x-coordinates '(((())))) --> (1 (1 (1 (1))))
X
X
X(define (incr x) (set-car! x (+ (car x) 1)) (car x))
X
X
X(define (average-x-of branches)
X (/ (apply + (map car branches)) (length branches))
X)
X
X(define (p->tree-x-coordinates p)
X (let ((max_x (list 0)))
X (let recurse ((p p))
X (cond ((not (pair? p)) (list (incr max_x)))
X (else
X (let ((branches (map recurse p)))
X (cons (average-x-of branches) branches)
X )
X )
X )
X )
X )
X)
X
X
X
X;; (normalize-root-to-zero-and-scale! (p->tree-x-coordinates '(()((())()))) 12)
X;; --> (0 (-9) (9 (3 (3)) (15)))
X
X(define (normalize-root-to-zero-and-scale! tx x-scale)
X (let ((off (car tx)))
X (let recurse ((tx tx))
X (cond ((pair? tx)
X (if (number? (car tx))
X (set-car! tx (* (- (car tx) off) x-scale))
X (recurse (car tx))
X )
X (recurse (cdr tx))
X )
X )
X )
X tx
X )
X)
X
X
X
X
END-of-gatocout.scm
echo x - gatoleff.scm
sed 's/^X//' >gatoleff.scm << 'END-of-gatoleff.scm'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatoleff.scm ;;
X;; - Functions for implementing "LEPREFF"'s, ;;
X;; i.e. "Leaves Preserving Forth-Forms" ;;
X;; ;;
X;; This Scheme-code is Copyright (C) 2002 by Antti Karttunen ;;
X;; (E-mail: my_firstname.my_surname@iki.fi) and is placed under ;;
X;; the GPL (Gnu Public License), so you are free to copy it. ;;
X;; ;;
X;; Runs at least in MIT Scheme Release 7.6.0, for which one can find ;;
X;; documentation and the pre-compiled binaries (for various OS's ;;
X;; running in Intel x86 architecture) under the URL: ;;
X;; ;;
X;; http://www.swiss.ai.mit.edu/projects/scheme/ ;;
X;; ;;
X;; The main pointer for this code collection is: ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X;; Some inspiration from: http://www.its.caltech.edu/~boozer/symbols/pr.html
X;;
X;; and from the papers of Henry G. Baker:
X;; "Linear Logic and Permutation Stacks -- The Forth Shall Be First"
X;; at http://linux.rice.edu/~rahul/hbaker/ForthStack.html
X;; "NREVERSAL of Fortune"
X;; at http://linux.rice.edu/~rahul/hbaker/ReverseGC.html
X;; and "Lively Linear Lisp"
X;; at http://linux.rice.edu/~rahul/hbaker/LinearLisp.html
X
X;; At the left (car) side map even integers to all integers,
X;; and odd integers to sublists,
X;; and at the right (cdr) side map all integers to sublists,
X;; with 0 mapped to the terminating ().
X
X;; How to generate a subset that begins and ends always
X;; with two parentheses? (i.e. with a sublist)?
X;; (or is always a list of one sublist. Easy.)
X
X(define (unrank-intsexp rank pr1 pr2)
X (let recurse ((rank rank) (side 'oikea))
X (cond ((eq? side 'oikea) ;; At the right side.
X (cond ((zero? rank) (list)) ;; 0 marks the terminating nil.
X (else (cons (recurse (pr1 (-1+ rank)) 'vasen)
X (recurse (pr2 (-1+ rank)) 'oikea)
X )
X )
X )
X )
X (else ;; At the left side
X (cond ((zero? (modulo rank 2)) (/ rank 2)) ;; 2n -> n
X (else (cons (recurse (pr1 (/ (-1+ rank) 2)) 'vasen)
X (recurse (pr2 (/ (-1+ rank) 2)) 'oikea)
X )
X )
X )
X )
X )
X )
X)
X
X
X(define (rank-intsexp is packfun)
X (let recurse ((is is) (side 'oikea))
X (cond ((integer? is) (* is 2)) ;; n -> 2n (integers only on the car-side)
X ((null? is) 0) ;; nils should occur only on the cdr-side.
X (else (1+ (* (if (eq? side 'vasen) 2 1)
X (packfun (recurse (car is) 'vasen)
X (recurse (cdr is) 'oikea)
X )
X )
X )
X )
X )
X )
X)
X
X(define (unrank-intsexp-tr rank) (unrank-intsexp rank A025581 A002262))
X(define (rank-intsexp-tr sexp) (rank-intsexp sexp packA001477))
X
X;; lepreff stands for "Leaves Preserving Forth-Form"
X
X(define (map-int-to-prim-at-level n depth)
X (cond ((eq? 1 depth) (list 'L n)) ;; Only calls to other lepreff's allowed.
X ((eq? 2 depth) ;; Also SWAPs & recursion calls allowed.
X (cond ((zero? n) 'SWAP)
X ((eq? 1 n) 'RECURSE)
X (else (list 'L (- n 2)))
X )
X )
X (else ;; Stack depth 3 or more. Also ROTation of the whole stack allowed.
X (cond ((zero? n) 'SWAP)
X ((eq? 1 n) 'ROTN)
X ((eq? 2 n) 'RECURSE)
X (else (list 'L (- n 3)))
X )
X )
X )
X)
X
X
X;; Increment all integers that occur either as in
X;;
X;; a) any non-initial or non-terminal position of
X;; a top-level or any level list.
X;; (i x x x x x t)
X;;
X;; b) the initial position of the sublist which
X;; itself is not an initial element of its
X;; parent list, and is preceded by another sublist
X;; (not an integer).
X;; (( ... ) (X ...))
X;;
X;; c) the terminal position of the sublist which
X;; itself is not an terminal element of its
X;; parent list, and is followed by another sublist
X;; (not an integer).
X;; (( ... X) (...))
X
X;; I.e., do not increment an integer if it occurs
X;; as the initial element of a top-level list,
X;; or of a sublist which is in the initial position
X;; of its parent-list, or is preceded by an integer,
X;; or if it occurs
X;; as the terminal element of a top-level list,
X;; or of a sublist which is in the terminal position
X;; of its parent-list, or is followed by an integer.
X;; or both (is the only element of a sublist which
X;; is neither followed nor preceded by another sublist)
X
X(define (intsexp-increment-selectively! is) (intsexp-change-selectively! is 1+))
X
X
X(define (intsexp-change-selectively! is how)
X (let recurse ((is is) (pre '()) (depth 0))
X (cond
X ((pair? is)
X (cond ((pair? (car is)) ;; We have a sublist.
X (cond ((and (integer? (caar is)) ;; Whose first elem is integer.
X (pair? pre) ;; Sublist preceded by another sublist
X )
X (set-car! (car is) (how (caar is))) ;; Incr first
X )
X )
X (cond ((and (or (not (pair? pre)) ;; Make sure that didn't match above
X (pair? (cdar is)) ;; or the length of sublist > 1
X ) ;; (to avoid double-change)
X (integer? (car (last-pair (car is)))) ;; last elem = integer
X (pair? (cdr is)) ;; And sublist is followed by ...
X (pair? (cadr is)) ;; ... another sublist?
X )
X (set-car! (last-pair (car is))
X (how (car (last-pair (car is))))
X )
X )
X )
X (recurse (car is) '() (1+ depth))
X )
X (else ;; We have an integer at this position.
X ;; Change if we are in the middle of the sublist:
X (cond ((and (> depth 0) (not (null? pre)) (not (null? (cdr is))))
X (set-car! is (how (car is)))
X )
X )
X )
X )
X (recurse (cdr is) (car is) depth) ;; Handle the rest.
X )
X ) ;; cond
X ) ;; let
X is
X)
X
X
X
X
X(define (intsexp->lepreff-clause is)
X (let recurse ((is is) (depth 1))
X (cond ((null? is) is)
X ((list? (car is))
X (append! (list ') ;; SNOC
X (recurse (car is) (1+ depth))
X (list ') ;; CONS
X (recurse (cdr is) depth)
X )
X )
X (else ;; An integer.
X (cons (map-int-to-prim-at-level (car is) depth)
X (recurse (cdr is) depth)
X )
X )
X ) ;; cond
X ) ;; let
X)
X
X
X(define (cons-snocs->swaps fl)
X (let loop ((fl fl) (res (list)))
X (cond ((null? fl) (reverse! res))
X ((and (pair? (cdr fl))
X (eq? ' (car fl)) ;; level -1
X (eq? ' (cadr fl)) ;; level +1
X )
X (loop (cddr fl) (cons 'SWAP res))
X )
X (else (loop (cdr fl) (cons (car fl) res)))
X )
X )
X)
X
X(define (lepreff0 n) (intsexp->lepreff-clause (unrank-intsexp-tr n)))
X(define (lepreff1 n)
X (cons-snocs->swaps
X (intsexp->lepreff-clause
X (intsexp-increment-selectively!
X (unrank-intsexp-tr n)
X )
X )
X )
X)
X
X
X
END-of-gatoleff.scm
echo x - gatomain.scm
sed 's/^X//' >gatomain.scm << 'END-of-gatomain.scm'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; gatomain.scm ;;
X;; ;;
X;; Antti Karttunen's collection of rotation-automorphisms and other ;;
X;; mappings of Catalan-enumerated objects ;;
X;; ('Gatomorphisms') ;;
X;; ('Catamorphism' is already reserved by Constructive Algorithmics) ;;
X;; ;;
X;; This code runs at least in MIT Scheme Release 7.6.0, for ;;
X;; which one can find documentation and the pre-compiled binaries ;;
X;; (for various OS's running in Intel x86 architecture) under the URL: ;;
X;; ;;
X;; http://www.swiss.ai.mit.edu/projects/scheme/ ;;
X;; ;;
X;; The main pointer for this code collection is: ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm ;;
X;; ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; Gatomorphism (noun) = any bijection from a set of parenthesizations ;;
X;; of size n to the same set (of size n), which is well-defined for ;;
X;; all the sizes n (for sizes n=0 and 1 we have an identity mapping). ;;
X;; In place of parenthesizations we can assume any other manifestation ;;
X;; of the exercise 19 by Stanley. ;;
X;; ;;
X;; See R. P. Stanley, Exercises on Catalan and Related Numbers, ;;
X;; located at: http://www-math.mit.edu/~rstan/ec/catalan.pdf ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X;; Porting from Maple to Scheme started by Antti Karttunen
X;; (E-mail: my_firstname.my_surname@iki.fi)
X;; in March 2002. These functions are in public domain.
X
X;; Last edited 23. April 2002
X
X;; Works in MIT Scheme, release 7.6.0.
X
X;; To be done: output of the objects with their rotations
X;; Use either MIT Scheme native Win32 graphics routines and/or
X;; FPS (functional PostScript) library at
X;; ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/fps.html
X;; (and maybe write an article about the whole project)
X
X(load "c:\\matikka\\Schemuli\\definecd.scm")
X(load "c:\\matikka\\Schemuli\\intfuns1.scm")
X(load "c:\\matikka\\Schemuli\\lstfuns1.scm")
X
X(load "c:\\matikka\\Nekomorphisms\\gatomorf.scm")
X(load "c:\\matikka\\Nekomorphisms\\gatochek.scm")
X(load "c:\\matikka\\Nekomorphisms\\gatoleff.scm")
X(load "c:\\matikka\\Nekomorphisms\\gatorank.scm")
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(define (catfun0 morphism) ;; only for self-embeddable automorphisms, like df->bf
X (letrec ((cache (make-vector 21))
X (fun (lambda (y)
X (cond ((null? y) cache) ; For debugging, reveal our cache for nothing.
X (else
X (if (fix:>= y (vector-length cache))
X (set! cache (vector-grow cache
X (max (1+ y)
X (* 2 (vector-length cache))
X )
X )
X )
X )
X (or (vector-ref cache y)
X (vector-set-and-return-value! cache y
X (CatalanRankLocal
X (parenthesization->binexp
X (morphism
X (binexp->parenthesization
X (CatalanUnrank (safe_w/2 y) y)
X )
X )
X )
X )
X )
X )
X )
X )
X )
X )
X )
X fun
X )
X)
X
X
X(define (catfun1 morphism)
X (letrec ((cache (make-vector 21))
X (fun (lambda (y)
X (cond ((null? y) cache) ; For debugging, reveal our cache for nothing.
X (else
X (if (fix:>= y (vector-length cache))
X (set! cache (vector-grow cache
X (max (1+ y)
X (* 2 (vector-length cache))
X )
X )
X )
X )
X (or (vector-ref cache y)
X (vector-set-and-return-value! cache y
X (CatalanRankGlobal
X (parenthesization->binexp
X (morphism
X (binexp->parenthesization
X (A014486 y)))))
X )
X )
X )
X )
X )
X )
X )
X fun
X )
X)
X
X
X(define (apply_upto_n upto_n morphism) ;; For testing.
X (map CatalanRankGlobal
X (map parenthesization->binexp
X (map morphism
X (map binexp->parenthesization
X (map A014486 (iota0 upto_n))))))
X)
X
X
X(define (binseqs_of_size size)
X (map (lambda (r) (CatalanUnrank size r))
X (cons 0 (iota (-1+ (A000108 size))))
X )
X)
X
X(define (partition_by_gatomorphism size gatomorphism)
X (let ((src_set (map binexp->parenthesization (binseqs_of_size size)))
X )
X (let loop ((cur (car src_set)) (src src_set) (res (list (list))))
X (cond ((null? src) (reverse! (map reverse! res)))
X ((member cur src)
X (loop (gatomorphism cur)
X (delete! cur src)
X (cons (cons cur (car res)) (cdr res))
X )
X )
X (else
X;; Completed one whole cycle, let's begin the next one with the first
X;; parenthesization we have left:
X (loop (car src) src (cons (list) res))
X )
X ) ; cond
X ) ; let loop
X )
X)
X
X;; Return a Cycle-Count function for a particular gatomorphism.
X;; (This one is quite ineffective).
X
X(define (cc-fun gatomorphism)
X (lambda (n)
X (length (partition_by_gatomorphism n gatomorphism))
X )
X)
X
X
X;; Don't use destructive version here!
X;; (output-gatomorphism-partitions "A057161.sxp" "RotateTriangularization" RotateTriangularization 5)
X;; (output-gatomorphism-partitions "A057501.sxp" "RotateHandshakes" RotateHandshakes 5)
X
X;; To be read in with gato-fps.scm's function:
X;; (output-part-file-as-ps-file "a057161.sxp" "a057161.ps" 8)
X;;
X
X(define (output-gatomorphism-partitions filename gatoname gatomorphism upto_n)
X (call-with-output-file filename
X (lambda (outport)
X (write (list gatoname upto_n) outport)
X (newline outport)
X (let loop ((i 0))
X (cond ((<= i upto_n)
X (write (partition_by_gatomorphism i gatomorphism) outport)
X (newline outport)
X (flush-output outport)
X (loop (1+ i))
X )
X )
X )
X )
X )
X)
X
X;; Use as:
X;;
X;; (output-sexp-sequence
X;; (map binexp->parenthesization (map A014486 (iota0 (-1+ (A014137 7)))))
X;; "C:\\matikka\\Nekomorphisms\\a014486.sxp" "A014486 upto the size 7")
X
X;; To be read in with gato-fps.scm's function:
X;; (output-sexp-file-as-ps-file "a014486.sxp" "a014486.ps" 12)
X;;
X
X(define (output-sexp-sequence sexps filename comment-line)
X (call-with-output-file filename
X (lambda (outport)
X (write (list comment-line) outport)
X (newline outport)
X (let loop ((sexps sexps))
X (cond ((pair? sexps)
X (write (car sexps) outport)
X (newline outport)
X (flush-output outport)
X (loop (cdr sexps))
X )
X )
X )
X )
X )
X)
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; Define the corresponding induced integer sequences (which most are ;;
X;; permutations of the natural non-negative integers) from the ;;
X;; gatomorphisms given in the file: ;;
X;; ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.scm ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X(define A070041 (compose-funlist (list 1+ (catfun0 df->bf)))) ;; inverse of A038776.
X
X(define A057118 (catfun1 df->bf))
X(define A057161 (catfun1 RotateTriangularization))
X(define A057161! (catfun1 RotateTriangularization!))
X(define A057161v1 (catfun1 RotateHandshakesD1))
X(define A057162 (catfun1 RotateTriangularizationInv))
X(define A057162! (catfun1 RotateTriangularizationInv!))
X(define A057163 (catfun1 ReflectBinTree))
X(define A057163! (catfun1 ReflectBinTree!))
X(define A057164 (catfun1 DeepRev))
X(define A057164! (catfun1 DeepRev1!))
X(define A057501 (catfun1 RotateHandshakes))
X(define A057501! (catfun1 RotateHandshakes!))
X(define A057502 (catfun1 (lambda (p) (RotateHandshakesInv! (copy-tree p)))))
X(define A057502! (catfun1 RotateHandshakesInv!))
X(define A057503 (catfun1 RotateHandshakesD2))
X(define A057505 (catfun1 DeepRotateTriangularization))
X(define A057505v1 (catfun1 RotateHandshakesD3))
X(define A057506 (catfun1 DeepRotateTriangularizationInv))
X(define A057508 (catfun1 reverse))
X(define A057508! (catfun1 Rev1!))
X(define A057508!! (catfun1 Rev2!))
X(define A057509 (catfun1 Rol))
X(define A057509! (catfun1 Rol!))
X(define A057510! (catfun1 Ror!))
X(define A057510 (catfun1 (lambda (p) (Ror! (copy-tree p)))))
X(define A057511 (catfun1 DeepRol))
X
X;; injections, not bijections
X(define A057123 (catfun1 BinTree2Tree))
X(define A057548 (catfun1 list))
X(define A057518 (catfun1 AllTrees2DoubleTrunked))
X;; --> (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)
X;; (map A014486 (map Argh (cons 0 (iota 30)))) gives A057517: (Change to offset=0)
X; --> (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)
X
X;; New ones:
X
X
X
X(define A069767! (catfun1 SwapDownCar!)) ;; Inverses of each ...
X(define A069768! (catfun1 SwapDownCdr!)) ;; ... other
X(define A069767 (catfun1 (lambda (p) (SwapDownCar! (copy-tree p)))))
X(define A069768 (catfun1 (lambda (p) (SwapDownCdr! (copy-tree p)))))
X(define A069769! (catfun1 Rev1CarSide!)) ;; Self-inverse
X(define A069769 (catfun1 CarReverse)) ;; Selt-inverse
X(define A069770 (catfun1 SwapBinTree))
X(define A069770! (catfun1 SwapBinTree!)) ;; Self-inverse
X(define A069771 (catfun1 RotateHandshakes180)) ;; Self-inverse
X(define A069772 (catfun1 xReflectHandshakes)) ;; Self-inverse
X(define A069773! (catfun1 RoblDownCar_et_Swap!))
X(define A069774! (catfun1 RoblDownCar_et_SwapInv!))
X(define A069775! (catfun1 RolCarSide!))
X(define A069776! (catfun1 RorCarSide!))
X(define A069787! (catfun1 DeepRev1CarSide!))
X
X(define A069888! (catfun1 DeepReverse_et_RotateHandshakes!)) ;; Self-inverse, Wouter Meeussen's "mirroring through the corners", ncflipskew
X(define A069889! (catfun1 RotateHandshakes_et_DeepReverse!)) ;; Self-inverse
X
X;; And non-destructive variants:
X(define A069773 (catfun1 (lambda (p) (RoblDownCar_et_Swap! (copy-tree p)))))
X(define A069774 (catfun1 (lambda (p) (RoblDownCar_et_SwapInv! (copy-tree p)))))
X(define A069775 (catfun1 (lambda (p) (RolCarSide! (copy-tree p)))))
X(define A069776 (catfun1 (lambda (p) (RorCarSide! (copy-tree p)))))
X(define A069787 (catfun1 (lambda (p) (DeepRev1CarSide! (copy-tree p)))))
X(define A069888 (catfun1 (lambda (p) (DeepReverse_et_RotateHandshakes! (copy-tree p)))))
X(define A069889 (catfun1 (lambda (p) (RotateHandshakes_et_DeepReverse! (copy-tree p)))))
X
X
X(define check-these
X (list
X (list 57161 A057161! A057162 (list A057163 A057162 A057163) (list A069767 A069769))
X (list 57162 A057162! A057161 (list A057163 A057161 A057163) (list A069768 A057508))
X (list 57163 A057163! A057163)
X (list 57164 A057164! A057164 (list A057163 A069787 A057163))
X (list 57501 A057501! A057502 (list A057163 A069773 A057163))
X (list 57502 A057502 A057501 (list A057163 A069774 A057163))
X (list 57508 A057508! A057508 (list A057163 A069769 A057163))
X (list 57509 A057509! A057510 (list A057163 A069775 A057163) (list A057501 A069770))
X (list 57510 A057510! A057509 (list A057163 A069776 A057163) (list A069770 A057502))
X (list 69767 A069767! A069768 (list A057163 A069768 A057163))
X (list 69768 A069768! A069767 (list A057163 A069767 A057163))
X (list 69769 A069769! A069769 (list A057163 A057508 A057163))
X (list 69770 A069770 A069770 (list A057163 A069770 A057163))
X (list 69771 A069771 A069771)
X (list 69772 A069772 A069772 (list A057164 A069771) (list A069771 A057164))
X (list 69773 A069773! A069774 (list A057163 A057501 A057163))
X (list 69774 A069774! A069773 (list A057163 A057502 A057163))
X (list 69775 A069775! A069776 (list A057163 A057509 A057163) (list A069773 A069770))
X (list 69776 A069776! A069775 (list A057163 A057510 A057163) (list A069770 A069774))
X (list 69787 A069787! A069787 (list A057163 A057164 A057163))
X (list 69888 A069888! A069888 (list A057501 A057164))
X (list 69889 A069889! A069889 (list A057164 A057501))
X (list 57118 A057118 A057118) ;; Not the correct inverse, but
X (list 70041 A070041 A070041) ;; .. just something.... This one is 1-based.
X )
X)
X
X
END-of-gatomain.scm
echo x - gatomorf.scm
sed 's/^X//' >gatomorf.scm << 'END-of-gatomorf.scm'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.scm ;;
X;; - "Hand-coded" "gatomorphism"-functions, ;;
X;; first the consing, non-destructive versions, ;;
X;; and then the destructive versions composed of the basic ;;
X;; "primitives" swap!, robl! and robr! ;;
X;; ;;
X;; This Scheme-code is coded 2002 by Antti Karttunen, ;;
X;; (E-mail: my_firstname.my_surname@iki.fi) and is placed in ;;
X;; Public Domain. ;;
X;; ;;
X;; All the examples run at least in MIT Scheme Release 7.6.0, for ;;
X;; which one can find documentation and the pre-compiled binaries ;;
X;; (for various OS's running in Intel x86 architecture) under the URL: ;;
X;; ;;
X;; http://www.swiss.ai.mit.edu/projects/scheme/ ;;
X;; ;;
X;; The main pointer for this code collection is: ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; Gatomorphism (noun) = any bijection from a set of parenthesizations ;;
X;; of size n to the same set (of size n), which is well-defined for ;;
X;; all the sizes n (for sizes n=0 and 1 we have an identity mapping). ;;
X;; In place of parenthesizations we can assume any other manifestation ;;
X;; of the exercise 19 by Stanley. ;;
X;; ;;
X;; See R. P. Stanley, Exercises on Catalan and Related Numbers, ;;
X;; located at: http://www-math.mit.edu/~rstan/ec/catalan.pdf ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;; Not yet in EIS.
X(define (SwapBinTree bt)
X (cond ((not (pair? bt)) bt)
X (else (cons (cdr bt) (car bt)))
X )
X)
X
X
X(define (ReflectBinTree bt) ;; -> A057163
X (cond ((not (pair? bt)) bt)
X (else (cons (ReflectBinTree (cdr bt))
X (ReflectBinTree (car bt)))
X )
X )
X)
X
X
X(define (AllTrees2DoubleTrunked bt)
X (cond ((not (pair? bt)) bt)
X (else (list (car bt) (cdr bt)))
X )
X)
X
X
X(define (BinTree2Tree bt) ;; Not a bijection. (A057123)
X (cond ((not (pair? bt)) bt)
X (else (list (BinTree2Tree (car bt))
X (BinTree2Tree (cdr bt)))
X )
X )
X)
X
X
X(define (RotateTriangularization bt) ;; -> A057161
X (let loop ((lt bt) (nt (list)))
X (cond ((not (pair? lt)) nt)
X (else (loop (car lt)
X (cons (cdr lt) nt)
X )
X )
X )
X )
X)
X
X
X
X(define (RotateTriangularizationInv bt) ;; -> A057162
X (let loop ((lt bt) (nt (list)))
X (cond ((not (pair? lt)) nt)
X (else (loop (cdr lt)
X (cons nt (car lt))
X )
X )
X )
X )
X)
X
X
X
X(define (DeepRotateTriangularization bt) ;; -> A057505
X (let loop ((lt bt) (nt (list)))
X (cond ((not (pair? lt)) nt)
X (else (loop (car lt)
X (cons (DeepRotateTriangularization (cdr lt)) nt)
X )
X )
X )
X )
X)
X
X
X
X(define (DeepRotateTriangularizationInv bt) ;; -> A057506
X (let loop ((lt bt) (nt (list)))
X (cond ((not (pair? lt)) nt)
X (else (loop (cdr lt)
X (cons nt (DeepRotateTriangularizationInv (car lt)))
X )
X )
X )
X )
X)
X
X
X; ((()((()())()))()())
X;
X; /\/\
X; / \/\
X; /\/ \
X; / \/\/\
X; / \
X;
X;->(define vv (list '((()((()())()))()())))
X; (((() ((() ()) ())) () ()))
X; ->(RotateHandshakes180 vv)
X; ((() ((() () ()) ())) () ())
X; ->(xReflectHandshakes vv)
X; (() () ((() (() () ())) ()))
X;
X; /\/\/\
X; /\/ \
X; / \/\
X; /\/\/ \
X;
X
X(define (RotateHandshakes a)
X (cond ((null? a) (list))
X (else (append (car a) (list (cdr a))))
X )
X)
X
X(define (RotateHandshakes_n_steps a n)
X (cond ((zero? n) a)
X (else (RotateHandshakes_n_steps (RotateHandshakes a) (-1+ n)))
X )
X)
X
X
X(define (RotateHandshakes180 a) (RotateHandshakes_n_steps a (count-pars a)))
X
X; Reflect handshakes over x-axis. (DeepRev reflects over y-axis)
X; This transformation keeps palindromic parenthesizations/mount ranges/
X; rooted planar trees palindromic, but not necessarily same.
X
X(define (xReflectHandshakes a) (DeepRev (RotateHandshakes180 a)))
X
X
X
X(define (RotateHandshakesD1 a) ;; -> A057161
X (cond ((null? a) (list))
X (else (append (RotateHandshakesD1 (car a)) (list (cdr a))))
X )
X)
X
X
X(define (RotateHandshakesD2 a)
X (cond ((null? a) (list))
X (else (append (car a) (list (RotateHandshakesD2 (cdr a)))))
X )
X)
X
X
X(define (RotateHandshakesD3 a)
X (cond ((null? a) (list))
X (else (append (RotateHandshakesD3 (car a)) (list (RotateHandshakesD3 (cdr a)))))
X )
X)
X
X
X(define (Rol s)
X (cond ((not (pair? s)) s) (else (append (cdr s) (list (car s)))))
X)
X
X(define (RolRecursive s)
X (cond ((not (pair? s)) s)
X ((null? (cdr s)) s)
X (else (cons (car (cdr s))
X (RolRecursive (cons (car s) (cdr (cdr s))))
X )
X )
X )
X)
X
X
X(define (DeepRol s)
X (cond ((not (pair? s)) s)
X ((null? (cdr s)) (list (DeepRol (car s))))
X (else (cons (DeepRol (car (cdr s)))
X (DeepRol (cons (car s) (cdr (cdr s))))
X )
X )
X )
X)
X
X
X(define (CarReverse bt) ;; --> ?
X (let loop ((lt bt) (nt (list)))
X (cond ((not (pair? lt)) nt)
X (else (loop (car lt)
X (cons nt (cdr lt))
X )
X )
X )
X )
X)
X
X(define (AnotherReverse bt) ;; --> A057508
X (let loop ((lt bt) (nt (list)))
X (cond ((not (pair? lt)) nt)
X (else (loop (cdr lt)
X (cons (car lt) nt)
X )
X )
X )
X )
X)
X
X
X
X(define (*reverse lista)
X (cond ((null? lista) (list))
X (else (append (*reverse (cdr lista))
X (cons (car lista) (list))))))
X
X
X(define (rewerse lista)
X (cond ((null? lista) lista)
X ((null? (cdr lista)) lista)
X (else (cons (car (rewerse (cdr lista)))
X (rewerse (cons (car lista)
X (rewerse (cdr (rewerse (cdr lista))))
X )
X )
X )
X )
X )
X)
X
X
X;; Compute the similar sequence as A033538 for this function:
X(define (deep*reverse lista)
X (cond ((not (pair? lista)) lista)
X ((null? (cdr lista)) (list (deep*reverse (car lista))))
X (else (cons (deep*reverse (car (deep*reverse (cdr lista))))
X (deep*reverse (cons (car lista)
X (deep*reverse
X (cdr (deep*reverse (cdr lista)))
X )
X )
X )
X )
X )
X )
X)
X
X
X(define (DeepRev lista)
X (cond ((not (pair? lista)) lista)
X ((null? (cdr lista)) (cons (DeepRev (car lista)) (list)))
X (else (append (DeepRev (cdr lista))
X (DeepRev (cons (car lista) (list))))
X )
X )
X)
X
X
X
X;; df->bf is the inverse of Wouter Meeussen's breadth-first to depth-first
X;; automorphism of plane binary trees. Cf. A038776, A057117, A057118
X
X;; (df->bf '(a (b (c) d) e)) --> (a ((b e) (c) . d))
X;; I.e. (df->bf '(a . ((b . ((c . ()) . (d . ()))) . (e . ()))))
X;; --> (a . (((b . (e . ())) . ((c . ()) . d))))
X
X;; Note: it's essential that pass-left is "frozen" (i.e. bound
X;; lexically as usual) before it's called from newcont closure
X;; (i.e. when this was not the leftmost branch (= first branch traversed)
X;; of the level depth,
X;; and likewise, it's essential that when we come to
X;; the first branch (= leftmost) of each level (and pass-left
X;; is set to false), we call the next "continuation" through
X;; conts-list, which MUST be physically modified, because we might
X;; not yet have traversed to the rightmost branch of the next
X;; shallower level of bt.
X
X(define (df->bf bt)
X (let ((conts (list car))) ;; The last thing we do is take car
X (let recurse ((bt bt) (depth 0))
X (let* ((plp (nthcdr depth conts))
X (pass-left (and (pair? plp) (car plp)))
X (newcont (lambda (stack)
X ((or pass-left (list-ref conts (-1+ depth)))
X (if (pair? bt) (cons2top! stack) (cons bt stack))
X )
X )
X )
X )
X
X (if pass-left
X (set-car! plp newcont)
X (append! conts (list newcont))
X )
X
X (cond ((pair? bt)
X (recurse (car bt) (1+ depth))
X (recurse (cdr bt) (1+ depth))
X )
X )
X ) ; let*
X ) ;; let recurse
X ((car (last-pair conts)) (list)) ;; Now, apply the last of closures to ()
X )
X)
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; Destructive versions of some of the above automorphisms, ;;
X;; implemented by using only physical primitives ;;
X;; swap!, robl! and robr! and simple recursions on car and/or cdr ;;
X;; branch of the tree-structure. ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;
X;; (define (AnotherReverse! s) ;; --> A057508
X;; (if (null? s)
X;; s
X;; (let loop ((c s) (ex-cdr (cdr s)) (prev (list)))
X;; (set-cdr! c prev)
X;; (cond ((not (pair? ex-cdr)) c)
X;; (else (loop ex-cdr (cdr ex-cdr) c))
X;; )
X;; )
X;; )
X;; )
X;;
X;; (define (RotateHandshakes! a) ;; This version not purely physical!
X;; (if (null? a)
X;; a
X;; (let ((ex-car (car a)))
X;; (set-car! a (cdr a))
X;; (set-cdr! a (list)) ;; () <- (cdr (last-pair ex-car)) (one cell)
X;; (cond ((pair? ex-car)
X;; (set-cdr! (last-pair ex-car) a)
X;; ex-car
X;; )
X;; (else a)
X;; )
X;; )
X;; )
X;; )
X;;
X
X
X(define (swap! s)
X (let ((ex-car (car s)))
X (set-car! s (cdr s))
X (set-cdr! s ex-car)
X s
X )
X)
X
X;; robl! -- Rotate Binary tree Left. Inverse of robr!
X;; Convert (a . (b . rest)) to ((a . b) . rest) destructively
X;; (with no cons cells wasted).
X;; Like cons2top! but keeps the "point(er) of reference" same:
X
X(define (robl! s)
X (let ((ex-car (car s))) ;; <- a
X (set-car! s (cddr s)) ;; (a . (b . rest)) -> (rest . (b . rest))
X (set-cdr! (cdr s) ex-car) ;; -> (rest . (b . a))
X (swap! (cdr s)) ;; -> (rest . (a . b))
X (swap! s) ;; -> ((a . b) . rest)
X s
X )
X)
X
X;; robr! -- Rotate Binary tree Right. Inverse of robl!
X;; Convert ((a . b) . rest) to (a . (b . rest)) destructively
X;; (with no cons cells wasted).
X
X(define (robr! s)
X (let ((ex-cdr (cdr s))) ;; <- rest
X (set-cdr! s (caar s)) ;; ((a . b) . rest) -> ((a . b) . a)
X (set-car! (car s) ex-cdr) ;; -> ((rest . b) . a)
X (swap! (car s)) ;; -> ((b . rest) . a)
X (swap! s) ;; -> (a . (b . rest))
X s
X )
X)
X
X
X(define (SwapBinTree! s)
X (cond ((not (pair? s)))
X (else
X (swap! s)
X )
X )
X s
X)
X
X
X(define (SwapDownCar! s)
X (cond ((not (pair? s)))
X (else
X (swap! s)
X (SwapDownCar! (cdr s)) ;; Really down car...
X;; Or:
X;; (SwapDownCar! (car s))
X;; (swap! s)
X )
X )
X s
X)
X
X
X(define (SwapDownCdr! s)
X (cond ((not (pair? s)))
X (else
X (swap! s)
X (SwapDownCdr! (car s)) ;; Really down cdr...
X;; Or:
X;; (SwapDownCdr! (cdr s))
X;; (swap! s)
X )
X )
X s
X)
X
X(define (ReflectBinTree! s)
X (cond ((not (pair? s)))
X (else ;; Six possible ways to arrange these:
X (swap! s)
X (ReflectBinTree! (car s))
X (ReflectBinTree! (cdr s))
X )
X )
X s
X)
X
X
X(define (RotateHandshakes! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))) (swap! s))
X (else
X (robr! s)
X (RotateHandshakes! (cdr s))
X )
X )
X s
X)
X
X(define (RotateHandshakesInv! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (RotateHandshakesInv! (cdr s))
X (robl! s)
X )
X )
X s
X)
X
X;; (0 1 3 2 7 8 4 5 6 17 18 20 21 22 9 10 11 12 13 14 15 19 16 45 46 48 49 50 54 55 ...)
X(define (RobrDownCar! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))) (swap! s))
X (else
X (robr! s)
X (RobrDownCar! (car s))
X )
X )
X s
X)
X
X;; (0 1 3 2 6 7 8 4 5 14 15 16 17 18 19 20 22 9 10 21 11 12 13 37 38 39 40 41 42 43 ...)
X(define (RobrDownCarInv! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (RobrDownCarInv! (car s))
X (robl! s)
X )
X )
X s
X)
X
X
X;; (0 1 3 2 6 7 8 4 5 15 14 16 17 18 19 20 21 9 10 22 11 12 13 39 40 41 37 38 43 ...)
X(define (RoblDownCdr_et_Swap! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (robl! s)
X (RoblDownCdr_et_Swap! (cdr s))
X )
X )
X s
X)
X
X;; (0 1 3 2 7 8 4 5 6 17 18 20 21 22 10 9 11 12 13 14 15 16 19 45 46 48 49 50 54 55 ...)
X(define (RoblDownCdr_et_SwapInv! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))) (swap! s))
X (else
X (RoblDownCdr_et_SwapInv! (cdr s))
X (robr! s)
X )
X )
X s
X)
X
X
X(define (RoblDownCar_et_Swap! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (robl! s)
X (RoblDownCar_et_Swap! (car s))
X )
X )
X s
X)
X
X(define (RoblDownCar_et_SwapInv! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))) (swap! s))
X (else
X (RoblDownCar_et_SwapInv! (car s))
X (robr! s)
X )
X )
X s
X)
X
X
X
X;; --> (0 1 3 2 7 8 5 4 6 17 18 20 21 22 12 13 10 9 11 15 14 19 16 45 46 48 49 50 54 55 ...)
X(define (robr_double_et_swap! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))) (swap! s))
X (else
X (robr! s)
X (robr_double_et_swap! (car s))
X (robr_double_et_swap! (cdr s))
X )
X )
X s
X)
X
X;; --> (0 1 3 2 7 6 8 4 5 17 16 18 14 15 20 19 22 9 10 21 11 12 13 45 44 46 42 43 48 47 ...)
X(define (double_robl_et_swap! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (double_robl_et_swap! (car s))
X (double_robl_et_swap! (cdr s))
X (robl! s)
X )
X )
X s
X)
X
X;; --> (0 1 3 2 7 8 5 6 4 17 18 20 21 22 12 13 15 16 19 10 9 14 11 45 46 48 49 50 54 55 ...)
X(define (domino_robr_et_swap! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))) (swap! s))
X (else
X (domino_robr_et_swap! (car s))
X (robr! s)
X (domino_robr_et_swap! (cdr s))
X )
X )
X s
X)
X
X;; --> (0 1 3 2 8 6 7 4 5 20 19 22 14 15 21 16 17 9 10 18 11 12 13 64 53 55 51 52 54 60 ...)
X(define (domino_robr_et_swap_inv! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (domino_robr_et_swap_inv! (cdr s))
X (robl! s)
X (domino_robr_et_swap_inv! (car s))
X )
X )
X s
X)
X
X;; (0 1 3 2 7 8 4 6 5 17 18 20 21 22 10 9 14 16 19 11 12 15 13 45 46 48 49 50 54 55 ...)
X(define (double_robr_et_swap! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))) (swap! s))
X (else
X (double_robr_et_swap! (car s))
X (double_robr_et_swap! (cdr s))
X (robr! s)
X )
X )
X s
X)
X
X
X;; (0 1 3 2 6 8 7 4 5 15 14 19 20 22 16 21 17 9 10 18 11 12 13 39 41 40 37 38 52 ...)
X(define (robl_double_et_swap! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (robl! s)
X (robl_double_et_swap! (car s))
X (robl_double_et_swap! (cdr s))
X )
X )
X s
X)
X
X
X;; Not a bijection: (0 1 2 2 4 5 4 4 6 9 10 11 12 13 9 10 9 9 11 14 14 16 19 23 ...)
X(define (robr_down_cdr! s)
X (cond ((not (pair? s)))
X ((not (pair? (car s))))
X (else
X (robr! s)
X (robr_down_cdr! (cdr s))
X )
X )
X s
X)
X
X
X(define (Rol! s)
X (cond ((pair? s)
X (swap! s)
X (RotateHandshakes! s)
X )
X )
X s
X)
X
X(define (Ror! s)
X (cond ((pair? s)
X (RotateHandshakesInv! s)
X (swap! s)
X )
X )
X s
X)
X
X
X(define (DeepRol_sans_top! s) ;; How to implement like the others?
X (cond ((pair? s)
X (Rol! (car s))
X (DeepRol_sans_top! (car s))
X (DeepRol_sans_top! (cdr s))
X )
X )
X s
X)
X
X(define (DeepRol! s) (Rol! (DeepRol_sans_top! s)))
X
X;; See http://www.megabaud.fi/~karttu/software/stacks.lsp
X
X(define (Rev1! s)
X (cond ((pair? s)
X (Rev1! (cdr s))
X (Rol! s)
X )
X )
X s
X)
X
X(define (Rev2! s)
X (cond ((pair? s)
X (Ror! s)
X (Rev2! (cdr s))
X )
X )
X s
X)
X
X
X(define (DeepRev1! s)
X (cond ((not (pair? s))) ;; Do nothing
X (else
X (DeepRev1! (car s))
X (DeepRev1! (cdr s))
X (Rol! s)
X )
X )
X s
X)
X
X
X
X(define (RolCarSide! s)
X (cond ((not (pair? s))) ;; Do nothing.
X (else
X (swap! s)
X (RoblDownCar_et_Swap! s)
X )
X )
X s
X)
X
X(define (RorCarSide! s)
X (cond ((not (pair? s))) ;; Do nothing.
X (else
X (RoblDownCar_et_SwapInv! s)
X (swap! s)
X )
X )
X s
X)
X
X
X
X(define (Rev1CarSide! s)
X (cond ((not (pair? s))) ;; Do nothing
X (else
X (Rev1CarSide! (car s))
X (RolCarSide! s)
X )
X )
X s
X)
X
X
X(define (DeepRev1CarSide! s)
X (cond ((not (pair? s))) ;; Do nothing
X (else
X (DeepRev1CarSide! (car s))
X (DeepRev1CarSide! (cdr s))
X (RolCarSide! s)
X )
X )
X s
X)
X
X(define (RotateTriangularization! s)
X (Rev1CarSide! s)
X (SwapDownCar! s)
X s
X)
X
X(define (RotateTriangularizationInv! s)
X (Rev1! s)
X (SwapDownCdr! s)
X s
X)
X
X
X(define (DeepReverse_et_RotateHandshakes! s)
X (DeepRev1! s)
X (RotateHandshakes! s)
X s
X)
X
X(define (RotateHandshakes_et_DeepReverse! s)
X (RotateHandshakes! s)
X (DeepRev1! s)
X s
X)
X
X
X;; Not a bijection!
X;; -> (0 1 2 2 4 4 4 4 5 9 9 9 9 9 9 9 9 9 10 10 11 12 13 23 23 ...)
X
X(define (robl-swap-robr! s)
X (cond ((not (pair? s)))
X ((not (pair? (cdr s))) (swap! s))
X (else
X (robl! s)
X (robl-swap-robr! (car s))
X (robr! s)
X (robl-swap-robr! (cdr s))
X )
X )
X s
X)
X
END-of-gatomorf.scm
echo x - gatorank.scm
sed 's/^X//' >gatorank.scm << 'END-of-gatorank.scm'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatorank.scm ;;
X;; - Functions for ranking & unranking objects in Catalan families, ;;
X;; either in the standard lexicographical order (A014486) ;;
X;; or in some of the alternative orders. ;;
X;; ;;
X;; This Scheme-code is Copyright (C) 2002 by Antti Karttunen ;;
X;; (E-mail: my_firstname.my_surname@iki.fi) and is placed under ;;
X;; the GPL (Gnu Public License), so you are free to copy it. ;;
X;; ;;
X;; Runs at least in MIT Scheme Release 7.6.0, for which one can find ;;
X;; documentation and the pre-compiled binaries (for various OS's ;;
X;; running in Intel x86 architecture) under the URL: ;;
X;; ;;
X;; http://www.swiss.ai.mit.edu/projects/scheme/ ;;
X;; ;;
X;; The main pointer for this code collection is: ;;
X;; http://www.megabaud.fi/~karttu/matikka/Nekomorphisms/gatomorf.htm ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X;; (load "C:\\matikka\\Schemuli\\intfuns1.scm") ;; Loads definecd.scm (definec-macro) in turn.
X
X;; (map A014486 (cons 0 (iota 23)))
X;; --> (0 2 10 12 42 44 50 52 56 170 172 178 180 184 202 204 210 212 216 226 228 232 240 682)
X
X(definec (A014486 n)
X (let ((w/2 (ranks_w/2 n)))
X (CatalanUnrank w/2 (if (zero? n) 0 (- n (A014137 (-1+ w/2)))))
X )
X)
X
X
X;; (map safe_w/2 (cons 0 (iota 42)))
X;; --> (0 2 3 3 3 4 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 6)
X(define (safe_w/2 n) (first_pos_with_funs_val_gte A000108 (1+ n)))
X
X
X(define (CatalanRankLocal a)
X (if (zero? a)
X 0
X (+ (CatalanRank (/ (binwidth a) 2) a))
X )
X)
X
X(define (CatalanRankGlobal a)
X (if (zero? a)
X 0
X (let ((w/2 (/ (binwidth a) 2)))
X (+ (A014137 (-1+ w/2))
X (CatalanRank w/2 a)
X )
X )
X )
X)
X
X;; This should produce same as (cons 0 (iota 6919)):
X;;
X;; (map CatalanRankGlobal
X;; (map parenthesization->binexp
X;; (map binexp->parenthesization
X;; (map A014486 (cons 0 (iota 6919))))))
X;;
X
X;; See http://www.megabaud.fi/~karttu/matikka/tab9766.htm
X
X
X(define (CatalanRank w/2 a)
X (let loop ((a a) ;; The totally balanced binary expansion
X (r 0)
X (lo 0)
X (y -1)
X )
X (if (zero? a)
X (- (/ (C (* 2 w/2) w/2) (1+ w/2))
X (1+ lo)
X )
X (if (zero? (modulo a 2))
X (loop ;; Down to the valley
X (fix:lsh a -1) ;; a >>= 1
X (1+ r)
X (+ lo (CatTriangle (1+ r) y))
X y
X )
X (loop ;; Upto the mountain high.
X (fix:lsh a -1) r lo (1+ y))
X )
X )
X )
X)
X
X(define (CatalanUnrank w/2 orank)
X (let ((rank (- (/ (C (* 2 w/2) w/2) (1+ w/2))
X (1+ orank)
X )
X )
X )
X (let loop ((a 0) ;; Constructed bit-string
X (lo 0)
X (t w/2) ;; The row on A009766
X (y (-1+ w/2)) ;; The position on row t of A009766
X (m (CatTriangle w/2 (-1+ w/2)))
X )
X (if (zero? t) a
X (if (> (+ lo m) rank)
X (loop (1+ (* 2 a)) ;; Up the mountain high
X lo
X t
X (-1+ y)
X (CatTriangle t (-1+ y))
X )
X (loop (* 2 a) ;; Down to the valley low
X (+ lo m)
X (-1+ t)
X y
X (CatTriangle (-1+ t) y)
X )
X )
X )
X )
X )
X)
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; Function parenthesization->binexp and two versions of ;;
X;; binexp->parenthesization, first the ;;
X;; straightforward version converted from Maple code, ;;
X;; and then the more enlightened "Forth"-inspired version. ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X;; (parenthesization->binexp '()) --> 0
X;; (parenthesization->binexp '(())) --> 2
X;; (parenthesization->binexp '(() ())) --> 10
X;; (parenthesization->binexp '((()))) --> 12
X
X(define (parenthesization->binexp p)
X (let loop ((s 0) (p p))
X (if (null? p)
X s
X (let* ((x (parenthesization->binexp (car p)))
X (w (binwidth x))
X )
X (loop (+ (fix:lsh s (+ w 2)) (fix:lsh 1 (1+ w)) (* 2 x))
X (cdr p)
X )
X )
X )
X )
X)
X
X
X;; PeelNextBalSubSeq and RestBalSubSeq expect their
X;; integer argument nn to contain the binary expansion
X;; of the (sub-)parenthesization in reverse order,
X;; with the least significant bit being always 1.
X
X
X(define (PeelNextBalSubSeq nn) ;; We assume that given nn is odd.
X (let loop ((z 0) (level -1) (n (fix:lsh nn -1)))
X (cond ((zero? level) (/ z 2)) ;; n on prev. iteration must has been even.
X (else (loop (+ (fix:lsh z 1) (modulo n 2)) ;; z <<= 1, z += n % 2
X (+ level (expt -1 (modulo n 2)))
X (fix:lsh n -1) ;; n >>= 1
X )
X )
X )
X )
X)
X
X
X(define (RestBalSubSeq nn) ;; We assume that given nn is odd.
X (let loop ((level -1) (n (fix:lsh nn -1)))
X (cond ((zero? level) (PeelNextBalSubSeq (1+ (* 2 n))))
X (else (loop (+ level (expt -1 (modulo n 2)))
X (fix:lsh n -1) ;; n >>= 1
X )
X )
X )
X )
X)
X
X
X(define (reversed_binexp->parenthesization n)
X (cons (binexp->parenthesization_in_dumb_way (PeelNextBalSubSeq n))
X (binexp->parenthesization_in_dumb_way (RestBalSubSeq n))
X )
X)
X
X(define (binexp->parenthesization_in_dumb_way n)
X (if (zero? n)
X (list)
X (reversed_binexp->parenthesization (binrev n))
X )
X)
X
X
X;; Now, if we remember that "Lisp" spelled backwards is "Forth",
X;; and the parenthesizations have another form as Dyck paths,
X;; it's much easier to implement this by scanning the totally
X;; balanced binary string from the end (the rightmost = the least
X;; significant bit) to the beginning (to the leftmost = the most
X;; significant bit). Note how we don't need double-forked
X;; recursion anymore, but just simple tail-recursion is enough.
X;;
X
X
X(define (binexp->parenthesization n)
X (let loop ((n n) (stack (list (list))))
X (cond ((zero? n) (car stack))
X ((zero? (modulo n 2))
X (loop (fix:lsh n -1) (cons (list) stack))
X )
X (else
X (loop (fix:lsh n -1) (cons2top! stack))
X )
X )
X )
X)
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;; ;;
X;; A few alternative ranking & unranking functions (in development) ;;
X;; ;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
X
X(define (rank-bintree bt packfun)
X (cond ((not (pair? bt)) 0)
X (else (1+ (packfun (rank-bintree (car bt) packfun)
X (rank-bintree (cdr bt) packfun)
X )
X )
X )
X )
X)
X
X(define (unrank-bintree rank pr1 pr2)
X (cond ((zero? rank) (list))
X (else (cons (unrank-bintree (pr1 (-1+ rank)) pr1 pr2)
X (unrank-bintree (pr2 (-1+ rank)) pr1 pr2)
X )
X )
X )
X)
X
X
X
X(define (lexrank->btrank-bijection packfun)
X (lambda (n) (rank-bintree (binexp->parenthesization (A014486 n)) packfun))
X)
X
X
X(define (btrank->lexrank-bijection pr1 pr2)
X (lambda (n)
X (CatalanRankGlobal (parenthesization->binexp (unrank-bintree n pr1 pr2)))
X )
X)
X
X
X(define lexrank->btrank0 (lexrank->btrank-bijection packA061579))
X
X(define btrank0->lexrank (btrank->lexrank-bijection A002262 A025581))
X
X(define lexrank->btrank1 (lexrank->btrank-bijection packA001477))
X
X(define btrank1->lexrank (btrank->lexrank-bijection A025581 A002262))
X
X
X;; (map lexrank->btrank0 (cons 0 (iota 120)))
X;; --> (0 1 2 3 4 7 5 6 10 11 29 16 22 56 8 12 9 15 36 14 21 28 66 67 436 137 254 1597 37 79 46 121 667 106 232 407 2212 17 38 23 30 68 13 18 20 78 465 44 153 276 1653 19 25 27 45 91 35 55 136 703 77 120 253 435 2278 2279 95267 9454 32386 1276004 704 3161 1082 7382 222779 5672 27029 83029 2447579 154 742 277 466 2347 92 172 211 3082 108346 991 11782 38227 1367032 191 326 379 1036 4187 631 1541 9317 247457 3004 7261 32132 94831 2595782 80 467 155 278 1655 47 93 57 138 705 122 255 437 2280)
X
X;; (map btrank0->lexrank (cons 0 (iota 120)))
X;; --> (0 1 2 3 4 6 7 5 14 16 8 9 15 42 19 17 11 37 43 51 44 20 12 39 121 52 126 53 21 10 40 123 149 127 154 56 18 28 38 124 151 385 155 163 47 54 30 112 122 152 387 475 164 135 156 57 13 114 376 150 388 477 503 136 480 165 22 23 41 378 466 386 478 505 413 481 508 60 45 29 107 125 468 1234 476 506 415 1540 509 177 128 55 84 113 371 153 1236 1531 504 416 1542 1630 178 390 159 166 33 348 377 461 389 1533 1621 414 1543 1632 551 391 489 510 61)
X
X;; (first-dislocated (map lexrank->btrank0 (map btrank0->lexrank (cons 0 (iota 999))))) --> ()
X
X
X;; (map lexrank->btrank1 (cons 0 (iota 120)))
X;; --> (0 1 3 2 10 6 5 7 4 66 28 21 36 15 14 9 12 56 22 8 16 29 11 2278 435 253 703 136 120 55 91 1653 276 45 153 465 78 77 35 27 44 20 25 18 68 2212 407 30 232 667 121 19 13 23 106 46 38 79 1597 254 17 37 137 436 67 2598060 95266 32385 248160 9453 7381 1596 4278 1368685 38503 1081 11935 108811 3160 3081 666 406 1035 231 351 190 2415 2449791 83436 496 27261 223446 7503 210 105 300 5778 1128 780 3240 1277601 32640 171 741 9591 95703 2346 2345 464 275 740 152 135 65 104 1710 299 54 170 495 90)
X
X;; (map btrank1->lexrank (cons 0 (iota 120)))
X;; --> (0 1 3 2 8 6 5 7 19 15 4 22 16 52 14 13 20 60 43 51 41 11 18 53 178 42 153 39 10 21 47 155 177 125 151 38 12 61 56 136 154 555 123 150 40 33 55 179 164 135 479 553 122 152 117 29 17 159 557 163 417 477 552 124 471 113 9 64 44 490 556 507 415 476 554 381 467 37 36 57 191 127 489 1799 505 414 478 1791 377 149 120 30 181 165 600 126 1572 1797 504 416 1536 1787 121 474 114 94 54 561 509 599 389 1570 1796 506 1329 1532 551 384 468 358 28)
X
END-of-gatorank.scm
echo x - gatouse1.scm
sed 's/^X//' >gatouse1.scm << 'END-of-gatouse1.scm'
X
X(define reversed_iota
X (lambda (n)
X (if (zero? n) (list)
X (cons n (reversed_iota (- n 1)))
X )
X )
X)
X
X(define iota (lambda (n) (reverse! (reversed_iota n))))
X
X(define (iota0 upto_n)
X (let loop ((n upto_n) (result (list)))
X (cond ((zero? n) (cons 0 result))
X (else (loop (- n 1) (cons n result)))
X )
X )
X)
X
X
X(define (nthmemq elem lista)
X (let loop ((lista lista) (i 0))
X (cond ((null? lista) #f)
X ((eq? (car lista) elem) i)
X (else (loop (cdr lista) (1+ i)))
X )
X )
X)
X
X(define attach! ; Borrowed from Franz lisp, is like destructive cons.
X (lambda (elem lista)
X (set-cdr! lista (cons (car lista) (cdr lista)))
X (set-car! lista elem)
X lista
X )
X)
X
X
X(define (count-pars a)
X (cond ((not (pair? a)) 0)
X (else (+ 1 (count-pars (car a)) (count-pars (cdr a))))
X )
X)
X
X
X(define (nthcdr n lista)
X (if (or (zero? n) (null? lista))
X lista
X (nthcdr (- n 1) (cdr lista))
X )
X)
X
X
X;; For testing whether we have an identity permutation or not.
X(define (first_dislocated lista)
X (let loop ((lista lista) (i 0))
X (cond ((null? lista) lista)
X ((not (eq? (car lista) i)) lista)
X (else (loop (cdr lista) (1+ i)))
X )
X )
X)
X
X(define (prsymbol x)
X (cond ((symbol? x) (write-string (string-upcase (symbol->string x))))
X (else (write x))
X )
X)
X
X(define (prlist x)
X (cond ((null? x) (newline))
X ((list? x) (prsymbol (car x))
X (if (not (null? (cdr x))) (write-string " "))
X (prlist (cdr x))
X )
X (else (write x))
X )
X)
X
X
X
END-of-gatouse1.scm
exit