From a89d6c82e981fec7d6e4c975e083d2b9e04467ad Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Mon, 1 May 2023 07:56:42 -0700 Subject: Rewrite most of the compiler. This represents a major step back in terms of functionality, and amount of code. The latter I think constitutes a major win. Next steps are to reimplement syntax-rules, call/cc, and call-with-values. --- lib/csc/map.scheme | 316 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 316 insertions(+) create mode 100644 lib/csc/map.scheme (limited to 'lib/csc/map.scheme') diff --git a/lib/csc/map.scheme b/lib/csc/map.scheme new file mode 100644 index 0000000..be27758 --- /dev/null +++ b/lib/csc/map.scheme @@ -0,0 +1,316 @@ +; Stolen with love from Haskell's Data.Map. +(define-library (csc map) + (export + delete + difference + empty + empty? + insert + intersect + list->map + lookup + map->list + map? + not-found-error? + singleton + union) + (import (scheme base) + (only (scheme case-lambda) case-lambda)) + (begin + + + (define-record-type + (make-map cmp root) + map? + (cmp map-cmp) + (root map-root)) + + + (define-record-type + (make-node size key val left right) + node? + (size node-size) + (key node-key) + (val node-val) + (left node-left) + (right node-right)) + + + (define-syntax match + (syntax-rules (node tip) + ((match n (tip case1 ...) ((node k x l r) case2 ...)) + (if n + (let ((k (node-key n)) + (x (node-val n)) + (l (node-left n)) + (r (node-right n))) + case2 ...) + (begin + case1 ...))) + ((match n ((node k x l r) body ...)) + (match n (tip (error "no match")) ((node k x l r) body ...))))) + + + (define (empty cmp) + (make-map cmp #f)) + + + (define (empty? m) + (not (map-root m))) + + + (define (singleton-node key val) + (make-node 1 key val #f #f)) + + + (define (singleton cmp key val) + (make-map cmp (singleton-node key val))) + + + (define (size n) + (if n + (node-size n) + 0)) + + + (define-record-type + (make-not-found-error) + not-found-error?) + + + (define *not-found-error* (make-not-found-error)) + + + (define lookup + (case-lambda + ((m k) + (let loop ((n (map-root m))) + (unless n + (raise *not-found-error*)) + (let ((ord ((map-cmp m) k (node-key n)))) + (cond + ((negative? ord) (loop (node-left n))) + ((positive? ord) (loop (node-right n))) + (else (node-val n)))))) + ((m k def) + (guard (err ((not-found-error? err) def)) + (lookup m k))))) + + + ; The bin constructor maintains the size of the tree. + (define (bin k x l r) + (make-node (+ (size l) (size r) 1) k x l r)) + + + ; https://hackage.haskell.org/package/containers-0.4.0.0/docs/src/Data-Map.html#delta + (define delta 4) + (define ratio 2) + + + ; This is where the magic happens... + (define (single-l k1 x1 t1 n) + (match n ((node k2 x2 t2 t3) + (bin k2 x2 (bin k1 x1 t1 t2) t3)))) + + + (define (single-r k1 x1 n t3) + (match n ((node k2 x2 t1 t2) + (bin k2 x2 t1 (bin k1 x1 t2 t3))))) + + + (define (double-l k1 x1 t1 n1) + (match n1 ((node k2 x2 n2 t4) + (match n2 ((node k3 x3 t2 t3) + (bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4))))))) + + + (define (double-r k1 x1 n1 t4) + (match n1 ((node k2 x2 t1 n2) + (match n2 ((node k3 x3 t2 t3) + (bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4))))))) + + + (define (rotate-l k x l r) + (if (< (size (node-left r)) (* ratio (size (node-right r)))) + (single-l k x l r) + (double-l k x l r))) + + + (define (rotate-r k x l r) + (if (< (size (node-right l)) (* ratio (size (node-left l)))) + (single-r k x l r) + (double-r k x l r))) + + + (define (balance k x l r) + (define size-l (size l)) + (define size-r (size r)) + (cond + ((<= (+ size-l size-r) 1) (bin k x l r)) + ((> size-r (* delta size-l)) (rotate-l k x l r)) + ((> size-l (* delta size-r)) (rotate-r k x l r)) + (else (bin k x l r)))) + + + (define (insert-max t kx x) + (match t + (tip (singleton-node kx x)) + ((node ky y l r) + (balance ky y l (insert-max r kx x))))) + + + (define (insert-min t kx x) + (match t + (tip (singleton-node kx x)) + ((node ky y l r) + (balance ky y (insert-min l kx x) r)))) + + + ; This is the "general purpose map function". All other map operations are + ; defined in terms of join. + ; https://www.cs.cmu.edu/~guyb/papers/BFS16.pdf + (define (join kx x l r) + (cond + ((not l) (insert-min r kx x)) + ((not r) (insert-max l kx x)) + (else + (match l ((node ky y ly ry) + (define size-l (node-size l)) + (match r ((node kz z lz rz) + (define size-r (node-size r)) + (cond + ((<= (* delta size-l) size-r) (balance kz z (join kx x l lz) rz)) + ((<= (* delta size-r) size-l) (balance ky y ly (join kx x ry r))) + (else (bin kx x l r)))))))))) + + + (define (split cmp t k) + (match t + (tip (values #f #f #f)) + ((node km m l r) + (define ord (cmp k km)) + (cond + ((zero? ord) (values l #t r)) + ((negative? ord) + (let-values (((ll b lr) (split cmp l k))) + (values ll b (join km m lr r)))) + (else + (let-values (((rl b rr) (split cmp r k))) + (values (join km m l rl) b rr))))))) + + + (define (split-last t) + (match t ((node kx x l r) + (if r + (let-values (((t2 kx2 x2) (split-last r))) + (values (join kx x l t2) kx2 x2)) + (values l kx x))))) + + + (define (join2 tl tr) + (if tl + (let-values (((tl2 kx x) (split-last tl))) + (join kx x tl2 tr)) + tr)) + + + (define (insert t kx x) + (define cmp (map-cmp t)) + (define-values (tl m tr) (split cmp (map-root t) kx)) + (make-map cmp (join kx x tl tr))) + + + (define (delete t k) + (define cmp (map-cmp t)) + (define-values (tl m tr) (split cmp (map-root t) k)) + (make-map cmp (join2 tl tr))) + + + (define (foldl f acc l) + (if (null? l) + acc + (foldl f (f acc (car l)) (cdr l)))) + + + (define (union-node cmp t1 t2) + (cond + ((not t1) t2) + ((not t2) t1) + (else + (match t2 ((node k2 x2 l2 r2) + (define-values (l1 b r1) (split cmp t1 k2)) + (define tl (union-node cmp l1 l2)) + (define tr (union-node cmp r1 r2)) + (join k2 x2 tl tr)))))) + + + (define (union m . ms) + (define cmp (map-cmp m)) + (make-map cmp + (foldl + (lambda (acc x) + (union-node cmp acc (map-root x))) + (map-root m) + ms))) + + + (define (intersect-node cmp t1 t2) + (cond + ((not (and t1 t2)) #f) + (else + (match t2 ((node k2 x2 l2 r2) + (define-values (l1 b r1) (split cmp t1 k2)) + (define tl (intersect-node cmp l1 l2)) + (define tr (intersect-node cmp r1 r2)) + (if b + (join k2 x2 tl tr) + (join2 tl tr))))))) + + + (define (intersect m . ms) + (define cmp (map-cmp m)) + (make-map cmp + (foldl + (lambda (acc x) + (intersect-node cmp acc (map-root x))) + (map-root m) + ms))) + + + (define (difference-node cmp t1 t2) + (and t1 + (match t2 + (tip t1) + ((node k2 x2 l2 r2) + (define-values (l1 b r1) (split cmp t1 k2)) + (define tl (difference-node cmp l1 l2)) + (define tr (difference-node cmp r1 r2)) + (join2 tl tr))))) + + + (define (difference m . ms) + (define cmp (map-cmp m)) + (make-map cmp + (foldl + (lambda (acc x) + (difference-node cmp acc (map-root x))) + (map-root m) + ms))) + + + (define (list->map cmp l) + (foldl + (lambda (acc x) + (insert acc (car x) (cdr x))) + (empty cmp) + l)) + + + (define (map->list m) + (let loop ((n (map-root m)) + (acc '())) + (match n + (tip acc) + ((node k v l r) + (loop l + (cons (cons k v) (loop r acc))))))))) -- cgit v1.3.1