Data commit

Task/Hamming-numbers/Scheme/hamming-numbers-1.ss

@@ -0,0 +1,48 @@
+(define-syntax lons
+  (syntax-rules ()
+    ((_ lar ldr) (delay (cons lar (delay ldr))))))
+
+(define (lar lons)
+  (car (force lons)))
+
+(define (ldr lons)
+  (force (cdr (force lons))))
+
+(define (lap proc . llists)
+  (lons (apply proc (map lar llists)) (apply lap proc (map ldr llists))))
+
+(define (take n llist)
+  (if (zero? n)
+      (list)
+      (cons (lar llist) (take (- n 1) (ldr llist)))))
+
+(define (llist-ref n llist)
+  (if (= n 1)
+      (lar llist)
+      (llist-ref (- n 1) (ldr llist))))
+
+(define (merge llist-1 . llists)
+  (define (merge-2 llist-1 llist-2)
+    (cond ((null? llist-1) llist-2)
+          ((null? llist-2) llist-1)
+          ((< (lar llist-1) (lar llist-2))
+           (lons (lar llist-1) (merge-2 (ldr llist-1) llist-2)))
+          ((> (lar llist-1) (lar llist-2))
+           (lons (lar llist-2) (merge-2 llist-1 (ldr llist-2))))
+          (else (lons (lar llist-1) (merge-2 (ldr llist-1) (ldr llist-2))))))
+  (if (null? llists)
+      llist-1
+      (apply merge (cons (merge-2 llist-1 (car llists)) (cdr llists)))))
+
+(define hamming
+  (lons 1
+        (merge (lap (lambda (x) (* x 2)) hamming)
+               (lap (lambda (x) (* x 3)) hamming)
+               (lap (lambda (x) (* x 5)) hamming))))
+
+(display (take 20 hamming))
+(newline)
+(display (llist-ref 1691 hamming))
+(newline)
+(display (llist-ref 1000000 hamming))
+(newline)

Task/Hamming-numbers/Scheme/hamming-numbers-2.ss

@@ -0,0 +1,25 @@
+(define (hamming)
+  (define (foldl f z l)
+    (define (foldls zs ls)
+      (if (null? ls) zs (foldls (f zs (car ls)) (cdr ls))))
+    (foldls z l))
+  (define (merge a b)
+    (if (null? a) b
+      (let ((x (car a)) (y (car b)))
+        (if (< x y) (cons x (delay (merge (force (cdr a)) b)))
+                    (cons y (delay (merge a (force (cdr b)))))))))
+  (define (smult m s) (cons (* m (car s)) ;; equiv to map (* m) s; faster
+             (delay (smult m (force (cdr s))))))
+  (define (u s n) (letrec ((a (merge s (smult n (cons 1 (delay a)))))) a))
+  (cons 1 (delay (foldl u '() '(5 3 2)))))
+
+;;; test...
+(define (stream-take->list n strm)
+  (if (= n 0) (list) (cons (car strm)
+    (stream-take->list (- n 1) (force (cdr strm))))))
+(define (stream-ref strm nth)
+  (do ((nxt strm (force (cdr nxt))) (cnt 0 (+ cnt 1)))
+      ((>= cnt nth) (car nxt))))
+(display (stream-take->list 20 (hamming))) (newline)
+(display (stream-ref (hamming) (- 1691 1))) (newline)
+(display (stream-ref (hamming) (- 1000000 1))) (newline)