Hp49g+ and scheme droid
Background
;; 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 >>
;; 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 >>