From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Stefan Israelsson Tampe Newsgroups: gmane.lisp.guile.devel,gmane.lisp.guile.user Subject: Re: Fun with guile, Erastones + goldbach conjecture Date: Tue, 9 Apr 2013 12:24:29 +0200 Message-ID: References: <1551498.g80VkUsTQo@warperdoze> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=ISO-8859-1 X-Trace: ger.gmane.org 1365503080 32460 80.91.229.3 (9 Apr 2013 10:24:40 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 9 Apr 2013 10:24:40 +0000 (UTC) To: guile-devel , guile-user@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Apr 09 12:24:44 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1UPVjG-0000vC-NP for guile-devel@m.gmane.org; Tue, 09 Apr 2013 12:24:42 +0200 Original-Received: from localhost ([::1]:51187 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UPVjF-0001vY-VV for guile-devel@m.gmane.org; Tue, 09 Apr 2013 06:24:41 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:46893) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UPVj9-0001sK-Gl for guile-devel@gnu.org; Tue, 09 Apr 2013 06:24:37 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UPVj8-0006sY-Bg for guile-devel@gnu.org; Tue, 09 Apr 2013 06:24:35 -0400 Original-Received: from mail-pa0-f43.google.com ([209.85.220.43]:52843) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UPVj4-0006rg-TA; Tue, 09 Apr 2013 06:24:31 -0400 Original-Received: by mail-pa0-f43.google.com with SMTP id hz11so3762644pad.2 for ; Tue, 09 Apr 2013 03:24:29 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=mime-version:x-received:in-reply-to:references:date:message-id :subject:from:to:content-type; bh=H29MZwa8CyF9peXuHj+rOBKk5CU7ThhiUa6E9tinZIQ=; b=aeWdbj435WYDrrhnGuFAJI1h3jFWEX7pkvKL39rtF3DGnPMiqhzf+JDXQpHqMlxG6t 1/IpqVQX4ri14TzpuV03Ib9PI5Jb2kcpGBJClPAPQoItDPkdxQ5nDtq2p7cdQoPgxYHC asyIirQwPHK9XlfhJ9w2kSOhzL6/FRrsCQbiSwzvquo80Biu0bTKLlpVpKQt45P29uhu REOVM4JlIfOHT3x2uMq1S+ww2NVO4Iu4DYn3tjP2ksG7+z+ifu3yF5Pl0IMbwgGb7UK/ 31D3RQ95hnXGv0PVMPD8VEAR1Oxr2l4iDtSwU78wH3rnTWi6h5kQ3jK86qgUNxfZeFk8 1ojg== X-Received: by 10.66.144.69 with SMTP id sk5mr44458678pab.69.1365503069826; Tue, 09 Apr 2013 03:24:29 -0700 (PDT) Original-Received: by 10.70.22.5 with HTTP; Tue, 9 Apr 2013 03:24:29 -0700 (PDT) In-Reply-To: <1551498.g80VkUsTQo@warperdoze> X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [fuzzy] X-Received-From: 209.85.220.43 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:16203 gmane.lisp.guile.user:10253 Archived-At: 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 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)))))