# Collection of various algorithms written as Maple procedures, # mostly thought out and implemented by Antti Karttunen # (unless otherwise noted). These are all in Public Domain. # All procedures will be published here before they appear in # Neil J.A. Sloane's Encyclopedia of Integer Sequences. # # Most of these are very straightforward implementations, # with no much attention paid to either mathematical elegance # nor the run-time efficiency. # Someday I will sort and rewrite almost everything here in Lisp, # and make clear cross-references to all EIS-sequences # produced by these procedures. # # Yes, the time is now: some of the stuff can be found # from the Scheme-module: # http://www.iki.fi/~kartturi/matikka/Schemuli/intfuns1.scm # See also: # http://www.iki.fi/~kartturi/matikka/Nekomorphisms/gatomorf.htm # # # Note: I transferred the musical scale/gammier stuff from # the end of this file to its own separate module: # http://www.iki.fi/~kartturi/matikka/gammoids.txt # interface(echo=1); # read `c:\\karttu\\matikka\\www.research.att.com\\~njas\\sequences\\transfor.txt`; read `c:\\maplev4\\matikka\\transfor.txt`; interface(echo=1); # oldquiet := interface( quiet, quiet=true ); # read `c:\\karttu\\matikka\\someseqs\\someseqs.txt`; # interface( quiet, quiet=oldquiet ); # readshare(guesss,calculus); # Not needed, the guesss function. with(group); with(combinat); # For fibonacci; with(numtheory); # For mobius, tau, etc. readlib(issqr); # For issqr avg := a -> (convert(a,`+`)/nops(a)); nthmember := proc(e,l) local k; if(member(e,l,'k')) then RETURN(k) else RETURN(0); fi; end; positions := proc(e,ll) local a,k,l,m; l := ll; m := 1; a := []; while(member(e,l[m..nops(l)],'k')) do a := [op(a),(k+m-1)]; m := k+m; od; RETURN(a); end; negative_terms := proc(b) local a,i; a := []; for i from 1 to nops(b) do if(b[i] < 0) then a := [op(a),i]; fi; od; RETURN(a); end; odd_terms := proc(b) local a,i; a := []; for i from 1 to nops(b) do if(1 = (b[i] mod 2)) then a := [op(a),i]; fi; od; RETURN(a); end; palindrome_lists := proc(b) local a,i; a := []; for i from 1 to nops(b) do if(reverse(b[i]) = b[i]) then a := [op(a),i]; fi; od; RETURN(a); end; car:=proc(l) if 0 = nops(l) then ([]) else (op(1,l)): fi: end: cdr:=proc(l) if 0 = nops(l) then ([]) else (l[2..nops(l)]): fi: end: last_term:=proc(l) local n: n := nops(l); if(0 = n) then ([]) else (op(n,l)): fi: end: cons:=proc(head,tail) ([head, op(tail)]); end: list3:=proc(el1,el2,el3) ([el1,el2,el3]); end: # # (defun *reverse (lista) # (cond ((null lista) nil) # (t (append (*reverse (cdr lista)) # (cons (car lista) nil))))) # reverse:=proc(a) if 0 = nops(a) then (a) else [op(reverse(cdr(a))), a[1]]; fi: end: deepreverse:=proc(a) if 0 = nops(a) or list <> whattype(a) then (a) else [op(deepreverse(cdr(a))), deepreverse(a[1])]; fi; end; rotateL:=proc(a) if 0 = nops(a) then (a) else [op(cdr(a)), a[1]]; fi; end; rotateR:= a -> reverse(rotateL(reverse(a))); deeprotateL:=proc(a) if 0 = nops(a) or list <> whattype(a) then (a) else rotateL(map(deeprotateL,a)); fi; end; deeprotateR:=proc(a) if 0 = nops(a) or list <> whattype(a) then (a) else rotateR(map(deeprotateR,a)); fi; end; deeprotateRalt:= a -> deepreverse(deeprotateL(deepreverse(a))); # Note how Maple and Lisp functions correspond here: # nops(l) = (length l) # map(fun, lista) = (mapcar fun lista) # convert(lista, `+`) = (apply #'+ lista) # eval_prefix:=proc(l): if whattype(l) <> list then (l) else if 0 = nops(l) then (l) else (convert(map(eval_prefix, cdr(l)),car(l))) fi: fi: end: # # Bisect sequence a to two one-element shorter sequences, # that is, the sequence of quotients and remainders computed # from each consecutive pair of terms. # If a zero divisor is ever encountered (that is, occurring in # any but as the last term of a), the construction is aborted # and an empty list is returned. # QUOREM:=proc(a) local ql,rl, dividend, divisor, remainder, i: if whattype(a) <> list then RETURN([]); fi: if nops(a) <= 1 then RETURN([]); fi: ql:=[]; rl:=[]; divisor := a[1]; for i from 2 to nops(a) do if (0 = divisor) then RETURN([]); fi: dividend := a[i]; ql := [op(ql), iquo(dividend,divisor,'remainder')]; rl := [op(rl), remainder]; divisor := dividend; od: RETURN([ql,rl]); end: # # Describing transformation. Count the multiplicity of each term, # the result is a sequence of even number of terms. # DESCRIBE:=proc(a) local b, prev_term, n, i: b := []; prev_term := NULL; for i from 1 to nops(a) do if(a[i] <> prev_term) then if(prev_term <> NULL) then b := [op(b), n, prev_term]; fi: prev_term := a[i]; n := 1; else n := n+1; fi: od: if(prev_term <> NULL) then b := [op(b), n, prev_term]; fi: RETURN(b); end: DESCRIBE_SEPARATELY:=proc(a) local b, factors: b := DESCRIBE(a); factors := BISECT(b,0); if ({1} = convert(factors,set)) then RETURN([]); fi: [factors, BISECT(b,1)]; end: # # This tests whether the given sequence is an "idemterm" sequence # (an "isotermic" sequence?), i.e. that all the terms are same, # and there are at least two of them. # ALL_SAMEP_OLD:=proc(a) local i: if nops(a) <= 1 then RETURN(false); fi: for i from 2 to nops(a) do if(a[i] <> a[i-1]) then RETURN(false); fi: od: RETURN(true); end: # Here is a more elegant solution, probably faster as well: ALL_SAMEP:=proc(a) (nops(a) > 1 and (1 = nops(convert(a,set)))) end: # # This tests whether the sequence b is an eigensequence to a, # that is, a's first terms are identical to b's all terms. # Returns an index (one-based) to the next term in a # (the first term that is not in b), if that is the case, # otherwise zero. # BEGIN_SIMILARLY_P:=proc(a, b, len_at_least) local a_l, b_l, i: a_l := nops(a); b_l := nops(b); if((b_l < len_at_least) or (a_l <= b_l)) then RETURN(0); fi: for i from 1 to b_l do if(a[i] <> b[i]) then RETURN(0); fi: od: RETURN(b_l+1); end: # # If options have R in them, then we check also for any right-shifted # eigen-sequences. # findnext_main:=proc(a, b, trans_op, opts, len_at_least) local c, b1, b2, i, x: if(member(D, opts)) then print ([trans_op, b]); fi: if nops(b) < 2 then RETURN([]); fi: if ALL_SAMEP(b) then RETURN(cons(car(b), [cons(trans_op, b)])); fi: if(a = b) then return ([]); fi: # Avoid idiot loops. i := BEGIN_SIMILARLY_P(a, b, len_at_least); if ((0 = i) and (member(R, opts))) then i := BEGIN_SIMILARLY_P(a, cdr(b), len_at_least); fi: if (0 <> i) then RETURN(cons(a[i], [cons(trans_op, b)])); fi: c := findnext_main(b, DIFF(b), `-`, opts, len_at_least); if(nops(c) > 0) then RETURN(cons([`+`, last_term(b), car(c)], cons(cons(trans_op, b), cdr(c)))); fi: c := QUOREM(b); if(nops(c) > 0) then # Check whether the remainders (c[2]) and quotients (c[1]) # make any sense, thus forming two branches b1 and b2 b1 := findnext_main(b, c[2], `%`, opts, len_at_least); if(nops(b1) > 0) then b2 := findnext_main(b, c[1], `/`, opts, len_at_least); if(nops(b2) > 0) then x := [`*`, last_term(b), car(b2)]; if(car(b1) <> 0) then x := [`+`, x, car(b1)]; fi: RETURN(cons(x, cons(cons(trans_op, b), [op(cdr(b1)), op(cdr(b2))]))); fi: fi: fi: RETURN([]); end: findnext:=proc(a, opts, len_at_least) local r: r := findnext_main([], a, `>`, opts, len_at_least); if (nops(r) <> 0) then map(print, cdr(r)); print (car(r)); RETURN([op(a), eval_prefix(car(r))]); fi: RETURN([]); end: # Return a lists of quotients and remainders produced by # blackboard division when # computing reciprocal of n (1/n) in base bas. # recrem:=proc(divisor,bas) local ql,rl,remainder; ql:=[]; rl:=[]; remainder := 1; while((0 = nops(ql)) or (remainder > 1)) do while(remainder < divisor) do remainder := (bas * remainder); if(remainder < divisor) then ql := [op(ql), 0]; rl := [op(rl), remainder]; fi: od: ql := [op(ql), iquo(remainder, divisor, 'remainder')]; rl := [op(rl), remainder]; od: RETURN([ql,rl]); end: fib_mod_n:=proc(x,n) option remember: if (0 = x) then (10) else if (1 = x) then (100-n) else ((fib_mod_n((x-2),n)+fib_mod_n((x-1),n)) mod n) fi: fi: end: # fib:=proc(n) option remember: if (n < 2) then (n) else (fib(n-2)+fib(n-1)): fi: end: # luc:=proc(n) option remember: if (n < 2) then (2-n) else (luc(n-2)+luc(n-1)): fi: end: fib := n -> fibonacci(n); luc := n -> (fibonacci(n-1)+fibonacci(n+1)); selfirst := p -> op(1,p); A006530 := proc(n) local b; if(n < 2) then RETURN(n); fi; b := sort(map(selfirst,op(2,ifactors(n)))); RETURN(b[nops(b)]); end; # Number of distinct primes dividing n (also called omega(n)). A001221 := n -> nops(op(2,ifactors(n))); bit_i := (x,i) -> `mod`(floor(x/(2^i)),2); A000523 := proc(n) local nn,i; # Was: floor_log_2 nn := n; for i from -1 to n do if(0 = nn) then RETURN(i); fi; nn := floor(nn/2); od; end; A070939 := n -> (`if`((0 = n),1,A000523(n)+1)); # Was binwidth binrev := proc(nn) local n,z; n := nn; z := 0; while(n <> 0) do z := 2*z + (n mod 2); n := floor(n/2); od; RETURN(z); end; A079446 := n -> 2*(2^(1+A000523(n))+n); A079446v2 := n -> `if`(0=n,2,2^A000523(4*n)+2*n); A036044 := proc(nn) local n,z; # Was binrevcompl, differs at a(0). n := nn; z := 0; while(n <> 0) do z := 2*z + ((n+1) mod 2); n := floor(n/2); od; RETURN(z); end; # Return mask bit positions: list_mask_bits := proc(nn) local n,a,x; n := nn; x := 1; a := []; while(n > 0) do if(1 = (n mod 2)) then a := [op(a),x]; fi; n := floor(n/2); x := 2*x; od; RETURN(a); end; sum_by_mask_list := proc(nn,a) local n,i,s; n := nn; s := 0; i := 1; while(n > 0) do if(1 = (n mod 2)) then s := s + a[i]; fi; n := floor(n/2); i := i+1; od; RETURN(s); end; maskees := proc(n) local a,b,u,i; a := []; b := list_mask_bits(n); u := (2^nops(b))-1; for i from 0 to u do a := [op(a),sum_by_mask_list(i,b)]; od; RETURN(a); end; # See Marc LeBrun's message # "half-baked generalized convolution sequence transforms" # posted Sat, 09 Jun 2001 12:08:54 -0700 # on SeqFan mailing list: (seqfan@ext.jussieu.fr) # 5. Now we generalize the vanilla convolution by replacing the index # subtraction that appears in the summation # # j - i # # with some other operation # # j ~ i # # (which I pronounce as "the complement of i in j") giving # # R[j] = sum S[i] T[j ~ i]. # # 6. It seems (half-bakedly, can you prove it?) that the new operation should # obey a kind of "reflection" law # # n ~ i = j <==> n ~ j = i # # This defines what I call a "numbral subtraction", # # [j] - [i] = [j ~ i]. # # Here the complement of i in j is just the ordinary difference--but only # when j masks i is it defined! So instead of summing over divisors we sum # over "bivisors" (or whatever you want to call the binary "maskees"). # # Does it Mask (j over i)? dim := proc(j,i) if(ANDnos(j,i) = i) then 1 else 0; fi; end; # MASKTRANS(a) is equivalent to MASKCONV(a,A000012), where A000012 is all-1's sequence. MASKTRANS :=proc(a) local c,i,j,n; if whattype(a) <> list then RETURN([]); fi; n := nops(a); c := []; for j from 0 to n-1 do c := [ op(c), sum( ' dim(j,i)*a[i+1] ', 'i'=0..j)]; od; RETURN(c); end; # And the inverse Mask transform is then: MASKTRANSi := a -> MASKCONV(a,[seq((-1)^(wt(j) mod 2),j=0..nops(a)-1)]); MASKCONV :=proc(a,b) local c,i,j,n; if whattype(a) <> list then RETURN([]); fi; if whattype(b) <> list then RETURN([]); fi; n := min(nops(a),nops(b)); c := []; for j from 0 to n-1 do c := [ op(c), sum( ' dim(j,i)*a[i+1]*b[(j-i)+1] ', 'i'=0..j)]; od; RETURN(c); end; EIGENbyMASKCONVslow := proc(upto_n) local a,i; a := [1]; for i from 1 to upto_n do a := [1,op(MASKCONV(a,a))]; od; RETURN(a); end; # Gives A062177 [1,1,2,4,12,24,72,192,720,1440,4320,11520,43200,103680,362880,1105920,4665600,9331200,27993600,...] EIGENbyMASKCONV := proc(upto_n) local n,a,j,i,s,m; a := [1]; for i from 0 to upto_n do s := 0; m := maskees(i); n := nops(m); for j from 1 to n do s := s+(a[m[j]+1]*a[m[(n-j)+1]+1]); od; a := [op(a),s]; od; RETURN(a); end; # Gives: A038044 = [1,1,2,4,9,18,40,80,168,340,698,1396,2844,5688,11456,22948,...] # (A sequence which shifts left under Dirichlet convolution) EIGENbyDIRCONV := proc(upto_n) local n,a,j,i,s,m; a := [1]; for i from 1 to upto_n do s := 0; m := convert(divisors(i),set); n := nops(m); for j from 1 to n do # printf(`(a[%a]*a[%a]) = (%a*%a) = %a, s=%a\n`,m[j],m[(n-j)+1],a[m[j]],a[m[(n-j)+1]],(a[m[j]]*a[m[(n-j)+1]]),s); s := s+(a[m[j]]*a[m[(n-j)+1]]); od; a := [op(a),s]; od; RETURN(a); end; # A000012 = [1,1,1,1,1,1,1,1,....] # MASKTRANS(A000012) = MASKCONV(A000012,A000012); gives: # A001316 = [1,2,2,4,2,4,4,8,2,4,4,8,4,8,8,16,2,4,4,8,4,8,8,16,4,8,8,16,... # (Which is also given by [seq(nops(maskees(j)),j=0..30)];) # A001477 := [seq(j,j=0..35)]; --> [0,1,2,3,4,5,6,7,8,9,10,11,12, ...]; # MASKTRANS(A001477); = MASKCONV(A000012,A001477); = MASKCONV(A001477,A000012); # [0,1,2,6,4,10,12,28,8,18,20,44,24,52,56,120,16,34,36,76,40,84,88,184,48,100,104,216,112,232,240,496,32,66,68,140] # A010060 := [seq((wt(j) mod 2),j=0..63)]; # A010060 := [0,1,1,0,1,0,0,1,1,0,0,1,0,1,1,0,1,0,0,1,0,1,1,0,0,1,1,0,1,0,...] # Iseq := [seq((-1)^(wt(j) mod 2),j=0..63)]; # Iseq := [1,-1,-1,1,-1,1,1,-1,-1,1,1,-1,1,-1,-1,1,-1,1,1,-1,1,-1,-1,1,1,-1,-1,1,...] # A048678 := [seq(rewrite_0to0_1to01(n),n=0..64)]; # A048678 := [0,1,2,5,4,9,10,21,8,17,18,37,20,41,42,85,16,33,34,69,36,73,74,149,40,81,82, # A053644pre0 := MASKCONV(A048678,Iseq); # A053644pre0 := [0,1,2,2,4,4,4,4,8,8,8,8,8,8,8,8,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,32,...] # A055975pre0 := MASKCONV(A053644pre0,Iseq); # A055975pre0 := [0,1,2,-1,4,-1,-2,1,8,-1,-2,1,-4,1,2,-1,16,-1,-2,1,-4,1,2,-1,-8,1,2,-1,4,-1,-2,1,32,-1,-2,1,-4,...] # A006519pre0 := map(abs,A055975pre0); # A006519pre0 := [0,1,2,1,4,1,2,1,8,1,2,1,4,1,2,1,16,1,2,1,4,1,2,1,8,1,2,1,4,1,2,1,32,1,2,1,4,1,2,1,8,1,2,1,4,1,...] # Or going to the other way: # MASKTRANS(A055975pre0); # [0,1,2,2,4,4,4,4,8,8,8,8,8,8,8,8,16,16,16,16,16,16,16,16,16,16,16,...] # MASKTRANS(MASKTRANS(A055975pre0)); # [0,1,2,5,4,9,10,21,8,17,18,37,20,41,42,85,16,33,34,69,36,73,74,149,40,81,82,...] # Like A000523 but this one returns only odd values # (even values are incremented by one, for the needs of quatpal_lr) A000523_coarse := proc(n) local nn,i: nn := n; for i from -1 to n do if(0 = nn) then RETURN(i+(1-(i mod 2))); fi: nn := floor(nn/2); od: end: # Produces incorrect results if sum is used without the quotes: binpal_lr_even := n -> (2^(A000523(n)+1))*n + sum('(bit_i(n,i)*(2^(A000523(n)-i)))','i'=0..A000523(n)); binpal_lr_even_wide := n -> (2^n)*n + sum('(bit_i(n,i)*(2^(A000523(n)-i)))','i'=0..A000523(n)); binpal_lr_odd := n -> (2^(A000523(n)))*n + sum('(bit_i(n,i)*(2^(A000523(n)-i)))','i'=1..A000523(n)); quatpal_lr := n -> (2^(A000523_coarse(n)+1))*n + sum('(bit_i(n,i+((-1)^i))*(2^(A000523_coarse(n)-i)))','i'=0..A000523_coarse(n)); # A000120(0) = 0, A000120(2n) = A000120(n), A000120(2n+1) = A000120(n) + 1. A000120 := proc(nn) local n,s; n := nn; s := 0; while(n > 0) do s := s + (n mod 2); n := (n-(n mod 2))/2; od; RETURN(s); end; A062383 := proc(n) option remember; if(0 = n) then RETURN(1); else RETURN(2*A062383(floor(n/2))); fi; end; # A007814 := [0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1, # 0,5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2, # 0,1,0,6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1, # 0,2,0,1,0,5]; A007814 := proc(nn) local i,n; n := nn; i := 0; if(0 = n) then RETURN(0); fi; while(0 = (`mod`(n,2))) do n := n/2; i := i+1; od; RETURN(i); end; A001511 := n -> A007814(n)+1; A006519 := n -> 2^A007814(n); # Highest power of 2 dividing n: 1,2,1,4,1,2,1,8,1,... A000265 := n -> n/A006519(n); A025480 := n -> (A000265(n+1)-1)/2; # Krassimir T. Atanassov: On some of the Smarandache's Problems, # section 7, on the 61-st problem, page 42: A007814_partsum := proc(n) local l,nn,j; l := A000523(n); nn := n - (2^l); RETURN(((2^(l))-1)+sum('(j*floor((nn+2^j)/(2^(j+1))))','j'=1..l)); end; bper3_rec := proc(n) option remember; local d; if(0 = n) then RETURN(0); fi; d := 2^(A000523(n)-A007814(n)); if(1 = d) then RETURN((2*bper3_rec(n-1))+d); else RETURN(bper3_rec(n-1)+d); fi; end; bper3_direct := proc(n) local l,nn,j; l := A000523(n); nn := n - (2^l); RETURN((2/3*((2^(2*A000523(n)))-1))+1+sum('(2^(l-j)*floor((nn+2^j)/(2^(j+1))))','j'=0..l)); end; primorial := proc(n) option remember; if(1 = n) then RETURN(2); else RETURN(ithprime(n)*primorial(n-1)); fi; end; crt_add_factors := proc(n) local p,t,i,a; a := []; t := primorial(n); for i from 1 to n do p := ithprime(i); a := [op(a),op(2,op(1,msolve((t/p)*x=1,p)))]; od; RETURN(a); end; # Is 1 for all n, as expected. crt_comp_gcd := proc(n) local p,t,i,d; d := 0; t := primorial(n); for i from 1 to n do p := ithprime(i); d := igcd(d,(t/p)*op(2,op(1,msolve((t/p)*x=1,p)))); od; RETURN(d); end; igcd_list := proc(a) local i,d; d := 0; for i in a do d := igcd(d,i); od; RETURN(d); end; incr_plist_from_left := proc(aa) local i,n,a; a := aa; n := nops(a); for i from 1 to n do if(a[i] < (ithprime(i)-1)) then a[i] := a[i]+1; RETURN(a); else a[i] := 1; fi; od; RETURN([op(a),1]); end; incr_plist_from_right := proc(aa) local i,n,a; a := aa; n := nops(a); for i from n by -1 to 1 do if(a[i] < (ithprime(i)-1)) then a[i] := a[i]+1; RETURN(a); else a[i] := 1; fi; od; RETURN([op(a),1]); end; incr_plist_from_left_n_times := proc(aa,n) local a,i; a := aa; for i from 1 to n do a := incr_plist_from_left(a); od; RETURN(a); end; incr_plist_from_right_n_times := proc(aa,n) local a,i; a := aa; for i from 1 to n do a := incr_plist_from_right(a); od; RETURN(a); end; preprimorial := n -> product((ithprime('i')-1),'i'=1..n); prod_even_per_odds := n -> product(((2*'i')/((2*'i')+1)),'i'=1..n); # prod_even_per_odds := proc(n) local i; RETURN(mul(((2*i)/((2*i)+1)),i=1..n)); end; sum_them := m -> sum(((1/((4*'j')+2))*prod_even_per_odds('j'-1)),'j'=1..m); form_modlist := proc(a) local b,i; b := []; for i from 1 to nops(a) do b := [op(b),ithprime(i)]; od; RETURN(b); end; prim_chrem_left := proc(n) local r,m; r := incr_plist_from_left_n_times([],n); m := form_modlist(r); RETURN(chrem(r,m)); end; prim_chrem_right := proc(n) local r,m; r := incr_plist_from_right_n_times([],n); m := form_modlist(r); RETURN(chrem(r,m)); end; # Fibbinary numbers: A003714 := [0,1,2,4,5,8,9,10,16,17,18,20,21,32,33,34,36,37,40,41,42,64,65,66,68,69,72,73,74,80,81,82,84,85,128,129,130,132,133,136,137,138,144,145,146,148,149,160,161,162,164,165,168,169,170,256,257,258,260]; fastfib := n -> round((((sqrt(5)+1)/2)^n)/sqrt(5)); fibinv_appr := n -> floor(log[(sqrt(5)+1)/2](sqrt(5)*n)); fibinv := n -> (fibinv_appr(n) + floor(n/fibonacci(1+fibinv_appr(n)))); fibinv_deb := proc(n) local r; r := fibinv(n); printf(`fibinv(%a)=%a\n`,n,r); RETURN(r); end; # # fibcorterm_for_Fn := n -> log[phi](1-((invphi^(2*n))*(-1)^n)); # # Where phi := (1+sqrt(5))/2 and invphi := (sqrt(5)-1)/2 # # But we would need to compute this correction term (to be added to # log[(sqrt(5)+1)/2](sqrt(5)*n) before using floor) for any particular # value x (of which some are Fn). Note how the argument for logarithm # converges to 1, but vacillating a little bit above and below 1, # thus the value of the logarithm itself (the whole correction term) # converges to zero, but alternating from the both sides (negative and # positive). # Note how that as the Lucas sequence intersperses the Fibonacci sequence, # it means that the fractional part of the Lucas inverse of n is # "near" 0.5 when the fractional part of the Fibonacci inverse is near # zero (that is, when n is near some Fib(x)), so flooring the Lucas # inverse in those cases yields a safe value. (But we still need to # know when to use which one, Lucas or Fibonacci inverse safely.) # fibbinary := proc(n) option remember; if(n <= 2) then RETURN(n); else RETURN((2^(fibinv(n)-2))+fibbinary(n-fibonacci(fibinv_deb(n)))); fi; end; # This gives all the patterns that are multiplied by 5 when applied to rule 90 # AND multiplied by 3 when applied to rule 150: (our indexing begins from 0) # The old formula gives only every second: # both90x5and150x3 := n -> 3*sum('(bit_i(A003714[n+1],i)*(4^i))','i'=0..A000523(A003714[n+1])); # Something fishy going on, check this later: both90x5and150x3 := n -> (2^((n+1) mod 2)) * 3*sum('(bit_i(A003714[floor((n+1)/2)+1],i)*(4^i))','i'=0..A000523(A003714[floor((n+1)/2)+1])); # Nope! this returns just a subset! # I had forgotten that there could be also three (or other odd number of) # zero-bits located between 1-bit pairs! # But we could derive a Binet-like formula for the following recursive # formula, and then do a somewhat similar trick as with fibbinary # # This counts the number of bit-sequences between 0 and (2^n - 1) # inclusive that contain only two 1-bit groups, separated at least # by two 0-locations. count_90x5_and_150x3 := proc(n) option remember; if(n <= 5) # Or 4 as 0-> 0, 1-> 1, 2-> 2, 3-> 3, 4-> 4, 5-> 5, 6-> 7 then RETURN(n); else RETURN(count_90x5_and_150x3(n-1)+count_90x5_and_150x3(n-4)); fi; end; count_150x7 := proc(n) option remember; if(n <= 3) then RETURN(n); else RETURN(count_150x7(n-1)+count_150x7(n-3)); fi; end; # A simplistic, brute force solution for finding the integral inverse # of the above function. We don't even try to optimize. # We could find a good starting point by using the inverse formula # of the Binet-like formula for the above one, involving the taking # of logarithm and roots of quartic equation, but for now, # this suffices. inv_of_n_1_plus_n_4 := proc(n) local i; for i from 0 to n do if(count_90x5_and_150x3(i+1) > n) then RETURN(i); fi; od; RETURN(-1); # Should not happen. end; inv_of_n_1_plus_n_3 := proc(n) local i; for i from 0 to n do if(count_150x7(i+1) > n) then RETURN(i); fi; od; RETURN(-1); # Should not happen. end; # This produces the sequence matching to ((0)*001)*(0*) # i.e. max 1 one-bit occur in each bit triplet. bin_001_seq := proc(n) option remember; if(n <= 2) then RETURN(n); else RETURN((2^(inv_of_n_1_plus_n_3(n)-1)) +bin_001_seq(n-count_150x7(inv_of_n_1_plus_n_3(n)))); fi; end; # This produces the sequence matching to ((0)*0001)*(0*) # i.e. max 1 one-bit occur in each range [bit i - bit i+3] bin_0001_seq := proc(n) option remember; if(n <= 2) then RETURN(n); else RETURN((2^(inv_of_n_1_plus_n_4(n)-1)) +bin_0001_seq(n-count_90x5_and_150x3(inv_of_n_1_plus_n_4(n)))); fi; end; bin0_0011_seq := n -> (3 * bin_0001_seq(n)); # Condition: rule150(n) = 7*n <=> Pattern: ((0)*001)*(0*) # That is, if bit i is 1, then bits i+1 and i+2 must be 0. # A subset of the following one: first_n_150x7 := proc(n) local j, k, a; a := []; j := 0; k := 1; while(k <= n) do if(rule150(j,1) = (7*j)) then a := [op(a), j]; k := k+1; fi; j := j+1; od; RETURN(a); end; # Condition: rule90(n) = 5*n <=> Pattern: ((0)*00(1?)1)*(0*) # That is, if bit i is 1, then bit i+2 (and of course i-2) must be 0. first_n_90x5 := proc(n) local j, k, a; a := []; j := 0; k := 1; while(k <= n) do if(rule90(j,1) = (5*j)) then a := [op(a), j]; k := k+1; fi; j := j+1; od; RETURN(a); end; # Condition: rule150(n) = 3*n <=> Pattern: ((0)*00(1*)11)*(0*) # That is, 1-bits occur only in groups of two or more, separated from # other groups of ones by at least two 0-bits. first_n_150x3 := proc(n) local j, k, a; a := []; j := 0; k := 1; while(k <= n) do if(rule150(j,1) = (3*j)) then a := [op(a), j]; k := k+1; fi; j := j+1; od; RETURN(a); end; # Condition: rule150(n) = 3*n and rule90(n) = 5*n <=> Pattern: ((0)*0011)*(0*) # That is, 1-bits occur only in pairs, separated from other pairs of # ones by at least two 0-bits. # The intersection of the two previous sequences. first_n_90x5_and_150x3 := proc(n) local j, k, a; a := []; j := 0; k := 1; while(k <= n) do if(((rule90(j,1) = (5*j)) and (rule150(j,1) = (3*j)))) then a := [op(a), j]; k := k+1; fi; j := j+1; od; RETURN(a); end; primorial_div_by_2 := proc(n) option remember; if(n <= 1) then RETURN(1); else RETURN(ithprime(n)*primorial_div_by_2(n-1)); fi; end; A033538seq := proc(n) option remember; if(n < 2) then RETURN(1); else RETURN(3*A033538seq(n-1)+A033538seq(n-2)+1); fi; end; A033539seq := proc(n) option remember; if(n < 3) then RETURN(1); else RETURN(2*A033539seq(n-1)+A033539seq(n-2)+1); fi; end; count_primes:=proc(a) local c, i; c := 0; i := 1; while i <= nops(a) do if(isprime(a[i])) then c := c+1; fi; i := i + 1; od; RETURN(c); end; collect_primes:=proc(a) local b, i; b := []; i := 1; while i <= nops(a) do if(isprime(a[i])) then b := [op(b),a[i]]; fi; i := i + 1; od; RETURN(b); end; collect_composites:=proc(a) local b, i; b := []; i := 1; while i <= nops(a) do if(not isprime(a[i])) then b := [op(b),a[i]]; fi; i := i + 1; od; RETURN(b); end; collect_prime_indices:=proc(a) local b, i; b := []; i := 1; while i <= nops(a) do if(isprime(a[i])) then b := [op(b),i]; fi; i := i + 1; od; RETURN(b); end; collect_composite_indices:=proc(a) local b, i; b := []; i := 1; while i <= nops(a) do if(not isprime(a[i])) then b := [op(b),i]; fi; i := i + 1; od; RETURN(b); end; collect_indices_of_n:=proc(n,a) local b, i; b := []; i := 1; while i <= nops(a) do if(n = a[i]) then b := [op(b),i]; fi; i := i + 1; od; RETURN(b); end; # factor_present(43, map(ifactor,some_seq)) # produces of a list of one-based indices where the factor 43 # is present. factor_present := proc(x,a) local i, b; b := []; for i from 1 to nops(a) do if(has(a[i],x)) then b := [op(b), i]; fi; od; RETURN(b); end; # The procedure for calculating the generation n (starting from # the generation 0: 1) of the one-dimensional Cellular Automata # sigma (rule 150) as a binary number: rule150:=proc(seed,n) option remember: local sl, i: if (0 = n) then (seed) else sl := A000523(seed+1); add(((bit_i(rule150(seed,n-1),i)+bit_i(rule150(seed,n-1),i-1)+bit_i(rule150(seed,n-1),i-2)) mod 2)*(2^i), i=0..((2*n)+sl)) fi: end: # Like rule150, but cut the produced binary numbers after the # central 1 column. I.e. divide each term of rule150 with 2^n # rule150cut:=proc(seed,n) local i: if (0 = n) then (seed) else add(((bit_i(rule150(seed,n-1),i+1+n-1)+bit_i(rule150(seed,n-1),i+n-1)+bit_i(rule150(seed,n-1),i-1+n-1)) mod 2)*(2^i), i=0..(n)) fi: end: # The procedure for calculating the generation n (starting from # the generation 0: 1) of the one-dimensional Cellular Automata # sigma-minus (rule 90) as a binary number: rule90:=proc(seed,n) option remember: local sl, i: if (0 = n) then (seed) else sl := A000523(seed+1); add(((bit_i(rule90(seed,n-1),i)+bit_i(rule90(seed,n-1),i-2)) mod 2)*(2^i), i=0..(2*n)+sl) fi: end: compute_new_cell:=proc(rule_x,r,p,i) local j; if(0 = ANDnos(rule_x,2^(add((bit_i(p,i+j)*(2^j)),j=0..(2*r))))) then RETURN(0); else RETURN(1); fi; end: apply_rule_x:=proc(rule_x,r,seed,n) option remember: local sl, i: if (0 = n) then (seed) else sl := A000523(seed+1); add(compute_new_cell(rule_x,r,apply_rule_x(rule_x,r,seed,n-1),(i-((2*r)))) *(2^i), i=0..(2*r*n)+sl); fi: end: # Rule 1721342310 is in hexadecimal `66999966` # this forms the NW->SE diagonal of any 90x150 array: apply_90x150_composite := (seed,n) -> apply_rule_x(1721342310,2,seed,n); # This is the conjugate rule of the above, and can be used to form # new double GoE's from any existing double GoE (to be proved...) apply96696996 := (seed,n) -> apply_rule_x(2523490710,2,seed,n); xor_1d_ca_rule:=proc(n) local j; RETURN(add((wt(ANDnos(n,j)) mod 2)*(2^j),j=0..(2^(A000523(n)+1)-1))); end; xor_1d_ca_rule_canonized:=proc(n) local j; RETURN(add((wt(ANDnos(n,j)) mod 2)*(2^j),j=0..(2^(A000523(n)+(A000523(n) mod 2)+1)-1))); end; bit_coords := proc(pattern,i,seed,r) local sequ, n; sequ := []; for n from 0 to A000523(pattern+1) do if(ANDnos(pattern,2^n) <> 0) then sequ := [op(sequ),[n-(i*r),-i]]; fi; od; RETURN(sequ); end; bit3coords := proc(pattern,x_offset,y,z) local sequ, pat, i; sequ := []; pat := pattern; for i from 0 to A000523(pattern+1) do if((`mod`(pat,2)) <> 0) then sequ := [op(sequ),[(i-x_offset),y,z]]; fi; pat := floor(pat/2); od; RETURN(sequ); end; # this works only with the symmetric patterns (that have bit-0 as 1): bit3coords_ends_only := proc(pattern,x_offset,y,z) RETURN([[(-x_offset),y,z],[(x_offset),y,z]]); end; plot90x150_3d_coords := proc(ini_seq,x_offset,y_offset,z_offset,ends_only) local coordseq, seq, subseq, x_off, x_off_for_this_row, y, z, i; coordseq := []; x_off_for_this_row := x_offset; z := 0; seq := ini_seq; while (nops(seq) <> 0) do x_off := x_off_for_this_row; y := 0; for i from 1 to nops(seq) do if((ends_only <> 0) and (z <> 0) and (y <> 0)) then subseq := bit3coords_ends_only(seq[i],x_off,y,z); else subseq := bit3coords(seq[i],x_off,y,z); fi; if(coordseq = []) then coordseq := op(subseq); else coordseq := coordseq,op(subseq); fi; x_off := x_off+1; y := y+y_offset; od; x_off_for_this_row := x_off_for_this_row + 1; z := z+z_offset; seq := SHIFTXORADJ(seq); od; RETURN(coordseq); end; plot_coords := proc(rule_x,r,seed,i) local pattern, sequ; sequ := []; pattern := seed; for n from 0 to i do if(sequ = []) then sequ := op(bit_coords(pattern,n,seed,r)); else sequ := sequ,op(bit_coords(pattern,n,seed,r)); fi; pattern := apply_rule_x(rule_x,r,pattern, 1); od; RETURN(sequ); end; plot_seq := proc(sequ,width,height); PLOT(POINTS(sequ),COLOUR(RGB,1,0,0),SYMBOL(POINT),VIEW(-200..200,-200..0)); end; # Tries to find a finite predecessor for n amongst the cell # patterns two cells (bits) shorter # (where n is considered as a finite cell pattern produced by rule 90), # and if such a pattern is found, returns it, # otherwise returns -1, as to mark that the n # belongs to a set of (extended) Garden of Eden patterns # in that rule. # (I.e. all patterns whose bit-weight (parity) is odd # are GoE in rule 90). # # Child: 1cba1 # Parent: 01x10 a = 0 xor x, x = 0 xor a = a # c = x xor 0, c = x = a; (c and a must be same!) # x = 0 xor c = c = a # # b = 1 xor 1, must be zero. # # 10001 11011 # 0 101 0 0 111 0 # # Child: 1dcba1 # Parent: 01yx10 # # x = 0 xor a = a = ~c # y = 1 xor b = ~b = d # c = x xor 1 = ~x = ~a # d = y xor 0 = y = ~b # # d must <> b # c must <> a # # x = a = ~c # y = ~b = d # # dcba dcba dcba dcba # 543210 # 100111 101101 110011 111001 # 0101100 010010 011110 011010 # ba cba # c rule90reverse:=proc(n) local l, i, a, b, c, s; # if (0 = n) then (0) else a := 0; b := 0; s := 0; l := A000523(n); for i from 0 to l do c := ((a + bit_i(n,i)) mod 2); s := s + c*(2^i); a := b; b := c; od; # printf(`a=%a, b=%a, c=%a, s=%a, i=%a, l=%a\n`, a, b, c, s, i, l); if(0 = (a+b)) then RETURN(s); else RETURN(-1); fi; # fi: end: # # Child: 1cba1 # Parent: 01x10 # # a = 0 xor 1 xor x = ~x; x = ~a # b = 1 xor x xor 1 = x # c = x xor 1 xor 0 = ~x = ~b = a # # # 10101 11011 # 0 111 0 0 101 0 # rule150reverse:=proc(n) local l, i, a, b, c, s; if (0 = n) then (0) else a := 0; b := 0; s := 0; l := A000523(n); for i from 0 to l do c := ((a + b + bit_i(n,i)) mod 2); s := s + c*(2^i); a := b; b := c; od; # printf(`a=%a, b=%a, c=%a, s=%a, i=%a, l=%a\n`, a, b, c, s, i, l); if(0 = (a+b)) then RETURN(s); else RETURN(-1); fi; fi: end: poly11xreverse:=proc(n) local l, i, a, b, c, x, s; if (0 = n) then (0) else a := 0; b := 0; c := 0; s := 0; l := A000523(n); for i from 0 to l do x := ((a + c + bit_i(n,i)) mod 2); s := s + x*(2^i); a := b; b := c; c := x; od; # printf(`a=%a, b=%a, c=%a, x=%a, s=%a, i=%a, l=%a\n`, a, b, c, x, s, i, l); if(0 = (a+b+c)) then RETURN(s); else RETURN([a,b,c,x]); fi; fi; end; # Try to divide n with d, returns quotient if succeeds, # something else if not divisible. (e.g. -remainder or such thing) Xdivide:=proc(n,d) local k, l, i, m, w, x, s; if (0 = n) then (0) else w := 0; l := A000523(n); k := A000523(d); # Width of divisor (-1) m := 2^(k+1); s := 0; for i from 0 to l do w := ((w*2) mod m); x := (wt(ANDnos((w+bit_i(n,i)),d)) mod 2); # printf(`i=%a, w=%a, x=%a, s=%a, bit_i(n,%a)=%a, ANDnos((w+bit_i(n,i)),d)=%a\n`, # i,w,x,s, i, bit_i(n,i), ANDnos((w+bit_i(n,i)),d)); if(x <> 0) then s := s + (2^i); fi; w := w+x; od; # printf(`i=%a, w=%a, x=%a, s=%a, bit_i(n,i)=%a, ANDnos((w + bit_i(n,i)),d)=%a\n`, # i,w,x,s, bit_i(n,i), ANDnos((w + bit_i(n,i)),d)); if(0 = (w mod (2^k))) then RETURN(s); else RETURN(-w); fi; fi; end; Xdivided_by_one_of:=proc(n,a) local d,m; m := 2^A000523(n); # 4->4, 7->4, 63->32 for d in a do if(d >= m) then RETURN(0); fi; if(Xdivide(n,d) > 0) then RETURN(d); fi; od; RETURN(0); end; Xerasthotenes:=proc(upto_n) local b,i,j; b:=[]; for i from 1 to upto_n do j := (i*2)+1; if(0 = Xdivided_by_one_of(j,b)) then b := [op(b),j]; fi; od; RETURN(b); end; Xfactorize:=proc(nn,a) local n,b,d; n:=nn; b:=[]; d := Xdivided_by_one_of(n,a); while (0 <> d) do b := [op(b),d]; n := Xdivide(n,d); d := Xdivided_by_one_of(n,a); od; RETURN([op(b),n]); end; # Xprimes5000 := Xerasthotenes(5000); Xcomposites_that_are_prime_in_Z:=proc(upto_n,a) local b,i,j,d; b:=[]; for i from 2 to upto_n do j := ithprime(i); d := Xdivided_by_one_of(j,a); if(0 <> d) # and (d <> j) then b := [op(b),j]; fi; if(0 = (i mod 1000)) then printf(`%a\n`, b); fi; od; RETURN(b); end; Xdivide_nicht_werke:=proc(n,d) local k, l, i, m, w, x, s, dm; if (0 = n) then (0) else w := 0; l := A000523(n); k := A000523(d); # Width of divisor (-1) m := 2^(k+1); dm := floor(d/2); s := 0; for i from 0 to l do x := ((wt(ANDnos(w,dm)) + bit_i(n,i)) mod 2); printf(`i=%a, w=%a, x=%a, s=%a, bit_i(n,i)=%a, ANDnos(w,dm)=%a\n`, i,w,x,s, bit_i(n,i), ANDnos(w,dm)); if(x <> 0) then s := s + (2^i); fi; w := ((w*2) mod m) + x; od; printf(`i=%a, w=%a, x=%a, s=%a, bit_i(n,i)=%a, ANDnos(w,dm)=%a\n`, i,w,x,s, bit_i(n,i), ANDnos(w,dm)); if(0 = w) then RETURN(s); else RETURN(-w); fi; fi; end; # Try to divide GF(2)[X] polynomial mm with another polynomial nn. Xdivide_ei_valmis := proc(mm,nn) local n,m,q,r,l,i,h,k; m := mm; n := nn; i := A000523(m); # Width of dividend in bits (-1). l := A000523(n); # Width of divisor in bits (-1). q := 0; h := 0; while ((k < l) and (i >= 0)) do q := q*2; if(k < l) then h := ((h * 2) + bit_i(m,i)); k := k+1; else h := XORnos(h,nn); q := q+1; k := A000523(h); # if(k < l) fi; i := i-1; k := k+1; od; RETURN([q,h]); end; # # Here we do binary addition in disguise, so as to keep the # sequence term a(n+1) strictly dependent only of the # previous term a(n). That is, we deduce "what the carry should be" # by examining what the sum bit (m0) of bits m2 and m1 is. # # +-----+ # |Carry| # +-----+-----+ # | a | x | # +-----+-----+ # | b | y | # +-----+-----+ # | c | z | # +-----+-----+ # # Carry = (((x XOR y) AND (NOT z)) OR (x AND y)) # # x, y, z Carry xyz zyx # # 0 0 0 0 0 0 # # 0 1 1 0 3 6 # # 1 0 1 0 5 5 # # 1 1 0 1 6 3 # # 0 0 1 0 1 4 # # 0 1 0 1 2 2 # # 1 0 0 1 1 1 # # 1 1 1 1 7 7 # # # vertfibo_math:=proc(n) option remember; local a, b, c, i, j, k, l, s, x, y, z; if (0 = n) then (6) else a := 0; b := 0; s := 0; x := 0; y := 0; k := 3*(2^(n-1)); l := 3*(2^n); j := 0; for i from 0 to l do z := bit_i(vertfibo(n-1),(j)); # j := (i mod k); c := (a + b + (`if`((x = y),x,((z+1) mod 2))) mod 2); s := s + c*(2^i); a := b; b := c; x := y; y := z; j := j + 1; if(j = k) then j := 0; fi; od; RETURN(s); fi: end: vertfibo:=proc(n) option remember; local a, b, c, i, j, k, l, s, x, y, z; if (0 = n) then (6) else a := 0; b := 0; s := 0; x := 0; y := 0; k := 3*(2^(n-1)); l := 3*(2^n); j := 0; for i from 0 to l do z := bit_i(vertfibo(n-1),(j)); # j := (i mod k); c := (a + b + (`if`((x = y),x,(z+1))) mod 2); if(c <> 0) then s := s + (2^i); fi; a := b; b := c; x := y; y := z; j := j + 1; if(j = k) then j := 0; fi; od; RETURN(s); fi: end: vertfibo_next:=proc(n,prev) local a, b, c, i, j, k, l, s, x, y, z; if (0 = n) then (6) else a := 0; b := 0; s := 0; x := 0; y := 0; k := 3*(2^(n-1)); l := 3*(2^n); j := 0; for i from 0 to l do z := bit_i(prev,(j)); # j := (i mod k); c := (a + b + (`if`((x = y),x,(z+1))) mod 2); if(c <> 0) then s := s + (2^i); fi; a := b; b := c; x := y; y := z; j := j + 1; if(j = k) then j := 0; fi; od; RETURN(s); fi: end: # We implement rule96696996reverse analogously to rule150reverse # # Child: 1edcba1 # Parent: 001x100 # # a = 0 xor 0 xor 0 xor 1 xor x = ~x; x = ~a # b = 0 xor 0 xor 1 xor x xor 1 = x; x = b # c = 0 xor 1 xor x xor 1 xor 0 = x = b = ~a # # # Check this formula! rule96696996reverse:=proc(n) local l, i, a, b, c, d, e, s; if (0 = n) then (0) else a := 0; b := 0; c := 0; d := 0; e := 0; s := 0; l := A000523(n); for i from 0 to l do e := ((a + b + c + d + bit_i(n,i)) mod 2); s := s + e*(2^i); a := b; b := c; c := d; d := e; od; # printf(`a=%a, b=%a, c=%a, d=%a, e=%a, s=%a, i=%a, l=%a\n`, a, b, c, d, e, s, i, l); if(0 = (a+b+c+d)) then RETURN(s); else RETURN(-1); fi; fi: end: # Find the [f,g,h,i], that is the family patriarch, rule90 count # and rule150 count and rule96696996 count. # family90x150x96696996:=proc(n) local nn, old_nn, g, h, i; if (0 = n) then ([0,0,0]) else g := -1; h := -1; i := -1; nn := n; while nn <> -1 do old_nn := nn; nn := rule90reverse(nn); g := g + 1; od; nn := old_nn; while nn <> -1 do old_nn := nn; nn := rule150reverse(nn); h := h + 1; od; nn := old_nn; while nn <> -1 do old_nn := nn; nn := rule96696996reverse(nn); i := i + 1; od; print([old_nn,g,h,i]); RETURN([old_nn,g,h,i]); fi: end: is90x150x96696996patriarch:= n -> RETURN((-1 = rule90reverse(n)) and (-1 = rule150reverse(n)) and (-1 = rule96696996reverse(n))); # First N patriarchs first_n_patriarchs := proc(n) local j, k, a, candidate; a := []; j := 1; k := 1; while(k <= n) do candidate := j; if(is90x150x96696996patriarch(candidate)) then a := [op(a), candidate]; k := k+1; fi; j := j+1; od; RETURN(a); end; # First N even palindrome patriarchs first_n_ep_patriarchs := proc(n) local j, k, a, candidate; a := []; j := 1; k := 1; while(k <= n) do candidate := binpal_lr_even(j); if(is90x150x96696996patriarch(candidate)) then a := [op(a), candidate]; k := k+1; fi; j := j+1; od; RETURN(a); end; # First N odd palindrome patriarchs first_n_op_patriarchs := proc(n) local j, k, a, candidate; a := []; j := 1; k := 1; while(k <= n) do candidate := binpal_lr_odd(j); if(is90x150x96696996patriarch(candidate)) then a := [op(a), candidate]; k := k+1; fi; j := j+1; od; RETURN(a); end; collect_90_lt_and_gt_150_lists := proc(n) local j, a, b; a := []; b := []; j := 1; while(j <= n) do if(rule90(j,1) < rule150(j,1)) then a := [op(a), j]; else b := [op(b), j]; fi; j := j+1; od; RETURN([a, b]); end; extended_A020652 := [0,1,1,1,2,1,3,1,2,3,4,1,5,1,2,3,4,5,6,1,3,5,7,1,2,4,5,7,8,1,3,7,9,1,2,3,4,5,6,7,8,9,10,1,5,7,11,1,2,3,4,5,6,7,8,9,10,11,12,1,3,5,9,11,13,1,2,4,7,8,11,13,14,1,3,5,7,9,11,13,15,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,1,5]; # Numerators in canonical bijection from positive integers to positive rationals. extended_A020653 := [1,0,1,2,1,3,1,4,3,2,1,5,1,6,5,4,3,2,1,7,5,3,1,8,7,5,4,2,1,9,7,3,1,10,9,8,7,6,5,4,3,2,1,11,7,5,1,12,11,10,9,8,7,6,5,4,3,2,1,13,11,9,5,3,1,14,13,11,8,7,4,2,1,15,13,11,9,7,5,3,1,16,15,14,13,12,11,10,9,8,7,6,5,4,3,2,1,17]; # Denominators in canonical bijection from positive integers to positive rationals. org_reduced_residue_set := proc(n) local a,i; a := []; for i from 1 to (n-1) do if (1 = igcd(n,i)) then a := [op(a),i]; fi; od; RETURN(a); end; reduced_residue_set := proc(n) local a,b,i; a := []; b := []; if (2 = n) then RETURN([1]); fi; for i from 1 to floor(n/2) do if (1 = igcd(n,i)) then a := [op(a),i]; b := [(n-i),op(b)]; fi; od; RETURN([op(a),op(b)]); end; reversed_reduced_residue_set := proc(n) local a,b,i; a := []; b := []; if (2 = n) then RETURN([1]); fi; for i from 1 to floor(n/2) do if (1 = igcd(n,i)) then a := [i,op(a)]; b := [op(b),(n-i)]; fi; od; RETURN([op(b),op(a)]); end; reduced_residue_set_0_1_array_blah := proc(n) local a,b,i,e; a := []; b := []; if (2 = n) then RETURN([1]); fi; for i from 1 to floor(n/2) do if (1 = igcd(n,i)) then e := 1; else e := 0; fi; a := [op(a),e]; b := [e,op(b)]; od; RETURN([op(a),op(b)]); end; A003989seq_fun := n -> igcd( ((n-((trinv(n)*(trinv(n)-1))/2))+1), ((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1) ); # A003989seq := [seq(A003989seq_fun(j),j=0..30)]; # A003989seq := [1, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 2, 3, 2, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 4, 1, 2, 1, 1, 1, 3]; # one_or_zero := n -> `if`((1 = n),(1),(0)); reduced_residue_set_0_1_array := n -> one_or_zero(igcd( ((n-((trinv(n)*(trinv(n)-1))/2))+1), ((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1) )); # Funny, but this produces the same result, when n is given from 1 onward: rrs_0_1_array := (n) -> one_or_zero(igcd((n-((trinv(n-1)*(trinv(n-1)-1))/2)),(trinv(n-1)+1))); # This does not make much sense: legendre_array := n -> (legendre(ithprime ((n-((trinv(n)*(trinv(n)-1))/2))+1), ithprime((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1) )); # This makes more sense. When n begins from 1, x and y both begin from 1. x_y_columnwise:= (n) -> ([((n-((trinv(n-1)*(trinv(n-1)-1))/2))),(trinv(n-1)+1)]); # [seq(x_y_columnwise(j),j=1..55)]; # [[1, 2], [1, 3], [2, 3], [1, 4], [2, 4], [3, 4], [1, 5], [2, 5], [3, 5], [4, 5], [1, 6], [2, 6], [3, 6], [4, 6], [5, 6], # [1, 7], [2, 7], [3, 7], [4, 7], [5, 7], [6, 7], [1, 8], [2, 8], [3, 8], [4, 8], [5, 8], [6, 8], [7, 8], # [1, 9], [2, 9], [3, 9], [4, 9], [5, 9], [6, 9], [7, 9], [8, 9], # [1, 10], [2, 10], [3, 10], [4, 10], [5, 10], [6, 10], [7, 10], [8, 10], [9, 10], # [1, 11], [2, 11], [3, 11], [4, 11], [5, 11], [6, 11], [7, 11], [8, 11], [9, 11], [10, 11]] # triangle_row_wise := (n) -> ([(trinv(n-1),(n-((trinv(n-1)*(trinv(n-1)-1))/2)))]); # [seq(triangle_row_wise(j),j=1..21)]; # -> [[1, 1], [2, 1], [2, 2], [3, 1], [3, 2], [3, 3], [4, 1], [4, 2], [4, 3], [4, 4], [5, 1], [5, 2], [5, 3], [5, 4], [5, 5], # [6, 1], [6, 2], [6, 3], [6, 4], [6, 5], [6, 6]] # # Table-wise, 0-based: # [seq([(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n), (n-((trinv(n)*(trinv(n)-1))/2)) ],n=0..27)]; # [[0, 0], [1, 0], [0, 1], [2, 0], [1, 1], [0, 2], [3, 0], [2, 1],[1, 2], # [0, 3], [4, 0], [3, 1], [2, 2], [1, 3], [0, 4], [5, 0], [4, 1], [3, 2], [2, 3], [1, 4], # [0, 5], [6, 0], [5, 1], [4, 2], [3, 3], [2, 4], [1, 5], [0, 6]] # Table-wise, 1-based: # [seq([(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1, 1+(n-((trinv(n)*(trinv(n)-1))/2)) ],n=0..27)]; quadres_array := (n) -> (quadres((n-((trinv(n-1)*(trinv(n-1)-1))/2)),(trinv(n-1)+1))); quadres_0_1_array := (n) -> one_or_zero(quadres((n-((trinv(n-1)*(trinv(n-1)-1))/2)),(trinv(n-1)+1))); sum2distinct_squares_array := (n) -> (((n-((trinv(n-1)*(trinv(n-1)-1))/2))^2)+((trinv(n-1)+1)^2)); # Quadratic Residue Set to binary code: A055094 := proc(n) local i,z; # = Was qrs2bincode z := 0; for i from 1 to n-1 do z := z*2; if (1 = quadres(i,n)) then z := z + 1; fi; od; RETURN(z); end; # ithprime_has_totally_balanced_qrs. A080110 is the characteristic function of A080112 A080110 := n -> A080116(A080117(n)); # ithprime_has_not_totally_balanced_qrs A080111 := n -> 1-A080116(A080117(n)); # find_nth_prime_with_tbbs A080112 := proc(n) option remember; local i; if(1 = n) then RETURN(2); fi; # The 2nd prime = 3 is the first. i := A080112(n-1)+1; while(i > 0) # I.e. indefinitely. do if(A080110(i) > 0) then RETURN(i); fi; i := i+1; od; end; # find_nth_prime_with_no_tbbs. A080113 is complement to A080112. A080113 := proc(n) option remember; local i; if(1 = n) then RETURN(1); fi; # The first prime = 2 is the first. i := A080113(n-1)+1; while(i > 0) # I.e. indefinitely. do if(A080111(i) > 0) then RETURN(i); fi; i := i+1; od; end; A080114 := n -> ithprime(A080112(n)); A080115 := n -> ithprime(A080113(n)); A080114v2 := proc(upto_n) local j,a,p,i,s; a := []; for i from 2 to upto_n do p := ithprime(i); s := 0; for j from 1 to (p-1)/2 do s := s + legendre(j,p); if(s < 0) then break; fi; od; if(s >= 0) then a := [op(a),p]; fi; od; RETURN(a); end; # Ugly, ugly, ugly: A080261 := proc(n) local w; w := floor(A070939(n)/2); RETURN(((2^w)*floor(n/(2^w)))+(((2^w)-1)-ANDnos(n,(2^w)-1))); end; # is_totally_balanced_seq. The characteristic function of A014486. A080116 := proc(n) local c,lev; lev := 0; c := n; while(c > 0) do lev := lev + (-1)^c; c := floor(c/2); if(lev < 0) then RETURN(0); fi; od; if(lev > 0) then RETURN(0); else RETURN(1); fi; end; A080300 := n -> `if`((0 = n) or (0 = A080116(n)),0,A014137(((A000523(n)+1)/2)-1)+A080301(n)); A080301 := n -> `if`(0 = A080116(n),-1,CatalanRank((A000523(n)+1)/2,n)); # qrs_for_primes_forced_compl_sym A080117 := proc(n) local c,p; p := ithprime(n); c := A055094(p); if(3 = (p mod 4)) then RETURN(c); else RETURN(A080261(c)); fi; end; A080118 := n -> A080117(A080112(n)); # Only valid TBBS'es A080119 := n -> CatalanRankGlobal(A080118(n)); A080120 := n -> convert(A080118(n),binary); A080146 := n -> A055094(ithprime(n)); # Gives A054432. rrs2bincode := proc(n) local i,z; z := 0; for i from 1 to n-1 do z := z*2; if (1 = igcd(n,i)) then z := z + 1; fi; od; RETURN(z); end; # Phi_at_x(j,2) gives A019320: Phi_at_x := (n,y) -> subs(x=y,cyclotomic(n,x)); A054432_for_p_to_e := (p,e) -> Phi_at_x(p^e,2)*(((2^(p^(e-1)))-1)*((2^(p-1))-1))/((2^p)-1); # Bloom, D.M. "On the Coefficients of the Cyclotomic Polynomials." Amer.Math.Monthly 75, 372-377, 1968. # (Which says that the coefficients of odd terms (with odd exponent) change sign when moving from odd n to 2n) # # See Lam, T.Y. and Leung, K.H. "On the Cyclotomic Polynomial Phi_pq(X)", Amer.Math.Monthly 103, 562-564, 1996. # and Lenstra, H. "Vanishing sums of roots of unity", in Proc. Bicentennial Congress Wiskundig Genootschap (Vrije Univ. Amsterdam, 1978), Part II, pp. 249-268 # Find's p's inverse modulo q: inv_p_mod_q := (p,q) -> op(2,op(1,msolve(p*x=1,q))); # [seq(dilate(j,2,2),j=0..40)]; gives A000695 # [seq(dilate(j,2,3),j=0..40)]; gives A033045 # [seq(dilate(j,2,4),j=0..40)]; gives A033052 # [seq(dilate(j,3,2),j=0..40)]; gives A037314/A037457 dilate := proc(nn,x,e) local n,i,s; n := nn; i := 0; s := 0; while(n > 0) do s := s + (((x^e)^i)*(n mod x)); n := floor(n/x); i := i+1; od; RETURN(s); end; # every_other_pos(n,2,0) takes all even-positioned bits, # every_other_pos(n,2,1) takes all odd-positioned bits, # every_other_pos(n,3,0) takes all even-positioned trits, # every_other_pos(n,3,1) takes all odd-positioned trits # etc. # Note that every_other_pos(j,k,0)+every_other_pos(j,k,1) # gives always j back intact. every_other_pos := proc(nn,x,w) local n,i,s; n := nn; i := 0; s := 0; while(n > 0) do if((i mod 2) = w) then s := s + ((x^i)*(n mod x)); fi; n := floor(n/x); i := i+1; od; RETURN(s); end; # Handles all n of the form p^e, p^e * q^f, 2^d * p^e * q^f # where p and q are distinct odd primes. # Thus this is good upto 104, because 105 = 3*5*7 is the # first number with three distinct odd prime factors. # Handles all x > 1 that are integers. # Handles also x = -2 upto 29. # (Functions every_other_pos and dilate don't handle negative bases.) Phi_pos_terms := proc(n,x) local a,m,p,q,e,f,r,s; if(n < 2) then RETURN(x); fi; a := op(2,ifactors(n)); m := nops(a); p := a[1][1]; e := a[1][2]; if(1 = m) then RETURN(((x^(p^e))-1)/((x^(p^(e-1)))-1)); fi; if(2 = m) then q := a[2][1]; f := a[2][2]; r := inv_p_mod_q(p,q)-1; s := inv_p_mod_q(q,p)-1; RETURN( (`if`(0=s,1,(((x^((s+1)*((q^f)*(p^(e-1)))))-1)/((x^((q^f)*(p^(e-1))))-1)))) * (`if`(0=r,1,(((x^((r+1)*((p^e)*(q^(f-1)))))-1)/((x^((p^e)*(q^(f-1))))-1)))) ); fi; if((3 = m) and (2 = p)) then if(1 = e) then RETURN(every_other_pos(Phi_pos_terms(n/2,x),x,0)+every_other_pos(Phi_neg_terms(n/2,x),x,1)); else RETURN(dilate(Phi_pos_terms((n/(2^(e-1))),x),x,2^(e-1))); fi; else printf(`Cannot handle argument %a with three or more distinct odd prime factors!\n`,n); RETURN(0); fi; end; Phi_neg_terms := proc(n,x) local a,m,p,q,e,f,r,s; if(n < 2) then RETURN(n); fi; a := op(2,ifactors(n)); m := nops(a); p := a[1][1]; e := a[1][2]; if(1 = m) then RETURN(0); fi; if(2 = m) then q := a[2][1]; f := a[2][2]; r := inv_p_mod_q(p,q)-1; s := inv_p_mod_q(q,p)-1; RETURN( x^((s+1)*(q^f)*(p^(e-1))) * x^((r+1)*(p^e)*(q^(f-1))) * x^(-((p^e) * (q^f))) * (`if`((p-2)=s,1,(((x^((p-s-1)*((q^f)*(p^(e-1)))))-1)/((x^((q^f)*(p^(e-1))))-1)))) * (`if`((q-2)=r,1,(((x^((q-r-1)*((p^e)*(q^(f-1)))))-1)/((x^((p^e)*(q^(f-1))))-1)))) ); fi; if((3 = m) and (2 = p)) then if(1 = e) then RETURN(every_other_pos(Phi_neg_terms(n/2,x),x,0)+every_other_pos(Phi_pos_terms(n/2,x),x,1)); else RETURN(dilate(Phi_neg_terms((n/(2^(e-1))),x),x,2^(e-1))); fi; else printf(`Cannot handle argument %a with three or more distinct odd prime factors!\n`,n); RETURN(0); fi; end; check_Phi_funs := proc(upto_n,x) local a,b,i,t,u,s; s := []; for i from 0 to upto_n do a := Phi_at_x(i,x); t := Phi_pos_terms(i,x); u := Phi_neg_terms(i,x); b := t-u; if(a <> b) then printf(`Phi_at_x(%a,%a) <> %a - %a\n`,i,x,t,u); s := [op(s),i]; fi; od; RETURN(s); end; canonical_fractions_of_n := proc(n) local a,b,i; a := []; b := []; if (2 = n) then RETURN([1/1]); fi; for i from 1 to floor(n/2) do if (1 = igcd(n,i)) then a := [op(a),(i/(n-i))]; b := [((n-i)/i),op(b)]; fi; od; RETURN([op(a),op(b)]); end; # Gives A020652/A020653: org_canonical_fractions := proc(u) local a,n,i; a := []; for n from 2 to u do for i from 1 to n do if (1 = igcd(n,i)) then a := [op(a),(i/(n-i))]; fi; od; od; RETURN(a); end; canonical_fractions := proc(u) local a,b,n,i; a := []; for n from 2 to u do if (2 = n) then a := [op(a),1]; else b := []; for i from 1 to floor(n/2) do if (1 = igcd(n,i)) then a := [op(a),(i/(n-i))]; b := [((n-i)/i),op(b)]; fi; od; a := [op(a),op(b)]; fi; od; RETURN(a); end; ReverseNextPhi_n_elements_permutation := proc(u) local m,a,n,k,i; a := []; k := 0; for n from 2 to u do m := k + phi(n); for i from 1 to phi(n) do a := [op(a),m]; m := m-1; k := k+1; od; od; RETURN(a); end; A020650 := n -> `if`((n < 2),n,`if`(type(n,even),A020650(n/2)+A020651(n/2),A020651(n-1))); A020651 := n -> `if`((n < 2),n,`if`(type(n,even),A020651(n/2),A020650(n-1))); A086592 := n -> A020650(n)+A020651(n); A086592v2 := n -> A020650(2*n); A086593 := n -> A086592((2*n)-1); A086593v2 := n -> A020650((4*(n-1))+2); # A020652 := map(op,[seq(reduced_residue_set(j),j=2..29)]); # A020652 := [1,1,2,1,3,1,2,3,4,1,5,1,2,3,4,5,6,1,3,5,7,1,2,4,5,7,8,1,3,7,9,1,2,3,4,5,6,7,8,9,10,1]; # A020563 := map(op,[seq(reversed_reduced_residue_set(j),j=2..29)]); # A020563 := [1,2,1,3,1,4,3,2,1,5,1,6,5,4,3,2,1,7,5,3,1,8,7,5,4,2,1,9,7,3,1,10,9,8,7,6,5,4,3,2,1,11]; # A038566 Sequence: 1,1,1,2,1,3,1,2,3,4,1,5,1,2,3,4,5,6,1,3,5,7,1,2,4,5,7,8,1 # The nth "clump" consists of integers <= n and prime to n. # 1/1, 1/2, 1/3, 2/3, 1/4, 3/4, 1/5, 2/5, 3/5 # A038567 Sequence: 1,2,3,3,4,4,5,5,5,5,6,6,7,7,7,7,7,7,8,8,8,8,9,9,9,9,9,9,10 # n occurs phi(n) times. A038566_per_A038567 := proc(u) local a,n,i; a := []; for n from 1 to u do for i from 1 to n do if (1 = igcd(n,i)) then a := [op(a),(i/n)]; fi; od; od; RETURN(a); end; A038567_per_A038566 := proc(u) local a,n,i; a := []; for n from 1 to u do for i from 1 to n do if (1 = igcd(n,i)) then a := [op(a),(n/i)]; fi; od; od; RETURN(a); end; # # perm1seq := [0,1,3,2,7,4,15,6,5,8,31,16,63,14,12,11,9,32,127,13,10,64,255, # 30,24,23,17,128,511,28,19,256,1023,62,29,27,48,47,20,18,33, # 512,2047,25,22,1024,4095,126,60,56,26,96,95,21,39,35,65,2048, # 8191,61,55,40,34,4096,16383,254,59,192,191,36,129,8192,32767, # 124,112,49,46,79,67,16384,65535,510,125,120,57,111,51,384,383, # 44,80,38,71,66,257,32768,131071,58,52,43,37,65536,262143,1022, # 252,123,119,224,54,50,768,767,45,41,159,72,68,131,513,131072, # 524287,253,223,97,94,160,130,262144] # # A007306 (Formerly M0437) # Sequence: 1,1,2,3,3,4,5,5,4,5,7,8,7,7,8,7,5,6,9,11,10,11,13,12,9,9,12, # 13,11,10,11,9,6,7,11,14,13,15,18,17,13,14,19,21,18,17,19,16, # 11,11,16,19,17,18,21,19,14,13,17,18,15,13,14,11,7,8,13,17, # 16,19,23,22,17,19 # Name: Denominators of Farey (or Stern-Brocot) tree fractions. # (also: numerators of the right hand side?) # # 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 # # Right Side of Stern-Brocot tree: 1/1 2/1 3/2 3/1 4/3 5/3 5/2 4/1 5/4 7/5 8/5 7/4 7/3 8/3 7/2 5/1 # # A038567/A038566: 1/1 2/1 3/1 3/2 4/1 4/3 5/1 5/2 5/3 5/4 6/1 6/5 7/1 7/2 7/3 7/4 # # A038567/A038566[n] = Right Side of Stern-Brocot Tree[perm1seq[n]] = shift_left(A007306)/A047679[perm1seq[n]] # # Left Side of Stern-Brocot tree 1/1 1/2 2/3 1/3 3/4 3/5 2/5 1/4 4/5 5/7 5/8 4/7 3/7 3/8 2/7 1/5 # traversed with right to left order # # A038566/A038567: 1/1 1/2 1/3 2/3 1/4 3/4 1/5 2/5 3/5 4/5 1/6 5/6 1/7 2/7 3/7 4/7 # A038567_A038566_to_SternBrocot_permutation_minus_one := proc(u) local a,n,i; a := []; for n from 1 to u do for i from 1 to n do if (1 = igcd(n,i)) then a := [op(a),cfrac2binexp(convert((n/i),confrac))]; fi; od; od; RETURN(a); end; A038567_A038566_to_SternBrocot_permutation := proc(u) local a,n,i; a := []; for n from 1 to u do for i from 1 to n do if (1 = igcd(n,i)) then a := [op(a),cfrac2binexp(convert((n/i),confrac))+1]; fi; od; od; RETURN(a); end; # seq_a := canonical_fractions_to_whole_SternBrocot_permutation_in_wrong_way(20); # [1,2,3,5,7,11,4,6,15,23,31,47,10,8,12,14,63,95,9,13,127,191,22,16,24,30,255,383,20,28,511,767,46,21,19,32,48,27,29,62,1023,1535,17] # 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 # # 1 2 3 4 7 8 5 6 13 19 # # Whole Stern Brocot Tree: 1/1 1/2 2/1 1/3 2/3 3/2 3/1 1/4 2/5 3/5 3/4 4/3 5/3 5/2 4/1 1/5 2/7 # # Canonical Fractions: 1/1 1/2 2/1 1/3 3/1 1/4 2/3 3/2 4/1 1/5 5/1 1/6 2/5 3/4 4/3 5/2 6/1 1/7 3/5 5/3 7/1 # # 1 2 3 4 7 8 5 6 15 16 Sought after! canonical_fractions_to_whole_SternBrocot_permutation := proc(u) local a,n,i; a := []; for n from 2 to u do for i from 1 to n-1 do if (1 = igcd(n,i)) then a := [op(a),frac2position_in_whole_SB_tree(i/(n-i))]; fi; od; od; RETURN(a); end; canonical_fractions_to_whole_SternBrocot_permutation_in_array_form := proc(u) local a,n,i; a := []; for n from 2 to u do for i from 1 to n-1 do if (1 = igcd(n,i)) then a := [op(a),frac2position_in_whole_SB_tree(i/(n-i))]; else a := [op(a),0]; fi; od; od; RETURN(a); end; position_in_whole_SB_tree_or_zero := (n,m) -> `if`((1 = gcd(n,m)),(frac2position_in_whole_SB_tree(n/m)),(0)); A54424_as_array := n -> position_in_whole_SB_tree_or_zero( ((n-((trinv(n)*(trinv(n)-1))/2))+1), ((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1) ); canonical_fractions_to_whole_SternBrocot_permutation_in_wrong_way := proc(u) local a,b,n,i,k,msb; a := []; for n from 2 to u do if (2 = n) then a := [op(a),1]; else b := []; for i from 1 to floor(n/2) do if (1 = igcd(n,i)) then k := cfrac2binexp(convert(((n-i)/i),confrac)); msb := A000523(k); a := [op(a), ((2^(msb+1)) + k - (2^msb))]; b := [((2^(msb+1))+k),op(b)]; fi; od; a := [op(a),op(b)]; fi; od; RETURN(a); end; canonical_fractions_to_whole_SternBrocot_permutation_in_wrong_way2 := proc(u) local w,a,b,n,i,k,msb; w := []; for n from 2 to u do if (2 = n) then w := [op(w),1]; else a := []; b := []; for i from 1 to floor(n/2) do if (1 = igcd(n,i)) then k := cfrac2binexp(convert(((n-i)/i),confrac)); msb := A000523(k); a := [((2^(msb+1)) + k - (2^msb)),op(a)]; b := [((2^(msb+1))+k),op(b)]; fi; od; w := [op(w),op(a),op(b)]; fi; od; RETURN(w); end; cfrac2binexp := proc(c) local i,e,n; n := 0; for i from 1 to nops(c) do e := c[i]; if(i = nops(c)) then e := e-1; fi; n := ((2^e)*n) + ((i mod 2)*((2^e)-1)); od; RETURN(n); end; # Range: rationals in open interval ]0,1[ frac2position_in_0_1_SB_tree := r -> RETURN(ReflectBinTreePermutation(cfrac2binexp(convert(1/r,confrac)))); frac2position_in_whole_SB_tree := proc(r) local k,msb; if(1 = r) then RETURN(1); else if(r > 1) then k := cfrac2binexp(convert(r,confrac)); else k := ReflectBinTreePermutation(cfrac2binexp(convert(1/r,confrac))); fi; msb := A000523(k); if(r > 1) then RETURN(k + (2^(msb+1))); else RETURN(k + (2^(msb+1)) - (2^msb)); fi; fi; end; sbtree_perm_1_1_left := x -> (`if`((x <= 0),x,(`if`((x < 1),(x/(1+x)),(`if`((x < 2),(1/(3-x)),(x-1))))))); sbtree_perm_1_1_right := x -> (`if`((x <= 0),x,(`if`((x < (1/2)),(x/(1-x)),(`if`((x < 1),(3-(1/x)),(x+1))))))); A065249 := n -> frac2position_in_whole_SB_tree((SternBrocotTreeNum(n)/SternBrocotTreeDen(n))/2); A065250 := n -> frac2position_in_whole_SB_tree((SternBrocotTreeNum(n)/SternBrocotTreeDen(n))*2); A065251 := n -> 1-((n-2^A000523(n)) mod 3); # Refer to http://groups.google.com/groups?hl=en&selm=1998Jan30.190735.12371%40leeds.ac.uk # by Robert Hill # # 1) If x in Z, f(x) = x. # # 2) If x is not in Z but has a terminating binary expansion, # # say x = (2a+1)/2^b, # then we may inductively assume that the surrounding values # f(a/2^(b-1)) = p/q, f((a+1)/2^(b-1)) = r/s # have already been defined, where gcd(p,q) = gcd(r,s) = 1; # then define f(x) = (p+r)/(q+s). (This will be in lowest terms too.) # # 3) For other x, f is defined by continuity. # # # How to find whether x is of the form (2a+1)/(2^b) ? f_rh_n := proc(x) option remember; local n,d; n := numer(x); d := denom(x); if(1 = d) then RETURN(n); fi; if((2^A000523(d)) <> d) then printf(`The denominator must be a power of 2, not %a\n`,d); RETURN(0); fi; if(0 = `mod`(n,2)) then printf(`The numerator must be an odd number, not %a\n`,n); RETURN(0); fi; RETURN(f_rh_n((n-1)/d) + f_rh_n((((n-1)/2)+1)/(d/2)) ); end; f_rh_d := proc(x) option remember; local n,d; n := numer(x); d := denom(x); if(1 = d) then RETURN(d); fi; if((2^A000523(d)) <> d) then printf(`The denominator must be a power of 2, not %a\n`,d); RETURN(0); fi; if(0 = `mod`(n,2)) then printf(`The numerator must be an odd number, not %a\n`,n); RETURN(0); fi; RETURN(f_rh_d((n-1)/d) + f_rh_d((((n-1)/2)+1)/(d/2)) ); end; f_rh := x -> f_rh_n(x)/f_rh_d(x); # # 1 # 10 11 # 100 101 110 111 # 1000 1001 1010 1011 1100 1101 1110 1111 # # | # V # # 10 # 100 1 # 1000 1001 101 11 # 10000 10001 10010 10011 1010 1011 110 111 # # # In general, when the node t is rotated to the right, it means that # the binary expansion of t itself is shifted once left and added one, # # t -> t1 # t0 -> t # t00... -> t0... # t01... -> t10... # t1... -> t11... # # And to the other direction (the left): # # t -> t0 # t10... -> t01... # t1 -> t # t11... -> t1... # t0... -> t00.... # # x is the integer which is permuted, t is the node to be rotated. # The table generated by these permutations (for rotations of the Stern-Brocot # tree nodes 1,2,3,4,5,6,7 etc.) # [seq(RotateNodeRight(1,j),j=1..128)]; gives A057114 RotateNodeRight := proc(t,x) local u,y; u := A000523(t)+1; # The binary width. y := A000523(x)+1; if(y < u) then RETURN(x); fi; # x is nearer to the root than t, leave intact. if(floor(x/(2^(y-u))) <> t) then RETURN(x); fi; # x is not on the same subtree as t, leave intact. if(x = t) then RETURN((2*x)+1); fi; # t --> t1 if(1 = (floor(x/(2^(y-u-1))) mod 2)) then RETURN(x + (t * 2^(y-u)) + 2^(y-u)); fi; # t1... -> t11... ((t * 2^(1+y-u)) + 2^(y-u) + x - (t* 2^(y-u))); if(y = (u+1)) then RETURN(x/2); fi; # t0 --> t if(1 = (floor(x/(2^(y-u-2))) mod 2)) then RETURN(x + 2^(y-u-2)); fi; # t01... -> t10... RETURN(x - (t * 2^(y-u-1))); # t00... -> t0... Equal to: (x - (t * 2^(y-u)) + (t * 2^(y-u-1))) end; # [seq(RotateNodeLeft(1,j),j=1..128)]; gives A057115 RotateNodeLeft := proc(t,x) local u,y; u := A000523(t)+1; # The binary width. y := A000523(x)+1; if(y < u) then RETURN(x); fi; # x is nearer to the root than t, leave intact. if(floor(x/(2^(y-u))) <> t) then RETURN(x); fi; # x is not on the same subtree as t, leave intact. if(x = t) then RETURN(2*x); fi; # t --> t0 if(0 = (floor(x/(2^(y-u-1))) mod 2)) then RETURN(x + (t * 2^(y-u))); fi; # t0... -> t00... if(y = (u+1)) then RETURN((x-1)/2); fi; # t1 --> t if(0 = (floor(x/(2^(y-u-2))) mod 2)) then RETURN(x - 2^(y-u-2)); fi; # t10... -> t01... RETURN(x - ((t+1) * 2^(y-u-1))); # t11... -> t1... Equal to: (x - (t * 2^(y-u)) + (t * 2^(y-u-1))) end; # We have identities like RotateNodeRight(4,j) = RotateNodeLeft(1,RotateNodeRight(2,RotateNodeRight(1,j))) # i.e. convert([seq(RotateNodeRight(4,j)-RotateNodeLeft(1,RotateNodeRight(2,RotateNodeRight(1,j))),j=1..65537)],set); --> {0} # or equally: RotateNodeRight(2,j) = RotateNodeRight(1,RotateNodeRight(4,RotateNodeLeft(1,j))) # or: RotateNodeRight(7,j) = RotateNodeRight(1,RotateNodeRight(3,RotateNodeLeft(1,j))) # Start indexing from zero: # hubat := [seq(RotateRightTable(j),j=0..119)]; # hubat := [3,1,1,7,5,1,2,3,2,1,6,2,7,2,1,14,11,4,3,2,1,15,6,5,9,3,2,1,4,7,3,5,4,3,2,1,5,4,15,6, # 11,4,3,2,1,12,10,8,7,6,5,4,3,2,1,13,22,9,4,7,13,5,4,3,2,1,28,23,10,19,8,7,6,5,4,3,2,1,29,12, # 11,10,9,8,15,6,5,4,3,2,1,30,13,6,11,5,9,8,7,6,5,4,3,2,1,31,14,14,12,23,10,9,17,7,6,5,4,3,2] # lubat := [seq(RotateLeftTable(j),j=0..119)]; # lubat := [2,4,1,1,4,1,8,3,2,1,9,8,6,2,1,5,2,4,3,2,1,3,6,5,8,3,2,1,16,7,12,5,4,3,2,1,17,16,3,6,...] RotateRightTable := n -> RotateNodeRight(1+(n-((trinv(n)*(trinv(n)-1))/2)),(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1); RotateLeftTable := n -> RotateNodeLeft(1+(n-((trinv(n)*(trinv(n)-1))/2)),(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1); # # 0.1 # 0.10 0.11 # 0.100 0.101 0.110 0.111 # 0.1000 0.1001 0.1010 0.1011 0.1100 0.1101 0.1110 0.1111 # # | # V # # 0.10 # 0.100 0.1 # 0.1000 0.1001 0.101 0.11 # 0.10000 0.10001 0.10010 0.10011 0.1010 0.1011 0.110 0.111 # # # In general, when the node t is rotated to the right, it means that # # # x is the rational in range ]0,1[ which is permuted, t is the node to be rotated. SternBrocot0_1frac := proc(n) local m; m := n + 2^A000523(n); SternBrocotTreeNum(m)/SternBrocotTreeDen(m); end; RotateBinFracNodeRight := (t,n) -> frac2position_in_0_1_SB_tree(RotateBinFracNodeRight_x(t,SternBrocot0_1frac(n))); RotateBinFracNodeRight_x := proc(t,x) local num,den; den := 2^(1+A000523(t)); num := (2*(t-(den/2)))+1; if((x <= (num-1)/den) or (x >= (num+1)/den)) then RETURN(x); fi; if(x <= ((2*(num-1))+1)/(2*den)) then RETURN((2*(x - ((num-1)/den))) + ((num-1)/den)); fi; if(x < (num/den)) then RETURN(x + (1/(2*den))); fi; RETURN((num/den) + ((x-((num-1)/den))/2)); end; RotateBinFracNodeLeft := (t,n) -> frac2position_in_0_1_SB_tree(RotateBinFracNodeLeft_x(t,SternBrocot0_1frac(n))); RotateBinFracNodeLeft_x := proc(t,x) local num,den; den := 2^(1+A000523(t)); num := (2*(t-(den/2)))+1; if((x <= (num-1)/den) or (x >= (num+1)/den)) then RETURN(x); fi; if(x >= ((2*num)+1)/(2*den)) then RETURN(((num-1)/den) + (2*(x - (num/den)))); fi; if(x > (num/den)) then RETURN(x - (1/(2*den))); fi; RETURN(((num-1)/den) + ((x-((num-1)/den))/2)); end; RotateBinFracRightTable := n -> RotateBinFracNodeRight(1+(n-((trinv(n)*(trinv(n)-1))/2)),(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1); RotateBinFracLeftTable := n -> RotateBinFracNodeLeft(1+(n-((trinv(n)*(trinv(n)-1))/2)),(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1); # [seq(RotateBinFracNodeRight(1,j),j=1..4096)]; starts as: # [7,25,31,1,223,15,127,5,385,13,1792,61,124,63,511,2,23,6145,97,211,439,3,226,30,247,496,62,253,508,255,2047,9,20,11,95,98305,1537,3103, QuasiCyclics2_pos_in_0_1_SB_tree := proc(t) local num,den; den := 2^(1+A000523(t)); num := (2*(t-(den/2)))+1; RETURN(frac2position_in_0_1_SB_tree(num/den)); end; exp_of_2 := proc(x) local f,m; f := ifactors(x)[2]; for m in f do if(2 = m[1]) then RETURN(m[2]); fi; od; RETURN(0); end; SB01Den := proc(n) option remember; local r; if(n <= 1) then RETURN(n+1); fi; r := n - 2^A000523(n); if(0 = (floor((1+r)/2) mod 2)) then RETURN(2*SB01Den(floor(n/2)) - SB01Den(floor(n/4))); else RETURN(SB01Den(floor(n/2)) + SB01Den(floor(n/4))); fi; end; # We make an induction hypothesis that # on the previous row (first row with a single node (= 2, pos. 1) # is the row 1) # the values mod 2 are: L,1,~L, L,1,~L, L,1,~L, L,1,~L, ... # and on the row before that (where the grandparent is) # the values are ~L,1,L, ~L,1,L, ~L,1,L, ... # and we prove that they are also on this row: # ~L,1,L, ~L,1,L, ~L,1,L, ... # where L denotes the parity of the current level, # and ~L is its complement. # (Note that 2*x terms actually eliminate, and -x is same as x # because these are computed modulo 2) # # 0 >> 2 = 0 (3n+0) 0 >> 1 = 0 (3n+0) 2*L - ~L = ~L # 1 >> 2 = 0 (3n+0) 1 >> 1 = 0 (3n+0) L + ~L = 1 # 2 >> 2 = 0 (3n+0) 2 >> 1 = 1 (3n+1) 1 + ~L = L # ------------------------------------------- # 3 >> 2 = 0 (3n+0) 3 >> 1 = 1 (3n+1) 2*1 - ~L = ~L # 4 >> 2 = 1 (3n+1) 4 >> 1 = 2 (3n+2) 2*~L - 1 = 1 # 5 >> 2 = 1 (3n+1) 5 >> 1 = 2 (3n+2) ~L + 1 = L # ------------------------------------------- # 6 >> 2 = 1 (3n+1) 6 >> 1 = 3 (3n+0) L + 1 = ~L # 7 >> 2 = 1 (3n+1) 7 >> 1 = 3 (3n+0) 2*L - 1 = 1 # 8 >> 2 = 2 (3n+2) 8 >> 1 = 4 (3n+1) 2*1 - L = L # ------------------------------------------- # 9 >> 2 = 2 (3n+2) 9 >> 1 = 4 (3n+1) 1 + L = ~L # 10 >> 2 = 2 (3n+2) 10 >> 1 = 5 (3n+2) ~L + L = 1 # 11 >> 2 = 2 (3n+2) 11 >> 1 = 5 (3n+2) 2*~L - L = L # ------------------------------------------- # 12 >> 2 = 3 (3n+0) 12 >> 1 = 6 (3n+0), 2* repeats. # # Q.E.D. every row of the Stern-Brocot 0-1 subtree begins # as ~L,1,L, ~L,1,L, ~L,1,L, ... # Based on symmetry (easily proved), every second row # is of the form 0,1,1;... ;1,1,0 # and every other of the form 1,1,0;... ; 0,1,1 # thus the zeroes (even denominators) can be found # at the positions 3n+1 of the whole sequence. # Next problem: find the locations where the denominator # is a pure power of 2, i.e., the positions of the # elements of the quasicyclic group Z+(2a+1)/((2^b)) # in Stern-Brocot ]0,1[ subtree. bindiv := proc(x,y) local xx,b,c,k; b := []; c := []; xx := x; while(xx <> 0) do b := [op(b),floor(xx/y)]; c := [op(c),xx]; xx := 2*(xx-(b[nops(b)]*y)); if(member(xx,c,'k')) then printf(`Cyclic: the dividend %a occurs again at position %a of dividends: %a\n`, xx,k,c); RETURN(b); fi; od; RETURN(b); end; # Very dumb. sqrt_n_pos_in_N2QuQR1_very_dumb := proc(upto_n,upsearch) local a,i,j; a := []; for i from 1 to upto_n do for j from 1 to upsearch do if(N2QuQR1(j) = sqrt(i)) then a := [op(a),j]; break; fi; od; if(j > upsearch) then a := [op(a),0]; fi; od; RETURN(a); end; # Just a bit more sophisticated: # Gives [1,6,14,7,120,248,...] sqrt_n_pos_in_N2QuQR1_slightly_dumb := proc(upsearch) local a,i,j; a := array(1..upsearch); for i from 1 to upsearch do a[i] := 0; od; for i from 1 to upsearch do j := N2QuQR1(i); if(type(j*j,integer)) then a[j*j] := i; print(convert(a,list)); fi; od; RETURN(convert(a,list)); end; sqrt_n_pos_in_N2QuQR2 := proc(upsearch) local a,i,j; a := array(1..upsearch); for i from 1 to upsearch do a[i] := 0; od; for i from 1 to upsearch do j := N2QuQR2(i); if(type(j*j,integer)) then a[j*j] := i; print(convert(a,list)); fi; od; RETURN(convert(a,list)); end; # From http://mathworld.wolfram.com/ContinuedFraction.html CONFRACS_FOR_SQRT_N := [[1], # 1 [1,2], # 2 [1,1,2], # 3 [2], # 4 [2,4], # 5 [2,2,4], # 6 [2,1,1,1,4], # 7 [2,1,4], # 8 [3], # 9 [3,6], # 10 [3,3,6], # 11 [3,2,6], # 12 [3,1,1,1,1,6], # 13 [3,1,2,1,6], # 14 [3,1,6], # 15 [4], # 16 [4,8], # 17 [4,4,8], # 18 [4,2,1,3,1,2,8], # 19 [4,2,8], # 20 [4,1,1,2,1,1,8], # 21 [4,1,2,4,2,1,8], # 22 [4,1,3,1,8], # 23 [4,1,8], # 24 [5], # 25 [5,10], # 26 [5,5,10], # 27 [5,3,2,3,10], # 28 [5,2,1,1,2,10], # 29 [5,2,10], # 30 [5,1,1,3,5,3,1,1,10], # 31 [5,1,1,1,10], # 32 [5,1,2,1,10], # 33 [5,1,4,1,10], # 34 [5,1,10], # 35 [6], # 36 [6,12], # 37 [6,6,12], # 38 [6,4,12], # 39 [6,3,12] # 40 ]; sqrt_n_confrac2binfrac := proc(n) local c,t; c := CONFRACS_FOR_SQRT_N[n]; t := `if`((1 = nops(c)),[],`if`((0 = (nops(c) mod 2)),[op(c[2..nops(c)]),op(c[2..nops(c)])],c[2..nops(c)])); RETURN( (((2^c[1])-1) + `if`(1 = nops(c),0,(runcounts2binexp0(t) / ((2^(convert(t,`+`)))-1)))) / (2^c[1])); end; find_sqrt := proc(x) local n,i,y; n := nops(x); if(n < 2) then RETURN(0); fi; if((2 = n) and (`^` = op(0,x)) and (1/2 = op(2,x))) then RETURN(op(1,x)); else for i from 0 to n do y := find_sqrt(op(i,x)); if(y <> 0) then RETURN(y); fi; od; RETURN(0); # Not found. fi; end; # sqrootit := [seq(find_sqrt(N2QuQR1(j)),j=1..512)]; # [0, # 5,5, # 0,2,2,0, # 2,3,0,3,3,0,3,2, # 5,13,17,10,17,37,5,13,13,5,37,17,10,17,13,5, # 3,17,3,37,21,37,10,37,5,401,6,37,10,401,0,17,17,0,401,10,37,6,401,5,37,10,37,21,37,3,17,3, # 0,37,10,0,401,506,17,5,401,6085,...] # Note the symmetry which migrates from the Stern-Brocot ]0,1[ subtree! # # ratpos := positions(0,sqrootit); # # ratpos := [1,4,7,10,13,46,49,64,67,79,112,124,127,139,151,232,244,262,310,325,349,352,364,403,415,418,442,457,505] # # map(sub1,ratpos); # # [0,3,6,9,12,45,48,63,66,78,111,123,126,138,150,231,243,261,309,324,348,351,363,402,414,417,441,456,504] # # map(div3,map(sub1,ratpos)); # # [0,1,2,3,4,15,16,21,22,26,37,41,42,46,50,77,81,87,103,108,116,117,121,134,138,139,147,152,168] # # How to obtain either of the above sequences? Carries, 2-automatic sequence? # # A bijection from N to the union of positive rationals # plus positive real roots of quadratic polynomials, version 1: N2QuQR1 := proc(n) local m; m := n + 2^A000523(n); MinkowskisQMarkVarInv(SternBrocotTreeNum(m)/SternBrocotTreeDen(m)); end; # Convert to rational or irrational real which is a root of quadratic polynomial # via use of the continued fractions: This one uses # binary fractions in range ]0,1[ # and the other version in range ]0,inf[ (= Conway's box-function ?) # # Here neither x nor y should be zero! # Note that the cycle checking condition must be: # if(member(xx,d,'k') and ((1 = k) or (b[k] <> b[k-1])) and (q <> floor(xx/y))) # instead of just: # if(member(xx,d,'k') and (k > 1) and (b[k] <> b[k-1])) # otherwise also N2QuQR1(1663) would be sqrt(2), not just N2QuQR1(6) # as SternBrocot0_1frac(6) = 3/5 = 0.100110011001100 # and SternBrocot0_1frac(1663) = 25/42 = 0.10011000011000011000011.. # MinkowskisQMarkVarInv := proc(r) local x,y,b,d,k,s,i,q; x := numer(r); y := denom(r); if(y = 2*x) then RETURN(1); fi; b := []; d := []; k := 0; s := 0; i := 0; while(x <> 0) do q := floor(x/y); if(i > 0) # Do not store the first zero. then b := [op(b),q]; d := [op(d),x]; fi; x := 2*(x-(q*y)); if(member(x,d,'k') and (k > 1) and (b[k] <> b[k-1]) and (q <> floor(x/y))) # Only at run boundaries! then s := eval_periodic_confrac_tail(list2runcounts(b[k..nops(b)])); b := b[1..(k-1)]; break; fi; i := i+1; od; if(0 = k) # If finite. then b := b[1..(nops(b)-1)]; # Remove the last 1. b := [op(b),b[nops(b)]]; # And dup the last remaining digit. fi; if(r < (1/2)) # On the left side of the tree? then RETURN(factor(eval_confrac([0,op(list2runcounts(b))],s))); else RETURN(factor(eval_confrac(list2runcounts(b),s))); fi; end; # A bijection from N to the union of positive rationals # plus positive real roots of quadratic polynomials, version 1: N2QuQR2 := n -> ConwaysXinBoxInv(SternBrocotTreeNum(n)/SternBrocotTreeDen(n)); # For example: # f_rh(13/8); = 8/5 = ConwaysBoxInv(13/8); # f_rh(11/8); = 7/5 = ConwaysBoxInv(11/8); ConwaysXinBoxInv := proc(r) local x,y,b,d,k,s,i,q; x := numer(r); y := denom(r); if(1 = y) then RETURN(x/y); fi; if(2 = y) then RETURN(x/y); fi; b := []; d := []; x := x; k := 0; s := 0; i := 0; while(x <> 0) do q := floor(x/y); if(i > 0) # Do not store the first quotient. then b := [op(b),q]; d := [op(d),x]; fi; x := 2*(x-(q*y)); if(member(x,d,'k') and (k > 1) and (b[k] <> b[k-1]) and (q <> floor(x/y))) # Only at run boundaries! then s := eval_periodic_confrac_tail(list2runcounts(b[k..nops(b)])); b := b[1..(k-1)]; break; fi; i := i+1; od; if(0 = k) then b := b[1..(nops(b)-1)]; # Remove the last 1. b := [op(b),b[nops(b)]]; # And dup the last remaining digit. fi; RETURN(factor(eval_confrac([floor(r),op(list2runcounts([0,op(b)]))],s))); end; eval_confrac := proc(c,z) local x,i; x := z; # printf(`eval_confrac(%a,%a),%a\n`,c,z,nops(c)); for i from nops(c) by -1 to 1 do x := (`if`((0=x),x,(1/x)))+c[i]; od; RETURN(x); end; eval_periodic_confrac_tail := proc(c) local x,i,u,r; x := (eval_confrac(c,u) - u) = 0; r := [solve(x,u)]; if(nops(r) <> 2) then printf(`Should not happen: no two distinct roots %a computed for periodic confrac %a\n`, r,c); RETURN(0); fi; if(signum(r[1]) = signum(r[2])) then printf(`Should not happen: both roots %a computed for periodic confrac %a are either positive or negative!\n`, r,c); RETURN(0); fi; RETURN(max(r[1],r[2])); end; list2runcounts := proc(b) local a,p,y,c; if(0 = nops(b)) then RETURN([]); fi; a := []; c := 0; p := b[1]; for y in b do if(y <> p) then a := [op(a),c]; c := 0; p := y; fi; c := c+1; od; RETURN([op(a),c]); end; QuQR2toQuQR1 := n -> frac2position_in_0_1_SB_tree(QtoQ0_1(SternBrocotTreeNum(n)/SternBrocotTreeDen(n))); QtoQ0_1 := r -> (((2^floor(r))-1)+(frac(r)/2))/(2^floor(r)); QuQR1toQuQR2 := proc(n) local m; m := n + 2^A000523(n); frac2position_in_whole_SB_tree(Q0_1toQ(SternBrocotTreeNum(m)/SternBrocotTreeDen(m))); end; Q0_1toQ := proc(rr) local r,i; r := rr; i := 0; while(r >= 1/2) do r := 2*(r-(1/2)); i := i+1; od; RETURN(i + (2*r)); end; A65934pl := proc(r) local n,m; n := frac2position_in_whole_SB_tree(Q0_1toQ(convert(r,rational))); m := n + 2^A000523(n); SternBrocotTreeNum(m)/SternBrocotTreeDen(m); end; # samplist := [seq(0.1 + (j/1000),j=0..800)]; # plot(A65934pl, (0.1)..(0.9),adaptive=false,sample=samplist); MQMVIpl := r -> MinkowskisQMarkVarInv(convert(r,rational)); CXIBIpl := r -> ConwaysXinBoxInv(convert(r,rational)); MQMVIpl2 := proc(r) local n,m; n := frac2position_in_whole_SB_tree(convert(r,rational)); m := n + 2^A000523(n); MinkowskisQMarkVarInv(SternBrocotTreeNum(m)/SternBrocotTreeDen(m)); end; # If we start from binfrac2confrac_approx(1/3,500); convert(",confrac); # and iterate, we end with A058914: # 0,2,2,1,1,1,3,2,3,1,2,4,1,1,2,3,1,2,5,1,3,2,3,1,3,1,2,3,2,1,... # Continued fraction expansion of the fixed point of the ?-function of Minkowski. # which is about 0.420372339... # The other fixed point, 0.5796276606 (1 - the other fixed point) # doesn't have it confrac # 0,1,1,2,1,1,1,3,2,3,1,2,4,1,1,2,3,1,2,5,1,3,2,3,1,3,1,2,3,2,1,4,1,4,2,1,1,2,2,1,2,1, # yet stored in EIS. binfrac2confrac_approx := proc(r,lim) local x,y,b,d,k,s,i,q; x := numer(r); y := denom(r); if(1 = y) then RETURN(x/y); fi; if(2 = y) then RETURN(x/y); fi; b := []; d := []; x := x; k := 0; s := 0; i := 0; while(x <> 0) do q := floor(x/y); if(i > 0) # Do not store the first quotient. then b := [op(b),q]; d := [op(d),x]; fi; x := 2*(x-(q*y)); if(i > lim) # Only at run boundaries! then break; fi; i := i+1; od; if(0 = k) then b := b[1..(nops(b)-1)]; # Remove the last 1. b := [op(b),b[nops(b)]]; # And dup the last remaining digit. fi; RETURN(eval_confrac([floor(r),op(list2runcounts([0,op(b)]))],s)); end; # Should be same as convert(binexp2runcounts(n),`*`) mult_binruncounts := proc(nn) local n,a,p,c; n := nn; a := 1; p := (`mod`(n,2)); c := 0; while(n > 0) do c := c+1; n := floor(n/2); if((`mod`(n,2)) <> p) then a := a*c; c := 0; p := (`mod`(p+1,2)); fi; od; RETURN(a); end; LCM_binruncounts := proc(nn) local n,a,p,c; n := nn; a := 1; p := (`mod`(n,2)); c := 0; while(n > 0) do c := c+1; n := floor(n/2); if((`mod`(n,2)) <> p) then a := ilcm(a,c); c := 0; p := (`mod`(p+1,2)); fi; od; RETURN(a); end; mult1binruncounts := proc(nn) local n,a,p,c; n := nn; a := 0; p := (`mod`(n,2)); c := 0; while(n > 0) do c := c+1; n := floor(n/2); if((`mod`(n,2)) <> p) then if(0 = a) then a := c; else a := a*(c+1); fi; c := 0; p := (`mod`(p+1,2)); fi; od; RETURN(a); end; # # lebat := [seq(SternBrocotTreeNum(j)*SternBrocotTreeDen(j),j=0..66)]; # is equal to: # labet := [seq(mult_sbtree_num_den(j),j=0..66)]; # labet := [0, 1, 2, 2, 3, 6, 6, 3, 4, 10, 15, 12, 12, 15, 10, 4, 5, 14, 24, 21, 28, 40, 35, 20, 20, 35, 40, 28, 21, 24, 14, 5, 6, 18, 33, 30, 44, 65, 60, 36, 45, 84, 104, 77, 70, 88, 63, 30, 30, 63, 88, 70, 77, 104, 84, 45, 36, 60, 65, 44, 30, 33, 18, 6, 7, 22, 42] # mult_sbtree_num_den := proc(nn) local n,a,p,c,num,den,newnum; n := nn; a := 0; p := (`mod`(n,2)); c := 0; den := 1; while(n > 0) do c := c+1; n := floor(n/2); if(0 = n) then c := c-1; fi; if((`mod`(n,2)) <> p) then if(0 = a) then num := c+1; else newnum := c*num + den; den := num; num := newnum; fi; a := num*den; # printf(`a=%a c=%a p=%a den=%a, num=%a\n`,a,c,p,den,num); c := 0; p := (`mod`(p+1,2)); fi; od; RETURN(a); end; # Call like: MATR2HTML_TABLE_NO_ZEROS(create_SB_matrix(7),`c:\\maplev4\\matikka\\sb8.htm`,-3); # or: MATR2HTML_TABLE_NO_ZEROS(transpose(create_SB_matrix(7)),`c:\\maplev4\\matikka\\sb8t.htm`,-1); # or: T := map(numden,transpose(create_SB_matrix(7))); # where numden is: numden := r -> numer(r)*denom(r); first_pos_with_numden := proc(n) local i; for i from 1 to 2^(n-1) do if(mult_sbtree_num_den(i) = n) then RETURN(i); fi; od; RETURN(0); # Shouldn't come here. end; # Gives sequence like this: # first_pos := [seq(first_pos_with_numden(j),j=1..15)]; # --> [1, 2, 4, 8, 16, 5, 64, 128, 256, 9, 1024, 11, 4096, 17, 10] # # find_levels(53); -> # Quite interesting looking: # [1,2,4,8,16,5,64,128,256,9,1024,11,4096,17,10,32768,65536,33,262144,23,19,65,4194304,18,16777216,129,67108864,20,268435456,35,1073741824,2147483648,34,513,22,39,68719476736,1025,67,21,1099511627776,66,4398046511104,36,40,4097,70368744177664,131,281474976710656,8193,130,71,4503599627370496] # i.e. taking from the 6th term every fourth term we get: # [seq(pos53[6+(j*4)],j=0..11)]; # [5, 9, 17, 33, 65, 129, 35, 513, 1025, 66, 4097, 8193] # (the 30th and 42nd terms are thus exceptions from the pattern) # Furthermore: # [seq(nthmember((2^j)+1,pos53),j=2..16)]; # [6, 10, 14, 18, 22, 26, 0, 34, 38, 0, 46, 50, 0, 0, 0] # [seq(nthmember((2^j)+2,pos53),j=2..16)]; # [0, 15, 24, 33, 42, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0] # # [seq(nthmember((2^j)+3,pos53),j=2..16)]; # # [0, 12, 21, 30, 39, 48, 0, 0, 0, 0, 0, 0, 0, 0, 0] # [seq(nthmember((2^j)+4,pos53),j=2..16)]; # # [4, 0, 28, 44, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] # # First differences of these are 4, 9, 9, 16, ? (apart from the "holes") # # (Another sequence: numbers for which first_pos[n] = n-1 # and thse for which first_pos[n] = 2^(n-1) (i.e. primes and their powers)) # map(A070939,first_pos); # Gives the level: # --> [1,2,3,4,5,3,7,8,9,4,11,4,13,5,4] # is0 := find_ans(5000,0); # is0 := [1, 2, 6, 12, 176, 432, 2184] # map(convert,is0,binary); # [1, 10, 110, 1100, 10110000, 110110000, 100010001000] # map(ifactor,is0); # 2 4 4 3 3 # [1, (2), (2) (3), (2) (3), (2) (11), (2) (3) , (2) (3) (7) (13)] # # is_1 := find_ans(5000,-1); # is_1 := [3, 4, 34, 113, 280] # is1 := find_ans(17000,1); # is1 := [5, 9, 11, 27, 1271, 1439, 2463, 5895] # map(convert,is1,binary); # Note how 9 = 5-4+8 and 2463 = 1439 - 1024 + 2048; # [101, 1001, 1011, 11011, 10011110111, 10110011111, 100110011111, 1011100000111] # map(ifactor,is1); # 2 3 2 # [(5), (3) , (11), (3) , (31) (41), (1439), (3) (821), (3) (5) (131)] GLOB_LEVELS := []; find_levels := proc(upto_n) global GLOB_LEVELS; local i; GLOB_LEVELS := []; for i from 1 to upto_n do if(nops(ifactors(i)[2]) < 2) then GLOB_LEVELS := [op(GLOB_LEVELS),2^(i-1)]; else GLOB_LEVELS := [op(GLOB_LEVELS),first_pos_with_numden(i)]; print(GLOB_LEVELS); fi; od; RETURN(GLOB_LEVELS); end; GLOB_ANS := []; find_ans := proc(upto_n,d) global GLOB_ANS; local i; GLOB_ANS := []; for i from 1 to upto_n do if(mult_sbtree_num_den(i) = (i+d)) then print(i); GLOB_ANS := [op(GLOB_ANS),i]; fi; od; RETURN(GLOB_ANS); end; create_SB_matrix := proc(levels) local A,i,j,n; A := array(1..levels,1..(2^levels)); for i from 1 to levels do for j from 1 to 2^levels do A[i,j] := 0; od; od; for n from 1 to (2^levels)-1 do A[A070939(n),2^(levels - A070939(n))+((n - 2^A000523(n)))*2^((levels-A070939(n))+1)] := SternBrocotTreeNum(n)/SternBrocotTreeDen(n); od; RETURN(A); end; MATR2HTML_TABLE_NO_ZEROS := proc(A, filename,fontsize) local cols, rows, i, j, fp; fp := fopen(filename,APPEND,BINARY); fprintf (fp, `\n`); for i from 1 to rowdim(A) do fprintf (fp, ``); for j from 1 to coldim(A) do if(0 = A[i,j]) then fprintf(fp,``); else fprintf (fp, ``, fontsize, A[i,j]); fi; od; fprintf (fp, `\n`); od; fprintf (fp, `
%a
\n`); fclose(fp); end; # More and more... # Very useful. Use Henry Bottomley's recursive formula: # If 2*2^k<=n<3*2^k (2nd msb=0) then a(n)=2*a(n-2^k); # if 3*2^k<=n<4*2^k (2nd msb=1) then a(n)=1+ a(n-2^k) # starting with a(1)=1. A059893 := proc(n) option remember; local k; if(1 = n) then RETURN(1); fi; k := A000523(n)-1; if(2 = floor(n/(2^k))) then RETURN(2*A059893(n-(2^k))); else RETURN(1+A059893(n-(2^k))); fi; end; # Yet another Stern-Brocot tree inspired permutation of N: # # 11ab..yz -> 11ab..yz1 (shift left and add one) # 10ab..y0 -> 10ab..y (shift right) # 10ab..y1 -> 11AB..Y0 (where 1AB..Y0 is the complement of 0ab..y1) RightChildInverted := proc(n) local k; if(1 = n) then RETURN(3); fi; k := A000523(n)-1; if(3 = floor(n/(2^k))) then RETURN((2*n)+1); fi; if(0 = (n mod 2)) then RETURN(n/2); fi; RETURN(2^(k+1) + ((2^(k+2))-1) - n); end; # A variant: # 11ab..yz -> 11ab..yz0 (shift left) # 10ab..y1 -> 10ab..y (shift right) # 10ab..y0 -> 11AB..Y1 (where 1AB..Y1 is the complement of 0ab..y0) LeftChildInverted := proc(n) local k; if(1 = n) then RETURN(1); fi; k := A000523(n)-1; if(3 = floor(n/(2^k))) then RETURN(2*n); fi; if(1 = (n mod 2)) then RETURN((n-1)/2); fi; RETURN(2^(k+1) + ((2^(k+2))-1) - n); end; # And yet other two variants: # # 11ab..yz -> 11ab..yz0 (shift left) # 10ab..y0 -> 10ab..y (shift right) # 10ab..y1 -> 11ab..y1 (just fill the second most significant bit) RightChildTransferred := proc(n) local k; if(1 = n) then RETURN(3); fi; k := A000523(n)-1; if(3 = floor(n/(2^k))) then RETURN(2*n); fi; if(0 = (n mod 2)) then RETURN(n/2); fi; RETURN(n + (2^k)); end; # A variant: # 11ab..yz -> 11ab..yz1 (shift left and add one) # 10ab..y1 -> 10ab..y (shift right) # 10ab..y0 -> 11ab..y0 (just fill the second most significant bit) LeftChildTransferred := proc(n) local k; if(1 = n) then RETURN(1); fi; k := A000523(n)-1; if(3 = floor(n/(2^k))) then RETURN((2*n)+1); fi; if(1 = (n mod 2)) then RETURN((n-1)/2); fi; RETURN(n + (2^k)); end; # # Perverted variant: # # 11ab..yz -> 11ab..yz1 (shift left and add one) # 10ab..y0 -> 10ab..y (shift right (left child raises)) # 10ab..y1 -> 11ab..y0 (just fill the second most significant bit and subtract one) RightChildTransferred_1 := proc(n) local k; if(1 = n) then RETURN(3); fi; k := A000523(n)-1; if(3 = floor(n/(2^k))) then RETURN((2*n)+1); fi; if(0 = (n mod 2)) then RETURN(n/2); fi; RETURN(n + (2^k) - 1); end; Nperm_inverse := proc(a,from_n,upto_n) local c,b,i; b := []; for i from from_n to upto_n do c := positions(i,a); if(nops(c) <> 1) then printf(`The list %a is not valid permutation, because the element %a either not found there, or found more than once: %a\n`, a,i,c); RETURN([]); fi; b := [op(b),(c[1]-((from_n+1) mod 2))]; od; RETURN(b); end; format_sbtree_perm := proc(a,anum) local b,c,d,d2,s,i,upto_n; upto_n := floor(nops(a)/3); b := Nperm_inverse(a,1,upto_n): if(0 = nops(b)) then RETURN(0); fi; printf(`The permutation itself:\n`); format(a,anum); printf(`And its inverse:\n`); format(b,anum+1); c := []; for i from 1 to nops(a) do c := [op(c),A059893(a[A059893(i)])]; od; printf(`And the permutation conjugated with A059893:\n`); format(c,anum+2); d := Nperm_inverse(c,1,upto_n); # A059893 is self-inverse, thus c's inverse should be same as b's conjugation: printf(`And its inverse (= the permutation's inverse conjugated with A059893):\n`); format(d,anum+3); s := []; for i from 1 to nops(d) do s := [op(s),(N2Z(d[i])-N2Z(i))]; od; printf(`And the associated siteswap sequence (the deltas) for above:\n`); format(s,anum+4); printf(`Bisection of even terms (positive part of Z):\n`); format(BISECT(s,1),anum+5); printf(`Bisection of odd terms (negative part of Z):\n`); format(BISECT(s,0),anum+6); end; # Recursively in a manner like this (however, this is incorrect...) # (defun cfrac2binexp (c) # (cond ((null (cdr c)) (* (sub1 (pow 2 (sub1 (car c)))) parity)) # (t # (+ cfrac2binexp (cdr c) (add1 parity) # (* (sub1 (pow 2 (car c))) parity) # ) # ) OrgSternBrocotTreeNum := proc(n) option remember; local msb,r,nhb; if(n < 2) then RETURN(n); fi; # 0 -> 0, 1 -> 1 msb := A000523(n); # Index of the highest bit. r := n - (2^msb); # Remainder after msb is turned off. nhb := A000523(r); # Next highest bit. if(nhb < (msb-1)) then RETURN(OrgSternBrocotTreeNum((2^(msb-1))+r)); else RETURN(OrgSternBrocotTreeNum(r) + OrgSternBrocotTreeNum(((2^msb)+(2^nhb)-r)-1)); fi; end; SternBrocotTreeNum := proc(n) option remember; local msb,r; if(n < 2) then RETURN(n); fi; # 0 -> 0, 1 -> 1 msb := A000523(n); # Index of the highest bit. r := n - (2^msb); # Remainder after msb is turned off. if(A000523(r) = (msb-1)) then RETURN(SternBrocotTreeNum(r) + SternBrocotTreeNum(((3*(2^(msb-1)))-r)-1)); else RETURN(SternBrocotTreeNum((2^(msb-1))+r)); fi; end; ReflectBinTreePermutation := n -> (((3*(2^A000523(n)))-n)-1); SternBrocotTreeDen := n -> SternBrocotTreeNum(((3*(2^A000523(n)))-n)-1); # A047679 := [seq(SternBrocotTreeDen(j),j=1..100)]; # Continued Fraction based Pseudo-Wild Numbers: # (This is quite tame, invent something wilder!) # (Now this is too wild, invent something tamer!) cfrpsw_f := r -> (`if`((0 = r),r,(`if`((r < 1),cfrpsw_f(1/r),r/(convert(convert(r,'confrac'),`*`)/convert(convert(r,'confrac'),`+`)))))); iter_cfrpsw_f := proc(start,upto_n) local a,n,i; n := start; a := []; for i from 1 to upto_n do n := cfrpsw_f(n); a := [op(a),n]; if(whattype(n) = integer) then RETURN(a); fi; od; RETURN(a); end; cfrpsw2f := r -> convert(convert(r,'confrac'),`+`)/nops(convert(r,'confrac')); iter_cfrpsw2f := proc(start,upto_n) local a,n,i; n := start; a := []; for i from 1 to upto_n do n := cfrpsw2f(n); a := [op(a),n]; if(whattype(n) = integer) then RETURN(a); fi; od; RETURN(a); end; # Here it is too rare that SternBrocotTreeNum(n)*SternBrocotTreeDen(n) would produce (2^k)-1. iter_sbtpsw := proc(start,upto_n) local a,n,i; n := start; a := []; for i from 1 to upto_n do if(whattype(SternBrocotTreeNum(n)/SternBrocotTreeDen(n)) = integer) then RETURN(n); fi; n := SternBrocotTreeNum(n)*SternBrocotTreeDen(n); print(n); od; RETURN(0); end; rule90x150combination_old_definition := proc(n) local r,d,p,q,j,s,i,pattern; p := extended_A020652[n]; # the rule 150 component q := extended_A020653[n]; # the rule 90 component r := p+q; # radius of CA. d := (2*r)+1; # diameter of CA, including the cell itself. s := 0; for i from 0 to (2^d)-1 do pattern := i; for j from 1 to p do pattern := rule150(pattern,1); od; for j from 1 to q do pattern := rule90(pattern,1); od; if(0 <> bit_i(pattern,(2*r))) then s := s + 2^i; fi; od; RETURN(s); end; rule90x150combination := proc(n) local p,q,i; p := extended_A020652[n]; # the rule 150 component [0,1,op(A020652)] q := extended_A020653[n]; # the rule 90 component [1,0,op(A020653)] RETURN(sum('bit_i(rule150(rule90(i,q),p),(2*(p+q))) * (2^i)','i'=0..(2^((2*(p+q))+1))-1)); end; # This gives the corresponding XOR-conjugate rules: rule150x90combination_xored := proc(n) local r,d,p,q,j,s,k,pattern; p := extended_A020652[n]; # the rule 150 component q := extended_A020653[n]; # the rule 90 component r := p+q; # radius of CA. d := (2*r)+1; # diameter of CA, including the cell itself. s := 0; for k from 0 to (2^d)-1 do pattern := k; for j from 1 to q do pattern := rule90(pattern,1); od; for j from 1 to p do pattern := rule150(pattern,1); od; if(bit_i(k,r) <> bit_i(pattern,(2*r))) then s := s + 2^k; fi; od; RETURN(s); end; # y is applied first, then x, the result is r=2 rule: compose_two_r1_rules := (x,y) -> sum('bit_i(apply_rule_x(x,1,apply_rule_x(y,1,l,1),1),4) * (2^l)','l'=0..(2^(5))-1); # Exhaustive search. find_component_rules := proc(x) local r,d,p,q,a; r := 1; # radius of CA. d := (2*r)+1; # diameter of CA, including the cell itself. a := []; for p from 0 to (2^(2^d))-1 do printf (`%a %a\n`, p, a); fflush(default); for q from 0 to (2^(2^d))-1 do if (compose_two_r1_rules(p,q) = x) then a := [op(a),[p,q]]; fi; od; od; RETURN(a); end; # An algebraic formula for the generation n of rule-90 started from # the initial pattern 1. # floor(log[2](n+1)) is so messy in Maple, is replaced by n here # (But in the formula, use inf). Shortly after n = 16 gets incalculable: # (Because here, Maple always first computes the 2^2^(i+i) regardless of # whether the bit_i(n,i) is 0 or 1). rule90prod := n -> product('((bit_i(n,i)*(2^(2^(i+1))))+1)','i'=0..A000523(n+1)); # Starting from the seed 7: rule90prod7 := n -> product('((bit_i((n+1),i)*(2^(2^(i+1))))+1)','i'=0..A000523(n+2)) + 2*product('((bit_i(n,i)*(2^(2^(i+1))))+1)','i'=0..A000523(n+1)); rule90prodfactors:= proc(n) local i,b: b := []; for i from 0 to n # floor(log[2](n+1)) do b:=[op(b), ((bit_i(n,i)*(2^(2^(i+1))))+1)]; od: RETURN(b); end: # This gives the numerators of ratios leading to Thue Morse constant. # The denominators are just 2^(2^n), 4,16,256 (beginning from n = 1) # See http://www.inwap.com/pdp10/hbaker/hakmem/series.html#item122 thuemorse_num := proc(n) option remember; if(0 = n) then RETURN(0); else RETURN((thuemorse_num(n-1)+1)*((2^(2^(n-1)))-1)); fi; end; rabbit_seq := proc(n) option remember; if(n <= 1) then RETURN(n); else RETURN((rabbit_seq(n-1)*(2^fib(n-1)))+rabbit_seq(n-2)); fi; end; # Gives A000695: rewrite_0to00_1to01 := proc(n) local b,i; b := convert(convert(n,base,2),base,4,2); RETURN(add(b[i]*(2^(i-1)),i=1..nops(b))); end; rewrite_0to1_1to10 := proc(n) option remember; if(n < 2) then RETURN(n + 1); else RETURN(((2^(1+(n mod 2))) * rewrite_0to1_1to10(floor(n/2))) + (n mod 2) + 1); fi; end; # rewrite_0to1_1to10_n_i_times(0,n) produces the same sequence as rabbit_seq(n): rewrite_0to1_1to10_n_i_times := proc(n,i) local z,j; z := n; j := i; while(j > 0) do z := rewrite_0to1_1to10(z); j := j - 1; od; RETURN(z); end; # 0, 1, 10, 101, 10110, 10110101, 1011010110110, 101101011011010110101, 1011010110110101101011011010110110 # How to generate by rewrite-process (the "binary complement" of the rabbit sequence) ? # 10,101,1010,101001,101001010,10100101001001 rewrite_1to0_0to01 := proc(n) option remember; if(n < 2) then RETURN(n); else RETURN(((2^(2-(n mod 2))) * rewrite_1to0_0to01(floor(n/2))) + ((1+n) mod 2)); fi; end; # Start with n = 2. rewrite_1to0_0to01_n_i_times := proc(n,i) local z,j; z := n; j := i; while(j > 0) do z := rewrite_1to0_0to01(z); j := j - 1; od; RETURN(z); end; # # Neither of them is in EIS yet: # #> complrabbits := [seq(rewrite_1to0_0to01_n_i_times(2,j),j=0..10)]; # #complrabbits := [2, 5, 10, 41, 330, 10569, 2705738, 22165408073, # # 46484229871716682, 798592988315077703256066377, # # 28772344676771798485270562007975440432056650] # #> zeck_exp := map(interpret_as_zeckendorf_expansion,complrabbits); # #zeck_exp := [2, 4, 7, 19, 83, 925, 43490, 22658619, 554592377904, # # 7072185850510042229, 2207363610758479078901679523695] # #> map(ifactor,zeck_exp); # # 2 2 #[(2), (2) , (7), (19), (83), (5) (37), (2) (5) (4349), 4 (3) (1373) (5501), (2) (3) (149) (77543677), # (11) (631) (1018900136941369), (3) (5) (43) (3422269163966634230855317091)] # rewrite_0to0_1to01 := proc(n) option remember; if(n < 2) then RETURN(n); else RETURN(((2^(1+(n mod 2))) * rewrite_0to0_1to01(floor(n/2))) + (n mod 2)); fi; end; rewrite_0to0_x1to1 := proc(n) option remember; if(0 = n) then RETURN(n); else RETURN((2 * rewrite_0to0_x1to1(floor(n/(2^(1+(n mod 2)))))) + (n mod 2)); fi; end; interpret_as_zeckendorf_expansion_with_loop := proc(n) local nn,i,s; nn := n; i := 0; s := 0; while(nn > 0) do s := s + ((nn mod 2) * fib(i+2)); nn := floor(nn/2); i := i + 1; od; RETURN(s); end; interpret_as_zeckendorf_expansion := n -> sum('(bit_i(n,i)*fib(i+2))','i'=0..A000523(n)); # # # # L(0)=2 01 = 1 C=1 # 10 = 2 # # L(1)=1 100 = 3 C=3 # # L(2)=3 0101 = 4 C=4 # 1000 = 5 # 1010 = 6 # # L(3)=4 01001 = 7 C=7 # 10000 = 8 # 10010 = 9 # 10100 = 10 # # L(4)=7 010001 = 11 C=11 11+0 = 11 # 010101 = 12 11+1 = 12 # 100000 = 13 11+2+0 = 13 # 100010 = 14 11+2+1 = 14 # 100100 = 15 11+2+2 = 15 # 101000 = 16 11+2+3 = 16 # 101010 = 17 11+2+4 = 17 # # L(5)=11 0100001 = 18 C=18 # 0100101 = 19 # 0101001 = 20 # 1000000 = 21 # # [seq([j,fibbinary(j),convert(fibbinary(j),'binary'),CycBinSeqNo11Rank(fibbinary(j))],j=0..30)]; # # [[0, 0, 0, 0], [1, 1, 1, 1], [2, 2, 10, 2], [3, 4, 100, 3], [4, 5, 101, 4], [5, 8, 1000, 5], [6, 9, 1001, 7], [7, 10, 1010, 6], # [8, 16, 10000, 8], [9, 17, 10001, 11], [10, 18, 10010, 9], [11, 20, 10100, 10], [12, 21, 10101, 12], [13, 32, 100000, 13], # [14, 33, 100001, 18], [15, 34, 100010, 14], [16, 36, 100100, 15], [17, 37, 100101, 19], [18, 40, 101000, 16], [19, 41, 101001, 20], # [20, 42, 101010, 17], [21, 64, 1000000, 21], [22, 65, 1000001, 29], [23, 66, 1000010, 22], [24, 68, 1000100, 23], # [25, 69, 1000101, 30], [26, 72, 1001000, 24], [27, 73, 1001001, 31],[28, 74, 1001010, 25],[29, 80, 1010000, 26],[30, 81, 1010001, 32]] # # # The ranking algorithm for the cyclic binary sequences # with forbidden -11- subsequence. (These are counted # by Lucas numbers). # # The cumulative sum in the beginning of # the next set of L(n-2) cyclic binary sequences of n bits is always # L(n-1). Initialize the result to this. # # A) If the sequence begins with 010 (i.e. ends with 1), # then what follows is a n-5 digit long # ordinary Zeckendorf expansion sandwiched between 010- and -01. # Count it (sum the Fibonacci numbers) and add to the sum. # # B) If the sequence begins with 1, then add F(n-3) # to the result. What follows is a n-3 digits long # ordinary Zeckendorf expansion sandwiched between 10- and -0. # Count it (sum the Fibonacci numbers) and add to the sum. # # L(n-1) = F(n-2) + F(n) # Some pretty cancellations occur, we get the following simple formula: # L(n-1)+F(n-3) # = F(n)+F(n-2)+F(n-3) # (F(n) is already implicitly present in the Zeckendorf Expansion). # CycBinSeqNo11Rank := proc(s) local n; if(s < 2) then RETURN(s); fi; n := A000523(s)+1; if(1 = (`mod`(s,2))) then RETURN(fibonacci(n+1) + interpret_as_zeckendorf_expansion(floor(s/4))); else RETURN(fibonacci(n-2) + fibonacci(n-3) + interpret_as_zeckendorf_expansion(floor(s/2))); fi; end; # Same function as above (except with 0 gives incorrectly 1) # Now use the adjective "circular" instead of "cyclic": # Gives the sequence A056017 is EIS. CircBinSeqNo11Rank := n -> fibonacci(A000523(n)+1-((-1)^n)) + interpret_as_zeckendorf_expansion(floor(n/(3-((-1)^n)))); divide_A048757_by_known_factors:= proc(n,j) local l,i,nn: nn := n; l := A000523(nn+1); for i from 1 to l do; if(0 <> bit_i(j,i)) then nn := nn / (fib((2^i)+1)+fib((2^i)-1)); fi; od; RETURN(nn); end; distinct_luc_products := n -> product('luc(2^(i+1))^bit_i(n,i)','i'=0..A000523(n+1)); distinct_luc2_products := n -> product('luc(2^i)^bit_i(n,i)','i'=0..A000523(n+1)); distinct_fib_products := n -> product('fib(2^(i+2))^bit_i(n,i)','i'=0..A000523(n+1)); FL := n -> (`if`(1 = (n mod 2),luc(n),fibonacci(n))); # Now prove that A048757_as_product(n) = interpret_as_zeckendorf_expansion(Xpower(5,n)) # for all n. A048757_as_product_old := n -> (fib(n+2)+((n mod 2)*2*fib(n+1)))*product('(bit_i(n,i)*((fib((2^i)+1)+fib((2^i)-1) - 1)))+1','i'=1..A000523(n+1)); A048757_as_product := n -> (`if`(1 = (n mod 2),luc(n+2),fib(n+2)))*product('luc(2^i)^bit_i(n,i)','i'=1..A000523(n+1)); # There's something absolutely mystic going on here... sum is probably too trying to be too intelligent again... # A048757_as_sum := n -> sum(((binomial(n,'i') mod 2)*fibonacci(2+2*'i')),'i'=0..n); # A048757_as_sum_b := n -> sum(((binomial(2*n,'i') mod 2)*fibonacci(2+'i')),'i'=0..2*n); # A048757_as_sum_c := n -> sum(((binomial(2*n,2*'i') mod 2)*fibonacci(2+2*'i')),'i'=0..n); A048757_as_sum := proc(n) local i; RETURN(add(((binomial(n,i) mod 2)*fibonacci(2+2*i)),i=0..n)); end; A048757_as_sum_b := proc(n) local i; RETURN(add(((binomial(2*n,i) mod 2)*fibonacci(2+i)),i=0..2*n)); end; A048757_as_sum_c := proc(n) local i; RETURN(add(((binomial(2*n,2*i) mod 2)*fibonacci(2+2*i)),i=0..n)); end; A054433_as_sum := proc(n) local i; RETURN(add((one_or_zero(igcd(n,i))*fibonacci(i+1)),i=1..(n-1))); end; A063683_as_sum := proc(n) local i; RETURN(add((one_or_zero(igcd(n,i))*fibonacci(i)),i=1..(n-1))); end; wri_for_A048757_as_sum := proc(n) local i; RETURN(add(((binomial(n,i) mod 2)*fibonacci(2*i)),i=0..n)); end; wri_for_A048757_as_sum_c := proc(n) local i; RETURN(add(((binomial(2*n,2*i) mod 2)*fibonacci(2*i)),i=0..n)); end; wri_for_A048757_as_product := n -> (`if`(1 = (n mod 2),luc(n),fib(n)))*product('luc(2^i)^bit_i(n,i)','i'=1..A000523(n+1)); generic_bincoeff_fibsum_as_sum := proc(n,k) local i; RETURN(add(((binomial(n,i) mod 2)*fibonacci(k+2*i)),i=0..n)); end; generic_bincoeff_fibsum_as_product := (n,k) -> (`if`(1 = (n mod 2),luc(n+k),fibonacci(n+k)))*product('luc(2^i)^bit_i(n,i)','i'=1..A000523(n+1)); generic_bincoeff_fibsum_table_as_sums := (n) -> generic_bincoeff_fibsum_as_sum( (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n),(n-((trinv(n)*(trinv(n)-1))/2)) ); generic_bincoeff_fibsum_table_as_products := (n) -> generic_bincoeff_fibsum_as_product( (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n),(n-((trinv(n)*(trinv(n)-1))/2)) ); generic_bincoeff_fibsum_table_as_sums2 := (n) -> generic_bincoeff_fibsum_as_sum( (n-((trinv(n)*(trinv(n)-1))/2)),(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); generic_bincoeff_fibsum_table_as_products2 := (n) -> generic_bincoeff_fibsum_as_product( (n-((trinv(n)*(trinv(n)-1))/2)), (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); # Integers with "odd" Zeckendorf Expansion (with F2=1) A003622 := n -> (n+floor((n+1)*((1+sqrt(5))/2))); # a(n) = A019586[A048757[n]] # wythoff_row_indices_for_A048757(2000000); # [0,1,3,12,21,77,168,609,987,3572,7755,28059,47376,171409,372099] # Now prove that this is equal to wri_for_A048757_as_sum_c[n] # Remember to set Digits := 60; (at least) # to get any meaningful results. wythoff_row_indices_for_A048757 := proc(upto_n) local a,n,j,k; a := []; j := 0; k := A048757_as_product(j); for n from 0 to upto_n do if((n+floor((n+1)*((1+sqrt(5))/2))) = k) then a := [op(a),n]; j := j+1; k := A048757_as_product(j); fi; od; RETURN(a); end; variant_as_sum := proc(n) local i; RETURN(add(((binomial(n,i) mod 2)*luc(3+2*i)),i=0..n)); end; # bs1 := map(b_as_pol,[5,9,11,13,17,19,21,23,25,27,29,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,65]); # bs1 := [7, 47, 141, 329, 2207, 6621, 15449, 46347, 103729, 311187, 726103, 4870847, 14612541, 34095929, 102287787, 228929809, # 686789427, 1602508663, 4807525989, 10749959329, 32249877987, 75249715303, 225749145909, 505248088463, 1515744265389, # 3536736619241, 23725150497407] # ts1 := map(test_mod,[5,9,11,13,17,19,21,23,25,27,29,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,65]); # ts1 := [0, 0, 1, 2, 0, 1, 2, 3, 4, 5, 6, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 0] # # ts2 := map(test2mod,[5,9,11,13,17,19,21,23,25,27,29,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,65]); # ts2 := [2, 2, 6, 10, 2, 6, 10, 14, 18, 22, 26, 2, 6, 10, 14, 18, 22, 26, 30, 34, 38, 42, 46, 50, 54, 58, 2] # # tps1 := map(test_pow,[5,9,11,13,17,19,21,23,25,27,29,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,65]); # tps1 := [1, 5, 3, 1, 13, 11, 9, 7, 5, 3, 1, 29, 27, 25, 23, 21, 19, 17, 15, 13, 11, 9, 7, 5, 3, 1, 61] # # ats1 := [seq(test_mod((2*j)+1),j=0..32)]; # ats1 := [-1/2, 0, 0, 1, 0, 1, 2, 3, 0, 1, 2, 3, 4, 5, 6, 7, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 0] # # ats2 := [seq(test2mod((2*j)+1),j=0..32)]; # ats2 := [0, 2, 2, 6, 2, 6, 10, 14, 2, 6, 10, 14, 18, 22, 26, 30, 2, 6, 10, 14, 18, 22, 26, 30, 34, 38, 42, 46, 50, 54, 58, 62, 2] # # atps1 := [seq(test_pow((2*j)+1),j=0..32)]; # atps1 := [-1, -1, 1, -1, 5, 3, 1, -1, 13, 11, 9, 7, 5, 3, 1, -1, 29, 27, 25, 23, 21, 19, 17, 15, 13, 11, 9, 7, 5, 3, 1, -1, 61] # # test_mod := n -> (((n mod (2^A000523(n)))-1)/2); test2mod := n -> ((n mod (2^A000523(n)))*2); test_pow := n -> ((n-2)-2*(n mod (2^A000523(n)))); b_as_pol := n -> interpret_as_zeckendorf_expansion(2^(((n-2)-2*(n mod (2^A000523(n)))))*Xmult(5,Xpower(17,((n mod (2^A000523(n)))-1) /2) )); b_as_product := n -> product('luc(2^i)^bit_i(n,i)','i'=1..A000523(n+1)); b_as_sum := proc(n) local i; RETURN(add(((binomial((n mod (2^A000523(n)))*2,i) mod 2)*fibonacci(i+n-2*(n mod (2^A000523(n))))),i=0..(n mod (2^A000523(n)))*2)); end; b_as_fib_sum := proc(n) local i; add(((binomial(((n+((n+1) mod 2)) mod (2^A000523(n)))*2,i) mod 2)*fibonacci(n+((n+1) mod 2)-i)),i=0..((n+((n+1) mod 2)) mod (2^A000523(n)))*2); end; b_as_luc_sum := proc(n) local i; add(((binomial(((n-(n mod 2)) mod (2^A000523(n)))*2,i) mod 2)*luc(n-(n mod 2)-i)),i=0..((n-(n mod 2)) mod (2^A000523(n)))*2); end; # as_fib_sums := [seq(b_as_fib_sum(j),j=1..65)]; # as_fib_sums := [1, 3, 3, 7, 7, 21, 21, 47, 47, 141, 141, 329, 329, # 987, 987, 2207, 2207, 6621, 6621, 15449, 15449, 46347, 46347, # 103729, 103729, 311187, 311187, 726103, 726103, 2178309, 2178309, # 4870847, 4870847, 14612541, 14612541, 34095929, 34095929, # 102287787, 102287787, 228929809, 228929809, 686789427, 686789427, # 1602508663, 1602508663, 4807525989, 4807525989, 10749959329, # 10749959329, 32249877987, 32249877987, 75249715303, 75249715303, # 225749145909, 225749145909, 505248088463, 505248088463, # 1515744265389, 1515744265389, 3536736619241, 3536736619241, # 10610209857723, 10610209857723, 23725150497407, 23725150497407] # A001317_as_sum := proc(n) local i; RETURN(add(((binomial(n,i) mod 2)*(2^i)),i=0..n)); end; bincoeffs_in_factorial_base := proc(n) local i; RETURN(add(((binomial(n,i) mod 2)*((i+1)!)),i=0..n)); end; bincoeffs_in_factorial_base_b := proc(n) local i; RETURN(add(((binomial(2*n,i) mod 2)*((i+1)!)),i=0..2*n)); end; bincoeffs_in_factorial_base_mod_i := proc(n) local i; RETURN(add(((binomial(n,i) mod (i+2))*((i+1)!)),i=0..n)); end; # This gives A001339 (M2901 and N1164) # 1,3,11,49,261,1631,11743,95901,876809,8877691,98641011, bincoeffs_in_factorial_base_no_mod := proc(n) local i; RETURN(add(((binomial(n,i))*((i+1)!)),i=0..n)); end; get_coefficient := proc(e); if(1 = nops(e)) then if(`integer` = op(0,e)) then RETURN(e); else RETURN(1); fi; else if(2 = nops(e)) then if(`*` = op(0,e)) then RETURN(op(1,e)); else RETURN(1); fi; else RETURN(`Cannot find coefficient!`); fi; fi; end; get_exponent := proc(e); if((1 = e) or (-1 = e)) then RETURN(0); else if(1 = nops(e)) then RETURN(1); else if(2 = nops(e)) then if(`^` = op(0,e)) then RETURN(op(2,e)); else RETURN(get_exponent(op(2,e))); fi; else RETURN(`Cannot find exponent!`); fi; fi; fi; end; fibo_cyclotomic := proc(j) local i,p; p := sort(cyclotomic(j,x)); RETURN(add((get_coefficient(op(i,p))*fibonacci(get_exponent(op(i,p)))),i=1..nops(p))); end; compressed_fibbinary := n -> rewrite_0to0_x1to1(fibbinary(n)); wp_compressed_fibbinaries:=proc(upto_n) local b,i; b:=[]; for i from 0 to upto_n do if(compressed_fibbinary(i) = i) then b := [op(b), i]; fi; od: RETURN(b); end; wp_compressed_fibbinaries_inv:=proc(upto_n) local b,i; b:=[]; for i from 0 to upto_n do if(interpret_as_zeckendorf_expansion(rewrite_0to0_1to01(i)) = i) then b := [op(b), i]; fi; od: RETURN(b); end; binpackfib := proc(n) option remember; if(0 = n) then RETURN(0); else RETURN(binpackfib(n-1)+(2^(fib(n+1)-1))); fi; end; binpackfib_rev := proc(n) option remember; if(0 = n) then RETURN(0); else RETURN((binpackfib_rev(n-1)*(2^(fib(n-1))))+1); fi; end; # Produces an integral inverse of triangular numbers. trinv := n -> floor((1+sqrt(1+8*n))/2); # A002262 := [seq(j-((trinv(j)*(trinv(j)-1))/2),j=0..100)]; # A025581 := [seq(((trinv(j)-1)*(((1/2)*trinv(j))+1))-j,j=0..100)]; # Transforms ADDONE, RIGHT0, SUMTABL, RAST and RASTxx contributed by # Antti Karttunen 12. July 2002. add1 := n -> n+1: ADDONE := a -> map(add1,a): # Increment each term by one. RIGHT0 := a -> [0,op(a)]: # Shift right, prepending 0. # SUMTABL(A001477,A001477) gives A003056. # SUMTABL(A000027,A000027) gives A003057. # and SUMTABL(A000027,A001477) & SUMTABL(A001477,A000027) give A002024. A025581 := n -> binomial(1+floor((1/2)+sqrt(2*(1+n))),2) - (n+1); # The X-projection & A002262 := n -> n - binomial(floor((1/2)+sqrt(2*(1+n))),2); # Y-projection (of A001477) A003056 := n -> floor(sqrt(2*(1+n))-(1/2)); # repeat n n+1 times, starting from n = 0. SUMTABL := proc(a,b) local c,i,u; u := binomial(min(nops(a),nops(b))+1,2); c := []; for i from 0 to u-1 do c := [ op(c), a[A025581(i)+1]+b[A002262(i)+1] ]; od; RETURN(c); end: # Theorem: The set of the sequences where each n >= 0 occurs A000108(n) times # (i.e. the permutations of A072643) is closed under these two transformations. # The fixed point of RASTxx is A071673. RAST := (a,b) -> RIGHT0(ADDONE(SUMTABL(a,b))); RASTxx := a -> RIGHT0(ADDONE(SUMTABL(a,a))); antidiagonal_nth_of_rule90x150 := (seed, n) -> rule150(rule90(seed,(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)),(n-((trinv(n)*(trinv(n)-1))/2))); # This gives A018900, the sum of two distinct powers of 2: # I.e. 2^A002024[n]+2^A002262[n-1] A018900f := n -> (2^trinv(n-1) + 2^((n-1)-((trinv(n-1)*(trinv(n-1)-1))/2))); most_two_bits_f := n -> (2^(trinv(n-1)-1) + 2^((n-1)-((trinv(n-1)*(trinv(n-1)-1))/2))); # Gives: [2, 3, 4, 5, 6, 8, 9, 10, 12, 16, 17, 18, 20, 24, 32, 33, 34, 36, 40, 48, 64, 65, 66, 68, 72, 80, 96, 128, 129, 130, 132, 136, 144, 160, 192, 256, 257, 258, 260, 264, 272, 288, 320, 384, 512, 513, 514, 516, 520, 528, 544, 576, 640, 768, 1024, 1025, 1026, 1028, 1032, 1040, 1056, 1088, 1152, 1280, 1536, 2048, 2049, 2050, 2052, 2056, 2064, 2080, 2112, 2176, 2304, 2560, 3072, 4096, 4097, 4098, 4100, 4104, 4112, 4128, 4160, 4224, 4352, 4608, 5120, 6144, 8192, 8193, 8194, 8196, 8200, 8208, 8224, 8256, 8320, 8448] Xmult_iter := proc(nn,mm) local n,m,s; n := nn; m := mm; s := 0; while (n > 0) do if(1 = (n mod 2)) then s := XORnos(s,m); fi; n := floor(n/2); m := m*2; od; RETURN(s); end; Xmult := proc(n,m) option remember; if(0 = n) then RETURN(0); else RETURN(XORnos(((n mod 2)*m),Xmult(floor(n/2),m*2))); fi; end; Xfactorial := proc(n); if(0 = n) then RETURN(1); else RETURN(Xmult(n,Xfactorial(n-1))); fi; end; Xcatalans := proc(upto_n) local a,i,k; a := [1]; for i from 1 to upto_n do a := [ op(a), add(Xmult(a[k],a[i-k+1]), k=1..i)]; od; RETURN(a); end; # Modified from CONV, given at http://www.research.att.com/~njas/sequences/transforms.txt XMULTCONV:=proc(a,b) local c,i,k,n: if whattype(a) <> list then RETURN([]); fi: if whattype(b) <> list then RETURN([]); fi: n:=min( nops(a), nops(b) ): c:=[]: for i from 0 to n-1 do c:=[ op(c), add(Xmult(a[k+1],b[i-k+1]), k=0..i)]: od; RETURN(c); end: Plus_self_convolved := proc(upto_n) local a,i,k; a := [1]; for i from 1 to upto_n do a := [ op(a), add((a[k]+a[i-k+1]), k=1..i)]; od; RETURN(a); end; PLUSCONV:=proc(a,b) local c,i,k,n: if whattype(a) <> list then RETURN([]); fi: if whattype(b) <> list then RETURN([]); fi: n:=min( nops(a), nops(b) ): c:=[]: for i from 0 to n-1 do c:=[ op(c), add((a[k+1]+b[i-k+1]), k=0..i)]: od; RETURN(c); end: Xpower := proc(nn,mm) option remember; if(0 = mm) then RETURN(1); # By definition, also 0^0 = 1. else RETURN(Xmult(nn,Xpower(nn,mm-1))); fi; end; Xpower_loop := proc(nn,mm) local n,m; if(0 = mm) then RETURN(1); # By definition, also 0^0 = 1. else n := nn; m := mm; while (m > 1) do n := Xmult(n,nn); m := m-1; od; RETURN(n); fi; end; mult2xn_columnwise:= (n) -> (((n+1-((trinv(n-1)*(trinv(n-1)-1))/2)))*(trinv(n-1)+1)); Xmult2xn_columnwise:= (n) -> Xmult(((n+1-((trinv(n-1)*(trinv(n-1)-1))/2))),(trinv(n-1)+1)); Xcomposites_upto_n:= (n) -> sort(convert(convert([seq(Xmult2xn_columnwise(jj),jj=1..n)],set),list)); find_Xfactors:=proc(c) local n; for n from 1 to 100000 do if (Xmult(((n+1-((trinv(n-1)*(trinv(n-1)-1))/2))),(trinv(n-1)+1)) = c) then RETURN([((n+1-((trinv(n-1)*(trinv(n-1)-1))/2))),(trinv(n-1)+1)]); fi; od; RETURN([]); end; mult_table_expr := ( (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) * (n-((trinv(n)*(trinv(n)-1))/2)) ); # This gives A004247, e.g. A004247 := [seq(mult_table(j),j=0..119)]; mult_table := (n) -> floor(evalf((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) * (n-((trinv(n)*(trinv(n)-1))/2)) )); mult_table1 := (n) -> floor(evalf(((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1) * (1+(n-((trinv(n)*(trinv(n)-1))/2))) )); mult_table3 := (n) -> floor(evalf(((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+3) * (3+(n-((trinv(n)*(trinv(n)-1))/2))) )); Xmult_table := (n) -> Xmult( (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n),(n-((trinv(n)*(trinv(n)-1))/2)) ); Xmult_table1 := (n) -> Xmult( ((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1),(1+(n-((trinv(n)*(trinv(n)-1))/2))) ); Xmult_table3 := (n) -> Xmult( ((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+3),(3+(n-((trinv(n)*(trinv(n)-1))/2))) ); Xpower_table := (n) -> Xpower( (n-((trinv(n)*(trinv(n)-1))/2)), (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); diff_mult_Xmult_table := (n) -> (mult_table(n) - Xmult_table(n)); # Gives A061859 := [seq(diff_mult_Xmult_table3(j),j=0..119)]; diff_mult_Xmult_table3 := (n) -> (mult_table3(n) - Xmult_table3(n)); # Based on HAKMEM, Item 23 (by Schroeppel): # # (A AND B) + (A OR B) = A + B = (A XOR B) + 2 (A AND B). # # See http://www.inwap.com/pdp10/hbaker/hakmem/boolean.html#item23 addh := proc(a,b) option remember; if(0 = a) then RETURN(b) fi; if(0 = b) then RETURN(a); else RETURN(addh(XORnos(a,b),2*ANDnos(a,b))); fi; end; # The first ending condition is unnecessary above, so we remove it: # (Find an elegant proof that this will eventually terminate with all # a and b in N). add_h := proc(a,b) option remember; if(0 = b) then RETURN(a); else RETURN(add_h(XORnos(a,b),2*ANDnos(a,b))); fi; end; # Count for the previous: add1c := proc(a,b) option remember; if(0 = b) then RETURN(0); else RETURN(1+add1c(XORnos(a,b),2*ANDnos(a,b))); fi; end; # Count for the previous: add2c := proc(a,b) option remember; if((0 = a) or (0 = b)) then RETURN(0); else RETURN(1+add2c(XORnos(a,b),2*ANDnos(a,b))); fi; end; add3c := proc(a,b) option remember; if(0 = ANDnos(a,b)) then RETURN(0); else RETURN(1+add3c(XORnos(a,b),2*ANDnos(a,b))); fi; end; add1c_table := (n) -> add1c( (n-((trinv(n)*(trinv(n)-1))/2)), (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); add2c_table := (n) -> add2c( (n-((trinv(n)*(trinv(n)-1))/2)), (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); add3c_table := (n) -> add3c( (n-((trinv(n)*(trinv(n)-1))/2)), (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); xor_and_shr := proc(a,b) option remember; if(0 = b) then RETURN(a); else RETURN(xor_and_shr(XORnos(a,b),floor(ANDnos(a,b)/2))); fi; end; xasr_table := (n) -> xor_and_shr( (n-((trinv(n)*(trinv(n)-1))/2)), (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); gcd_table := (n) -> gcd( (n-((trinv(n)*(trinv(n)-1))/2)), (((trinv(n)-1)*(((1/2)*trinv(n))+1))-n) ); add_iterative := proc(a,b) local aa,bb,new_aa; aa := a; bb := b; while (bb <> 0) do new_aa := XORnos(aa,bb); bb := 2*ANDnos(aa,bb); aa := new_aa; od; RETURN(aa); end; add_count_recursions := proc(a,b) local aa,bb,new_aa,nn; nn := 0; aa := a; bb := b; while (bb <> 0) do new_aa := XORnos(aa,bb); bb := 2*ANDnos(aa,bb); aa := new_aa; nn := nn + 1; od; RETURN(nn); end; # This counts "the depth of carry bits", 0 if no carries were present at all. # Returns a negative number if on the last iteration/recursion aa and bb # were equal (thus their XOR was 0). count_add1carries := proc(a,b) local aa,bb,new_aa,nn; nn := 0; aa := a; bb := b; while (true) do new_aa := XORnos(aa,bb); bb := 2*ANDnos(aa,bb); if(0 = bb) then RETURN(nn); fi; if(0 = new_aa) then RETURN(-(nn+1)); fi; aa := new_aa; nn := nn + 1; od; RETURN(nn); end; plustable := n -> add_h((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n),(n-((trinv(n)*(trinv(n)-1))/2)) ); count_add1carry_table := n -> count_add1carries((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n),(n-((trinv(n)*(trinv(n)-1))/2)) ); count_add2carry_table := n -> count_add2carries((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n),(n-((trinv(n)*(trinv(n)-1))/2)) ); divbytwospowers:=proc(a) local b,n,i,l_a: if whattype(a) <> list then RETURN([]); fi: l_a := nops(a); b:=[]: for n from 1 to l_a do b:=[op(b), floor(a[n]/(2^(n-1)))]: od: RETURN(b); end: sifactor:=proc(n) local f,b,i: f := ifactor(n); b:=[]: for i from 1 to nops(f) do b:=[op(b), op(1,op(i,f))]: od: RETURN(b); end: # As a sequence A045965 in NJAS's encyclopedia: primedivisorsuccessor_old:=proc(n) local f,r,i,d,e,t,p; f := ifactor(n); if (`^` = op(0,f)) then f := [f]; fi; r:=1; for i from 1 to nops(f) do d := op(i,f); if(1 = nops(d)) then p := op(1,d); e := 1; else # if(2 = nops(d)) p := op(1,op(1,d)); e := op(2,d); fi; r:= r * (nextprime(p)^e); od; RETURN(r); end; # As a sequence A045965 in NJAS's encyclopedia: succfactorization:=proc(n) local p,d; if(1 = n) then RETURN(2); fi; p:=1; for d in ifactors(n)[2] do p := p * (nextprime(d[1])^d[2]); od; RETURN(p); end; factsuccbijection := n -> floor((succfactorization(n)+1)/2); # Invariant Factorization Successors: invariant_factsuccessors:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if(factsuccbijection(i) = i) then b := [op(b), i]; fi; od: RETURN(b); end; invariant_factsuccessors_fprintf:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if(factsuccbijection(i) = i) then b := [op(b), i]; fprintf(default,`%a\n`, i); fflush(default); fi; od: RETURN(b); end; invariant_befs:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if((2*bef(i)) = i) then b := [op(b), i]; fi; od: RETURN(b); end; nthprime:=proc(n) local i; if(isprime(n)) then for i from 1 to 1000000 do if(ithprime(i) = n) then RETURN(i); fi; od; else RETURN(0); fi; end; # This can be applied only to squarefree numbers: f_binary_encoding:=proc(n) local f,s,i,d,t; f := ifactor(n); if (`^` = op(0,f)) then f := [f]; fi; s:=0; for i from 1 to nops(f) do d := op(i,f); if(1 = nops(d)) then s := s + (2^nthprime(op(1,d))); else # if(2 = nops(d)) printf(`Sorry, the divisor %a of %a is not squarefree!\n`, d, n); RETURN(0); fi; od; RETURN(s); end; sqrfrees:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if(0 <> mobius(i)) then b := [op(b), i]; fi; od: RETURN(b); end; # A006881 sqr2frees:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if((0 <> mobius(i)) and (4 = tau(i))) then b := [op(b), i]; fi; od: RETURN(b); end; # with(numtheory,tau); # tau returns the number of divisors of its integer argument, # i.e. with squares of prime p^2, it gives 3 (for {1, p, p^2}) # and with # products of two distinct primes p*q, it returns 4 (for {1, p, q, p*q}) # (but it gives 4 also for 8, as its divisors are {1, 2, 4, 8}, so # we have to check with mobius that in that case the number is square-free) semiprimes:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if((3 = tau(i)) or ((0 <> mobius(i)) and (4 = tau(i)))) then b := [op(b), i]; fi; od: RETURN(b); end; bef:=proc(n) local s,d; s:=0; for d in ifactors(n)[2] do s := s + d[2]*(2^(nthprime(d[1])-1)); od; RETURN(s); end; bef2:=proc(n) local s,d; s:=0; for d in ifactors(n)[2] do s := s + (2^(nthprime(d[1])+d[2]-2)); od; RETURN(s); end; encode_sqrfrees:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if(0 <> mobius(i)) then b := [op(b), bef(i)]; fi; od: RETURN(b); end; # A006881 encode_sqr2frees:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if((0 <> mobius(i)) and (4 = tau(i))) then b := [op(b), bef(i)]; fi; od: RETURN(b); end; encode_semiprimes:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if((3 = tau(i)) or ((0 <> mobius(i)) and (4 = tau(i)))) then b := [op(b), bef(i)]; fi; od: RETURN(b); end; # Well-positioned square-frees: wp_sqrfrees:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if((0 <> mobius(i)) and (bef(i) = (nops(b)+1))) then b := [op(b), bef(i)]; fi; od: RETURN(b); end; # Indices to above one: iwp_sqrfrees:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if((0 <> mobius(i)) and (bef(i) = (nops(b)+1))) then b := [op(b), i]; fi; od: RETURN(b); end; # Well-positioned square-frees: wp_sqr2frees:=proc(upto_n) local b,i; b:=[]; for i from 1 to upto_n do if(((0 <> mobius(i)) and (4 = tau(i))) and (bef(i) = A018900f(nops(b)+1))) then b := [op(b), i]; fi; od: RETURN(b); end; # Indices to above one: iwp_sqr2frees:=proc(upto_n) local b,i,j; b:=[]; j:=1; for i from 1 to upto_n do if(((0 <> mobius(i)) and (4 = tau(i))) and (bef(i) = A018900f(j))) then b := [op(b), j]; j := j+1; fi; od: RETURN(b); end; # Ascending Binary diagonal. # b[n] := Sum(bit_i(a[n+i],i)*(2^i),i=0..inf) # Produces finite terms only if the source sequence 'a' grows # slowly enough. E.g. Fibonacci and Lucas sequences are such, # but 2^n is too steep. # # In practice we have to use a smaller value than infinity # as the upper limit. I.e. here it is the end of the source # sequence, which means that the end of the result sequence # is incorrect and has to be cut off after some point. One way # to use this is to specify the source sequence as # [op(a),op(cdr(guesss(a,n)))] which gives n extra terms, # and then cut the result sequence after some point. # cdr, the "tail of list" function of Lisp is defined as: # cdr:=proc(l) if 0 = nops(l) then ([]) else (l[2..nops(l)]): fi: end: # # And guesss is the sequence extrapolator of Harm Derksen, # hderksen@sci.kun.nl found from calculus/guess directory of Maple # Share-library. # ASCBINDIAG:=proc(a) local b,n,i,aa,l_a: if whattype(a) <> list then RETURN([]); fi: l_a := nops(a); b:=[]: for n from 1 to l_a do b:=[op(b), sum( 'bit_i(a[n+i],i)*(2^i)', 'i'=0..(l_a-n))]: od: RETURN(b); end: # Shallow (1,2) Descending Binary Diagonal, where # the right edge bits become the most significant bits. # SHALLOWDESCBINDIAG:=proc(a) local b,n,i,aa,l_a: if whattype(a) <> list then RETURN([]); fi: l_a := nops(a); b:=[]: for n from 1 to l_a do b:=[op(b), sum( 'bit_i(a[n-i],(2*i))*(2^((n-1)-i))', 'i'=0..(n-1))]: od: RETURN(b); end: # Descending Binary Diagonal # b[n] := Sum(bit_i(a[n-i],i)*(2^i),i=0..(n-1)) # DESCBINDIAG:=proc(a) local b,n,i,aa,l_a: if whattype(a) <> list then RETURN([]); fi: l_a := nops(a); b:=[]: for n from 1 to l_a do b:=[op(b), sum( 'bit_i(a[n-i],i)*(2^i)', 'i'=0..(n-1))]: od: RETURN(b); end: GCDADJ:=proc(a) local b,i: if whattype(a) <> list then RETURN([]); fi: if nops(a) <= 1 then RETURN([]); fi: b:=[]: for i from 2 to nops(a) do b:=[op(b), gcd(a[i],a[i-1]) ]: od: RETURN(b); end: XORADJ:=proc(a) local b,i: if whattype(a) <> list then RETURN([]); fi: if nops(a) <= 1 then RETURN([]); fi: b:=[]: for i from 2 to nops(a) do b:=[op(b), XORnos(a[i],a[i-1]) ]: od: RETURN(b); end: # Like previous, but here the preceding term is shifted once left before # xored with the posterior term: # This transforms one "rule 90"-sequence to another, and the first terms # (or any nth terms) of sequences generated in such way form themselves # a "rule 150" sequence. SHIFTXORADJ:=proc(a) local b,i: if whattype(a) <> list then RETURN([]); fi: if nops(a) <= 1 then RETURN([]); fi: b:=[]: for i from 2 to nops(a) do b:=[op(b), XORnos((a[i-1]*2),a[i]) ]: od: RETURN(b); end: SHIFTnXORADJ:=proc(a,n) local b,i: if whattype(a) <> list then RETURN([]); fi: if nops(a) <= 1 then RETURN([]); fi: b:=[]: for i from 2 to nops(a) do b:=[op(b), XORnos((a[i-1]*(2^n)),a[i]) ]: od: RETURN(b); end: # Constructs a matrix of form n x n, starting from initial value seed, # and by first producing the first column as Rule-150 sequence of # length N with 'seed' used as the initial term, # and then by constructing each row of length N # by Rule-90 sequence of length N, with nth term of the first column # working as a seed term. # Conjecture: All the other columns are valid Rule-150 sequences # as well. CA90x150MATRIX :=proc(seed,n) local i, seed_i, col0, a: a := []; col0 := [seq(rule150(seed,i),i=0..(n-1))]; for seed_i in col0 do a := [op(a), op([seq(rule90(seed_i,i),i=0..(n-1))])]; od; RETURN(matrix(n,n,a)); end; CA66999966x96696996MATRIX := proc(seed,n) local i, seed_i, col0, a: a := []; col0 := [seq(apply96696996(seed,i),i=0..(n-1))]; for seed_i in col0 do a := [op(a), op([seq(apply_90x150_composite(seed_i,i),i=0..(n-1))])]; od; RETURN(matrix(n,n,a)); end; # This is another way. Rows are rule-150 sequences and # columns are rule-90 sequences. # Theorem (or Conjecture): # equal(CA150x90MATRIX(s,n), transpose(CA90x150MATRIX(s,n))) = true # needs yet to be proved. # CA150x90MATRIX :=proc(seed,n) local i, seed_i, col0, a: a := []; col0 := [seq(rule90(seed,i),i=0..(n-1))]; for seed_i in col0 do a := [op(a), op([seq(rule150(seed_i,i),i=0..(n-1))])]; od; RETURN(matrix(n,n,a)); end; A000201fun := n -> floor((n+1)*(1+sqrt(5))/2); # The lower Wythoff sequence. WYTHOFF_MATRIX :=proc(n) local i, j, a, b: a := []; for i from 0 to n-1 do b := [i,floor((i+1)*(1+sqrt(5))/2)]; for j from 0 to n-3 do # printf(`j=%a, b=%a, a=%a\n`, j, b, a); b := [op(b), b[j+1]+b[j+2]]; od; a := [op(a),op(b)]; od; RETURN(matrix(n,n,a)); end; XMULT_MATRIX :=proc(n) local i, j, a, b: a := []; for i from 0 to n-1 do b := []; for j from 0 to n-1 do # printf(`j=%a, b=%a, a=%a\n`, j, b, a); b := [op(b), Xmult(i,j)]; od; a := [op(a),op(b)]; od; RETURN(matrix(n,n,a)); end; XPOWER_MATRIX :=proc(n) local i, j, a, b: a := []; for i from 0 to n-1 do b := []; for j from 0 to n-1 do # printf(`j=%a, b=%a, a=%a\n`, j, b, a); b := [op(b), Xpower(i,j)]; od; a := [op(a),op(b)]; od; RETURN(matrix(n,n,a)); end; ADDCOUNT_MATRIX :=proc(n) local i, j, a, b: a := []; for i from 0 to n-1 do b := []; for j from 0 to n-1 do # printf(`j=%a, b=%a, a=%a\n`, j, b, a); b := [op(b), count_add1carries(i,j)]; od; a := [op(a),op(b)]; od; RETURN(matrix(n,n,a)); end; # Theorem: determinants of all nxn matrices with seed 1 # go like this: # [seq(det(CA90x150MATRIX(1,n)),n=1..13)]; # [1, -8, 256, -32768, 16777216, -1430224109568, # 11716395905581056, -60920408332222813175808, # 7984959760921108568579506176, -4832821973017079976234876288368640, # 5525009511402910343196523934081000952299520, # 18820801145508339494005058842109037023969738596810752, # -631521292222481682984507154573546419406274963804461794852864, # ...] # # # Note: this formula is valid only upto the fifth term 16777216: appr_cand := i -> ((-1)^i)*(2^(i*(i+2))); # # but the determinants of seed-3 matrices: # [seq(det(CA90x150MATRIX(3,n)),n=1..20)] # -> [3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] # # [seq(det(CA90x150MATRIX(11,n)),n=1..20)]; # -> [11, 784, 38144, 480690176, -1583542697984, # 290184715120410624, -56788232520011979161600, # 10239054871088430858899772407808, # -36550035376988768549840805120060686336, # -153036917381791036430699409519762235730165760, # 73643211617338660092252891623151561950960883469385728, # 850626310015590440774329668652176666542066014422415698712068096, # MATR2HTML_TABLE := proc(A, filename) local cols, rows, i, j, fp; fp := fopen(filename,APPEND,BINARY); fprintf (fp, `\n`); for i from 1 to rowdim(A) do fprintf (fp, ``); for j from 1 to coldim(A) do fprintf (fp, ``, A[i,j]); od; fprintf (fp, `\n`); od; fprintf (fp, `
%a
\n`); fclose(fp); end; MATR2HTML_TABLE2 := proc(A, filename) local cols, rows, i, j, fp; fp := fopen(filename,APPEND,BINARY); fprintf (fp, `\n`); for j from 1 to coldim(A) do fprintf (fp, `\n`); for i from 1 to rowdim(A) do fprintf (fp, ``, (i-1)); for j from 1 to coldim(A) do fprintf (fp, ``, A[i,j]); od; fprintf (fp, `\n`); od; fprintf (fp, `
%a`, (j-1)); od; fprintf (fp, `
%a  %a
\n`); fclose(fp); end; detseq_90x150 := proc(i, size) local j, detseq; detseq := []; for j from 1 to size do detseq := [op(detseq),det(CA90x150MATRIX(i,j))]; od; RETURN(detseq); end; # This should produce same answer: detseq_150x90 := proc(i, size) local j, detseq; detseq := []; for j from 1 to size do detseq := [op(detseq),det(CA150x90MATRIX(i,j))]; od; RETURN(detseq); end; # The sequence of double Garden of Edens: that is patterns # that are Garden of Eden both in Rule 90 and Rule 150. # (Where Garden of Eden condition has been reformulated here # so that any pattern which does not have a precedessor amongst # the patterns two cells (bits) shorter is considered as Goe). # GGOESEQ := [1,3,11,13,19,23,25,29,31,33,37,41,43,47,53,55,59,61,67,69,71,73,77,81,87,89,91,97,103,109,111,113,115,117,123]; CREATE_FILE := proc(size, seq, filename) local fp, i,j,A, detseq; fp := fopen(filename,WRITE,BINARY); fprintf (fp,`The first %a Rule 90 x Rule 150 (%ax%a)-Matrices\n`, nops(seq), size, size); fprintf (fp,`
\n`); fclose(fp); for i in seq do fp := fopen(filename,APPEND,BINARY); fprintf (fp,`
`); fclose(fp); A := CA90x150MATRIX(i,size); MATR2HTML_TABLE(A,filename); MATR2HTML_TABLE(map(ifactor,A),filename); detseq := []; for j from 1 to size do detseq := [op(detseq),det(CA90x150MATRIX(i,j))]; od; fp := fopen(filename,APPEND,BINARY); fprintf(fp, `
Detseq is %a
First 6 factored: %a


`, detseq, map(ifactor,detseq[1..6])); fclose(fp); od; fp := fopen(filename,APPEND,BINARY); fprintf (fp,`
`); fclose(fp); end; seq_of_i_j_in_mat_A := proc(A, elem) local b,i,j; b := []; for i from 1 to rowdim(A) do for j from 1 to coldim(A) do if(A[i,j] = elem) then b := [op(b),[i,j]]; fi; od; od; RETURN(b); end; seq_of_h_i_j_in_all := proc(all, elem) local A, b, h, i,j; b := []; for h from 1 to nops(all) do A := all[h]; for i from 1 to rowdim(A) do for j from 1 to coldim(A) do if(A[i,j] = elem) then b := [op(b),[h,i,j]]; fi; od; od; od; RETURN(b); end; check_all := proc(all) local A, b, h, i,j, loc; b := []; # b is a list of duplicates. for h from 1 to nops(all) do A := all[h]; for i from 1 to rowdim(A) do for j from 1 to coldim(A) do loc := seq_of_h_i_j_in_all(all,A[i,j]); if(nops(loc) <> 1) then b := [op(b),loc]; fi; od; od; od; RETURN(b); end; CREATE_MAT_SEQ := proc(size, seq) local b,i; b := []; for i in seq do b := [op(b),CA90x150MATRIX(i,size)]; od; RETURN(b); end; bvp3h := n -> sum( 'bit_i(3^i,n)*(2^i)', 'i'=0..(2^(n-1))-1); bvp3 := n -> sum( 'bit_i(3^i,n)*(2^i)', 'i'=0..(2^(n))-1); # Old shit: # We should have inf instead of l_a - n as the upper index of sum. BINDIAGSW:=proc(a) local b,n,i,aa,l_a: if whattype(a) <> list then RETURN([]); fi: l_a := nops(a); # aa:=[op(a),op(cdr(guesss(a,(l_a+10))))]; b:=[]: for n from 1 to l_a do b:=[op(b), sum( 'bit_i(a[n+i],i)*(2^i)', 'i'=0..(l_a-n))]: od: # for n from 1 to l_a do b:=[op(b), sum( 'bit_i(aa[n+i],i)*(2^i)', 'i'=0..(n+5))]: od: RETURN(b); end: # Gives A037468 base5tobase9 := proc(n) local l,k; l := convert(n,base,5); add(l[k]*9^(k-1), k=1..nops(l)); end; basextobasey := proc(n) local l,k; l := convert(n,base,x); add(l[k]*y^(k-1), k=1..nops(l)); end; base3 := proc(n) local l,k; l := convert(n,base,3); add(l[k]*10^(k-1), k=1..nops(l)); end; list_in_base_b := proc(l,b) local k; add(l[nops(l)-k]*(b^k), k=0..(nops(l)-1)); end; find_k_does_not_divide_fn := proc(k,upto_n) local a,i; a := []; for i from 1 to upto_n do # Stupidities! (in more than one way...) # if(member(k,divisors(binomial((2*i)-1,i)))) then ; # else a := [op(a),i]; fi; if(0 <> (binomial((2*i)-1,i) mod k)) then a := [op(a),i]; fi; od; RETURN(a); end; find_k_does_not_divide_gn := proc(k,upto_n) local a,i; a := []; for i from 1 to upto_n do if(0 <> (binomial((2*i),i) mod k)) then a := [op(a),i]; fi; od; RETURN(a); end; find_n_with_a_to_sqrt_phi_plus_1_always_a_in_mod_n := proc(upto_n) local j,a,m,i; a := []; for i from 2 to upto_n do for m in invphi(i^2) do for j from 1 to m-1 while (((j^(i+1)) mod m) = j) do od; if(j = m) then a := [op(a),m]; fi; od; od; RETURN(a); end; find_squarefree_n_with_square_phi := proc(upto_n) local a,m,i; a := []; for i from 2 to upto_n do for m in invphi(i^2) do if(0 <> mobius(m)) then a := [op(a),m]; fi; od; od; RETURN(a); end; find_n_with_a_to_sqrt_phi_plus_1_always_a_in_mod_n_ordered := proc(upto_n) local a,m,i; a := []; for i from 2 to upto_n do if(issqrfree(i)) # i.e. (0 <> mobius(i)) # it's square-free then m := phi(i); if(issqr(m) and (lambda(i) <= sqrt(m))) then a := [op(a),i]; print(a); fi; fi; od; RETURN(a); end; find_A055095_is_2_composites := proc(upto_n) local j,a; a := []; for j from 1 to upto_n do if(-1 = (j - wt(GrayCode(A055094((2*j)+1))))) then if(not isprime((2*j)+1)) then a := [op(a),((2*j)+1)]; fi; fi; od; RETURN(a); end; A000984 := proc(n) local k; RETURN((mul(((2*k)+1),k=0..n-1)*(2*n))/(n!)); end; all_n_permutations_in_base_n_plus_1 := n -> map(list_in_base_b,permute(n),(n+1)); all_together := proc(u) local a,n; a := []; for n from 1 to u do a := [op(a),op(map(list_in_base_b,permute(n),(n+1)))]; od; RETURN(a); end; ascending_digits := proc(n) local i; add(i*((n+1)^(n-i)),i=1..n); end; descending_digits := proc(n) local i; add(i*((n+1)^(i-1)),i=1..n); end; divby := (n,d) -> n/d; absdiff := (x,y) -> abs(x-y); all_partitions_together := proc(u) local a,n; a := []; for n from 1 to u do a := [op(a),op(sort(map(list_in_base_b,partition(n),(n+1))))]; od; RETURN(a); end; all_partitions_together_including_repetitions := proc(u) local a,n; a := []; for n from 1 to u do a := [op(a),op(sort(map(list_in_base_b,map(op,map(permute,partition(n))),(n+1))))]; od; RETURN(a); end; all_partitions_together_divided := proc(u) local a,n; a := []; for n from 1 to u do a := [op(a),op(map(divby,sort(map(list_in_base_b,partition(n),(n+1))),n))]; od; RETURN(a); end; all_partitions_together_including_repetitions_divided := proc(u) local a,n; a := []; for n from 1 to u do a := [op(a),op(map(divby,sort(map(list_in_base_b,map(op,map(permute,partition(n))),(n+1))),n))]; od; RETURN(a); end; # See Algorithm 2.16: PermLexUnrank(n,r) # on page 56 of Combinatorial Algorithms, Generation, Enumeration and Search, # Donald L. Kreher and Douglas R. Stinson. ISBN 0-8493-3988-X CRC Press, 1998 # See URL: http://www.math.mtu.edu/~kreher/cages.html # [seq(factorial_base(j),j=0..30)]; # [[0], [1], [1, 0], [1, 1], [2, 0], [2, 1], # [1, 0, 0], [1, 0, 1], [1, 1, 0], [1, 1, 1], [1, 2, 0], [1, 2, 1], [2, 0, 0], [2, 0, 1], [2, 1, 0], [2, 1, 1], [2, 2, 0], [2, 2, 1], # [3, 0, 0], [3, 0, 1], [3, 1, 0], [3, 1, 1], [3, 2, 0], [3, 2, 1], # [1, 0, 0, 0], [1, 0, 0, 1], [1, 0, 1, 0], [1, 0, 1, 1], [1, 0, 2, 0], [1, 0, 2, 1], [1, 1, 0, 0]] factorial_base := proc(nn) local n,a,d,j,f; n := nn; if(0 = n) then RETURN([0]); fi; a := []; f := 1; j := 2; while(n > 0) do d := floor(`mod`(n,(j*f))/f); a := [d,op(a)]; n := n - (d*f); f := j*f; j := j+1; od; RETURN(a); end; # It should be much simpler, like this: fac_base := n -> fac_base_aux(n,2); fac_base_aux := proc(n,i) if(0 = n) then RETURN([]); else RETURN([op(fac_base_aux(floor(n/i),i+1)), (n mod i)]); fi; end; print_fac_base := proc(n) print_fac_base_aux(n,1); printf(`\n`); n; end; print_fac_base_aux := proc(n,i) if(n > 0) then print_fac_base_aux(floor(n/(i+1)),i+1); printf (`%a`,(n mod (i+1))); fi; end; # This is essentially same as unrank2 in Ruskey-Myrvold paper # (Ranking and Unranking Permutations in Linear Time) # http://www.theory.csc.uvic.ca/~fruskey/Publications/RankPerm.html # (Also invented by George Russell in 1993) PermUnrank2R := proc(n,r,p) local s; if(0 = n) then RETURN(p); else s := floor(r/((n-1)!)); RETURN(PermUnrank2R(n-1, r-(s*((n-1)!)), permul(p,[[n,s+1]]))); fi; end; # My modification: # We could use the ending condition if(0 = n), but if(0 = r) is faster, in case # r's factorial expansion ends in one more zeros: PermUnrank3Raux := proc(n,r,p) local s; if(0 = r) then RETURN(p); else s := floor(r/((n-1)!)); RETURN(PermUnrank3Raux(n-1, r-(s*((n-1)!)), permul(p,[[n,n-s]]))); fi; end; PermUnrank3R := proc(r) local n; n := nops(factorial_base(r)); convert(PermUnrank3Raux(n+1,r,[]),'permlist',1+(((r+2) mod (r+1))*n)); end; # PermRevLexUnrank (A055089) can be computed also with PermRevLexUnrankA and PermRevLexUnrankAMSD PermRevLexUnrankA := proc(rr) local r,i,p,k; r := rr; p := []; i := 2; while(r <> 0) do for k from i-1 by -1 to i-(r mod i) do p:= permul([[k,k+1]],p); od; r := floor(r/i); i := i+1; od; RETURN(convert(p,'permlist',1+(((rr+2) mod (rr+1))*nops(factorial_base(rr))))); end; # Compare this with PermUnrank3Raux, and you see why the identity # given at A060112 holds: PermRevLexUnrankAMSDaux := proc(n,r,pp) local s,p,k; p := pp; if(0 = r) then RETURN(p); else s := floor(r/((n-1)!)); for k from n-s to n-1 do p:= permul(p,[[k,k+1]]); od; RETURN(PermRevLexUnrankAMSDaux(n-1, r-(s*((n-1)!)), p)); fi; end; PermRevLexUnrankAMSD := proc(r) local n; n := nops(factorial_base(r)); convert(PermRevLexUnrankAMSDaux(n+1,r,[]),'permlist',1+(((r+2) mod (r+1))*n)); end; A060132 := proc(upto_n) local a,i; a := []; for i from 0 to upto_n do if(PermRevLexRank(PermUnrank3R(i)) = i) then a := [op(a),i]; fi; od; RETURN(a); end; # Gives A059590 bin2facbase := proc(n) local i; add((floor(n/(2^i)) mod 2)*((i+1)!),i=0..A000523(n)); end; # This works also: PermUnrank3Laux := proc(n,r,p) local s; if(0 = r) then RETURN(p); else s := floor(r/((n-1)!)); RETURN(PermUnrank3Laux(n-1, r-(s*((n-1)!)), permul([[n,n-s]],p))); fi; end; PermUnrank3L := proc(r) local n; n := nops(factorial_base(r)); convert(PermUnrank3Laux(n+1,r,[]),'permlist',1+(((r+2) mod (r+1))*n)); end; # We need also one which produces fixed length permutations: # (Standard Steinhaus-Trotter-Johnson would work as well) PermUnrank3Rfixaux := proc(n,r,p) local s; if(0 = n) then RETURN(p); else s := floor(r/((n-1)!)); RETURN(PermUnrank3Rfixaux(n-1, r-(s*((n-1)!)), permul(p,[[n,n-s]]))); fi; end; PermUnrank3Rfix := (n,r) -> convert(PermUnrank3Rfixaux(n,r,[]),'permlist',n); swap := (p,i,j) -> convert(permul(convert(p,'disjcyc'),[[i,j]]),'permlist',nops(p)); swap2r := p -> convert(permul([[nops(p)-1,nops(p)]],convert(p,'disjcyc')),'permlist',nops(p)); # Modification of rank2 in Myrvold-Ruskey paper: # q is inverse of p, both are given as permutation lists: PermRank3Aux := proc(n, p, q) if(1 = n) then RETURN(0); else RETURN((n-p[n])*((n-1)!) + PermRank3Aux(n-1,swap(p,n,q[n]),swap(q,n,p[n]))); fi; end; PermRank3R := p -> PermRank3Aux(nops(p),p,convert(invperm(convert(p,'disjcyc')),'permlist',nops(p))); PermRank3L := p -> PermRank3Aux(nops(p),convert(invperm(convert(p,'disjcyc')),'permlist',nops(p)),p); # [0] -> [1,2] # [1] -> [2,1] # [1, 0] -> [1, 3, 2] # [1, 1] -> [3, 1, 2] # [2, 0] -> [2, 3, 1] # [2, 1] -> [3, 2, 1] # [1, 0, 0] -> [1, 2, 4, 3] # [1, 0, 1] -> [2, 1, 4, 3] fexlist2permlist := proc(a) local n,b,j; n := nops(a); if(0 = n) then RETURN([1]); fi; b := fexlist2permlist(cdr(a)); for j from 1 to n do if(b[j] >= ((n+1)-a[1])) then b[j] := b[j]+1; fi; od; RETURN([op(b),(n+1)-a[1]]); end; PermRevLexUnrank := n -> `if`((0 = n),[1],fexlist2permlist(fac_base(n))); PermRevLexUnrank_w := (n,w) -> convert(convert(PermRevLexUnrank(n),'disjcyc'),'permlist',w); # [] or [1] -> 0 0¡ # [2,1] -> 1 1¡ # [1,3,2] -> 2 10¡ # [3,1,2] -> 3 11¡ # [2,3,1] -> 4 20¡ # [3,2,1] -> 5 21¡ # [1,2,4,3] -> 6 100¡ # [2,1,4,3] -> 7 101¡ # [1,4,2,3] # [4,1,2,3] # [2,4,1,3] # [4,2,1,3] # [1,3,4,2] -> 12 # [3,1,4,2] # [1,4,3,2] # [4,1,3,2] # [3,4,1,2] # [4,3,1,2] # [2,3,4,1] -> 18 # [3,2,4,1] # [2,4,3,1] # [4,2,3,1] # [3,4,2,1] # [4,3,2,1] # [1,2,3,5,4] # Is it possible to compute this easily # from the other end? (for j from 1 to n do ...) PermRevLexRank := proc(pp) local p,n,i,j,r; p := pp; n := nops(p); r := 0; for j from n by -1 to 1 do r := r + (((j-p[j])*((j-1)!))); for i from 1 to (j-1) do if(p[i] > p[j]) then p[i] := p[i]-1; fi; od; od; RETURN(r); end; Perm2SiteSwap1 := proc(p) local ip,n,i,a; n := nops(p); ip := convert(invperm(convert(p,'disjcyc')),'permlist',n); a := []; for i from 1 to n do a := [op(a),((ip[i]-i) mod n)]; od; RETURN(a); end; SiteSwap2Perm1 := proc(s) local e,n,i,a; n := nops(s); a := []; for i from 1 to n do e := ((i+s[i]) mod n); if(0 = e) then e := n; fi; a := [op(a),e]; od; RETURN(convert(invperm(convert(a,'disjcyc')),'permlist',n)); end; Perm2SiteSwap2 := proc(p) local ip,n,i,a; n := nops(p); ip := convert(invperm(convert(p,'disjcyc')),'permlist',n); a := []; for i from 1 to n do if(0 = ((ip[i]-i) mod n)) then a := [op(a),n]; else a := [op(a),((ip[i]-i) mod n)]; fi; od; RETURN(a); end; Perm2SiteSwap3 := proc(p) local ip,n,i,a; n := nops(p); ip := convert(invperm(convert(p,'disjcyc')),'permlist',n); a := []; for i from 1 to n do if(0 = ((ip[i]-i) mod n)) then a := [op(a),0]; else a := [op(a),n-((ip[i]-i) mod n)]; fi; od; RETURN(a); end; SiteSwap1ToDec := proc(s) local i,z,n; n := nops(s); z := 0; for i from 1 to n do z := 10*z; if(0 = s[i]) then z := z+n; else z := z+s[i]; fi; od; RETURN(z); end; # Variant 2: (digits reversed, thus, not a valid siteswap) SiteSwap2ToDec := proc(s) local i,z; z := 0; for i from nops(s) by -1 to 1 do z := 10*z + s[i]; od; RETURN(z); end; # Variant 3: (digits reversed and inverted, forms a valid siteswap) SiteSwap3ToDec := proc(s) local i,z,n; n := nops(s); z := 0; for i from n by -1 to 1 do z := 10*z; if(s[i] > 0) then z := z + (n-s[i]); fi; od; RETURN(z); end; # Gives: 1 2 4 10 28 136 726 # Not in EIS! except now as A061417 SiteSwapRotationPermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 1 to upto_n do b := []; u := n!; for r from 0 to u-1 do b := [op(b),1+PermRank3R(SiteSwap2Perm1(rotateL(Perm2SiteSwap2(PermUnrank3Rfix(n,r)))))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; # Gives A061417: SSRPCC := proc(n) local d,s; s := 0; for d in divisors(n) do s := s + phi(n/d)*((n/d)^d)*(d!); od; RETURN(s/n); end; SSRPCCmu := proc(n) local d,s; s := 0; for d in divisors(n) do s := s + mobius(n/d)*((n/d)^d)*(d!); od; RETURN(s/n); end; SSRPCCbin := proc(n) local d,s; s := 0; for d in divisors(n) do s := s + phi(n/d)*(binomial(n,d))*(d!); od; RETURN(s/n); end; # Many interesting sequences beginning with: 1,2,4,11,28 # From EIS: A000166:=proc(n) option remember; if n<=1 then 1-n else (n-1)*(A000166(n-1)+A000166(n-2)); fi; end; A000166dir := n -> `if`((0 = n),1,floor((n!/exp(1)) + (1/2))); # Gives A064636: SSRPCC_with_no_fixed_points := proc(n) local d,k,s; s := 0; for d in divisors(n) do s := s + (1/n) * phi(n/d) * ( (((n/d)^d)*A000166(d)) + add((((n/d)^(d-k)) * (((n/d)-1)^k) * (A000166(d-k)*binomial(d,k))),k=1..d)); od; RETURN(s); end; # Note: We could use the shorter form: # ( add((((n/d)^(d-k)) * (((n/d)-1)^k) * (A000166(d-k)*binomial(d,k))),k=0..d)); # instead of: # ( (((n/d)^d)*A000166(d)) + add((((n/d)^(d-k)) * (((n/d)-1)^k) * (A000166(d-k)*binomial(d,k))),k=1..d)); # if Maple computed 0^0 as 1, not as "undefined" like it does now. # (A000166(d-k)*binomial(d,k)) gives the number of permutations of d elements # with exactly k fixed points. (= A008290) # From: W. Myrvold and F. Ruskey, Ranking and Unranking Permutations in Linear Time # http://www.theory.csc.uvic.ca/~fruskey/Publications/RankPerm.html # Given a permutation p = [p0, p1, ..., p_n-1] its inversion # vector v = [v0, v1, ..., v_n-1] has v_i equal to the # number of entries p_j such that p_j > p_i and j < i. # # See also W.P. Thurston, in the Chapter 9, Braid Groups # in "Word Processing in Groups", by David B.A. Epstein, et al. # at pages 183 & 184. # We leave here the first element, which is always zero, away. Perm2InversionVector := proc(p) local ip,n,i,j,a,c; n := nops(p); # ip := convert(invperm(convert(p,'disjcyc')),'permlist',n); a := []; for i from 2 to n do c := 0; for j from 1 to i-1 do if(p[j] > p[i]) then c := c+1; fi; od; a := [op(a),c]; od; RETURN(a); end; CampanoPerm := proc(n) local z,p,i; p := []; z := fibbinary(n); i := 1; while(z > 0) do if(1 = (z mod 2)) then p := permul(p,[[i,i+1]]); fi; i := i+1; z := floor(z/2); od; RETURN(convert(p,'permlist',i)); end; # # map(convert,A014486[1..20],binary); # # [0, 10, 1010,1100, 101010,101100,110010,110100,111000, # 10101010,10101100,10110010,10110100,10111000,11001010,11001100, # 11010010,11010100,11011000,11100010] # # NonCrossingTranspos([]); -> [] (id.perm) (0) # NonCrossingTranspos([ [] ]); -> [[1 2]] (10) # NonCrossingTranspos([ [],[] ]); -> [[1 2],[3 4]] (1010) # NonCrossingTranspos([ [[]] ]); -> [[1 4],[2 3]] (1100) # NonCrossingTranspos([ [],[],[] ]); -> [[1 2],[3 4],[5 6]] (101010) # NonCrossingTranspos([ [],[[]] ]); -> [[1 2],[3 6],[4 5]] (101100) # NonCrossingTranspos([ [[]],[] ]); -> [[1 4],[2 3],[5 6]] (110010) # NonCrossingTranspos([ [[],[]] ]); -> [[1 6],[2 3],[4 5]] (110100) # NonCrossingTranspos([ [[[]]] ]); -> [[1 6],[2 5],[3 4]] (111000) # This is the interpretation 19. (kk) in the sixth chapter "Exercises on Catalan and Related Numbers" # of Enumerative Combinatorics, Vol. 2, 1999 by R. P. Stanley, Wadsworth, Vol. 1, 1986, # "Fixed-point free involutions w of [2n] such that if i < j < k < l and w(i) = k, # then w(j) <> l". (I.e. the transpositions do not cross). NonCrossingTranspos := n -> convert(NonCrossingTransposAux(binexp2pars(n),1),'permlist',A070939(n)); NonCrossingTransposRev := n -> convert(NonCrossingTransposAux(deepreverse(binexp2pars(n)),1),'permlist',A070939(n)); NonCrossingTransposAux := proc(s,ii) local e,p,i,j; i := ii; p := []; for e in s do p := permul(p,NonCrossingTransposAux(e,i+1)); j := i+CountParens(e)+1; p := permul(p,[[i,j]]); i := j+1; od; RETURN(p); end; NonCrossingTransposRev2TBBS := proc(p) local t,s; s := 0; for t in p do s := s + 2^(t[2]-1); od; RETURN(s); end; CountParens := proc(s) local e,k; if(0 = nops(s)) then RETURN(0); fi; e := 0; for k in s do e := e + 2 + CountParens(k); od; RETURN(e); end; A002995 := proc(n) local d; if(n<2) then RETURN(1); else RETURN( (1/(2*(n-1)))*add(phi((n-1)/d)*binomial(2*d,d),d=divisors(n-1)) - (A000108(n-1)/2) + (`mod`(n+1,2))*(A000108((n/2)-1)/2) ); fi; end; A054357 := n -> `if`(0 = n,1,2*A002995(n+1) - (`mod`(n,2))*A000108((n-1)/2)); # Gives A002995 # (Non-crossing handshakes of 2(n-1) people (each using only one hand) on round table, up to rotations) # as it should. NonCrossingTranspos_upto_cyclic_rotations := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,NonCrossingTransposRev2TBBS(convert(SiteSwap2Perm1(rotateL(Perm2SiteSwap2(NonCrossingTransposRev(CatalanUnrank(n,r))))),'disjcyc')))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; # Gives one-based index of the largest element in the numeric list a FindLargest := proc(a) local i,m; m := 0; for i from 1 to nops(a) do if(0 = m) then m := i; else if(a[i] > a[m]) then m := i; fi; fi; od; RETURN(m); end; RotCycleLargestFirst := proc(c) local x; x := FindLargest(c); if(x <= 1) then RETURN(c); else RETURN([op(c[x..nops(c)]),op(c[1..(x-1)])]); fi; end; FixedCycles := proc(p) local a,i; a := []; for i from 1 to nops(p) do if(p[i] = i) then a := [op(a),[i]]; fi; od; RETURN(a); end; FoataInv := p -> map(op,sort([op(map(RotCycleLargestFirst,convert(p,`disjcyc`))),op(FixedCycles(p))],sortbyfirst)); Foata := proc(p) local c,c1,i,m; c := []; c1 := []; m := 0; for i from 1 to nops(p) do if(p[i] > m) then if(nops(c1) > 1) then c := [op(c),c1]; fi; m := p[i]; c1 := []; fi; c1 := [op(c1),p[i]]; od; if(nops(c1) > 1) then c := [op(c),c1]; fi; RETURN(convert(c,'permlist',nops(p))); end; # Stupid algorithm, why it doesn't use partial sums instead: FoataPermutationCycleCountsOldAndStupid := proc(upto_n) local u,n,a,r,b; a := []; for n from 1 to upto_n do b := []; u := n!; for r from 0 to u-1 do b := [op(b),1+PermRank3R(FoataInv(PermUnrank3R(r)))]; od; a := [op(a),CountCycles(b)]; print (a); od; RETURN(a); end; # A bit better: FoataPermutationCycleCounts := proc(upto_n) local u,n,a,b,i,f; a := []; b := []; f := 1; for i from 0 to upto_n! -1 do b := [op(b),1+PermRank3R(Foata(PermUnrank3R(i)))]; if((f - 1) = i) then a := [op(a),CountCycles(b)]; print (a); f := f*(nops(a)+1); fi; od; RETURN(a); end; FoataPermutationCycleCounts_Lengths_and_LCM := proc(upto_n) local u,n,a,b,i,f; a := []; b := []; f := 1; for i from 0 to upto_n! -1 do b := [op(b),1+PermRank3R(Foata(PermUnrank3R(i)))]; if((f - 1) = i) then a := [op(a),[CountCycles(b), CycleLengths1(b), CyclesLCM(b)]]; print (a); f := f*(nops(a)+1); fi; od; RETURN(a); end; BinExpToPerm := proc(n) local z,p,i; p := []; z := n; i := 1; while(z > 0) do if(1 = (z mod 2)) then p := permul(p,[[i,i+1]]); fi; i := i+1; z := floor(z/2); od; RETURN(convert(p,'permlist',i)); end; # Maple documentation for group[permgroup] says: # # This package follows the convention that ``permutations act on the right''. # In other words, if p1 and p2 are permutations, then the product of p1 and p2 (p1 &* p2) # is defined such that (p1 &* p2)(i) = p2(p1(i)) for i=1..deg. # # And that is just the opposite of what I'm used to, after # reading Rotman (Introduction to the Theory of Groups), # Metsäkylä-Näätänen (Algebra) and A.C. White (Ringing the Changes, # Ringing the Cosets) # # So with this we have: permul(a,b) = a*b(i) = a(b(i)). # # When we multiply from left, the left-hand-side operand a # permutes the ELEMENTS in permutation b (the right-hand-side operand), # and when we are multiplying from right, the right-hand-side # operand b permutes the POSITIONS in permutation a. # # convert(permul([[5,4]],convert([5,4,3,2,1],'disjcyc')),'permlist',5); # -> [4, 5, 3, 2, 1] # # convert(permul(convert([5,4,3,2,1],'disjcyc'),[[5,4]]),'permlist',5); # -> [5, 4, 3, 1, 2] # # permul := (a,b) -> mulperms(b,a); PartPermProduct_left := proc(upto_n) local a,p,q,r; a := []; p := []; for r from 0 to upto_n do q := PermRevLexUnrank(r); p := permul(convert(q,'disjcyc'),p); a := [op(a),convert(p,'permlist',nops(q))]; od; RETURN(a); end; PartPermProduct_right := proc(upto_n) local a,p,q,r; a := []; p := []; for r from 0 to upto_n do q := PermRevLexUnrank(r); p := permul(p,convert(q,'disjcyc')); a := [op(a),convert(p,'permlist',nops(q))]; od; RETURN(a); end; count_transpositions := proc(l) local c,t; t := 0; for c in l do t := t + (nops(c)-1); od; RETURN(t); end; count_permorder := proc(l) local c,t; t := 1; for c in l do t := ilcm(t,nops(c)); od; RETURN(t); end; count_nonfixed := l -> convert(map(nops,l), `+`); # # # # # ID Number: A049344 n written in factorial base. # 0, 1, 10, 11, 20, 21,100,101,110,111,120,121,200,201,210,211,220,221,300,301,310,311,320,321,1000, # 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24 # 1, 2, 1, 2, 1, 3, 1, 2, 3, 2, 1, 2, 3, 2, 1, 2, 3, 1, 3, 2, 3, 2, 3, 4, # # This works nicely upto 120, when we get the permutation [1,2,3,5,4] # Now it works nice upto 720, when we get the permutation [1,2,5,3,6,4,7] # with the swinging (weaved-in) n (here 6) technique! # Gives the sequence A057112. # The 120th permutation produced is [1, 2, 3, 5, 4, 6], just a transposition # (4 5) from the identity permutation. # With this code upto 3600 (= 5*720) distinct permutations of S_7. adj_tp_seq := proc(n) local fl,fd,v; fl := factorial_base(n); fd := fl[1]; if((1 = fd) and (0 = convert(cdr(fl),`+`))) then RETURN(nops(fl)); fi; # This much we know for sure! if(n < 6) then RETURN(2 - (`mod`(n,2))); fi; # because always adj_tp_seq(n) <> adj_tp_seq(n+1) if((0 = convert(cdr(fl),`+`)) and (n < 24)) then RETURN((nops(fl)+1)-fd); fi; # 6 -> 3, 12 -> 2, 18 -> 1, (24 -> 4) if(n < 18) # but > 6 then if(0 = (`mod`(n,2))) then RETURN(2); else RETURN(4-(`mod`(n,4))); fi; else if(n < 24) # but > 18 then RETURN(2+(`mod`(n,2))); else if(n < 120) then if(0 = convert(cdr(fl),`+`)) then RETURN(nops(fl)); else RETURN(adj_tp_seq(`mod`(n,24))); fi; else if(n < 720) then # but n > 120 if(125 = n) then RETURN(5); fi; v := (`mod`(n,5)); if(0 = v) then v := (n-125)/5; RETURN(adj_tp_seq(v)+(`mod`(v+1,2))); else if(5 > (`mod`(n,10))) then RETURN(5-v); else RETURN(v); fi; fi; else if(0 = convert(cdr(fl),`+`)) then RETURN(nops(fl)); fi; RETURN(adj_tp_seq(`mod`(n,720))); fi fi; fi; fi; end; # First 23 terms give the Hamiltonian path of sol4.gif in # http://www.iki.fi/~kartturi/matikka/permgraf/troctahe.htm # Here the 73'th term (beginning of the 3rd batch of 24) # seems to result an identity permutation, in which ever order # we concatenate the first 24 transpositions. # (the angle between identity permutation and 1432... is not appropriate). # heis := atp2perm_ranks(119); # heis := [0, 1, 4, 5, 3, 2, 12, 13, 16, 17, 23, 22, 19, 18, 20, 21, 11, # 10, 7, 6, 8, 9, 15, 14, 74, 75, 77, 76, 73, 72, 78, 79, 82, 83, # 93, 92, 90, 91, 94, 95, 89, 88, 85, 84, 86, 87, 81, 80, 38, 39, # 41, 40, 37, 36, 26, 27, 29, 28, 42, 43, 46, 47, 45, 44, 34, 35, # 33, 32, 30, 31, 25, 24, 0, 1, 4, 5, 3, 2, 12, 13, 16, 17, 23, 22, # 19, 18, 20, 21, 11, 10, 7, 6, 8, 9, 15, 14, 74, 75, 77, 76, 73, # 72, 78, 79, 82, 83, 93, 92, 90, 91, 94, 95, 89, 88, 85, 84, 86, 87, 81] # adj_tp2seq := proc(n) local fl,fd,v; fl := factorial_base(n); fd := fl[1]; if((1 = fd) and (0 = convert(cdr(fl),`+`))) then RETURN(nops(fl)); fi; # This much we know for sure! if(n < 24) then if(1 = (n mod 2)) then RETURN(1); else if((6 = n) or (10 = n) or (16 = n) or (22 = n)) then RETURN(3); else RETURN(2); fi; fi; else if(0 = convert(cdr(fl),`+`)) then RETURN(nops(fl)); else if(n < 120) then v := (`mod`(n,24)); if(1 = (`mod`(fd,2))) then v := (24 - v); fi; RETURN(adj_tp2seq(v)); else # n > 120 v := (`mod`(n,120)); if(1 = (`mod`(fd,2))) then v := (120 - v); fi; RETURN(adj_tp2seq(v)); fi; fi; fi; end; # # 11 2 # 123456 78901 2 # Solution 9: (ababac)(abcba)(b)(abcba)(cababa) # 121213 12321 2 # # Apply transpositions produced with this to 12354 ([[4,5]]) # and check whether we can find a similar palindromic # Hamiltonian path through S5 as the solution 9 in S4. # # Yes we can! Here's one palindromic solution for S5: # sol9s := [seq(sol9seq(i),i=1..23)]; # sol9s := [1,2,1,2,1,3,1,2,3,2,1,2,1,2,3,2,1,3,1,2,1,2,1] # sol9_begin := sol9s[1..11]; # sol9_begin := [1,2,1,2,1,3,1,2,3,2,1] # sol9_end := sol9s[13..23]; # sol9_end := [1,2,3,2,1,3,1,2,1,2,1] # # (I.e. the CSW-algorithm for S4:) # DoubleCourt := [1,2,3,2,3,2,1,2,1,2,3,2,3,2,1,2,1,2,3,2,3,2,1]; # DoubleCourt_begin := DoubleCourt[1..11]; # DoubleCourt_begin := [1,2,3,2,3,2,1,2,1,2,3] # DoubleCourt_end := DoubleCourt[13..23]; # DoubleCourt_end := [3,2,1,2,1,2,3,2,3,2,1] # upto_119 := [op(sol9s),4,op(sol9_begin),4,op(DoubleCourt_begin),4,op(DoubleCourt),4,op(DoubleCourt_end),4,op(sol9_end),4,op(sol9s)]; # # This begins with A060135: A060135_upto_119 := [1,2,1,2,1,3,1,2,3,2,1,2, 1,2,3,2,1,3,1,2,1,2,1,4, 1,2,1,2,1,3,1,2,3,2,1,4, 1,2,3,2,3,2,1,2,1,2,3,4, 1,2,3,2,3,2,1,2,1,2,3,2, 3,2,1,2,1,2,3,2,3,2,1,4, 3,2,1,2,1,2,3,2,3,2,1,4, 1,2,3,2,1,3,1,2,1,2,1,4, 1,2,1,2,1,3,1,2,3,2,1,2, 1,2,3,2,1,3,1,2,1,2,1]; # # # nops(upto_119); = 119 # pos4 := positions(4,upto_119); # pos4 := [24, 36, 48, 72, 84, 96] # pos3 := positions(3,upto_119); # pos3 := [6,9,15,18,30,33,39,41,47,51,53,59,61,67,69,73,79,81,87,90,102,105,111,114] # DIFF(pos3); # [3,6,3,12,3,6,2,6,4,2,6,2,6,2,4,6,2,6,3,12,3,6,3] # # upto_119_ranks := apply_transposititions(upto_119); # # This begins with A060134: # upto_119_ranks := # [ 0, 1, 4, 5, 3, 2, 12, 13, 16, 22, 19, 18, # 20, 21, 23, 17, 15, 14, 8, 9, 11, 10, 7, 6, # 48, 49, 52, 53, 51, 50, 60, 61, 64, 70, 67, 66, # 108,109,112,118,115,101, 99, 98, 96, 97,100,114, # 90, 91, 94, 88, 85, 75, 77, 76, 73, 72, 74, 84, # 86, 80, 78, 79, 82, 83, 81, 87, 89, 95, 93, 92, # 116,106,103,102,104,105,107,117,119,113,111,110, # 68, 69, 71, 65, 63, 62, 56, 57, 59, 58, 55, 54, # 30, 31, 34, 35, 33, 32, 38, 39, 41, 47, 45, 44, # 42, 43, 46, 40, 37, 36, 26, 27, 29, 28, 25, 24] # # nops(convert(upto_119_ranks,'set')); = 120 # `if`((upto_119 = reverse(upto_119)),`on palindromi`,`ei`); -> on palindromi # # full_perms := map(PermRevLexUnrank_w,upto_119_ranks,5); # # full_perms := # [[1,2,3,4,5],[2,1,3,4,5],[2,3,1,4,5],[3,2,1,4,5],[3,1,2,4,5],[1,3,2,4,5], # [1,3,4,2,5],[3,1,4,2,5],[3,4,1,2,5],[3,4,2,1,5],[3,2,4,1,5],[2,3,4,1,5], # [2,4,3,1,5],[4,2,3,1,5],[4,3,2,1,5],[4,3,1,2,5],[4,1,3,2,5],[1,4,3,2,5], # [1,4,2,3,5],[4,1,2,3,5],[4,2,1,3,5],[2,4,1,3,5],[2,1,4,3,5],[1,2,4,3,5], # [1,2,4,5,3],[2,1,4,5,3],[2,4,1,5,3],[4,2,1,5,3],[4,1,2,5,3],[1,4,2,5,3], # [1,4,5,2,3],[4,1,5,2,3],[4,5,1,2,3],[4,5,2,1,3],[4,2,5,1,3],[2,4,5,1,3], # [2,4,5,3,1],[4,2,5,3,1],[4,5,2,3,1],[4,5,3,2,1],[4,3,5,2,1],[4,3,2,5,1], # [4,2,3,5,1],[2,4,3,5,1],[2,3,4,5,1],[3,2,4,5,1],[3,4,2,5,1],[3,4,5,2,1], # [3,4,5,1,2],[4,3,5,1,2],[4,5,3,1,2],[4,5,1,3,2],[4,1,5,3,2],[4,1,3,5,2], # [4,3,1,5,2],[3,4,1,5,2],[3,1,4,5,2],[1,3,4,5,2],[1,4,3,5,2],[1,4,5,3,2], # [1,5,4,3,2],[1,5,3,4,2],[1,3,5,4,2],[3,1,5,4,2],[3,5,1,4,2],[5,3,1,4,2], # [5,1,3,4,2],[5,1,4,3,2],[5,4,1,3,2],[5,4,3,1,2],[5,3,4,1,2],[3,5,4,1,2], # [3,5,4,2,1],[3,5,2,4,1],[3,2,5,4,1],[2,3,5,4,1],[2,5,3,4,1],[5,2,3,4,1], # [5,3,2,4,1],[5,3,4,2,1],[5,4,3,2,1],[5,4,2,3,1],[5,2,4,3,1],[2,5,4,3,1], # [2,5,4,1,3],[5,2,4,1,3],[5,4,2,1,3],[5,4,1,2,3],[5,1,4,2,3],[1,5,4,2,3], # [1,5,2,4,3],[5,1,2,4,3],[5,2,1,4,3],[2,5,1,4,3],[2,1,5,4,3],[1,2,5,4,3], # [1,2,5,3,4],[2,1,5,3,4],[2,5,1,3,4],[5,2,1,3,4],[5,1,2,3,4],[1,5,2,3,4], # [1,5,3,2,4],[5,1,3,2,4],[5,3,1,2,4],[5,3,2,1,4],[5,2,3,1,4],[2,5,3,1,4], # [2,3,5,1,4],[3,2,5,1,4],[3,5,2,1,4],[3,5,1,2,4],[3,1,5,2,4],[1,3,5,2,4], # [1,3,2,5,4],[3,1,2,5,4],[3,2,1,5,4],[2,3,1,5,4],[2,1,3,5,4],[1,2,3,5,4]] # sol9seq := n -> (`if`((n < 13),adj_tp_seq(n),sol9seq(24-n))); atp_perms := proc(upto_n) local t,a,p,i,k; p := convert([1],'disjcyc'); k := nops(factorial_base(upto_n))+1; a := []; for i from 1 to upto_n do a := [op(a),convert(p,'permlist',k)]; t := adj_tp_seq(i); p := permul(p,[[t,t+1]]); od; RETURN(a); end; atp_perm_ranks := proc(upto_n) local t,a,p,i,k; p := convert([1],'disjcyc'); k := nops(factorial_base(upto_n))+1; a := []; for i from 1 to upto_n do a := [op(a),PermRevLexRank(convert(p,'permlist',k))]; t := adj_tp_seq(i); p := permul(p,[[t,t+1]]); od; RETURN(a); end; atp2perms := proc(upto_n) local t,a,p,i,k; p := convert([1],'disjcyc'); k := nops(factorial_base(upto_n)); a := []; for i from 1 to upto_n do a := [op(a),convert(p,'permlist',k)]; t := adj_tp2seq(i); p := permul(p,[[t,t+1]]); od; RETURN(a); end; atp2perm_ranks := proc(upto_n) local t,a,p,i,k; p := convert([1],'disjcyc'); k := nops(factorial_base(upto_n))+1; a := []; for i from 1 to upto_n do a := [op(a),PermRevLexRank(convert(p,'permlist',k))]; t := adj_tp2seq(i); p := permul(p,[[t,t+1]]); od; RETURN(a); end; csw_perm_list := proc(n) local a; if(3 = n) then RETURN(atp2perms(6)); fi; if(4 = n) then RETURN(csw_perm_list_aux(n,[[3,1],[1,3],[2,5]])); fi; if(5 = n) then RETURN(csw_perm_list_aux(n,[[4,0], [3,6],[1,12],[2,18]])); fi; if(6 = n) then RETURN(csw_perm_list_aux(n,[[4,1], [5,25],[3,49],[1,73],[2,97]])); fi; if(7 = n) then RETURN(csw_perm_list_aux(n,[[6,0], [4,120], [5,240], [3,360], [1,480], [2,600]])); fi; end; # 3,1,2 # 4,3,1,2 # 4,5,3,1,2 # 6,4,5,3,1,2 # We get three possible CSW-orderings for S_5, as there exist # pairs of 4's in three different locations in CSW-ordering of S_4. # csw5a := csw_perm_list_aux(5,[[4,0], [3,6],[1,12],[2,18]]); # csw5b := csw_perm_list_aux(5,[[3,2], [4,8],[1,14],[2,20]]); # csw5c := csw_perm_list_aux(5,[[3,4],[1,10],[4,16],[2,22]]); # s is a list of splice-location pairs. csw_perm_list_aux := proc(n,s) local a,p; a := csw_perm_list(n-1); for p in reverse(s) do a := [op(a[1..p[2]]),op(create_D_vec(p[1],n-1,p[2])),op(a[(p[2]+1)..nops(a)])]; od; RETURN(map(convert,map(convert,a,'disjcyc'),'permlist',n)); end; # create_D_vec(3,3,0); # -> [[1, 2, 4, 3], [1, 4, 2, 3], [4, 1, 2, 3], [4, 2, 1, 3], [2, 4, 1, 3], [2, 1, 4, 3]] # create_D_vec(1,3,2); # -> [[2, 3, 4, 1], [2, 4, 3, 1], [4, 2, 3, 1], [4, 3, 2, 1], [3, 4, 2, 1], [3, 2, 4, 1]] # create_D_vec(2,3,4); # -> [[3, 1, 4, 2], [3, 4, 1, 2], [4, 3, 1, 2], [4, 1, 3, 2], [1, 4, 3, 2], [1, 3, 4, 2]] # s is one-based starting offset. create_D_vec := proc(i,n,s) local a,k; k := n!; a := csw_perm_list(n); a := map(convert,reverse([op(a[(s+1)..k]),op(a[1..(s)])]),'disjcyc'); RETURN(map(convert,map(mulperms,a,[[i,n+1]]),'permlist',n+1)); end; # From the right, starting from the identity permutation: apply_transpositions := proc(a) local k,b,t,p; p := []; k := nops(factorial_base(nops(a)))+1; b := [PermRevLexRank(convert(p,'permlist',k))]; for t in a do p := permul(p,[[t,t+1]]); b := [op(b),PermRevLexRank(convert(p,'permlist',k))]; od; RETURN(b); end; # # If tp = q (where t is some permutation (e.g. a transposition) # and p and q are successive permutations in list aa, we get t from p and q # by the following equation tp(p^-1) = q(p^-1) <=> t = q(p^-1) # # c stands for cyclic. # perm_diffs_c := proc(aa) local a,b,i,j; a := map(convert,aa,'disjcyc'); b := []; for i from 1 to nops(a) do if (nops(a) = i) then j := 1; else j := i+1; fi; b := [op(b),permul(invperm(a[i]),a[j])]; od; RETURN(b); end; print_perm_diffs_c := proc(aa,n) local a,b,i,j; a := map(convert,aa,'disjcyc'); b := []; for i from 1 to nops(a) do if (nops(a) = i) then j := 1; else j := i+1; fi; printf(`%a: %a=%a (%a)\n`,i,convert(a[i],'permlist',n),a[i],permul(invperm(a[i]),a[j])); b := [op(b),permul(invperm(a[i]),a[j])]; od; RETURN(b); end; # csw4 := csw_perm_list(4); # csw4 := [[1, 2, 3, 4], [1, 2, 4, 3], [1, 4, 2, 3], [4, 1, 2, 3], [4, 2, 1, 3], [2, 4, 1, 3], [2, 1, 4, 3], [2, 1, 3, 4], # [2, 3, 1, 4], [2, 3, 4, 1], [2, 4, 3, 1], [4, 2, 3, 1], [4, 3, 2, 1], [3, 4, 2, 1], [3, 2, 4, 1], [3, 2, 1, 4], # [3, 1, 2, 4], [3, 1, 4, 2], [3, 4, 1, 2], [4, 3, 1, 2], [4, 1, 3, 2], [1, 4, 3, 2], [1, 3, 4, 2], [1, 3, 2, 4]] # # csw4r := map(swap2r,csw4); # csw4r :=[[1, 2, 4, 3], [1, 2, 3, 4], [1, 3, 2, 4], [3, 1, 2, 4], [3, 2, 1, 4], [2, 3, 1, 4], [2, 1, 3, 4], [2, 1, 4, 3], # [2, 4, 1, 3], [2, 4, 3, 1], [2, 3, 4, 1], [3, 2, 4, 1], [3, 4, 2, 1], [4, 3, 2, 1], [4, 2, 3, 1], [4, 2, 1, 3], # [4, 1, 2, 3], [4, 1, 3, 2], [4, 3, 1, 2], [3, 4, 1, 2], [3, 1, 4, 2], [1, 3, 4, 2], [1, 4, 3, 2], [1, 4, 2, 3]] # print_info := proc(a,i) local p,s,pr; p := Perm2InversionVector(a[i]); s := convert(p,`+`); pr := Perm2InversionVector(`if`((1 = i),[],a[i-1])); printf(`%a = %a --> %a %a %a\n`, i-1,SiteSwap2ToDec(Perm2InversionVector(PermRevLexUnrank(i-1))), SiteSwap2ToDec(p),s, (1/2)*(1+(s-convert(pr,`+`)))); end; print_infos := proc(l) local i; for i from 1 to nops(l) do print_info(l,i); od; end; triang_perm := proc(upto_d) local a,i,j; a := []; for i from 1 to upto_d do for j from 1 to floor((i+1)/2) do a := [op(a),binomial((i-j)+1,2)+j]; od; od; RETURN(a); end; # divisors should return the divisors from the smallest to largest, # in ascending order! We make that absolutely sure with sort. ordered_pair_perm := proc(upto_n) local a,i,j; a := []; for i from 1 to upto_n do for j in sort(divisors(i)) do a := [op(a),binomial(((i/j) + j - 1),2)+j]; od; od; RETURN(a); end; # This does it: map(op,[seq(reverse(divisors(j)),j=1..30)]); A056538seq := proc(upto_n) local a,i,j; a := []; for i from 1 to upto_n do for j in sort(divisors(i)) do a := [op(a),(i/j)]; od; od; RETURN(a); end; A056539 := n -> runcounts2binexp(reverse(binexp2runcounts(n))); # Can be used to generate A001917 and A006694. # A001917 1,1,2,1,1,2,1,2,1,6,1,2,3,2,1,1,1,1,2,8,2,1,8,2,1,2,1,3,4,18,1,2,1, # 1,10,3,1,2,1,1,1,2,2,1,2,1,6,1,3,8,2,10,5,16,2,1,2,3,4,3,1,3,2,2,1,11,16,1 # Name: (p-1)/x, where 2^x == 1 mod p. # Where x = A002326 1,2,4,3,6,10,12,4,8,18,6,11,20,18,28,5,10,12,36,12,20,14, # 12,23,21,8,52,20,18,58,60,6,12,66,22,35,9,20,30,39,54,82,8,28,11,12,10,36, # 48,30,100,51,12,106,36,36,28,44,12,24,110,20,100,7,14,130,18,36,68,138,46, # 60,28,42,148,15,24 # Name: Multiplicative order of 2 mod 2n+1. f:=n->order(2,2*n+1); # 1, 123, 12345, 1234567, 123456789, etc. # rss_perms := [seq((gen_rss_perm((2*j))),j=1..12)]; # rss_perms := [[2, 1], [2, 4, 1, 3], [2, 4, 6, 1, 3, 5], # # [2, 4, 6, 8, 1, 3, 5, 7], [2, 4, 6, 8, 10, 1, 3, 5, 7, 9], # # [2, 4, 6, 8, 10, 12, 1, 3, 5, 7, 9, 11], # # [2, 4, 6, 8, 10, 12, 14, 1, 3, 5, 7, 9, 11, 13], # # [2, 4, 6, 8, 10, 12, 14, 16, 1, 3, 5, 7, 9, 11, 13, 15], # # [2, 4, 6, 8, 10, 12, 14, 16, 18, 1, 3, 5, 7, 9, 11, 13, 15, 17], # # [2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 1, 3, 5, 7, 9, 11, 13, 15, 17, 19], # [2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21], # # [2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23]] # # Obviously, the regular part [2, 4, 6, 8, 10, ...] produces the n! part of # the rank, and the "irregular" (how irregular? Not much) trailing part # produces what is left over. (Which one is which one, actually?) # # rss_perm_ranks := [seq(PermRevLexRank(gen_rss_perm((2*j))),j=0..12)]; # # An interesting sequence worth of more attention! (not in EIS): # # rss_perm_ranks := [0, 1, 10, 186, 6936, 462120, 48453840, 7321381200, # 1502852238720, 401839064968320, 135607710522412800, # 56349204870411129600, 28263671938641718656000] # # > map(ifactor,rss_perm_ranks); # # 3 2 3 #[0, 1, (2) (5), (2) (3) (31), (2) (3) (17) , (2) (3) (5) (3851), # # 4 2 4 2 2 # (2) (3) (5) (173) (389), (2) (3) (5) (7) (290531), # # 7 2 # (2) (3) (5) (7) (37273121), # # 7 4 # (2) (3) (5) (7) (17) (1583) (41149), # # 8 4 2 # (2) (3) (5) (7) (71) (526335911), # # 8 4 2 # (2) (3) (5) (7) (11) (229) (6164482043), # # 10 5 3 # (2) (3) (5) (7) (11) (11801076212957)] # # Note: 2^7 * 3^4 * 5 * 7; = 362880 = 9! # 1583*41149*17 = 1107360739 # 1107360739*9! = 401839064968320 # And: 2^10 * 3^5 * 5^2 * 7 * 11 = 479001600 = 12! # # # rss_perm_ranks_per_factorial := [seq(PermRevLexRank(gen_rss_perm((2*j)))/j!,j=0..12)]; # rss_perm_ranks_per_factorial := # [0, 1, 5, 31, 289, 3851, 67297, 1452655, 37273121, 1107360739, 37369849681, 1411666387847, 59005381064785] # map(ifactor,rss_perm_ranks_per_factorial); # 2 # [0, 1, (5), (31), (17) , (3851), (173) (389), (5) (290531), (37273121), (17) (1583) (41149), (71) (526335911), # (229) (6164482043), (5) (11801076212957)] # # # n should be even, we leave out the last digit in siteswap, # always a cycle of its own: gen_rss_perm := proc(n) local a, i; # Generate Rising SiteSwap Permutation. a := []; for i from 1 to n do a := [op(a), ((2*i) mod (n+1))]; od; RETURN(a); end; gen_rss2_perm := proc(n) local a, c, i; # Generate Rising SiteSwap (by 2 steps) Permutation. a := []; for i from 0 to n-1 do c := (((3*i)+2) mod n); if(0 = c) then c := n; fi; a := [op(a), c]; od; RETURN(a); end; # 1, 13, 1357, 13579, 13579bd, etc. # 1, 21, 2143, 25314, # rss2_perms := [seq(nops(convert(gen_rss2_perm(j),`set`)),j=1..33)]; # rss2_perms := [1, 2, 1, 4, 5, 2, 7, 8, 3, 10, 11, 4, 13, 14, 5, 16, # 17, 6, 19, 20, 7, 22, 23, 8, 25, 26, 9, 28, 29, 10,31,32,11] # # This generates valid permutations only when n is one of # A001651 Not divisible by 3. (Check it.) # 1,2,4,5,7,8,10,11,13,14,16,17,19,20,22,23,25,26,28,29,31,32, # 34,35,37,38,40,41,43,44,46,47,49,50,52,53,55,56,58,59,61,62, # 64,65,67,68,70,71,73,74,76,77,79,80,82,83,85,86,88,89,91,92,94,95,97 # # a(n) = 3+a(n-2). a(n) = a(n-1)+a(n-2)-a(n-3). a(2n) = 3n+1, a(2n-1) = 3n-1. # G.f.: (1+x+x^2)/((1-x)*(1-x^2)) - Michael Somos, June 7, 2000 # a(n) = (4-n)*a(n-1)+2*a(n-2)+(n-3)*a(n-3) (from the Carlitz et al. article). A001651seq := n -> ((3*floor((n+1)/2)) + ((-1)^n)); # #rss2_valid_perm_ranks := [seq(PermRevLexRank(gen_rss2_perm(A001651seq(j))),j=0..30)]; #rss2_valid_perm_ranks := [0, 1, 7, 44, 1090, 7836, 509226, 4955352, # # 619443096, 7892330160, 1604057070120, 25330048192080, # # 7584056810335440, 142789927748902560, 59046138658853413200, # # 1290351405674175304320, 704005414965834908814720, # # 17510171601213632189802240, 12180888757729759092877192320, # # 339685872568756355909213049600, 293382618322770627855717997612800, # # 9065042909440975152673194287347200, # # 9515764170412973235096929210348409600, # # 322658454620453569086337236770158310400, # # 404532180122659379114943325695143734656000, # # 14933546596351068794316653546697836060620800, # # 22038469015208507260313824635651895931766604800, # # 879823854427941785300768387178406380391494297600, # # 1509590922784120523668556844928888478144307533260800, # # 64803444975558704203338384538656867366776734265856000, # # 127909257269053396408922921141530061750847332680374528000] #rss2_cycles := [seq(nops(convert(gen_rss2_perm(A001651seq(j)),'disjcyc')),j=0..30)]; #rss2_cycles := [0, 1, 2, 1, 1, 2, 3, 2, 4, 3, 2, 1, 1, 6, 3, 2, 2, 5, # # 6, 1, 1, 2, 3, 4, 2, 3, 10, 5, 1, 6, 3] # #> map(ifactor,rss2_valid_perm_ranks[1..15]); # # 2 2 #[0, 1, (7), (2) (11), (2) (5) (109), (2) (3) (653), (2) (3) (84871), # # 3 3 # (2) (3) (19) (10867), (2) (3) (25810129), # # 4 3 # (2) (3) (5) (11) (13) (229963), (2) (3) (5) (13367142251), # # 4 3 # (2) (3) (5) (11726874163), # # 4 2 # (2) (3) (5) (150211) (3643) (19249), # # 5 2 # (2) (3) (5) (7) (499) (28388111093), # # 4 2 2 # (2) (3) (5) (7) (23) (43) (509) (4654541291)] # # GrayCode := n -> XORnos(n,floor(n/2)); # Rewrite from the most significant end: # 0 -> 10 # 1 a b -> 1 rewrite(a) rewrite(b) 0 # # Note that this rewrite process duplicates the length # of binary expansion of n, provided that n is a valid # balanced encoding of Catalan Mountain Range. # bintree_depth_first2tree(2); # 2, 10, 180, 47940, 3185189700 # 10, 1010, 10110100, 1011101101000100, 10111101110110100010001101000100 # A sequence: How many bits from the end are same? 2,1,4,11, ? # 4321 0 9 87654321 0 # 1010(0) -> (1)10110100(0) bt_df2tree_apply_k_times := proc(n,k) option remember; if(0 = k) then (n) else bt_df2tree_apply_k_times(bintree_depth_first2tree(n),k-1); fi; end; bintree_depth_first2tree := n -> ((btdf2t(n*2,A000523(n)+1)/2) - 2^(2*(A000523(n)+1))); btdf2t := proc(n,ii) local i,e,x,y; i := ii; if(n >= (2^i)) then x := btdf2t(n - (2^i),i-1); # Rewrite from that point on. i := i - ((A000523(x)+1)/2); # Length of rewritten subseq a = half of x's length y := btdf2t((n mod (2^i)),i-1); # Rewrite subsequence b. RETURN((2^(A000523(y)+2))*((2^(A000523(x)+1)) + x) + 2*y); else RETURN(2); # 0 -> 10 fi; end; # From: Wouter Meeussen # To: "'seqfan@ext.jussieu.fr'" # Subject: je-ne-sais-quoi, again...Date: Tue, 2 May 2000 19:02:32 +0100 # trees : depth first or width first # example: # # 1 # # 1 1 # # 0 1 1 1 # 0 0 0 0 0 1 # 0 0 # # depth first (caterpillar-wise) is ( 1( 1 0 (1 0 0) ) (1 (1 0 0) (1 0 (100) ) ) ) # # 0 1 2 3456 78 9A BC DE # width first is row-by-row: (1)(1 1) (0111)(00 00 01)(00) # # 10 0000 1110 11 1 # # # btbf2df(4215,0,1) = 27028 = 110100110010100 # # width->depth 013 478 259A 6BCDE # Jos kaikki olisi ykkosta, niin # vasen reuna menisi 0,1,3,7,15, etc. # seuraavaksi vasemmaisin 0,1,4,9,19 ((2^i - 1)+...) # Seuraava rivi: kaksi kertaa niin monta nollaa tai ykkosta # kuin edellisessa rivissa oli ykkosia. # Rivin n k:tta 1-digittia vastaava haara on rivilla n+1 # 2*k ja 2k +1 's digit-pari. # Kun traversoidaan, niin pidetaan koko ajan lukua siita, # monennellako rivilla ollaan (onko aivan pakko?) # ja kuinka mones ykkonen silla rivilla on. # Jos tulee jossain haarassa vasemmalla vastaan 0, niin # kokeillaan oikeata haaraa, jos siellakin nolla, niin palataan # rekursiokutsusta. # n: the binary sequence cut so that it begins with the next row. # i: we are examining the children of the ith 1 on the preceding row # w: twice the number of 1's on the preceding row, i.e. the # width of the first row of n. # Or is this better: # # n: the binary sequence cut so that it begins right from the # beginning of the row where is the 1-digit # of the branch we are going to traverse. # i: this belong # r: "pointer to the beginning of the next row", i.e. # then length of the remaining piece of this row, beginning # from this 1-digit we are examining. # Convention: let's fix root to the least significant bit, i.e. # all trees are odd. (We can do bit-reversing later). # We need: The location of 1-branch we are going to traverse, # either explicitly or implicitly (i.e. the MSB or LSB of n) # # B) The beginning point of the next row. # C) The number of 1's on the previous row, # i.e. the width of the next row (*2). # D) The position of this 1-branch on the previous row. # (i.e. how manyth 1 it was, to know where its children # are on the next row.) # This D) can be computed from B and C. # i.e. count how many 1's there are before # the beginning of the next row, and subtract # that from C. # n: the binary sequence cut so that it begins with the left # child we are going to traverse.on. # i: how manyth 1-branch we are now examining? (zero-based) # r: the next row begins r digits from the beginning of n. # # From i & r one can compute: # c: the number of 1's on the preceding row, i.e. the # half of the width of the row beginning from r. # Invoked from the root with btbf2df(floor(n/2),0,2) # 1 11, 10 11, 10 11 01, 00 00 00 00 # n # i=0 # r=1 # # n # i=0 # r=2 # # n # i=0 # r=4 # # n # i=0 # r=6 # # n # i=1 # r=1 # # n # i=1 # r=2 # # n # i=1 # r=4 # # # # convert(5871,binary); = 1011011101111 # btbf2df(5871,0,1); -> 1973396 = 111100001110010010100 # # convert(112,binary); = 1110000 # btbf2df(binrev(112),0,1); -> 100 = 1100100 # btbf2df(binrev(100),0,1); -> 104 = 1101000 # btbf2df(binrev(104),0,1); -> 112 = 1110000 # Ei ihan toimi: bintree_bf2tree := n -> ((btdf2t(btbf2df(binrev(n),0,1),A000523(n)+1)/2) - 2^(2*(A000523(n)+1))); # # A014486 = [0,2,10,12,42,44,50,52,56,170,172,178,180,184,202,204,210,212,216, # 226,228,232,240,682,684,690,692,696,714,716,722,724,728,738,740, # 744,752,810,812,818,820,824,842,844,850,852,856,866,868,872,880]; # # Name: Decimal representation of binary representation of planar planted # trees with n nodes. # # permseq := [seq(btbf2df(binrev(A014486[j]),0,1)/2,j=1..nops(A014486))]; # permseq := [0, 2, 10, 12, 42, 44, 52, 56, 50, 170, 172, 180, 184, 178, # 212, 216, 232, 240, 228, 202, 204, 210, 226, 682, 684, 692, 696, # 690, 724, 728, 744, 752, 740, 714, 716, 722, 738, 852, 856, 872, # 880, 868, 936, 944, 976, 992, 968, 916, 920, 932, 964] # # convert(180,binary); = 10110100 # # # 1 # 0 1 # 1 0 # 1 0 # 0 (0) # # btbf2df_d(binrev(180),0,1); = 368 = 101110000 # # # 1 01 10 10 0(0) # n=45 # i=0 # r=1 # # n=22 # i=0 # r=2 # # n=11 # i=0 (olikin 1) # r=1 # # n=5 # i=1 # # Note: the last row consists always of zeroes only. btbf2df := proc(nn,i,r) local n,j,c,x,y,w; n := nn; if(0 = (n mod 2)) then RETURN(0); fi; c := i; for j from 1 to r do c := c + (n mod 2); n := floor(n/2); od; w := 2*c; c := 0; # Now w = twice the count of ones on preceding row, the width of the next one. # n points to the beginning of the next row. for j from 1 to (2*i) do c := c + (n mod 2); n := floor(n/2); od; # Now c = how manyth 1 is the one at the beginning of n (zero-based) x := btbf2df(n,c,(w-(j-1))); y := btbf2df(floor(n/2),c+(n mod 2),(w-(j))); RETURN((2^(A070939(x)+A070939(y))) + (x * (2^(A070939(y)))) + y); end; btbf2df_d := proc(nn,i,r) local n,j,c,x,y,w; n := nn; printf(`Entering btbf2df(%a,%a,%a)\n`,n,i,r); if(0 = (n mod 2)) then printf(`Leaving with zero\n`); RETURN(0); fi; c := i; for j from 1 to r do c := c + (n mod 2); n := floor(n/2); od; w := 2*c; c := 0; # Now w = twice the count of ones on preceding row, the width of the next one. # n points to the beginning of the next row. for j from 1 to (2*i) do c := c + (n mod 2); n := floor(n/2); od; # Now c = how manyth 1 is the one at the beginning of n (zero-based) x := btbf2df_d(n,c,(w-(j-1))); y := btbf2df_d(floor(n/2),c+(n mod 2),(w-(j))); printf(`In btbf2df(%a,%a,%a): n=%a, c=%a, w=%a, j=%a, (w-j)=%a, x=%a, y=%a\n`,nn,i,r, n, c, w, j, (w-j),x,y); RETURN((2^(A070939(x)+A070939(y))) + (x * (2^(A070939(y)))) + y); end; # Like NextSubBinTree, but leaves the extra zero off: # Like Lisp CAR NextBalSubSeq := proc(nn) local n,z,c; n := nn; c := 0; z := 0; while(1 = 1) do z := 2*z + (n mod 2); c := c + (-1)^n; n := floor(n/2); if(c >= 0) then RETURN(z); fi; od; end; PeelNextBalSubSeq := proc(nn) local n,z,c; if(0 = nn) then RETURN(0); fi; n := nn; c := 0; z := 0; while(1 = 1) do z := 2*z + (n mod 2); c := c + (-1)^n; n := floor(n/2); if(c >= 0) then RETURN((z - 2^(A000523(z)))/2); fi; od; end; # RestBalSubSeq := proc(nn) local n,z,c; n := nn; c := 0; while(1 = 1) do c := c + (-1)^n; n := floor(n/2); if(c >= 0) then break; fi; od; z := 0; c := -1; while(1 = 1) do z := 2*z + (n mod 2); c := c + (-1)^n; n := floor(n/2); if(c >= 0) then RETURN(z/2); fi; od; end; # Starting from the bit-0 (supposed to be 1), # this gives the totally balanced subsequence # of 1's and 0's (contained by that "root"), # followed by additional zero. # Count c contains the count of surplus 0's, each # 1 will decrement, and each 0 increment it by one. # When it gets to 1 we stop. NextSubBinTree := proc(nn) local n,z,c; n := nn; c := 0; z := 0; while(c < 1) do z := 2*z + (n mod 2); c := c + (-1)^n; n := floor(n/2); od; RETURN(z); end; BinTreeLeftBranch := n -> NextSubBinTree(floor(n/2)); BinTreeRightBranch := n -> NextSubBinTree(floor(n/(2^(1+A070939(BinTreeLeftBranch(n)))))); ReflectBinTree := n -> ReflectBinTree2(n)/2; ReflectBinTree2 := n -> (`if`((0 = n),n,ReflectBinTreeAux(binrev(n)))); ReflectBinTreeAux := proc(n) local a,b; a := ReflectBinTree2(BinTreeLeftBranch(n)); b := ReflectBinTree2(BinTreeRightBranch(n)); RETURN((2^(A070939(b)+A070939(a))) + (b * (2^(A070939(a)))) + a); end; # Basically, reverse the leftmost trunk (from the root to the leftmost leaf). # I.e. take its right branches, and make them left branches of the new tree. RotateBinTree := proc(nn) local n,s,z,w; n := binrev(nn); z := 0; w := 0; while(1 = (n mod 2)) do s := BinTreeRightBranch(n); z := z + (2^w)*s; w := w + A070939(s); z := z + (2^w); w := w + 1; n := floor(n/2); od; RETURN(z); end; RotateBinTreeR := n -> ReflectBinTree(RotateBinTree(ReflectBinTree(n))); DeepRotateBinTree := proc(nn) local n,s,z,w; n := binrev(nn); z := 0; w := 0; while(1 = (n mod 2)) do s := DeepRotateBinTree(BinTreeRightBranch(n))*2; z := z + (2^w)*s; w := w + A070939(s); z := z + (2^w); w := w + 1; n := floor(n/2); od; RETURN(z); end; # See A009766. Cat := n -> binomial(2*n,n)/(n+1); A000108 := n -> binomial(2*n,n)/(n+1); A014137 := proc(n) option remember; if(0 = n) then RETURN(1); else RETURN(Cat(n)+A014137(n-1)); fi; end; CBCPSUM := proc(n) option remember; if(0 = n) then RETURN(1); else RETURN(binomial(n,floor(n/2))+CBCPSUM(n-1)); fi; end; CatTrianglDirect := (r,m) -> `if`((m < 0),0,((r-m+1)*(r+m)!)/(r! * m! * (r+1))); A009766 := proc(r,m) option remember; if(m < 0) then RETURN(0); fi; if(r < 0) then RETURN(0); fi; if(m > r) then RETURN(0); fi; if(0 = m) then RETURN(1); fi; RETURN(A009766(r,m-1) + A009766(r-1,m)); end; CTRSeq := n -> CatTrianglDirect(trinv(n-1)-1,(n-((trinv(n-1)*(trinv(n-1)-1))/2))-1); CTSeq := n -> A009766(trinv(n-1)-1,(n-((trinv(n-1)*(trinv(n-1)-1))/2))-1); # E.g.: [seq(CTSeq(j),j=1..120)]; gives A009766 # A.K.'s own version of the Catalan Ranking & Unranking algorithms. # Here we use the Triangle A009766. CatalanRank := proc(n,aa) local y,r,lo,a; a := aa; r := 0; y := -1; lo := 0; while (a > 0) do if(0 = (a mod 2)) then r := r+1; lo := lo + A009766(r,y); else y := y+1; fi; a := floor(a/2); od; RETURN((binomial(2*n,n)/(n+1))-(lo+1)); end; CatalanUnrank := proc(n,rr) local t,y,lo,r,a,m; r := (binomial(2*n,n)/(n+1))-(rr+1); a := 0; lo := 0; t := n; y := n-1; while(t > 0) do m := A009766(t,y); if(r < (lo+m)) then y := y-1; a := 2*a + 1; else lo := lo+m; t := t-1; a := 2*a; fi; od; RETURN(a); end; # Function M_n(x,y) from the page 98 of CAGES: # The number of all mountain ranges from (x,y) to (2n,0) that do # not drop below sea level. Mn := (n,x,y) -> binomial(2*n-x,n-((x+y)/2)) - binomial(2*n-x,n-1-((x+y)/2)); # Adapted from Algorithm 3.23: CatalanRank(n,a) CatalanRankLong := proc(n,aa) local x,y,lo,a; a := binrev(aa); y := 0; lo := 0; for x from 1 to (2*n)-1 do if(1 = (a mod 2)) then y := y+1; else lo := lo+Mn(n,x,y+1); y := y-1; fi; a := floor(a/2); od; RETURN((binomial(2*n,n)/(n+1))-(lo+1)); end; CatalanRankOld := proc(n,aa) local x,y,lo,a; a := binrev(aa); y := 0; lo := 0; for x from 1 to (2*n)-1 do lo := lo + (1-(a mod 2))*Mn(n,x,y+1); y := y - ((-1)^a); a := floor(a/2); od; RETURN((binomial(2*n,n)/(n+1))-(lo+1)); end; # Adapted from Algorithm 3.24: CatalanUnrank(n,r) CatalanUnrankOld := proc(n,rr) local r,x,y,lo,m,a; r := (binomial(2*n,n)/(n+1))-(rr+1); y := 0; lo := 0; a := 0; for x from 1 to 2*n do m := Mn(n,x,y+1); if(r <= lo+m-1) then y := y+1; a := 2*a + 1; else lo := lo+m; y := y-1; a := 2*a; fi; od; RETURN(a); end; # # [seq(add(A073345bi(n,i),i=0..n),n=0..20)]; should give us Catalans (A000108): # [1, 1, 2, 5, 14, 42, 132, 429, 1430, 4862, 16796, 58786, 208012, ...] # and [seq(add(A073345bi(n,r),n=0..(2^r)),r=0..8)]; # should give us A001699: # [1,1,3,21,651,457653,210065930571,44127887745696109598901,1947270476915296449559659317606103024276803403] # A073345bi := proc(n,k) option remember; local i,j; if(0 = n) then if(0 = k) then RETURN(1); else RETURN(0); fi; fi; if(0 = k) then RETURN(0); fi; 2 * add(A073345bi(n-i-1,k-1) * add(A073345bi(i,j),j=0..(k-1)), i=0..floor((n-1)/2)) + 2 * add(A073345bi(n-i-1,k-1) * add(A073345bi(i,j),j=0..(k-2)), i=(floor((n-1)/2)+1)..(n-1)) - (`mod`(n,2))*(A073345bi(floor((n-1)/2),k-1)^2); end; A036987 := n -> `if`(((2^A000523(n+1)) = (n+1)),1,0); A073346bi := proc(n,k) option remember; local i,j; if(0 = k) then RETURN(A036987(n)); fi; if(0 = n) then RETURN(0); fi; 2 * add(A073346bi(n-i-1,k-1) * add(A073346bi(i,j),j=0..(k-1)), i=0..floor((n-1)/2)) + 2 * add(A073346bi(n-i-1,k-1) * add(A073346bi(i,j),j=0..(k-2)), i=(floor((n-1)/2)+1)..(n-1)) - (`mod`(n,2))*(A073346bi(floor((n-1)/2),k-1)^2) - (`if`((1=k),1,0))*A036987(n); end; A073345 := n -> A073345bi(A025581(n),A002262(n)); A073346 := n -> A073346bi(A025581(n),A002262(n)); A073429 := n -> A073345bi(A003056(n),A002262(n)); A073430 := n -> A073346bi(A003056(n),A002262(n)); A074079bi := (n,k) -> A073346bi(n,k)/(2^k); A074079 := n -> A074079bi(A025581(n),A002262(n)); A074080 := n -> A074079bi(A003056(n)+1,A002262(n)); A073431 := proc(n) local i,j; if(0 = n) then RETURN(1); else add(add(A073346bi(n,j),j=0..A007814(i)),i=1..(2^(n-1)))/(2^(n-1)); fi; end; # Obviously, this produces the same answers: A073431v2 := proc(n) local i; if(0 = n) then RETURN(1); else (add(A073346bi(n,A007814(i)),i=1..(2^(n-1)))/(2^(n-2)))-1; fi; end; # Because of this reduction: A073431v3 := proc(n) local i; (1/2^n) * add((2^(n-i))*A073346bi(n,i),i=0..n); end; # Also, the column sums of the table A074079: A073431v4 := proc(n) local i; add(A074079bi(n,i),i=0..n); end; A073773 := n -> `if`((n < 3),0,((n^2 - 6)*2^(n-2))); # This shows the derivation: A073774v1 := n -> (2^(n-4)) * (((n-5)*(n-6)*(n-7)/6) # 3 \/ to differ. places, none reaching the top. + ((n-5)*(n-6)/4) # One \/ reaching the top, 2 \/'s to elsewhere. + 2*(n-6)^2 # One two-node tree (2 variants) anywhere where # it doesn't reach the top, and also \/ to anywhere # where it doesn't reach the top. + 2*(n-6) # Either the 2-node or 1-node subtree reach the top # (but not both!) + 4*(n-7) # (n-7) ways to add one of the four 3 node trees # of height 3, so that it doesn't reach the top. + 2 # One way to place those four trees to position # where they reach the top, of which half is # duplicate solutions. + (n-5)); # (n-5) ways to add a complete bin tree of # 3 nodes, regardless of whether it reaches # the top or not. A073774 := n -> `if`((n < 3),0,(2^(n-2))*abs(A073775(n-3))); A073775 := n -> ((1/3)*n^3 + (9/2)*n^2 + (85/6)*n - 2); A001477bi := (x,y) -> ((x+y)^2 + x + 3*y)/2; A001477 := n -> A001477bi(A025581(n),A002262(n)); A075300bi := (x,y) -> (2^x * (2*y + 1))-1; A075300 := n -> A075300bi(A025581(n),A002262(n)); A075301 := n -> A001477bi(A007814(n+1),A025480(n)); A075302 := n -> A075300bi(A002262(n),A025581(n)); A075303 := n -> A001477bi(A025480(n),A007814(n+1)); # Count the number of trees with n edges, # fixed by kth power of the deeprotate # gatomorphisms A057511/A057512, # and whose roots degrees are r. # Needs with(combinat,composition); # Note that cyclen*ncycles = r, # (cyclen is a divisor of r). # and we must check that cyclen is a divisor of n # (which implies that then it is also # a divisor of n-r = n-(ncycles*cyclen)). # Note that ilcm(r,k) = cyclen*k PFixedByA057511 :=proc(n,k,r) option remember; local ncycles, cyclen, i, c; ncycles := igcd(r,k); cyclen := r/ncycles; if(0 <> (n mod cyclen)) then RETURN(0); else # printf(`n=%a, r=%a, n-r=%a, cyclen=%a, ncycles=%a\n`, n,r,n-r,cyclen,ncycles); add(mul(A079216bi(i-1,ilcm(r,k)),i=c),c=composition(n/cyclen,ncycles)); fi; end; # Note that if we use in above recursion r*k instead of lcm(r,k) # then the answers for A057546 would differ from n=16 (324 instead of 316) # onward. I.e. [1,1,2,3,5,6,10,11,18,21,34,35,68,69,137,148,324,325,815,816,2165] # instead of [1,1,2,3,5,6,10,11,18,21,34,35,68,69,137,148,316,317,759,760,1869]. # Count the number of trees with n edges, # fixed by kth power of the deeprotate # gatomorphisms A057511/A057512, where # the root degree can be anything # from 1 to n (= the number of edges in the tree). A079216bi :=proc(n,k) option remember; local r; if(0 = n) then RETURN(1); else RETURN(add(PFixedByA057511(n,k,r),r=1..n)); fi; end; # Hopefully is correct now! A057546 := proc(n) local d; if(0=n) then RETURN(1); else RETURN(add(A079216bi(d-1,n/d),d=divisors(n))); fi; end; A057546v2 := n -> A079216bi(n,1); A003418 := proc(n) option remember; `if`((0=n),1,ilcm(n,A003418(n-1))); end; # Note that it is expected that A057546(p) = A057546(p-1)+1 # for all primes p, because for primes we only have the cases # where the root's degree is p, or any one of the A057546(p-1) # cases "planted" over an extra stem. (i.e. the root's degree # is one.) # Note also that: # [seq(A079216bi(n,A003418(n)),n=0..17)]; # -> [1, 1, 2, 5, 14, 42, 132, 429, 1430, 4862, 16796, 58786, # 208012, 742900, 2674440, 9694845, 35357670, 129644790] # The most unpractical formula, but computes correctly at least upto n=9. A057513 := proc(n) local i; `if`((0=n),1,(1/A003418(n-1))*add(A079216bi(n,i),i=1..A003418(n-1))); end; # Even more impractical, but work also. From these it might be easier # to derive a practical formula: A057513v2 := proc(n) local i; `if`((0=n),1,(1/(n-1)!)*add(A079216bi(n,i),i=1..(n-1)!)); end; A057513v3 := proc(n) local i; `if`((0=n),1,(1/n!)*add(A079216bi(n,i),i=1..n!)); end; # A-numbers 79216 --- 79227 reserved for this. A079216 := n -> A079216bi(A025581(n),A002262(n)+1); A079217 := n -> PFixedByA057511(A003056(n)+1,1,A002262(n)+1); A079218 := n -> PFixedByA057511(A003056(n)+1,2,A002262(n)+1); A079219 := n -> PFixedByA057511(A003056(n)+1,3,A002262(n)+1); A079220 := n -> PFixedByA057511(A003056(n)+1,4,A002262(n)+1); A079221 := n -> PFixedByA057511(A003056(n)+1,5,A002262(n)+1); A079222 := n -> PFixedByA057511(A003056(n)+1,6,A002262(n)+1); A079223 := n -> A079216bi(n,2); A079224 := n -> A079216bi(n,3); A079225 := n -> A079216bi(n,4); A079226 := n -> A079216bi(n,5); A079227 := n -> A079216bi(n,6); # A057546 := [1,1,2,3,5,6,10,11,18,21,34,35,68]; (Fixpoints of A057511) # A057513 := [1,1,2,4,9,21,56,153,451,1357,4212,13308,42898]; (CC's of A057511) # A000793 := [1,1,1,2,3,4,6,6,12,15,20,30,30]; (Landau's function) (shifted right) # A003418 := [1,1,1,2,6,12,60,60,420,840,2520,2520,27720]; (lcm{1..n}) (ditto) # 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] # A084509 := n -> `if`((n<4),n!,6*(4^(n-3))); 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; ShoogiKnightTriangle := proc(r,m) option remember; if(m < 0) then RETURN(0); fi; if(r < 0) then RETURN(0); fi; if(m > r) then RETURN(0); fi; if((1 = r) and (0 = m)) then RETURN(1); fi; # The starting position. RETURN(ShoogiKnightTriangle(r-3,m-2) + ShoogiKnightTriangle(r-1,m-2)); end; ShoogiKnightSeq := n -> ShoogiKnightTriangle(trinv(n-1)-1,(n-((trinv(n-1)*(trinv(n-1)-1))/2))-1); # 1-based row,column table: ChessPawnTriangle := proc(r,c) option remember; if(r < 2) then RETURN(0); fi; if(c < 1) then RETURN(0); fi; if(2 = r) then RETURN(1); fi; if(4 = r) then RETURN(1+ChessPawnTriangle(r-1,c-1)+ChessPawnTriangle(r-1,c)+ChessPawnTriangle(r-1,c+1)); else RETURN(ChessPawnTriangle(r-1,c-1)+ChessPawnTriangle(r-1,c)+ChessPawnTriangle(r-1,c+1)); fi; end; CPTSeq := n -> ChessPawnTriangle( (1+(n-((trinv(n)*(trinv(n)-1))/2))), ((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1) ); # This one doesn't allow the two-step move as the initial move (we get more regular triangle): ChessPawnTriangleV := proc(r,c) option remember; if(r < 2) then RETURN(0); fi; if(c < 1) then RETURN(0); fi; if(2 = r) then RETURN(1); fi; RETURN(ChessPawnTriangleV(r-1,c-1)+ChessPawnTriangleV(r-1,c)+ChessPawnTriangleV(r-1,c+1)); end; CPTVSeq := n -> ChessPawnTriangleV( (2+(n-((trinv(n)*(trinv(n)-1))/2))), ((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1) ); # Rank Palindromic Parenthesizations: # (Well, this mongrel version produces hybrid rankings based primarily on # the height of the central peak/valley and secondarily on # the lexicographic ordering of the slope). # map(convert,[170,178,204,212,232,240],binary); # -> [10101010, 10110010, 11001100, 11010100, 11101000, 11110000] # map2(PalParRank,4,[170,178,204,212,232,240]); -> [0, 2, 1, 3, 4, 5] # # There is still a bug: # map(PalParRankHeight1st,palBinSeqs_sep[5]); -> [0, 2, 5, 1, 3, 6, 4, 7, 8, 9] # map(PalParRankHeight1st,palBinSeqs_sep[6]); -> [1, 5, 3, 7, 10, 14, 2, 6, 4, 8, 11, 15, 5, 9, 12, 16, 13, 17, 18, 19] # PalParRankHeight1st(2762); -> 5 PalParRankHeight1st(3640); -> 5 # convert(2762, binary); convert(3640, binary); # # 101011001010 # 111000111000 # PalParRankHeight1st := x -> PalParRankHeight1st_aux((A000523(x)+1)/2,x); PalParGlobRankHeight1st := x -> CBCPSUM(((A000523(x)+1)/2)-1)+PalParRankHeight1st(x); PalParRankHeight1st_aux := proc(n,aa) local y,r,i,lo,a; if(binexp2runcounts(aa) <> reverse(binexp2runcounts(aa))) then RETURN(`Not palindromic!`); fi; a := aa; r := 0; y := -1; lo := 0; i := n; while (i > 0) do if(0 = (a mod 2)) then r := r+1; lo := lo + A009766(r,y); else y := y+1; fi; # printf(`r=%a, y=%a, lo=%a\n`,r,y,lo); a := floor(a/2); i := i-1; od; # printf(`lo=%a, A009766(%a,%a)=%a\n`,lo,(r+2),y,A009766((r+2),y)); RETURN(binomial(n,floor(n/2)) - (A009766((r+2),y)+lo+1)); end; # Does Maple allow dynamic scoping? In that way, this would be # a little bit more clean, with no explicit global variable: NDLS_GLOBAL := []; NonDivingLatticeSequences := proc(n) global NDLS_GLOBAL; NDLS_GLOBAL := []; NonDivingLatticeSequencesAux(0,0,n); RETURN(NDLS_GLOBAL); end; NonDivingLatticeSequencesAux := proc(x,h,i) global NDLS_GLOBAL; if(0 = i) then NDLS_GLOBAL := [op(NDLS_GLOBAL),x]; else if(h > 0) then NonDivingLatticeSequencesAux((2*x),h-1,i-1); fi; NonDivingLatticeSequencesAux((2*x)+1,h+1,i-1); fi; end; # Palindromic Totally Balanced Binary Sequences of the length n: ReflectBinSeq := (x,n) -> (((2^n)*x)+A036044(x)); # Was: binrevcompl(x); PalTotBalBinSequences := n -> map(ReflectBinSeq,NonDivingLatticeSequences(n),n); CatalanRankGlobal := proc(a) local n; n := floor(A070939(a)/2); RETURN(add((binomial(2*j,j)/(j+1)),j=0..(n-1))+CatalanRank(n,a)); end; CatalanRankGlobalOld := proc(a) local n; n := floor(A070939(a)/2); RETURN(add((binomial(2*j,j)/(j+1)),j=0..(n-1))+CatalanRankOld(n,a)); end; # Gives A014486 CatalanSequences := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanUnrank(n,r)]; od; od; RETURN(a); end; # Gives A001263 CatalanPeaksTriangle := proc(upto_n) local n,a,r,b,i; a := []; for n from 1 to upto_n do b := []; for r from 1 to n do b := [op(b),0]; od; for r from 0 to (binomial(2*n,n)/(n+1))-1 do i := wt(GrayCode(CatalanUnrank(n,r)))/2; b[i] := b[i]+1; od; a := [op(a),op(b)]; od; RETURN(a); end; # From EIS we find this formula: A001263 := (n,k) -> (binomial(n,k)*binomial(n,k-1))/n; # My formula for Motzkin numbers, A001006, both give the same results: M := proc(n) local i; add(binomial(n,2*i)*Cat(i),i=0..floor(n/2)); end; M2 := proc(n) local i; add(binomial(n,n-(2*i))*Cat(i),i=0..floor(n/2)); end; # Motzkin paths with minimum peak width m. With m=0, gives the # same results as above formula (the ordinary Motzkin numbers): # With m=1 [seq(Mpw(j,1),j=0..30)]; seems to give A004148 (with RNA connection) # [1, 1, 1, 2, 4, 8, 17, 37, 82, 185, 423, 978, 2283, 5373, 12735, 30372, 72832, 175502, 424748, # 1032004, 2516347, 6155441, 15101701, 37150472, 91618049, 226460893, 560954047, 1392251012, 3461824644, # 8622571758, 21511212261] # with m=2 seems to give A004149 # With m=3 gives A023421. # With m=4 gives A023422. # With m=5 gives A023423. # With m=6, not yet in EIS. C := (n,k) -> `if`((n <= 0),0,binomial(n,k)); Mpw := proc(n,m) local i,k; 1+add(add(A001263(i,k)*C(n-(m*k),2*i),k=1..i),i=0..floor(n/2)); end; # Start indexing from 0: A064645 := (n) -> Mpw((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n), (n-((trinv(n)*(trinv(n)-1))/2))); A064645_transposed := (n) -> Mpw( (n-((trinv(n)*(trinv(n)-1))/2)),(((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)); # Seems to give A033184 CatalanRootDegreeTriangle := proc(upto_n) local n,a,r,b,i; a := []; for n from 1 to upto_n do b := []; for r from 1 to n do b := [op(b),0]; od; for r from 0 to (binomial(2*n,n)/(n+1))-1 do i := nops(binexp2pars(CatalanUnrank(n,r))); b[i] := b[i]+1; od; a := [op(a),op(b)]; od; RETURN(a); end; RotBinTreePermutationL := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanRank(n,RotateBinTree(CatalanUnrank(n,r)))]; od; od; RETURN(a); end; ReflectTreePermutationL := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanRank(n,runcounts2binexp(reverse(binexp2runcounts(CatalanUnrank(n,r)))))]; od; od; RETURN(a); end; RotBinTreePermutation := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanRankGlobal(RotateBinTree(CatalanUnrank(n,r)))]; od; od; RETURN(a); end; RotBinTreePermutationR := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanRankGlobal(RotateBinTreeR(CatalanUnrank(n,r)))]; od; od; RETURN(a); end; # This gives the same sequence as RotateHandshakesD3: A057505 DeepRotBinTreePermutation := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanRankGlobal(DeepRotateBinTree(CatalanUnrank(n,r)))]; od; od; RETURN(a); end; RefBinTreePermutation := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanRankGlobal(ReflectBinTree(CatalanUnrank(n,r)))]; od; od; RETURN(a); end; bf2df := s -> (btbf2df(binrev(s),0,1)/2); lmax := proc(a) local e,z; z := 0; for e in a do if whattype(e) = list then e := last_term(e); fi; if e > z then z := e; fi; od; RETURN(z); end; lcmlist := proc(a) local z,e; z := 1; for e in a do z := ilcm(z,e); od; RETURN(z); end; CountCycles := b -> (nops(convert(b,'disjcyc')) + (nops(b)-convert(map(nops,convert(b,'disjcyc')),`+`))); CycleLengths1 := b -> [[(nops(b)-convert(map(nops,convert(b,'disjcyc')),`+`)),`*`,1],op(map(nops,convert(b,'disjcyc')))]; CyclesLCM := b -> lcmlist(map(nops,convert(b,'disjcyc'))); Bf2DfBinTreePermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,bf2df(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; Bf2DfBinTreePermutationCycleLengths := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,bf2df(CatalanUnrank(n,r)))]; od; a := [op(a),CycleLengths1(b)]; od; RETURN(a); end; Bf2DfBinTreePermutationCyclesLCM := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,bf2df(CatalanUnrank(n,r)))]; od; a := [op(a),CyclesLCM(b)]; od; RETURN(a); end; # # rpcc0 := Bf2DfBinTreePermutationCycleLengths(9); # rpcc0 := [[[1,*,1]],[[1,*,1]],[[2,*,1]], # [[2,*,1],3], # [[2,*,1],3,4,3,2], # [[2,*,1],3,4,3,2,16,8,2,2], # [[2,*,1],3,4,3,2,16,8,2,2,87,3], # [[2,*,1],3,4,3,2,16,8,2,2,87,3,202,25,5,4,61], # [[2,*,1],3,4,3,2,16,8,2,2,87,3,202,25,5,4,61,607,63,165,127,12,8,10,4,5], # [[2,*,1],3,4,3,2,16,8,2,2,87,3,202,25,5,4,61,607,63,165,127,12,8,10,4,5,927,1441,283,625,91,52,8,5]] # # # map(lmax,rpcc0); -> [1, 1, 1, 3, 4, 16, 87, 202, 607, 1441] # I am sorry, but the terms # 3, 4, 16, 87, 202, 607 # do not match anything in the table. # # # # # RotBinTreePermutationCycleCounts gives: # A001683 (Formerly M3288 and N1325) # 1,1,1,1,4,6,19,49,150,442,1424,4522,14924,49536,167367,570285,1965058, # 6823410,23884366,84155478,298377508,1063750740,3811803164,13722384546 # Name: One-sided triangulations of the disk; or flexagons of order n. # (as it should!) # And it appears in # http://www.research.att.com/~njas/sequences/JIS/VOL3/groupdata.html # as Plane boron trees (U-sequence, unlabeled), as it should! RotBinTreePermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateBinTree(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; # RotBinTreePermutationCycleLengths(8); # [[[1, *, 1]], [[1, *, 1]], [[0, *, 1], 2], [[0, *, 1], 5], [[0, *, 1], 6, 3, 2, 3], [[0, *, 1], 7, 7, 7, 7, 7, 7], # [[0, *, 1], 8, 8, 8, 8, 4, 8, 8, 8, 8, 4, 8, 8, 8, 4, 8, 8, 8, 4, 4], # [[0, *, 1],9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,3,9], # [[0,*,1],10,10,10,10,10,10,10,10,10,10,10,10,10,5,10,10,10,10,10,10,10,10,10,10,10,10,10,5,10,10,10,10,10,10, # 10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,5,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10, # 10,10,10,10,5,10,10,10,10,10,10,10,10,5,10,10,10,10,10,10,10,10,5,10,10,10,10,10,10,10,10,10,10,10,10, # 10,10,10,10,10,5,10,10,10,10,10,10,10,5,10,10,10,10,10,10,10,10,5,10,10,10,10,10,10,10,10,10,10,5,10,10,10,10, # 10,5,10,5,10,10,10,5,5]] # RotBinTreePermutationCycleLengths := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateBinTree(CatalanUnrank(n,r)))]; od; a := [op(a),CycleLengths1(b)]; od; RETURN(a); end; RotBinTreePermutationCyclesLCM := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateBinTree(CatalanUnrank(n,r)))]; od; a := [op(a),CyclesLCM(b)]; od; RETURN(a); end; ReflectTreePermutation := proc(upto_n) local n,a,r; a := []; for n from 0 to upto_n do for r from 0 to (binomial(2*n,n)/(n+1))-1 do a := [op(a),CatalanRankGlobal(runcounts2binexp(reverse(binexp2runcounts(CatalanUnrank(n,r)))))]; od; od; RETURN(a); end; alltrees2singletrunked := n -> pars2binexp([binexp2pars(n)]); alltrees2doubletrunked := n -> pars2binexp(alltrees2doubletrunkedP(binexp2pars(n))); alltrees2doubletrunkedP := h -> [car(h),cdr(h)]; # (defun RotateHandshakesP (h) (append (car h) (list (cdr h)))) RotateHandshakes := n -> pars2binexp(RotateHandshakesP(binexp2pars(n))); RotateHandshakesR := n -> pars2binexp(deepreverse(RotateHandshakesP(deepreverse(binexp2pars(n))))); RotateHandshakesP := h -> `if`((0 = nops(h)),h,[op(car(h)),cdr(h)]); RotHandshakesPermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakes(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; RotHandshakesPermutationCycleLengths := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakes(CatalanUnrank(n,r)))]; od; a := [op(a),CycleLengths1(b)]; od; RETURN(a); end; RotHandshakesPermutationCyclesLCM := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakes(CatalanUnrank(n,r)))]; od; a := [op(a),CyclesLCM(b)]; od; RETURN(a); end; # This seems to produce the same result as RotateBinTree (A057161) RotateHandshakesD1 := n -> pars2binexp(RotateHandshakesD1P(binexp2pars(n))); RotateHandshakesD1P := h -> `if`((0 = nops(h)),h,[op(RotateHandshakesD1P(car(h))),cdr(h)]); RotHandshakesD1PermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakesD1(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; RotateHandshakesD2 := n -> pars2binexp(RotateHandshakesD2P(binexp2pars(n))); # Ei oikea inverse!: RotateHandshakesD2R := n -> pars2binexp(deepreverse(RotateHandshakesD2P(deepreverse(binexp2pars(n))))); RotateHandshakesD2P := h -> `if`((0 = nops(h)),h,[op(car(h)),RotateHandshakesD2P(cdr(h))]); RotHandshakesD2PermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakesD2(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; # This gives the same lengths, but in different order as: RotBinTreePermutationCycleLengths: # map(lmax,rpcc2); = [1, 1, 2, 5, 6, 7, 8, 9, 10] RotHandshakesD2PermutationCycleLengths := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakesD2(CatalanUnrank(n,r)))]; od; a := [op(a),CycleLengths1(b)]; od; RETURN(a); end; RotHandshakesD2PermutationCyclesLCM := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakesD2(CatalanUnrank(n,r)))]; od; a := [op(a),CyclesLCM(b)]; od; RETURN(a); end; RotateHandshakesD3 := n -> pars2binexp(RotateHandshakesD3P(binexp2pars(n))); RotateHandshakesD3R := n -> pars2binexp(deepreverse(RotateHandshakesD3P(deepreverse(binexp2pars(n))))); RotateHandshakesD3P := h -> `if`((0 = nops(h)),h,[op(RotateHandshakesD3P(car(h))),RotateHandshakesD3P(cdr(h))]); RotHandshakesD3PermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakesD3(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; # # RotHandshakesD3PermutationCycleLengths(8); # [[[1,`*`,1]], # [[1,`*`,1]], # [[0,`*`,1],2], # [[0,`*`,1],2,3], # [[0,`*`,1],2,6,6], # [[0,`*`,1],2,6,6,6,3,3,2,3,6,5], # [[0,`*`,1],2,6,6,6,6,6,6,6,6,6,20,6,6,6,24,6,2,6], # [[0,`*`,1],2,6,6,6,6,6,6,6,6,6,6,20,6,3,6,6,72,3,6,6,6,3,6,6,10,48,6,6,6,20,6,6,6,3,18,9,6,24,6,3,6,3,15,3,2,6], # [[0,`*`,1],2,6,6,6,6,6,6,6,6,6,6,20,6,6,6,6,6,72,6,6,6,6,6,6,6,6,20,48,6,6,6,6,20,20,6,6,6,72,6,6,6,72,54,6,72, # 144,2,6,6,6,6,6,6,6,90,24,72,6,6,6,6,6,20,6,6,6,6,6,6,6,6,6,6,42,12,42,36,14,6,4,10,6,6,6,12,6,10,6,6,6,14,12,6,2,6]] # # map(lmax,rpcc3); = [1, 1, 2, 3, 6, 6, 24, 72, 144] # I am sorry, but the terms # 2, 3, 6, 6, 24, 72, 144 # do not match anything in the table. RotHandshakesD3PermutationCycleLengths := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakesD3(CatalanUnrank(n,r)))]; od; a := [op(a),CycleLengths1(b)]; od; RETURN(a); end; RotHandshakesD3PermutationCyclesLCM := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateHandshakesD3(CatalanUnrank(n,r)))]; od; a := [op(a),CyclesLCM(b)]; od; RETURN(a); end; ReverseBottomBranches := n -> pars2binexp(reverse(binexp2pars(n))); RotateBottomBranchesL := n -> pars2binexp(rotateL(binexp2pars(n))); RotateBottomBranchesR := n -> pars2binexp(rotateR(binexp2pars(n))); # map(CatalanRankGlobal,map(DeepReverse,A014486)); gives A057164 DeepReverse := n -> pars2binexp(deepreverse(binexp2pars(n))); DeepRotateL := n -> pars2binexp(deeprotateL(binexp2pars(n))); DeepRotateR := n -> pars2binexp(deeprotateR(binexp2pars(n))); # In principle: # A057164 := n -> A080300(A036044(A014486(n))); # and even more exactly: # A057164 := n -> A080300(A056539(A014486(n))); # Gives A003239 RotBBPermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateBottomBranchesL(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; RotBBPermutationCyclesLCM := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateBottomBranchesL(CatalanUnrank(n,r)))]; od; a := [op(a),CyclesLCM(b)]; od; RETURN(a); end; DeepRotatePermutationCycleCounts := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,DeepRotateL(CatalanUnrank(n,r)))]; od; a := [op(a),CountCycles(b)]; od; RETURN(a); end; DeepRotatePermutationCyclesLCM := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,DeepRotateL(CatalanUnrank(n,r)))]; od; a := [op(a),CyclesLCM(b)]; od; RETURN(a); end; # RotBBPermutationCycleLengths(8) # [[[1,`*`,1]],[[1,`*`,1]],[[2,`*`,1]],[[3,`*`,1],2],[[7,`*`,1],3,2,2],[[15,`*`,1],4,3,3,3,2,2,2,2,2,2,2], # [[46,`*`,1],5,4,4,4,3, ...] etc. # # %S A034731 1,2,3,7,15,46,133,436,1433,4878,16797,58837,208013,743034,2674457, # %T A034731 9695281,35357671,129646266,477638701,1767268073,6564120555, # %U A034731 24466283818,91482563641,343059672916,1289904147339,4861946609466 # %N A034731 Dirichlet convolution of b_n=1 with Catalan numbers. # %K A034731 nonn # %O A034731 1,2 # %A A034731 Erich Friedman (erich.friedman@stetson.edu) # A034731 := proc(n) local d,z; z:= 0; for d in divisors(n) do z := z+Cat(d-1); od; RETURN(z); end; # fooseq := [seq(A034731(j),j=0..25)]; # fooseq := [0,1,2,3,7,15,46,133,436,1433,4878,16797,58837,208013,743034,2674457, # 9695281,35357671,129646266,477638701,1767268073,6564120555, # 24466283818,91482563641,343059672916,1289904147339] # RotBBPermutationCycleLengths := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,RotateBottomBranchesL(CatalanUnrank(n,r)))]; od; a := [op(a),CycleLengths1(b)]; od; RETURN(a); end; # DeepRotatePermutationCycleLengths(8) # # [[1,`*`,1]],[[1,`*`,1]],[[2,`*`,1]],[[3,`*`,1],2],[[5,`*`,1],3,2,2,2],[[6,`*`,1],4,3,3,3,2,2,2,2,2,2,2,3,2,2,2], # [[10,`*`,1],5,4,4,4,3,6,3,3,2,3,3,3,2,6,2,2,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,4,3,3,3,2,2,2,2,2,2,2,3,2,2,2], # [[11,`*`,1],6,5,5,5,4,4,4,4,4,5,4,4,4,3,3,3,6,6,4,3,3,3,6,3,3,4,4,4,3,6,3,3,3,3,3,2,4,4,6,6,6,6,2,2,2,2,2,3,3,2,etc.] # # I am sorry, but the terms # 1,2,3,5,6,10,11,18 # do not match anything in the table. # # fixrepseq := [seq(DeepRotatePermutationFixedTrees(j),j=0..9)]; # fixrepseq := [[0], [2], [10, 12], [42, 52, 56], # # [170, 204, 212, 232, 240], # [682, 852, 920, 936, 976, 992], # [2730, 3276, 3380, 3412, 3640, 3752, 3888, 3920, 4000, 4032], # [10922, 13652, 14744, 14952, 15016, 15472, 15696, 15968, 16032, 16192, 16256], # [43690, 52428, 54484, 54612, 55524, 58584, 59624, 60072, 61680, 62256, 62672, 62800, 63712, 64160, 64704, 64832, 65152, 65280], # [174762, 216372, 218452, 233016, 235928, 240040, 240296, 242120, 248240, 250320, 251216, # 254432, 255584, 256416, 256672, 258496, 259392, 260480, 260736, 261376, 261632]] # map(nops,fixrepseq); [1, 1, 2, 3, 5, 6, 10, 11, 18, 21] # # Not exactly this one: # # %I A003238 M0628 # %S A003238 1,1,2,3,5,6,10,11,16,19,26,27,40,41,53,61,77,78,104,105,134, # %T A003238 147,175,176,227,233,275,294,350,351,438,439,516,545,624,640, # %U A003238 774,775,881,924,1069,1070,1265,1266,1444,1521,1698,1699 # %O A003238 1,3 # %F A003238 Shifts one place left under inverse Moebius transform: a(n+1)= Sum a(k), k|n. # %Y A003238 Cf. A007439, A007554. # %K A003238 nonn,nice,eigen # %A A003238 njas # %N A003238 Rooted trees where at each node all sub-rooted trees are identical. # %C A003238 Comment from Christian Bower: also, number of sequences of positive integers a_1,a_2,...,a_k such that # 1+a_1*(1+a_2*(...(1+a_k)...))=n. If you take mu(a_1)*mu(a_2)*...*mu(a_k) for each sequence you get 1's 0's and -1's. # Add them up and you get the terms for A007554. # (See A007439 "Planted trees" ??) # # Because already with totally balanced sequences of 2*8 bits we get # unbalanced trees/parenthesizations like: # map(binexp2pars,fixrepseq[9][5]); -> [[[], [[]]], [[[]], []]] # # /\ /\ /\ /\ # /\/ \ / \/\ and its "mirror": / \/\ /\/ \ # / \/ \ / \/ \ # # So we get A003238[9] + 2 = 18 # # deeprotateL("); -> [[[], [[]]], [[[]], []]] # # rotateL(map(binexp2pars,fixrepseq[9][5])); -> [[[[]], []], [[], [[]]]] # # map(binexp2pars,fixrepseq[9][6]); -> [[[[]], []], [[], [[]]]] # # deeprotateL("); -> [[[[]], []], [[], [[]]]] # # # # 0 1 2 3 4 5 6 7 8 # map(lmax,rpcc5); -> [1, 1, 1, 2, 3, 4, 6, 6, 12] (and the next term is 15) # # %I A000793 M0537 N0190 # 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 # %S A000793 1,1,2,3,4,6,6,12,15,20,30,30,60,60,84,105,140,210,210,420,420,420,420, # %T A000793 840,840,1260,1260,1540,2310,2520,4620,4620,5460,5460,9240,9240,13860, # %U A000793 13860,16380,16380,27720,30030,32760,60060,60060,60060,60060,120120 # %N A000793 Landau's function g(n): largest order of permutation of n elements. Equivalently, largest lcm of partitions of n. # %t A000793 Table[ Max[ Union[ Apply[ LCM, Partitions[ n ], 1 ] ] ],{n,30} ] # %Y A000793 Cf. A000792, A034890-A034891.%K A000793 nonn,core,easy.nice # %O A000793 0,3 # # 1 # 3 # 2 order = 6, nodes = 6 # # # 2 # 3 # 2 order = 6, nodes = 7 # # 1 # 4 # 3 order = 12, nodes = 8 # # Is it really equal to A000793? What with the trees of 20, 21, 22 and 23 nodes? # # A000793[10] = 30 = 5*3*2 # A000793[19] = 420 = 3*4*5*7 # A000793[20] = 420 = 3*4*5*7*1 # A000793[21] = 420 = 3*4*5*7*2 # A000793[22] = 420 = 3*4*5*7*3 # DeepRotatePermutationCycleLengths := proc(upto_n) local u,n,a,r,b; a := []; for n from 0 to upto_n do b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do b := [op(b),1+CatalanRank(n,DeepRotateL(CatalanUnrank(n,r)))]; od; a := [op(a),CycleLengths1(b)]; od; RETURN(a); end; DeepRotatePermutationFixedTrees := proc(n) local u,a,r,b; b := []; u := (binomial(2*n,n)/(n+1)); for r from 0 to u-1 do a := CatalanUnrank(n,r); if(DeepRotateL(a) = a) then b := [op(b),a]; fi; od; RETURN(b); end; pars2binexp := proc(p) local e,s,w,x; if(0 = nops(p)) then RETURN(0); fi; e := 0; for s in p do x := pars2binexp(s); w := A000523(x); e := e * 2^(w+3) + 2^(w+2) + 2*x; od; RETURN(e); end; # # map(convert,A014486[1..20],binary); # # [0, 10, 1010,1100, 101010,101100,110010,110100,111000, # 10101010,10101100,10110010,10110100,10111000,11001010,11001100, # 11010010,11010100,11011000,11100010] # # pars2binexp([]); -> 0 0 # pars2binexp([ [] ]); -> 2 10 # pars2binexp([ [],[] ]); -> 10 1010 # pars2binexp([ [[]] ]); -> 12 1100 # pars2binexp([ [],[],[] ]); -> 42 101010 # pars2binexp([ [],[[]] ]); -> 44 101100 # pars2binexp([ [[]],[] ]); -> 50 110010 # pars2binexp([ [[],[]] ]); -> 52 110100 # pars2binexp([ [[[]]] ]); -> 56 111000 # pars2binexp([ [],[],[],[] ]); -> 170 10101010 # pars2binexp([ [],[],[[]] ]); -> 172 10101100 # pars2binexp([ [],[[]],[] ]); -> 178 10110010 # pars2binexp([ [],[[],[]] ]); -> 180 10110100 # binexp2pars := proc(n) option remember; `if`((0 = n),[],binexp2parsR(binrev(n))); end; binexp2parsR := n -> [binexp2pars(PeelNextBalSubSeq(n)),op(binexp2pars(RestBalSubSeq(n)))]; runcounts2binexp0 := proc(c) local i,e,n; n := 0; for i from 0 to nops(c)-1 do e := c[i+1]; n := ((2^e)*n) + ((i mod 2)*((2^e)-1)); od; RETURN(n); end; runcounts2binexp := proc(c) local i,e,n; n := 0; for i from 1 to nops(c) do e := c[i]; n := ((2^e)*n) + ((i mod 2)*((2^e)-1)); od; RETURN(n); end; binexp2runcounts := proc(nn) local n,a,p,c; n := nn; a := []; p := (`mod`(n,2)); c := 0; while(n > 0) do c := c+1; n := floor(n/2); if((`mod`(n,2)) <> p) then a := [c,op(a)]; c := 0; p := (`mod`(p+1,2)); fi; od; RETURN(a); end; sortbyfirst := (a,b) -> `if`((a[1] < b[1]),true,false); pfact2runcount_list:=proc(n) local a,d; a:=[]; for d in sort(ifactors(n)[2],sortbyfirst) do while(ithprime(nops(a)+1) < d[1]) do a := [op(a),1]; od; a := [op(a),d[2]+1]; od; RETURN([op(a[1..(nops(a)-1)]),a[nops(a)]-1]); end; # sortbyfirst_r := (a,b) -> `if`((a[1] > b[1]),true,false); # Incorrect! pfact2runcount_list_r:=proc(n) local a,d; a:=[]; for d in sort(ifactors(n)[2],sortbyfirst) do while(ithprime(nops(a)+1) < d[1]) do a := [op(a),1]; od; a := [op(a),d[2]+1]; od; RETURN(reverse([a[1]-1,op(a[2..nops(a)])])); end; pfact2runcount_perm := n -> `if`((n < 2),(n-1),runcounts2binexp(pfact2runcount_list(n))); pfact2runcount_perm_r := n -> `if`((n < 2),(n-1),runcounts2binexp(pfact2runcount_list_r(n))); runcount2pfact_perm := proc(n) local i,z; a := binexp2runcounts(n); z := 1; for i from 1 to nops(a) do z := z*(ithprime(i)^(a[i]-1)); od; RETURN(z); # times something (either ithprime(1 or nops(a)) ???) end; # 1 -> 0, 2 -> 1, 3 -> -1, 4 -> 2, 5 -> -2, 6 -> 3, 7 -> -3, etc. # N2Z := n -> (1-(`mod`(n,2)*2))*floor(n/2); N2Z := n -> ((-1)^n)*floor(n/2); Z2N := z -> 2*abs(z)+`if`((z < 1),1,0); monic_polynomial_in_Z := proc(n) local a,p,i; a := binexp2runcounts(n); p := '1'; for i in a do p := ('x' * p) + N2Z(i); od; RETURN(p); end; # #> polys := [seq(expand(monic_polynomial_in_Z(j)),j=1..100)]; #> # # 2 2 3 2 2 3 4 #polys := [x, x , x + 1, x + 1, x , x + x, x - 1, x - 1, x + x, x , # # 3 2 3 2 2 2 3 # x + 1, x + x + 1, x + x , x - x, x + 2, x + 2, x - x, # # 4 2 3 4 5 4 3 2 # x + x , x + x + 1, x + 1, x , x + x, x - 1, x + x - 1, # # 3 2 4 3 3 2 2 3 2 2 # x + x + x, x + x , x + x + 1, x - x + 1, x - x , x + 2 x, # # 2 3 4 2 3 4 2 # x - 2, x - 2, x + 2 x, x - x , x - x + 1, x + x + 1, # # 5 3 4 2 3 4 5 6 5 # x + x , x + x + x, x + x - 1, x - 1, x + x, x , x + 1, # # 4 5 2 4 3 2 3 2 # x + x + 1, x + x , x - x, x + 2, x + x + 2, x + x - x, # # 4 3 2 3 2 4 3 5 4 4 3 # x + x + x , x + x + x + 1, x + x + 1, x + x , x + x + x, # # 3 2 2 3 2 4 3 3 2 # x + x - 1, x - x - 1, x - x + x, x - x , x - x + 1, # # 2 3 2 2 2 3 # x + 2 x + 1, x + 2 x , x - 2 x, x + 3, x + 3, x - 2 x, # # 4 2 3 4 2 5 3 4 2 # x + 2 x , x + 2 x + 1, x - x + 1, x - x , x - x + x, # # 3 4 2 5 3 6 4 5 3 # x - x - 1, x + x - 1, x + x + x, x + x , x + x + 1, # # 4 2 5 3 2 4 2 3 4 # x + x + x + 1, x + x + x , x + x - x, x + x + 2, x + 2, # # 5 6 2 5 6 7 6 5 # x - x, x + x , x + x + 1, x + 1, x , x + x, x - 1, # # 4 5 2 6 3 5 2 4 # x + x - 1, x + x + x, x + x , x + x + 1, x - x + 1, # # 5 2 4 3 2 3 2 # x - x , x + 2 x, x - 2, x + x - 2, x + x + 2 x, # # 4 3 2 3 2 4 3 2 # x + x - x , x + x - x + 1, x + x + x + 1] # #> count_pol_factors := p -> nops(op(2,factors(p))); # # count_pol_factors := p -> nops(op(2, factors(p))) # #> map(count_pol_factors,polys); # #[1, 1, 1, 1, 1, 2, 1, 2, 2, 1, 2, 1, 2, 2, 1, 1, 3, 2, 1, 1, 1, 3, 2, # # 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 3, 1, 2, 2, 2, 1, 3, 2, 1, 2, 1, 3, # # 3, 1, 1, 2, 2, 2, 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 2, 1, # # 1, 3, 2, 1, 1, 3, 2, 1, 1, 2, 2, 2, 1, 4, 2, 2, 2, 1, 3, 2, 1, 2, # # 3, 1, 1, 3, 2, 1, 2, 2, 2, 1, 1] # # 5,5,6,8,11,16,25,38,59,93,148,235,376,602,966,1550,2491, A019528 := proc(n) option remember; local i,v; v := [0,0,-1,-1,-2,-1,0,2,2,1,0]; if(1 = n) then RETURN(5); fi; if(2 = n) then RETURN(5); fi; if(3 = n) then RETURN(6); fi; if(4 = n) then RETURN(8); fi; if(5 = n) then RETURN(11); fi; if(6 = n) then RETURN(16); fi; if(7 = n) then RETURN(25); fi; if(8 = n) then RETURN(38); fi; if(9 = n) then RETURN(59); fi; if(10 = n) then RETURN(93); fi; if(11 = n) then RETURN(148); fi; RETURN(add(v[12-i]*A019528(n-i),i=1..11)); end; # Periodic from n=90 onward, with a period of 90 terms: # [seq(A080867(n),n=91..180)]; = [seq(A080867(n),n=181..270)]; # = [seq(A080867(n),n=271..360)]; # [1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 1, 3, 7, 5, 1, 4, 9, 9, 8, 7, 2, 5, 6, # 3, 0, 1, 5, 1, 6, 9, 7, 9, 6, 5, 6, 1, 7, 6, 7, 3, 3, 6, 3, 9, 5, # 1, 8, 5, 6, 9, 4, 3, 2, 7, 0, 1, 9, 3, 5, 1, 0, 1, 1, 2, 9, 2, 1, # 3, 8, 3, 1, 4, 7, 7, 4, 1, 5, 6, 5, 1, 6, 1, 7, 1, 8, 1, 9, 1, 0, 1] # # 80867 --- 80868 A080867 := proc(n) option remember; local i,u; if(n < 12) then RETURN(n mod 10); else u := A080867(n-1); for i from n-2 by -1 to 0 do if(A080867(i) = u) then RETURN((A080867(i+1)+u) mod 10); fi; od; fi; RETURN(-1); # Jamais! end; A080868 := n -> ((A080867(n+1)-A080867(n)) mod 10); # Variant of the above one, is it periodic or not? A0xxxxx := proc(n) option remember; local i,u; if(n < 12) then RETURN(n mod 10); else u := A0xxxxx(n-1); if(0 = (n mod 2)) then RETURN((2*u+1) mod 10); else for i from n-2 by -1 to 0 do if(A0xxxxx(i) = u) then RETURN((A0xxxxx(i+1)+u) mod 10); fi; od; fi fi; RETURN(-1); # Jamais! end; floor_diffs := proc(k,upto_n) local j; [seq(evalf(floor((k^2)*j)-(k*(floor(k*j)))),j=0..upto_n)]; end; floor_diffs_floored := proc(k,upto_n) local j; [seq(floor(floor((k^2)*j)-(k*(floor(k*j)))),j=0..upto_n)]; end; # %S A059459 2,3,7,5,13,29,31,23,19,17,8209,8273 # %N A059459 a(1) = 2; a(n+1) is obtained by writing a(n) in binary and trying to complement just one bit, # starting with the least significant bit, until a new prime is reached. A059459search := proc(a,upto_bit,upto_length) local i,n,t; if(nops(a) >= upto_length) then RETURN(a); fi; t := a[nops(a)]; for i from 0 to upto_bit do n := XORnos(t,(2^i)); if(isprime(n) and (not member(n,a))) then print([op(a),n]); RETURN(A059459search([op(a),n],upto_bit,upto_length)); fi; od; RETURN([op(a),`and no more`]); end; A059459search_to_file := proc(aa,upto_bit,upto_length,filename) local a,i,n,t,s,fp; a := aa; for s from 1 to upto_length do t := a[nops(a)]; for i from 0 to upto_bit do n := XORnos(t,(2^i)); if((not member(n,a)) and isprime(n)) then a := [op(a),n]; fp := fopen(filename,APPEND,BINARY); fprintf (fp,`%a`,[op(a),n]); fclose(fp); i := 0; break; fi; od; if(i > 0) then RETURN([op(a),`and no more found with this bit-limit`]); fi; od; RETURN(a); end; # Like previous, but the sequence must be strictly ascending. flip_primes_asc_search := proc(a,upto_bit,upto_length) local i,n,t; if(nops(a) >= upto_length) then RETURN(a); fi; t := a[nops(a)]; for i from 0 to upto_bit do n := XORnos(t,(2^i)); if(isprime(n) and (n > t)) then print([op(a),n]); RETURN(flip_primes_asc_search([op(a),n],upto_bit,upto_length)); fi; od; RETURN([op(a),`and no more`]); end; # 2 = 2*1 1 1 # 3 = 1*2 + 1*1 11 3 # 5 = 2*3 - 1*2 + 1*1 101 5 # 7 = 1*5 + 1*3 - 1*2 + 1*1 1101 13 # 11 = 2*7 - 1*5 + 1*3 - 1*2 + 1*1 10101 21 bitvector_as_prime_sum := proc(nn) local n,i,s; n := nn; s := (-1)^(n+1); n := floor(n/2); i := 1; while(n > 0) do # printf(`((-1^(%a))*ithprime(%a) = %a*%a = %a\n`,(n+1),i,((-1)^(n+1)),ithprime(i),(((-1)^(n+1))*ithprime(i))); s := s + (((-1)^(n+1))*ithprime(i)); i := i+1; n := floor(n/2); od; if(i > 1) then RETURN(s + (`mod`(i,2)*ithprime(i-1))); else RETURN(2*s); fi; end; # Same as above, but more compact code: bin_prime_sum := proc(n) local i,s; s := A000523(n); RETURN(((-1)^(n+1)) + add( (((-1)^(floor(n/(2^i))+1))*ithprime(i)),i=1..s) + (`if`((1 = n),1,((`mod`((s+1),2))*ithprime(s)))) ); end; # Check what above function give when given the sequences # A014437 (Odd Fibonacci numbers) and A050824 as their domains. # primesums_primes_search(16); produces the lexicographically first such sequence: # [1, 3, 5, 13, 21, 46, 78, 175, 303, 639, 1143, 2539, 4542, 9214, 17406, 36735] primesums_primes_search := (upto_n) -> primesums_primes_search_aux([],1,upto_n); primesums_primes_search_aux := proc(a,n,upto_n) local i,p,t; if(n > upto_n) then RETURN(a); fi; p := ithprime(n); for i from (2^(n-1)) to ((2^n)-1) do t := bin_prime_sum(i); if(t = p) then print([op(a),i]); RETURN(primesums_primes_search_aux([op(a),i],n+1,upto_n)); fi; od; RETURN([op(a),`and no more found`]); end; # This gives multiple solutions (all of them) primesums_primes_mult := proc(upto_n) local a,b,i,n,p,t; a := []; for n from 1 to upto_n do b := []; p := ithprime(n); for i from (2^(n-1)) to ((2^n)-1) do t := bin_prime_sum(i); if(t = p) then b := [op(b),i]; fi; od; a := [op(a),b]; print(a); od; RETURN(a); end; primesums_primes_odds_only := proc(upto_n) local a,b,i,n,p,t; a := []; for n from 1 to upto_n do b := []; p := ithprime(n); for i from (2^(n-1))+1 by 2 to ((2^n)-1) do t := bin_prime_sum(i); if(t = p) then a := [op(a),i]; i := 0; break; fi; od; if(i > 0) then RETURN([op(a),`no odd encoding found`]); fi; od; RETURN(a); end; DIVSUM_SOLUTIONS_GLOBAL := []; DivSumChoose := proc(n,k) global DIVSUM_SOLUTIONS_GLOBAL; DIVSUM_SOLUTIONS_GLOBAL := []; DivSumChooseSearch([],n,k); RETURN(DIVSUM_SOLUTIONS_GLOBAL); end; # The value in the upper limit of the loop, # n-(k-p) is equal to n - how many term we need still to # to choose # Otherwise quite brute backtracking: DivSumChooseSearch := proc(s,n,k) global DIVSUM_SOLUTIONS_GLOBAL; local i,p; p := nops(s); if(p = k) then if(0 = (convert(s,`+`) mod k)) then DIVSUM_SOLUTIONS_GLOBAL := [op(DIVSUM_SOLUTIONS_GLOBAL),s]; fi; else for i from lmax(s)+1 to n-(k-p)+1 do DivSumChooseSearch([op(s),i],n,k); od; fi; end; DivSumChooseTriangle := (n) -> nops(DivSumChoose(trinv(n-1),(n-((trinv(n-1)*(trinv(n-1)-1))/2)))); # Brute search: DivSumChoose2 := proc(n,k) local a,i,j; a := []; for i from 1 to (n-1) do for j from (i+1) to n do if(0 = ((i+j) mod k)) then a := [op(a),[i,j]]; fi; od; od; RETURN(a); end; # Use as A061857 := [seq(DivSumChoose2Triangle(j),j=1..120)]; DivSumChoose2Triangle := (n) -> nops(DivSumChoose2(trinv(n-1),(n-((trinv(n-1)*(trinv(n-1)-1))/2)))); # Naive, with a bit of overchecking: SquareThreatened := proc(a,i,j,upto_n,senw,nesw) local k; for k from 1 to i do if(a[k,j] > 0) then RETURN(1); fi; od; for k from 1 to j do if(a[i,k] > 0) then RETURN(1); fi; od; if((1 = i) and (1 = j)) then RETURN(0); fi; # The first square at top corner is free # Check the main diagonal, k is offset from the current location i,j towards the corner: for k from 1 to `if`((-1 = senw),min(i,j)-1,senw) do if(a[i-k,j-k] > 0) then RETURN(1); fi; od; # Check the antidiagonal towards ne, k is offset from the current location i,j towards # the top row: for k from 1 to `if`((-1 = nesw),i-1,nesw) do if(a[i-k,j+k] > 0) then RETURN(1); fi; od; # Check the antidiagonal towards sw, k is offset from the current location i,j towards # the left edge: for k from 1 to `if`((-1 = nesw),j-1,nesw) do if(a[i+k,j-k] > 0) then RETURN(1); fi; od; RETURN(0); # No threats. end; # b should be an odd integer >= 3, and d should be in range [0,b-1]. HalveDigit := (d,b) -> op(2,op(1,msolve(2*x=d,b))); DoubleDigits := proc(n,b) local i; add((b^i)*((2*floor(n/(b^i))) mod b),i=0..floor(evalf(log[b](n+1)))+1); end; HalveDigits := proc(n,b) local i; add((b^i)*HalveDigit((floor(n/(b^i)) mod b),b),i=0..floor(evalf(log[b](n+1)))+1); end; QuintalQueens0 := n -> DoubleDigits(n,5); QuintalQueens0Inv := n -> HalveDigits(n,5); QuintalQueens1 := n -> 1+QuintalQueens0(n-1); QuintalQueens1Inv := n -> 1+QuintalQueens0Inv(n-1); GreedyRooks := upto_n -> PM2PL(GreedyNonThreateningPermutation(upto_n,0,0),upto_n); GreedyDragons := upto_n -> PM2PL(GreedyNonThreateningPermutation(upto_n,1,1),upto_n); GreedyQueens := upto_n -> PM2PL(GreedyNonThreateningPermutation(upto_n,-1,-1),upto_n); GreedyDragonsDirect := n -> n + ((n-1) mod 5) - 5*(floor((n-1 mod 5)/3)); # Or alternatively, double (in mod 5) the least significant digit of base-5 # representation of n-1, convert back to decimal, and add one. # The delta-sequence p(n)-n is simple periodic 0,1,2,-2,-1, 0,1,2,-2,-1, ... # dl := GreedyDragons(256); # dl := [1,3,5,2,4,6,8,10,7,9,11,13,15,12,14,16,18,20, # 17,19,21,23,25,22,24,26,28,30,27,29,31,33,35,32, # 34,36,38,40,37,39,41,43,45,42,44,46,48,50,47,49, # 51,53,55,52,54,56,58,60,57,59,61,63,65,62,64,66, # 68,70,67,69,71,73,75,72,74,76,78,80,77,79,81,83, # 85,82,84,86,88,90,87,89,91,93,95,92,94,96,98,100, # 97,99,101,103,105,102,104,106,108,110,107,109,111, # 113,115,112,114,116,118,120,117,119,121,123,125,122,124,126,...] # Here's the gf for A065186 (GreedyDragons permutation): # # series(x*(x^5+2*x^4-3*x^3+2*x^2+2*x+1)/((x-1)*(x^5-1)),x,27); # 2 3 4 5 6 7 8 9 10 # x + 3 x + 5 x + 2 x + 4 x + 6 x + 8 x + 10 x + 7 x + 9 x + # # 11 12 13 14 15 16 17 # 11 x + 13 x + 15 x + 12 x + 14 x + 16 x + 18 x + 20 # # 18 19 20 21 22 23 24 # x + 17 x + 19 x + 21 x + 23 x + 25 x + 22 x + 24 # # 25 26 27 # x + 26 x + O(x ) # # And for the corresponding zero-based variant: # # series((2*x^4+2*x^3-3*x^2+2*x+2)/((x-1)*(x^5-1)),x,26); # 2 3 4 5 6 7 8 9 # 2 + 4 x + x + 3 x + 5 x + 7 x + 9 x + 6 x + 8 x + 10 x + 12 # # 10 11 12 13 14 15 16 # x + 14 x + 11 x + 13 x + 15 x + 17 x + 19 x + 16 # # 17 18 19 20 21 22 23 # x + 18 x + 20 x + 22 x + 24 x + 21 x + 23 x + 25 # # 24 25 26 # x + 27 x + O(x ) # # For doubling of the second digit, we get the following ogf: # # (5*(x^5 + 2*x^10 - 2*x^15 - x^20)/((1-x)*(1+x^5+x^10+x^15+x^20))) # = (5*(1-x^5)*(x^5 + 2*x^10 - 2*x^15 - x^20)/((1-x)*(1-x^25))) # = 5*(x^4+x^3+x^2+x+1)*(x^10+3*x^5+1)*x^5/(1+x^5+x^10+x^15+x^20) # = 5*(x^14+x^13+x^12+x^11+x^10+3*x^9+3*x^8+3*x^7+3*x^6+3*x^5+x^4+x^3+x^2+x+1)*x^5/(1+x^5+x^10+x^15+x^20) # ogf for A065190: # series(x*(x^3-2*x^2+2*x+1)/((x+1)*(x-1)^2),x,16); # 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 # x + 3 x + 2 x + 5 x + 4 x + 7 x + 6 x + 9 x + 8 x + 11 x + 10 x + 13 x + 12 x + 15 x + 14 x + O(x ) # # And for A014681: # # series(x*(x^2-x+2)/((x+1)*(x-1)^2),x,12); # 2 3 4 5 6 7 8 9 10 11 12 # 2 x + x + 4 x + 3 x + 6 x + 5 x + 8 x + 7 x + 10 x + 9 x + 12 x + O(x ) # # EIS gives same G.f. shifted left by factor of x: (2-x+x^2)/((1-x)*(1-x^2)) [ njas ].) # # # dq := GreedyQueens(512); # dq := [1,3,5,2,4,9,11,13,15,6,8,19,7,22,10,25,27,29, # 31,12,14,35,37,39,41,16,18,45,17,48,20,51,53,21, # 56,58,60,23,63,24,66,28,26,70,72,74,76,78,30,32, # 82,84,86,33,89,34,92,38,36,96,98,100,102,40,105, # 107,42,110,43,113,44,116,118,120,46,123,47,50,127, # 49,130,132,134,136,52,54,140,142,144,55,57,148,150, # 152,59,155,157,159,61,162,62,65,166,64,169,171,173, # 67,176,178,68,181,69,184,186,71,75,190,192,73,195, # 197,77,200,202,204,206,79,81,210,212,80,83,216,218, # 85,221,223,225,227,87,230,88,91,234,90,237,239,241, # 243,93,95,247,94,250,97,253,255,257,99,260,262,101, # 265,267,269,103,272,104,275,108,106,279,281,283,285, # 109,111,289,291,293,112,114,297,299,301,115,117,305, # 307,309,311,119,121,315,317, ...]; # GreedyNonThreateningPermutation := proc(upto_n,senw,nesw) local a,i,j; a := array(1..upto_n,1..upto_n); # Row,Column for i from 1 to upto_n do for j from 1 to upto_n do a[i,j] := 0; od; od; for j from 1 to upto_n # Antidiagonal we are on now. do for i from 1 to j # Row we are on now. do if(0 = SquareThreatened(a,i,(j-i+1),upto_n,senw,nesw)) then a[i,j-i+1] := 1; fi; od; od; RETURN(eval(a)); end; PM2PL := proc(a,upto_n) local b,i,j; b := []; for i from 1 to upto_n do for j from 1 to upto_n do if(a[i,j] > 0) then break; fi; od; b := [op(b),`if`((j > upto_n),0,j)]; od; RETURN(b); end; # Start indexing from 0: PerSS_table := (n) -> PerSS((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1, (n-((trinv(n)*(trinv(n)-1))/2))); PerSS := (n,c) -> Z2N(N2Z(n)+c); InfRisingSS := z -> `if`((z < 0),`if`((0 = (z mod 2)),z/2,-z),2*z); InfRisingSSInv := z -> `if`((z > 0),`if`((0 = (z mod 2)),z/2,-z),2*z); TZ2 := proc(xx) local x,s; s := 1; x := xx; if(0 = x) then RETURN(0); fi; while(0 = (x mod 2)) do x := floor(x/2); s := s+1; od; RETURN(2^s); end; DistSS := proc(n,b) local d,s; s := 0; for d in divisors(n) do s := s+mobius(n/d)*((b+1)^d - b^d); od; RETURN(s/n); end; DistSS_table := (n) -> DistSS((((trinv(n)-1)*(((1/2)*trinv(n))+1))-n)+1, (n-((trinv(n)*(trinv(n)-1))/2))); # Inspired by an identity by Ramanujan(the equation 60) in http://mathworld.wolfram.com/ContinuedFraction.html # A008794_prepended_with_1 := [1,seq(floor(j/2)^2,j=2..101)]; # A008794_prepended_with_1 := [1, 1, 1, 4, 4, 9, 9, 16, 16, 25, 25, ..., 2500, 2500] # rr60 := compute_RR_confrac(A008794_prepended_with_1); # rr60 := 269503858111983835196640050046460471568780471390130698652534177289819580498517036477344445097626298 # / 474258057165089348576722628669817659287730428814152089758483489943248959261173849573479567810542885 # Digits := 99; # evalf(rr60); # 0.568264163445028145581940250579269204815765747353456227851827782616386612559861763902646447886934072 # iex := 4* int((y*exp(-y*sqrt(5)))/cosh(y), y=0..infinity ); # infinity # / 1/2 # | y exp(-y 5 ) # iex := 4 | -------------- dy # | cosh(y) # / # 0 # # evalf(iex); -> 0.5683000031462351788 # compute_RR_confrac := proc(a) local i,s; s := 0; for i from nops(a) by -1 to 1 do s := a[i]/(1+s); od; RETURN(s); end; ################################## FINISHED HERE (currently) #########################################