Performance issue regarding Project Euler #60 in Scheme

Question

I solved Project Euler #60:

The primes 3, 7, 109, and 673, are quite remarkable. By taking any two primes and concatenating them in any order the result will always be prime. For example, taking 7 and 109, both 7109 and 1097 are prime. The sum of these four primes, 792, represents the lowest sum for a set of four primes with this property.

Find the lowest sum for a set of five primes for which any two primes concatenate to produce another prime.

in Scheme.

Considering primes under 10000, it takes 21 second to find the correct prime set and about 12 minutes to traverse the rest of the combinations (which don’t include other prime sets that satisfy the constraint).

I found a Haskell code that implements the same logic here.

The code found there and the one implemented by myself uses a very simple brute-force strategy: Search a pair that satisfies the constraint, and if it does, search for another prime to form a triple that satisfies the constraint, and if it does not, discard the triple, and so on.

This is not the smartest algorithm out there (this can be solved by search for 5-cliques in a graph), so I don’t expect it to run very fast. However, the Haskell version takes half a second to find the first solution, and takes another 15 seconds to traverse other prime sets that actually don’t include other satisfying sets. (Note that the code linked above halts after finding the first prime set. I modified the main function to print all candidates: main = print $ candidates.)

I demonstrate my Scheme code below:

I used a custom stream implementation to generate primes. For reference, I put the relevant part of the module here:

(define-library (stream)
 (export cons-stream stream-car stream-cdr stream-null? the-empty-stream
 stream-filter stream-take stream-take-while
 integers-starting-from
 prime-stream prime?)
 (import (scheme base)
 (scheme lazy))
 (begin
 (define-syntax cons-stream
 (syntax-rules ()
 ((_ a b)
 (cons a (delay b)))))
 (define (stream-car stream)
 (car stream))
 (define (stream-cdr stream)
 (force (cdr stream)))
 (define (stream-null? stream)
 (null? stream))
 (define the-empty-stream '())
 (define (stream-filter pred s)
 (cond ((stream-null? s) the-empty-stream)
 ((pred (stream-car s))
 (cons-stream
 (stream-car s)
 (stream-filter pred (stream-cdr s))))
 (else
 (stream-filter pred (stream-cdr s)))))
 (define (stream-take-while pred s)
 (if (or (stream-null? s)
 (not (pred (stream-car s))))
 '()
 (cons (stream-car s)
 (stream-take-while pred (stream-cdr s)))))
 (define (integers-starting-from n)
 (cons-stream
 n
 (integers-starting-from (+ n 1))))
 (define (divisible? n q)
 (zero? (remainder n q)))
 (define prime-stream
 (cons-stream
 2
 (stream-filter prime?
 (integers-starting-from 3))))
 (define (prime? n)
 (let loop ((ps prime-stream))
 (cond ((< n (square (stream-car ps)))
 #t)
 ((divisible? n (stream-car ps))
 #f)
 (else
 (loop (stream-cdr ps))))))))

In short, primes and prime? given above incrementally generates new prime numbers using a stream. The stream module follows the definitions given in SICP.

I imported the above stream module and SRFI-1 (for procedures like drop-while):

(import (except srfi-1 concatenate)
 stream)
(define (concatenate n m)
 (define (count-digits n)
 (if (= n 0)
 0
 (+ 1 (count-digits (quotient n 10)))))
 (+ m
 (* n (expt 10 (count-digits m)))))
(define (check p . rest)
 (if (null? rest)
 #t
 (let ((l-concat
 (map (lambda (q) (concatenate p q))
 rest))
 (r-concat
 (map (lambda (q) (concatenate q p))
 rest)))
 (and (every prime? l-concat)
 (every prime? r-concat)))))
(define primes
 (stream-take-while (lambda (p) (< p 10000))
 prime-stream))

Note that I just took out primes as a list primes that are less than 10000.

(concatenate n m) concatenates n and m, e.g., (concatenate 123 456) -> 123456 (It is not the one in SRFI-1.). (check p . rest) checks if p satisfies the constraint concatenated with other primes in rest. Prime set rest is assumed to already satisfy the constraint.

I now present two implementations, one with nested flatmaps, and the other using SRFI-42 (eager comprehension), for a Haskell-like list comprehension. The two implementations show very little (< 1s) performance difference, so the later is just for syntactic clarity.

The first one:

(define (flatmap proc lst)
 (if (null? lst)
 '()
 (foldr append '() (map proc lst))))
 (define satisfying-tuples
 (flatmap
 (lambda (p)
 (flatmap
 (lambda (q)
 (flatmap
 (lambda (r)
 (flatmap
 (lambda (s)
 (map (lambda (t) (let ((satisfying (list p q r s t)))
 (display "Found (p q r s t), sum: ")
 (display satisfying)
 (display #,円)
 (display (+ p q r s t))
 (newline)
 satisfying))
 (filter
 (lambda (t) (check t s r q p))
 (drop-while (lambda (t) (<= t s)) primes))))
 (filter
 (lambda (s) (check s r q p))
 (drop-while (lambda (s) (<= s r)) primes))))
 (filter
 (lambda (r) (check r q p))
 (drop-while (lambda (r) (<= r q)) primes))))
 (filter
 (lambda (q) (check q p))
 (drop-while (lambda (q) (<= q p)) primes))))
 primes))
 (display satisfying-tuples)
 (newline)

The second one using eager comprehension:

; Should (import srfi-42) as well
(define satisfying-tuples-2
 (list-ec (:list p primes)
 (:list q primes)
 (if (and (> q p)
 (check q p)))
 (:list r primes)
 (if (and (> r q)
 (check r q p)))
 (:list s primes)
 (if (and (> s r)
 (check s r q p)))
 (:list t primes)
 (if (and (> t s)
 (check t s r q p)))
 (begin
 (let ((satisfying (list p q r s t)))
 (display "Found (p q r s t), sum: ")
 (display satisfying)
 (display #,円)
 (display (+ p q r s t))
 (newline)))
 (list p q r s t)))
(display satisfying-tuples-2)
(newline)

The second version emphasizes the similarity with the Haskell version, yet it shows almost 50 times performance difference.

Is this just a classic example of

A LISP programmer knows the value of everything, but the cost of nothing.

, or is there a room for improvement in my code? I’m using Chicken Scheme, and I compiled my code with csc -R r7rs my-code.scm.

Here is a link to my stream library and to the complete code.