orangesquid (os) wrote,
orangesquid
os

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 >>

 

Tags: baseprime, math, primes
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