[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Jul 18:
; sum of two integers

(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 (vector-sort! vec comp)
  (define-syntax while
    (syntax-rules ()
      ((while pred? body ...)
        (do () ((not pred?)) body ...))))
  (define-syntax assign!
    (syntax-rules ()
      ((assign! var expr)
        (begin (set! var expr) var))))

  (define len (vector-length vec))
  (define-syntax v (syntax-rules () ((v k) (vector-ref vec k))))
  (define-syntax v! (syntax-rules () ((v! k x) (vector-set! vec k x))))
  (define-syntax cmp (syntax-rules () ((cmp a b) (comp (v a) (v b)))))
  (define-syntax lt? (syntax-rules () ((lt? a b) (negative? (cmp a b)))))
  (define-syntax swap! (syntax-rules () ((swap! a b)
    (let ((t (v a))) (v! a (v b)) (v! b t)))))
  (define (vecswap! a b s)
    (do ((a a (+ a 1)) (b b (+ b 1)) (s s (- s 1))) ((zero? s))
      (swap! a b)))

  (define (med3 a b c)
    (if (lt? b c)
        (if (lt? b a) (if (lt? c a) c a) b)
        (if (lt? c a) (if (lt? b a) b a) c)))
  (define (pv-init a n)
    (let ((pm (+ a (quotient n 2))))
      (when (> n 7)
        (let ((pl a) (pn (+ a n -1)))
          (when (> n 40)
            (let ((s (quotient n 8)))
              (set! pl (med3 pl (+ pl s) (+ pl s s)))
              (set! pm (med3 (- pm s) pm (+ pm s)))
              (set! pn (med3 (- pn s s) (- pn s) pn))))
          (set! pm (med3 pl pm pn))))
      pm))

  (let qsort ((a 0) (n len))
    (if (< n 7)
        (do ((pm (+ a 1) (+ pm 1))) ((not (< pm (+ a n))))
          (do ((pl pm (- pl 1)))
              ((not (and (> pl a) (> (cmp (- pl 1) pl) 0))))
            (swap! pl (- pl 1))))
        (let ((pv (pv-init a n)) (r #f)
              (pa a) (pb a) (pc (+ a n -1)) (pd (+ a n -1)))
          (swap! a pv) (set! pv a)
          (let loop ()
            (while (and (<= pb pc) (<= (assign! r (cmp pb pv)) 0))
              (when (= r 0) (swap! pa pb) (set! pa (+ pa 1)))
              (set! pb (+ pb 1)))
            (while (and (>= pc pb) (>= (assign! r (cmp pc pv)) 0))
              (when (= r 0) (swap! pc pd) (set! pd (- pd 1)))
              (set! pc (- pc 1)))
            (unless (> pb pc)
              (swap! pb pc) (set! pb (+ pb 1)) (set! pc (- pc 1)) (loop)))
          (let ((pn (+ a n)))
            (let ((s (min (- pa a) (- pb pa)))) (vecswap! a (- pb s) s))
            (let ((s (min (- pd pc) (- pn pd 1)))) (vecswap! pb (- pn s) s))
            (let ((s (- pb pa))) (when (> s 1) (qsort a s)))
            (let ((s (- pd pc))) (when (> s 1) (qsort (- pn s) s))))))))

(define (twosum1 xs t)
  (let i-loop ((i 0))
    (if (= i (vector-length xs)) #f
      (let j-loop ((j (+ i 1)))
        (cond ((= j (vector-length xs)) (i-loop (+ i 1)))
              ((= (+ (vector-ref xs i) (vector-ref xs j)) t)
                (list (vector-ref xs i) (vector-ref xs j)))
              (else (j-loop (+ j 1))))))))

(define (cmp a b) (if (< a b) -1 (if (< b a) 1 0)))

(define (twosum2 xs t)
  (vector-sort! xs cmp)
  (let loop ((lo 0) (hi (- (vector-length xs) 1)))
    (cond ((= lo hi) #f)
          ((< (+ (vector-ref xs lo) (vector-ref xs hi)) t) (loop (+ lo 1) hi))
          ((< t (+ (vector-ref xs lo) (vector-ref xs hi))) (loop lo (- hi 1)))
          (else (list (vector-ref xs lo) (vector-ref xs hi))))))

(define (twosum3 xs t)
  (let ((hash (make-hash (lambda (x) x) = #f 997)))
    (let loop ((i 0))
      (if (= i (vector-length xs)) #f  
        (let* ((x (vector-ref xs i)) (t-x (- t x)))
            (if (hash 'lookup t-x) (list x t-x)
              (begin (hash 'insert x x) (loop (+ i 1)))))))))

(define array #(14 17 -3 49 -23 16 1))

(display (twosum1 array 63)) (newline)
(display (twosum1 array 42)) (newline)

(display (twosum2 array 63)) (newline)
(display (twosum2 array 42)) (newline)

(display (twosum3 array 63)) (newline)
(display (twosum3 array 42)) (newline)


Output:
1
2
3
4
5
6
(14 49)
#f
(14 49)
#f
(49 14)
#f


Create a new paste based on this one


Comments: