tree-stuff.scm (14792B)
1 (define-library (trees-stuff) 2 (import (scheme base)) 3 4 (begin 5 (define (entry tree) (car tree)) 6 (define (left-branch tree) (cadr tree)) 7 (define (right-branch tree) (caddr tree)) 8 (define (make-tree entry left right) (list entry left right)) 9 10 (define (element-of-set? x set) 11 (cond 12 ((null? set) #f) 13 ((< x (entry set)) 14 (element-of-set? x (left-branch set))) 15 ((> x (entry set)) 16 (element-of-set? x (right-branch set))) 17 (else #t))) 18 19 (define (tree->list-1 tree) 20 (if (null? tree) 21 '() 22 (append 23 (tree->list-1 (left-branch tree)) 24 (cons (entry tree) 25 (tree->list-1 (right-branch tree)))))) 26 27 (define (copy-to-list tree result-list) 28 (if (null? tree) 29 result-list 30 (copy-to-list (left-branch tree) 31 (cons (entry tree) 32 (copy-to-list 33 (right-branch tree) 34 result-list))))) 35 (define (tree->list-2 tree) 36 (copy-to-list tree '())) 37 38 (define tree-1 39 (make-tree 7 40 (make-tree 3 41 (make-tree 1 '() '()) 42 (make-tree 5 '() '())) 43 (make-tree 9 44 '() 45 (make-tree 11 '() '())))) 46 47 (define tree-2 48 (make-tree 3 49 (make-tree 1 '() '()) 50 (make-tree 7 51 (make-tree 5 '() '()) 52 (make-tree 9 53 '() 54 (make-tree 11 '() '()))))) 55 56 (define tree-3 57 (make-tree 5 58 (make-tree 3 59 (make-tree 1 '() '()) 60 '()) 61 (make-tree 9 62 (make-tree 7 '() '()) 63 (make-tree 11 '() '())))) 64 65 ;; Exercise 2.63 XXX 66 67 (test-begin "2.63") 68 69 ;; These tests show that the algorithms are the same for the three input trees. Sadly, I wouldn't know how to prove mathematical equivalency. 70 (test-equal 71 (tree->list-1 tree-1) 72 (tree->list-2 tree-1)) 73 (test-equal 74 (tree->list-1 tree-2) 75 (tree->list-2 tree-2)) 76 (test-equal 77 (tree->list-1 tree-3) 78 (tree->list-2 tree-3)) 79 80 ;; tree->list-1 uses append for each pair of branches, so for level 1 we have 81 ;; 1 append, for level 2 we have 2 appends, level 3 has 4 appends. 82 ;; For an input of length n, an append has n steps, so for level 1 we append 83 ;; one half of the tree to the other. 84 ;; Therefore, for input of size n to tree->list-1: 85 ;; * Level 1 append would have the input of size n/2. 86 ;; * A level 2 append would have input of size n / 4. 87 ;; * A level 3 append, n / 8. 88 ;; * A level 4 append, n / 16. 89 ;; * A level n append, n / 2^n. 90 ;; XXX 91 92 (test-equal 93 '(1 3 5 7 9 11) 94 (tree->list-1 tree-1)) 95 (test-equal 96 '(1 3 5 7 9 11) 97 (tree->list-1 98 (make-tree 7 99 (make-tree 3 100 (make-tree 1 '() '()) 101 (make-tree 5 '() '())) 102 (make-tree 9 103 '() 104 (make-tree 11 '() '()))))) 105 (test-equal 106 '(1 3 5 7 9 11) 107 (append 108 (tree->list-1 109 (make-tree 3 110 (make-tree 1 '() '()) 111 (make-tree 5 '() '())) 112 (cons 113 7 114 (tree->list-1 115 (make-tree 9 116 '() 117 (make-tree 11 '() '()))))))) 118 (test-equal 119 '(1 3 5 7 9 11) 120 (append 121 (tree->list-1 122 (append 123 (make-tree 1 '() '()) 124 (cons 125 3 126 (tree->list-1 127 (make-tree 5 '() '())))) 128 (cons 129 7 130 (tree->list-1 131 (make-tree 9 132 '() 133 (make-tree 11 '() '()))))))) 134 (test-equal 135 '(1 3 5 7 9 11) 136 (append 137 (tree->list-1 138 (append 139 (make-tree 1 '() '()) 140 (cons 141 3 142 (tree->list-1 143 (append 144 '() 145 (cons 146 5 147 (tree->list-1 '())))))) 148 (cons 149 7 150 (tree->list-1 151 (make-tree 9 152 '() 153 (make-tree 11 '() '()))))))) 154 (test-equal 155 '(1 3 5 7 9 11) 156 (append 157 (tree->list-1 158 (append 159 (make-tree 1 '() '()) 160 (cons 161 3 162 (tree->list-1 163 (append 164 '() 165 (cons 166 5 167 '()))))) 168 (cons 169 7 170 (tree->list-1 171 (make-tree 9 172 '() 173 (make-tree 11 '() '()))))))) 174 (test-equal ;; 1 175 '(1 3 5 7 9 11) 176 (tree->list-2 177 (make-tree 7 178 (make-tree 3 179 (make-tree 1 '() '()) 180 (make-tree 5 '() '())) 181 (make-tree 9 182 '() 183 (make-tree 11 '() '()))))) 184 (test-equal ;; 2 185 '(1 3 5 7 9 11) 186 (copy-to-list 187 (make-tree 7 188 (make-tree 3 189 (make-tree 1 '() '()) 190 (make-tree 5 '() '())) 191 (make-tree 9 192 '() 193 (make-tree 11 '() '()))) 194 '())) 195 (test-equal ;; 3 196 '(1 3 5 7 9 11) 197 (copy-to-list 198 (make-tree 7 199 (make-tree 3 200 (make-tree 1 '() '()) 201 (make-tree 5 '() '())) 202 (make-tree 9 203 '() 204 (make-tree 11 '() '()))) 205 '())) 206 (test-equal ;; 4 207 '(1 3 5 7 9 11) 208 (copy-to-list 209 (make-tree 3 210 (make-tree 1 '() '()) 211 (make-tree 5 '() '())) 212 (cons 7 213 (copy-to-list 214 (make-tree 9 215 '() 216 (make-tree 11 '() '())) 217 '())))) 218 (test-equal ;; 5 219 '(1 3 5 7 9 11) 220 (copy-to-list 221 (make-tree 3 222 (make-tree 1 '() '()) 223 (make-tree 5 '() '())) 224 (cons 7 225 (copy-to-list 226 '() 227 (cons 9 228 (copy-to-list 229 (make-tree 11 '() '()) 230 '())))))) 231 (test-equal ;; 6 232 '(1 3 5 7 9 11) 233 (copy-to-list 234 (make-tree 3 235 (make-tree 1 '() '()) 236 (make-tree 5 '() '())) 237 (cons 7 238 (copy-to-list 239 '() 240 (cons 9 241 (copy-to-list 242 '() 243 (cons 11 244 (copy-to-list '() '())))))))) 245 (test-equal ;; 7 246 '(1 3 5 7 9 11) 247 (copy-to-list 248 (make-tree 3 249 (make-tree 1 '() '()) 250 (make-tree 5 '() '())) 251 (cons 7 252 (copy-to-list 253 '() 254 (cons 9 255 (copy-to-list 256 '() 257 (cons 11 258 (copy-to-list '() '())))))))) 259 (test-equal ;; 8 260 '(1 3 5 7 9 11) 261 (copy-to-list 262 (make-tree 3 263 (make-tree 1 '() '()) 264 (make-tree 5 '() '())) 265 (cons 7 266 (copy-to-list 267 '() 268 (cons 9 269 (copy-to-list 270 '() 271 (cons 11 272 '()))))))) 273 (test-equal ;; 9 274 '(1 3 5 7 9 11) 275 (copy-to-list 276 (make-tree 3 277 (make-tree 1 '() '()) 278 (make-tree 5 '() '())) 279 (cons 7 280 (copy-to-list 281 '() 282 (cons 9 283 (cons 11 284 '())))))) 285 (test-equal ;; 10 286 '(1 3 5 7 9 11) 287 (copy-to-list 288 (make-tree 3 289 (make-tree 1 '() '()) 290 (make-tree 5 '() '())) 291 (cons 7 292 (cons 9 293 (cons 11 294 '()))))) 295 (test-equal ;; 11 296 '(1 3 5 7 9 11) 297 (copy-to-list 298 (make-tree 1 '() '()) 299 (cons 3 300 (copy-to-list 301 (make-tree 5 '() '()) 302 (cons 7 303 (cons 9 304 (cons 11 305 '()))))))) 306 (test-equal ;; 12 307 '(1 3 5 7 9 11) 308 (copy-to-list 309 (make-tree 1 '() '()) 310 (cons 3 311 (copy-to-list 312 '() 313 (cons 5 314 (copy-to-list 315 '() 316 (cons 7 317 (cons 9 318 (cons 11 319 '()))))))))) 320 (test-equal ;; 13 321 '(1 3 5 7 9 11) 322 (copy-to-list 323 (make-tree 1 '() '()) 324 (cons 3 325 (copy-to-list 326 '() 327 (cons 5 328 (cons 7 329 (cons 9 330 (cons 11 331 '())))))))) 332 (test-equal ;; 14 333 '(1 3 5 7 9 11) 334 (copy-to-list 335 (make-tree 1 '() '()) 336 (cons 3 337 (cons 5 338 (cons 7 339 (cons 9 340 (cons 11 341 '()))))))) 342 (test-equal ;; 15 343 '(1 3 5 7 9 11) 344 (copy-to-list 345 '() 346 (cons 1 347 (copy-to-list 348 '() 349 (cons 3 350 (cons 5 351 (cons 7 352 (cons 9 353 (cons 11 354 '()))))))))) 355 (test-equal ;; 16 356 '(1 3 5 7 9 11) 357 (copy-to-list 358 '() 359 (cons 1 360 (cons 3 361 (cons 5 362 (cons 7 363 (cons 9 364 (cons 11 365 '())))))))) 366 (test-equal ;; 17 367 '(1 3 5 7 9 11) 368 (cons 1 369 (cons 3 370 (cons 5 371 (cons 7 372 (cons 9 373 (cons 11 374 '()))))))) 375 (test-end "2.63") 376 377 378 ;; Exercise 2.64 XXX 379 380 (define (list->tree elements) 381 (car (partial-tree 382 elements 383 (length elements)))) 384 385 (define (partial-tree elts n) 386 (if (= n 0) 387 (cons '() elts) 388 (let ([left-size 389 (quotient (- n 1) 2)]) 390 (let ([left-result 391 (partial-tree 392 elts left-size)]) 393 (let ([left-tree 394 (car left-result)] 395 [non-left-elts 396 (cdr left-result)] 397 [right-size 398 (- n (+ left-size 1))]) 399 (let ([this-entry 400 (car non-left-elts)] 401 [right-result 402 (partial-tree 403 (cdr non-left-elts) 404 right-size)]) 405 (let ([right-tree 406 (car right-result)] 407 [remaining-elts 408 (cdr right-result)]) 409 (cons (make-tree this-entry 410 left-tree 411 right-tree) 412 remaining-elts)))))))) 413 414 (test-begin "2.64") 415 (test-equal 416 (make-tree 1 '() '()) 417 (list->tree '(1)))) 418 (test-equal 419 (make-tree 1 420 '() 421 (make-tree 2 '() '())) 422 (list->tree '(1 2))) 423 (test-equal 424 (make-tree 2 425 (make-tree 1 '() '()) 426 (make-tree 3 '() '())) 427 (list->tree '(1 2 3))) 428 (test-equal 429 (make-tree 2 430 (make-tree 1 '() '()) 431 (make-tree 3 432 '() 433 (make-tree 4 '() '()))) 434 (list->tree '(1 2 3 4))) 435 (test-equal 436 (make-tree 3 437 (make-tree 1 438 '() 439 (make-tree 2 '() '())) 440 (make-tree 4 441 '() 442 (make-tree 5 '() '()))) 443 (list->tree '(1 2 3 4 5))) 444 (test-equal 445 (make-tree 3 446 (make-tree 1 447 '() 448 (make-tree 2 '() '())) 449 (make-tree 5 450 (make-tree 4 '() '()) 451 (make-tree 6 '() '()))) 452 (list->tree '(1 2 3 4 5 6))) 453 (test-equal 454 (make-tree 4 455 (make-tree 2 456 (make-tree 1 '() '()) 457 (make-tree 3 '() '())) 458 (make-tree 6 459 (make-tree 5 '() '()) 460 (make-tree 7 '() '()))) 461 (list->tree '(1 2 3 4 5 6 7))) 462 (test-equal 463 (make-tree 4 464 (make-tree 2 465 (make-tree 1 '() '()) 466 (make-tree 3 '() '())) 467 (make-tree 6 468 (make-tree 5 '() '()) 469 (make-tree 7 '() '()))) 470 (list->tree '(1 2 3 4 5 6 7 8))) 471 (test-end "2.64") 472 473 ;; Exercise 2.65 XXX 474 475 ;; Exercise 2.66 476 477 (define (make-entry key value) 478 (cons key value)) 479 480 (define (key entry) 481 (car entry)) 482 483 (define (value entry) 484 (cdr entry)) 485 486 (define (lookup given-key set-of-records) 487 (cond 488 ((null? set-of-records) #f) 489 ((< given-key (key (entry set-of-records))) 490 (lookup given-key (left-branch set-of-records))) 491 ((> given-key (key (entry set-of-records))) 492 (lookup given-key (right-branch set-of-records))) 493 (else (entry set-of-records)))) 494 495 (test-begin "2.66") 496 (test-equal 497 #f 498 (lookup 4 '())) 499 (test-equal 500 (make-entry 4 "moo") 501 (lookup 4 502 (make-tree (make-entry 4 "moo") '() '()))) 503 (test-equal 504 (make-entry 4 "moo") 505 (lookup 4 506 (make-tree (make-entry 3 "foo") 507 '() 508 (make-tree (make-entry 4 "moo") '() '())))) 509 (test-equal 510 (make-entry 4 "moo") 511 (lookup 4 512 (make-tree (make-entry 5 "foo") 513 (make-tree (make-entry 4 "moo") '() '()) 514 '()))) 515 (test-end "2.66"))