;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; http://www.iki.fi/~kartturi/matikka/Schemuli/intfuns1.scm ;; ;; - Often needed integer functions. ;; ;; ;; ;; Coded by Antti Karttunen (my_firstname.my_surname@gmail.com), ;; ;; 2002-2009 ;; ;; ;; ;; This Scheme-code is in Public Domain and runs (at least) ;; ;; in MIT Scheme Release 7.6.0/7.7.?, for which one can find documents ;; ;; 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/ ;; ;; ;; ;; Last edited Jul 30 2010 by Antti Karttunen. ;; ;; ;; ;; Oct 02 2009: Changed macros MATCHING-POS, NONZERO-POS, ZERO-POS, ;; ;; DISTINCT-POS, DISTINCT-VALS, RECORD-POS, RECORDS-VALS, PARTIALSUMS ;; ;; to use TWO separate starting offsets, the other for the function to ;; ;; be defined, and the other for the function whose values are ;; ;; searched/summed for. ;; ;; ;; ;; Oct 05 2009: Changed macros LEAST-EXCEEDING-I, PSEUDOINVERSE1, ;; ;; PSEUDOINVERSE2 in similar way, to use soff1 and soff2. ;; ;; ;; ;; Refactored implement-cached-function macro out of definec, ;; ;; and used it to implement memoizing functionals ;; ;; MATCHING-POS, NONZERO-POS, ;; ;; DISTINCT-POS, DISTINCT-VALS, RECORD-POS, RECORDS-VALS, ;; ;; NUMBER-OF-CHANGES, LEAST-EXCEEDING-I, PSEUDOINVERSE1 ;; ;; PSEUDOINVERSE2 and COMPLEMENT. ;; ;; These are still first-cut, to be polished. Need better names for some.;; ;; ;; ;; Added Jan 08 2007 a few sieving functions and eigen-convolutions. ;; ;; (Operators: EIGEN-CONVOLUTION, GEN-CONVOLVE, CONVOLVE, INVERT). ;; ;; ;; ;; grep -c "^(define[c]* [(]*A[0-9][0-9][0-9][0-9][0-9][0-9] " --> 226 ;; ;; ;; ;; To do: ;; ;; ;; ;; Implement most of the transformations in ;; ;; http://www.research.att.com/~njas/sequences/transforms.txt ;; ;; ;; ;; Implement all OEIS-sequences (functions) related to the ;; ;; binary fiddling. ;; ;; All http://www.research.att.com/~njas/sequences/Sindx_Bi.html#binary ;; ;; and much more: ;; ;; A000120, A000788, A000069, A001969, A023416, A059015, A007088, A070939 ;; ;; A005536, A003159, A006995, A006364, A054868, A070940, A070941, A001511 ;; ;; A029837, A037800, A014081, A014082 ;; ;; ;; ;; Also all 156 or so "core" sequences, at least those that can be ;; ;; easily computed. (Cf. A000001), the most cross-referenced, ;; ;; etc. (Huh huh!) ;; ;; ;; ;; But first think about the appropriate presentation, with which we ;; ;; can keep more information than with just basic define and definec. ;; ;; ;; ;; E.g. the starting offset, the validity range, if the sequence ;; ;; is finite (cf. A007623), alternative versions and compositions ;; ;; (E.g. we have a _DEFINING_ definition (might be very SLOW), ;; ;; then _IMPLEMENTING_ definition (should be faster) ;; ;; and various alternative compositions and other definitions, ;; ;; that can be used for checking.) ;; ;; Also, what subset of Scheme is allowed, and what kind of operators ;; ;; (PARTIALSUMS, COMPLEMENT, INVERT, etc.) are allowed, ;; ;; so that definitions can be automatically converted to say, Python? ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Compile as: ;; ;; (cf "../Schemuli/definech" "../Schemuli/") ;; ;; (load "../Schemuli/definech") ;; ;Loading "matikka\\schemuli\\definech.com" -- done ;; ;Value: definec ;; ;; (fluid-let ((sf/default-syntax-table user-initial-environment)) ;; (cf "../Schemuli/intfuns1" "../Schemuli/") ;; ) ;; ;; From http://www.swiss.ai.mit.edu/projects/scheme/documentation/user_5.html ;; ;; If you redefine some global name in your code, for example, car, cdr ;; and cons, you should indicate it in the declaration as: ;; (declare (usual-integrations car cdr cons)) ;; (Beware of using an argument name like list in the function definitions?) (declare (usual-integrations)) (load-option 'format) ;; All macros related to caching transferred to definech.scm (define (ROWSUMS0 antidiagfun) (lambda (n) (add antidiagfun (A000217 n) (-1+ (A000217 (1+ n)))))) (define (ROWSUMS1 antidiagfun) (lambda (n) (add antidiagfun (A000124 (-1+ n)) (A000217 n)))) ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for function fun, i.e. its domain: [soff2,infinity] ;; With argument n, the defined function sums the first (n-soff1)+1 values ;; of function 'fun' in domain [soff2,soff2+1,soff2+2,...,soff2+(n-soff1)] (define (PARTIALSUMS soff1 soff2 fun) ;; soff = starting offset. (implement-cached-function 0 (partsumsfun n) (let ((coff (- soff2 soff1))) ;; Correction offset. (cond ((< n soff1) 0) ((= n soff1) (fun soff2)) (else (+ (fun (+ n coff)) (partsumsfun (-1+ n)))) ) ) ) ) ;; Original version: ;; (define (PARTIALSUMS soff fun) ;; soff = starting offset. ;; (implement-cached-function 0 (partsumsfun n) ;; (cond ((< n soff) 0) ;; ((= n soff) (fun n)) ;; (else (+ (fun n) (partsumsfun (-1+ n)))) ;; ) ;; ) ;; ) ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for pred_on_i? function, (define (MATCHING-POS soff1 soff2 pred_on_i?) (implement-cached-function 0 (tvimadur n) (let loop ((i (if (= soff1 n) soff2 (1+ (tvimadur (-1+ n)))))) (cond ((pred_on_i? i) i) (else (loop (1+ i))) ) ) ) ) ;; Original version: ;; (define (MATCHING-POS soff pred_on_i?) ;; soff = starting offset. ;; (implement-cached-function 0 (tvimadur n) ;; (let loop ((i (if (= soff n) soff (1+ (tvimadur (-1+ n)))))) ;; (cond ((pred_on_i? i) i) ;; (else (loop (1+ i))) ;; ) ;; ) ;; ) ;; ) (define (NEXT-MATCHING-POS pred_on_i?) (implement-cached-function 0 (tvimadur n) (let loop ((i (1+ n))) (cond ((pred_on_i? i) i) (else (loop (1+ i))) ) ) ) ) (define (PREV-OR-SAME-MATCHING-POS pred_on_i?) (implement-cached-function 0 (tvimadur n) (let loop ((i n)) (cond ((zero? i) i) ;; Failed? ((pred_on_i? i) i) (else (loop (-1+ i))) ) ) ) ) ;; (define-syntax define-MATCHING-POS ;; (syntax-rules () ;; ((define-MATCHING-POS soff (fun_defined n) pred_on_i?) ;; (define fun_defined ;; (implement-cached-function 0 (fun_defined n) ;; (let loop ((i (if (= soff n) soff (1+ (fun_defined (-1+ n)))))) ;; (cond ((pred_on_i? i) i) ;; (else (loop (1+ i))) ;; ) ;; ) ;; ) ;; ) ;; (define fun_defined ...) ;; ) ;; ) ;; syntax-rules ;; ) ;; ;; (define-MATCHING-POS 0 (A125975 n) (lambda (i) (= i (A125974 (A125974 i))))) ;; (define (fun-succ-matching-is0 pred_on_i?) (MATCHING-POS 0 0 pred_on_i?)) ;; Give an "extended" characteristic function of foo for this, and you get foo: ;; E.g. (define A005117 (NONZERO-POS 1 1 A008683)) ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for charfun (characteristic function) (define (NONZERO-POS soff1 soff2 charfun) (MATCHING-POS soff1 soff2 (lambda (i) (not (zero? (charfun i)))))) (define (ZERO-POS soff1 soff2 fun) (MATCHING-POS soff1 soff2 (lambda (i) (zero? (fun i))))) (define (FIXED-POINTS soff1 soff2 fun) (MATCHING-POS soff1 soff2 (lambda (i) (= i (fun i))))) ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for fun_on_i (i.e. its domain is [soff2,infinity]) (define (DISTINCT-POS soff1 soff2 fun_on_i) (implement-cached-function 0 (belgthor n) (cond ((<= n soff1) soff2) ;; Was: ((<= n soff) n) (else (let outloop ((i (1+ (belgthor (-1+ n)))) (val_here (fun_on_i (1+ (belgthor (-1+ n))))) ) (let inloop ((j (-1+ n))) ;; ((j (-1+ i))) ;; If we didn't find any j < i where fun_on_i(belgthor(j)) would have been belgthor(i), then ... (cond ((< j 0) i) ;; ... we found a new distinct value, return its pos. ((= (fun_on_i (belgthor j)) val_here) ;; This value has occurred before. (outloop (+ i 1) (fun_on_i (+ i 1))) ;; Try the next candidate. ) (else (inloop (- j 1))) ) ) ) ) ) ) ) (define (DISTINCT-VALS soff1 soff2 fun_on_i) (compose-funs fun_on_i (DISTINCT-POS soff1 soff2 fun_on_i))) ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for fun_on_i (i.e. its domain is [soff2,infinity]) (define (RECORD-POS soff1 soff2 fun_on_i) (implement-cached-function 0 (arlaug n) (cond ((<= n soff1) soff2) ;; Was: ((<= n soff) n) (else (let* ((prevrecpos (arlaug (- n 1))) (prev_record (fun_on_i prevrecpos)) ) (let loop ((i (+ 1 prevrecpos))) ;; Starting index. (cond ((> (fun_on_i i) prev_record) i) (else (loop (+ i 1))) ) ) ) ) ) ) ) (define (RECORD-VALS soff1 soff2 fun_on_i) (compose-funs fun_on_i (RECORD-POS soff1 soff2 fun_on_i))) ;; ;; (arlaug n): Find a point i between zeroposfun(n) and zeroposfun(n+1) with ;; a maximum absolute value of fun(i). ;; (define (RECORD-ABSVALS-BETWEEN-ZEROS-POS soff fun zeroposfun) ;; soff = starting offset. (implement-cached-function 0 (arlaug n) (let* ((nextzeropos (zeroposfun (1+ n)))) (let loop ((i (zeroposfun n)) ;; Starting index. (m 0) (mp (zeroposfun n)) ) (cond ((= i nextzeropos) mp) ((> (abs (fun i)) m) (loop (1+ i) (abs (fun i)) i) ) (else (loop (1+ i) m mp)) ) ) ) ) ) ;; This forms a function (cfun n), that gives the number of times the value of function foo ;; has changed from (foo i) to (foo i+1), for i=soff to n-1. ;; For genuinely monotone functions this is always A000027. (define (NUMBER-OF-CHANGES soff foo) ;; soff = starting offset. (implement-cached-function 0 (cfun n) (cond ((< n soff) 0) ;; Maybe we should raise an error instead?! ((= soff n) 1) ;; For the starting offset we return 1, as there is our first value. ((= (foo n) (foo (- n 1))) (cfun (- n 1))) ;; foo stays same, use the previous value. (else (1+ (cfun (- n 1)))) ;; Foo obtains a new value here, return one more than last time ) ) ) ;; (define (GEN_CONVOLVE soff mulfun fun1 fun2) ...) ;; (define (CONVOLVE soff fun1 fun2) ...) ;; (PARSUMS_OF_CHARFUN soff foo): ;; Returns the partial sums of the characteristic function of foo, which should be growing, ;; but not necessarily genuinely so. ;; In other words, how many distinct values function foo has obtained up to and including (foo n). ;; E.g. (define A000720 (PARSUMS_OF_CHARFUN 1 A000040)) ;; A072649 = (compose-funs -1+ (PARSUMS_OF_CHARFUN 0 A000045)) ;; With LEAST-I-WITH-FUN-I-EQ-N we don't assume that fun_on_i is monotone. ;; smallest i, such that (foo i) = n. ;; soff1 = starting offset for this function to be defined. (not used). ;; soff2 = starting offset for fun_on_i (i.e. its domain is [soff2,infinity]) (define (LEAST-I-WITH-FUN-I-EQ-N soff1 soff2 fun_on_i) ;; soff = starting offset. (implement-cached-function 0 (fun_defined n) (let loop ((i soff2)) (cond ((= (fun_on_i i) n) i) (else (loop (+ i 1))) ) ) ) ) ;; Note: With the following it is required that fun_on_i is monotone! ;; smallest i, such that (foo i) > n. ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for fun_on_i (i.e. its domain is [soff2,infinity]) (define (LEAST-EXCEEDING-I soff1 soff2 fun_on_i) ;; soff = starting offset. (implement-cached-function 0 (fun_defined n) (let loop ((i (if (= soff1 n) soff2 (fun_defined (- n 1))))) (cond ((> (fun_on_i i) n) i) (else (loop (+ i 1))) ) ) ) ) ;; smallest i, such that (foo i) >= n. ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for fun_on_i (i.e. its domain is [soff2,infinity]) (define (LEAST-GTE-I soff1 soff2 fun_on_i) ;; soff = starting offset. (implement-cached-function 0 (fun_defined n) (let loop ((i (if (= soff1 n) soff2 (fun_defined (- n 1))))) (cond ((>= (fun_on_i i) n) i) (else (loop (+ i 1))) ) ) ) ) ;; Was: ;; (define (LEAST-EXCEEDING-I soff fun_on_i) ;; soff = starting offset. ;; (implement-cached-function 0 (fun_defined n) ;; (let loop ((i (if (= soff n) n (fun_defined (- n 1))))) ;; (cond ((> (fun_on_i i) n) i) ;; (else (loop (+ i 1))) ;; ) ;; ) ;; ) ;; ) (define (first_pos_with_funs_val_gte fun n) (let loop ((i 0)) (if (>= (fun i) n) i (loop (1+ i)) ) ) ) (define (first-n-where-fun_n-is-i0 fun i) (let loop ((n 0)) (cond ((= i (fun n)) n) (else (loop (+ n 1))) ) ) ) (define (first-n-where-fun_n-is-i1 fun i) (let loop ((n 1)) (cond ((= i (fun n)) n) (else (loop (+ n 1))) ) ) ) ;; When for some i, (foo i) = n, return the smallest such i, ;; otherwise the largest i such that (foo i) < n. ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for fun_on_i (i.e. its domain is [soff2,infinity]) (define (PSEUDOINVERSE1 soff1 soff2 fun_on_i) ;; soff = starting offset. (implement-cached-function 0 (fun_defined n) (let loop ((i (if (= soff1 n) soff2 (fun_defined (- n 1))))) (cond ((= (fun_on_i i) n) i) ((> (fun_on_i i) n) (- i 1)) (else (loop (+ i 1))) ) ) ) ) ;; (define (PSEUDOINVERSE1 soff fun_on_i) ;; soff = starting offset. ;; (implement-cached-function 0 (fun_defined n) ;; (let loop ((i (if (= soff n) n (fun_defined (- n 1))))) ;; (cond ((= (fun_on_i i) n) i) ;; ((> (fun_on_i i) n) (- i 1)) ;; (else (loop (+ i 1))) ;; ) ;; ) ;; ) ;; ) ;; Returns the largest i, such that (foo i) <= n. ;; soff1 = starting offset for this function to be defined. ;; soff2 = starting offset for fun_on_i (i.e. its domain is [soff2,infinity]) (define (PSEUDOINVERSE2 soff1 soff2 fun_on_i) (compose-funs -1+ (LEAST-EXCEEDING-I soff1 soff2 fun_on_i))) ;; Not yet correct: ;; (define (PARSUMS_OF_CHARFUN soff foo) ;; soff = starting offset. ;; (implement-cached-function 0 (cfun n) ;; (cond ((< n soff) 0) ;; ((= soff n) (if (> (foo soff) soff) 0 1)) ;; (else ;; (let ((preval (cfun (- n 1)))) ;; (if (= (foo (+ 1 soff preval)) n) (+ 1 preval) preval) ;; ) ;; ) ;; ) ;; ) ;; ) ;; 0,1,2,3,4,5,6,7 , 8, ;; A000045 begins from zero as: 0,1,1,2,3,5,8,13,21,34,55,89,144,... ;; A001477: 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,... ;; Characteristic function: 1,1,1,1,0,1,0,0,1,0 ,0, 0, 0, 1, 0, 0, 0 ;; Its partial sums: 1,2,3,4,4,5,5,5,6,6, 6, 6, 6, 7, 7, 7, 7 ;; "pseudo inverse 1": 0,1,3,4,4,5,5,5,6,6, 6, 6, 6, 7, 7, 7, 7 ;; "pseudo inverse 2": 0,2,3,4,4,5,5,5,6,6, 6, 6, 6, 7, 7, 7, 7 ;; A125975 begins from zero as: 0,1,2,3,5,7,10,11,12,13,15,21,31,38,39,42,43,44,... ;; A001477: 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,... ;; Characteristic function: 1,1,1,1,0,1,0,1,0,0, 1, 1, 1, 1, 0, 1, 0, ;; Its partial sums: 1,2,3,4,4,5,5,6,6,6, 7, 8, 9,10,10,11,11, ;; "pseudo inverse": 0,1,2,3,3,4,4,5,5,5, 6, 7, 8, 9, 9,10,10,... ;; A000040 begins from one as: 2,3,5,7,11,13,17,19,23,29,31,,... ;; A000027: 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,... ;; "pseudo inverse": (A000720) 0,1,2,2,3,3,4,4,4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 8, 8, 8, ;; A000523 begins from one as: 0,1,1,2,2,2,2,3,3,3,3,3,3,3,3,4,4 ;; Characteristic function: 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,... (all-ones, A000012) ;; Its partial sums = A000027: 1,2,3,4,5,6,7,8,9,10,11,... ;; A000079 begins from zero as: 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,... ;; A001477: 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,... ;; Characteristic function: 0,1,1,0,1,0,0,0,1,0, 0, 0, 0, 0, 0, 0, 1, 0,... ;; Its partial sums: 0,1,2,2,3,3,3,3,4,4, 4, 4, 4, 4, 4, 4, 5, 5, ... ;; A000079 begins from one as: 2,4,8,16,32,64,128,256,512,1024,2048,4096,... ;; A001477: 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,... ;; Characteristic function: 0,1,0,1,0,0,0,1,0, 0, 0, 0, 0, 0, 0, 1, 0,... ;; Its partial sums: 0,1,1,2,2,2,2,3,3, 3, 3, 3, 3, 3, 3, 4, 4, ... ;; (define (PARSUMS_OF_CHARFUN soff foo) ;; soff = starting offset. ;; (implement-cached-function 0 (cfun n) ;; (cond ((< n soff) 0) ;; ((= soff n) (if (> (foo soff) soff) 0 1)) ;; (else ;; (let ((preval (cfun (- n 1)))) ;; (if (= (foo (+ 1 soff preval)) n) (+ 1 preval) preval) ;; ) ;; ) ;; ) ;; ) ;; ) ;; fun_on_i should be a monotone function, we return the v which do not occur in its range. ;; Is there a way to do this with one cached function less? (define (COMPLEMENT soff fun_on_i) ;; soff = starting offset. (let ((inv (PSEUDOINVERSE2 soff soff fun_on_i))) (MATCHING-POS soff soff (lambda (i) (let ((inv_i (inv i))) (or (< inv_i soff) (not (= i (fun_on_i inv_i)))))) ) ) ) ;; The overriding of the initial values should be implemented in implement-cached-function, ;; so that there would not be any overhead at the runtime. ;; (They would be written directly to the cache, when it is initialized!) (define (EIGEN-CONVOLUTION soffval mulfun) ;; These begin always from zero. (implement-cached-function 0 (fun_defined n) (cond ((and (integer? soffval) (= 0 n)) soffval) ((and (list? soffval) (< n (length soffval))) (list-ref soffval n)) (else (let loop ((s 0) (i 0) (j (- n 1))) (if (>= i j) (+ (* 2 s) (if (= i j) (let ((c (fun_defined i))) (mulfun c c)) 0)) (loop (+ s (mulfun (fun_defined i) (fun_defined j))) (1+ i) (-1+ j)) ) ) ) ) ) ) (define (GEN-CONVOLVE soff mulfun fun1 fun2) (implement-cached-function 0 (fun_defined n) (let loop ((s 0) (i soff) (j n)) (if (< j soff) s (loop (+ s (mulfun (fun1 i) (fun2 j))) (1+ i) (-1+ j)) ) ) ) ) (define (CONVOLVE soff fun1 fun2) (GEN-CONVOLVE soff * fun1 fun2)) ;; Didn't realize that it is this easy. See Joshua Zucker's mail ;; "Re: [SeqFan]: Repeated iterations of INVERT starting from A019590 ?" ;; on SeqFan-mailing list, Jun 7, 2006 6:46 PM (define (INVERT fun) ;; Always one-based! (implement-cached-function 0 (fun_defined n) (+ (fun n) ;; The whole space can be filled by (fun n) objects of size n. (let loop ((s 0) (i 1) (j (- n 1))) ;; In how many ways smaller parts can be filled? (if (< j 1) s (loop (+ s (* (fun_defined i) (fun j))) (1+ i) (-1+ j)) ) ) ) ) ) (definec (add1 n) (1+ n)) ;; Our cached version. (definec (rowfun_n_for_Esieve n) ;; (if (= 1 n) add1 ;; We return +1 function, that gives 2,3,4,5,6,7,8,9,10,11,... (let* ((prevrowfun (rowfun_n_for_Esieve (- n 1))) (prevprime (prevrowfun 1)) ) (compose-funs prevrowfun (NONZERO-POS 1 1 (lambda (i) (modulo (prevrowfun i) prevprime)))) ) ) ) ;; Row 1 = 2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,... ;; Row 2 = 3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,... ;; Row 3 = 5,7,11,13,17,19,23,25,29,31,35,37,41,43,47,49,53 ;; Row 4 = 7,11,13,17,19,23,29,31,41,43,47,49,53,... (definec (A000040 n) ((rowfun_n_for_Esieve n) 1)) (define A000720 (PSEUDOINVERSE2 1 1 A000040)) (define A018252 (COMPLEMENT 1 A000040)) ;; 1 and composites. (define A002808 (compose-funs A018252 1+)) ;; Composites. (define Anew_primes_and_composited_convolved (CONVOLVE 1 A000040 A002808)) ;; Noise? (define Anew_primes_and_nonprimes_convolved (CONVOLVE 1 A000040 A018252)) ;; More of the same, noise? ;; In real life we would implement A010051 with some probabilistic or deterministic ;; primeness function, and then have: ;; (define A000040 (NONZERO-POS 1 1 A010051)) ;; and ;; (define A000720 (PARTIALSUMS 1 1 A010051)) ;; ;; (possibly with some clever optimization traversing only 6n+1 and 6n+5, etc. ;; also caching a lots of smaller terms). (define A007504 (PARTIALSUMS 1 1 A000040)) ;; A083375 n appears prime(n) times. (define A083375 (LEAST-GTE-I 1 1 A007504)) (definec (A165569 n) (if (= 1 n) 1 (let* ((i (A165569 (-1+ n))) (champion (abs (- *Phi* (/ (A108539 i) (A000040 i))))) ) (let loop ((i (1+ i))) (cond ((< (abs (- *Phi* (/ (A108539 i) (A000040 i)))) champion) i ;; Found a better specimen than the current champion. ) (else (loop (1+ i))) ) ) ) ) ) ;; Compute these sieve arrays as A-entries, and also similar tables as Yasutoshi's A083140. (define (Esievebi col row) ((rowfun_n_for_Esieve row) col)) (definec (rowfun_n_for_A083221 n) ;; (if (= 1 n) A005843 ;; We return even numbers as the first row. (let ((rowfun_of_esieve (rowfun_n_for_Esieve n)) (prime (A000040 n)) ) (compose-funs rowfun_of_esieve (MATCHING-POS 1 1 (lambda (i) (zero? (modulo (rowfun_of_esieve i) prime)))) ) ) ) ) (define (A083221bi col row) ((rowfun_n_for_A083221 row) col)) (define (A083221 n) (A083221bi (1+ (A025581 (-1+ n))) (1+ (A002262 (-1+ n))))) (define (A083140 n) (A083221bi (1+ (A002262 (-1+ n))) (1+ (A025581 (-1+ n))))) ;; Analogous tables for A000959 and A003309 should be permutations of natural numbers >= 1. ;; See also Y. Motohashi, "An Overview of the Sieve Method and its History" ;; http://arxiv.org/abs/math.NT/0505521 ;; Similarly, implement rowfun_n_for_A014580, provided there is an easily ;; implementable Euclidean algorithm for GCD's of GF(2)[X] polynomials. (definec (A005408shifted n) (- (* 2 n) 1)) ;; Cached variant of odd numbers, one-based. (define A001651c (compose-funs (NONZERO-POS 1 1 (lambda (i) (modulo i 3))) 1+)) ;; Zero-based in OEIS. (define (A001651 n) (if (even? n) (+ 1 (* 3 (/ n 2))) (- (* 3 (/ (+ n 1) 2)) 1))) ;; Lucky numbers: ;; A000959 = 1,3,7,9,13,15,21,25,31,33,37,43,49,51,63,67,69,73,75,79,87,93,99, ;; Delete every 2nd number (of naturals), ;; leaving 1 3 5 7 ...; ;; the 2nd number remaining is 3, so delete every 3rd number, ;; leaving 1 3 7 9 13 15 ...; ;; now delete every 7th number, ;; leaving 1 3 7 9 13 ...; ;; now delete every 9th number; etc. (definec (rowfun_n_for_A000959sieve n) ;; (if (= 1 n) A005408shifted ;; Else, remove every (prevrowfun n):th number from the previous row. (let* ((prevrowfun (rowfun_n_for_A000959sieve (- n 1))) (everynth (prevrowfun n)) ;; to be removed. ) (compose-funs prevrowfun (NONZERO-POS 1 1 (lambda (i) (modulo i everynth)))) ) ) ) (definec (A000959 n) ((rowfun_n_for_A000959sieve n) n)) (define A050505 (COMPLEMENT 1 A000959)) ;; Unlucky numbers. (define A109497 (PSEUDOINVERSE2 1 1 A000959)) ;; Ludic numbers: ;; A003309 = 2,3,5,7,11,13,17,23,25,29,37,41,43,47,53,61,67,71,77,83,89,91,97, ;; Ludic numbers: apply the same sieve as Eratosthenes, but cross off every k-th /remaining/ number. ;; Row 1 = 2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,... ;; Row 2 = 3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,... ;; Row 3 = 5,7,11,13,17,19,23,25,29,31,35,37,41,... ;; Row 4 = 7,11,13,17,23,25,29,31,37,41,... (definec (rowfun_n_for_A003309sieve n) ;; (if (= 1 n) add1 ;; We return +1 function, that gives 2,3,4,5,6,7,8,9,10,11,... (let* ((prevrowfun (rowfun_n_for_A003309sieve (- n 1))) (everynth (prevrowfun 1)) ) (compose-funs prevrowfun (NONZERO-POS 1 1 (lambda (i) (modulo (- i 1) everynth)))) ) ) ) (definec (A003309 n) (if (= 1 n) 1 ((rowfun_n_for_A003309sieve (- n 1)) 1))) (define Anew_unludic_numbers (COMPLEMENT 1 A003309)) ;; Unludic numbers. (define Anew_num_of_ludic_numbers (PSEUDOINVERSE2 1 1 A003309)) ;; Number of ludic numbers <= n. (define (Anew_joku1 n) (- (A003309 (+ n 1)) (A000040 n))) ;; Is it always positive?! One-based. Cf. A032600. (define (Anew_joku2 n) (/ (Anew_joku1 n) 2)) (define (A032600 n) (- (A000959 n) (A000040 n))) ;; halved versions not in OEIS. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define *Sqrt5* (sqrt 5)) (define *Phi* (/ (1+ *Sqrt5*) 2)) (define *LogPhi* (log *Phi*)) (define (sgn n) (cond ((zero? n) 0) ((< n 0) -1) (else 1))) (define (A000004 n) (- n n)) (define (A000012 n) (1+ (- n n))) (define (fix:jacobi-symbol p q) (if (not (and (fix:fixnum? p) (fix:fixnum? q) (fix:= 1 (fix:and q 1)))) (error "fix:jacobi-symbol: args must be fixnums, and 2. arg should be odd: " p q ) (let loop ((p p) (q q) (s 0)) ;; 0 in bit-1 stands for +1, 1 in bit-1 for -1. (cond ((fix:zero? p) 0) ((fix:= 1 p) (fix:- 1 (fix:and s 2))) ((fix:= 1 (fix:and p 1)) ;; Odd p ? (loop (fix:remainder q p) p (fix:xor s (fix:and p q))) ) (else ;; It's even, get rid of one 2: (loop (fix:lsh p -1) q (fix:xor s (fix:xor q (fix:lsh q -1)))) ) ) ) ) ) ;; Here's our C-version. The teaching: Never implement mathematician's ;; or logician's elegant formulae directly, without thinking! ;; Working in GF(2) with XOR & AND is much more natural for ;; computers than working in isomorphic multiplicative group of {+1, -1} ;; with MUL. ;; We also convert the recursion in our formula to a simple loop. ;; q should be always odd! ;; ;; int js_ULI(ULI p,ULI q) ;; { ;; int s = 0; /* 0 in bit-1 stands for +1, 1 in bit-1 for -1. */ ;; ULI new_p; ;; loop: ;; if(0 == p) { return(p); } ;; if(1 == p) { return(1-(s&2)); } /* Convert 1 in bit-1 to -1, 0 to +1. */ ;; ;; if(p&1) /* We have an odd p. */ ;; { ;; /* If both p & q are 3 mod 4, then sign changes, otherwise stays same: */ ;; s ^= (p&q); /* Only the bit-1 is significant, others are ignored. */ ;; new_p = q % p; /* Could we have a simple - here as with Euclid? */ ;; q = p; ;; p = new_p; ;; goto loop; ;; } ;; else /* We have an even p. So (2k/q) = (2/q)*(k/q) */ ;; { /* where (2/q) = 1 if q is +-1 mod 8 and -1 if q is +-3 mod 8. */ ;; /* I.e. sign changes only if q's lower bits are (011) or (101), ;; i.e. if the bit-1 and bit-2 xored yield 1. */ ;; s ^= (q^(q>>1)); /* Thus, this does it. */ ;; p >>= 1; ;; goto loop; ;; } ;; } ;; (define fix:legendre-symbol fix:jacobi-symbol) (define jacobi-symbol fix:jacobi-symbol) (define legendre-symbol fix:legendre-symbol) ;; Useful. (define (ratio->float-str x y prec) (if (or (zero? x) (zero? y)) (if (equal? x y) "1" "0") (fluid-let ((flonum-unparser-cutoff (list 'absolute prec))) (string-append (if (< x y) "0" "") (number->string (exact->inexact (/ x y))) ) ) ) ) ;; A007918 Least prime >= n (version 1 of the "next prime" function). ;; (Offset 0) ;; 2,2,2,3,5,5,7,7,11,11,11,11,13,13,17,17,17,17,19,19,23,23,23,23,29,29,29, ;; A151800 Least prime > n (version 2 of the "next prime" function). ;; 2,2,3,5,5,7,7,11,11,11,11,13,13,17,17,17,17,19,19,23,23,23,23,29,29,29,29, ;; (Offset 0) ;; A007917 Version 1 of the "previous prime" function: largest prime <= n. ;; (Offset 2) ;; 2,3,3,5,5,7,7,7,7,11,11,13,13,13,13,17,17,19,19,19,19,23,23,23,23,23,23, ;; A151799 Version 2 of the "previous prime" function: largest prime < n. ;; (Offset 3) ;; 2,3,3,5,5,7,7,7,7,11,11,13,13,13,13,17,17,19,19,19,19,23,23,23,23,23,23, ;; A108539 Prime p such that p/prime(n) is nearest to phi, the golden ratio. ;; Note: A010051 is in module GF2Xfuns.scm/com in this same directory. (define A151800 (NEXT-MATCHING-POS (lambda (i) (= 1 (A010051 i))))) (define A007917 (PREV-OR-SAME-MATCHING-POS (lambda (i) (= 1 (A010051 i))))) (definec (A108539 n) (let* ((p1 (A000040 n)) (n2 (A000201 p1)) (q1 (A151800 n2)) (q2 (A007917 n2)) ) (if (< (abs (- *Phi* (/ q1 p1))) (abs (- *Phi* (/ q2 p1)))) q1 q2 ) ) ) (definec (fibo nakki) ;; I.e., A000045 (if (< nakki 2) nakki (+ (fibo (-1+ nakki)) (fibo (- nakki 2))) ) ) (define A000045 fibo) (define (A001906 n) (A000045 (A005843 n))) (define (A122367 n) (A000045 (A005408 n))) (define (A027941 n) (-1+ (A122367 n))) (define (A000201 n) (floor->exact (* n *Phi*))) (define (A004956 n) (ceiling->exact (* n *Phi*))) (define (A007067 n) (round->exact (* n *Phi*))) (define (A005408 n) (+ (* 2 n) 1)) (define (A004767 n) (+ (* 4 n) 3)) (define (A016813 n) (+ (* 4 n) 1)) (definec (A016813c n) (+ (* 4 n) 1)) ;; Cached version for debugging. (define (A017557 n) (+ (* 12 n) 3)) (define (A017605 n) (+ (* 12 n) 7)) (define (A019590 n) (if (< n 3) 1 0)) (define A000045_shifted_left (INVERT A019590)) ;; Factorial with syntax modified from the post-fix to pre-fix !: (definec (! n) (if (zero? n) 1 (* n (! (-1+ n))))) ;; A000142 (define A000142 !) (define (!cut i j) ;; Compute the product i*(i+1)*(i+2)*...*j (cond ((eq? i j) i) ((> i j) 1) (else (* i (!cut (1+ i) j))) ) ) ;; (C r n) stands for the binomial {r choose n} (define (A007318tr r n) (/ (!cut (1+ n) r) (! (- r n)))) (define C A007318tr) (define A000108 (EIGEN-CONVOLUTION 1 *)) (define A000108one_based (INVERT (compose-funs A000108 -1+))) (define (A007318 n) (C (A003056 n) (A002262 n))) (definec (A000984 n) (/ (! (* 2 n)) (expt (! n) 2))) ;; Central binomial coefficients: C(2n,n) = (2n)!/(n!)^2. (definec (binomial_n_2 n) (/ (* (-1+ n) n) 2)) ;; A000217 = LEFT(binomial_n_2) (define A003989bi gcd) (define A003990bi lcm) (define (A003989 n) (A003989bi (1+ (A002262 n)) (1+ (A025581 n)))) (define (A003990 n) (A003990bi (1+ (A002262 n)) (1+ (A025581 n)))) (define (obtain-integer-bitwise-function bit-string-FUN) (lambda (x y) (let ((size (max (binwidth x) (binwidth y)))) (bit-string->unsigned-integer (bit-string-FUN (unsigned-integer->bit-string size x) (unsigned-integer->bit-string size y) ) ) ) ) ) (define A003986bi (obtain-integer-bitwise-function bit-string-or)) (define A003987bi (obtain-integer-bitwise-function bit-string-xor)) (define A004198bi (obtain-integer-bitwise-function bit-string-and)) (definec (nth-row-of-A047999 n) (cond ((zero? n) (unsigned-integer->bit-string 1 1)) (else (next-row-of-A047999 (nth-row-of-A047999 (-1+ n)))) ) ) (define (next-row-of-A047999 gen) (let ((one-zero (make-bit-string 1 #f))) (bit-string-xor (bit-string-append gen one-zero) (bit-string-append one-zero gen) ) ) ) (define (A001317 n) (bit-string->unsigned-integer (nth-row-of-A047999 n))) (definec (nth-gen-of-rule90 n) (cond ((zero? n) (unsigned-integer->bit-string 1 1)) (else (next-rule90-gen (nth-gen-of-rule90 (-1+ n)))) ) ) (define (next-rule90-gen gen) (let ((two-zeros (make-bit-string 2 #f))) (bit-string-xor (bit-string-append gen two-zeros) (bit-string-append two-zeros gen) ) ) ) (define (A038183 n) (bit-string->unsigned-integer (nth-gen-of-rule90 n))) (define (A038183v2 n) (A001317 (* 2 n))) (define (bit-i n i) (modulo (floor->exact (/ n (expt 2 i))) 2)) (define (factbaseR->n rex) ;; Convert the reversed factorial expansion list to an integer. (let loop ((rex rex) (n 0) (i 1)) (cond ((null? rex) n) (else (loop (cdr rex) (+ n (* (! i) (car rex))) (1+ i))) ) ) ) (define (n->factbase n) ;; Convert an integer to a factorial expansion list. (let loop ((n n) (fex (if (zero? n) (list 0) (list))) (i 2)) (cond ((zero? n) fex) (else (loop (floor->exact (/ n i)) (cons (modulo n i) fex) (1+ i))) ) ) ) (define (A099563 n) (car (n->factbase n))) (define (baselist->n base bex) ;; Convert base n expansion list to an integer. (let loop ((bex bex) (n 0)) (cond ((null? bex) n) (else (loop (cdr bex) (+ (* n base) (car bex)))) ) ) ) (define (baselist-as-binary lista) (baselist->n 2 lista)) (define (baselist-as-ternary lista) (baselist->n 3 lista)) (define (baselist-as-decimal lista) (baselist->n 10 lista)) ;; Note: A link from A007623 to A060130 is completely off the wall! (Really?) ;; This is of the limited usability: (define (A007623 n) (baselist-as-decimal (n->factbase n))) (define (A034968 n) (let loop ((n n) (i 2) (s 0)) (cond ((zero? n) s) (else (loop (quotient n i) (1+ i) (+ s (remainder n i)) ) ) ) ) ) ;; %N A060130 Minimum number of transpositions needed to compose each ;; permutation in the lists A060117/A060118; number of nonzero digits ;; in factorial base representation (A007623) of n. (define (A060130 n) (let loop ((n n) (i 2) (s 0)) (cond ((zero? n) s) (else (loop (quotient n i) (1+ i) (+ s (if (zero? (remainder n i)) 0 1)) ) ) ) ) ) (define (permute-A060118 elems size permrank) (let ((p (vector-head elems size))) (let unrankA060118 ((r permrank) (i 1) ) (cond ((zero? r) p) (else (let* ((j (1+ i)) (m (modulo r j)) ) (cond ((not (zero? m)) ;; Swap at i and (i-(r mod (i+1))) (let ((org-i (vector-ref p i))) (vector-set! p i (vector-ref p (- i m))) (vector-set! p (- i m) org-i) ) ) ) (unrankA060118 (/ (- r m) j) j) ) ) ) ) ) ) (define (avg lista) (/ (reduce + 0 lista) (length lista))) (define Ajoku1 (MATCHING-POS 0 0 (lambda (i) (integer? (avg (n->factbase i)))))) (define Ajoku2 (MATCHING-POS 0 0 (lambda (i) (let* ((fex (n->factbase i)) (m (avg fex)) ) (and (integer? m) (gs2gs? (list->vector fex) m 0)) ) ) ) ) (define Ajoku3 (MATCHING-POS 0 0 (lambda (i) (integer? (avg (n->factbase (A000290 i))))))) (define Ajoku4 (MATCHING-POS 0 0 (lambda (i) (= 1 (avg (n->factbase (A000290 i))))))) (define Ajoku5 (MATCHING-POS 0 0 (lambda (i) (= 2 (avg (n->factbase (A000290 i))))))) (define Ajoku6 (MATCHING-POS 0 0 (lambda (i) (= 3 (avg (n->factbase (A000290 i))))))) ;; (map Ajoku7 (iota0 6)) --> (0 1 26 195 4666 19888 780568) (definec (Ajoku7 n) (first-n-where-fun_n-is-i0 (lambda (i) (avg (n->factbase (A000290 i)))) n)) ;; A127230 ??? (definec (Ajoku0 n) (first-n-where-fun_n-is-i0 (lambda (i) (avg (n->factbase i))) n)) (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 ) ) ;; Shift factorial expansion of n one digit left: (define (A153880 n) (let loop ((n n) (z 0) (i 2) (f 2)) (cond ((zero? n) z) (else (loop (quotient n i) (+ (* f (remainder n i)) z) (1+ i) (* f (+ i 1)) ) ) ) ) ) ;; And the same halved: (define (A153883 n) (/ (A153880 n) 2)) (define (A001563 n) (* n (! (1+ n)))) ;; First differences of A000142. ;; From juggling.scm, all zero-based: (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 (definec (A084558 n) (cond ((zero? n) 0) (else (length (n->factbase n))))) ;; After 0, which occurs once, each n occurs A001563(n) times (definec (A084519 n) (cond ((< n 3) 1) ((= n 3) 3) (else (+ (* 3 (A084519 (- n 1))) (* 2 (A084519 (- n 2))) (* 2 (A084519 (- n 3))))) ) ) (definec (A084509 n) (if (< n 4) (! n) (* 4 (A084509 (-1+ n))))) (define A084509v2 (INVERT A084519)) (define (shr n) (if (odd? n) (/ (- n 1) 2) (/ n 2))) (define (>> n i) (if (zero? i) n (>> (floor->exact (/ n 2)) (- i 1)))) (define (<< n i) (if (<= i 0) (>> n (- i)) (<< (+ n n) (- i 1)))) (define (A005843 n) (* 2 n)) (define (A008585 n) (* 3 n)) (define (A008586 n) (* 4 n)) (define (A008587 n) (* 5 n)) (define (A008588 n) (* 6 n)) (define (A008589 n) (* 7 n)) (define (A008590 n) (* 8 n)) (define (A008591 n) (* 9 n)) (define (A008598 n) (* 16 n)) (define (A016777 n) (1+ (* 3 n))) (define (A016789 n) (+ 2 (* 3 n))) (define (A004526 n) (floor->exact (/ n 2))) (define (A002264 n) (floor->exact (/ n 3))) (define (A102283 n) (- (A000035 (A010872 n)) (A004526 (A010872 n)))) ;; Period 3: repeat (0,1,-1). (define (A000035 n) (modulo n 2)) (define (A010872 n) (modulo n 3)) (define (A010873 n) (modulo n 4)) (define halve A004526) (define double A005843) (define lsb A000035) (define (A000079 n) (expt 2 n)) ;; Note for n > 0, (floor-log-2 n) = (- (binwidth n) 1) (define (binwidth n) ;; = A029837(n+1) (let loop ((n n) (i 0)) (if (zero? n) i (loop (floor->exact (/ n 2)) (1+ i)) ) ) ) ;; This doesn't seem to work for numbers > 1023 bits: (define (A000523faster n) (cond ((zero? n) -1) (else (floor->exact (/ (log n) (log 2)))))) ;; Have to do it with a reliable loop! (define (A000523 n) (-1+ (binwidth n))) (define floor-log-2 A000523) ;; An old alias. (define (A052928 n) (+ n (- (modulo n 2)))) (define (A016116 n) (expt 2 (floor->exact (/ n 2)))) ;; 1,1,1,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,... (define (A081604 n) ;; Except we have a(0)=0, not 1, as in OEIS! (let loop ((n n) (i 0)) (if (zero? n) i (loop (floor->exact (/ n 3)) (1+ i)) ) ) ) ;; 0,0,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3, (define (A062153 n) (- (A081604 n) 1)) ;; Floor [ log_3(n) ]. One-based. (define (A053644 n) (if (zero? n) n (expt 2 (A000523 n)))) ;; (define (A053645 n) (- n (expt 2 (A000523 n)))) (define (A053645 n) (cond ((zero? n) n) (else (- n (expt 2 (A000523 n)))))) ;; One-based. (define (A006257 n) (if (zero? n) 0 (A005408 (A053645 n)))) (define (A004760 n) (if (zero? n) 0 (- (A008585 n) 2 (A006257 (-1+ n))))) (define (A004754 n) (+ n (A053644 n))) (define (A004758 n) (+ n (* 5 (expt 2 (A000523 n))))) (define (A072376 n) (if (< n 2) n (/ (A053644 n) 2))) (define (A003817 n) (if (zero? n) n (-1+ (A005843 (A053644 n))))) (definec (A003817v2 n) (if (zero? n) n (A003986bi (A003817v2 (-1+ n)) n))) (define (A062383 n) (1+ (A003817 n))) ;; A065120 Highest power of 2 dividing A057335(n). ;; 0,1,2,1,3,2,1,1,4,3,2,2,1,1,1,1,5,4,3,3,2,2,2,2,1,1,1,1,1,1,1,1,6,... (define (A065120 n) (if (zero? n) n (1+ (length-of-zero-bit-run-before-msb n)))) ;; Brute and dumb: (define (length-of-zero-bit-run-before-msb n) (let loop ((i 0) (maskbit (A072376 n))) (if (or (zero? maskbit) (not (zero? (modulo (floor->exact (/ n maskbit)) 2))) ) i (loop (1+ i) (floor->exact (/ maskbit 2))) ) ) ) (define (A000120 n) (let loop ((n n) (i 0)) (if (zero? n) i (loop (floor->exact (/ n 2)) (+ i (modulo n 2))) ) ) ) ;; f(z) = 2z if z>0 else 2|z|+1 (define (Z->N n) (if (positive? n) (* n 2) (+ 1 (* 2 (- n))))) ;; g(n) = n/2 if n even, else (1-n)/2. (define (N->Z n) (if (even? n) (/ n 2) (/ (- 1 n) 2))) (define (A001057 n) (N->Z (+ 1 n))) ;; Zero-based version of N->Z (define (A033999 n) (expt -1 n)) ;; A033999 := n->(-1)^n; (define (A010060 n) (modulo (A000120 n) 2)) (define (A010059 n) (- 1 (A010060 n))) (define (A007895 n) (A000120 (A003714 n))) ;; Number of 1-fibits in Z.E. (define (A095076 n) (A010060 (A003714 n))) ;; Parity of 1-fibits in Z.E. (define (A095111 n) (- 1 (A095076 n))) ;; Its complement. (define (A002450 n) (/ (- (expt 4 n) 1) 3)) (define (A020988 n) (* 2 (A002450 (+ n 1)))) (define (A028552 n) (* n (+ n 3))) (define (A028387 n) (1+ (A028552 n))) (define (A028347 n) (- (* n n) 4)) ;; n^2 - 4. From n=2: 0, 5, 12, 21, ... (define (A028875 n) (- (* n n) 5)) ;; n^2 - 5. From n=3: 4,11,20,31,... (define (A028884 n) (- (* n n) 8)) ;; n^2 - 8. From n=3: 1,8,17,28,41,... (define (A072197 n) (/ (- (* 10 (expt 4 n)) 1) 3)) ;; I trust Bottomley's formula. (define (A072197v2 n) (+ 3 (* 10 (A002450 n)))) (define (A080675 n) (/ (- (* 5 (expt 4 n)) 8) 6)) ;; Of course many of these (especially those that occur as columns of ;; Wythoff array, A035513) have elegant formulae as well. ;; See the corresponding entries in OEIS. Here I just wanted ;; to be thorough and systematic: (definec (A095096 n) ;; fibevil numbers, complement of A020899. (cond ((= 0 n) 0) ;; 0 is the first fibevil number. (else (let loop ((i (+ 1 (A095096 (- n 1))))) (cond ((= 0 (A095076 i)) i) ;; parity of 1-fibits is even? (else (loop (+ 1 i))) ;; Try the next one then. ) ) ) ) ) (definec (A020899 n) ;; fibodious numbers (cond ((= 0 n) 1) ;; 1 is the first fibodious number. (else (let loop ((i (+ 1 (A020899 (- n 1))))) (cond ((= 1 (A095076 i)) i) ;; parity of 1-fibits is odd? (else (loop (+ 1 i))) ;; Try the next one then. ) ) ) ) ) (definec (A026274 n) ;; fib00 numbers. Check this! (cond ((= 0 n) 3) ;; 3 is the first member. it's z.e. being 100. (else (let loop ((i (+ 1 (A026274 (- n 1))))) (cond ((= 0 (modulo (A003714 i) 4)) i) ;; z.e. ends as ...00 ? (else (loop (+ 1 i))) ;; Try next one then. ) ) ) ) ) (definec (A095097 n) ;; fib000 numbers. (cond ((= 0 n) 5) ;; 5 is the first member, it's z.e. being 1000. (else (let loop ((i (+ 1 (A095097 (- n 1))))) (cond ((= 0 (modulo (A003714 i) 8)) i) ;; z.e. ends as ...000 ? (else (loop (+ 1 i))) ;; Try next one then. ) ) ) ) ) (definec (A095098 n) ;; fib001 numbers. (cond ((= 0 n) 1) ;; 1 is the first member, it's z.e. being 1. (else (let loop ((i (+ 1 (A095098 (- n 1))))) (cond ((= 1 (modulo (A003714 i) 8)) i) ;; z.e. ends as ...001 ? (else (loop (+ 1 i))) ;; Try next one then. ) ) ) ) ) (definec (A035336 n) ;; fib010 numbers, second column of Wythoff array. (cond ((= 0 n) 2) ;; 2 is the first member, it's z.e. being 10. (else (let loop ((i (+ 1 (A035336 (- n 1))))) (cond ((= 2 (modulo (A003714 i) 8)) i) ;; z.e. ends as ...010 ? (else (loop (+ 1 i))) ;; Try next one then. ) ) ) ) ) (definec (A035337 n) ;; fib100 numbers, third column of Wythoff array. (cond ((= 0 n) 3) ;; 3 is the first member. it's z.e. being 100. (else (let loop ((i (+ 1 (A035337 (- n 1))))) (cond ((= 4 (modulo (A003714 i) 8)) i) ;; z.e. ends as ...100 ? (else (loop (+ 1 i))) ;; Try next one then. ) ) ) ) ) (definec (A095099 n) ;; fib101 numbers. (cond ((= 0 n) 4) ;; 4 is the first member. it's z.e. being 101. (else (let loop ((i (+ 1 (A095099 (- n 1))))) (cond ((= 5 (modulo (A003714 i) 8)) i) ;; z.e. ends as ...101 ? (else (loop (+ 1 i))) ;; Try next one then. ) ) ) ) ) (define (A029837 n) (cond ((< n 1) (error "A029837 supplied with argument less than one: " n)) (else (binwidth (-1+ n))) ) ) (definec (A030101 nn) ;; Was: binrev (let loop ((z 0) (n nn)) (if (zero? n) z (loop (+ (* 2 z) (modulo n 2)) (floor->exact (/ n 2)) ;; Doesn't work when n is big enough: (fix:lsh n -1) ;; n >>= 1 ) ) ) ) (definec (A035327 n) (- (-1+ (expt 2 (binwidth n))) n)) ;; Complement the binary exp. (definec (A036044 n) ;; i.e. binrevcompl, differs from EIS-seq as a(0)=0, not 1. (let loop ((z 0) (n n)) (if (zero? n) z (loop (+ (* 2 z) (- 1 (modulo n 2))) (floor->exact (/ n 2)) ;; (fix:lsh n -1) ;; n >>= 1 ) ) ) ) ;; Note that ;; (fetch-from-bits-of-n-given-by-column-x-of-table ;; (store-n-to-bits-given-by-column-x-of-table n col some-NxN->N-map) ;; col some-NxN->N-map) ;; is an identity function on n, with all values of col >= 0. ;; Corresponds to *A057163 (define (A054429 n) ;; -> (0),1,3,2,7,6,5,4,15,14,13,12,11,10,9,8,31,30,... (if (zero? n) n (-1+ (- (* 3 (expt 2 (A000523 n))) n)) ) ) ;; Corresponds to *A069770 ;; A063946 Write n in binary and complement second bit (from the left), with a(0)=0 and a(1)=1. ;; if(n<2, n>0, 3/2*2^floor(log(n)/log(2))-2^floor(log(4/3*n)/log(2))+n) (from R. Stephan) (define (A063946 n) ;; -> (0),1,3,2,6,7,4,5,12,13,14,15,8,9,10,11,24,25,26,... (if (< n 2) n (let ((sm (A072376 n))) (+ n (* sm (- 1 (* 2 (modulo (floor->exact (/ n sm)) 2))))) ) ) ) (definec (A059893 n) (if (<= n 1) n (let* ((k (- (A000523 n) 1)) (r (A059893 (- n (A000079 k))))) (if (= 2 (floor->exact (/ n (A000079 k)))) (* 2 r) (+ 1 r) ) ) ) ) (define A059894 (compose-funs A054429 A059893)) ;; A065190 = A059893 o A063946 o A059893 (define (A065190 n) (if (< n 2) n (+ n (expt -1 n)))) (define (A056539 n) (if (odd? n) (A030101 n) (A036044 n))) ;; There exists similar rotate & deep rotate variants of this same idea. (define (A056539v2 n) (runcount1list->binexp (reverse! (binexp->runcount1list n)))) ;; How to prove that this is an involution? ;; By (strong) induction, or by simpler means? ;; (E.g. if a Life pattern is symmetric, it just cannot ;; but stay symmetric ever after.) (definec (A105726 n) (cond ((< n 2) n) (else (runcount1list->binexp (map A105726 (reverse! (binexp->runcount1list n))))) ) ) (definec (A001477yet_another_variant n) (cond ((< n 2) n) (else (runcount1list->binexp (map A001477yet_another_variant (binexp->runcount1list n)))) ) ) ;; This one by Leroy Quet, Oct 08 2009: ;; a(9)=27, because (binexp->runcount1list 9)=(1 2 1), so replacing ;; run of 1 ones with run of 2 ones, run of 2 0's with run of 1 0's ;; and finally run of 1 ones with run of 2 ones, thus we get 11011 = 27. ;; a(11)=25 because (binexp->runcount1list 11)=(1 1 2) (1011), so ;; replacing run of 1 ones with run of 2 ones, run of 1 0's with run ;; of 2 zeros, and run of 2 ones with run of 1 ones, we get 11001 = 25. (definec (A166166 n) (let* ((runlens (binexp->runcount1list n)) (rlsorted (uniq (sort runlens <))) (lenrls (length rlsorted)) ) (let loop ((rl runlens) (s 0) (b 1)) (cond ((null? rl) s) (else (let* ((nrl (list-ref rlsorted (- lenrls 1 (nthmemq (car rl) rlsorted)) ) ) (p2 (expt 2 nrl)) ) (loop (cdr rl) (+ (* s p2) (* b (-1+ p2))) (- 1 b)) ) ) ) ) ) ) (define (interleave a b) (let loop ((z (list)) (a a) (b b)) (cond ((and (null? a) (null? b)) (reverse! z)) ((null? a) (loop (cons (car b) z) a (cdr b))) ((null? b) (loop (cons (car a) z) (cdr a) b)) (else (loop (cons (car b) (cons (car a) z)) (cdr a) (cdr b))) ) ) ) ;; Cf. A056539 (definec (A166404 n) ;; begins as 0,1,2,3,6,5,4,7,14,13,10,11,12,9,8,15,30,29,26,27,22,21,20,23,28,25,... (let ((runlens (binexp->runcount1list n))) (runcount1list->binexp (interleave (bisect runlens 1) (bisect runlens 0))) ) ) ;; Not an involution like the previous one: (define (Ajoku2 n) ;; begins as 1,2,3,4,5,6,7,8,11,10,9,12,13,14,15,16,23,22,19,20,21 (let ((runlens (binexp->runcount1list n))) (runcount1list->binexp (append (bisect runlens 0) (bisect runlens 1))) ) ) ;; Also by Leroy Quet. I want to compute the b-file. ;; a(0)=0, a(1)=1, a(2)=2. For n>=3, a(n) = a(n-1) - min(a(n-2),a(n-3)). (definec (A163495 n) (if (< n 3) n (- (A163495 (-1+ n)) (min (A163495 (- n 2)) (A163495 (- n 3)))) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (definec (on-bit-indices n) (let loop ((n n) (i 0) (c (list)) ) (cond ((zero? n) (reverse! c)) ((odd? n) (loop (/ (- n 1) 2) (+ 1 i) (cons i c))) (else (loop (/ n 2) (+ 1 i) c)) ) ) ) (define (halve n) (/ n 2)) (define (shr n) (if (odd? n) (/ (- n 1) 2) (/ n 2))) (definec (left-options n) (map halve (keep-matching-items (on-bit-indices n) even?))) (definec (right-options n) (map halve (map -1+ (keep-matching-items (on-bit-indices n) odd?)))) ;; . = 0 ;; \ = 1 ;; / = 2 ;; \/ = 3 ;; \ ;; / = 8 ;; / ;; \ = 16 ;; \ ;; \ = 4 ;; / ;; / = 32 ;; \ ;; \ \ \ \/ \/ ;; \/ = 9 \/ = 12 \/ = 129 \/ = 524289 = 2^(2*9+1)+1 (definec (A057300 n) (reduce + 0 (map (lambda (i) (expt 2 i)) (map A004442 (on-bit-indices n)))) ) (definec (A126006 n) ;; Swap the positions of quaternary digits q0 <-> q1, q2 <-> q3, q4 <-> q5, ... (let loop ((n n) (s 0) (p 1)) (cond ((zero? n) s) (else (loop (floor->exact (/ n 16)) (+ s (* p (+ (* 4 (modulo n 4)) (modulo (floor->exact (/ n 4)) 4)))) (* p 16) ) ) ) ) ) (define (A126007 n) ;; Swap the positions of quaternary digits q0, q1 <-> q2, q3 <-> q4, ... (+ (modulo n 4) (* 4 (A126006 (floor->exact (/ n 4))))) ) (define A126008 (compose-funs A057300 A126007)) ;; The first 64 terms are same as in A106485. (define A126008v2 (compose-funs A126007 A057300)) ;; Return the number of leading 1-bits in the binary expansion of n: ;; The current version (< 2007) in OEIS has been shifted once left! (define (A090996 n) (A007814 (+ 1 (A030101 n)))) ;; Zero-based, 0,1,1,2,1,1,2,3,1,1,1,1,2,2,3,4,1,... (definec (A106485 n) ;; negate, i.e. take the mirror-image of a CGT-tree. (let loop ((n n) (i 0) (s 0) ) (cond ((zero? n) s) ((odd? n) (loop (/ (- n 1) 2) (+ 1 i) (+ s (if (even? i) (expt 2 (+ 1 (* 2 (A106485 (/ i 2))))) (expt 2 (* 2 (A106485 (/ (- i 1) 2)))) ) ) ) ) (else (loop (/ n 2) (+ 1 i) s)) ) ) ) ;; 85159 --- 85228 ;; Note that: A071156 = A085198 o A014486 (define (A085198 n) (let loop ((n n) (s 0) (h 1) (i 2) (fi 1)) (cond ((zero? n) s) ((odd? n) (loop (/ (-1+ n) 2) s (-1+ h) i fi)) (else (loop (/ n 2) (+ s (* h fi)) (1+ h) (1+ i) (* fi i))) ) ) ) ;; Note that: A126302 = A125989 o A014486 (define (A125989 n) (let loop ((n n) (s 0) (h 0)) (cond ((zero? n) s) ((= 2 (modulo n 4)) (loop (/ (- n 2) 4) (+ s h 1) h)) ((odd? n) (loop (/ (- n 1) 2) s (- h 1))) (else (loop (/ n 2) s (+ 1 h))) ) ) ) ;; binexp->A071158-list o A014486 produces the terms of A071158 in list form: ;; (() (1) (1 1) (2 1) (1 1 1) (1 2 1) ...) (define (binexp->A071158-list n) (let loop ((n n) (lista (list)) (h 1)) (cond ((zero? n) lista) ((odd? n) (loop (/ (- n 1) 2) lista (- h 1))) (else (loop (/ n 2) (cons h lista) (1+ h))) ) ) ) ;; ;; Algorithm for Anewone1: divide the run-lengths of n into ;; two separate lists, those that correspond with runs of ones ;; (starting with the first run from the msb-end of n) ;; and that correspond with runs of zeros in the binary expansion ;; of n. ;; A) Beginning from zero-runs, add 1's to the result (from msb to lsb-end) ;; as long as there are 1's in the zero-runs-list (making it shorter all the time). ;; ;; When there's a first run larger than one in the zero-list, ;; add also one 1 to the result, subtract than run by one, ;; and switch the runlists for zeros and ones, make b=0 (start adding 0's ;; to result), and go back to A. ;; ;; If the run-list of zeros is finished completely ;; (after taking the last 1 from it and adding it to the 2*sum) ;; then switch also in that case to the list of ones. ;; ;; When the run-list of ones is also finished ;; (after taking the last 1 from it and adding zero to the 2*sum) ;; then the result is ready. This is the case for n whose ;; binary expansion is balanced. ;; ;; Note: there are n for which there is only runs of ones (no zeros), ;; e.g. 3, 7, 15. ;; and there are n for which there is one list more of ones than ;; zeros (e.g. 5). ;; ;; ;; (define (Ajoku_not_submitted n) (let ((runlens (binexp->runcount1list n))) (let loop ((chosen (bisect runlens 1)) ;; initially zeros. (others (bisect runlens 0)) ;; initially ones. (s 0) (b 1) ) (format #t "chosen=~a, others=~a, b=~a, s=~a\n" chosen others b s) (cond ((and (null? chosen) (null? others)) s) ((and (pair? chosen) (= 1 (car chosen)) (pair? (cdr chosen))) (loop (cdr chosen) others (+ s s b) b) ) (else ;; next run in result, or chosen will be finished, swap chosen and others. (loop others (if (or (null? chosen) (= 1 (car chosen))) '() (cons (- (car chosen) 1) (cdr chosen)) ) (+ s s b) (- 1 b) ) ) ) ) ) ) ;; Like previous, but start from the lsb-end. ;; Here are the 40 A-numbers you requested: A125974 --- A126013. (define (A125974v2 n) (let ((runlens (binexp->runcount1list n))) (let loop ((chosen (reverse! (bisect runlens 0))) ;; initially ones. (others (reverse! (bisect runlens 1))) ;; initially zeros. (s 0) (b (modulo n 2)) (p 1) ) ;; (format #t "chosen=~a, others=~a, b=~a, s=~a, p=~a\n" chosen others b s p) (cond ((and (null? chosen) (null? others)) s) ((and (pair? chosen) (= 1 (car chosen)) (pair? (cdr chosen))) (loop (cdr chosen) others (+ s (* b p)) b (+ p p)) ) (else ;; next run in result, or chosen will be finished, swap chosen and others. (loop others (if (or (null? chosen) (= 1 (car chosen))) '() (cons (- (car chosen) 1) (cdr chosen)) ) (+ s (* b p)) (- 1 b) (+ p p) ) ) ) ) ) ) ;; Here 1(0/1)* refers to the msb-prefix of the n: ;; ;; 0 Chosen=0 (but others is not 0), swap to others. ;; 1 Chosen=1, last one will follow. ;; (1+)0 Chosen=0, last zero will follow. One of A000918 (2^n - 2) (pow2? n+2) ;; 1(0/1)*11 Chosen=1, and one or more ones will follow. (= 3 (modulo chosen 4)) ;; 1(0/1)*00 Chosen=0, and one or more zeros will follow. (= 0 (modulo chosen 4)) ;; ;; Checked after the above cases: ;; 1(0/1)*(0+)1 Chosen=1, and one or more zeros follow, after which follow more ones. ;; (= 1 (modulo chosen 4)) ;; 1(0/1)*(0+)(1+)0 Chosen=0, and one or more ones follow, after which follow more zeros. ;; (= 2 (modulo chosen 4)) (define (A125974 n) (if (zero? n) n (let loop ((chosen (/ n (A006519 n))) ;; Initially ones, get rid of lsb-0's. (others (floor->exact (/ n (A006519 (+ 1 n))))) ;; Initially zeros, get rid of lsb-1's. (s 0) (b (modulo n 2)) (p 1) ) ;; (format #t "chosen=~a, others=~a, b=~a, s=~a, p=~a\n" chosen others b s p) (cond ((and (zero? chosen) (zero? others)) s) ((or (= 1 chosen) (pow2? (+ chosen 2))) ;; Last one or zero at hand. (loop others 0 (+ s (* b p)) (- 1 b) (+ p p)) ) ((or (= 0 (modulo chosen 4)) (= 3 (modulo chosen 4))) ;; source run continues, dest changes. (loop others (floor->exact (/ chosen 2)) (+ s (* b p)) (- 1 b) (+ p p)) ) ((= 1 (modulo chosen 4)) ;; source run changes, from ones to zeros, skip past zeros. (loop (floor->exact (/ chosen (A006519 (- chosen 1)))) others (+ s (* b p)) b (+ p p) ) ) (else ;; (= 2 (modulo chosen 4)) ;; source run changes, from zeros to ones, skip past ones. (loop (floor->exact (/ chosen (A006519 (+ chosen 2)))) others (+ s (* b p)) b (+ p p) ) ) ) ) ) ) ;; (define A125975 (fun-succ-matching-is0 (lambda (i) (= i (A125974 (A125974 i)))))) (define A125975 (MATCHING-POS 0 0 (lambda (i) (= i (A125974 (A125974 i)))))) ;; A154103 --- A154104. ;; Gives 1, if y should come before x, 0 otherwise: (define (A154103bi x y) (cond ((and (zero? y) (not (zero? x))) 1) ((> (A085207bi (* 2 x) y) (A085207bi (* 2 y) x)) 1) (else 0) ) ) (define (A154103 n) (A154103bi (A002262 n) (A025581 n))) (define (A154104 n) (A154103bi (A025581 n) (A002262 n))) ;; Binary concatenation: (0 understood as an empty string). (define (A085207bi x y) (+ (* (expt 2 (A029837 (1+ y))) x) y)) (define (A085207 n) (A085207bi (A025581 n) (A002262 n))) (define (A085208 n) (A085207bi (A002262 n) (A025581 n))) (define (A085209 n) (A007088 (A085207 n))) (define (A085210 n) (A007088 (A085208 n))) ;; Strange binary concatenation: (define (A085211bi x y) (cond ((zero? x) (A085207bi x y)) (else (* (+ (* (expt 2 (A029837 (1+ y))) (A000265 x)) y) (A006519 x))) ) ) (define (A085211 n) (A085211bi (A025581 n) (A002262 n))) (define (A085212 n) (A085211bi (A002262 n) (A025581 n))) (define (A085213 n) (A007088 (A085211 n))) (define (A085214 n) (A007088 (A085212 n))) ;; Factorial expansion concatenation: (0 understood as an empty string). ;; ! is cached, so it's not so foolish as it looks like: (define (A085215bi x y) (let loop ((x x) (y y) (i 2) (j (1+ (A084558 y)))) (cond ((zero? x) y) (else (loop (floor->exact (/ x i)) (+ (* (! j) (modulo x i)) y) (1+ i) (1+ j))) ) ) ) (define (A085215 n) (A085215bi (A025581 n) (A002262 n))) (define (A085216 n) (A085215bi (A002262 n) (A025581 n))) (define (A085217 n) (A007623 (A085216 n))) (define (A085218 n) (A007623 (A085217 n))) ;; Rised factorial expansion concatenation: (0 understood as an empty string). ;; To the each digit of x we add 'r', the first digit of y. ;; (to get a more or less continuous "staircase"). (define (A085219bi x y) (let loop ((x x) (y y) (i 2) (j (1+ (A084558 y))) (r (car (n->factbase y)))) (cond ((zero? x) y) (else (loop (floor->exact (/ x i)) (+ (* (! j) (+ r (modulo x i))) y) (1+ i) (1+ j) r ) ) ) ) ) (define (A085219 n) (A085219bi (A025581 n) (A002262 n))) (define (A085220 n) (A085219bi (A002262 n) (A025581 n))) (define (A085221 n) (A007623 (A085219 n))) (define (A085222 n) (A007623 (A085220 n))) ;; I bet this is the correct formula: ;; Maple: A002542 := n -> 2^((2^n)-1)*((2^((2^n)-1))-1); (define (A002542 n) (* (expt 2 (-1+ (expt 2 n))) (-1+ (expt 2 (-1+ (expt 2 n)))) ) ) ;; ID Number: A002542 (Formerly M2174 and N0869) ;; Sequence: 0,2,56,16256,1073709056,4611686016279904256, ;; 85070591730234615856620279821087277056 ;; Name: Complete Post functions of n variables. ;; References Wheeler, Roger F.; Complete connectives for the $3$-valued ;; propositional calculus. Proc. London Math. Soc. (3) 16 1966 167-191. ;; See also: Cf. A002543. ;; Keywords: nonn ;; Offset: 1 ;; Author(s): njas (definec (A080303 n) ;; rewrite 1->1, 0->100 in the binary expansion. (cond ((zero? n) 4) ((= n 1) n) ((odd? n) (1+ (* 2 (A080303 (/ (-1+ n) 2))))) (else (+ 4 (* 8 (A080303 (/ n 2))))) ) ) (define (A080310 n) (/ (A080303 (* 2 n)) 2)) (definec (A126308 n) ;; rewrite 10->'' in the binary expansion. Cf. A080303. (cond ((zero? n) 0) ((= 2 (modulo n 4)) (A126308 (/ (- n 2) 4))) (else (+ (modulo n 2) (* 2 (A126308 (floor->exact (/ n 2)))))) ) ) (define (A079946 n) (* 2 (+ (A000079 (1+ (A000523 n))) n))) ;; A079446 := n -> 2*(2^(1+A000523(n))+n); ;; A079446v2 := n -> `if`(0=n,2,2^A000523(4*n)+2*n); (define (A079946v2 n) (if (zero? n) 2 (+ (A000079 (A000523 (* 4 n))) (* 2 n)))) (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)) ) ) ) ) ;; (Show ternary form in decimal) (define (A007089 n) ;; 0,1,2,10,11,12,20,21,22,100,101,102,... (let loop ((z 0) (i 0) (n n)) (if (zero? n) z (loop (+ z (* (expt 10 i) (modulo n 3))) (1+ i) (floor->exact (/ n 3)) ) ) ) ) ;; Tersum n + n: (definec (A004488 n) ;; 0,2,1,6,8,7,3,5,4,18,20,19,24,26,25,21,23 (let loop ((z 0) (i 0) (n n)) (if (zero? n) z (loop (+ z (* (expt 3 i) (modulo (- (modulo n 3)) 3))) (1+ i) (floor->exact (/ n 3)) ) ) ) ) (define (A007090 n) ;; 0,1,2,3,10,10,11,12,13,20,... (Show quaternary form in decimal) (let loop ((z 0) (i 0) (n n)) (if (zero? n) z (loop (+ z (* (expt 10 i) (modulo n 4))) (1+ i) (floor->exact (/ n 4)) ) ) ) ) ;; E.g. (A000695 n) = (expand-n-x-fold n 2) (define (expand-n-x-fold n x) ;; Expand bits of n, by scale 2^x. (if (zero? n) n (+ (modulo n 2) (* (expt 2 x) (expand-n-x-fold (floor->exact (/ n 2)) x)) ) ) ) (define (A000302 n) (expt 4 n)) (define (A002001 n) (if (zero? n) 1 (* 3 (A000302 (-1+ n))))) ;; A002001 = 1,3,12,48,192,768,3072,12288,49152,196608,786432,3145728, ;; a(n) = 3*4^(n-1), n>0; a(0)=1. (define (A080116 c) ;; Characteristic function of A014486 (let loop ((c c) (lev 0)) (cond ((zero? c) (if (zero? lev) 1 0)) ((< lev 0) 0) (else (loop (floor->exact (/ c 2)) (+ lev (- 1 (* 2 (modulo c 2))))) ) ) ) ) (define (store-n-to-bits-given-by-column-x-of-table n x NxN->N) (let loop ((n n) (i 0) (s 0)) (if (zero? n) s (loop (floor->exact (/ n 2)) (1+ i) (+ s (* (modulo n 2) (expt 2 (NxN->N x i)))) ) ) ) ) ;; The checking of upper-limit is very naive, and to work it requires ;; that all columns of the map NxN->N are monotone (growing). (define (fetch-from-bits-of-n-given-by-column-x-of-table n x NxN->N) (let ((upper-limit (A000523 n))) (let loop ((i 0) (s 0) (bitpos (NxN->N x 0))) (if (> bitpos upper-limit) s (loop (1+ i) (+ s (* (bit-i n bitpos) (expt 2 i))) (NxN->N x (1+ i)) ) ) ) ) ) ;; ;; Moser-de Bruijn sequence: 0,1,4,5,16,17,20,21,64,65,68,69,80,... ;; (definec (A000695 n) ;; Expand bits, 0->00, 1->01, i.e. from base-2 to base-4. ;; (if (zero? n) ;; n ;; (+ (modulo n 2) (fix:lsh (A000695 (fix:lsh n -1)) 2)) ;; ) ;; ) ;; ;; (definec (A059905 n) ;; Take the even-positioned bits and contract them. ;; (if (zero? n) ;; n ;; (+ (modulo n 2) (fix:lsh (A059905 (fix:lsh n -2)) 1)) ;; ) ;; ) ;; ;; Moser-de Bruijn sequence: 0,1,4,5,16,17,20,21,64,65,68,69,80,... (define (A000695 n) ;; Expand bits, 0->00, 1->01, i.e. from base-2 to base-4. (if (zero? n) n (+ (modulo n 2) (* 4 (A000695 (floor->exact (/ n 2))))) ) ) (define (A059905 n) ;; Take the even-positioned bits and contract them. (if (zero? n) n (+ (modulo n 2) (* 2 (A059905 (floor->exact (/ n 4))))) ) ) (definec (A000695c n) (A000695 n)) ;; The cached variant. Be careful with this! (definec (A059905c n) (A055905 n)) ;; The cached variant. Be careful with this! (define (A059906 n) (A059905 (floor->exact (/ n 2)))) ;; Take the odd bits and contract (define (A059906*2 n) (* 2 (A059906 n))) ;; a(0) = 0, a(1) = 1, a(2k) = 3*a(k), a(2k+1) = 2*a(k) + a(k+1). (definec (A006046 n) (cond ((< n 2) n) ((even? n) (* 3 (A006046 (/ n 2)))) (else (+ (* 2 (A006046 (/ (- n 1) 2))) (A006046 (/ (+ n 1) 2)) ) ) ) ) (define (A080978 n) (1+ (* 2 (A006046 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 (A000265 n) (/ n (A006519 n))) ;; Remove 2s from n; or largest odd divisor of n. ;; One-based: (define (A018900 n) (+ (expt 2 (A002024 n)) (expt 2 (A002262 (-1+ n))))) (definec (A036987 n) (if (eq? (1+ n) (A006519 (1+ n))) 1 0)) (define A073268shifted_once_left (CONVOLVE 0 A000108 A036987)) ;; (map A073268shifted_once_left (iota0 25)) ;; --> (1 2 3 8 20 58 179 576 1902 6426 22092 77026 271702 967840 3476555 12578728 45800278 167693698 617037126 2280467586 8461771342 31510700712 117725789124 441141656810 1657559677646 6243810767912) (define (A073265bi n k) (cond ((zero? n) n) ((zero? k) k) ((> k n) 0) ((eq? 1 k) (if (eq? n (A006519 n)) 1 0)) (else (let sumloop ((i (A000523 (-1+ n))) (s 0)) (cond ((negative? i) s) (else (sumloop (-1+ i) (+ s (A073265bi (- n (fix:lsh 1 i)) (-1+ k))) ) ) ) ) ) ) ) ;; (define seqA003319 (list 1 1 3 13 71 461 3447 29093 273343 2829325 31998903 392743957 5201061455 73943424413 1123596277863 18176728317413 311951144828863 5661698774848621 108355864447215063 2181096921557783605 ) ) (define A000142test (INVERT (lambda (n) (list-ref seqA003319 (-1+ n))))) (define A051296shifted_left (INVERT A000142)) (define A051295shifted_left (INVERT (compose-funs A000142 -1+))) ;; (define A061922 (EIGEN-CONVOLUTION 1 A048720bi)) (define A007460 (EIGEN-CONVOLUTION 1 A003986bi)) ;; OR-convolution with itself. (define A007461 (EIGEN-CONVOLUTION 1 A004198bi)) ;; AND-convolution with itself. (define A007462 (EIGEN-CONVOLUTION '(0 1) A003987bi)) ;; XOR-convolution with itself. (define A007463 (EIGEN-CONVOLUTION 1 lcm)) ;; LCM-convolution with itself. (define A007464 (EIGEN-CONVOLUTION 1 gcd)) ;; GCD-convolution with itself. (define A025192 (EIGEN-CONVOLUTION 1 +)) (define A090826 (CONVOLVE 0 A000045 A000108)) (define A090826_shifted_left_check (CONVOLVE 0 (compose-funs A000045 1+) A000108)) ;; A073265 - A073270 reserved for us. (define (A073265 n) (A073265bi (1+ (A025581 n)) (1+ (A002262 n)))) (define (A073266 n) (A073265bi (1+ (A003056 n)) (1+ (A002262 n)))) (define (A073267 n) (A073265bi n 2)) ;; Occurs also as the FIX-counts of form 105. 6o6 ;; (A073265bi n 1) ;; gives the characteristic function of A000079, ;; i.e. A036987 with offset 1 instead of 0, and a(0) = 0. ;; A073265(6,1) = 0 ;; A073265(6,2) = 2 4+2, 2+4 -> 3+(1)+1, 1+(1)+3 ;; A073265(6,3) = 4 2+2+2, 4+1+1, 1+4+1, 1+1+4 -> 1+(1)+1+(1)+1, 3+(1)+0+(1)+0, etc. ;; A073265(6,4) = 6 2+2+1+1, 2+1+2+1, 2+1+1+2, 1+2+1+2, 1+2+2+1, 1+1+2+2 ;; A073265(6,5) = 5 2+1+1+1+1 * 5 --> 1+(1)+0+(1)+0+(1)+0+(1)+0 ;; A073265(6,6) = 1 1+1+1+1+1+1 --> 0+(1)+0+(1)+0+(1)+0+(1)+0+(1)+0 (define (A073268 n) ;; The fix sequence for form 41, SwapBinTree o SwapDownCar (0 o 6) (if (zero? n) 1 (let sumloop ((i (floor->exact (/ (log n) (log 2)))) (s 0)) (cond ((negative? i) s) (else (sumloop (-1+ i) (+ s (A000108 (- n (expt 2 i)))))) ) ) ) ) (define (A073345bi n k) (cond ((zero? n) (if (zero? k) 1 0)) ((zero? k) k) ((> k n) 0) (else (let ((half-n (fix:lsh (-1+ n) -1)) (k-1 (-1+ k)) ) (+ (* 2 (add (lambda (i) (* (A073345bi (- (-1+ n) i) k-1) (add (lambda (j) (A073345bi i j)) 0 k-1 ) ) ) 0 half-n ) ) (* 2 (add (lambda (i) (* (A073345bi (- (-1+ n) i) k-1) (add (lambda (j) (A073345bi i j)) 0 (- k 2) ) ) ) (1+ half-n) (-1+ n) ) ) (if (odd? n) (* -1 (expt (A073345bi half-n k-1) 2)) 0) ) ;; + ) ;; let ) ;; else ) ;; cond ) (define (A073346bi n k) (cond ((zero? k) (A036987 n)) ((zero? n) 0) ((> k n) 0) (else (let ((half-n (fix:lsh (-1+ n) -1)) (k-1 (-1+ k)) ) (+ (* 2 (add (lambda (i) (* (A073346bi (- (-1+ n) i) k-1) (add (lambda (j) (A073346bi i j)) 0 k-1 ) ) ) 0 half-n ) ) (* 2 (add (lambda (i) (* (A073346bi (- (-1+ n) i) k-1) (add (lambda (j) (A073346bi i j)) 0 (- k 2) ) ) ) (1+ half-n) (-1+ n) ) ) (if (odd? n) (* -1 (expt (A073346bi half-n k-1) 2)) 0) (if (= 1 k) (* -1 (A036987 n)) 0) ) ;; + ) ;; let ) ;; else ) ;; cond ) (define (A073345 n) (A073345bi (A025581 n) (A002262 n))) (define (A073346 n) (A073346bi (A025581 n) (A002262 n))) (define (A073429 n) (A073345bi (A003056 n) (A002262 n))) (define (A073430 n) (A073346bi (A003056 n) (A002262 n))) (define (A073431 n) (cond ((zero? n) 1) (else (/ (add (lambda (i) (add (lambda (j) (A073346bi n j)) 0 (A007814 i))) 1 (expt 2 (-1+ n)) ) (expt 2 (-1+ n)) ) ) ) ) ;; For some reason this seems to produce the same answers: ;; (Some peculiar interaction of A007814 & A073346 ?) (define (A073431v2 n) (cond ((zero? n) 1) (else (-1+ (/ (add (lambda (i) (A073346bi n (A007814 i))) 1 (expt 2 (-1+ n)) ) (expt 2 (- n 2)) ) ) ) ) ) (definec (A048678 n) ;; Rewrite to Zeckendorf-expansion: 0->0, 1->01 (cond ((zero? n) n) ((even? n) (* 2 (A048678 (floor->exact (/ n 2))))) (else (1+ (* 4 (A048678 (floor->exact (/ n 2)))))) ) ) (define (A022290 n) ;; I.e. interpret_as_zeckendorf_expansion (let loop ((n n) (s 0) (i 2)) (cond ((zero? n) s) (else (loop (floor->exact (/ n 2)) (+ s (* (modulo n 2) (fibo i))) (1+ i) ) ) ) ) ) (define (A072648 n) ;; An approximate "inverse" of A000045 (of the fibonacci numbers) (cond ((zero? n) n) (else (floor->exact (/ (log (* n *Sqrt5*)) *LogPhi*))) ) ) ;; 1,2,3,4,5,6,7,8,9,A,B,C,D,E,F, ,21 ;; 1,2,3,3,4,4,4,5,5,5,5,5,6,6,6,6,6,6,6,6,7,... (define (A072649 n) ;; n occurs fibo(n) times. (let ((b (A072648 n))) (+ -1 b (floor->exact (/ n (fibo (1+ b))))) ) ) (define (A072650 n) ;; rewrite_0to0_x1to1 (let loop ((n n) (s 0) (i 0)) (cond ((zero? n) s) ((even? n) (loop (floor->exact (/ n 2)) s (1+ i))) (else (loop (floor->exact (/ n 4)) (+ s (expt 2 i)) (1+ i))) ) ) ) (definec (A003714c n) ;; The cached variant. (cond ((< n 3) n) (else (+ (expt 2 (-1+ (A072649 n))) (A003714c (- n (fibo (1+ (A072649 n))))) ) ) ) ) (define (A003714 n) ;; Iterative (tail-recursive) variant, not cached. (let loop ((n n) (s 0)) (cond ((< n 3) (+ s n)) (else (loop (- n (fibo (1+ (A072649 n)))) (+ s (expt 2 (-1+ (A072649 n)))) ) ) ) ) ) (define (A048679 n) (A072650 (A003714 n))) (define (A048680 n) (A022290 (A048678 n))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Some edits of Ctibor O. Zizka's sequences. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Here are the 10 A-numbers you requested: A166012 --- A166021. (definec (A133923 n) (cond ((< n 2) n) ((even? (A133923 (-1+ n))) (/ (A133923 (-1+ n)) 2)) (else (A000005 (* n (A133923 (-1+ n))))) ) ) ;; Auxiliary sequence for A138606: (definec (A166012 n) (+ 1 (modulo n 2) (* 2 (- (A000045 n) (modulo n 2))))) ;; Note: A138606(n) = A072649(n) modulo 2. (defineperm1 (A138606 n) (if (zero? n) n (+ (A166012 (-1+ (A072649 n))) (* 2 (- n (A000045 (1+ (A072649 n)))))) ) ) (define (A166013 n) (A138606 (- n))) (defineperm1 (A138607 n) (if (< n 3) n (let ((k (A083375 (- n 2)))) (if (= (- n 2) (A007504 k)) (+ 2 (A138607 (- n 1 (A000040 k)))) (+ 2 (A138607 (-1+ n))) ) ) ) ) (define (A166014 n) (A138607 (- n))) (defineperm1 (A138608 n) (if (< n 4) n (let ((k (A072649 n))) (if (= n (A000045 (1+ k))) (+ 3 (A138608 (- n 1 (A000045 k)))) (+ 3 (A138608 (-1+ n))) ) ) ) ) (define (A166015 n) (A138608 (- n))) (defineperm1 (A074147 n) ;; (2n-1) odd numbers followed by 2n even numbers. (if (zero? n) n (+ (A061925 (-1+ (A002024 n))) (* 2 (A002262 (-1+ n)))) ) ) ;; a(n) = n + {1,2,0,1} according as n == {0,1,2,3} mod 4. (define (A116966 n) (+ n (list-ref '(1 2 0 1) (modulo n 4)))) (defineperm1 (A138609 n) (if (zero? n) n (A116966 (-1+ (A074147 n))))) (define (A166016 n) (A138609 (- n))) ;; Must be computed term-by-term before its inverse A166017 ! (defineperm1 (A138612 n) (if (< n 3) n (let loop ((k (if (zero? (A002262 (-1+ n))) 1 (A138612 (-1+ n)))) (i 1) ) (cond ((not-lte? (A166017 i) (-1+ n)) (if (= 1 k) i (loop (-1+ k) (1+ i))) ) (else (loop k (1+ i))) ) ) ) ) (define (A166017 n) (A138612 (- n))) (define (A166018 n) (A138612 (A000124 (-1+ n)))) ;; Leading edge (define (A166019 n) (A138612 (A000217 n))) ;; Trailing edge. (define A166020 (ROWSUMS1 A138612)) ;; tabl (definec (A166021 n) (if (zero? (A002262 (-1+ n))) (* 2 (A000124 (A003056 (-1+ n)))) (1+ (A166021 (-1+ n)))) ) (define A136272 (COMPLEMENT 1 A166021)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (A000217 n) (/ (* n (+ n 1)) 2)) (define (A000124 n) (1+ (A000217 n))) (define (A000290 n) (* n n)) (define (A061925 n) (1+ (ceiling->exact (/ (A000290 n) 2)))) ; Ceiling[n^2/2]+1 (define (A046092 n) (* 2 n (1+ n))) ;; This gives the central diagonal from zero-indexed arrays/tables. ;; (map A025581 (cons 0 (iota 20))) --> (0 1 0 2 1 0 3 2 1 0 4 3 2 1 0 5 4 3 2 1 0) ;; (definec (A025581 n) ;; The X component (column) of square {0..inf} arrays ;; (- (binomial_n_2 (1+ (floor->exact (+ (/ 1 2) (sqrt (* 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 (+ (/ 1 2) (sqrt (* 2 (1+ n))))))) ;; ) ;; 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)))) ) ;; Repeat n 2n times, starting from n=1: (define (A000194 n) (A002024 (1+ (floor->exact (/ (-1+ n) 2))))) ;; Integers 1 to 2k followed by integers 1 to 2(k+1) and so on. ;; 1,2,1,2,3,4,1,2,3,4,5,6,1,2,3,4,5,6,7,8, (define (A074294 n) (- n (* 2 (A000217 (-1+ (A000194 n)))))) ;; Integers (2k)-1..0 followed by integers (2k)+1..0 and so on: ;; 1,0,3,2,1,0,5,4,3,2,1,0,7,6,5,4,3,2,1,0,... (define (A179753 n) (- (* 2 (A000194 n)) (A074294 n))) (define (A003056 n) ;; repeat n n+1 times, starting from n = 0. (floor->exact (- (sqrt (* 2 (1+ n))) (/ 1 2))) ) (define (square? n) (= n ((lambda (r) (* r r)) (floor->exact (sqrt n))))) (define (A001477 n) n) (define (A001489 n) (- n)) (define (A023443 n) (- n 1)) (define (A020725 n) (+ n 1)) ;; Actually "Integers >= 2.", with offset=1. (define (packA001477 x y) (/ (+ (expt (+ x y) 2) x (* 3 y)) 2)) (define (packA061579 x y) (/ (+ (expt (+ x y) 2) (* 3 x) y) 2)) (define A001477bi packA001477) ;; I.e. (define (id n) (packA001477 (A025581 n) (A002262 n))) ;; and (define (A061579 n) (packA061579 (A025581 n) (A002262 n))) (define (A038722 n) (if (zero? n) n (1+ (A061579 (-1+ n))))) ;; Gives id (A001477): (+ (A000695 (A059905 n)) (* 2 (A000695 (A059906 n)))) (define (A057300 n) (+ (A000695 (A059906 n)) (* 2 (A000695 (A059905 n))))) (define (A054238 n) (+ (A000695 (A025581 n)) (* 2 (A000695 (A002262 n))))) (define (A054239 n) (packA001477 (A059905 n) (A059906 n)))