Project EulerにGaucheで挑戦する話 ref: http://qiita.com/items/7c7bd54747676e3f1fb1

euler.scm

(use srfi-1)
(use util.combinations)
(use gauche.uvector)

(define pi 3.141592653589793238462643383279)
(define phi (/ (+ 1 (sqrt 5)) 2))

(define *log2* (log 2))
(define *log10* (log 10))

(define (log2 x) (/ (log x) *log2*))
(define (log10 x) (/ (log x) *log10*))

;(use math.mt-random)
;(define *mt* (make <mersenne-twister> :seed (sys-time)))
;(define (rand100) (mt-random-integer *mt* 100))

#|
VECTOR
|#

(define (vector-inc! v ref d)
  (vector-set! v ref (+ (vector-ref v ref) d)))

#|
MATH
|#

(define (divisible? x y) (zero? (remainder x y)))
(define (sum lis) (apply + lis))
(define (prod lis) (apply * lis))
(define (square x) (* x x))
(define (cube x) (* x x x))

(define (sqrt-floor x) (floor->exact (sqrt x)))
(define (squared? n) (let1 sq (sqrt-floor n) (= n (* sq sq))))

(define (digits base n)
  (if (= n 0) (list 0)
      (let loop ((n n) (s '()))
        (if (= n 0) (reverse! s)
            (receive (q r) (quotient&remainder n base)
              (loop q (cons r s)))))))

#|
COMBINATIONS
|#

(define (C n k)
  (let loop ((x 1) (n n) (k (min k (- n k))))
    (if (= k 0) x
        (loop (/ (* x n) k) (- n 1) (- k 1)))))

(define (xrange a b) (iota (- b a -1) a))

#|
PRIMES
;(define primes '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79))

;(define primes (do-sieve 2500000)) ; 10sec for 25000000
;(print (length primes))
|#

(define sieve #())
(define (prime? n) (vector-ref sieve n))

(define (_prime? n primes)
  (let loop ((ps primes))
    (if (null? ps) #t
        (if (divisible? n (car ps)) #f
            (loop (cdr ps))))))

(define (do-sieve M)
  (define (elim n)
    (let loop ((i (* n 2)))
      (if (<= i M)
          (begin
            ;(s32vector-set! sieve i 1)
            (vector-set! sieve i #f)
            (loop (+ i n)))
          #t)))

  (set! sieve (make-vector (+ M 1) #t))

  (display "do sieve 2..") (flush)
  (vector-set! sieve 0 #f)
  (vector-set! sieve 1 #f)
  (elim 2)
  (let loop ((n 3) (ps (list 2)))
    (if (<= n M)
        (loop (+ n 2)
              (if (prime? n)
                  (begin
                    (elim n)
                    (cons n ps))
                  ps))
        (begin
          (print "M. done.")
          (reverse! ps)))))

(define (prime-factors->divisors pf) ;; '(2 1 1) -> 
  (define (pfs p n) ; --> (p^n p^(n-1) ... p^2 p 1)
    (let loop ((i 0) (p^i 1) (ls '()))
      (if (> i n) ls
          (loop (+ i 1) (* p^i p) (cons p^i ls)))))
  (let loop ((pf pf) (ps primes) (ls '()))
    (if (null? pf)
        (map (cut apply * <>) (cartesian-product ls))
        (loop (cdr pf) (cdr ps)
              (if (zero? (car pf)) ls
                  (cons (pfs (car ps) (car pf)) ls) )))))

(define (prime-factors n)
  (let lp1 ((n n) (ps primes) (ls '()))
    (if (= 1 n) (reverse! ls)
        (let1 p (car ps)
          (let lp2 ((n n) (i 0))
            (if (divisible? n p)
                (lp2 (/ n p) (+ i 1))
                (lp1 n (cdr ps) (cons i ls))))))))

(define (pf-nums pf)
  ;(filter identity (map (lambda (p) (if (zero? (car p)) #f (cadr p))) (zip pf primes))))
  (let loop ((pf pf) (ps primes) (ls '()))
    (if (null? pf) (reverse! ls)
        (loop (cdr pf) (cdr ps) 
              (if (zero? (car pf)) ls (cons (car ps) ls))))))

(define (pf-test n)
  (let1 pf (prime-factors n)
    (print "prime factors of " n " = " (pf-nums pf))
    (print "divisors of " n " = " (sort (prime-factors->divisors pf)))))

(define (pf-merge pf1 pf2)
  (let loop ((pf1 pf1) (pf2 pf2) (pf '()))
    (cond [(null? pf1) (append (reverse! pf) pf2)]
          [(null? pf2) (append (reverse! pf) pf1)]
          [else (loop (cdr pf1) (cdr pf2) (cons (+ (car pf1) (car pf2)) pf))])))

(define (next-prime n)
  (let loop ((x (+ n 1)))
    (if (even? x) (loop (+ x 1))
        (let1 sq (sqrt-floor x)
          (let lp ((ps primes))
            (if (null? ps) x
                (let1 p (car ps)
;             (if (> p sq) x
                  (if (divisible? x p) (loop (+ x 2))
                      (lp (cdr ps))))))))))

(define (totient k)
  (let loop ((x k) (pfn (pf-nums (prime-factors k))))
    (if (null? pfn) x
        (loop (* x (- 1 (/ (car pfn)))) (cdr pfn)))))

#|
FIBONACCI
|#

#;(define fib-ht (make-hash-table 'eq?))
#;(define (fib n)
  (cond [(= n 1) 1]
        [(= n 2) 2]
        [else
         (or (hash-table-get fib-ht n #f)
             (let1 val (+ (fib (- n 1))
                          (fib (- n 2)))
               (hash-table-put! fib-ht n val)
               val)) 
         ]))

;; USING MATRIX
(define (fib n)
  (define (M x) (remainder x 1234567891011))

  (define (A* A B)
    (cons (cons (M (+ (* (caar A) (caar B))
                      (* (cdar A) (cadr B))))
                (M (+ (* (caar A) (cdar B))
                      (* (cdar A) (cddr B)))))
          (cons (M (+ (* (cadr A) (caar B))
                      (* (cddr A) (cadr B))))
                (M (+ (* (cadr A) (cdar B))
                      (* (cddr A) (cddr B)))))))
  (define (A** A) (A* A A))

  (define A-ht (make-hash-table 'eq?))
  (define A1 (cons (cons 1 1) (cons 1 0)))
  (define (An n)
    (if (= n 1) A1 ;; aa da ad dd
        (or (hash-table-get A-ht n #f)
            (let1 v (if (even? n)
                        (A** (An (/ n 2)))
                        (A* (An (- n 1)) A1))
              ;(format #t "(An ~d)..\n" n)
              (hash-table-put! A-ht n v)
              v))))

  (if (= n 0) 0
      (M (cdar (An n)))))

#|
PYTHAGOREAN
|#

(define (make-base-pythagoreans upper)
  (define (py3 a b c)
    (define (U a b c)
      (list (+ (* a 1) (* b -2) (* c 2))
            (+ (* a 2) (* b -1) (* c 2))
            (+ (* a 2) (* b -2) (* c 3))))
    (define (A a b c)
      (list (+ (* a 1) (* b 2) (* c 2))
            (+ (* a 2) (* b 1) (* c 2))
            (+ (* a 2) (* b 2) (* c 3))))
    (define (D a b c)
      (list (+ (* a -1) (* b 2) (* c 2))
            (+ (* a -2) (* b 1) (* c 2))
            (+ (* a -2) (* b 2) (* c 3))))
    (values (U a b c) (A a b c) (D a b c)))

  (let1 pythagoreans (make-hash-table 'equal?)
    (let loop ((q '((3 4 5))))
      (if (null? q) pythagoreans
          (let1 tr (car q)
            (if (every (cut <= <> upper) tr)
                (begin
                  (hash-table-put! pythagoreans tr #t)
                  (receive (u a d) (apply py3 tr)
                    (loop (cons* u a d (cdr q)))))
                (loop (cdr q))))))))

#|
SIMPLE MEMOIZATION
|#

(define (memoize fn cmp)
  (let1 memo (make-hash-table cmp)
    (lambda (arg)
      (or (hash-table-get memo arg #f)
          (let1 value (fn arg)
            (hash-table-put! memo arg value)
            value)))))

loop.scm

(let loop ((l lis) (i 0))
  . . .
  )