[ create a new paste ] login | about

Link: http://codepad.org/Y70sHPc0    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on May 23:
; coin change, part 3

(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 (hash x)
  (define (mod n) (modulo n 4294967296))
  (cond ((boolean? x) (if x 1 0))
        ((symbol? x) (hash (symbol->string x)))
        ((char? x) (char->integer x))
        ((integer? x) (mod x))
        ((real? x)
          (let* ((r (inexact->exact x))
                 (n (numerator r))
                 (d (denominator r)))
            (mod (+ n (* 37 d)))))
        ((rational? x) (mod (+ (numerator x) (* 37 (denominator x)))))
        ((complex? x)
          (mod (+ (hash (real-part x))
                  (* 37 (hash (imag-part x))))))
        ((null? x) 4294967295)
        ((pair? x)
          (let loop ((x x) (s 0))
            (if (null? x) s
              (loop (cdr x) (mod (+ (* 31 s) (hash (car x))))))))
        ((vector? x)
          (let loop ((i (- (vector-length x) 1)) (s 0))
            (if (negative? i) s
                (loop (- i 1) (mod (+ (* 31 s) (hash (vector-ref x i))))))))
        ((string? x)
          (let loop ((i (- (string-length x) 1)) (s 0))
            (if (negative? i) s
              (loop (- i 1) (mod (+ (* 31 s) (hash (string-ref x i))))))))
        ((procedure? x) (error 'hash "can't hash procedure"))
        ((port? x) (error 'hash "can't hash port"))
        (else (error 'hash "don't know how to hash object"))))

(define (make-matrix rows columns . value)
  (do ((m (make-vector rows)) (i 0 (+ i 1)))
      ((= i rows) m)
    (if (null? value)
        (vector-set! m i (make-vector columns))
        (vector-set! m i (make-vector columns (car value))))))

(define (matrix-ref m i j) (vector-ref (vector-ref m i) j))

(define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))

(define (fs n s)
  (if (or (<= n 0) (<= s 0)) (list)
    (append (if (= n s) (list (list n))
              (map (lambda (xs) (cons n xs))
                   (fs (- n 1) (- s n))))
            (fs (- n 1) s))))

(display (fs 10 10)) (newline)

(define (f n s)
  (if (or (<= s 0) (<= n 0)) 0
    (+ (if (= n s) 1
         (f (- n 1) (- s n)))
       (f (- n 1) s))))

(display (f 10 10)) (newline)

(time (display (f 100 100)) (newline))

(define-syntax define-memoized
  (syntax-rules ()
    ((_ (f args ...) body ...)
      (define f
        (let ((results (make-hash hash equal? #f 997)))
          (lambda (args ...)
            (let ((result (results 'lookup (list args ...))))
              (or result
                  (let ((result (begin body ...)))
                    (results 'insert (list args ...) result)
                    result)))))))))

(define-memoized (f n s)
  (if (or (<= s 0) (<= n 0)) 0
    (+ (if (= n s) 1
         (f (- n 1) (- s n)))
      (f (- n 1) s))))

(time (display (f 100 100)) (newline))

(define (f n s)
  (let ((fs (make-matrix (+ n 1) (+ s 1) 0)))
    (do ((i 1 (+ i 1))) ((< n i))
      (do ((j 1 (+ j 1))) ((< s j))
        (matrix-set! fs i j
          (+ (if (= i j)
                 1
                 (matrix-ref fs (- i 1) (max (- j i) 0)))
             (matrix-ref fs (- i 1) j)))))
    (matrix-ref fs n s)))

(time (display (f 100 100)) (newline))
(time (display (f 1000 1000)) (newline))


Output:
1
2
3
4
5
6
7
8
9
10
((10) (9 1) (8 2) (7 3) (7 2 1) (6 4) (6 3 1) (5 4 1) (5 3 2) (4 3 2 1))
10
444793
cpu time: 880 real time: 4847 gc time: 0
444793
cpu time: 40 real time: 194 gc time: 10
444793
cpu time: 0 real time: 7 gc time: 0
8635565795744155161506
cpu time: 340 real time: 1855 gc time: 30


Create a new paste based on this one


Comments: