[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/8rQnIhhP    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Nov 7:
; subset sums

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define (make-hash hash eql? oops size)
  (let ((table (make-vector size '())))
    (lambda (message . args)
      (if (eq? message 'enlist)
          (let loop ((k 0) (result '()))
            (if (= size k)
                result
                (loop (+ k 1) (append (vector-ref table k) result))))
          (let* ((key (car args))
                 (index (modulo (hash key) size))
                 (bucket (vector-ref table index)))
            (case message
              ((lookup fetch get ref recall)
                (let loop ((bucket bucket))
                  (cond ((null? bucket) oops)
                        ((eql? (caar bucket) key) (cdar bucket))
                        (else (loop (cdr bucket))))))
              ((insert insert! ins ins! set set! store store! install install!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (cadr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key (cadr args)) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((delete delete! del del! remove remove!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket) '())
                          ((eql? (caar bucket) key)
                            (cdr bucket))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((update update!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (caddr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              (else (error 'hash-table "unrecognized message")) ))))))

(define (primes n)
  (let* ((max-index (quotient (- n 3) 2))
         (v (make-vector (+ 1 max-index) #t)))
    (let loop ((i 0) (ps '(2)))
      (let ((p (+ i i 3)) (startj (+ (* 2 i i) (* 6 i) 3)))
        (cond ((>= (* p p) n)
               (let loop ((j i) (ps ps))
                  (cond ((> j max-index) (reverse ps))
                        ((vector-ref v j)
                          (loop (+ j 1) (cons (+ j j 3) ps)))
                        (else (loop (+ j 1) ps)))))
              ((vector-ref v i)
                (let loop ((j startj))
                  (if (<= j max-index)
                      (begin (vector-set! v j #f)
                             (loop (+ j p)))))
                      (loop (+ 1 i) (cons p ps)))
              (else (loop (+ 1 i) ps)))))))

(define example '(1 2 3 4 6))

(define challenge '(3 4 9 14 15 19 28 37 47
  50 54 56 59 61 70 73 78 81 92 95 97 99))

(define primes-two10 (primes (expt 2 10)))

; slow version

(define (subsets s)
  (if (null? s) (list ())
    (let ((rest (subsets (cdr s))))
      (append rest (map (lambda (x) (cons (car s) x)) rest)))))

(define (greplin3-slow s)
  (length
    (filter (lambda (x) (= (car x) (apply + (cdr x))))
      (map reverse
        (filter (lambda (x) (< 2 (length x)))
          (subsets s))))))

; fast version

(define ss #f)

(define (d k n)
  (cond ((negative? n) 0)
        ((negative? k) (if (zero? n) 1 0))
        (else (+ (d (- k 1) n)
                 (d (- k 1) (- n (list-ref ss k)))))))

(define (greplin3-fast s)
  (set! ss s)
  (let loop ((s s) (k 0) (c (- (length s))))
    (if (null? s) c
      (loop (cdr s) (+ k 1) (+ c (d k (car s)))))))

; memoized version

(define t #f)

(define (hash args) (+ (* (car args) 10000) (cadr args)))

(define (d-memo k n)
  (define (return k n v) (t 'insert! (list k n) v) v)
  (let ((prev (t 'lookup (list k n))))
    (cond (prev prev)
          ((negative? n) (return k n 0))
          ((negative? k) (return k n (if (zero? n) 1 0)))
          (else (return k n (+ (d-memo (- k 1) n)
            (d-memo (- k 1) (- n (list-ref ss k)))))))))

(define (greplin3-memo s)
  (set! ss s)
  (set! t (make-hash hash equal? #f 10000))
  (let loop ((s s) (k 0) (c (- (length s))))
    (if (null? s) c
      (loop (cdr s) (+ k 1) (+ c (d-memo k (car s)))))))

; tests

(display (greplin3-slow example)) (newline)
(display (greplin3-fast example)) (newline)
(display (greplin3-memo example)) (newline)
(display (greplin3-fast challenge)) (newline)
(display (greplin3-memo challenge)) (newline)
(display (greplin3-memo primes-two10)) (newline)


Output:
1
2
3
4
5
6
4
4
4
179
179
44586565247


Create a new paste based on this one


Comments: