;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; http://www.research.att.com/~njas/sequences/juggling.scm.txt ;; ;; ;; ;; Coded by Antti Karttunen (Antti.Karttunen(-AT-)iki.fi), 2003 ;; ;; ;; ;; This file contains the Scheme-functions that compute the sequences ;; ;; A084449-A084470, A084489-A084530, A084555-A084557 submitted to ;; ;; Neil Sloane's On-Line Encyclopedia of Integer Sequences (OEIS) ;; ;; and available at http://www.research.att.com/~njas/sequences/ ;; ;; ;; ;; Copy of THIS source file is also available at: ;; ;; http://www.iki.fi/~karttu/matikka/Schemuli/juggling.scm ;; ;; ;; ;; This Scheme-code is in Public Domain and runs (at least) ;; ;; in MIT Scheme Release 7.7.x, 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/ ;; ;; ;; ;; This should be a stand-alone module. ;; ;; ;; ;; Note that "Polster's book" mentioned here refers to: ;; ;; Burkard Polster, The Mathematics of Juggling, Springer-Verlag, 2003. ;; ;; ;; ;; Please feel free to add more code here, if you want to compute ;; ;; the corresponding sequences for 2, 4 and 5 balls for example. ;; ;; Send the edited version then either to my address ;; ;; (with subject "TOPIC: Juggling.scm.txt") ;; ;; or Neil's address at njas(-AT-)research.att.com, ;; ;; so that the attachment ;; ;; http://www.research.att.com/~njas/sequences/juggling.scm.txt ;; ;; stays up-to-date. ;; ;; ;; ;; Last edited 2. June 2003 by Antti Karttunen. ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; In my system I have this located as C:\matikka\Schemuli\juggling.scm ;; so I can either load this as: ;; (load "c:\\matikka\\Schemuli\\juggling.scm") ;; ;; or compile as: ;; (cf "c:\\matikka\\Schemuli\\juggling.scm" "c:\\matikka\\Schemuli\\") ;; and then load the compiled image as: ;; (load "c:\\matikka\\Schemuli\\juggling.com") ;; ;; (declare (usual-integrations)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; Copied from http://www.iki.fi/~kartturi/matikka/Schemuli/definech.scm ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define unary cached functions. Syntax is like ;; (define (func arg) ...) of Scheme. ;; Note that this and other cached functions depend on MIT Scheme ;; peculiarities, like that vectors are initialized to contain #f's ;; and also that #f is actually same thing as (). To be corrected. ;; Added this 10. July 2002 to avoid allocation catastrophes ;; caused by the careless use of the cached integer functions: (define *MAX-CACHE-SIZE-FOR-DEFINEC* 290512) ;; Was 131072 (define-syntax definec (syntax-rules () ((definec (name arg) e0 ...) (define name (letrec ((_cache_ (vector #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)) (name (lambda (arg) (cond ((null? arg) _cache_) ((>= arg *MAX-CACHE-SIZE-FOR-DEFINEC*) e0 ... ) (else (if (>= arg (vector-length _cache_)) (set! _cache_ (vector-grow _cache_ (min *MAX-CACHE-SIZE-FOR-DEFINEC* (max (1+ arg) (* 2 (vector-length _cache_)) ) ) ) ) ) (or (vector-ref _cache_ arg) ((lambda (res) (vector-set! _cache_ arg res) res ) (begin e0 ...) ) ) ) ) ; cond ) ) ) ; letrec-definitions name ) ; letrec ) ;; (define name ...) ) ) ;; syntax-rules ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; Copied from http://www.iki.fi/~kartturi/matikka/Schemuli/lstfuns1.scm ;; ;; (always useful!) ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (compose-funs . funlist) (cond ((null? funlist) (lambda (x) x)) (else (lambda (x) ((car funlist) ((apply compose-funs (cdr funlist)) x)))) ) ) (define reversed_iota (lambda (n) (if (zero? n) (list) (cons n (reversed_iota (- n 1))) ) ) ) (define iota (lambda (n) (reverse! (reversed_iota n)))) (define (iota0 upto_n) (let loop ((n upto_n) (result (list))) (cond ((zero? n) (cons 0 result)) (else (loop (- n 1) (cons n result))) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; Copied from http://www.iki.fi/~kartturi/matikka/Schemuli/intfuns1.scm ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (first_pos_with_funs_val_gte fun n) (let loop ((i 0)) (if (>= (fun i) n) i (loop (1+ i)) ) ) ) (definec (binomial_n_2 n) (/ (* (-1+ n) n) 2)) ;; At some point these will produce incorrect values, because of the ;; limited precision of IEEE 64-bit floating point numbers. ;; What is that point, and how to recode these with strictly fixnum-only ;; way? (I need a fixnum-only square root algorithm...) (definec (A025581 n) ;; The X component (column) of square {0..inf} arrays (- (binomial_n_2 (1+ (floor->exact (flo:+ 0.5 (flo:sqrt (exact->inexact (* 2 (1+ n)))))))) (1+ n)) ) ;; (map A002262 (cons 0 (iota 20))) --> (0 0 1 0 1 2 0 1 2 3 0 1 2 3 4 0 1 2 3 4 5) (definec (A002262 n) ;; The Y component (row) of square {0..inf} arrays (- n (binomial_n_2 (floor->exact (flo:+ 0.5 (flo:sqrt (exact->inexact (* 2 (1+ n)))))))) ) (define (A002024 n) ;; repeat n n times, starting from n = 1. (floor->exact (+ (/ 1 2) (sqrt (* 2 n)))) ) (define (A003056 n) ;; repeat n n+1 times, starting from n = 0. (floor->exact (- (sqrt (* 2 (1+ n))) (/ 1 2))) ) (define (A000265 n) (/ n (A006519 n))) ;; Remove 2s from n; or largest odd divisor of n. (define (A006519 n) ;; Highest power of 2 dividing n: 1,2,1,4,1,2,1,8,1,2,1,4,1,2,1,16 (cond ((zero? n) 0) (else (let loop ((n n) (i 1)) (cond ((odd? n) i) (else (loop (floor->exact (/ n 2)) (* i 2))) ) ) ) ) ) ;; Note that (A007814 33574912) = 12. (define (A007814 n) ;; Exponent of the A006519. (cond ((zero? n) 0) (else (let loop ((n n) (i 0)) (cond ((odd? n) i) ;; (else (loop (fix:lsh n -1) (1+ i))) ;; Dangerous code. (else (loop (floor->exact (/ n 2)) (1+ i))) ) ) ) ) ) (define (A007088 n) ;; 0,1,10,11,100,101,110,111,1000,... (Show binary form in decimal) (let loop ((z 0) (i 0) (n n)) (if (zero? n) z (loop (+ z (* (expt 10 i) (modulo n 2))) (1+ i) (floor->exact (/ n 2)) ) ) ) ) ;; One-based: (define (A018900 n) (+ (expt 2 (A002024 n)) (expt 2 (A002262 (-1+ n))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; Some asynchronic, infinite juggling sequences, with the states and ;; ;; throw-heights (i.e. usual "siteswap"-notation). ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (N2Z n) (* (expt -1 n) (floor->exact (/ n 2)))) (define (Z2n z) (+ (* 2 (abs z)) (if (not (positive? z)) 1 0))) ;; (Note that zero is not a positive number.) ;; (map N2Z (iota 30)) ;; (0 1 -1 2 -2 3 -3 4 -4 5 -5 6 -6 7 -7 8 -8 9 -9 10 -10 11 -11 12 -12 13 -13 14 -14 15) ;; Essentially A001057, but using offset=1 instead of 0. ;; These six are one-based: (define A065164 (compose-funs Z2N 1+ N2Z)) (define A065165 (compose-funs Z2N 1+ 1+ N2Z)) (define A065166 (compose-funs Z2N 1+ 1+ 1+ N2Z)) (define A065168 (compose-funs Z2N -1+ N2Z)) (define A065169 (compose-funs Z2N -1+ -1+ N2Z)) (define A065170 (compose-funs Z2N -1+ -1+ -1+ N2Z)) ;; E.g.: ;; (map A065166 (iota 20)) --> (6 8 4 10 2 12 1 14 3 16 5 18 7 20 9 22 11 24 13 26) ;; (map A065170 (iota 20)) --> (7 5 9 3 11 1 13 2 15 4 17 6 19 8 21 10 23 12 25 14) (define (reflect-to-Z throw-fun z) (cond ((zero? z) z) ;; Do a zero-throw at beat 0. ((positive? z) (throw-fun z)) (else ;; Beats before zero... (let loop ((i (- z))) (cond ((zero? i) (* 2 (- z))) ((= (+ i (throw-fun i)) (- z)) (- (- z) i)) (else (loop (-1+ i))) ) ) ) ) ) ;; Applying the idea of "Inverse of Juggling Sequence" ;; (See Polster's book, pages 25-27) to infinite permutations: ;; (This one for 3-ball sequences.) (define (reflect-to-Z-b3 throw-fun permfun z) (cond ((positive? z) (throw-fun z)) ((<= (- z) 3) (* 2 (- z))) (else (throw-fun (permfun (- (- z) 3)))) ) ) ;; 84449 --- 84463. (definec (A084449 n) ;; Positions of sevens (ground states) in A084451. (cond ((zero? n) n) (else (let loop ((i (1+ (A084449 (-1+ n))))) (cond ((= (A084451 0) (A084451 i)) i) (else (loop (1+ i))) ) ) ) ) ) ;; First differences of A084449: (define (A084465 n) (- (A084449 (1+ n)) (A084449 n))) (define (A084450 n) (A007088 (A084451 n))) (definec (A084451 n) (if (zero? n) 7 ;; Ground-state for three balls (bits). (/ (-1+ (+ (A084451 (-1+ n)) (expt 2 (A084452 n)))) 2) ) ) ;; (definec (A084451v2 n) ;; Older variant. ;; (cond ((zero? n) 7) ;; Ground-state for three balls (bits). ;; (else (+ (floor->exact (/ (A084451v2 (-1+ n)) 2)) ;; (floor->exact (expt 2 (- (A084452 n) 1))) ;; ) ;; ) ;; ) ;; ) ;; (define (A084452 n) ;; One-based: 4,4,4,0,5,5,5,0,0,6,3,5, (let ((prevstate (A084451 (-1+ n)))) (cond ((even? prevstate) 0) ;; Must throw zero! (else ;; (call-with-current-continuation ;; (lambda (return) (let outloop ((t 1)) (cond ((even? (floor->exact (/ prevstate (expt 2 t)))) ;; Free position? (let inloop ((c (+ (floor->exact (/ prevstate 2)) (expt 2 (-1+ t)) ) ) (i (-1+ n)) ) (cond ((< i 0) t) ;; (return t) ((= c (A084451 i)) (outloop (1+ t))) (else (inloop c (-1+ i))) ) ) ) (else (outloop (1+ t))) ) ) ;; ) ;; ) ) ) ) ) (definec (A084453 n) (- (+ n (A084452 n)) 3)) (define (A084454 n) (let loop ((i 1)) (cond ((= n (A084453 i)) i) (else (loop (1+ i)))))) ;; Inverse is A084466. (define A084455 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z A084452 z))) N2Z ) ) (define A084455v2 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z-b3 A084452 A084454 z))) N2Z ) ) (define (A084466 n) (let loop ((i 1)) (cond ((= n (A084455 i)) i) (else (loop (1+ i)))))) ;;;;;;;;;;;; (define (A084456 n) (A007088 (A084457 n))) (definec (A084457 n) (if (zero? n) 7 ;; Ground-state for three balls (bits). (/ (+ -1 (A084457 (-1+ n)) (expt 2 (A084458 n))) 2) ) ) (define (A084458 n) ;; One-based: 4,4,6,0,5,8,0,0,3,7,0,7,0,9,0,0,7,0,10,... (let ((prevstate (A084457 (-1+ n)))) (cond ((even? prevstate) 0) ;; Must throw zero! (else (let outloop ((t 1)) (cond ((even? (floor->exact (/ prevstate (expt 2 t)))) ;; Free position? (let inloop ((c (A000265 (+ (floor->exact (/ prevstate 2)) (expt 2 (-1+ t)) ) ) ) (i (-1+ n)) ) (cond ((< i 0) t) ((= c (A084457 i)) (outloop (1+ t))) (else (inloop c (-1+ i))) ) ) ) (else (outloop (1+ t))) ) ) ) ) ) ) (define (A084459 n) (- (+ n (A084458 n)) 3)) (define (A084460 n) (let loop ((i 1)) (cond ((= n (A084459 i)) i) (else (loop (1+ i)))))) (define A084461 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z A084458 z))) N2Z ) ) (define A084461v2 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z-b3 A084458 A084460 z))) N2Z ) ) (define (A084462 n) (let loop ((i 1)) (cond ((= n (A084461 i)) i) (else (loop (1+ i)))))) ;; One-based: (definec (A084463 n) ;; Positions of even states in 84457, i.e. zeros in A084458 - 1. (cond ((= 1 n) 3) (else (let loop ((i (1+ (A084463 (-1+ n))))) (cond ((even? (A084457 i)) i) (else (loop (1+ i))) ) ) ) ) ) ;; Positions of odd states in 84457, i.e. non-zero-throws in A084458 - 1. One-based. (definec (A084464 n) (cond ((= 1 n) 0) (else (let loop ((i (1+ (A084464 (-1+ n))))) (cond ((odd? (A084457 i)) i) (else (loop (1+ i))) ) ) ) ) ) ;; One-based: (definec (A084467 n) (A084457 (A084464 n))) ;; (map A084467 (iota 22)) ;; (7 11 13 19 25 35 21 37 41 69 49 67 97 131 73 137 81 133 161 261 193 259) ;; (keep-matching-items (map A084457 (iota0 64)) odd?) ;; (7 11 13 19 25 35 21 37 41 69 49 67 97 131 73 137 81 133 161 261 193 259 145 265 289) ;; One-based: (definec (A084468 n) (1+ (* 2 (A018900 n)))) ;; (map A084468 (iota 22)) ;; (7 11 13 19 21 25 35 37 41 49 67 69 73 81 97 131 133 137 145 161 193 259) (define (A084469 n) (let loop ((x (A084467 n)) (i 1)) (cond ((= x (A084468 i)) i) (else (loop x (1+ i))) ) ) ) (define (A084470 n) (let loop ((x (A084468 n)) (i 1)) (cond ((= x (A084467 i)) i) (else (loop x (1+ i))) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; Successively larger loops starting from and returning to the ground ;; ;; state (with various conditions). ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This implementation is very straightforward and dumb. ;; It would be more efficient to merge the functions ;; next-test-vector! and gs2gs? together, and not to speak ;; about the fact that there EXISTS an _unranking_ algorithm ;; for type=0 ground-state sequences, except that I'm afraid ;; that we cannot find such a variant that would return ;; the sequences in the ascending lexical order. ;; See Polster's book, pages 28-29, for Martin Probert's ;; "Pick a Pattern Procedure", or: ;; Probert, Martin. Four Ball Juggling. Published by Veronika Probert, U.K., 1995. ;; ;; (Even with that drawback a direct unranking algorithm would be useful ;; when computing the terms of A084529 for example). ;; (define (vec-to-dec tv) (let loop ((i 0) (s 0)) (cond ((= (vector-length tv) i) s) (else (loop (1+ i) (+ (* 10 s) (vector-ref tv i)))) ) ) ) ;; tv is a vector, p = (vector-length tv), i = running index, 0 initially. ;; (last-possible? (vector) 2 0 0) --> #t ;; (last-possible? (vector 3) 3 1 0) --> #t ;; (last-possible? (vector 3 1) 3 2 0) --> #t ;; (last-possible? (vector 5 3 1) 5 3 0) --> #t ;; (last-possible? (vector 6 4 2 0) 6 4 0) --> #t ;; (last-possible? (vector 7 5 3 1 0) 7 5 0) --> #t ;; (last-possible? (vector 8 6 4 2 0 0) 8 6 0) --> #t (define (last-possible? tv u p i) (cond ((= i p) #t) ((= (vector-ref tv i) u) (last-possible? tv (max (- u 2) 0) p (1+ i)) ) (else #f) ) ) (define (next-test-vector! tv b) ;; b is the number of balls. (let ((p (vector-length tv))) ;; Period of our (sub-)pattern. (cond ((last-possible? tv (+ p (-1+ b)) p 0) (make-vector (1+ p) b) ;; Return one element longer vector [b,b,b,...,b] ) (else ;; Increment with an odometer-principle, from right to left: (let loop ((i (-1+ p)) (u b)) (cond ((< i 0) (error "next-test-vector! should not happen: tv=" tv " i=" i " u=" u " b=" b ) ) ((= (vector-ref tv i) u) ;; Highest poss. value for this thow? (vector-set! tv i 0) ;; Replace with a zero throw (loop (-1+ i) (1+ u)) ;; and continue to the left. ) (else ;; Found a position with not yet in its max. height. (vector-set! tv i (1+ (vector-ref tv i))) ;; Increment tv ;; and return. ) ) ) ) ) ) ) ;; ;; Above works like this. ;; Alternatively, we could take the multiples of b!, ;; and discard b-1 least significant digits (zeros) ;; from their factorial expansion. ;; ;; (begin (set! v (next-test-vector! (vector) 3)) v) --> #(3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(3 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(3 3 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(3 4 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(3 4 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(3 4 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(3 4 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 0 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 0 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 0 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 0 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 1 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 1 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 1 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 1 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 2 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 2 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 2 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 2 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 3 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 3 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 3 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 3 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 4 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 4 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 4 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(4 4 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 0 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 0 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 0 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 0 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 1 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 1 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 1 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 1 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 2 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 2 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 2 2) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 2 3) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 3 0) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(5 3 1) ;; (begin (set! v (next-test-vector! v 3)) v) --> #(3 3 3 3) ;; ;; type = 0: Anything goes. ;; type = 1: No ground state in the middle allowed. ;; type = 2: No state should be visited twice (i.e. collect only "prime" loops). ;; (gs2gs? (vector 3) 3 0) --> #t ;; (gs2gs? (vector 3 3) 3 0) --> #t ;; (gs2gs? (vector 3 3 3) 3 0) --> #t ;; (gs2gs? (vector 3 3 3) 3 1) --> () ;; (gs2gs? (vector 3 3 3) 3 2) --> () ;; (gs2gs? (vector 4 2) 3 0) --> #t ;; (gs2gs? (vector 4 2) 3 1) --> #t ;; (gs2gs? (vector 4 2) 3 2) --> #t ;; (gs2gs? (vector 4 2 3) 3 0) --> #t ;; (gs2gs? (vector 4 2 3) 3 1) --> () ;; (gs2gs? (vector 4 2 3) 3 2) --> () ;; (gs2gs? (vector 4 4 1) 3 0) --> #t ;; (gs2gs? (vector 4 4 1) 3 1) --> #t ;; (gs2gs? (vector 4 4 1) 3 2) --> #t ;; (gs2gs? (vector 5 3 1) 3 0) --> #t ;; (gs2gs? (vector 5 3 1) 3 1) --> #t ;; (gs2gs? (vector 5 3 1) 3 2) --> #t ;; (gs2gs? (vector 4 5 1 2) 3 0) --> #t ;; (gs2gs? (vector 4 5 1 2) 3 1) --> #t ;; (gs2gs? (vector 4 5 1 2) 3 2) --> () (define (gs2gs? tv b type) (let ((gs (-1+ (expt 2 b))) ;; The ground state, e.g. 7 for b=3. (p (vector-length tv)) ;; Period of our tentative pattern ) (let loop ((s gs) (i 0) (visited (list))) ;; When finished, return true only if we have returned back to the ground state: (cond ((= i p) (= s gs)) (else (let ((tt (vector-ref tv i))) (cond ((and (= 1 type) (> i 0) (= s gs)) #f) ((and (= 2 type) (memq s visited)) #f) ((and (even? s) (not (zero? tt))) #f) ;; Zero-throw expected! ((not (even? (floor->exact (/ s (expt 2 tt))))) #f ;; Collision! ) (else (loop (floor->exact (/ (+ s (expt 2 tt)) 2)) (1+ i) (if (= 2 type) (cons s visited) visited) ) ) ) ) ) ) ;; cond ) ;; let loop ) ) (definec (nth-successful-test-vector-3-0 n) (cond ((zero? n) (vector)) (else (let loop ((tv (next-test-vector! (vector-copy (nth-successful-test-vector-3-0 (-1+ n))) 3 ) )) (cond ((gs2gs? tv 3 0) tv) (else (loop (next-test-vector! tv 3))) ) ) ) ) ) ;; Instead of having zillion simple functions like one above, ;; we now have the complex function-defining function given below, ;; which we can reuse for all the possible variants. ;; E.g. we could define a copy of above function as: ;; (define another-nth-successful-test-vector-3-0 ;; (cacfun-for-nth-successful-test-vec 3 0) ;; ) ;; (define (cacfun-for-nth-successful-test-vec balls type) (letrec ((_cache_ (vector #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)) (belgthor ;; The function we are defining and returning here. (lambda (n) (cond ((not (integer? n)) _cache_) ;; Just for debugging. (else (if (>= n (vector-length _cache_)) (set! _cache_ (vector-grow _cache_ (max (1+ n) (* 2 (vector-length _cache_)) ) ) ) ) (or (vector-ref _cache_ n) ((lambda (result) (vector-set! _cache_ n result) result ) (cond ((zero? n) (vector)) (else (let loop ((tv (next-test-vector! (vector-copy (belgthor (-1+ n))) balls ) )) (cond ((gs2gs? tv balls type) tv) (else (loop (next-test-vector! tv balls)) ) ) ) ) ) ) ;; Invocation of the lambda-form ) ;; or ) ;; else ) ;; cond ) ; lambda (n) ) ) ;; letrec-definitions. belgthor ) ;; letrec ) ;; What we really should have, is macro that would expand to ;; this, with its invocation's body-part inserted as an argument ;; to that inner lambda-form. ;; I.e. macro with which we could define functions that return ;; lambda-forms (which cache their only argument). (define (cacfun-for-posfun fun start-from elem) (letrec ((_cache_ (vector #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)) (tvimadur ;; The function we are defining and returning here. (lambda (n) (cond ((not (integer? n)) _cache_) ;; Just for debugging. (else (if (>= n (vector-length _cache_)) (set! _cache_ (vector-grow _cache_ (max (1+ n) (* 2 (vector-length _cache_)) ) ) ) ) (or (vector-ref _cache_ n) ((lambda (result) (vector-set! _cache_ n result) result ) (cond ((= start-from n) n) (else (let loop ((i (if (= start-from n) n (1+ (tvimadur (-1+ n))) ) )) (cond ((= (fun i) elem) i) (else (loop (1+ i))) ) ) ) ) ) ;; Invocation of the lambda-form ) ;; or ) ;; else ) ;; cond ) ; lambda (n) ) ) ;; letrec-definitions. tvimadur ) ;; letrec ) (define nth-successful-test-vec-3-0 (cacfun-for-nth-successful-test-vec 3 0)) (define nth-successful-test-vec-3-1 (cacfun-for-nth-successful-test-vec 3 1)) (define nth-successful-test-vec-3-2 (cacfun-for-nth-successful-test-vec 3 2)) ;; 84489 --- 84530 reserved for us. ;; First twelve permutations of non-negative integers & natural numbers ;; induced by these three infinite siteswap-sequences: ;; One-based: (definec (A084489 n) (- (+ n (A084501 n)) 3)) (define (A084490 n) (let loop ((i 1)) (cond ((= n (A084489 i)) i) (else (loop (1+ i)))))) (define A084491 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z A084501 z))) N2Z ) ) (define A084491v2 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z-b3 A084501 A084490 z))) N2Z ) ) (define (A084492 n) (let loop ((i 1)) (cond ((= n (A084491 i)) i) (else (loop (1+ i)))))) ;;;;;;;;;;;;; (definec (A084493 n) (- (+ n (A084511 n)) 3)) (define (A084494 n) (let loop ((i 1)) (cond ((= n (A084493 i)) i) (else (loop (1+ i)))))) (define A084495 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z A084511 z))) N2Z ) ) (define A084495v2 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z-b3 A084511 A084494 z))) N2Z ) ) (define (A084496 n) (let loop ((i 1)) (cond ((= n (A084495 i)) i) (else (loop (1+ i)))))) ;;;;;;;;;;;;; (definec (A084497 n) (- (+ n (A084521 n)) 3)) (define (A084498 n) (let loop ((i 1)) (cond ((= n (A084497 i)) i) (else (loop (1+ i)))))) (define A084499 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z A084521 z))) N2Z ) ) (define A084499v2 (compose-funs Z2N (lambda (z) (+ z (reflect-to-Z-b3 A084521 A084498 z))) N2Z ) ) (define (A084530 n) (let loop ((i 1)) (cond ((= n (A084499 i)) i) (else (loop (1+ i)))))) ;; Siteswap-sequences (throws): A084501, A084511, A084521 ;; Siteswap-sequences (finite decimal notation): A084502, A084512, A084522 ;; Associated state-sequences (decimal notation): A084503, A084513, A084523 ;; Associated state-sequences (binary notation): A084504, A084514, A084524 ;; partial sums of the next: A084505, A084515, A084525 ;; length of each gs->gs siteswap-subpattern, ~first diff of above -6 ;; first position of n in A0845[0-2]1: -7 ;; positions of 1's in that. -8 ;; their first differences (~ count of how many siteswaps of each period) -9 ;; All are one-based, except the state-sequences, or unless otherwise noted. ;; These tell at which siteswap sub-pattern (as given by A0845{0,1,2}2) ;; is the nth term of A0845{0-2}1: (definec (A084500 n) (first_pos_with_funs_val_gte A084505 n)) (definec (A084510 n) (first_pos_with_funs_val_gte A084515 n)) (definec (A084520 n) (first_pos_with_funs_val_gte A084525 n)) ;; (equal? (map A084510 (iota 64)) (map A084520 (iota 64))) --> #t ;; (A084510 65) --> 19 ;; (A084520 65) --> 18 (definec (A084501 n) (vector-ref (nth-successful-test-vec-3-0 (A084500 n)) (- n (1+ (A084505 (-1+ (A084500 n))))) ) ) (definec (A084511 n) (vector-ref (nth-successful-test-vec-3-1 (A084510 n)) (- n (1+ (A084515 (-1+ (A084510 n))))) ) ) (definec (A084521 n) (vector-ref (nth-successful-test-vec-3-2 (A084520 n)) (- n (1+ (A084525 (-1+ (A084520 n))))) ) ) ;; Siteswap-sequences (finite decimal notation): A084502, A084512, A084522 (define A084502 (compose-funs vec-to-dec nth-successful-test-vec-3-0)) (define A084512 (compose-funs vec-to-dec nth-successful-test-vec-3-1)) (define A084522 (compose-funs vec-to-dec nth-successful-test-vec-3-2)) ;; These are zero-based: (definec (A084503 n) (cond ((zero? n) (-1+ (expt 2 3))) ;; 7 = ground-state for three balls (bits). (else (/ (+ -1 (A084503 (-1+ n)) (expt 2 (A084501 n))) 2)) ) ) (definec (A084513 n) (cond ((zero? n) (-1+ (expt 2 3))) ;; 7 = ground-state for three balls (bits). (else (/ (+ -1 (A084513 (-1+ n)) (expt 2 (A084511 n))) 2)) ) ) (definec (A084523 n) (cond ((zero? n) (-1+ (expt 2 3))) ;; 7 = ground-state for three balls (bits). (else (/ (+ -1 (A084523 (-1+ n)) (expt 2 (A084521 n))) 2)) ) ) ;; As well: (define A084504 (compose-funs A007088 A084503)) (define A084514 (compose-funs A007088 A084513)) (define A084524 (compose-funs A007088 A084523)) ;; Partial sums of the next ones, zero-based. (definec (A084505 n) (if (zero? n) n (+ (A084505 (-1+ n)) (A084506 n)))) (definec (A084515 n) (if (zero? n) n (+ (A084515 (-1+ n)) (A084516 n)))) (definec (A084525 n) (if (zero? n) n (+ (A084525 (-1+ n)) (A084526 n)))) ;; A084506(130)=6 (define A084506 (compose-funs vector-length nth-successful-test-vec-3-0)) (define A084516 (compose-funs vector-length nth-successful-test-vec-3-1)) (define A084526 (compose-funs vector-length nth-successful-test-vec-3-2)) ;; Zero-based, the first occurrence of n in A0845[0-2]1: (define (A084507 n) (let loop ((i 1)) (cond ((= n (A084501 i)) i) (else (loop (1+ i)))))) (define (A084517 n) (let loop ((i 1)) (cond ((= n (A084511 i)) i) (else (loop (1+ i)))))) (define (A084527 n) (let loop ((i 1)) (cond ((= n (A084521 i)) i) (else (loop (1+ i)))))) ;; charfun-for-A084508 differs from the characteristic function of A007489 first time ;; at n=129 (where the former gets value 1, while the latter gets next time ;; value 1 at n=153.) ;; Don't submit these three, there are enough thrash in OEIS already: (definec (charfun-for-A084508 n) (- (A084506 (1+ n)) (A084506 n))) (definec (charfun-for-A084518 n) (- (A084516 (1+ n)) (A084516 n))) (definec (charfun-for-A084528 n) (- (A084526 (1+ n)) (A084526 n))) (define A084449v2 (cacfun-for-posfun A084451 0 7)) ;; See ;; http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A007489 ;; (partial sums of factorials, Sum k!, k=1..n. 0,1,3,9,33,153, ;; (map A084508 (iota 7)) --> (1 3 9 33 129 513 2049) (definec (A084508 n) (if (zero? n) n (+ (A084508 (-1+ n)) (A084509 n)))) (define A084508v2 (cacfun-for-posfun charfun-for-A084508 1 1)) (define A084518 (cacfun-for-posfun charfun-for-A084518 1 1)) (define A084528 (cacfun-for-posfun charfun-for-A084528 1 1)) ;; Is the first essentially equivalent to: 1,2, followed by: (checked upto n=8 -> 6144). ;; A002023 = 6,24,96,384,1536,6144,24576,98304,393216,1572864,6291456,... ? ;; Name: 6*4^n. ;; Yes, see Burkard Polster, The Mathematics of Juggling, Springer-Verlag, 2003, page 48. ;; (ISBN 0-387-95513-5) ;; These were not in OEIS: ;; (map A084509 (iota 8)) --> (1 2 6 24 96 384 1536 6144 24576) ;; (map A084519 (iota 7)) --> (1 1 3 13 47 173 639 2357 8695) ;; (map A084529 (iota 7)) --> (1 1 3 12 42 142 502 1702 5878) (definec (A084509 n) (if (< n 4) (! n) (* 4 (A084509 (-1+ n))))) (define (A084509v2 n) (if (= 1 n) (A084508 1) (- (A084508 n) (A084508 (-1+ n))))) (define (A084519 n) (if (= 1 n) (A084518 1) (- (A084518 n) (A084518 (-1+ n))))) (define (A084529 n) (if (= 1 n) (A084528 1) (- (A084528 n) (A084528 (-1+ n))))) ;; Maple code: ;; ;; A084509 := n -> `if`((n<4),n!,6*(4^(n-3))); ;; with(combinat); A084519 := proc(n) option remember; local c,i,k; ;; A084509(n)-add(add(mul(A084519(i),i=c),c=composition(n,k)),k=2..n); ;; end; ;; ;; Is there a simpler way to define A084519 ??? ;; See also http://www.cs.brandeis.edu/~ira/papers/enum.pdf page 8 ;; for indecomposable permutations (A003319), and their g.f.: ;; > powseries[powcreate](f(n)=n!): tpsform(f,x,8); ;; ;; 2 3 4 5 6 7 8 ;; 1 + x + 2 x + 6 x + 24 x + 120 x + 720 x + 5040 x + O(x ) ;; ;; > g := powseries[inverse](f): tpsform(g,x,8); ;; ;; 2 3 4 5 6 7 8 ;; 1 - x - x - 3 x - 13 x - 71 x - 461 x - 3447 x + O(x ) ;; ;; > ;; > powseries[powcreate](h(n)=`if`((n<4),n!,6*(4^(n-3)))): powseries[tpsform](h,x,8); ;; ;; 2 3 4 5 6 7 8 ;; 1 + x + 2 x + 6 x + 24 x + 96 x + 384 x + 1536 x + O(x ) ;; ;; > j := powseries[inverse](h): powseries[tpsform](j,x,9); ;; ;; 2 3 4 5 6 7 8 9 ;; 1 - x - x - 3 x - 13 x - 47 x - 173 x - 639 x - 2357 x + O(x ) ;; ;; > [seq(A084509(n),n=1..12)]; ;; ;; [1, 2, 6, 24, 96, 384, 1536, 6144, 24576, 98304, 393216, 1572864] ;; ;; > [seq(A084519(n),n=1..12)]; ;; ;; [1, 1, 3, 13, 47, 173, 639, 2357, 8695, 32077, 118335, 436549] ;; ;; > INVERTi([seq(A084509(n),n=1..12)]); ;; ;; [1, 1, 3, 13, 47, 173, 639, 2357, 8695, 32077, 118335, 436549] ;; ;; > INVERT([seq(A084519(n),n=1..12)]); ;; ;; [1, 2, 6, 24, 96, 384, 1536, 6144, 24576, 98304, 393216, 1572864] ;; ;; 84551 --- 84560 ;; Zero-based, the first occurrence of n in A084452 & A084458: ;; Does 2 occur ever? Start computing from n=3. Not submitted yet. ;; (define (A084552 n) (let loop ((i 1)) (cond ((= n (A084452 i)) i) (else (loop (1+ i)))))) ;; (define (A084558 n) (let loop ((i 1)) (cond ((= n (A084458 i)) i) (else (loop (1+ i)))))) ;; More to come. ;; Zero-based: (definec (! n) (if (zero? n) 1 (* n (! (-1+ n))))) ;; A000142 (definec (A007489 n) (if (zero? n) 0 (+ (! n) (A007489 (-1+ n))))) (definec (A084555 n) (if (zero? n) 0 (+ (A084556 n) (A084555 (-1+ n))))) ;; PSUM of next (definec (A084556 n) (first_pos_with_funs_val_gte A007489 n)) ;; n occurs n! times. (definec (A084557 n) (first_pos_with_funs_val_gte A084555 n)) ;; n occurs A084556(n) times ;; (equal? (map A084505 (iota0 129)) (map A084555 (iota0 129))) --> #t ;; (A084505 130) --> 605 ;; (A084555 130) --> 604 ;; (equal? (map A084500 (iota0 604)) (map A084557 (iota0 604))) --> #t ;; (A084500 605) --> 130 ;; (A084557 605) --> 131 ;; (equal? (map A084506 (iota0 130)) (map A084556 (iota0 130))) --> () ;; (A084506 130) --> 6 ;; (A084556 130) --> 5 ;; (output-check-html "C:\\matikka\\seqs\\juggling.htm" check-juggling 119 45 #f) (define check-juggling (list ;; Permutations: (list 120 1 84469 A084469 A084470) (list 120 1 84470 A084470 A084469) (list 120 1 84453 A084453 A084454) (list 120 1 84454 A084454 A084453) (list 120 1 84455 A084455 A084466 (list A084455v2)) (list 120 1 84466 A084466 A084455) (list 120 1 84459 A084459 A084460) (list 120 1 84460 A084460 A084459) (list 120 1 84461 A084461 A084462 (list A084461v2)) (list 120 1 84462 A084462 A084461) (list 120 1 84489 A084489 A084490) (list 120 1 84490 A084490 A084489) (list 120 1 84491 A084491 A084492 (list A084491v2)) (list 120 1 84492 A084492 A084491) (list 120 1 84493 A084493 A084494) (list 120 1 84494 A084494 A084493) (list 120 1 84495 A084495 A084496 (list A084495v2)) (list 120 1 84496 A084496 A084495) (list 120 1 84497 A084497 A084498) (list 120 1 84498 A084498 A084497) (list 120 1 84499 A084499 A084530 (list A084499v2)) (list 120 1 84530 A084530 A084499) ;; Other, related to A084452 & A084458: (list 15 0 84449 A084449 #f (list A084449v2)) (list 14 0 84465 A084465) (list 80 0 84450 A084450) (list 100 0 84451 A084451) (list 120 1 84452 A084452) (list 80 0 84456 A084456) (list 100 0 84457 A084457) (list 120 1 84458 A084458) (list 100 1 84463 A084463) (list 100 1 84464 A084464) (list 100 1 84467 A084467) (list 100 1 84468 A084468) ;; related to three variants of 3-ball ground-state sequences: (list 100 0 84500 A084500) (list 100 0 84510 A084510) (list 100 0 84520 A084520) (list 120 1 84501 A084501) (list 120 1 84511 A084511) (list 120 1 84521 A084521) (list 120 1 84502 A084502) (list 120 1 84512 A084512) (list 120 1 84522 A084522) (list 100 0 84503 A084503) (list 100 0 84513 A084513) (list 100 0 84523 A084523) (list 80 0 84504 A084504) (list 80 0 84514 A084514) (list 80 0 84524 A084524) (list 100 0 84505 A084505) (list 100 0 84515 A084515) (list 100 0 84525 A084525) (list 130 1 84506 A084506) (list 120 1 84516 A084516) (list 120 1 84526 A084526) (list 12 0 84507 A084507) (list 12 0 84517 A084517) (list 12 0 84527 A084527) (list 62 0 84508 A084508) (list 9 1 84518 A084518) (list 9 1 84528 A084528) (list 80 1 84509 A084509) (list 8 1 84519 A084519) (list 8 1 84529 A084529) (list 130 0 84555 A084555) (list 130 0 84556 A084556) (list 130 0 84557 A084557) ) )