[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Mar 28:
; subset sum, meet in the middle

(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)
                (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 (identity x) x)

(define (split xs)
  (let loop ((ts xs) (hs xs) (zs (list)))
    (if (or (null? hs) (null? (cdr hs)))
        (values (reverse zs) ts)
        (loop (cdr ts) (cddr hs) (cons (car ts) zs)))))

; original function
(define (subset-sum xs t)
  (let ((h (make-hash identity = #f 99991)))
    (let loop1 ((xs xs))
      (if (null? xs) #f
        (let loop2 ((ys (cons (cons 0 (list)) (h 'enlist))))
          (cond ((null? ys) (loop1 (cdr xs)))
                ((= (+ (car xs) (caar ys)) t)
                  (cons (car xs) (cdar ys)))
                (else (h 'insert (+ (car xs) (caar ys))
                                 (cons (car xs) (cdar ys)))
                      (loop2 (cdr ys)))))))))

; meet in the middle algorithm
(define (subset-sum-mitm xs t)
  (let-values (((f) (make-hash identity = #f 997))
               ((b) (make-hash identity = #f 997))
               ((front back) (split xs)))
    (let loop1 ((front front))
      (if (pair? front)
          (let loop2 ((ys (cons (cons 0 (list)) (f 'enlist))))
            (cond ((null? ys) (loop1 (cdr front)))
                  ((= (+ (car front) (caar ys)) t)
                    (cons (car front) (cdar ys)))
                  (else (f 'insert (+ (car front) (caar ys))
                                   (cons (car front) (cdar ys)))
                        (loop2 (cdr ys)))))
          (let loop3 ((back back))
            (if (null? back) #f
              (let loop4 ((ys (cons (cons 0 (list)) (b 'enlist))))
                (cond ((null? ys) (loop3 (cdr back)))
                      ((f 'lookup (- t (car back) (caar ys))) =>
                        (lambda (x)
                          (append (list (car back))
                                  (cdar ys) x)))
                      (else (b 'insert (+ (car back) (caar ys))
                                       (cons (car back) (cdar ys)))
                            (loop4 (cdr ys)))))))))))

(define ys '(267 439 869 961 1000 1153 1246 1598 1766 1922))

(time (display (subset-sum ys 5842)) (newline))

(time (display (subset-sum-mitm ys 5842)) (newline))

(1766 1246 1000 961 869)
cpu time: 40 real time: 269 gc time: 0
(1766 1246 1000 961 869)
cpu time: 0 real time: 3 gc time: 0

Create a new paste based on this one