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

    Error

    default userpic

    Your IP address will be recorded 

  • 0 comments