From 56df584eed3a7228ca06a9ed1e49272410a7e671 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Sat, 23 Jul 2022 11:06:55 -0700 Subject: Add a delete method to the red-black tree. God damn delete is even more complicated than insert. I think it works, at least. --- csc/hash-map.csc | 291 ++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 233 insertions(+), 58 deletions(-) (limited to 'csc/hash-map.csc') diff --git a/csc/hash-map.csc b/csc/hash-map.csc index a8579fb..5a604ad 100644 --- a/csc/hash-map.csc +++ b/csc/hash-map.csc @@ -1,18 +1,22 @@ (define-library (csc hash-map) (export alist->map - map-for-each hash-bytevector insert key-not-found-error? lookup make-map + delete map->alist + map-for-each map? merge) (import (scheme base) - (only (csc format) sprintf) - (only (csc match) match)) + (only (csc match) + define-match-record-type + match) + (only (scheme case-lambda) + case-lambda)) (begin @@ -23,29 +27,17 @@ (hash key-hash-hash)) - (define (key-hash h1 h2) - #f) - (else - (cmp (key-hash-value k1) (key-hash-value k2))))) - - - (define (key-hash=? k1 k2 cmp) - (define v1 (key-hash-value k1)) - (define v2 (key-hash-value k2)) - (and (= (key-hash-hash k1) (key-hash-hash k2)) - (not (cmp v1 v2)) - (not (cmp v2 v1)))) + (define (cmp-key-hash k1 k2 cmp) + (define d (- (key-hash-hash k2) (key-hash-hash k1))) + (if (zero? d) + (cmp (key-hash-value k1) (key-hash-value k2)) + d)) - (define-record-type + (define-match-record-type (make-node color key-hash val left right) node? + %node (color node-color) (key-hash node-key) (val node-value) @@ -63,6 +55,21 @@ (eq? 'black (node-color n)))) + (define (node-kv n) + (cons (node-key n) (node-value n))) + + + (define (node-colored color kv left right) + (make-node color (car kv) (cdr kv) left right)) + + + (define (red-node kv left right) + (node-colored 'red kv left right)) + + (define (black-node kv left right) + (node-colored 'black kv left right)) + + (define (rebalance-left m) (define p (node-left m)) (define u (node-right m)) @@ -84,9 +91,9 @@ ; r r => b b ; \ \ ; r r - (make-node 'red (node-key m) (node-value m) - (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)) - (make-node 'black (node-key u) (node-value u) (node-left u) (node-right u)))) + (red-node (node-kv m) + (black-node (node-kv p) (node-left p) (node-right p)) + (black-node (node-kv u) (node-left u) (node-right u)))) ((and (red? p) (red? (node-right p)) (black? u)) @@ -163,19 +170,24 @@ (else m))) - (define (insert-node m k v cmp) - (cond ((null? m) (make-node 'red k v '() '())) - ((key-hash @@ -202,11 +214,11 @@ (define (insert m k v) - (let ((res (insert-node (map-root m) (make-key-hash k ((map-hash m) k)) v (map-cmp m)))) - (construct-map - (map-raw-hash m) - (map-cmp m) - (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res))))) + (define res (insert-node (map-root m) (make-key-hash k ((map-hash m) k)) v (map-cmp m))) + (construct-map + (map-raw-hash m) + (map-cmp m) + (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res)))) (define-record-type @@ -214,25 +226,38 @@ key-not-found-error?) - (define (lookup m k) - (letrec ((k* (make-key-hash k ((map-hash m) k))) - (lookup - (lambda (n) - (cond ((null? n) (raise (make-key-not-found-error))) - ((key-hashalist m) @@ -274,4 +299,154 @@ (m m)) (match m* ('() m) - ((head . tail) (loop tail (merge2 m head)))))))) + ((head . tail) (loop tail (merge2 m head)))))) + + + ; Jinkies! + (define (delete m k) + (define cmp (map-cmp m)) + (define k* (make-key-hash k ((map-hash m) k))) + ; local variables + (define need-fix #f) + (define replacement-node #f) + + (define (fix-black-height-left p) + ; n.b.: s must not be nil, because we deleted a black node and so + ; there must be at least one node in s to balance out the + ; black height. + (define s (node-right p)) + (define n (node-left p)) + (define c (node-left s)) + (define d (node-right s)) + (set! need-fix #f) + (cond + ((red? s) + ; p s + ; / \ / \ + ; n s => p d + ; / \ / \ + ; c d n c + (black-node (node-kv s) + (fix-black-height-left + (red-node (node-kv p) n c)) + d)) + ((red? d) + (node-colored (node-color p) (node-kv s) + (black-node (node-kv p) n c) + (black-node (node-kv d) (node-left d) (node-right d)))) + ((red? c) + (fix-black-height-left + (node-colored (node-color p) (node-kv p) + n + (black-node (node-kv c) + (node-left c) + (red-node (node-kv s) + (node-right c) + d))))) + ((red? p) + (black-node (node-kv p) + n + (red-node (node-kv s) c d))) + (else + (set! need-fix #t) ; This is the only recursive case. + (black-node (node-kv p) + n + (red-node (node-kv s) c d))))) + (define (fix-black-height-right p) + (define s (node-left p)) + (define n (node-right p)) + (define c (node-right s)) + (define d (node-left s)) + (set! need-fix #f) + (cond + ((red? s) + (black-node (node-kv s) + d + (fix-black-height-right + (red-node (node-kv p) c n)))) + ((red? d) + (node-colored (node-color p) (node-kv s) + (black-node (node-kv d) (node-left d) (node-right d)) + (black-node (node-kv p) c n))) + ((red? c) + ; p p + ; / \ / \ + ; s n => c n + ; / \ / + ; d c s + ; / + ; d + (fix-black-height-right + (node-colored (node-color p) (node-kv p) + (black-node (node-kv c) + (red-node (node-kv s) + d + (node-left c)) + (node-right c)) + n))) + ((red? p) + (black-node (node-kv p) + (red-node (node-kv s) d c) + n)) + (else + (set! need-fix #t) + (black-node (node-kv p) + (red-node (node-kv s) d c) + n)))) + (construct-map (map-raw-hash m) cmp + (let loop ((n (map-root m))) + (match n + ('() '()) + ((% %node color nk nv left right) + (define ord (cmp-key-hash k* nk cmp)) + (cond + ((negative? ord) + (let* ((left* (loop left)) + (n* (make-node color nk nv left* right))) + (if need-fix + (fix-black-height-left n*) + n*))) + ((positive? ord) + (let* ((right* (loop right)) + (n* (make-node color nk nv left right*))) + (if need-fix + (fix-black-height-right n*) + n*))) + ((and (not (null? left)) + (not (null? right))) + (let* ((left* (let find-max ((r left)) + (match r + ((% %node _ _ _ r-left '()) + (set! replacement-node r) + (cond + ((red? r) '()) + ((null? r-left) + (set! need-fix #t) + '()) + (else + (black-node (node-kv r-left) + (node-left r-left) + (node-right r-left))))) + ((% %node r-color r-k r-v r-left r-right) + (define n* (make-node r-color r-k r-v + r-left + (find-max r-right))) + (if need-fix + (fix-black-height-right n*) + n*))))) + (n* (node-colored color (node-kv replacement-node) left* right))) + (if need-fix + (fix-black-height-left n*) + n*))) + ((red? n) '()) + ((and (null? left) + (null? right)) + (set! need-fix #t) + '()) + (else + (let ((child (if (null? left) + right + left))) + (black-node (node-kv child) + (node-left child) + (node-right child)))))))))))) -- cgit v1.3.1