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
<address@hidden> 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)))))