orangesquid (os) wrote,
orangesquid
os

all the code.. i had missed a few things, mostly rpl


*** basep-gen ***
#!/bin/bash
echo "" echo " " echo " " echo " " echo " " 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=$(( $x + 1 )) done echo "
base-10factorizationbase-P
$x$f$b
"

*** 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
Subscribe
  • Post a new comment

    Error

    default userpic

    Your IP address will be recorded 

    When you submit the form an invisible reCAPTCHA check will be performed.
    You must follow the Privacy Policy and Google Terms of use.
  • 0 comments