all the code.. i had missed a few things, mostly rpl
*** basep-gen ***
#!/bin/bash
echo ""
echo " "
echo " base-10"
echo " factorization"
echo " base-P"
echo " "
x=1
p=
while [ $x -le 30 ]
do
f=$(
factor $x|
cut -d: -f2
)
p=$(
echo $p $f|
tr ' ' '\n'|
grep -v '^1\?$'|
sort -n|
uniq|
tr '\n' ' '
)
b=$(
echo $f $p|
tr ' ' '\n'|
sort -n|
uniq -c|
sed 's/^ *//'|cut -d' ' -f1|
tac|
(
while :
do
read line ||
exit
echo $((
$line - 1
))
done
)|
tr -d '\n'|
sed 's/^0*//'
)
if [ -z "$b" ]
then
b=0
fi
echo " $x$f$b"
x=$((
$x + 1
))
done
echo ""
*** basep-mult ***
#!/bin/bash
if [ $# -ne 2 ]
then
echo Usage: $0 n1 n2
exit 1
fi
if [ $1 -ne 0 ]
then
f1=$(factor $1|cut -d: -f2|sed 's/^ *//')
if [ -z "$f1" ]
then
echo Invalid number $1
exit 1
fi
maxf1=$(echo $f1|rev|cut -d\ -f1|rev)
echo $1 has factors $f1, max is $maxf1
else
f1=
maxf1=1
echo $1 has no factors "(setting max to 1)"
fi
if [ $2 -ne 0 ]
then
f2=$(factor $2|cut -d: -f2|sed 's/^ *//')
if [ -z "$f2" ]
then
echo Invalid number $2
exit 1
fi
maxf2=$(echo $f2|rev|cut -d\ -f1|rev)
echo $2 has factors $f2, max is $maxf2
else
f2=
maxf2=1
echo $2 has no factors "(setting max to 1)"
fi
if [ $maxf1 -gt $maxf2 ]
then
max=$maxf1
else
max=$maxf2
fi
p=$(primes 1 $[ $max + 1 ])
np=$(echo $p|wc -w)
np2=$[$np * 2]
echo $np primes, scaling to $np2 "(double)"
while [ $np -lt $np2 ]
do
max=$[ $max * 2 ]
p=$(primes 1 $[ $max + 1])
np=$(echo $p|wc -w)
done
p=$(echo $p|cut -d' ' -f1-$np2)
if [ $1 -ne 0 -a $1 -ne 1 ]
then
p2=$p
done=
q=
while [ -z "$done" ]
do
z=$(echo $p2|cut -d\ -f1)
p2=$(echo $p2|cut -d\ -f2-)
c=$(echo $f1|tr ' ' '\n'|grep '^'$z'$'|wc -l)
echo "$1 has $c $z's"
q="$c $q"
if [ "$z" = "$p2" ]
then
done=1
fi
done
q=$(echo $q|sed 's/^\(0 \)*//')
else
q=0
fi
echo "$1: $q"
if [ $2 -ne 0 -a $2 -ne 1 ]
then
p2=$p
done=
q2=
while [ -z "$done" ]
do
z=$(echo $p2|cut -d\ -f1)
p2=$(echo $p2|cut -d\ -f2-)
c=$(echo $f2|tr ' ' '\n'|grep '^'$z'$'|wc -l)
echo "$2 has $c $z's"
q2="$c $q2"
if [ "$z" = "$p2" ]
then
done=1
fi
done
q2=$(echo $q2|sed 's/^\(0 \)*//')
else
q2=0
fi
echo "$2: $q2"
zz=
z=0
for d in $(echo $q|rev)
do
q=$(echo $q|rev)
echo -n "$d by $q2 is "
iz=0
while [ $iz -lt $z ]
do
iz=$[$iz + 1]
r2[$iz]=0
done
n=$[1 + $z]
r2s=
for d2 in $(echo $q2|rev)
do
d2=$(echo $d2|rev)
r2[$n]=$[ $d * $d2 ]
r[$n]=$[ ${r[$n]} + $d * $d2 ]
r2s="$r2s ${r2[$n]}"
n=$[$n + 1]
done
echo -n $zz$r2s "(R): "
set|grep ^r2=|cut -d= -f2-
echo -n "Cumulative: "
set|grep ^r=|cut -d= -f2-
zz="0 $zz"
z=$[$z + 1]
done
a=1
n=1
for d in $p
do
if [ -n "${r[$n]}" ]
then
a=$[$a * $d ** ${r[$n]}]
fi
echo Prime $d, cumulative $a
n=$[$n + 1]
done
echo Answer: $a
*** BCLIB-p ***
/* example usage: */
/* j=num2p(200,f[]) --> 3 0 2 in f[] */
/* n=p2num(f[],j) returns 200 */
define num2p(n, *f[]) {
auto i, j, l, s[], z;
z = scale;
scale = 0;
l = n;
for(i = 2; i <= l; ++i) {
s[i - 2] = 1;
}
for(i = 2; i <= l; ++i) {
for(j = 2; i*j <= l; ++j) {
s[i*j - 2] = 0;
}
}
for(i = 2; i <= l; ++i) {
print i, ": ", s[i - 2], "\n";
}
j = 0;
for(i = 2; i <= l; ++i) {
if(s[i - 2]) {
f[j] = 0;
print n, " % ", i, " == ", n % i;
while(n % i == 0) {
++f[j];
n = n / i;
print "for ", i, " (p#", j, "): n -> ", n, "; f -> ", f[j], "\n";
}
++j;
}
}
for(i = 0; i < j; ++i) {
print f[i], " "
}
print "\n"
scale = z;
return j;
}
define p2num(p[], r) {
auto i, j, l, s[], z, o, k;
z = scale;
scale = 0;
l = r;
k = 0;
while(k < r) {
l = l * 2;
for(i = 2; i <= l; ++i) {
s[i - 2] = 1;
}
for(i = 2; i <= l; ++i) {
for(j = 2; i*j <= l; ++j) {
s[i*j - 2] = 0;
}
}
k = 0;
for(i = 2; i <= l; ++i) {
if(s[i - 2]) {
++k;
}
}
}
print "l=", l, " k=", k, "\n";
for(i = 2; i <= l; ++i) {
print i, ": ", s[i - 2], "\n";
}
o = 1;
j = 0;
for(i = 2; i <= l; ++i) {
if(s[i - 2]) {
if(p[j]) {
o = o * i^p[j];
print "after ", i, " (p#", j, "): o -> ", o, " from p:", p[j], "\n";
}
++j;
}
}
scale = z;
return o;
}
define squid(a,b) {
auto m, n, p[], q[], r[], j, k, l;
j = num2p(a,p[]);
k = num2p(b,q[]);
l = j + k;
print "j:", j, " k:", k, " -> l:", l, "\n";
for(m = 0; m < l; ++m) {
r[m] = 0;
}
for(m = 0; m < j; ++m) {
for(n = 0; n < k; ++n) {
r[m + n] = r[m + n] + p[m]*q[n];
print "@", m, ",", n, " r->", r[m+n], " from ", p[m], ",", q[n], "\n";
}
}
return p2num(r[],l);
}
*** basep.scm ***
;; copy/paste to load:
; (load "/sdcard/basep.scm")
;; glue code for wh-primes
;; not very well tested. exercise caution.
;; --os
(define (foldl func v l)
(if (null? l)
v
(foldl func
(func (car l) v) (cdr l)
)
)
)
(define (filter func l)
(let
(
(elem
(car l))
)
(cond
((null? l)
l)
((func elem)
(cons elem (filter func (cdr l))))
(else
(filter func (cdr l)
)
)
)
)
)
;; copied from
;; http://webcache.googleusercontent.com/search?q=cache:swarm.cs.pub.ro/~mihai/facultate/pp/wh-primes.scm
;; with minor changes for Scheme Droid. original page is 404'd.
;;; (define (gnat x)
;;; (list x (delay (gnat (+ 1 x)))))
;;;
;;; (define nat2 (gnat 2)) ; skip 0 and 1
;;; (define nat0 (gnat 0))
;;;
;;; (define (take-wh n s)
;;; (if (< n 1) '()
;;; (cons (car s) (take-wh (- n 1) (force (cadr s))))))
;;;
;;; ; Any prime number other than 2 and 3 is of the form 6k+1 or 6k+5.
;;; ; We should avoid testing primality by diving to 2 and 3 and check
;;; ; only the remainders by 6.
;;; ; And we could generalize further.
;;; ; Other way to look at this would be to think of this as a wheel of
;;; ; circumference 6 with spikes at 1 and 5. Rolling it on a sheet of
;;; ; paper will give marks on positions not divisible by 2 and 3.
;;; ; And we could generalize this more.
;;;
;;; ; The wheel: size and a list of spikes
;;; ; (size (spike1 spike2 ... spiken))
;;; (define (wSize w) (car w))
;;; (define (wSpikes w) (cadr w))
;;;
;;; (define w6 '(6 (1 5))) ; the example wheel
;;;
;;; ; Rolling a wheel of size k=p1*p2*...*pn (where each pi is a prime)
;;; ; should mark all positions that could represent primes, if the
;;; ; spikes are properly chosen.
;;; (define (roll w) (roll-aux1 0 (wSize w) (wSpikes w)))
;;;
;;; (define (roll-aux1 n r s)
;;; (let
;;; (
;;; (next (delay (roll-aux1 (+ 1 n) r s)))
;;; (poss (map (lambda (x) (+ (* r n) x)) s))
;;; )
;;; (build-gen poss next)
;;; ))
;;;
;;; (define (build-gen ps g)
;;; (if (null? ps) (force g)
;;; (list (car ps) (delay (build-gen (cdr ps) g)))))
;;;
;;; ; smallest wheel
;;; (define w0 '(1 (1)))
;;;
;;; ; generate a bigger wheel
;;; (define (next p w)
;;; (let*
;;; (
;;; (size (wSize w))
;;; (spikes (wSpikes w))
;;; (wh0p-1 (map (lambda (x) (* x size)) (take-wh p nat0)))
;;; (candidates (apply append (map (lambda (x) (map (lambda (s) (+ s
;;; x)) spikes)) wh0p-1)))
;;; (newspikes (filter (lambda (x) (not (= 0 (remainder x p))))
;;; candidates))
;;; )
;;; (list (* size p) newspikes)
;;; ))
;;;
;;; ; generate the wheel from a list of (known)primes
;;; (define (mkWheel primes) (foldl next w0 primes))
;;;
;;; ; get primes using a fixed wheel (optimize by changing the wheel in the
;;; ; middle)
;;; ; right now, it assumes a wheel of a proper size which will give the
;;; ; first N
;;; ; primes and may give false primes afterwards
;;; (define primes-wh
;;; (let
;;; (
;;; (primes '(2 3 5 7))
;;; )
;;; (build-gen primes (force (cadr (roll (mkWheel primes)))))))
;;;
;;adapted from
;;http://stackoverflow.com/questions/3345626/finding-a-prime-number-in-scheme-using-natural-recursion
(define (is-not-divisible-by<=i i m)
(cond ((= i 1) true)
(else (cond
((= (remainder m i) 0) false)
(else (is-not-divisible-by<=i (sub1 i) m))))))
(define (sub1 n) (- n 1))
(define (add1 n) (+ n 1))
(define true #t)
(define false #f)
(define (square n) (* n n))
(define (is-prime n)
(is-not-divisible-by<=i (floor (sqrt n)) n))
;;excerpted from
;;http://danf.wordpress.com/2011/03/05/testing-for-primes-scheme/
(define divides?
(lambda (a b)
(= (remainder a b) 0)))
(define prime?
(lambda (n)
(cond ((or (= n 1) (= n 0)) #f)
((= n 2) #t)
((even? n) #f)
(else (let prime-test ((d 3))
(cond ((> (square d) n) #t)
((divides? n d) #f)
(else (prime-test (+ d 2)
))))))))
;; (define naturals (let
;; make-naturals ((i 0))
;; (cons-stream i
;; (make-naturals (+ i 1)))))
;;
;; (define filter-stream
;; (lambda (f s)
;; (let (
;; (rest (delay (filter-stream f (force (cdr s)))))
;; (head (car s)) )
;; (if (f head) (cons head rest) (force rest)))))
;;
;; (define take (lambda (n s)
;; (if (= n 0) '()
;; (let (
;; (rest (take (- n 1)
;; (stream-cdr s)))
;; (head (stream-car s))
;; )
;; (cons head rest)))))
;;
;; (define sieve
;; (lambda (s)
;; (cons (car s)
;; (delay
;; (sieve
;; (filter-stream
;; (lambda (x)
;; (not (= (remainder x (car s)) 0)))
;; s))))))
;;
;; (define naturals-from-2
;; (force (cdr (force (cdr naturals)))))
;;
;; (define primes (sieve naturas-from-2))
;;
;; (define benchmark
;; (lambda (f)
;; (time (begin (force f) '()))))
;;
;; (define oldforce force)
;; (define forces 0)
;; (define (force x)
;; (set! forces (+ 1 forces))
;; (oldforce x))
;;
;;everything henceforth is my pseudobase-prime work...
;; may cause your scheme interpreter to catch fire, shown to induce delirium
;; in rhesus monkeys, contains chemicals known to the State of California to
;; cause cancer and/or spontaneous abortion and/or pregnancy in males, etc
;; etc
;; equivalent RPN code is for User RPL
;; interpreter on HP 49g+
;; --os
(define (divide-out-factor n f)
(if (not (= 0 (remainder n f)))
(list n 0)
(let ((l (divide-out-factor (/ n f) f)))
(list (car l) (+ 1 (cadr l))))))
(define (basepaux n l f)
(cond ((< f 2) l)
((not (prime? f))
(basepaux n l (- f 1)))
(else (let* ((dof (divide-out-factor n f))
(p (cadr dof)))
(basepaux (car dof)
(if (and (null? l) (= p 0)) l
(cons (cadr dof) l))
(- f 1))))))
(define (basep n)
(basepaux n '() n))
; ADD2REP
; << SWAP WHILE DUP LASTP NEXTPRIME DUP
; 3 ROLLD >= REPEAT 'LASTP' STO BPOS
; 1 + 'BPOS' STO REP OBJ-> 0 SWAP 1 +
; ->LIST 'REP' STO END DROP DROP REP
; BPOS 3 ROLL PUT 'REP' STO >>
; BPRECUR
; << DUP TYPE IF 28 == THEN 1 ADD2REP
; ELSE OBJ-> ->STR IF "^" == THEN DROP
; ADD2REP ELSE DROP SWAP BPRECUR
; BPRECUR END END >>
; BASEP
; << IF DUP 1 == THEN DROP { } ELSE
; FACTOR { } 'REP' STO 0 'BPOS' STO
; 1 'LASTP' STO BPRECUR REP END
(define (bp2num l)
(bp2numaux l 2))
(define (bp2numaux l f)
(cond ((null? l) 1)
((not (prime? f))
(bp2numaux l (+ 1 f)))
(else (* (pwr f (car l))
(bp2numaux (cdr l)
(+ 1 f))))))
(define (pwr a b)
(cond
((= b 0) 1)
((= b 1) a)
((= a 0) 0)
((= a 1) 1)
(else (* a (pwr a (- b 1))))))
; BP2NUM
; << BPNORM REVLIST 1 1 -> N P <<
; OBJ-> WHILE DUP 0 > REPEAT SWAP P
; NEXTPRIME DUP 'P' STO SWAP ^ N *
; 'N' STO 1 - END DROP N >> >>
(define (bpnorm l)
(if (null? l) l
(let ((rest (cdr l))
(f (car l)))
(if (= 0 f)
(if (null? rest)
rest
(let ((newrest (bpnorm rest)))
(if (null? newrest)
newrest
(cons f newrest))))
(cons f (bpnorm rest))))))
; BPNORM
; << 1 SWAP OBJ-> WHILE SWAP DUP 0 ==
; REPEAT DROP 1 - END SWAP ->LIST SWAP
; DROP >>
(define (trim l c)
(if (or (= c 0) (null? l)) '()
(cons (car l)
(trim (cdr l) (- c 1)))))
(define (revtrima l c a)
(if (or (= c 0) (null? l)) a
(revtrima (cdr l)
(- c 1)
(cons (car l) a))))
(define (revtrim l c)
(revtrima l c '()))
(define (chopn l n)
(if (= n 0) l
(chopn (cdr l) (- n 1))))
(define (sumlist l)
(if (null? l) 0
(+ (car l)
(sumlist (cdr l)))))
(define (mulcol x y)
(if (or (null? x) (null? y)) '()
(cons (* (car x)
(car y))
(mulcol (cdr x)
(cdr y)))))
(define (gencolsqd j k c chop)
(sumlist (mulcol (revtrim j c)
(chopn (trim k c) chop))))
(define (squidaux j k c n s)
(if (> c n) '()
(cons (gencolsqd j k c
(if (> c s) (- c s)
0)) (squidaux j k
(+ c 1) n s))))
(define (squid a b)
(let* ((al (length a)) (bl (length b))
(aj (< al bl)) (j (if aj a b))
(k (if aj b a)) (s (if aj al bl)))
(bpnorm (squidaux j k 1 (- (+ al bl) 1) s))))
; SQUID
; << -> M N << IF M SIZE 0 == N SIZE 0
; == OR THEN { } ELSE M SIZE N SIZE + 1
; - -> C << M OBJ-> 1 SWAP 2 ->LIST
; ->ARRY 1 M SIZE FOR R 1 R FOR Q 0
; NEXT DROP N OBJ-> R + 1 - C FOR Z 0
; NEXT DROP C ROW-> NEXT M SIZE ROW->
; * >> OBJ-> OBJ-> DROP SWAP DROP
; ->LIST END >> >>
(define (bpconjaux l)
(if (null? l) '(1)
(let ((p (car l))
(r (cdr l)))
(if (= p 0)
(if (null? r) '(1)
(cons (+ (car r) 1)
(cdr r))
(cons 0
(cons (- (car r) 1)
(cdr r))))))))
(define (bpconj l)
(bpconjaux (bpnorm l)))
; BPCONJ
; << OBJ-> IF DUP 0 == THEN DROP
; { 1 } ELSE DUP 1 + ROLL DUP IF 0
; == THEN DROP IF DUP 1 == THEN
; DROP { 1 } ELSE DUP ROLL 1 + SWAP
; DUP 3 ROLLD ROLLD 1 - ->LIST END
; ELSE 0 SWAP 1 - 3 ROLL 2 + DUP
; 3 ROLLD ROLLD 1 - ->LIST END END >>
(define (inbptreerow l)
(if (null? l) 0
(+ (sumlist l)
(- (length l) 1))))
(define (inbptreecol l)
(cond ((null? l) 0)
((null? (cdr l)) 0)
((null? (cddr l)) (pwr 2 (car l)))
(else (* (pwr 2 (car l))
(+ 1 (* 2
(inbptreecol (cdr l))))))))
(define (inbptree l)
(list (inbptreerow l)
(inbptreecol l)))
; INBPTREE
; << IF DUP SIZE 0 == THEN DROP { 0 0 }
; ELSE DUP DUP 0 SWAP 1 << + >> DOLIST
; SWAP SIZE 1 - + SWAP OBJ-> SWAP DROP
; IF DUP 1 == THEN DROP 0 ELSE 0 SWAP
; 1 - 0 FOR Z IF Z 0 > THEN 1 + SWAP
; Z 1 > + 2 SWAP ^ * END -1 STEP END
; 2 ->LIST END >>
(define (bptree r c)
(cond ((= 0 r) '())
((= 1 r) '(1))
((= 0 c) (list r))
((= 0 (remainder c 2))
(let ((p (bptree
(- r 1)
(/ c 2))))
(cons (+ 1 (car p))
(cdr p))))
(else (cons 0
(bptree (- r 1)
(/ (- c 1) 2))))))
(define (log2 n)
(if (< n 2) 0
(+ 1 (log2 (/ n 2)))))
; BPTREE
; << OBJ-> DROP -> R C << IF R 0 == THEN
; { } ELSE C 1 R FOR Z DUP 2 MOD DUP 3
; ROLLD - 2 / NEXT DROP { 0 } 1 R FOR Z
; SWAP IF 1 == THEN OBJ-> 0 SWAP 1 +
; ->LIST ELSE OBJ-> SWAP 1 + SWAP ->LIST
; END NEXT REVLIST END >> >>
(define (bpseq n)
(if (= 0 n) '()
(let ((p (log2 n)))
(bptree (+ p 1)
(- n (pwr 2 p))))))
; BPSEQ
; << IF DUP 0 == THEN DROP { } ELSE
; DUP LN 2 LN / ->NUM FLOOR DUP 3 ROLLD
; 2 SWAP ^ - SWAP 1 + SWAP 2 ->LIST
; BPTREE END >>
(define (rnbpord n)
(if (= n 0) '()
(cons (bp2num (bpseq (- n 1)))
(rnbpord (- n 1)))))
(define (nbpord n)
(reverse (rnbpord n)))
; NBPORD
; << 1 - << A BPSEQ >> 'A' 0 4 ROLL 1
; SEQ 1 << BP2NUM >> DOLIST >>
(define (rnatseq n)
(if (= n 0) '()
(cons n (rnatseq (- n 1)))))
(define (bpordnth n)
(map (lambda (x)
(let ((pos (inbptree (basep x))))
(if (= 0 (car pos)) 0
(+ (cadr pos)
(pwr 2 (- (car pos) 1))))))
(reverse (rnatseq n))))
; BPORDNTH
; << << A BASEP >> 'A' 1 4 ROLL 1 SEQ
; 1 << INBPTREE OBJ-> DROP SWAP IF
; DUP 0 == THEN DROP DROP 0 ELSE 1 -
; 2 SWAP ^ + END >> DOLIST >>
*** BCLIB-p ***
define squidn(a,b) {
auto m, n, p[], q[], r[], j, k, l;
j = num2p(a,p[]);
k = num2p(b,q[]);
l = j + k;
print "j:", j, " k:", k, " -> l:", l, "\n";
for(m = 0; m < l; ++m) {
r[m] = 0;
}
for(m = 0; m < j; ++m) {
for(n = 0; n < k; ++n) {
r[m + n] = r[m + n] + p[m]*q[n];
print "@", m, ",", n, " r->", r[m+n], " from ", p[m], ",", q[n], "\n";
}
}
return p2num(r[],l);
}
define void bpconj(p[],*q[]) {
auto i;
if(p[0] == 0) {
q[0] = 1;
q[1] = 1;
return;
}
if(p[1] == 0) {
for(i = 2; i <= p[0]; ++i) {
q[i - 1] = p[i];
}
q[0] = p[0] - 1;
q[1] = q[1] + 1;
} else {
for(i = 1; i <= p[0]; ++i) {
q[i + 1] = p[i];
}
q[1] = 0;
q[0] = p[0] + 1;
q[2] = q[2] - 1;
}
}
define void bpnorm(*p[]) {
auto i, c, b;
b=0;
for(i = p[0]; i > 0; --i) {
if(b == 0) {
if(p[i] == 0) {
c++;
} else {
b++;
}
}
}
p[0] = p[0] - c;
}
---snip---
P2RLE:
<< 0 0 0 -> DAT LST CNT RLE
<< DAT DUP
IF SIZE 0 =/=
THEN 1
<< DUP
IF LST ==
THEN 1 CNT + 'CNT' STO DROP
ELSE
IF CNT 0 >
THEN LST CNT 2 ->ARRY 1 RLE + 'RLE' STO 0 'CNT' STO SWAP
END 'LST' STO 1 'CNT' STO
END
>> DOSUBS
IF CNT 0 >
THEN
IF RLE 0 =/=
THEN OBJ-> DROP
END LST CNT 2 ->ARRY 1 RLE + 'RLE' STO RLE ->LIST
END
END
>>
>>
BP2BINSTR:
<< IF DUP SIZE 0 == THEN DROP 0
ELSE 1 << "0" SWAP IF DUP 0 >
THEN 1 SWAP START "1" + NEXT
ELSE DROP END >> DOSUBS REVLIST
OBJ-> DUP 1 + ROLL TAIL 2 PICK
1 + ROLLD ->LIST << + >> STREAM
"#" SWAP + "b" + OBJ-> B->R END
>>
RLE2BP:
<< LIST-> IF DUP 0 =/= THEN { } ->
B << 1 SWAP FOR X OBJ-> DROP DUP
1 SWAP FOR Y 2 PICK Y 2 +
ROLLD NEXT SWAP DROP ->LIST B
SWAP + 'B' STO NEXT B >> ELSE {
} END >>
BINSTR2BP:
<< 0 R->B ->STR SWAP BIN R->B ->STR
DUP SIZE DUP 3 ROLLD 1 - 3 SWAP
SUB "0" + SWAP 0 { } -> S L
<< 3 - 1 SWAP
FOR X DUP X X SUB "0"
IF =/=
THEN S 1 + 'S' STO
ELSE S 1 ->LIST L + 'L' STO 0 'S' STO
END
NEXT DROP S 1 ->LIST L +
>> SWAP DUP SIZE DUP SUB
IF DUP "h" ==
THEN HEX
END
IF DUP "o" ==
THEN OCT
END
IF DUP "d" ==
THEN DEC
END DROP
>>
DELTAS0:
<< DUP 0 SWAP LIST-> DROP ->LIST - >>
DELTAS1:
<< DELTAS0 TAIL >>
define void squid(a[], b[], *c[]) {
auto m, n, p[], q[], r[], j, k, l;
j = a[0];
k = b[0];
for(n = 0; n < j; ++n) {
p[n] = a[n + 1];
}
for(n = 0; n < k; ++n) {
q[n] = b[n + 1];
}
l = j + k;
print "j:", j, " k:", k, " -> l:", l, "\n";
for(m = 0; m < l; ++m) {
r[m] = 0;
}
for(m = 0; m < j; ++m) {
for(n = 0; n < k; ++n) {
r[m + n] = r[m + n] + p[m]*q[n];
print "@", m, ",", n, " r->", r[m+n], " from ", p[m], ",", q[n], "\n";
}
}
for(n = 0; n < l; ++n) {
c[n + 1] = r[n];
}
c[0] = l;
}
define void dispnonl(p[]) {
auto i;
print "{";
for(i = 1; i <= p[0]; ++i) {
print p[i];
if(i < p[0]) {
print ",";
}
}
print "}";
}
define void disp(p[]) {
dispnonl(p[]);
print "\n";
}
define void bptree(r,c,*p[]) {
auto i, j, s, m, o[], z;
s = scale;
scale = 0;
p[0] = 1;
p[1] = 0;
for(i = 0; i < r; ++i) {
print "@r", i, ":";
m = c / 2;
m = m * 2;
m = c - m;
if(m > 0) {
print "R";
o[r - i - 1] = 0;
c = (c - 1) / 2;
} else {
print "L";
o[r - i - 1] = 1;
c = c / 2;
}
print ",c:=", c, "\n";
disp(p[]);
}
for(i = 0; i < r; ++i) {
print "op", i, ":", o[i], "\n";
if(o[i] > 0) {
p[1] = p[1] + 1;
} else {
print "n=", p[0], ":";
disp(p[]);
for(j = p[0]; j >= 1; --j) {
print "j.", j, ".", p[j], "\n";
p[j + 1] = p[j];
}
p[1] = 0;
p[0] = p[0] + 1;
}
disp(p[]);
}
scale = s;
}
define void inbptree(p[],*rc[]) {
auto g, r, c, i, o[], n;
g = 1;
n = 0;
while(g > 0) {
disp(p[]);
if(p[0] == 1) {
if(p[1] == 0) {
p[0] = 0;
}
}
if(p[0] > 0) {
if(p[1] > 0) {
p[1] = p[1] - 1;
o[n++] = 1;
print "L\n";
} else {
for(i = 1; i < p[0]; ++i) {
p[i] = p[i + 1];
}
p[0] = p[0] - 1;
o[n++] = 0;
print "R\n";
}
} else {
g = 0;
}
}
r = 0;
c = 0;
for(i = n - 1; i >= 0; --i) {
if(o[i] > 0) {
r++;
c = c * 2;
print "op1\n";
} else {
r++;
c = c * 2 + 1;
print "op0\n";
}
}
rc[0] = r;
rc[1] = c;
print "(",r,",",c,")\n";
}
define void bpseq(n,*p[]) {
auto s, r, c, w;
s = scale;
scale = 0;
w = 1;
r = 0;
c = 0;
if(n == 0) {
p[0] = 0;
scale = s;
return;
}
while(n >= w) {
w = w * 2;
++r;
}
print "2^",w,">n@r=",r,"\n";
c = n - w / 2;
bptree(r,c,p[]);
scale = s;
}
define void nbpord(n,*s[]) {
auto i, p[];
for(i = 0; i < n; ++i) {
bpseq(i,p[]);
print "seq#",i,":";
disp(p[]);
s[i + 1] = bp2num(p[]);
}
s[0] = n;
}
define void bpordnth(n,*s[]) {
auto i, m, j, p[], x;
k = 1;
s[0] = n;
print "bpordnth: 0 to ",n,"\n";
for(i = 0; i < n; ++i) {
print "bpordnth: bpseq(",i,")-1=";
bpseq(i,p[]);
s[i + 1] = bp2num(p[])-1;
print s[i+1],"\n";
}
}
define bporddif(n) {
auto i, o[], s;
nbpord(2^n, o[]);
s = 0;
if(n > 0) {
for(i = 1; i <= o[0]; ++i) {
s = s + o[i];
}
s = s - 2^(2*n-1) - 2^(n-1);
}
return s;
}
define void bpordlst(n,*s[]) {
auto i;
if(n < 3) {
n = 3;
}
s[0] = n + 1;
for(i = 0; i <= n; ++i) {
s[i + 1] = bporddif(i);
}
}
define void bpordmul(n,*m[]) {
auto i, s[], d;
if(n < 4) {
m[0] = 0;
return;
}
d = scale;
scale = 10;
m[0] = n - 3;
bpordlst(n, s[]);
for(i = 4; i <= n; ++i) {
m[i - 3] = s[i + 1] / s[i];
print "bpordmul@", i - 3, ": ", m[i - 3], "\n";
}
scale = d;
}
bpordm10[0] = 7;
bpordm10[1] = 16;
bpordm10[2] = 10.6875;
bpordm10[3] = 9.28070175439;
bpordm10[4] = 8.98361688721;
bpordm10[5] = 9.25657571719;
bpordm10[6] = 9.89187776102;
bpordm10[7] = 10.7296193394;
/* I don't remember what this is... */
bpwtf[0] = 27;
bpwtf[1] = 1;
bpwtf[2] = 2;
bpwtf[3] = 2;
bpwtf[4] = 4;
bpwtf[5] = 2;
bpwtf[6] = 6;
bpwtf[7] = 2;
bpwtf[8] = 8;
bpwtf[9] = 4;
bpwtf[10] = 10;
bpwtf[11] = 2;
bpwtf[12] = 18;
bpwtf[13] = 2;
bpwtf[14] = 14;
bpwtf[15] = 6;
bpwtf[16] = 16;
bpwtf[17] = 2;
bpwtf[18] = 12;
bpwtf[19] = 2;
bpwtf[20] = 50;
bpwtf[21] = 10;
bpwtf[22] = 22;
bpwtf[23] = 2;
bpwtf[24] = 54;
bpwtf[25] = 4;
bpwtf[26] = 26;
bpwtf[27] = 8;
define void lstadd0s(*a[], *b[]) {
auto i;
if(a[0] >= b[0]) {
for(i = b[0] + 1; i <= a[0]; ++i) {
b[i] = 0;
}
b[0] = a[0];
} else {
for(i = a[0] + 1; i <= b[0]; ++i) {
a[i] = 0;
}
a[0] = b[0];
}
}
define void bpmax(a[], b[], *o[]) {
auto i;
lstadd0s(a[], b[]);
o[0] = a[0];
for(i = 1; i <= a[0]; ++i) {
if(a[i] >= b[i]) {
o[i] = a[i];
} else {
o[i] = b[i];
}
}
}
define void bpmin(a[], b[], *o[]) {
auto i;
lstadd0s(a[], b[]);
o[0] = a[0];
for(i = 1; i <= a[0]; ++i) {
if(a[i] >= b[i]) {
o[i] = b[i];
} else {
o[i] = a[i];
}
}
bpnorm(o[]);
}
define void bpfunc(n, *t[]) {
/* before calling, define a function bpfuncf: */
/* define bpfuncf(a[], b[], *c[]) { */
/* ... */
/* } */
/* for example: */
/* define bpfuncf(a[], b[], *c[]) { */
/* squid(a[], b[], *c[]) */
/* } */
auto r, c, x[], y[], z[];
t[0] = -n;
t[1] = -n;
for(r = 0; r < n; ++r) {
for(c = 0; c < n; ++c) {
print "bpfunc: f(",r+1,",",c+1,")\n"
basep(r + 1, x[]);
basep(c + 1, y[]);
print "bpfuncf(";
dispnonl(x[]);
print ",";
dispnonl(y[]);
print ") = \n";
bpfuncf(x[], y[], z[]);
print "bpfuncf result ";
dispnonl(z[]);
print "\n";
t[r * n + c + 2] = bp2num(z[]);
print "bpfunc: result ",t[r * n + c + 2], " into [",r*n+c+2,"]\n";
}
}
}
define void bpfuncf(a[], b[], *c[]) {
squid(a[], b[], c[]);
}
define void disptbl(t[]) {
auto i, j;
for(j = 0; j < -t[0]; ++j) {
print "[";
for(i = 0; i < -t[1]; ++i) {
print t[-t[1] * j + i + 2];
if(i < -t[1]-1) {
print ",";
}
}
print "]\n";
}
}
define void bpmirror(i[], *o[]) {
auto n, x, s;
bpnorm(i[]);
n = 0;
for(x = 1; i[x] == 0; ++x) {
++n;
}
print "chop ",n," zeroes\n";
for(x = 1; x <= n + 1; ++x) {
i[x] = i[x + n];
}
i[0] = i[0] - n;
s = scale;
scale = 0;
n = i[0] * 2 - i[0] % 2 - n;
print "expand to ",n," elems\n";
scale = s;
for(x = i[0] + 1; x <= n; ++x) {
i[x] = 0;
}
o[0] = n;
for(x = 1; x <= n; ++x) {
print "moving ",i[x],"\n";
o[n - x + 1] = i[x];
}
bpnorm(o[]);
}
define bpfact(n) {
auto z, r;
r = 2;
for(z = 2; z <= n; ++z) {
print "call squidn on ",r,z,"\n";
r = squidn(r, z);
}
return r;
}
define bptfunc(a, b) {
/* just like bpfunc: define bptfuncf but with scalars: */
/* define bptfunc(a, b) { */
/* ... */
/* return c; */
/* } */
auto p[], q[], x, y, z, r[], w[];
bpseq(a,p[]);
bpseq(b,q[]);
x = bp2num(p[]);
y = bp2num(q[]);
z = bptfuncf(x, y);
basep(z, r[]);
inbptree(r[], w[]);
if(w[0] == 0) {
return 0;
}
return 2^(w[0]-1)+w[1];
}
define bptfuncf(a, b) {
return a + b;
}
define bp2rle(p[], *r[]) {
auto i, v, c;
v = p[1];
r[0] = 0;
c = 1;
for(i = 2; i <= p[0]; ++i) {
if((p[i] == v)) {
++c;
} else {
print v,": ",c," @ ",r[0],"\n";
r[r[0]+1] = v;
r[r[0]+2] = c;
r[0] = r[0] + 2;
c = 1;
v = p[i];
}
}
print v,": ",c," @ ",r[0],"\n";
r[r[0]+1] = v;
r[r[0]+2] = c;
r[0] = r[0] + 2;
}
define void rle2bp(a[], *b[]) {
auto v, c, j, m, p, s;
p = 1;
s = scale;
scale = 0;
print "rle groups: ", a[0]/2, "\n";
scale = s;
for(m = 1; m < a[0]; m = m + 2) {
v = a[m];
c = a[m + 1];
print m, "@", p, ": ", c, " ", v, "'s\n"
for(j = 0; j < c; ++j) {
b[p++] = v;
}
}
b[0] = p - 1;
}
define bp2binstr(p[]) {
auto i, j, c, o[], v, q;
c = 1;
for(i = 1; i <= p[0]; ++i) {
v = p[i];
if(v > 0) {
for(j = 0; j < v; ++j) {
print "1@",j+c,"\n";
o[j + c] = 1;
}
c = c + j;
o[c++] = 0;
} else {
o[c++] = 0;
}
}
o[0] = c;
disp(o[]);
q = 0;
for(i = 0; i < c; ++i) {
q = o[i + 1] * 2 ^ i + q;
}
return q;
}
define void binstr2bp(b, *p[]) {
auto s, c, i;
s = scale;
scale = 0;
for(i = 1; b; b = b / 2) {
print "i=",i," bit:",b%2," c=",c,"\n";
if(b%2 == 0) {
print "hit 0\n"
p[i++] = c;
c = 0;
} else {
++c;
}
}
p[i] = c;
print i,"\n";
p[0] = i;
scale = s;
}
SQUIDN:
BASEP SWAP BASEP SWAP SQUID BP2NUM
define void deltas0(p[], *q[]) {
auto i, v;
v = 0;
for(i = 1; i <= p[0]; ++i) {
q[i] = p[i] - v;
v = p[i];
}
q[0] = p[0];
}
define void deltas1(p[], *q[]) {
auto i, v;
if(p[0] == 0) {
q[0] = p[0];
return;
}
v = p[1];
for(i = 2; i <= p[0]; ++i) {
q[i - 1] = p[i] - v;
v = p[i];
}
q[0] = p[0] - 1;
}
define bpnxor(n) {
auto x, r, s, m, p[], b, e;
s = scale;
scale = 0;
basep(n, p[]);
m = bp2binstr(p[]);
b = obase;
obase = 2;
print "n:",n,"\n";
print "m:",m,"\n";
r = 0;
while((n != 0) || (m != 0)) {
if(n % 2 != m % 2) {
r = r + 1;
}
n = n / 2;
m = m / 2;
r = r * 2;
}
r = r / 2;
print "r:",r,"\n";
e = 0;
while(r != 0) {
e = e + (r % 2);
r = r / 2;
e = e * 2;
}
e = e / 2;
print "e:",e,"\n";
scale = s;
obase = b;
return e;
}
/* func1f is the function called on 1 ... n; input, output are scalar ints
* */
define void func1(n, *o[]) {
auto i;
o[0] = n;
for(i = 1; i <= n; ++i) {
o[i] = func1f(i);
}
}
define func1f(n) {
return bpnxor(n);
}
define void bitlist(m, *q[]) {
auto x, r, s, n, b;
s = scale;
scale = 0;
b = obase;
obase = 2;
n = m;
print "m:",m,"\n";
r = 0;
while(m != 0) {
r = r + 1;
m = m / 2;
}
print "n:",n,"\n";
obase = b;
print "r:",r,"\n";
q[0] = r;
for(x = 0; x < r; ++x) {
q[r - x] = n % 2;
n = n / 2;
}
scale = s;
}
define unbitlist(p[]) {
auto x, s;
s = 0;
for(x = p[0]; x > 0; --x) {
if(p[x]) {
s = s + 2 ^ (p[0] - x);
}
}
return s;
}
FUNC1:
-> N F << 1 N FOR X X NEXT N ->LIST 1 F DOLIST >>
UNBITLIST:
<< DUP 0 -> M N << LIST-> 1 SWAP FOR X X DUP 2
SWAP 1 - ^ SWAP 1 + PICK * N + 'N' STO NEXT M
SIZE 1 SWAP FOR X DROP NEXT N >>
BITLIST:
<< DUP -> N M << IF N 0 == THEN {
} ELSE WHILE N REPEAT N 2 MOD
N 2 / ->NUM FLOOR 'N' STO END M
2 * LN 2 LN / ->NUM FLOOR ->LIST
REVLIST END >>
BPNXOR:
DUP BITLIST REVLIST SWAP
BASEP BP2BINSTR BITLIST
REVLIST LSTADD0S XOR REVLIST
UNBITLIST
*** print-basep-func-list ***
(grep '^[A-Z]\{4\}[^ ]*' baseprime-allcode|
sed 's/:$//'|
grep -v 'DROP\|SWAP\|P BP\|T [LE]';
grep '^define' baseprime-allcode|
sed 's/define \(void\)* \?\([^ (]*\).*/\2/';
grep '^(define' baseprime-allcode|
sed 's/^([^(]*//'|
grep -v '^ *$'|
sed 's/^(. \([^ ]\)\+.*$/\1 &/';
grep '^\*\*\*' baseprime-allcode|
sed 's/^[^ ] //';
grep '^; ' baseprime-allcode|
sed 's/^; //';
)|
sed 's/^(//;s/)$/ scheme/;s/ .*scheme/ scheme/'|
grep -v 'basep\.scm\|BCLIB-p'|
sort -f
BPWTF:
{ 27 1 2 2 4 2 6 2 8 4 10 2 18 2 14 6 16 2 12 2 50 10 22 2 54 4 26 8 }
BPORDM10:
{ 7 16 10.6875 9.28070175439 8.98361688721 9.25657571719 9.89187776102 10.7296193394 }
BPFACT:
{ 1 } SWAP 2 SWAP FOR Z Z
BASEP SQUID NEXT BP2NUM
BPFUNC:
-> N F
<< 1 N
FOR Z Z BASEP
NEXT N ->LIST 1 N
FOR Z DUP
NEXT N ->LIST 2
<< SWAP -> X
<< 1
<< X SWAP F EVAL
>> DOLIST
>>
>> DOLIST OBJ-> 1 SWAP
FOR Z OBJ-> DUP 1 + SWAP 1 SWAP
FOR X DUP ROLL BP2NUM SWAP
NEXT DROP Z N * N + Z - Z N =/= * ROLL
NEXT N N 2 ->LIST ->ARRY
IF N 2 >=
THEN 1 ROW- N ROW+
END
>>
BPMIN:
{ 0 } + SWAP { 0 } +
LSTADD0S 2 << MIN >>DOLIST BPNORM
BPMAX:
{ 0 } + SWAP { 0 } +
LSTADD0S 2 << MAX >> DOLIST
BPMIRROR:
DUP
IF SIZE 0 >
THEN DUP SORT REVLIST
HEAD SWAP DUP SIZE DUP 1 +
2 / DUP FLOOR SWAP CEIL
0 -> M L S F C P
<<
DO
IF L C GET M ==
THEN C 'P' STO
ELSE
IF L F GET M ==
THEN F 'P' STO
ELSE F 1 - 'F' STO
C 1 + 'C' STO
END
END
UNTIL P 0 =/= S C <
DUP C SWAP - 'C' STO
1 F > DUP F + 'F' STO
AND OR
END
IF S P == P 1 > AND
THEN L OBJ-> 1 - DUP
S + 'S' STO 1 SWAP
FOR Z 0
NEXT S ->LIST 'L' STO
END S P - P 1 - MIN
IF DUP 1 <
THEN DROP L
ELSE P DUP2 SWAP - 3
ROLLD + 2 PICK L
SWAP P 1 - SUB REVLIST 3
ROLLD L SWAP P 1 +
SWAP SUB REVLIST 3 ROLL
L SWAP 4 ROLL SWAP 4
ROLL SWAP 4 ROLLD
REPL P 1 + 3
R ROLL REPL
END
>> BPNORM
END
BPORDDIF:
2 SWAP ^ DUP 0 SWAP NBPORD 1
<< + >> DOLIST SWAP DUP 1 + 2 /
* ->NUM - >>
BPORDLST:
0 0 0 << n BPORDDIF >> 'n' 3 7
ROLL 1 SEQ OBJ-> 3 + ->LIST
BPORDMUL:
BPORDLST DUP SIZE 4 SWAP SUB
2 << SWAP / >> DOSUBS OBJ-> 1
SWAP 2 ->LIST ->ARRY
BPTFUNC:
3 ROLLD BPSEQ BP2NUM SWAP
BPSEQ BP2NUM SWAP 3 ROLL EVAL
BASEP INBPTREE OBJ-> DROP SWAP
IF DUP THEN 1 - 2 SWAP ^ |
ELSE SWAP DROP END