├── .gitignore ├── README.md ├── doc └── intro.md ├── project.clj ├── src └── purely_functional_data_structures │ ├── ch2.clj │ └── ch3.clj └── test └── purely_functional_data_structures ├── ch2_test.clj └── ch3_test.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | pom.xml 6 | *.jar 7 | *.class 8 | .lein-deps-sum 9 | .lein-failures 10 | .lein-plugins 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purely-functional-data-structures 2 | 3 | Clojure versions of the code and solutions from the book [Purely Functional Data Structures](http://amzn.to/UcIidh). 4 | 5 | If you'd like to read the posts I published about the code, visit the [series on my blog](http://www.leonardoborges.com/writings/tags/functional-data-structures/). 6 | 7 | 8 | 9 | ## License 10 | 11 | Copyright © 2012 [Leonardo Borges](http://www.leonardoborges.com) 12 | 13 | Distributed under the Eclipse Public License, the same as Clojure. 14 | -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to purely-functional-data-structures 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) 4 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject purely-functional-data-structures "0.1.0-SNAPSHOT" 2 | :description "FIXME: write description" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.5.1"] 7 | [org.clojure/core.match "0.2.0-rc3"]]) 8 | -------------------------------------------------------------------------------- /src/purely_functional_data_structures/ch2.clj: -------------------------------------------------------------------------------- 1 | (ns purely-functional-data-structures.ch2) 2 | 3 | ;; 4 | ;;Chapter 2 - Persistence 5 | ;; 6 | 7 | (defn ++ [xs ys] 8 | (if (seq xs) 9 | (cons (first xs) (++ (rest xs) ys)) 10 | ys)) 11 | 12 | 13 | (defn update [xs idx val] 14 | (if (= 0 idx) 15 | (cons val (rest xs)) 16 | (cons (first xs) (update (rest xs) (dec idx) val)))) 17 | 18 | ;; 19 | ;; Excercise 2.1 20 | ;; 21 | 22 | (defn suffixes [xs] 23 | (if (seq xs) 24 | (cons xs (suffixes (rest xs))) 25 | (conj [] xs))) 26 | 27 | ;; 28 | ;; Binary search tree 29 | ;; 30 | 31 | (defn mk-tree [l v r] 32 | {:left l :val v :right r}) 33 | 34 | (defn is-member? [tree value] 35 | (if-let [member (:val tree)] 36 | (cond 37 | (< value member) (recur (:left tree) value) 38 | (> value member) (recur (:right tree) value) 39 | :else true) 40 | false)) 41 | 42 | 43 | (defn insert [tree value] 44 | (if-let [member (:val tree)] 45 | (cond 46 | (< value member) (mk-tree 47 | (insert (:left tree) value) member (:right tree)) 48 | (> value member) (mk-tree (:left tree) member (insert (:right tree) value)) 49 | :else tree) 50 | (mk-tree nil value nil))) 51 | 52 | ;; 53 | ;; Excercise 2.2 54 | ;; 55 | 56 | (defn insert [tree value] 57 | (if-let [member (:val tree)] 58 | (cond 59 | (< value member) (mk-tree 60 | (insert (:left tree) value) member (:right tree)) 61 | (> value member) (mk-tree (:left tree) member (insert (:right tree) value)) 62 | :else (throw (Exception. "Element already in tree"))) 63 | (mk-tree nil value nil))) 64 | 65 | 66 | (defn insert* [tree value] 67 | (try (insert tree value) 68 | (catch Exception e 69 | (do (prn "Element already in tree. Halting and returning root") 70 | tree)))) 71 | 72 | 73 | ;;(insert* (insert* my-tree 2) 2) 74 | ;; "Element already in tree. Halting and returning root" -------------------------------------------------------------------------------- /src/purely_functional_data_structures/ch3.clj: -------------------------------------------------------------------------------- 1 | (ns purely-functional-data-structures.ch3 2 | (:refer-clojure :exclude [merge]) 3 | (:use [clojure.core.match :only (match)] 4 | [clojure.pprint :only (pprint)])) 5 | 6 | 7 | ;; 8 | ;; Chapter 3 - Familiar Data Structures in a Functional Setting 9 | ;; 10 | 11 | 12 | ;; 13 | ;; Leftist heaps 14 | ;; 15 | 16 | ;; 17 | ;; Using protocols 18 | ;; 19 | 20 | 21 | (defprotocol Heap 22 | (is-empty? [this]) 23 | (insert [this v]) 24 | (merge [this other]) 25 | (rank [this]) 26 | (find-min [this]) 27 | (delete-min [this])) 28 | 29 | (defrecord LeftistHeap [rank value left right]) 30 | 31 | (defn ensure-leftist 32 | [this other v] 33 | (let [rank-this (rank this) 34 | rank-other (rank other)] 35 | (if (>= rank-this rank-other) 36 | (->LeftistHeap (inc rank-other) v this other) 37 | (->LeftistHeap (inc rank-this) v other this)))) 38 | 39 | (extend-protocol Heap 40 | nil 41 | (rank [_] 0) 42 | (merge [_ other] other) 43 | (is-empty? [_] true) 44 | 45 | LeftistHeap 46 | (is-empty? [this] 47 | (nil? this)) 48 | 49 | (rank [this] 50 | (:rank this)) 51 | 52 | (merge [{val-this :value left-this :left right-this :right :as this} 53 | {val-other :value left-other :left right-other :right :as other}] 54 | (cond 55 | (is-empty? other) this 56 | (<= val-this val-other) (ensure-leftist left-this 57 | (merge right-this other) 58 | val-this) 59 | :else (ensure-leftist left-other 60 | (merge this right-other) 61 | val-other))) 62 | 63 | (insert [this v] 64 | (merge (->LeftistHeap 1 v nil nil) 65 | this)) 66 | 67 | (find-min [{v :value}] v) 68 | 69 | (delete-min [{left :left right :right}] 70 | (merge right left))) 71 | 72 | 73 | ;; 74 | ;; Using pure functions and maps 75 | ;; 76 | 77 | 78 | (defn mk-heap [rank value left right] 79 | {:rank rank :value value :left left :right right}) 80 | 81 | (defn heap-rank [heap] 82 | (if (nil? heap) 83 | 0 84 | (:rank heap))) 85 | 86 | (defn ensure-leftist-heap [value heap-a heap-b] 87 | (let [rank-a (heap-rank heap-a) 88 | rank-b (heap-rank heap-b)] 89 | (if (>= rank-a rank-b) 90 | (mk-heap (inc rank-b) value heap-a heap-b) 91 | (mk-heap (inc rank-a) value heap-b heap-a)))) 92 | 93 | (defn merge-heaps [{val-a :value left-a :left right-a :right :as heap-a} 94 | {val-b :value left-b :left right-b :right :as heap-b}] 95 | (cond 96 | (nil? heap-a) heap-b 97 | (nil? heap-b) heap-a 98 | (<= val-a val-b) (ensure-leftist-heap val-a 99 | left-a 100 | (merge-heaps right-a heap-b)) 101 | :else (ensure-leftist-heap val-b 102 | left-b 103 | (merge-heaps heap-a right-b)))) 104 | 105 | (defn heap-insert [value heap] 106 | (merge-heaps (mk-heap 1 value nil nil) 107 | heap)) 108 | 109 | (defn heap-find-min [{v :value}] v) 110 | 111 | (defn heap-delete-min [{left :left right :right}] 112 | (merge-heaps right left)) 113 | 114 | 115 | ;; 116 | ;; Exercises - p19 117 | ;; 118 | 119 | ;; 120 | ;; 3.2 121 | ;; 122 | 123 | (defn direct-heap-insert 124 | [value {val-b :value left-b :left right-b :right :as heap-b}] 125 | (cond (nil? heap-b) (mk-heap 1 value nil nil) 126 | (< value val-b) (ensure-leftist-heap value heap-b nil) 127 | :else (ensure-leftist-heap val-b left-b 128 | (direct-heap-insert value right-b)))) 129 | 130 | ;; 131 | ;; 3.3 132 | ;; 133 | 134 | (defn heap-from-list-O-n 135 | [coll] 136 | (reduce (fn [acc i] 137 | (merge-heaps (if (map? acc) acc (mk-heap 1 acc nil nil)) 138 | (mk-heap 1 i nil nil))) coll)) 139 | 140 | 141 | (defn mk-singleton-heap [n] 142 | (mk-heap 1 n nil nil)) 143 | 144 | (defn heap-from-list-O-log-n 145 | [coll] 146 | (let [singleton-heaps (map mk-singleton-heap coll)] 147 | (loop [heaps singleton-heaps] 148 | (if (= (count heaps) 1) 149 | (first heaps) 150 | (recur (map (fn [pair] (apply merge-heaps pair)) 151 | (partition 2 2 [nil] heaps))))))) 152 | 153 | 154 | 155 | ;; 156 | ;; Binomial Heaps 157 | ;; 158 | 159 | (defn mk-binomial-heap [rank value children] 160 | {:rank rank :value value :children children}) 161 | 162 | 163 | (defn link-binomial-heaps [{rank :rank value-a :value children-a :children :as heap-a} 164 | {value-b :value children-b :children :as heap-b}] 165 | (if (<= value-a value-b) 166 | (mk-binomial-heap (inc rank) value-a (cons heap-b children-a)) 167 | (mk-binomial-heap (inc rank) value-b (cons heap-a children-b)))) 168 | 169 | (defn insert-into-binomial-heap* [heap [head & tail :as heaps]] 170 | (if (or (empty? heaps) 171 | (< (heap-rank heap) (:rank head))) (cons heap heaps) 172 | (insert-into-binomial-heap* (link-binomial-heaps heap head) 173 | tail))) 174 | 175 | (defn insert-into-binomial-heap [value heaps] 176 | (insert-into-binomial-heap* (mk-binomial-heap 0 value []) 177 | heaps)) 178 | 179 | (defn merge-binomial-heaps [[{rank-heap-a :rank :as heap-a} & tail-a :as heaps-a] 180 | [{rank-heap-b :rank :as heap-b} & tail-b :as heaps-b]] 181 | (cond 182 | (empty? heaps-a) heaps-b 183 | (empty? heaps-b) heaps-a 184 | (< rank-heap-a rank-heap-b) (cons heap-a (merge-binomial-heaps tail-a heaps-b)) 185 | (< rank-heap-b rank-heap-a) (cons heap-b (merge-binomial-heaps heaps-a tail-b)) 186 | :else (insert-into-binomial-heap* (link-binomial-heaps heap-a heap-b) 187 | (merge-binomial-heaps tail-a tail-b)))) 188 | 189 | (defn remove-min-binomial-heap [[{value-heap-a :value :as heap-a} & tail-a :as heaps-a]] 190 | (cond (empty? heaps-a) (throw (Exception. "Empty binomial heap")) 191 | (= 1 (count heaps-a)) [heap-a []] 192 | :else (let [[{value-heap-b :value :as heap-b} heaps-b] (remove-min-binomial-heap tail-a)] 193 | (if (< value-heap-a value-heap-b) 194 | [heap-a heaps-b] 195 | [heap-b (cons heap-a heaps-b)])))) 196 | 197 | (defn find-min-binomial-heap [heaps] 198 | (first (remove-min-binomial-heap heaps))) 199 | 200 | (defn delete-min-binomial-heap [heaps] 201 | (let [[{children :children} rest] (remove-min-binomial-heap heaps)] 202 | (merge-binomial-heaps (reverse children) 203 | rest))) 204 | 205 | (defn binomial-heap-from-list [coll] 206 | (reduce (fn [acc n] 207 | (insert-into-binomial-heap n acc)) 208 | [] 209 | coll)) 210 | 211 | ;; 212 | ;; Exercises - p23 213 | ;; 214 | 215 | ;; 216 | ;; 3.5 - Define findMin directly rather than via a call to removeMinTree. 217 | ;; 218 | 219 | ;; First a recursive solution 220 | 221 | (defn rec-find-min-binomial-heap [[heap-a & rest]] 222 | (if (seq rest) 223 | (let [heap-b (rec-find-min-binomial-heap rest)] 224 | (if (<= (:value heap-a) (:value heap-b)) 225 | heap-a 226 | heap-b)) 227 | heap-a)) 228 | 229 | ;; Now using reduce 230 | 231 | (defn reduce-find-min-binomial-heap [heaps] 232 | (reduce (fn [acc heap] 233 | (if (<= (:value acc) (:value heap)) 234 | acc 235 | heap)) 236 | heaps)) 237 | 238 | ;; 239 | ;; 3.6 - Most of the rank annotation in this representation of 240 | ;; binomial heaps are redundant because we know that the children of 241 | ;; a node of rank r have ranks r-1,...,0 . Thus, we can remove the rank 242 | ;; annotations from each node and instead pair each tree at the top-level with its rank, i.e., 243 | ;; 244 | ;; datatype Tree = Node of Elem x Tree list 245 | ;; type Heap = (int x Tree) list 246 | ;; 247 | ;; Reimplement binomial heaps with this new representation. 248 | ;; 249 | 250 | 251 | (defn mk-node [value children] 252 | {:value value :children children}) 253 | 254 | (defn link-bin-heaps [[rank {value-a :value children-a :children :as heap-a}] 255 | [_ {value-b :value children-b :children :as heap-b}]] 256 | (if (<= value-a value-b) 257 | [(inc rank) (mk-node value-a (cons heap-b children-a))] 258 | [(inc rank) (mk-node value-b (cons heap-a children-b))])) 259 | 260 | (defn insert-into-bin-heap* [[rank-a _ :as heap-a] 261 | [[rank-b _ :as head-heap-b] & tail :as heaps-b]] 262 | (if (or (empty? heaps-b) 263 | (< rank-a rank-b)) (cons heap-a heaps-b) 264 | (insert-into-bin-heap* (link-bin-heaps heap-a head-heap-b) 265 | tail))) 266 | 267 | (defn insert-into-bin-heap [value heaps] 268 | (insert-into-bin-heap* [0 (mk-node value [])] 269 | heaps)) 270 | 271 | 272 | (defn bin-heap-from-list [coll] 273 | (reduce (fn [acc n] 274 | (insert-into-bin-heap n acc)) 275 | [] 276 | coll)) 277 | 278 | (defn merge-bin-heaps [[[rank-a _ :as heap-a] & tail-a :as heaps-a] 279 | [[rank-b _ :as heap-b] & tail-b :as heaps-b]] 280 | (cond 281 | (empty? heaps-a) heaps-b 282 | (empty? heaps-b) heaps-a 283 | (< rank-a rank-b) (cons heap-a (merge-bin-heaps tail-a heaps-b)) 284 | (< rank-b rank-a) (cons heap-b (merge-bin-heaps heaps-a tail-b)) 285 | :else (insert-into-bin-heap* (link-bin-heaps heap-a heap-b) 286 | (merge-bin-heaps tail-a tail-b)))) 287 | 288 | (defn remove-min-bin-heap [[[_ {value-heap-a :value} :as heap-a] & tail-a :as heaps-a]] 289 | (cond (empty? heaps-a) (throw (Exception. "Empty binomial heap")) 290 | (= 1 (count heaps-a)) [heap-a []] 291 | :else (let [[[_ {value-heap-b :value} :as heap-b] heaps-b] (remove-min-bin-heap tail-a)] 292 | (if (< value-heap-a value-heap-b) 293 | [heap-a heaps-b] 294 | [heap-b (cons heap-a heaps-b)])))) 295 | 296 | (defn find-min-bin-heap [heaps] 297 | (first (remove-min-bin-heap heaps))) 298 | 299 | (defn decorate-heaps-with-rank [rank heaps] 300 | (second (reduce (fn [[r result] heap] 301 | (let [new-rank (dec r)] 302 | [new-rank (conj result [new-rank heap])])) 303 | [rank []] 304 | heaps))) 305 | 306 | (defn delete-min-bin-heap [heaps] 307 | (let [[[min-rank {children :children}] rest] (remove-min-bin-heap heaps)] 308 | (merge-bin-heaps (reverse (decorate-heaps-with-rank min-rank children)) 309 | rest))) 310 | 311 | 312 | ;; 313 | ;; Red-Black trees 314 | ;; 315 | 316 | 317 | (defn rb-mk-tree [color left value right] 318 | {:color color :left left :value value :right right}) 319 | 320 | 321 | (def rb-tree (rb-mk-tree :black 322 | (rb-mk-tree :red ;; left 323 | (rb-mk-tree :black nil "a" nil) ;;left 324 | 8 325 | (rb-mk-tree :red ;;right 326 | (rb-mk-tree :black nil "b" nil) ;;left 327 | 11 328 | (rb-mk-tree :black nil "c" nil))) ;;right 329 | 13 330 | (rb-mk-tree :black nil "d" nil) ;;right 331 | )) 332 | 333 | 334 | 335 | (comment 336 | 337 | ;; My first attempt - far from ideal without pattern-matching 338 | 339 | (defn rb-balance [tree] 340 | (let [{z :value d :right} tree 341 | {x-color :color x :value a :left} (-> tree :left) 342 | {y-color :color y :value b :left c :right} (-> tree :left :right) 343 | d (:right tree)] 344 | (if (and (= x-color :red) (= y-color :red)) 345 | (rb-mk-tree :red 346 | (rb-mk-tree :black a x b) 347 | y 348 | (rb-mk-tree :black c z d)) 349 | tree)))) 350 | 351 | 352 | 353 | 354 | (defn rb-balance [tree] 355 | (match [tree] 356 | [(:or {:left {:color :red 357 | :left {:color :red :left a :value x :right b} 358 | :value y :right c} 359 | :value z :right d} 360 | 361 | {:left {:color :red 362 | :left a :value x 363 | :right {:color :red :value y :left b :right c}} 364 | :value z :right d} 365 | 366 | {:left a :value x 367 | :right {:color :red 368 | :left {:color :red 369 | :left b :value y :right c} 370 | :value z :right d}} 371 | 372 | {:left a :value x 373 | :right {:color :red 374 | :left b :value y 375 | :right {:color :red 376 | :left c :value z :right d}}})] 377 | (rb-mk-tree :red 378 | (rb-mk-tree :black a x b) 379 | y 380 | (rb-mk-tree :black c z d)) 381 | 382 | :else tree)) 383 | 384 | (defn balance [tree] 385 | (match [tree] 386 | [(:or [:black [:red [:red a x b] y c] z d] 387 | [:black [:red a x [:red b y c]] z d] 388 | [:black a x [:red [:red b y c] z d]] 389 | [:black a x [:red b y [:red c z d]]])] [:red [:black a x b] 390 | y 391 | [:black c z d]] 392 | :else tree)) 393 | 394 | (defn insert [tree x] 395 | (let [ins (fn ins [tree] 396 | (match tree 397 | nil [:red nil x nil] 398 | [color a y b] (cond 399 | (< x y) (balance [color (ins a) y b]) 400 | (> x y) (balance [color a y (ins b)]) 401 | :else tree))) 402 | [_ a y b] (ins tree)] 403 | [:black a y b])) 404 | 405 | (defn is-member? [tree x] 406 | (match tree 407 | nil false 408 | [_ a y b] (cond 409 | (< x y) (recur a x) 410 | (> x y) (recur b x) 411 | :else true))) 412 | 413 | (comment 414 | 415 | ;; When core.match supports protocols, this will be 416 | ;; awesome. 417 | 418 | (defrecord Black [left value right]) 419 | (defrecord Red [left value right]) 420 | 421 | 422 | (def protocol-tree 423 | (Black. (Red. 424 | (Black. nil "a" nil) 425 | 8 426 | (Red. 427 | (Black. nil "b" nil) 428 | 11 429 | (Black. nil "c" nil))) 430 | 13 431 | (Black. nil "d" nil))) 432 | 433 | (defn balance [node] 434 | (match [node] 435 | [(:or (Black. (Red. (Red. a x b) y c) z d) 436 | (Black. (Red. a x (Red. b y c)) z d) 437 | (Black. a x (Red. (Red. b y c) z d)) 438 | (Black. a x (Red. b y (Red. c z d))))] (Red. (Black. a x b) 439 | y 440 | (Black. c z d)) 441 | :else node))) -------------------------------------------------------------------------------- /test/purely_functional_data_structures/ch2_test.clj: -------------------------------------------------------------------------------- 1 | (ns purely-functional-data-structures.ch2-test 2 | (:use clojure.test 3 | purely-functional-data-structures.ch2)) 4 | 5 | (deftest persistence 6 | (testing "catenation" 7 | (is (= (++ [] [4 5 6]) 8 | [4 5 6])) 9 | 10 | (is (= (++ [1 2 3] [4 5 6]) 11 | [1 2 3 4 5 6]))) 12 | 13 | (testing "updates" 14 | (is (= (update [1 2 3 4] 0 7) 15 | [7 2 3 4])) 16 | 17 | (is (= (update [1 2 3 4] 2 10) 18 | [1 2 10 4]))) 19 | 20 | 21 | (testing "suffixes" 22 | (is (= (suffixes [1 2 3 4]) 23 | '([1 2 3 4] (2 3 4) (3 4) (4) ()))))) 24 | 25 | (deftest binary-search-tree 26 | (let [tree (mk-tree 27 | (mk-tree 28 | (mk-tree nil 4 nil) 29 | 5 30 | (mk-tree nil 7 nil)) 31 | 10 32 | (mk-tree 33 | nil 34 | 15 35 | (mk-tree nil 20 nil)))] 36 | (testing "membership" 37 | (is (is-member? tree 5)) 38 | (is (is-member? tree 10)) 39 | (is (is-member? tree 20)) 40 | (is (not (is-member? tree 3))) 41 | (is (not (is-member? tree 1)))) 42 | 43 | (testing "insert" 44 | (is (is-member? (insert tree 13) 13)) 45 | (is (is-member? (insert tree 9) 9))) 46 | 47 | (testing "using exceptions to abort when inserting duplicates" 48 | (is (thrown-with-msg? Exception #"Element already in tree" 49 | (insert (insert tree 2) 2)))))) -------------------------------------------------------------------------------- /test/purely_functional_data_structures/ch3_test.clj: -------------------------------------------------------------------------------- 1 | (ns purely-functional-data-structures.ch3-test 2 | (:refer-clojure :exclude [merge]) 3 | (:require [clojure.walk :as w] 4 | [clojure.zip :as z]) 5 | (:use clojure.test 6 | purely-functional-data-structures.ch3)) 7 | 8 | (defn heap-values [heap] 9 | (map :value (filter (complement nil?) 10 | (tree-seq map? (fn [node] (vector (:left node) (:right node))) 11 | heap)))) 12 | 13 | 14 | 15 | (defmacro get-time 16 | [expr] 17 | `(let [start# (. System (nanoTime)) 18 | ret# ~expr] 19 | (/ (double (- (. System (nanoTime)) start#)) 1000000.0))) 20 | 21 | (deftest leftist-heaps 22 | (testing "Implemented with protocols" 23 | (let [heap (-> (->LeftistHeap 1 3 nil nil) 24 | (insert 2) 25 | (insert 7) 26 | (insert 4) 27 | (insert 10) 28 | (insert 1) 29 | (insert 20))] 30 | 31 | (is (= (heap-values heap) 32 | [1 2 4 7 10 3 20])) 33 | 34 | (is (= (find-min heap) 35 | 1)) 36 | 37 | (is (= (:value (delete-min heap)) 38 | 2)))) 39 | 40 | 41 | (testing "Implemented with pure functions" 42 | (let [heap (->> (mk-heap 1 3 nil nil) 43 | (heap-insert 2) 44 | (heap-insert 7) 45 | (heap-insert 4) 46 | (heap-insert 10) 47 | (heap-insert 1) 48 | (heap-insert 20))] 49 | 50 | (is (= (heap-values heap) 51 | [1 2 4 7 10 3 20])) 52 | 53 | (is (= (heap-find-min heap) 54 | 1)) 55 | 56 | (is (= (:value (heap-delete-min heap)) 57 | 2)))) 58 | 59 | (testing "Implementing insert directly" 60 | (let [heap (->> (mk-heap 1 3 nil nil) 61 | (direct-heap-insert 2) 62 | (direct-heap-insert 7) 63 | (direct-heap-insert 4) 64 | (direct-heap-insert 10) 65 | (direct-heap-insert 1) 66 | (direct-heap-insert 20))] 67 | (is (= (heap-values heap) 68 | [1 2 4 7 10 3 20])))) 69 | 70 | (testing "Performance" 71 | (let [time-O-n (get-time (dotimes [_ 10000] (heap-from-list-O-n (range 500)))) 72 | time-O-log-n (get-time (dotimes [_ 10000] (heap-from-list-O-log-n (range 500))))] 73 | (prn "Creating a leftist heap with 500 elemens 10k times: ") 74 | (prn (format "O(n) time: %s" time-O-n)) 75 | (prn (format "O(log n) time: %s" time-O-log-n)) 76 | (is (< time-O-log-n time-O-n))))) 77 | 78 | 79 | (defn binomial-heap-values [heaps] 80 | (letfn [(heap-values [heap] 81 | (map :value (tree-seq map? 82 | (fn [h] (:children h)) 83 | heap)))] 84 | (mapcat heap-values heaps))) 85 | 86 | (deftest binomial-heaps 87 | (testing "linking heaps" 88 | (let [heap-a (mk-binomial-heap 0 3 []) 89 | heap-b (mk-binomial-heap 0 2 [])] 90 | 91 | (is (= (link-binomial-heaps heap-a heap-b) 92 | {:rank 1, 93 | :value 2, 94 | :children '({:rank 0, 95 | :value 3, 96 | :children []})})) 97 | 98 | (is (= (binomial-heap-values 99 | [(->> (link-binomial-heaps heap-a heap-b) 100 | (link-binomial-heaps (mk-binomial-heap 0 1 [])))]) 101 | [1 2 3])))) 102 | 103 | (testing "inserting" 104 | (let [heaps (->> (insert-into-binomial-heap 1 []) 105 | (insert-into-binomial-heap 2) 106 | (insert-into-binomial-heap 7) 107 | (insert-into-binomial-heap 5) 108 | (insert-into-binomial-heap 6) 109 | (insert-into-binomial-heap 10) 110 | (insert-into-binomial-heap 8))] 111 | (is (= (count heaps) 112 | 3)) 113 | (is (= (map :rank heaps) 114 | [0 1 2])) 115 | (is (= (binomial-heap-values 116 | heaps) 117 | [8 6 10 1 5 7 2])) 118 | 119 | (is (= heaps) 120 | (binomial-heap-from-list [1 2 7 5 6 10]))) 121 | 122 | 123 | (let [heaps (binomial-heap-from-list [9 5 17 21 99 12 23 12 77 33 24 23 53])] 124 | (is (= (count heaps) 125 | 3)) 126 | (is (= (map :rank heaps) 127 | [0 2 3])) 128 | (is (= (binomial-heap-values 129 | heaps) 130 | [53 23 33 77 24 5 12 12 99 23 17 21 9])))) 131 | 132 | (testing "merging heaps" 133 | (let [heap-a (binomial-heap-from-list [1 2 7 5 6 10 8]) 134 | heap-b (binomial-heap-from-list [9 5 17 21 99 12 23 12 77 33 24 23 53]) 135 | 136 | merged-heap (merge-binomial-heaps heap-a heap-b)] 137 | (is (= (count merged-heap) 138 | 2)) 139 | 140 | (is (= (map :rank merged-heap) 141 | [2 4])))) 142 | 143 | (testing "removing min heap" 144 | (let [heaps (binomial-heap-from-list [1 2 7 5 6 10 8]) 145 | [min rest] (remove-min-binomial-heap heaps)] 146 | (is (= min 147 | {:rank 2, :value 1, 148 | :children [{:rank 1, :value 5, 149 | :children [{:rank 0, :value 7, 150 | :children []}]} 151 | {:rank 0, :value 2, 152 | :children []}]})) 153 | 154 | (is (= (count rest) 155 | 2)))) 156 | 157 | (testing "delete min heap" 158 | (let [heaps (binomial-heap-from-list [1 2 7 5 6 10 8]) 159 | new-heap (delete-min-binomial-heap heaps)] 160 | (is (= (binomial-heap-values new-heap) 161 | [2 8 5 6 10 7])) 162 | 163 | (is (= (count new-heap) 164 | 2)))) 165 | 166 | (testing "finding min heap" 167 | (let [heaps (binomial-heap-from-list [1 2 7 5 6 10 8]) 168 | expected-min {:rank 2, :value 1, 169 | :children [{:rank 1, :value 5, 170 | :children [{:rank 0, :value 7, 171 | :children []}]} 172 | {:rank 0, :value 2, 173 | :children []}]}] 174 | (is (= (find-min-binomial-heap heaps) 175 | expected-min)) 176 | 177 | (is (= (rec-find-min-binomial-heap heaps) 178 | expected-min)) 179 | 180 | (is (= (reduce-find-min-binomial-heap heaps) 181 | expected-min)))) 182 | 183 | 184 | (testing "exercise. 3.6 - inserting" 185 | (let [heaps (->> (insert-into-bin-heap 1 []) 186 | (insert-into-bin-heap 2) 187 | (insert-into-bin-heap 7) 188 | (insert-into-bin-heap 5) 189 | (insert-into-bin-heap 6) 190 | (insert-into-bin-heap 10) 191 | (insert-into-bin-heap 8))] 192 | (is (= (count heaps) 193 | 3)) 194 | (is (= (map first heaps) 195 | [0 1 2])) 196 | (is (= (binomial-heap-values 197 | (map second heaps)) 198 | [8 6 10 1 5 7 2])) 199 | 200 | (is (= heaps) 201 | (bin-heap-from-list [1 2 7 5 6 10]))) 202 | 203 | 204 | (let [heaps (bin-heap-from-list [9 5 17 21 99 12 23 12 77 33 24 23 53])] 205 | (is (= (count heaps) 206 | 3)) 207 | (is (= (map first heaps) 208 | [0 2 3])) 209 | (is (= (binomial-heap-values 210 | (map second heaps)) 211 | [53 23 33 77 24 5 12 12 99 23 17 21 9])))) 212 | 213 | (testing "exercise. 3.6 - merging heaps" 214 | (let [heap-a (bin-heap-from-list [1 2 7 5 6 10 8]) 215 | heap-b (bin-heap-from-list [9 5 17 21 99 12 23 12 77 33 24 23 53]) 216 | 217 | merged-heap (merge-bin-heaps heap-a heap-b)] 218 | (is (= (count merged-heap) 219 | 2)) 220 | 221 | (is (= (map first merged-heap) 222 | [2 4])))) 223 | 224 | 225 | (testing "exercise. 3.6 - removing min heap" 226 | (let [heaps (bin-heap-from-list [1 2 7 5 6 10 8]) 227 | [min rest] (remove-min-bin-heap heaps)] 228 | (is (= min 229 | [2 {:value 1, 230 | :children [{:value 5, 231 | :children [{:value 7, :children []}]} 232 | {:value 2, 233 | :children []}]}])) 234 | 235 | (is (= (count rest) 236 | 2)))) 237 | 238 | (testing "exercise. 3.6 - delete min heap" 239 | (let [heaps (bin-heap-from-list [1 2 7 5 6 10 8]) 240 | new-heap (delete-min-bin-heap heaps)] 241 | (is (= (binomial-heap-values (map second new-heap)) 242 | [2 8 5 6 10 7])) 243 | 244 | (is (= (count new-heap) 245 | 2)))) 246 | 247 | (testing "exercise. 3.6 - finding min heap" 248 | (let [heaps (bin-heap-from-list [1 2 7 5 6 10 8]) 249 | expected-min [2 {:value 1, 250 | :children [{:value 5, 251 | :children [{:value 7, :children []}]} 252 | {:value 2, 253 | :children []}]}]] 254 | (is (= (find-min-bin-heap heaps) 255 | expected-min))))) 256 | 257 | (defn assert-balanced [balanced] 258 | (are [x y] (= x (first y)) 259 | "y" (:value balanced) 260 | :red (:color balanced) 261 | 262 | "x" (-> balanced :left :value) 263 | :black (-> balanced :left :color) 264 | 265 | "a" (-> balanced :left :left :value) 266 | "b" (-> balanced :left :right :value) 267 | 268 | "z" (-> balanced :right :value) 269 | :black (-> balanced :right :color) 270 | 271 | "c" (-> balanced :right :left :value) 272 | "d" (-> balanced :right :right :value))) 273 | 274 | (deftest red-black-trees 275 | (testing "Map-based red-black trees" 276 | (testing "balancing, case 1" 277 | (let [tree (rb-mk-tree :black 278 | (rb-mk-tree :red ;; left 279 | (rb-mk-tree :black nil "a" nil) ;;left 280 | "x" 281 | (rb-mk-tree :red ;;right 282 | (rb-mk-tree :black nil "b" nil) ;;left 283 | "y" 284 | (rb-mk-tree :black nil "c" nil))) ;;right 285 | "z" 286 | (rb-mk-tree :black nil "d" nil) ;;right 287 | )] 288 | (assert-balanced (rb-balance tree)))) 289 | 290 | (testing "balancing, case 2" 291 | (let [tree (rb-mk-tree :black 292 | (rb-mk-tree :red 293 | (rb-mk-tree :red 294 | (rb-mk-tree :black nil "a" nil) 295 | "x" 296 | (rb-mk-tree :black nil "b" nil)) 297 | "y" 298 | (rb-mk-tree :black nil "c" nil)) 299 | "z" 300 | (rb-mk-tree :black nil "d" nil))] 301 | (assert-balanced (rb-balance tree)))) 302 | 303 | (testing "balancing, case 3" 304 | (let [tree (rb-mk-tree :black 305 | (rb-mk-tree :black nil "a" nil) 306 | "x" 307 | (rb-mk-tree :red 308 | (rb-mk-tree :red 309 | (rb-mk-tree :black nil "b" nil) 310 | "y" 311 | (rb-mk-tree :black nil "c" nil)) 312 | "z" 313 | (rb-mk-tree :black nil "d" nil)))] 314 | (assert-balanced (rb-balance tree)))) 315 | 316 | (testing "balancing, case 4" 317 | (let [tree (rb-mk-tree :black 318 | (rb-mk-tree :black nil "a" nil) 319 | "x" 320 | (rb-mk-tree :red 321 | (rb-mk-tree :black nil "b" nil) 322 | "y" 323 | (rb-mk-tree :red 324 | (rb-mk-tree :black nil "c" nil) 325 | "z" 326 | (rb-mk-tree :black nil "d" nil))))] 327 | (assert-balanced (rb-balance tree))))) 328 | 329 | 330 | (testing "Vector-based red-black trees" 331 | (letfn [(assert-balanced [balanced] 332 | (let [balanced-zp (z/zipper vector? seq (fn [_ c] c) balanced) 333 | left-child (comp z/right z/down) 334 | right-child (comp z/right z/right z/right z/down) 335 | value (comp z/right z/right z/down) 336 | color z/down] 337 | ;; root 338 | (are [x y] (= x (first y)) 339 | :red (-> balanced-zp color) 340 | "y" (-> balanced-zp value) 341 | 342 | :black (-> balanced-zp left-child color) 343 | "x" (-> balanced-zp left-child value) 344 | 345 | "a" (-> balanced-zp left-child left-child value) 346 | "b" (-> balanced-zp left-child right-child value) 347 | 348 | :black (-> balanced-zp right-child color) 349 | "z" (-> balanced-zp right-child value) 350 | 351 | "c" (-> balanced-zp right-child left-child value) 352 | "d" (-> balanced-zp right-child right-child value))))] 353 | 354 | (testing "balancing, case 1" 355 | (let [tree [:black 356 | [:red 357 | [:black nil "a" nil] 358 | "x" 359 | [:red 360 | [:black nil "b" nil] 361 | "y" 362 | [:black nil "c" nil]]] 363 | "z" 364 | [:black nil "d" nil]]] 365 | 366 | (assert-balanced (balance tree)))) 367 | 368 | (testing "balancing, case 2" 369 | (let [tree [:black 370 | [:red 371 | [:red 372 | [:black nil "a" nil] 373 | "x" 374 | [:black nil "b" nil]] 375 | "y" 376 | [:black nil "c" nil]] 377 | "z" 378 | [:black nil "d" nil]]] 379 | 380 | (assert-balanced (balance tree)))) 381 | 382 | (testing "balancing, case 3" 383 | (let [tree [:black 384 | [:black nil "a" nil] 385 | "x" 386 | [:red 387 | [:red 388 | [:black nil "b" nil] 389 | "y" 390 | [:black nil "c" nil]] 391 | "z" 392 | [:black nil "d" nil]]]] 393 | 394 | (assert-balanced (balance tree)))) 395 | 396 | (testing "balancing, case 4" 397 | (let [tree [:black 398 | [:black nil "a" nil] 399 | "x" 400 | [:red 401 | [:black nil "b" nil] 402 | "y" 403 | [:red 404 | [:black nil "c" nil] 405 | "z" 406 | [:black nil "d" nil]]]]] 407 | (assert-balanced (balance tree)))))) 408 | 409 | (testing "Vector-based red-black trees: insert" 410 | (let [tree (-> (insert nil 10) 411 | (insert 5) 412 | (insert 7) 413 | (insert 1) 414 | (insert 14))] 415 | (is (= tree 416 | [:black 417 | [:black [:red nil 1 nil] 5 nil] 418 | 7 419 | [:black nil 10 [:red nil 14 nil]]])))) 420 | 421 | (testing "Vector-based red-black trees: membership" 422 | (let [tree (-> (insert nil 10) 423 | (insert 5) 424 | (insert 7) 425 | (insert 1) 426 | (insert 14))] 427 | (are [x y] (= x y) 428 | true (is-member? tree 10) 429 | true (is-member? tree 7) 430 | true (is-member? tree 14) 431 | false (is-member? tree 20) 432 | false (is-member? tree 2))))) 433 | --------------------------------------------------------------------------------