Fun with guile, Erastones + goldbach conjecture

Fun with guile, Erastones + goldbach conjecture

[Stefan Israelsson Tampe]

[-- Attachment #1: Type: text/plain, Size: 1806 bytes --]

Hi all,

The program below is an interesting variant of a sieve that given an
even number seams to constructs two primes that added together becomes 
the even 
number, the file below does this construction for n = 3 ... 1000.

Have fun!

/Stefan


(use-modules (srfi srfi-1))

(define (analyze k)
  (define n (* k 2))
  (define l (apply circular-list (map (lambda (X) #f) (iota n))))
  (define (shift l k)
    (let loop ((l l) (k k))
      (if (= k 0) 
	  l
	  (loop (cdr l) (- k 1)))))

  (define (next loop)
    (let lp ((ll l) (i 0))
      (if (= i n)
	  l
	  (if (car ll)
	      (lp (cdr ll) (+ i 1))
	      (loop i l 0)))))
	  
  (define (M)
    (let lp ((l l) (k n) (M -1))
      (if (= k 0)
	  M
	  (let ((c (caar l)))
	    (if (< M c)
		(lp (cdr l) (- k 1) c)
		(lp (cdr l) (- k 1) M))))))

  (define (place x)
    (let loop ((ll l) (i 0))
      (if (equal? (car ll) x)
	  i
	  (loop (cdr ll) (+ i 1)))))
      
  (set-car! (cdr l) (cons 1 0))
  (set-car! (shift l (- n 1)) (cons 1 0))
  (let loop ((m 2) (ll l) (k 0))
    (let ((ll (shift ll m)))
      (if (and (pair? (car ll)) (eq? (caar ll) m))
	  (next loop)
	  (begin
	    (unless (car ll) (set-car! ll (cons m k)) (set! k (+ k 1)))
	    (loop m ll k)))))

  (let* ((M   (M))
	 (ll  (let lp ((ll l) (k n))
		(if (= k 0)
		    '()
		    (cons (car ll) (lp (cdr ll) (- k 1))))))
	 (ll  (fold (lambda (k r)(if (eq? (car k) M) (cons k r) r)) '() ll))
	 (ll  (sort ll (lambda (x y) (< (cdr x) (cdr y))))))

    (cond 
     ((= (length ll) 1)
      (* (place (car ll)) 2))
     (else
      (+ (place (car ll)) (place (car (last-pair ll))))))))
   
(let lp ((i 3))
  (if (= i 1000)
      (pk 'ok)
      (begin
	(if (not (= (* 2 i) (analyze i)))
	    (format #t "~a != (analyze ~a) == ~a~%" (* 2 i) (* 2 i) 
		    (analyze (* 2i))))
	(lp (+ i 1)))))

[-- Attachment #2: goldbach.scm --]
[-- Type: text/x-scheme, Size: 1560 bytes --]

(use-modules (srfi srfi-1))

(define (analyze k)
  (define n (* k 2))
  (define l (apply circular-list (map (lambda (X) #f) (iota n))))
  (define (shift l k)
    (let loop ((l l) (k k))
      (if (= k 0) 
	  l
	  (loop (cdr l) (- k 1)))))

  (define (next loop)
    (let lp ((ll l) (i 0))
      (if (= i n)
	  l
	  (if (car ll)
	      (lp (cdr ll) (+ i 1))
	      (loop i l 0)))))
	  
  (define (M)
    (let lp ((l l) (k n) (M -1))
      (if (= k 0)
	  M
	  (let ((c (caar l)))
	    (if (< M c)
		(lp (cdr l) (- k 1) c)
		(lp (cdr l) (- k 1) M))))))

  (define (place x)
    (let loop ((ll l) (i 0))
      (if (equal? (car ll) x)
	  i
	  (loop (cdr ll) (+ i 1)))))
      
  (set-car! (cdr l) (cons 1 0))
  (set-car! (shift l (- n 1)) (cons 1 0))
  (let loop ((m 2) (ll l) (k 0))
    (let ((ll (shift ll m)))
      (if (and (pair? (car ll)) (eq? (caar ll) m))
	  (next loop)
	  (begin
	    (unless (car ll) (set-car! ll (cons m k)) (set! k (+ k 1)))
	    (loop m ll k)))))

  (let* ((M   (M))
	 (ll  (let lp ((ll l) (k n))
		(if (= k 0)
		    '()
		    (cons (car ll) (lp (cdr ll) (- k 1))))))
	 (ll  (fold (lambda (k r)(if (eq? (car k) M) (cons k r) r)) '() ll))
	 (ll  (sort ll (lambda (x y) (< (cdr x) (cdr y))))))

    (cond 
     ((= (length ll) 1)
      (* (place (car ll)) 2))
     (else
      (+ (place (car ll)) (place (car (last-pair ll))))))))
   
(let lp ((i 3))
  (if (= i 1000)
      (pk 'ok)
      (begin
	(if (not (= (* 2 i) (analyze i)))
	    (format #t "~a != (analyze ~a) == ~a~%" (* 2 i) (* 2 i) 
		    (analyze (* 2i))))
	(lp (+ i 1)))))
  

Re: Fun with guile, Erastones + goldbach conjecture

[Stefan Israelsson Tampe]

Actually, inserting a primality check 500 out of 1000 items is nonprime.
but this algorithm still shows some interesting aspect and adding to the
algorithm to sellect the inner pair that sum to n, we do get primality for all
n = 3 ... 1000. Kind of cool.

-------------------------------------------------------
(use-modules (srfi srfi-1))
(use-modules (ice-9 pretty-print))
(define pp pretty-print)


(define (prim x)
  (let lp ((i 2))
    (if (<= i (/ x 2))
(if (= (modulo x i) 0)
   #f
   (lp (+ i 1)))
#t)))

(define prims (let loop ((i 2))
(if (< i 10000)
   (if (prim i)
(cons i (loop (+ i 1)))
(loop (+ i 1)))
   '())))

(define (factor x)
  (let lp ((ps prims))
    (if (< (car ps) (/ x 2))
(if (= (modulo x (car ps)) 0)
   (cons (car ps) (lp (cdr ps)))
   (lp (cdr ps)))
'())))

(define L3 '())

(define (analyze k)
  (define n (* k 2))
  (define l (apply circular-list (map (lambda (X) #f) (iota n))))
  (define (shift l k)
    (let loop ((l l) (k k))
      (if (= k 0)
          l
          (loop (cdr l) (- k 1)))))

  (define (next loop)
    (let lp ((ll l) (i 0))
      (if (= i n)
          l
          (if (car ll)
              (lp (cdr ll) (+ i 1))
              (loop i l 0)))))

  (define (M)
    (let lp ((l l) (k n) (M -1))
      (if (= k 1)
          M
          (let ((c (caar l)))
            (if (< M c)
                (lp (cdr l) (- k 1) c)
                (lp (cdr l) (- k 1) M))))))

  (define (place x)
    (let loop ((ll l) (i 0))
      (if (equal? (car ll) x)
          i
          (loop (cdr ll) (+ i 1)))))

  (define (splitx x M)
    (let lp1 ((xx x) (l '()) (r '()) (i 0))
      (if (pair? xx)
 (if (= (caar xx) M)
     (if (= (cadar xx) i)
 (lp1 (cdr xx) (cons (car xx) l) r (+ i 1))
 (lp1 (cdr xx) l r i))
     (lp1 (cdr xx) l r i))
 (if (null? l)
     (reverse r)
     (lp1 x '() (cons (reverse l) r) i)))))

  (define (inner l)
    (let ((n (length l)))
      (if (= (modulo n 2) 1)
 (list-ref l (/ (- n 1) 2))
 (append (list-ref l (- (/ n 2) 1))
 (list-ref l (- (/ n 2) 0))))))

  (define (shrink l)
    (let lp ((l (apply append l)) (i 0))
      (let ((a (list-ref (car l) 2)))
(if (and (null? (factor (- n a))) (null? (factor a)))
   a
   (if (< i (length l))
(lp (cdr l) (+ i 1))
(error "could not find conjecture I"))))))

  (define (thin l)
    (let lp ((l l) (r (reverse l)) (p -1))
      (if (pair? r)
 (let ((x (car r)))
   (let lp2 ((ll l))
     (if (pair? ll)
 (if (= (+ (list-ref (car ll) 2)
   (list-ref x 2))
n)
     (lp l (cdr r) (list-ref (car ll) 2))
     (lp2 (cdr ll)))
 p)))
 p)))

  (set-car! (cdr l)           (cons 1 0))
  (set-car! (shift l (- n 1)) (cons 1 1))

  (let loop ((m 2) (ll l) (k 1))
    (let ((ll (shift ll m)))
      (if (and (pair? (car ll))
      (eq? (caar ll) m))
          (next loop)
          (begin
            (unless (car ll) (set-car! ll (cons m k)) (set! k (+ k 1)))
            (loop m ll k)))))

  (let* ((M   (M))
         (l2  (let lp ((ll l) (k 0))
                (if (= k n)
                    '()
                    (cons (list (caar ll) (cdar ll) k)
 (lp (cdr ll) (+ k 1))))))
(l3  (splitx l2 M))
(ll  (inner l3))
         (ll  (fold (lambda (k r)(if (eq? (car k) M) (cons k r) r)) '() ll))
         (ll  (sort ll (lambda (x y) (< (cadr x) (cadr y))))))

    (set! l l2)
    (set! L3 l3)
    (thin ll)#;(place (car ll))))


(let lp ((i 3) (fail 0))
  (if (= i 1000)
      (pk `(,i ,fail))
      (let ((p (analyze i)))
(pk `(,i : ,p ,(- (* 2 i) p)))
(if (null? (factor (- (* 2 i) p)))
   (lp (+ i 1) fail)
   (begin
     (pp `(fail ,L3))
     (lp (+ i 1) (+ fail 1)))))))




On Tue, Apr 9, 2013 at 12:03 AM, Stefan Israelsson Tampe
<stefan.itampe@gmail.com> wrote:
> Hi all,
>
> The program below is an interesting variant of a sieve that given an
> even number seams to constructs two primes that added together becomes
> the even
> number, the file below does this construction for n = 3 ... 1000.
>
> Have fun!
>
> /Stefan
>
>
> (use-modules (srfi srfi-1))
>
> (define (analyze k)
>   (define n (* k 2))
>   (define l (apply circular-list (map (lambda (X) #f) (iota n))))
>   (define (shift l k)
>     (let loop ((l l) (k k))
>       (if (= k 0)
>           l
>           (loop (cdr l) (- k 1)))))
>
>   (define (next loop)
>     (let lp ((ll l) (i 0))
>       (if (= i n)
>           l
>           (if (car ll)
>               (lp (cdr ll) (+ i 1))
>               (loop i l 0)))))
>
>   (define (M)
>     (let lp ((l l) (k n) (M -1))
>       (if (= k 0)
>           M
>           (let ((c (caar l)))
>             (if (< M c)
>                 (lp (cdr l) (- k 1) c)
>                 (lp (cdr l) (- k 1) M))))))
>
>   (define (place x)
>     (let loop ((ll l) (i 0))
>       (if (equal? (car ll) x)
>           i
>           (loop (cdr ll) (+ i 1)))))
>
>   (set-car! (cdr l) (cons 1 0))
>   (set-car! (shift l (- n 1)) (cons 1 0))
>   (let loop ((m 2) (ll l) (k 0))
>     (let ((ll (shift ll m)))
>       (if (and (pair? (car ll)) (eq? (caar ll) m))
>           (next loop)
>           (begin
>             (unless (car ll) (set-car! ll (cons m k)) (set! k (+ k 1)))
>             (loop m ll k)))))
>
>   (let* ((M   (M))
>          (ll  (let lp ((ll l) (k n))
>                 (if (= k 0)
>                     '()
>                     (cons (car ll) (lp (cdr ll) (- k 1))))))
>          (ll  (fold (lambda (k r)(if (eq? (car k) M) (cons k r) r)) '() ll))
>          (ll  (sort ll (lambda (x y) (< (cdr x) (cdr y))))))
>
>     (cond
>      ((= (length ll) 1)
>       (* (place (car ll)) 2))
>      (else
>       (+ (place (car ll)) (place (car (last-pair ll))))))))
>
> (let lp ((i 3))
>   (if (= i 1000)
>       (pk 'ok)
>       (begin
>         (if (not (= (* 2 i) (analyze i)))
>             (format #t "~a != (analyze ~a) == ~a~%" (* 2 i) (* 2 i)
>                     (analyze (* 2i))))
>         (lp (+ i 1)))))

Re: Fun with guile, Erastones + goldbach conjecture

[Panicz Maciej Godek]

[-- Attachment #1: Type: text/plain, Size: 738 bytes --]

Hey,
I see that the style of your code is fairly unorthodox.
I'd suggest you to read the following chapters of SICP,
if you haven't already:
Section 3.5 (Streams), which introduces the notion
of streams, or lazy lists (that can be infinite), with the
most amazing example of Erastostenes' sieve
implementation, as well as sections 4.1 and 4.3 of
Chapter 4 (Metalinguistic abstraction). The first one
presents the notion of "meta-circular evaluator", which
is then used to implement "non-deterministic evaluator",
which allows to express certain problems extremely
elegantly. Simultaneously, the book shows many
examples of the finest programming style in Scheme.
I think you might find it quite entertaining and useful.

Best regards,
M.

[-- Attachment #2: Type: text/html, Size: 1446 bytes --]

Re: Fun with guile, Erastones + goldbach conjecture

[Ian Price]

Stefan Israelsson Tampe <stefan.itampe@gmail.com> writes:

> Hi all,
>
> The program below is an interesting variant of a sieve that given an
> even number seams to constructs two primes that added together becomes 
> the even 
> number, the file below does this construction for n = 3 ... 1000.

Amusing, but I feel that code like that needs a big massive disclaimer
at the top saying "CAUTION: DO NOT ACTUALLY WRITE SCHEME LIKE THIS".

Mutable circular lists? No thank you :)
Actually, I think you understand this yourself, since the circularity
infected all the procedures, and made them a little more complex than
they'd usually be.

For the newer Schemers, I've added a bunch of annotations.

> (use-modules (srfi srfi-1))
>
> (define (analyze k)
>   (define n (* k 2))
>   (define l (apply circular-list (map (lambda (X) #f) (iota n))))
Personally, I would move l down closer to where it is being mutated,
rather than having a bunch of procedures in the way.

>   (define (shift l k)
>     (let loop ((l l) (k k))
>       (if (= k 0) 
> 	  l
> 	  (loop (cdr l) (- k 1)))))
    (define shift drop)

>   (define (next loop)
>     (let lp ((ll l) (i 0))
>       (if (= i n)
> 	  l
> 	  (if (car ll)
> 	      (lp (cdr ll) (+ i 1))
> 	      (loop i l 0)))))
The continuation passing here is a bit weird, I would do two mutually
recursive procedures instead.

The additional state makes it harder to break into separate procedures,
but it feels to me like you should be able change this into a
drop-while.
> 	  
>   (define (M)
>     (let lp ((l l) (k n) (M -1))
>       (if (= k 0)
> 	  M
> 	  (let ((c (caar l)))
> 	    (if (< M c)
> 		(lp (cdr l) (- k 1) c)
> 		(lp (cdr l) (- k 1) M))))))
M was a terrible name. :)
I'd either suggest moving the if into the third clause of loop, or
rewriting this as

    (define (M)
      ;; maybe factor into procedure 'maximum-by'
      (fold-right (lambda (x prev) (max (car x) prev))
                  -1
                  (take l n)))

Yeah it allocates, but it was either that or write a foldr for
cyclic lists.

>   (define (place x)
>     (let loop ((ll l) (i 0))
>       (if (equal? (car ll) x)
> 	  i
> 	  (loop (cdr ll) (+ i 1)))))
    (define (place x)
      (list-index (lambda (y) (eqv? x y)) l))

>   (set-car! (cdr l) (cons 1 0))
>   (set-car! (shift l (- n 1)) (cons 1 0))
>   (let loop ((m 2) (ll l) (k 0))
>     (let ((ll (shift ll m)))
>       (if (and (pair? (car ll)) (eq? (caar ll) m))
> 	  (next loop)
> 	  (begin
> 	    (unless (car ll) (set-car! ll (cons m k)) (set! k (+ k 1)))
> 	    (loop m ll k)))))
Not quite sure what to make of this.

>   (let* ((M   (M))
> 	 (ll  (let lp ((ll l) (k n))
> 		(if (= k 0)
> 		    '()
> 		    (cons (car ll) (lp (cdr ll) (- k 1))))))
         (ll  (take l n))
> 	 (ll  (fold (lambda (k r)(if (eq? (car k) M) (cons k r) r)) '() ll))
         (ll  (filter (lambda (x) (eq? (car x) M)) ll))

Granted, that doesn't have the same ordering, but you are sorting the
result anyway.

> 	 (ll  (sort ll (lambda (x y) (< (cdr x) (cdr y))))))
>
>     (cond 
>      ((= (length ll) 1)
>       (* (place (car ll)) 2))
>      (else
>       (+ (place (car ll)) (place (car (last-pair ll))))))))
        (+ (place (car l1)) (place (last l1)))

For the purposes of your demonstration, it doesn't really matter, but it
would be a better idea to return those two values, rather than the sum.
Otherwise, analyze just becomes a very long-winded doubling function :)

> (let lp ((i 3))
>   (if (= i 1000)
>       (pk 'ok)
>       (begin
> 	(if (not (= (* 2 i) (analyze i)))
> 	    (format #t "~a != (analyze ~a) == ~a~%" (* 2 i) (* 2 i) 
> 		    (analyze (* 2i))))
btw, Typo here               ^^^^^^
> 	(lp (+ i 1)))))
>   

Maybe I'll meditate on this more, and post a "schemier" version.

-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"

Re: Fun with guile, Erastones + goldbach conjecture

[Ian Price]

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain; charset=iso-2022-jp-2, Size: 2229 bytes --]

Panicz Maciej Godek <godek.maciek@gmail.com> writes:

> Section 3.5 (Streams), which introduces the notion
> of streams, or lazy lists (that can be infinite), with the
> most amazing example of Erastostenes' sieve^[,A ^[(B
> implementation, as well as sections^[,A ^[(B4.1^[,A ^[(Band^[,A ^[(B4.3^[,A ^[(Bof

My pedant sense is tingling :P

Two concerns here.

First, lazy lists as presented in SICP are subject to off-by-1 coding
problems. You see it throughout the streams chapter, and in the
non-deterministic evaluator chapter by occasional smatterings of 'force'
and 'delay' about the place.  In the next release of Guile, we will have
an implementation of SRFI 41[0], which does not have these problems.

Secondly, that is not actually the sieve of Eratosthenes, but Trial
Division.  Melissa E. O'Neill has a lovely paper about this[1], giving
performances analyses of both.

And before you object to me calling SICP's sieve ^[$B!H^[(Bfake^[$B!I^[(B...
^[$B!H^[(BSome readers may feel that despite all of these concerns, the earlier
algorithm is somehow ^[$B!H^[(Bmorally^[$B!I^[(B the Sieve of Eratosthenes. I would
argue, however, that they are confusing a mathematical abstraction drawn
from the Sieve of Eratosthenes with the actual algorithm. The
algorithmic details, such as how you remove all the multiples of 17,
matter.^[$B!I^[(B

I have an implementation of the genuine sieve available[2], that you
will be able to run when the next release comes out. (Needs pfds).

Okay, pedant sense sufficiently exercised for now.

SICP is a fine book IMO, but it isn't perfect. Section 3 is not
fantastic, for a variety of reasons, and I feel people are better served
learning recursion on recursive data structures (like lists or trees),
rather than the way SICP does with numbers (yes, the naturals are
recursive, but many of the algorithms, like fast-exponentiation, rely on
recursion other than on the predecessor).

0. http://srfi.schemers.org/srfi-41/srfi-41.html
1. http://www.cs.hmc.edu/~oneill/papers/Sieve-JFP.pdf
2. https://github.com/ijp/ijputils/blob/master/streams.sls#L73
-- 
Ian Price -- shift-reset.com

"Programming is like pinball. The reward for doing it well is
the opportunity to do it again" - from "The Wizardy Compiled"