├── README ├── Chapter 1.scm ├── Chapter 4.scm ├── Chapter 2.scm └── Chapter 3.scm /README: -------------------------------------------------------------------------------- 1 | My take on the SICP exercises. 2 | 3 | -------------------------------------------------------------------------------- /Chapter 1.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Pluies/SICP/HEAD/Chapter 1.scm -------------------------------------------------------------------------------- /Chapter 4.scm: -------------------------------------------------------------------------------- 1 | ; Prelude: the metacircular evaluator 2 | ; Code given: 3 | (define (eval exp env) 4 | (cond ((self-evaluating? exp) exp) 5 | ((variable? exp) (lookup-variable-value exp env)) 6 | ((quoted? exp) (text-of-quotation exp)) 7 | ((assignment? exp) (eval-assignment exp env)) 8 | ((definition? exp) (eval-definition exp env)) 9 | ((if? exp) (eval-if exp env)) 10 | ((lambda? exp) 11 | (make-procedure (lambda-parameters exp) 12 | (lambda-body exp) 13 | env)) 14 | ((begin? exp) 15 | (eval-sequence (begin-actions exp) env)) 16 | ((cond? exp) (eval (cond->if exp) env)) 17 | ((application? exp) 18 | (apply (eval (operator exp) env) 19 | (list-of-values (operands exp) env))) 20 | (else 21 | (error "Unknown expression type -- EVAL" exp)))) 22 | ; Need to define that before shadowing apply 23 | (define apply-in-underlying-scheme apply) 24 | (define (apply procedure arguments) 25 | (cond ((primitive-procedure? procedure) 26 | (apply-primitive-procedure procedure arguments)) 27 | ((compound-procedure? procedure) 28 | (eval-sequence 29 | (procedure-body procedure) 30 | (extend-environment 31 | (procedure-parameters procedure) 32 | arguments 33 | (procedure-environment procedure)))) 34 | (else 35 | (error 36 | "Unknown procedure type -- APPLY" procedure)))) 37 | (define (list-of-values exps env) 38 | (if (no-operands? exps) 39 | '() 40 | (cons (eval (first-operand exps) env) 41 | (list-of-values (rest-operands exps) env)))) 42 | (define (eval-if exp env) 43 | (if (true? (eval (if-predicate exp) env)) 44 | (eval (if-consequent exp) env) 45 | (eval (if-alternative exp) env))) 46 | (define (eval-sequence exps env) 47 | (cond ((last-exp? exps) (eval (first-exp exps) env)) 48 | (else (eval (first-exp exps) env) 49 | (eval-sequence (rest-exps exps) env)))) 50 | (define (eval-assignment exp env) 51 | (set-variable-value! (assignment-variable exp) 52 | (eval (assignment-value exp) env) 53 | env) 54 | 'ok) 55 | (define (eval-definition exp env) 56 | (define-variable! (definition-variable exp) 57 | (eval (definition-value exp) env) 58 | env) 59 | 'ok) 60 | (define (self-evaluating? exp) 61 | (cond ((number? exp) true) 62 | ((string? exp) true) 63 | (else false))) 64 | (define (variable? exp) (symbol? exp)) 65 | (define (quoted? exp) 66 | (tagged-list? exp 'quote)) 67 | (define (text-of-quotation exp) (cadr exp)) 68 | (define (tagged-list? exp tag) 69 | (if (pair? exp) 70 | (eq? (car exp) tag) 71 | false)) 72 | (define (assignment? exp) 73 | (tagged-list? exp 'set!)) 74 | (define (assignment-variable exp) (cadr exp)) 75 | (define (assignment-value exp) (caddr exp)) 76 | (define (definition? exp) 77 | (tagged-list? exp 'define)) 78 | (define (definition-variable exp) 79 | (if (symbol? (cadr exp)) 80 | (cadr exp) 81 | (caadr exp))) 82 | (define (definition-value exp) 83 | (if (symbol? (cadr exp)) 84 | (caddr exp) 85 | (make-lambda (cdadr exp) ; formal parameters 86 | (cddr exp)))) ; body 87 | (define (lambda? exp) (tagged-list? exp 'lambda)) 88 | (define (lambda-parameters exp) (cadr exp)) 89 | (define (lambda-body exp) (cddr exp)) 90 | (define (make-lambda parameters body) 91 | (cons 'lambda (cons parameters body))) 92 | (define (if? exp) (tagged-list? exp 'if)) 93 | (define (if-predicate exp) (cadr exp)) 94 | (define (if-consequent exp) (caddr exp)) 95 | (define (if-alternative exp) 96 | (if (not (null? (cdddr exp))) 97 | (cadddr exp) 98 | 'false)) 99 | (define (make-if predicate consequent alternative) 100 | (list 'if predicate consequent alternative)) 101 | (define (begin? exp) (tagged-list? exp 'begin)) 102 | (define (begin-actions exp) (cdr exp)) 103 | (define (last-exp? seq) (null? (cdr seq))) 104 | (define (first-exp seq) (car seq)) 105 | (define (rest-exps seq) (cdr seq)) 106 | (define (sequence->exp seq) 107 | (cond ((null? seq) seq) 108 | ((last-exp? seq) (first-exp seq)) 109 | (else (make-begin seq)))) 110 | (define (make-begin seq) (cons 'begin seq)) 111 | (define (application? exp) (pair? exp)) 112 | (define (operator exp) (car exp)) 113 | (define (operands exp) (cdr exp)) 114 | (define (no-operands? ops) (null? ops)) 115 | (define (first-operand ops) (car ops)) 116 | (define (rest-operands ops) (cdr ops)) 117 | (define (cond? exp) (tagged-list? exp 'cond)) 118 | (define (cond-clauses exp) (cdr exp)) 119 | (define (cond-else-clause? clause) 120 | (eq? (cond-predicate clause) 'else)) 121 | (define (cond-predicate clause) (car clause)) 122 | (define (cond-actions clause) (cdr clause)) 123 | (define (cond->if exp) 124 | (expand-clauses (cond-clauses exp))) 125 | (define (expand-clauses clauses) 126 | (if (null? clauses) 127 | 'false ; no else clause 128 | (let ((first (car clauses)) 129 | (rest (cdr clauses))) 130 | (if (cond-else-clause? first) 131 | (if (null? rest) 132 | (sequence->exp (cond-actions first)) 133 | (error "ELSE clause isn't last -- COND->IF" 134 | clauses)) 135 | (make-if (cond-predicate first) 136 | (sequence->exp (cond-actions first)) 137 | (expand-clauses rest)))))) 138 | 139 | 140 | ;-- 4.1 141 | ; These two versions force list-of-value to examine arguments either ltr 142 | ; (left-to-right), i.e. the leftmost one first, or rtl (right-to-left) 143 | (define (list-of-values-ltr exps env) 144 | (if (no-operands? exps) 145 | '() 146 | (let ((arg-ltr (eval (first-operand exps) env))) 147 | (cons arg-ltr 148 | (list-of-values (rest-operands exps) env))))) 149 | (define (list-of-values-rtl exps env) 150 | (if (no-operands? exps) 151 | '() 152 | (let ((arg-rtl (list-of-values (rest-operands exps) env))) 153 | (cons (eval (first-operand exps) env) 154 | arg-rtl)))) 155 | 156 | ;-- 4.2 157 | ; a. If we put procedure application before assignment, (define x 3) will try 158 | ; to call the procedure define with arguments x and 3, which won't work because 159 | ; x is undefined. 160 | 161 | ; b. 162 | ; First, we'll change eval to fit the new order: 163 | (define (eval exp env) 164 | (cond ((self-evaluating? exp) exp) 165 | ((variable? exp) (lookup-variable-value exp env)) 166 | ((quoted? exp) (text-of-quotation exp)) 167 | ((application? exp) 168 | (apply (eval (operator exp) env) 169 | (list-of-values (operands exp) env))) 170 | ((assignment? exp) (eval-assignment exp env)) 171 | ((definition? exp) (eval-definition exp env)) 172 | ((if? exp) (eval-if exp env)) 173 | ((lambda? exp) 174 | (make-procedure (lambda-parameters exp) 175 | (lambda-body exp) 176 | env)) 177 | ((begin? exp) 178 | (eval-sequence (begin-actions exp) env)) 179 | ((cond? exp) (eval (cond->if exp) env)) 180 | (else 181 | (error "Unknown expression type -- EVAL" exp)))) 182 | ; Now we have to modify the application? function: 183 | (define (application? exp) 184 | (tagged-list? exp 'call)) 185 | ; And its helpers: 186 | (define (operator exp) (cadr exp)) 187 | (define (operands exp) (cddr exp)) 188 | 189 | ;-- 4.3 190 | ; Rewrite eval so that the dispatch is done in data-directed style. 191 | ; We'll use MIT Scheme's hash-table implementation 192 | (define operators (make-eq-hash-table)) 193 | (define (put-operator op action) 194 | (hash-table/put! operators op action)) 195 | (define (operator-exists? op) 196 | (hash-table/lookup operators op (lambda (_) #t) (lambda () #f))) 197 | (define (get-operation op) 198 | (hash-table/get operators op '())) 199 | (put-operator 'quote 200 | (lambda (exp env) (text-of-quotation exp))) 201 | (put-operator 'set! 202 | (lambda (exp env) (eval-assignment exp env))) 203 | (put-operator 'define 204 | (lambda (exp env) (eval-definition exp env))) 205 | (put-operator 'if 206 | (lambda (exp env) (eval-if exp env))) 207 | (put-operator 'lambda 208 | (lambda (exp env) 209 | (make-procedure (lambda-parameters exp) 210 | (lambda-body exp) 211 | env))) 212 | (put-operator 'begin 213 | (lambda (exp env) (eval-sequence (begin-actions exp) env))) 214 | (put-operator 'cond 215 | (lambda (exp env) (eval (cond->if exp) env))) 216 | 217 | (define (eval exp env) 218 | (cond ((self-evaluating? exp) exp) 219 | ((variable? exp) (lookup-variable-value exp env)) 220 | ; Data-directed dispatch: 221 | ((operator-exists? (car exp)) 222 | ((get-operation (car exp)) exp env)) 223 | ((application? exp) 224 | (apply (eval (operator exp) env) 225 | (list-of-values (operands exp) env))) 226 | (else 227 | (error "Unknown expression type -- EVAL" exp)))) 228 | 229 | ; Okay, now we'd better test all of that. 230 | ; We're missing the following methods: 231 | (define (lookup-variable-value var env) 232 | (define (env-loop env) 233 | (define (scan vars vals) 234 | (cond ((null? vars) 235 | (env-loop (enclosing-environment env))) 236 | ((eq? var (car vars)) 237 | (car vals)) 238 | (else (scan (cdr vars) (cdr vals))))) 239 | (if (eq? env the-empty-environment) 240 | (error "Unbound variable" var) 241 | (let ((frame (first-frame env))) 242 | (scan (frame-variables frame) 243 | (frame-values frame))))) 244 | (env-loop env)) 245 | (define (enclosing-environment env) (cdr env)) 246 | (define (first-frame env) (car env)) 247 | (define the-empty-environment '()) 248 | (define (setup-environment) 249 | (let ((initial-env 250 | (extend-environment (primitive-procedure-names) 251 | (primitive-procedure-objects) 252 | the-empty-environment))) 253 | (define-variable! 'true true initial-env) 254 | (define-variable! 'false false initial-env) 255 | initial-env)) 256 | (define (primitive-procedure? proc) 257 | (tagged-list? proc 'primitive)) 258 | (define (primitive-implementation proc) (cadr proc)) 259 | (define primitive-procedures 260 | (list (list 'car car) 261 | (list 'cdr cdr) 262 | (list 'cons cons) 263 | (list 'null? null?) 264 | (list '+ +))) 265 | (define (primitive-procedure-names) 266 | (map car 267 | primitive-procedures)) 268 | (define (primitive-procedure-objects) 269 | (map (lambda (proc) (list 'primitive (cadr proc))) 270 | primitive-procedures)) 271 | (define (extend-environment vars vals base-env) 272 | (if (= (length vars) (length vals)) 273 | (cons (make-frame vars vals) base-env) 274 | (if (< (length vars) (length vals)) 275 | (error "Too many arguments supplied" vars vals) 276 | (error "Too few arguments supplied" vars vals)))) 277 | (define (make-frame variables values) 278 | (cons variables values)) 279 | (define (frame-variables frame) (car frame)) 280 | (define (frame-values frame) (cdr frame)) 281 | (define (add-binding-to-frame! var val frame) 282 | (set-car! frame (cons var (car frame))) 283 | (set-cdr! frame (cons val (cdr frame)))) 284 | (define (set-variable-value! var val env) 285 | (define (env-loop env) 286 | (define (scan vars vals) 287 | (cond ((null? vars) 288 | (env-loop (enclosing-environment env))) 289 | ((eq? var (car vars)) 290 | (set-car! vals val)) 291 | (else (scan (cdr vars) (cdr vals))))) 292 | (if (eq? env the-empty-environment) 293 | (error "Unbound variable -- SET!" var) 294 | (let ((frame (first-frame env))) 295 | (scan (frame-variables frame) 296 | (frame-values frame))))) 297 | (env-loop env)) 298 | (define (define-variable! var val env) 299 | (let ((frame (first-frame env))) 300 | (define (scan vars vals) 301 | (cond ((null? vars) 302 | (add-binding-to-frame! var val frame)) 303 | ((eq? var (car vars)) 304 | (set-car! vals val)) 305 | (else (scan (cdr vars) (cdr vals))))) 306 | (scan (frame-variables frame) 307 | (frame-values frame)))) 308 | (define true #t) 309 | (define false #f) 310 | 311 | (define (make-procedure parameters body env) 312 | (list 'procedure parameters body env)) 313 | (define (compound-procedure? p) 314 | (tagged-list? p 'procedure)) 315 | (define (procedure-parameters p) (cadr p)) 316 | (define (procedure-body p) (caddr p)) 317 | (define (procedure-environment p) (cadddr p)) 318 | (define (apply-primitive-procedure proc args) 319 | (apply-in-underlying-scheme 320 | (primitive-implementation proc) args)) 321 | (define the-global-environment (setup-environment)) 322 | 323 | 324 | ; Phew, finally: 325 | (eval '(+ 2 3) the-global-environment) 326 | ; 5 327 | ; Awesome! 328 | 329 | ;-- 4.4 330 | ; First, we have to modify eval: 331 | (define (eval exp env) 332 | (cond ((self-evaluating? exp) exp) 333 | ((variable? exp) (lookup-variable-value exp env)) 334 | ((quoted? exp) (text-of-quotation exp)) 335 | ((assignment? exp) (eval-assignment exp env)) 336 | ((definition? exp) (eval-definition exp env)) 337 | ((if? exp) (eval-if exp env)) 338 | ((and? exp) (eval-and exp env)) 339 | ((or? exp) (eval-or exp env)) 340 | ((lambda? exp) 341 | (make-procedure (lambda-parameters exp) 342 | (lambda-body exp) 343 | env)) 344 | ((begin? exp) 345 | (eval-sequence (begin-actions exp) env)) 346 | ((cond? exp) (eval (cond->if exp) env)) 347 | ((application? exp) 348 | (apply (eval (operator exp) env) 349 | (list-of-values (operands exp) env))) 350 | (else 351 | (error "Unknown expression type -- EVAL" exp)))) 352 | 353 | ; Then we can write and and or helper functions: 354 | (define (and? exp) 355 | (tagged-list? exp 'and)) 356 | (define (or? exp) 357 | (tagged-list? exp 'or)) 358 | (define (eval-and exps env) 359 | (define (eval-operands exps env) 360 | (cond ((null? exps) #t) 361 | ((eval (first-exp exps) env) 362 | (eval-operands (rest-exps exps) env)) 363 | (else #f))) 364 | (eval-operands (rest-exps exps) env)) 365 | (define (eval-or exps env) 366 | (define (eval-operands exps env) 367 | (cond ((null? exps) #f) 368 | ((eval (first-exp exps) env) #t) 369 | (else 370 | (eval-operands (rest-exps exps) env)))) 371 | (eval-operands (rest-exps exps) env)) 372 | 373 | ; Tests: 374 | (eval '(and true true) the-global-environment) 375 | (eval '(and false true true) the-global-environment) 376 | (eval '(or false false false true false) the-global-environment) 377 | (eval '(or false false false) the-global-environment) 378 | 379 | ; As derived expressions: 380 | (define (eval exp env) 381 | (cond ((self-evaluating? exp) exp) 382 | ((variable? exp) (lookup-variable-value exp env)) 383 | ((quoted? exp) (text-of-quotation exp)) 384 | ((assignment? exp) (eval-assignment exp env)) 385 | ((definition? exp) (eval-definition exp env)) 386 | ((if? exp) (eval-if exp env)) 387 | ((and? exp) (eval (and->if exp) env)) 388 | ((or? exp) (eval (or->if exp) env)) 389 | ((lambda? exp) 390 | (make-procedure (lambda-parameters exp) 391 | (lambda-body exp) 392 | env)) 393 | ((begin? exp) 394 | (eval-sequence (begin-actions exp) env)) 395 | ((cond? exp) (eval (cond->if exp) env)) 396 | ((application? exp) 397 | (apply (eval (operator exp) env) 398 | (list-of-values (operands exp) env))) 399 | (else 400 | (error "Unknown expression type -- EVAL" exp)))) 401 | ; and? and or? are the same as above: 402 | (define (and? exp) 403 | (tagged-list? exp 'and)) 404 | (define (or? exp) 405 | (tagged-list? exp 'or)) 406 | ; But this is new: 407 | (define (and->if exps) 408 | (define (expand-and exps) 409 | (if (null? exps) 410 | 'true 411 | (make-if (first-exp exps) 412 | (expand-and (rest-exps exps)) 413 | 'false))) 414 | (expand-and (rest-exps exps))) 415 | (define (or->if exps) 416 | (define (expand-or exps) 417 | (if (null? exps) 418 | 'false 419 | (make-if (first-exp exps) 420 | 'true 421 | (expand-or (rest-exps exps))))) 422 | (expand-or (rest-exps exps))) 423 | 424 | ; Strangely enough, we also need to add this: 425 | (define (true? b) (not (eq? b #f))) 426 | 427 | ; Same tests as above: 428 | (eval '(and true true) the-global-environment) 429 | (eval '(and false true true) the-global-environment) 430 | (eval '(or false false false true false) the-global-environment) 431 | (eval '(or false false false) the-global-environment) 432 | 433 | ;-- 4.5 434 | ; We must support the syntax: 435 | ; (cond ((assoc 'b '((a 1) (b 2))) => cadr) 436 | ; (else false)) 437 | 438 | ; We add the helper functions: 439 | (define (cond-arrow-form? clause) 440 | (eq? (car (cond-actions clause)) '=>)) 441 | (define (cond-arrow-action clause) 442 | (caddr clause)) 443 | ; And modify expand-clauses as follows: 444 | (define (expand-clauses clauses) 445 | (if (null? clauses) 446 | 'false 447 | (let ((first (car clauses)) 448 | (rest (cdr clauses))) 449 | ; We replace the simple if by a ternary cond: our clause can be either an 450 | ; else, an arrow, or a standard clause 451 | (cond ((cond-else-clause? first) 452 | (if (null? rest) 453 | (sequence->exp (cond-actions first)) 454 | (error "ELSE clause isn't last -- COND->IF" 455 | clauses))) 456 | ((cond-arrow-form? first) 457 | (make-if (cond-predicate first) 458 | (list (cond-arrow-action first) 459 | (cond-predicate first)) 460 | (expand-clauses rest))) 461 | (else 462 | (make-if (cond-predicate first) 463 | (sequence->exp (cond-actions first)) 464 | (expand-clauses rest))))))) 465 | 466 | ; Tests: 467 | (eval '(cond ((+ 1 1) => quote) 468 | (false => quote) 469 | (else 1)) 470 | the-global-environment) 471 | ; (+ 1 1) 472 | (eval '(cond (false => quote) 473 | ((+ 2 2) => quote) 474 | (else 1)) 475 | the-global-environment) 476 | ; (+ 2 2) 477 | 478 | ;-- 4.6 479 | ; Support for let 480 | (define (let? exp) 481 | (tagged-list? exp 'let)) 482 | (define let-body cddr) 483 | (define let-associations cadr) 484 | (define (let-symbols exp) 485 | (map car (let-associations exp))) 486 | (define (let-values exp) 487 | (map cadr (let-associations exp))) 488 | (define (let->combination exp) 489 | (cons (make-lambda (let-symbols exp) 490 | (let-body exp)) 491 | (let-values exp))) 492 | ; Tests: 493 | (let->combination '(let ((a (+ 1 5))) (+ a 1))) 494 | ; ((lambda (a) (+ a 1)) (+ 1 5)) 495 | 496 | ; Now we redefine eval: 497 | (define (eval exp env) 498 | (cond ((self-evaluating? exp) exp) 499 | ((variable? exp) (lookup-variable-value exp env)) 500 | ((quoted? exp) (text-of-quotation exp)) 501 | ((assignment? exp) (eval-assignment exp env)) 502 | ((definition? exp) (eval-definition exp env)) 503 | ((if? exp) (eval-if exp env)) 504 | ((let? exp) (eval (let->combination exp) env)) 505 | ((lambda? exp) 506 | (make-procedure (lambda-parameters exp) 507 | (lambda-body exp) 508 | env)) 509 | ((begin? exp) 510 | (eval-sequence (begin-actions exp) env)) 511 | ((cond? exp) (eval (cond->if exp) env)) 512 | ((application? exp) 513 | (apply (eval (operator exp) env) 514 | (list-of-values (operands exp) env))) 515 | (else 516 | (error "Unknown expression type -- EVAL" exp)))) 517 | 518 | (eval '(let ((a (+ 1 5))) (+ a 1)) the-global-environment) 519 | ; 7 520 | 521 | ;-- 4.7 522 | ; let* 523 | (define (make-let assocs body) 524 | (list 'let assocs body)) 525 | (define (let*? exp) 526 | (tagged-list? exp 'let*)) 527 | (define (make-recursive-let assocs body) 528 | (if (null? assocs) 529 | (car body) 530 | (make-let (list (car assocs)) 531 | (make-recursive-let (cdr assocs) body)))) 532 | (define (let*->nested-lets exp) 533 | (make-recursive-let (let-associations exp) (let-body exp))) 534 | 535 | ; Test: 536 | (let*->nested-lets '(let* ((a 1) (b (+ a 1))) b)) 537 | ; (let ((a 1)) (let ((b (+ a 1))) b)) 538 | 539 | ; Now we redefine eval: 540 | (define (eval exp env) 541 | (cond ((self-evaluating? exp) exp) 542 | ((variable? exp) (lookup-variable-value exp env)) 543 | ((quoted? exp) (text-of-quotation exp)) 544 | ((assignment? exp) (eval-assignment exp env)) 545 | ((definition? exp) (eval-definition exp env)) 546 | ((if? exp) (eval-if exp env)) 547 | ((let*? exp) (eval (let*->nested-lets exp) env)) 548 | ((let? exp) (eval (let->combination exp) env)) 549 | ((lambda? exp) 550 | (make-procedure (lambda-parameters exp) 551 | (lambda-body exp) 552 | env)) 553 | ((begin? exp) 554 | (eval-sequence (begin-actions exp) env)) 555 | ((cond? exp) (eval (cond->if exp) env)) 556 | ((application? exp) 557 | (apply (eval (operator exp) env) 558 | (list-of-values (operands exp) env))) 559 | (else 560 | (error "Unknown expression type -- EVAL" exp)))) 561 | 562 | ; Test: 563 | (eval '(let* ((a 1) (b (+ a 1))) b) the-global-environment) 564 | ; 2 565 | 566 | ; As we show, it is indeed possible to evaluate let* in terms of derived 567 | ; expressions (actually, derived derived expressions, because a let* is 568 | ; derived in several let which are in turn derived in lambdas). 569 | ; This is due to the recursive nature of eval. 570 | 571 | ;-- 4.8 572 | ; Named let 573 | 574 | ; From 4.6: 575 | (define (let? exp) 576 | (tagged-list? exp 'let)) 577 | (define let-body cddr) 578 | (define let-associations cadr) 579 | (define (let-symbols exp) 580 | (map car (let-associations exp))) 581 | (define (let-values exp) 582 | (map cadr (let-associations exp))) 583 | ; Added: 584 | (define (named-let? exp) 585 | (not (list? (let-associations exp)))) 586 | (define named-let-fun cadr) 587 | (define named-let-associations caddr) 588 | (define named-let-body cdddr) 589 | (define (named-let-symbols exp) 590 | (map car (named-let-associations exp))) 591 | (define (named-let-values exp) 592 | (map cadr (named-let-associations exp))) 593 | (define (define-let-fun exp) 594 | (list 'define 595 | (cons (named-let-fun exp) 596 | (named-let-symbols exp)) 597 | (car (named-let-body exp)))) 598 | ; Modified: 599 | (define (let->combination exp) 600 | (cond ((named-let? exp) 601 | (cons (make-lambda (named-let-symbols exp) 602 | (cons (define-let-fun exp) 603 | (list (cons (named-let-fun exp) 604 | (named-let-symbols exp))))) 605 | (named-let-values exp))) 606 | (else 607 | (cons (make-lambda (let-symbols exp) 608 | (let-body exp)) 609 | (let-values exp))))) 610 | 611 | ; Test: 612 | (define named-let-test '(let fib-iter ((a 1) 613 | (b 0) 614 | (count n)) 615 | (if (= count 0) 616 | b 617 | (fib-iter (+ a b) a (- count 1))))) 618 | (let->combination named-let-test) 619 | ; ((lambda (a b count) (define (fib-iter a b count) (if (= count 0) b (fib-iter (+ a b) a (- count 1)))) (fib-iter a b count)) 1 0 n) 620 | 621 | ; Let's reindent that to see if it's correct: 622 | ((lambda (a b count) 623 | (define (fib-iter a b count) 624 | (if (= count 0) 625 | b 626 | (fib-iter (+ a b) a (- count 1)))) 627 | (fib-iter a b count)) 628 | 1 0 n) 629 | 630 | (eval '(define (fib n) 631 | (let fib-iter ((a 1) 632 | (b 0) 633 | (count n)) 634 | (if (= count 0) 635 | b 636 | (fib-iter (+ a b) a (- count 1))))) 637 | the-global-environment) 638 | ; ok 639 | (eval '(fib 5) the-global-environment) 640 | ;Unbound variable = 641 | 642 | ; Darn. Can't test this, = is not part of our environment. 643 | ; That said, we can try the combinator by executing the generated code in 644 | ; another Scheme: 645 | (define n 20) 646 | ((lambda (a b count) 647 | (define (fib-iter a b count) 648 | (if (= count 0) 649 | b 650 | (fib-iter (+ a b) a (- count 1)))) 651 | (fib-iter a b count)) 652 | 1 0 n) 653 | ; 6765 654 | ; Correct! 655 | 656 | ;-- 4.9 657 | ; Let's create for. 658 | ; It should be called this way: 659 | (for ((define i 0) (< i 5) (set! i (+ i 1))) 660 | (display i)) 661 | ; And "compile" down to a recursive function. 662 | 663 | (define (for? exp) 664 | (tagged-list? exp 'for)) 665 | (define for-params cadr) 666 | (define (for-init exp) 667 | (car (for-params exp))) 668 | (define (for-cond exp) 669 | (cadr (for-params exp))) 670 | (define (for-iter exp) 671 | (caddr (for-params exp))) 672 | (define for-body caddr) 673 | (define (for-recursion exp) 674 | (list 'define ; NB: we could write a make-definition 675 | (list 'recurse) 676 | (list 'if ; ... and adapt make-if to support alternative-less ifs 677 | (for-cond exp) 678 | (make-begin (list (for-body exp) 679 | (for-iter exp) 680 | (list 'recurse)))))) 681 | (define (for->combination exp) 682 | (list (make-lambda '() 683 | (list (for-init exp) 684 | (for-recursion exp) 685 | (list 'recurse))))) 686 | 687 | ; Test: 688 | (define for-test '(for ((define i 0) (< i 5) (set! i (+ i 1))) (display i))) 689 | (for->combination for-test) 690 | ; Gives: 691 | ((lambda () 692 | (define i 0) 693 | (define (recurse) 694 | (if (< i 5) 695 | (begin (display i) 696 | (set! i (+ i 1)) 697 | (recurse)))) 698 | (recurse))) 699 | ; Given set! and display aren't defined in our implementation, we can execute 700 | ; the generated code in another Scheme to see that it works: 701 | ; 01234 702 | 703 | ;-- 4.10 704 | ; Let's say we change the syntax of if to strange-if, defined as: 705 | ; (strange-if consequent predicate alternative) 706 | ; We only have to change: 707 | (define (if? exp) (tagged-list? exp 'strange-if)) 708 | (define (if-predicate exp) (caddr exp)) 709 | (define (if-consequent exp) (cadr exp)) 710 | (define (if-alternative exp) 711 | (if (not (null? (cdddr exp))) 712 | (cadddr exp) 713 | 'false)) 714 | (define (make-if predicate consequent alternative) 715 | (list 'strange-if consequent predicate alternative)) 716 | 717 | ; Test: 718 | (eval '(strange-if true (+ 1 1) false) the-global-environment) 719 | ; #t 720 | 721 | ;-- 4.11 722 | ; Instead of representing a frame as a pair of lists, we can represent a frame 723 | ; as a list of bindings, where each binding is a name-value pair. 724 | (define (make-frame variables values) 725 | (zip variables values)) 726 | (define (frame-variables frame) (map car frame)) 727 | (define (frame-values frame) (map cadr frame)) 728 | (define (add-binding-to-frame! var val frame) 729 | (set-cdr! frame (cons (car frame) (cdr frame))) 730 | (set-car! frame (list var val))) 731 | 732 | ; Let's try: 733 | (eval '(+ 2 3) the-global-environment) 734 | ; Value: 5 735 | ; Good! 736 | (eval '(define a 10) the-global-environment) 737 | ; Value: ok 738 | ; Good! 739 | (eval 'a the-global-environment) 740 | ; 10 741 | ; Perfect! 742 | 743 | ;-- 4.12 744 | (define (lookup-variable-value var env) 745 | (define (env-loop env) 746 | (if (eq? env the-empty-environment) 747 | (error "Unbound variable" var) 748 | (let ((frame (first-frame env))) 749 | (scan frame 750 | var 751 | '() 752 | #f 753 | (lambda () 754 | (env-loop (enclosing-environment env))))))) 755 | (env-loop env)) 756 | (define (set-variable-value! var val env) 757 | (define (env-loop env) 758 | (if (eq? env the-empty-environment) 759 | (error "Unbound variable -- SET!" var) 760 | (let ((frame (first-frame env))) 761 | (scan frame 762 | var 763 | val 764 | #t 765 | (lambda () 766 | (env-loop (enclosing-environment env))))))) 767 | (env-loop env)) 768 | (define (define-variable! var val env) 769 | (let ((frame (first-frame env))) 770 | (scan frame 771 | var 772 | val 773 | #t 774 | (lambda () 775 | (add-binding-to-frame! var val frame))))) 776 | ; These three methods all perform a search of the environment. 777 | (define (scan frame var val set callback) 778 | (define (scan-iter vars vals) 779 | (cond ((null? vars) 780 | (callback)) 781 | ((eq? var (car vars)) 782 | (if set 783 | (set-car! vals val) 784 | (car vals))) 785 | (else (scan-iter (cdr vars) (cdr vals))))) 786 | (scan-iter (frame-variables frame) (frame-values frame))) 787 | 788 | ; Test: 789 | (eval '(define b 10) the-global-environment) 790 | ; ok 791 | (eval 'b the-global-environment) 792 | ; 10 793 | 794 | ;-- 4.13 795 | ; Design an un-binding mechanism 796 | ; Helper functions: 797 | (define (undefinition? exp) 798 | (tagged-list? exp 'make-unbound!)) 799 | (define (undefinition-variable exp) (cadr exp)) 800 | (define (eval-undefinition exp env) 801 | (undefine-variable! (undefinition-variable exp) 802 | env) 803 | 'ok) 804 | ; Reminder: our variable list for each is composed of two lists: one containing 805 | ; the variable names, the other containing the actual values. 806 | ; We'll only look for the variable in the first frame. 807 | (define (undefine-variable! var env) 808 | (let ((frame (first-frame env))) 809 | (define (scan vars vals) 810 | (cond ((null? vars) 811 | (error "Variable does not exist -- MAKE-UNBOUND!" var)) 812 | ((eq? var (car vars)) ; Remove binding: 813 | (set-car! vars (cdr vars))) 814 | (else (scan (cdr vars) (cdr vals))))) 815 | (scan (frame-variables frame) 816 | (frame-values frame)))) 817 | ; Then we redefine eval: 818 | (define (eval exp env) 819 | (cond ((self-evaluating? exp) exp) 820 | ((variable? exp) (lookup-variable-value exp env)) 821 | ((quoted? exp) (text-of-quotation exp)) 822 | ((assignment? exp) (eval-assignment exp env)) 823 | ((definition? exp) (eval-definition exp env)) 824 | ((undefinition? exp) (eval-undefinition exp env)) 825 | ((if? exp) (eval-if exp env)) 826 | ((let? exp) (eval (let->combination exp) env)) 827 | ((lambda? exp) 828 | (make-procedure (lambda-parameters exp) 829 | (lambda-body exp) 830 | env)) 831 | ((begin? exp) 832 | (eval-sequence (begin-actions exp) env)) 833 | ((cond? exp) (eval (cond->if exp) env)) 834 | ((application? exp) 835 | (apply (eval (operator exp) env) 836 | (list-of-values (operands exp) env))) 837 | (else 838 | (error "Unknown expression type -- EVAL" exp)))) 839 | 840 | ; Test: 841 | (eval 'a the-global-environment) 842 | ; Unbound variable a 843 | (eval '(define a 12) the-global-environment) 844 | ;Value: ok 845 | (eval 'a the-global-environment) 846 | ;Value: 12 847 | (eval '(make-unbound! a) the-global-environment) 848 | ;Value: ok 849 | (eval 'a the-global-environment) 850 | ; Unbound variable a 851 | 852 | ;-- 4.14 853 | ; Eva's version works as intended because it is interpreted inside the Scheme 854 | ; interpreter we wrote. However, Louis' version calls the underlying Scheme's 855 | ; "apply", instead of our interpreted "apply"... Hence things going awry. 856 | 857 | ;-- 4.15 858 | ; Given a one-argument procedure p and an object a, p is said to ``halt'' on a 859 | ; if evaluating the expression (p a) returns a value (as opposed to terminating 860 | ; with an error message or running forever). Show that it is impossible to 861 | ; write a procedure halts? that correctly determines whether p halts on a for 862 | ; any procedure p and object a. Use the following reasoning: If you had such a 863 | ; procedure halts?, you could implement the following program: 864 | (define (run-forever) (run-forever)) 865 | (define (try p) 866 | (if (halts? p p) 867 | (run-forever) 868 | 'halted)) 869 | ; Now consider evaluating the expression (try try) and show that any possible 870 | ; outcome (either halting or running forever) violates the intended behavior of 871 | ; halts? 872 | 873 | ; The two possible outcomes when we run (try try) are: 874 | ; - (try try) runs forever: it means that the condition inside try has been 875 | ; found correct, i.e. that (halts? try try) is true. But we hypothesised it 876 | ; runs forever. Contradiction. 877 | ; - (try try) returns 'halted: it means that the condition inside try has been 878 | ; found false, i.e. that (halts? try try) is false. But we hypothesised it does 879 | ; halt. Contradition. 880 | 881 | ;-- 4.16 882 | ; (Uses let from 4.6 and functions defined in 4.12) 883 | ; a. 884 | (define (lookup-variable-value var env) 885 | (define (env-loop env) 886 | (if (eq? env the-empty-environment) 887 | (error "Unbound variable" var) 888 | (let ((frame (first-frame env))) 889 | (scan frame 890 | var 891 | '() 892 | #f 893 | (lambda () 894 | (env-loop (enclosing-environment env))))))) 895 | (let ((value (env-loop env))) 896 | (if (eq? value '*unassigned*) 897 | (error "Unassigned value for variable:" var) 898 | value))) 899 | ; Test: 900 | (eval '(define a '*unassigned*) the-global-environment) 901 | ; ok 902 | (eval 'a the-global-environment) 903 | ; *** ERROR IN (console)@568.1 -- Unassigned value for variable: a 904 | 905 | ; b. 906 | ; Helper functions, if they're not defined in your Scheme: 907 | (define (filter predicate list) 908 | (cond ((null? list) '()) 909 | ((predicate (car list)) 910 | (cons (car list) (filter predicate (cdr list)))) 911 | (else 912 | (filter predicate (cdr list))))) 913 | (define (last list) 914 | (cond ((null? list) '()) 915 | ((null? (cdr list)) (car list)) 916 | (else (last (cdr list))))) 917 | (define (zip a b) 918 | (if (null? a) 919 | '() 920 | (cons (list (car a) (car b)) (zip (cdr a) (cdr b))))) 921 | (define (scan-out-defines body) 922 | (let* ((definitions (filter definition? body)) 923 | (rest-of-lambda (cdr (memq (last definitions) body))) 924 | (symbols (map cadr definitions)) 925 | (bodies (map caddr definitions))) 926 | (append (list 'let 927 | (map (lambda (s) (cons s (cons '*unassigned* '()))) 928 | symbols)) 929 | (map (lambda (s) (list 'set! (cadr s) (caddr s))) 930 | definitions) 931 | rest-of-lambda))) 932 | ; Test: 933 | (define test '((define u true) 934 | (define v false) 935 | (its-the-lambda-rest))) 936 | (scan-out-defines test) 937 | ; (let ((u *unassigned*) (v *unassigned*)) 938 | ; (set! u true) 939 | ; (set! v false) 940 | ; (its-the-lambda-rest)) 941 | 942 | ; All good. 943 | 944 | ; c. 945 | (define (procedure-body p) 946 | (scan-out-defines (caddr p))) 947 | ; Test: 948 | (define test '(lambda (a b c) 949 | (define u 1) 950 | (define v 3) 951 | (+ u v))) 952 | (eval test the-global-environment) 953 | ; Does a procedure as expected. 954 | (define test2 '(define (ll a b c) 955 | (define d 1) 956 | (+ a b c d))) 957 | (eval test2 the-global-environment) 958 | (eval '(ll 1 2 3) the-global-environment) 959 | 960 | ; Alright, so. This code is wrong. It blows up somewhere between evaluating and 961 | ; executing, as far as I can tell. I spent too much time staring blankly at the 962 | ; code already; to fix someday. 963 | 964 | ;-- 4.17 965 | ; (Imagine drawings) 966 | 967 | ;-- 4.18 968 | ; This will work in 4.16's way, but not in the alternative strategy. 969 | 970 | ;-- 4.19 971 | ; I support Ben's point of view. f is a closure over the bound variable a, which 972 | ; gets overwritten in the function scope when redefined. 4.16's behaviour is 973 | ; indeed as described by Alyssa, but should stay an implementation detail. 974 | ; This is very much of a procedural-oriented way of thinking, because it doesn't 975 | ; satisfy the condition of simultaneity that should be part of a suite of 976 | ; definitions. 977 | ; Eva's way is the best, but is hard to implement: it would require definitions 978 | ; to be processed in a certain order, and/or to be scanned out for 979 | ; yet-unprocessed definitions and put on hold until those have been evaluated. 980 | 981 | ;-- 4.20 982 | ; 983 | 984 | ;-- 4.21 985 | ; Haaa! That's the Y Combinator! *brain 'splodes* 986 | ; Putting this part of Chapter 4 on hold until my brain gets bigger. 987 | 988 | 989 | 990 | ;-- 4.25 991 | (define (unless condition usual-value exceptional-value) 992 | (if condition exceptional-value usual-value)) 993 | (define (factorial n) 994 | (unless (= n 1) 995 | (* n (factorial (- n 1))) 996 | 1)) 997 | (factorial 5) 998 | ; This never stops. Why? 999 | ; After all, it we transpose unless as if, it gives: 1000 | (define (if-factorial n) 1001 | (if (= n 1) 1002 | 1 1003 | (* n (if-factorial (- n 1))))) 1004 | ; And that works. So where's the catch? 1005 | 1006 | ; The catch is in applicative-order. 1007 | ; When we want to apply factorial, we apply unless and eval its arguments. But 1008 | ; one of these arguments is factorial, which contains an unless, which is 1009 | ; converted to an if. But this if also has factorial which has an unless which 1010 | ; needs to be converted to an if - and so on ad infinitum. 1011 | 1012 | ; With lazy evaluation, factorial would be evaluated once when n is 5. Then 1013 | ; evaluated a second time when n is 4, and so on until n is 1 and we don't need 1014 | ; to eval factorial any more. 1015 | 1016 | ;-- 4.26 1017 | ; Ben's solution is easy. I don't think I understand Alyssa's solution. 1018 | 1019 | ;-- 4.27 1020 | (define count 0) 1021 | (define (id x) 1022 | (set! count (+ count 1)) 1023 | x) 1024 | (define w (id (id 10))) 1025 | ;;; L-Eval input: 1026 | count 1027 | ;;; L-Eval value: 1028 | 0 1029 | ; Nothing has been evaluated yet. w received a mere thunk, but has not been 1030 | ; executed because of laziness. 1031 | ;;; L-Eval input: 1032 | w 1033 | ;;; L-Eval value: 1034 | 10 1035 | ; id returns its input value, in this case the value of the (now executed) 1036 | ; (id 10) thunk. 1037 | ;;; L-Eval input: 1038 | count 1039 | ;;; L-Eval value: 1040 | 2 1041 | ; The two (id) and their side-effects have been forced to execute due to 1042 | ; evaluating w 1043 | 1044 | ;-- 4.28 1045 | (define (alittlebitsofternow) -) 1046 | (define (alittlebitfasternow) +) 1047 | (define shout #t) 1048 | (define (speed) 1049 | (if shout 1050 | (alittlebitsofternow) 1051 | (alittlebitfasternow))) 1052 | (define (songpart) 1053 | ((speed) 1 1)) 1054 | 1055 | ; We have to evaluate the operator (speed) here. If we didn't, we wouldn't know 1056 | ; how to apply those arguments to a thunk. 1057 | 1058 | ;-- 4.29 1059 | ; Canonical example is the naive fibonacci: 1060 | (define (fibonacci n) 1061 | (if (or (= n 0) 1062 | (= n 1)) 1063 | 1 1064 | (+ (fibonacci (- n 1)) 1065 | (fibonacci (- n 2))))) 1066 | 1067 | ; As is, this function does an exponential number of function calls — which is 1068 | ; bad. Memoizing allows us to cut that number dramatically and make the number 1069 | ; of function calls O(n) 1070 | 1071 | (define (square x) 1072 | (* x x)) 1073 | ;;; L-Eval input: 1074 | (square (id 10)) 1075 | ;;; L-Eval value: 1076 | 100 1077 | ;;; L-Eval input: 1078 | count 1079 | ;;; L-Eval value: 1080 | ; With memoization: 1081 | 1 ; because (id 10) has been called once and memoized 1082 | ; Without: 1083 | 2 ; because (id 10) has been called twice 1084 | 1085 | ;-- 4.30 1086 | ; I don't know. 1087 | 1088 | ;-- 4.31 1089 | ; Insert large rewrite of the interpreter. 1090 | 1091 | ;-- 4.32 1092 | ; Making the car as lazy as the cdr allows for completely-lazy data structures, 1093 | ; such as trees. Before that, we'd have had to make sure the car was something 1094 | ; easily computable and/or small, because it'd be evaluated as soon as the 1095 | ; element is accessed - now it can be lazy. 1096 | 1097 | ;-- 4.33 1098 | ; '(a b) is seen by the parser as (quote (a b)). This leaves out our tuned cons 1099 | ; and makes both approaches incompatible. 1100 | ; The solution is to replace the parser of quotations in a way that it'll 1101 | ; provide lazy lists that we can manipulate with the lazy car and the lazy cdr. 1102 | 1103 | ;-- 4.34 1104 | ; You're on your own, buddy. 1105 | 1106 | ;-- 4.35 1107 | ; At first, I wanted to use: 1108 | (define (an-integer-between low high) 1109 | (if (= low high) 1110 | high 1111 | (amb low (an-integer-between (+ low 1) high)))) 1112 | ; But is seems more in the spirit of the chapter to write: 1113 | (define (an-integer-between low high) 1114 | (require (<= low high)) 1115 | (amb low (an-integer-between (+ low 1) high))) 1116 | 1117 | ;-- 4.36 1118 | ; This won't work due to the way amb works. Depth-first backtracking means that 1119 | ; amb will try values of i, j, k as (1 1 1) first, then (1 1 2), then (1 1 3), 1120 | ; etc, trying to cover all the possible values of k. 1121 | 1122 | ; Instead, we can write: 1123 | (define (pythagorean-triples) 1124 | (letrec ((k (an-integer-starting-from 1)) 1125 | (j (an-integer-between 1 k)) 1126 | (i (an-integer-between 1 j))) 1127 | (require (= (+ (* i i) (* j j)) (* k k))) 1128 | (list i j k))) 1129 | ; Here, we're inverting the order of integers to use depth-first search to our 1130 | ; advantage. amb will start by incrementing i, then j, and k in last resort, 1131 | ; yielding all the possible triplets that can give pythagorean numbers. These 1132 | ; triplets will then be checked to be pythagorean by the 'require' clause. 1133 | 1134 | ;-- 4.37 1135 | ; Yes, Ben's technique is more efficient: he adds i² and j², then checks if the 1136 | ; square root of this sum (an hypothetical k) is an integer. This allows him to 1137 | ; only iterate on two values instead of three, i.e. for a given i and j, he 1138 | ; doesn't have to go through several values of k to determine if this is a 1139 | ; pythagorean triple or not. 1140 | ; 1141 | ; Another optimisation is discarding every (i, j) combination where 1142 | ; i²+j² > high², a case where no solution would be acceptable. 1143 | 1144 | ;-- 4.38 1145 | ; We'll see when implementing (amb). 1146 | 1147 | ;-- 4.39 1148 | ; The order of the conditions doesn't affect the answer, but can affect how 1149 | ; long the program takes to run. If we put the more restrictive conditions 1150 | ; first, then a lot of unnecessary checks will never be done. 1151 | 1152 | ;-- 4.40 1153 | ; Before: 5^5 = 3125 1154 | ; After: 5! = 120 1155 | 1156 | ; An attempt to make it faster: 1157 | (define (multiple-dwelling) 1158 | (let ((baker (amb 1 2 3 4))) 1159 | (let ((cooper (amb 2 3 4 5))) 1160 | (let ((fletcher (amb 2 3 4))) 1161 | (let ((miller (amb 1 2 3 4 5))) 1162 | (require (> miller cooper)) 1163 | (let ((smith (amb 1 2 3 4 5))) 1164 | (require (not (= (abs (- smith fletcher)) 1))) 1165 | (require (not (= (abs (- fletcher cooper)) 1))) 1166 | (list (list 'baker baker) 1167 | (list 'cooper cooper) 1168 | (list 'fletcher fletcher) 1169 | (list 'miller miller) 1170 | (list 'smith smith)))))))) 1171 | 1172 | ;-- 4.41 1173 | ; Following permutation function and helpers provided by the Rosetta Code wiki 1174 | (define (insert l n e) 1175 | (if (= 0 n) 1176 | (cons e l) 1177 | (cons (car l) 1178 | (insert (cdr l) (- n 1) e)))) 1179 | 1180 | (define (seq start end) 1181 | (if (= start end) 1182 | (list end) 1183 | (cons start (seq (+ start 1) end)))) 1184 | 1185 | (define (permute l) 1186 | (if (null? l) 1187 | '(()) 1188 | (apply append (map (lambda (p) 1189 | (map (lambda (n) 1190 | (insert p n (car l))) 1191 | (seq 0 (length p)))) 1192 | (permute (cdr l)))))) 1193 | 1194 | ; And solving code by yours truly 1195 | (define (ok-arrangement r) 1196 | (letrec ((baker (car r)) 1197 | (cooper (cadr r)) 1198 | (fletcher (caddr r)) 1199 | (miller (cadddr r)) 1200 | (smith (car (cddddr r)))) 1201 | ; Make sure a floor arrangement conforms to the rules 1202 | (and (not (= baker 5)) 1203 | (and (not (= cooper 1)) 1204 | (and (not (or (= fletcher 1) (= fletcher 5))) 1205 | (and (> miller cooper) 1206 | (and (not (= (abs (- smith fletcher)) 1)) 1207 | (and (not (= (abs (- fletcher cooper)) 1)))))))))) 1208 | 1209 | (define (solve) 1210 | (define (solve-with-solutions s) 1211 | (if (ok-arrangement (car s)) 1212 | (car s) 1213 | (solve-with-solutions (cdr s)))) 1214 | (solve-with-solutions (permute '(1 2 3 4 5)))) 1215 | 1216 | (solve) 1217 | ; (3 2 4 5 1) 1218 | 1219 | ;-- 4.42 1220 | ; We will solve this problem in a similar manner to 4.38 1221 | (define (solve) 1222 | (define betty (amb 1 2 3 4 5)) 1223 | (define ethel (amb 1 2 3 4 5)) 1224 | (define joan (amb 1 2 3 4 5)) 1225 | (define kitty (amb 1 2 3 4 5)) 1226 | (define mary (amb 1 2 3 4 5)) 1227 | ; We'll use not equal as a subsitute for xor; it is logically equivalent 1228 | (require (not (equal? (= kitty 2) (= betty 3)))) 1229 | (require (not (equal? (= ethel 1) (= joan 2)))) 1230 | (require (not (equal? (= joan 3) (= ethel 5)))) 1231 | (require (not (equal? (= kitty 2) (= mary 4)))) 1232 | (require (not (equal? (= mary 4) (= betty 1)))) 1233 | (list (list 'betty betty) 1234 | (list 'ethel ethel) 1235 | (list 'joan joan) 1236 | (list 'kitty kitty) 1237 | (list 'mary mary))) 1238 | 1239 | -------------------------------------------------------------------------------- /Chapter 2.scm: -------------------------------------------------------------------------------- 1 | ;-- 2.1 2 | (define (make-rat n d) 3 | (let ((g (gcd n d))) 4 | (cons (/ n g) (/ d g)))) 5 | 6 | (define (make-rat n d) 7 | (let ((g (gcd n d))) 8 | (cons (/ (if (or (and (< n 0) (< d 0)) (and (> n 0) (< d 0))) 9 | (- n) 10 | n) 11 | g) 12 | (/ (if (or (and (< n 0) (< d 0)) (and (> n 0) (< d 0))) 13 | (- d) 14 | d) 15 | g)))) 16 | 17 | ; Clever version, from http://community.schemewiki.org/?sicp-ex-2.1 18 | (define (make-rat n d) 19 | (let ((g ((if (< d 0) - +) (gcd n d)))) 20 | (cons (/ n g) (/ d g)))) 21 | 22 | ;-- 2.2 23 | (define (make-segment x y) (cons x y)) 24 | (define (start-segment s) (car s)) 25 | (define (end-segment s) (cdr s)) 26 | 27 | (define (make-point x y) (cons x y)) 28 | (define (x-point p) (car p)) 29 | (define (y-point p) (cdr p)) 30 | 31 | (define (average x y) (/ (+ x y) 2)) 32 | (define (midpoint-segment s) 33 | (make-point (average (x-point (start-segment s)) 34 | (x-point (end-segment s))) 35 | (average (y-point (start-segment s)) 36 | (y-point (end-segment s))))) 37 | 38 | ; Given: 39 | (define (print-point p) 40 | (newline) 41 | (display "(") 42 | (display (x-point p)) 43 | (display ",") 44 | (display (y-point p)) 45 | (display ")")) 46 | 47 | ;-- 2.3 48 | (define (rectangle a b c d) ; Where a, b, c and d are (x,y) pairs representing 49 | ; points coordinates as : a b 50 | (cons (cons a b) (cons c d))) ; d c 51 | (define (point_a r) (car (car r))) 52 | (define (point_b r) (cdr (car r))) 53 | (define (point_c r) (car (cdr r))) 54 | (define (point_d r) (cdr (cdr r))) 55 | (define (distance a b) 56 | (sqrt (+ (square (- (x-point b) (x-point a))) 57 | (square (- (y-point b) (y-point a)))))) 58 | (define (width r) 59 | (distance (point_a r) (point_b r))) 60 | (define (height r) 61 | (distance (point_b r) (point_c r))) 62 | 63 | (define (perimeter r) 64 | (+ (* 2 (height r)) 65 | (* 2 (width r)))) 66 | (define (area r) 67 | (* (height r) (width r))) 68 | 69 | (define r_test (rectangle (cons 1 3) (cons 4 3) (cons 4 (- 1)) (cons 1 (- 1)))) 70 | (perimeter r_test) 71 | (area r_test) 72 | 73 | ;-- 2.4 74 | (define (cons24 x y) 75 | (lambda (m) (m x y))) 76 | (define (car24 z) 77 | (z (lambda (p q) p))) 78 | (define (cdr24 z) 79 | (z (lambda (p q) q))) 80 | 81 | ;-- 2.5 82 | 83 | ;-- 2.6 84 | (define zero (lambda (f) (lambda (x) x))) 85 | 86 | (define (add-1 n) 87 | (lambda (f) (lambda (x) (f ((n f) x))))) 88 | 89 | ; we'll find (one) by substitution 90 | ; one => (add-1 zero) 91 | ; (lambda (f) (lambda (x) (f ((zero f) x)))) 92 | ; (lambda (f) (lambda (x) (f x))) 93 | 94 | ;-- 2.7 - 2.16 95 | 96 | ;-- 2.17 97 | (define (last-pair l) 98 | (if (null? (cdr l)) 99 | l 100 | (last-pair (cdr l)))) 101 | 102 | ; Test: 103 | (last-pair (list 1 2 3 4)) 104 | 105 | ;-- 2.18 106 | (define (reverse alist) 107 | (if (null? (cdr alist)) 108 | alist 109 | (append (reverse (cdr alist)) 110 | (list (car alist))))) 111 | 112 | ; Test: 113 | (reverse (list 1 2 3 4)) 114 | 115 | ;-- 2.19 116 | (define (first-denomination coin-values) 117 | (car coin-values)) 118 | (define (except-first-denomination coin-values) 119 | (cdr coin-values)) 120 | (define (no-more? coin-values) 121 | (null? coin-values)) 122 | (define (cc amount coin-values) 123 | (cond ((= amount 0) 1)((or (< amount 0) (no-more? coin-values)) 0) 124 | (else 125 | (+ (cc amount 126 | (except-first-denomination coin-values)) 127 | (cc (- amount 128 | (first-denomination coin-values)) 129 | coin-values))))) 130 | 131 | ;-- 2.20 132 | (define (same-parity . numberlist) 133 | (define (filter li condition) 134 | (if (null? li) 135 | li 136 | (if (condition (car li)) 137 | (append (list (car li)) (filter (cdr li) condition)) 138 | (filter (cdr li) condition)))) 139 | (if (even? (car numberlist)) 140 | (filter numberlist even?) 141 | (filter numberlist (lambda (x) (not (even? x)))))) 142 | 143 | ;-- 2.21 144 | (define (square-list items) 145 | (if (null? items) 146 | nil 147 | (cons (* (car items) (car items)) 148 | (square-list (cdr items))))) 149 | (define (square-list items) 150 | (map (lambda (x) (* x x)) items)) 151 | 152 | ;-- 2.22 153 | ; The first version won't work because the items are popped from the 154 | ; first list and then pushed in the second � resulting in a reverse 155 | ; order. 156 | ; The second version won't work because "cons"-ing a list to an int 157 | ; results in a list-in-a-list ((a b) c); contrary to "cons"-ing an 158 | ; int to a list which gives a list (a b c). 159 | 160 | ;-- 2.23 161 | (define (for-each fun lis) 162 | (cond ((null? lis) #t) 163 | (else (fun (car lis)) 164 | (for-each fun (cdr lis))))) 165 | 166 | ;-- 2.24 167 | (list 1 (list 2 (list 3 4))) 168 | ; Interpreter: (1 (2 (3 4))) 169 | ; Boxes: [.|.]->[.|x] 170 | ; v v 171 | ; [1] [.|.]-> [.|x] 172 | ; v v 173 | ; [2] [.|.]->[.|x] 174 | ; v v 175 | ; [3] [4] 176 | ; 177 | ; Tree: (1 (2 (3 4))) 178 | ; / \ 179 | ; 1 (2 (3 4)) 180 | ; / \ 181 | ; 2 (3 4) 182 | ; / \ 183 | ; 3 4 184 | 185 | ;-- 2.25 186 | ; Give combinations of cars and cdrs that will pick 7 from each of the 187 | ; following lists: 188 | ; (1 3 (5 7) 9) 189 | (define A (list 1 3 (list 5 7) 9)) 190 | (car (cdr (car (cdr (cdr a))))) 191 | ; ((7)) 192 | (define B (list (list 7))) 193 | (car (car B)) 194 | ; (1 (2 (3 (4 (5 (6 7)))))) 195 | (define C (list 1 (list 2 (list 3 (list 4 (list 5 (list 6 7))))))) 196 | (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr C)))))))))))) 197 | 198 | ;-- 2.26 199 | ; Suppose we define x and y to be two lists: 200 | (define x (list 1 2 3)) 201 | (define y (list 4 5 6)) 202 | ; What result is printed by the interpreter in response to evaluating each of 203 | ; the following expressions: 204 | (append x y) 205 | ; (1 2 3 4 5 6) 206 | (cons x y) 207 | ; ((1 2 3) 4 5 6) 208 | (list x y) 209 | ; ((1 2 3)(4 5 6)) 210 | 211 | ;-- 2.27 212 | (define (deep-reverse li) 213 | (cond ((null? li) li) 214 | (else (append (deep-reverse (cdr li)) 215 | (list (if (pair? (car li)) 216 | (deep-reverse (car li)) 217 | (car li))))))) 218 | ; Test: 219 | (define x (list (list 1 2) (list 3 (list 4 5)))) 220 | (deep-reverse x) 221 | 222 | ;-- 2.28 223 | (define (fringe node) 224 | (if (pair? node) 225 | (append (fringe (car node)) 226 | (fringe (cdr node))) 227 | (if (null? node) 228 | '() 229 | (list node)))) 230 | ; Test: 231 | (define x (list (list 1 2) (list 3 4))) 232 | (fringe x) 233 | ; (1 2 3 4) 234 | (fringe (list x x)) 235 | ; (1 2 3 4 1 2 3 4) 236 | 237 | ;-- 2.29 238 | (define (make-mobile left right) 239 | (list left right)) 240 | (define (make-branch length structure) 241 | (list length structure)) 242 | 243 | ; a. 244 | (define (left-branch mobile) (car mobile)) 245 | (define (right-branch mobile) (car (cdr mobile))) 246 | (define (branch-length branch) (car branch)) 247 | (define (branch-structure branch) (car (cdr branch))) 248 | 249 | ; b. 250 | (define (branch-weight branch) 251 | (let ((sub (branch-structure branch))) 252 | (if (structure-is-mobile? sub) 253 | (total-weight sub) 254 | sub))) 255 | (define (total-weight mobile) 256 | (+ (branch-weight (left-branch mobile)) 257 | (branch-weight (right-branch submobile)))) 258 | 259 | ; c. 260 | (define (balanced? mobile) 261 | (= (branch-weight (left-branch mobile)) 262 | (branch-weight (right-branch mobile)))) 263 | 264 | ; d. 265 | 266 | 267 | ; Tests: 268 | (left-branch (make-mobile 2 3)) 269 | (right-branch (make-mobile 2 3)) 270 | (branch-length (make-branch 4 5)) 271 | (branch-structure (make-branch 4 5)) 272 | 273 | ;-- 2.30 274 | (define (square-tree tree) 275 | (cond ((null? tree) nil) 276 | ((not (pair? tree)) (* tree tree)) 277 | (else (cons (square-tree (car tree)) 278 | (square-tree (cdr tree)))))) 279 | ; With map: 280 | (define (square-tree-map tree) 281 | (map (lambda (x) 282 | (cond ((null? x) nil) 283 | ((not (pair? x)) (* x x)) 284 | (else (square-tree-map x)))) 285 | tree)) 286 | ; Tests: 287 | (define my-tree (list 1 (list 2 (list 3 4) 5) (list 6 7))) 288 | (square-tree my-tree) 289 | (square-tree-map my-tree) 290 | 291 | ;-- 2.31 292 | (define (tree-map function tree) 293 | (cond ((null? tree) nil) 294 | ((not (pair? tree)) (function tree)) 295 | (else (cons (tree-map function (car tree)) 296 | (tree-map function (cdr tree)))))) 297 | 298 | ;-- 2.32 299 | (define (subsets s) 300 | (if (null? s) 301 | (list nil) 302 | (let ((rest (subsets (cdr s)))) 303 | (append rest 304 | (map (lambda (x) (cons (car s) x)) 305 | rest))))) 306 | ; Test: 307 | (subsets (list 1 2 3)) 308 | ; NB: doesn't seem to work well on sisc-scheme. 309 | 310 | ;-- 2.33 311 | (define (accumulate op initial sequence) 312 | (if (null? sequence) 313 | initial 314 | (op (car sequence) 315 | (accumulate op initial (cdr sequence))))) 316 | (define (map p sequence) 317 | (accumulate (lambda (x y) (cons (p x) y)) 318 | nil 319 | sequence)) 320 | (define (append seq1 seq2) 321 | (accumulate cons 322 | seq2 323 | seq1)) 324 | (define (length sequence) 325 | (accumulate (lambda (x y) (+ 1 y)) 326 | 0 327 | sequence)) 328 | 329 | ;-- 2.34 330 | (define (horner-eval x coefficient-sequence) 331 | (accumulate (lambda (this-coeff higher-terms) (+ (* x higher-terms) 332 | this-coeff)) 333 | 0 334 | coefficient-sequence)) 335 | ; Test: 336 | (horner-eval 2 (list 1 3 0 5 0 1)) 337 | ; => 79 338 | 339 | ;-- 2.35 340 | (define (count-leaves t) 341 | (accumulate + 342 | 0 343 | (map (lambda (node) 344 | (if (pair? node) (count-leaves node) 1)) 345 | t))) 346 | ; Test: 347 | (count-leaves (list (list 1 2 3) (list (list 1 2) (list 2)) 2 3 (list 1 2))) 348 | ; => 10 349 | 350 | ;-- 2.36 351 | (define (accumulate-n op init seqs) 352 | (if (null? (car seqs)) 353 | nil 354 | (cons (accumulate op init (map car seqs)) 355 | (accumulate-n op init (map cdr seqs))))) 356 | ; Test: 357 | (define listoflist (list (list 1 2 3) 358 | (list 4 5 6) 359 | (list 7 8 9) 360 | (list 10 11 12))) 361 | (accumulate-n + 0 listoflist) 362 | ; => (22 26 30) 363 | 364 | ;-- 2.37 365 | (define (dot-product v w) 366 | (accumulate + 0 (map * v w))) 367 | 368 | (define (matrix-*-vector m v) 369 | (map (lambda (x) (dot-product x v)) 370 | m)) 371 | (define (transpose mat) 372 | (accumulate-n cons 373 | '() 374 | mat)) 375 | (define (matrix-*-matrix m n) 376 | (let ((cols (transpose n))) 377 | (map (lambda (x) (matrix-*-vector cols x)) 378 | m))) 379 | 380 | ; Tests: 381 | (define matrix (list (list 1 2 3 4) (list 4 5 6 6) (list 6 7 8 9))) 382 | (define identity-vector (list 1 1 1 1)) 383 | (define double-vector (list 2 2 2 2)) 384 | (matrix-*-vector matrix identity-vector) 385 | ; => (10 21 30) 386 | (matrix-*-vector matrix double-vector) 387 | ; => (20 42 60) 388 | (transpose matrix) 389 | ; => ((1 4 6) (2 5 7) (3 6 8) (4 6 9)) 390 | (matrix-*-matrix matrix matrix) 391 | ; => ((27 33 39 43) (60 75 90 100) (82 103 124 138)) 392 | 393 | ;-- 2.38 394 | (define (fold-left op initial sequence) 395 | (define (iter result rest) 396 | (if (null? rest) 397 | result 398 | (iter (op result (car rest)) 399 | (cdr rest)))) 400 | (iter initial sequence)) 401 | 402 | ; What are the values of: 403 | (fold-right / 1 (list 1 2 3)) 404 | ; 3/2 405 | (fold-left / 1 (list 1 2 3)) 406 | ; 1/6 407 | (fold-right list nil (list 1 2 3)) 408 | ; (3 (2 (1 ()))) 409 | (fold-left list nil (list 1 2 3)) 410 | ; (((() 1) 2) 3) 411 | 412 | ; Give a property that op should satisfy to guarantee that fold-right and 413 | ; fold-left will produce the same values for any sequence. 414 | ; Let's take a (list 1 2 3) and fold it: 415 | ; Fold-right => (op 3 (op 2 (op 1 nil))) Ex. (3 * ( 2 * (1))) 416 | ; Fold-left => (op (op (op nil 1) 2) 3) Ex. (((1)*2)*3) 417 | ; To me it looks like commutativity. However, others point at associativity 418 | ; instead. To investigate. 419 | ; Commutativity: https://secure.wikimedia.org/wikipedia/en/wiki/Commutativity 420 | ; Associativity: https://secure.wikimedia.org/wikipedia/en/wiki/Associativity 421 | 422 | ;-- 2.39 423 | (define (fold-right op initial sequence) 424 | (if (null? sequence) 425 | initial 426 | (op (car sequence) 427 | (fold-right op initial (cdr sequence))))) 428 | (define (reverse sequence) 429 | (fold-right (lambda (item rest) (append rest (list item))) 430 | nil 431 | sequence)) 432 | (define (reverse sequence) 433 | (fold-left (lambda (item rest) (cons rest item)) 434 | nil 435 | sequence)) 436 | 437 | ;-- 2.40 438 | ; Env: 439 | (define (enumerate-interval a b) 440 | (if (> a b) 441 | nil 442 | (append (list a) (enumerate-interval (+ a 1) b)))) 443 | (define (filter predicate sequence) 444 | (cond ((null? sequence) nil) 445 | ((predicate (car sequence)) 446 | (cons (car sequence) 447 | (filter predicate (cdr sequence)))) 448 | (else (filter predicate (cdr sequence))))) 449 | (define nil '()) 450 | (define (prime? x) 451 | (define (test divisor) 452 | (cond ((> (* divisor divisor) x) #t) 453 | ((= 0 (remainder x divisor)) #f) 454 | (else (test (+ divisor 1))))) 455 | (test 2)) 456 | (define (accumulate op initial sequence) 457 | (if (null? sequence) 458 | initial 459 | (op (car sequence) 460 | (accumulate op initial (cdr sequence))))) 461 | (define (flatmap proc seq) 462 | (accumulate append nil (map proc seq))) 463 | (define (prime-sum? pair) 464 | (prime? (+ (car pair) (cadr pair)))) 465 | (define (make-pair-sum pair) 466 | (list (car pair) (cadr pair) (+ (car pair) (cadr pair)))) 467 | (define (prime-sum-pairs n) 468 | (map make-pair-sum 469 | (filter prime-sum? 470 | (flatmap 471 | (lambda (i) 472 | (map (lambda (j) (list i j)) 473 | (enumerate-interval 1 (- i 1)))) 474 | (enumerate-interval 1 n))))) 475 | 476 | (define (unique-pairs n) 477 | (flatmap (lambda (i) 478 | (map (lambda (j) (list i j)) 479 | (enumerate-interval 1 (- i 1)))) 480 | (enumerate-interval 1 n))) 481 | 482 | (define (prime-sum-pairs n) 483 | (map make-pair-sum 484 | (filter prime-sum? (unique-pairs n)))) 485 | 486 | ;-- 2.41 487 | ; Write a procedure to find all ordered triples of distinct positive integers 488 | ; i, j, and k less than or equal to a given integer n that sum to a given 489 | ; integer s. 490 | (define (ordered-triples n s) 491 | (filter (lambda (triple) (= (fold-left + 0 triple) s)) 492 | (flatmap (lambda (i) 493 | (flatmap (lambda (j) 494 | (map (lambda (k) (list i j k)) 495 | (enumerate-interval 1 j))) 496 | (enumerate-interval 1 i))) 497 | (enumerate-interval 1 n)))) 498 | 499 | ;-- 2.42 500 | ; Env: 501 | (define nil '()) 502 | (define (enumerate-interval a b) 503 | (if (> a b) 504 | nil 505 | (append (list a) (enumerate-interval (+ a 1) b)))) 506 | (define (filter predicate sequence) 507 | (cond ((null? sequence) nil) 508 | ((predicate (car sequence)) 509 | (cons (car sequence) 510 | (filter predicate (cdr sequence)))) 511 | (else (filter predicate (cdr sequence))))) 512 | (define (accumulate op initial sequence) 513 | (if (null? sequence) 514 | initial 515 | (op (car sequence) 516 | (accumulate op initial (cdr sequence))))) 517 | (define (flatmap proc seq) 518 | (accumulate append nil (map proc seq))) 519 | 520 | ; Skeleton of the function to implement: 521 | (define (queens board-size) 522 | (define (queen-cols k) 523 | (if (= k 0) 524 | (list empty-board) 525 | (filter 526 | (lambda (positions) (safe? k positions)) 527 | (flatmap 528 | (lambda (rest-of-queens) 529 | (map (lambda (new-row) 530 | (adjoin-position new-row k rest-of-queens)) 531 | (enumerate-interval 1 board-size))) 532 | (queen-cols (- k 1)))))) 533 | (queen-cols board-size)) 534 | 535 | ; Helper functions: 536 | (define empty-board '()) 537 | (define (adjoin-position new-row k rest-of-queens) 538 | (append (list (cons k new-row)) rest-of-queens)) 539 | (define (same-line queen-a queen-b) ; Coordinates are (x,y) pairs. If the y is 540 | ; the same for both queens, they are on the 541 | ; same line. 542 | (= (cdr queen-a) (cdr queen-b))) 543 | (define (same-diagonal queen-a queen-b) ; Two queens are on the same diagonal 544 | ; if their horizontal distance is equal 545 | ; to their vertical distance 546 | (= (- (car queen-a) (car queen-b)) 547 | (abs (- (cdr queen-a) (cdr queen-b))))) 548 | (define (safe? k positions) 549 | (define (safe-iter queen-pos other-queens) 550 | (if (null? other-queens) 551 | #t 552 | (let ((qtt (car other-queens))) ;qtt = queen to test 553 | (cond ((same-line queen-pos qtt) #f) ; Same line 554 | ((same-diagonal queen-pos qtt) #f) ; Diagonal 555 | (else (safe-iter queen-pos (cdr other-queens))))))) 556 | (safe-iter (car positions) (cdr positions))) 557 | 558 | 559 | ;-- 2.43 560 | ; Way longer, Louis is not skilled. 561 | 562 | ;-- 2.44 563 | (define (up-split painter n) 564 | (if (= n 0) 565 | painter 566 | (let ((smaller (up-split painter (- n 1)))) 567 | (below painter (beside smaller smaller))))) 568 | 569 | ;-- 2.45 570 | (define (right-split painter n) 571 | (if (= n 0) 572 | painter 573 | (let ((smaller (right-split painter (- n 1)))) 574 | (beside painter (below smaller smaller))))) 575 | (define (up-split painter n) 576 | (if (= n 0) 577 | painter 578 | (let ((smaller (up-split painter (- n 1)))) 579 | (below painter (beside smaller smaller))))) 580 | 581 | ; Right-split and up-split can be expressed as instances of a general splitting 582 | ; operation. Define a procedure split with the property that evaluating 583 | ; (define right-split (split beside below)) 584 | ; (define up-split (split below beside)) 585 | ; produces procedures right-split and up-split with the same behaviors as the 586 | ; ones already defined. 587 | 588 | (define (split first-transform second-transform) 589 | (define (new-split painter n) 590 | (if (= n 0) 591 | painter 592 | (let ((smaller (new-split painter (- n 1)))) 593 | (first-transform painter (second-transform smaller smaller))))) 594 | (lambda (painter n) (new-split painter n))) 595 | 596 | ; A cleverer version that avoids having to name the lambda in order to recurse, 597 | ; from the scheme wiki: 598 | (define (split first-transform second-transform) 599 | (lambda (painter n) 600 | (if (= n 0) 601 | painter 602 | (let ((smaller ((split first-transform second-transform) 603 | painter 604 | (- n 1)))) 605 | (first-transform painter (second-transform smaller smaller)))))) 606 | 607 | ;-- 2.46 608 | (define (make-vect x y) 609 | (cons x y)) 610 | (define (xcor-vect vect) 611 | (car vect)) 612 | (define (ycor-vect vect) 613 | (cdr vect)) 614 | (define (add-vect v1 v2) 615 | (make-vect (+ (xcor-vect v1) (xcor-vect v2)) 616 | (+ (ycor-vect v1) (ycor-vect v2)))) 617 | (define (sub-vect v1 v2) 618 | (make-vect (- (xcor-vect v1) (xcor-vect v2)) 619 | (- (ycor-vect v1) (ycor-vect v2)))) 620 | (define (scale-vect s vect) 621 | (make-vect (* s (xcor-vect vect)) 622 | (* s (ycor-vect vect)))) 623 | 624 | ;-- 2.45 625 | (define (make-frame origin edge1 edge2) 626 | (list origin edge1 edge2)) 627 | ; Accessors: 628 | (define (origin frame) 629 | (car frame)) 630 | (define (edge1 frame) 631 | (car (cdr frame))) 632 | (define (edge2 frame) 633 | (car (cdr (cdr frame)))) 634 | 635 | 636 | (define (make-frame origin edge1 edge2) 637 | (cons origin (cons edge1 edge2))) 638 | ; Accessors: 639 | (define (origin frame) 640 | (car frame)) 641 | (define (edge1 frame) 642 | (car (cdr frame))) 643 | (define (edge2 frame) 644 | (cdr (cdr frame))) 645 | 646 | ; The next exercises aren't that interesting. 647 | 648 | ;-- 2.53 649 | (list 'a 'b 'c) 650 | ; (a b c) 651 | (list (list 'george)) 652 | ; ((george)) 653 | (cdr '((x1 x2) (y1 y2))) 654 | ; ((y1 y2)) 655 | (cadr '((x1 x2) (y1 y2))) 656 | ; (y1 y2) 657 | (pair? (car '(a short list))) 658 | ; false 659 | (memq 'red '((red shoes) (blue socks))) 660 | ; false 661 | (memq 'red '(red shoes blue socks)) 662 | ; (red shoes blue socks) 663 | 664 | ;-- 2.54 665 | (define (equal? a b) 666 | (if (and (pair? a) (pair? b)) ; two pairs : we test deeper 667 | (and (equal? (car a) (car b)) 668 | (equal? (cdr a) (cdr b))) 669 | (eq? a b))) ; everything else is handled by eq? 670 | 671 | ;-- 2.55 672 | (car ''abracadabra) 673 | <=> (car '(quote abracadabra)) 674 | <=> (car ('quote 'abracadabra)) 675 | <=> 'quote 676 | ; i.e. the symbol 'quote 677 | 678 | ;-- 2.56 679 | ; Functions given: 680 | (define (variable? x) (symbol? x)) 681 | (define (same-variable? v1 v2) 682 | (and (variable? v1) (variable? v2) (eq? v1 v2))) 683 | (define (make-sum a1 a2) (list '+ a1 a2)) ; Naive implementation; will be 684 | ; replaced afterwards 685 | (define (make-product m1 m2) (list '* m1 m2)) ; Same 686 | (define (sum? x) 687 | (and (pair? x) (eq? (car x) '+))) 688 | (define (addend s) (cadr s)) 689 | (define (augend s) (caddr s)) 690 | (define (product? x) 691 | (and (pair? x) (eq? (car x) '*))) 692 | (define (multiplier p) (cadr p)) 693 | (define (multiplicand p) (caddr p)) 694 | (define (make-sum a1 a2) 695 | (cond ((=number? a1 0) a2) 696 | ((=number? a2 0) a1) 697 | ((and (number? a1) (number? a2)) (+ a1 a2)) 698 | (else (list '+ a1 a2)))) 699 | (define (=number? exp num) 700 | (and (number? exp) (= exp num))) 701 | (define (make-product m1 m2) 702 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 703 | ((=number? m1 1) m2) 704 | ((=number? m2 1) m1) 705 | ((and (number? m1) (number? m2)) (* m1 m2)) 706 | (else (list '* m1 m2)))) 707 | 708 | ; The question itself: 709 | (define (exponentiation? x) 710 | (and (pair? x) (eq? (car x) '** ))) 711 | (define base cadr) ; No need to copy the argument 712 | (define exponent caddr) 713 | (define (make-exponentiation base exponent) 714 | (cond ((=number? base 1) 1) 715 | ((=number? exponent 0) 1) 716 | ((=number? exponent 1) base) 717 | ((and (number? base) (number? exponent)) (expt base exponent)) 718 | (else (list '** base exponent)))) 719 | (define (deriv exp var) 720 | (cond ((number? exp) 0) 721 | ((variable? exp) 722 | (if (same-variable? exp var) 1 0)) 723 | ((sum? exp) 724 | (make-sum (deriv (addend exp) var) 725 | (deriv (augend exp) var))) 726 | ((product? exp) 727 | (make-sum 728 | (make-product (multiplier exp) 729 | (deriv (multiplicand exp) var)) 730 | (make-product (deriv (multiplier exp) var) 731 | (multiplicand exp)))) 732 | ((exponentiation? exp) 733 | (make-product (make-product (exponent exp) 734 | (make-exponentiation (base exp) 735 | (if (number? (exponent exp)) 736 | (- (exponent exp) 1) 737 | (list '- (exponent exp) '1)))) 738 | (deriv (base exp) var))) 739 | (else 740 | (error "unknown expression type -- DERIV" exp)))) 741 | 742 | ; Test cases: 743 | (deriv '(** 5 6) '2) 744 | ; 0 745 | (deriv '(** x 1) 'x) 746 | ; 1 747 | (deriv '(** 1 x) 'x) 748 | ; 0 749 | (deriv '(** x 5) 'x) 750 | ; (* 5 (** x 4)) 751 | (deriv '(** x y) 'x) 752 | ; (* y (** x (- y 1))) 753 | 754 | ;-- 2.57 755 | (define (addend s) (cadr s)) ; Does not change 756 | (define (augend s) 757 | (if (null? (cdddr s)) ; Means the addition is just two terms long 758 | (caddr s) ; The term itself 759 | (append '(+) (cddr s)))) ; A new addition comprised of the next terms 760 | (define (make-sum a1 a2) 761 | (cond ((=number? a1 0) a2) 762 | ((=number? a2 0) a1) 763 | ((and (number? a1) (number? a2)) (+ a1 a2)) 764 | ((sum? a2) (make-sum a1 (make-sum (addend a2) (augend a2)))) 765 | (else (list '+ a1 a2)))) 766 | (define (multiplier p) (cadr p)) 767 | (define (multiplicand p) 768 | (if (null? (cdddr p)) 769 | (caddr p) 770 | (append '(*) (cddr p)))) 771 | (define (make-product m1 m2) 772 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 773 | ((=number? m1 1) m2) 774 | ((=number? m2 1) m1) 775 | ((product? m2) (make-product m1 (make-product (multiplier m2) 776 | (multiplicand m2)))) 777 | ((and (number? m1) (number? m2)) (* m1 m2)) 778 | (else (list '* m1 m2)))) 779 | 780 | ; Test: 781 | (deriv '(* x y (+ x 3)) 'x) 782 | ; (+ (* x y) (* y (+ x 3))) 783 | 784 | ;-- 2.58 785 | ; a. 786 | (define (sum? x) 787 | (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '+))) 788 | (define addend car) 789 | (define augend caddr) 790 | (define (make-sum a1 a2) 791 | (cond ((=number? a1 0) a2) 792 | ((=number? a2 0) a1) 793 | ((and (number? a1) (number? a2)) (+ a1 a2)) 794 | (else (list a1 '+ a2)))) 795 | (define (product? x) 796 | (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '*))) 797 | (define multiplier car) 798 | (define multiplicand caddr) 799 | (define (make-product m1 m2) 800 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 801 | ((=number? m1 1) m2) 802 | ((=number? m2 1) m1) 803 | ((and (number? m1) (number? m2)) (* m1 m2)) 804 | (else (list m1 '* m2)))) 805 | 806 | ; Test: 807 | (deriv '(x + (3 * (x + (y + 2)))) 'x) 808 | ; 4 809 | 810 | ; b. 811 | ; It looks long and complicated - kept in stock for a long winter night. 812 | 813 | ;-- 2.59 814 | ; Functions given: 815 | (define (element-of-set? x set) 816 | (cond ((null? set) #f) ; "false" and "true" replaced by their Scheme 817 | ; equivalent for convenience 818 | ((equal? x (car set)) #t) 819 | (else (element-of-set? x (cdr set))))) 820 | (define (adjoin-set x set) 821 | (if (element-of-set? x set) 822 | set 823 | (cons x set))) 824 | (define (intersection-set set1 set2) 825 | (cond ((or (null? set1) (null? set2)) '()) 826 | ((element-of-set? (car set1) set2) 827 | (cons (car set1) 828 | (intersection-set (cdr set1) set2))) 829 | (else (intersection-set (cdr set1) set2)))) 830 | 831 | ; Union: 832 | (define (union-set set1 set2) 833 | (cond ((null? set1) set2) ; We'll add elements of set1 to set2 (given they're 834 | ; not already present in set2) 835 | ((element-of-set? (car set1) set2) 836 | (union-set (cdr set1) set2)) 837 | (else (cons (car set1) 838 | (union-set (cdr set1) set2))))) 839 | 840 | ; Test: 841 | (define s1 (list 1 2 3 4 5)) 842 | (define s2 (list 5 6 7 8)) 843 | (intersection-set s1 s2) 844 | ; (5) 845 | (union-set s1 s2) 846 | ; (1 2 3 4 5 6 7 8) 847 | 848 | ;-- 2.60 849 | ; element-of-set?: doesn't need to change 850 | (define adjoin-set cons) ; No need to check for duplicates 851 | ; intersection-set: doesn't change either. It will destroy the duplicates. 852 | (define (union-set set1 set2) 853 | (append set1 set2)) 854 | 855 | ; Test: 856 | (union-set s1 s3) 857 | ; (1 2 3 4 5 5 5 5 5) 858 | (intersection-set s1 s3) 859 | ; (5) 860 | 861 | ; Efficiency: by eliminating the need to walk the list, adjoin is now O(1) 862 | ; instead of O(n). 863 | ; union becomes O(n) instead of O(n²) 864 | 865 | ;-- 2.61 866 | ; Functions given: 867 | (define (element-of-set? x set) 868 | (cond ((null? set) false) 869 | ((= x (car set)) true) 870 | ((< x (car set)) false) 871 | (else (element-of-set? x (cdr set))))) 872 | (define (intersection-set set1 set2) 873 | (if (or (null? set1) (null? set2)) 874 | '() 875 | (let ((x1 (car set1)) (x2 (car set2))) 876 | (cond ((= x1 x2) 877 | (cons x1 878 | (intersection-set (cdr set1) 879 | (cdr set2)))) 880 | ((< x1 x2) 881 | (intersection-set (cdr set1) set2)) 882 | ((< x2 x1) 883 | (intersection-set set1 (cdr set2))))))) 884 | 885 | ; Answer: 886 | (define (adjoin-set x set) 887 | (cond ((or (null? set) (< x (car set))) (cons x set)) 888 | ((= x (car set)) set) 889 | (else (cons (car set) (adjoin-set x (cdr set)))))) 890 | 891 | ; Test: 892 | (define s4 (list 1 2 3 5 6)) 893 | (adjoin-set 4 s4) 894 | ; (1 2 3 4 5 6) 895 | (adjoin-set 9 s4) 896 | ; (1 2 3 5 6 9) 897 | 898 | ;-- 2.62 899 | (define (union-set set1 set2) 900 | (if (null? set1) 901 | set2 902 | (let ((x1 (car set1)) (x2 (car set2))) 903 | (cond ((= x1 x2) 904 | (cons x1 (union-set (cdr set1) (cdr set2)))) 905 | ((< x1 x2) 906 | (cons x1 (union-set (cdr set1) set2))) 907 | ((< x2 x1) 908 | (cons x2 (union-set set1 (cdr set2)))))))) 909 | ; This implementation is O(n) because each iteration selects an item from 910 | ; either set1 or set2 and cons it (an O(1) operation). There are n iterations 911 | ; at most, n being the length of set1 + the length of set2, hence an O(n) total 912 | ; complexity. 913 | 914 | ; Test: 915 | (define s1 (list 1 2 3 4 5)) 916 | (define s2 (list 5 6 7 8)) 917 | (union-set s1 s2) 918 | ; (1 2 3 4 5 6 7 8) 919 | 920 | ;-- 2.63 921 | ; Tree functions: 922 | (define (entry tree) (car tree)) 923 | (define (left-branch tree) (cadr tree)) 924 | (define (right-branch tree) (caddr tree)) 925 | (define (make-tree entry left right) 926 | (list entry left right)) 927 | (define (element-of-set? x set) 928 | (cond ((null? set) #f) 929 | ((= x (entry set)) #t) 930 | ((< x (entry set)) 931 | (element-of-set? x (left-branch set))) 932 | ((> x (entry set)) 933 | (element-of-set? x (right-branch set))))) 934 | (define (adjoin-set x set) 935 | (cond ((null? set) (make-tree x '() '())) 936 | ((= x (entry set)) set) 937 | ((< x (entry set)) 938 | (make-tree (entry set) 939 | (adjoin-set x (left-branch set)) 940 | (right-branch set))) 941 | ((> x (entry set)) 942 | (make-tree (entry set) 943 | (left-branch set) 944 | (adjoin-set x (right-branch set)))))) 945 | 946 | ; a. 947 | ; Do the two procedures produce the same result for every tree? 948 | ; Yes. To test: 949 | (define t1 (list 7 (list 3 (list 1 '() '()) (list 5 '() '())) (list 9 '() (list 11 '() '())))) 950 | (define t2 (list 3 (list 1 '() '()) (list 7 (list 5 '() '()) (list 9 '() (list 11 '() '()))))) 951 | (define t3 (list 5 (list 3 (list 1 '() '()) '()) (list 9 (list 7 '() '()) (list 11 '() '())))) 952 | ; If not, how do the results differ? What lists do the two procedures produce 953 | ; for the trees in figure 2.16? 954 | ; Both tree->list algorithm will print (1 3 5 7 9 11) for the three trees. 955 | 956 | ; b. 957 | ; They're O(n) 958 | 959 | ;-- 2.64 960 | (define (list->tree elements) 961 | (car (partial-tree elements (length elements)))) 962 | (define (partial-tree elts n) 963 | (if (= n 0) 964 | (cons '() elts) 965 | (let ((left-size (quotient (- n 1) 2))) 966 | (let ((left-result (partial-tree elts left-size))) 967 | (let ((left-tree (car left-result)) 968 | (non-left-elts (cdr left-result)) 969 | (right-size (- n (+ left-size 1)))) 970 | (let ((this-entry (car non-left-elts)) 971 | (right-result (partial-tree (cdr non-left-elts) 972 | right-size))) 973 | (let ((right-tree (car right-result)) 974 | (remaining-elts (cdr right-result))) 975 | (cons (make-tree this-entry left-tree right-tree) 976 | remaining-elts)))))))) 977 | 978 | ; a. 979 | ; Partial-tree splits the list given in two parts of equal size (modulo 1). 980 | ; Both halves are submitted to partial-tree through recursion. The recursive 981 | ; procedures will yield a pair made of the subtree and the list of elements 982 | ; that didn't make it into said subtree. By splitting the process between right 983 | ; and left hands, we will ensure that we have a correctly balanced tree. The 984 | ; stop condition for partial-tree is asking a tree made of 0 elements, who will 985 | ; yield a pair made of an empty list and the list of items. 986 | ; Finally, these halves are assembled by a make-tree between the value at the 987 | ; middle of the list (strictly speaking the leftmost of the right half) and the 988 | ; left and right trees computed beforehand. 989 | ; This only works with ordered lists containing no duplicates. 990 | 991 | ; Tree given for (1 3 5 7 9 11): 992 | ; 5 993 | ; / \ 994 | ; 1 9 995 | ; \ / \ 996 | ; 3 7 11 997 | 998 | ; b. 999 | ; Basically O(n). 1000 | 1001 | ;-- 2.65 1002 | ; First try: 1003 | ; We will reuse filter from a few exercises back 1004 | (define (filter predicate sequence) 1005 | (cond ((null? sequence) '()) 1006 | ((predicate (car sequence)) 1007 | (cons (car sequence) 1008 | (filter predicate (cdr sequence)))) 1009 | (else (filter predicate (cdr sequence))))) 1010 | (define (intersection-set tree1 tree2) 1011 | (list->tree (filter (lambda (x) (element-of-set? x tree1)) 1012 | (tree->list-1 tree2)))) 1013 | (define (union-set tree1 tree2) 1014 | (define (union-tree-list t l) 1015 | (if (null? l) 1016 | t 1017 | (union-tree-list (adjoin-set (car l) t) (cdr l)))) 1018 | (union-tree-list tree1 (tree->list-1 tree2))) 1019 | ; Complexity: 1020 | ; intersection uses an O(log n) filter on an O(n) walk of the elements of a 1021 | ; list. It's O(n * log n) 1022 | ; union uses an O(log n) insertion on an O(n) walk: it's O(n * log n) too. 1023 | ; These algorithms are poor, in the sense that they don't reuse previous 1024 | ; techniques. 1025 | 1026 | ; Second try: 1027 | (define tree->list tree->list-1) 1028 | (define (intersection-set-tree tree1 tree2) 1029 | (list->tree (intersection-set (tree->list tree1) 1030 | (tree->list tree2)))) 1031 | (define (union-set-tree tree1 tree2) 1032 | (list->tree (union-set (tree->list tree1) 1033 | (tree->list tree2)))) 1034 | ; Complexity: all operations are O(n) as shown in 2.62 and performed 1035 | ; sequentially; hence the result is O(n) too. 1036 | 1037 | ; Test: 1038 | (define t1 (list 7 (list 3 (list 1 '() '()) (list 5 '() '())) (list 9 '() (list 11 '() '())))) 1039 | (define t2 (list 4 (list 1 '() '()) (list 7 (list 6 '() '()) (list 9 '() (list 11 '() '()))))) 1040 | ; First try: 1041 | (intersection-set t1 t2) 1042 | ; (7 (1 () ()) (9 () (11 () ()))) 1043 | (union-set t1 t2) 1044 | ; (7 (3 (1 () ()) (5 (4 () ()) (6 () ()))) (9 () (11 () ()))) 1045 | ; Second try: 1046 | (intersection-set-tree t1 t2) 1047 | ; (7 (1 () ()) (9 () (11 () ()))) 1048 | (union-set-tree t1 t2) 1049 | ; (5 (3 (1 () ()) (4 () ())) (7 (6 () ()) (9 () (11 () ())))) 1050 | ; The difference between the two union-set stems from the fact that the first 1051 | ; version merely adds elements from tree2 to tree1, while the second version 1052 | ; flattens both trees, creates a new list and turns that list into a balanced 1053 | ; tree. 1054 | 1055 | ;-- 2.66 1056 | (define (lookup given-key set-of-records) 1057 | (cond ((null? set-of-records) #f) 1058 | ((= given-key (key set-of-records)) true) 1059 | ((< given-key (key set-of-records)) 1060 | (lookup given-key (left-branch set-of-records))) 1061 | ((> given-key (key set-of-records)) 1062 | (lookup given-key (right-branch set-of-records))))) 1063 | ; Basically just a tree lookup. 1064 | 1065 | ;-- 2.67 1066 | ; Huffman trees 1067 | ; Functions given: 1068 | (define (make-leaf symbol weight) 1069 | (list 'leaf symbol weight)) 1070 | (define (leaf? object) 1071 | (eq? (car object) 'leaf)) 1072 | (define (symbol-leaf x) (cadr x)) 1073 | (define (weight-leaf x) (caddr x)) 1074 | (define (make-code-tree left right) 1075 | (list left 1076 | right 1077 | (append (symbols left) (symbols right)) 1078 | (+ (weight left) (weight right)))) 1079 | (define (left-branch tree) (car tree)) 1080 | (define (right-branch tree) (cadr tree)) 1081 | (define (symbols tree) 1082 | (if (leaf? tree) 1083 | (list (symbol-leaf tree)) 1084 | (caddr tree))) 1085 | (define (weight tree) 1086 | (if (leaf? tree) 1087 | (weight-leaf tree) 1088 | (cadddr tree))) 1089 | (define (decode bits tree) 1090 | (define (decode-1 bits current-branch) 1091 | (if (null? bits) 1092 | '() 1093 | (let ((next-branch 1094 | (choose-branch (car bits) current-branch))) 1095 | (if (leaf? next-branch) 1096 | (cons (symbol-leaf next-branch) 1097 | (decode-1 (cdr bits) tree)) 1098 | (decode-1 (cdr bits) next-branch))))) 1099 | (decode-1 bits tree)) 1100 | (define (choose-branch bit branch) 1101 | (cond ((= bit 0) (left-branch branch)) 1102 | ((= bit 1) (right-branch branch)) 1103 | (else (error "bad bit -- CHOOSE-BRANCH" bit)))) 1104 | (define (adjoin-set x set) 1105 | (cond ((null? set) (list x)) 1106 | ((< (weight x) (weight (car set))) (cons x set)) 1107 | (else (cons (car set) 1108 | (adjoin-set x (cdr set)))))) 1109 | (define (make-leaf-set pairs) 1110 | (if (null? pairs) 1111 | '() 1112 | (let ((pair (car pairs))) 1113 | (adjoin-set (make-leaf (car pair) ; symbol 1114 | (cadr pair)) ; frequency 1115 | (make-leaf-set (cdr pairs)))))) 1116 | 1117 | ; Question: 1118 | (define sample-tree 1119 | (make-code-tree (make-leaf 'A 4) 1120 | (make-code-tree 1121 | (make-leaf 'B 2) 1122 | (make-code-tree (make-leaf 'D 1) 1123 | (make-leaf 'C 1))))) 1124 | (define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0)) 1125 | (decode sample-message sample-tree) 1126 | ; (a d a b b c a) 1127 | 1128 | ;-- 2.68 1129 | ; Given: 1130 | (define (encode message tree) 1131 | (if (null? message) 1132 | '() 1133 | (append (encode-symbol (car message) tree) 1134 | (encode (cdr message) tree)))) 1135 | 1136 | ; Answer: 1137 | (define (encode-symbol symbol tree) 1138 | (cond ((and (leaf? tree) (eq? symbol (symbol-leaf tree))) '()) 1139 | ((memq symbol (symbols (left-branch tree))) 1140 | (cons '0 (encode-symbol symbol (left-branch tree)))) 1141 | ((memq symbol (symbols (right-branch tree))) 1142 | (cons '1 (encode-symbol symbol (right-branch tree)))))) 1143 | 1144 | ; Tests: 1145 | (encode-symbol 'a sample-tree) 1146 | ; (0) 1147 | (encode-symbol 'b sample-tree) 1148 | ; (1 0) 1149 | (encode-symbol 'c sample-tree) 1150 | ; (1 1 1) 1151 | (encode-symbol 'd sample-tree) 1152 | ; (1 1 0) 1153 | (encode '(a d a b b c a) sample-tree) 1154 | ; (0 1 1 0 0 1 0 1 0 1 1 1 0) 1155 | (equal? sample-message (encode '(a d a b b c a) sample-tree)) 1156 | ; #t 1157 | 1158 | ;-- 2.69 1159 | ; Given: 1160 | (define (generate-huffman-tree-1 pairs) 1161 | (successive-merge-1 (make-leaf-set pairs))) 1162 | ; Answer 1163 | (define (successive-merge-1 leaves) 1164 | (if (= (length leaves) 2) 1165 | (make-code-tree (car leaves) (cadr leaves)) 1166 | (successive-merge-1 (cons (make-code-tree (car leaves) (cadr leaves)) 1167 | (cddr leaves))))) 1168 | ; Test: 1169 | (generate-huffman-tree-1 '((A 4) (B 2) (C 1) (D 1))) 1170 | ;((((leaf d 1) (leaf c 1) (d c) 2) (leaf b 2) (d c b) 4) (leaf a 4) (d c b a) 8) 1171 | 1172 | ; NB: this only works because of the special 1 1 2 4 case we're in here. Using 1173 | ; this algorithm on the first Huffman tree yields an incorrect result: 1174 | (generate-huffman-tree-1 '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1))) 1175 | ;((((((((leaf h 1) (leaf g 1) (h g) 2) (leaf f 1) (h g f) 3) (leaf e 1) (h g f e) 4) (leaf d 1) (h g f e d) 5) (leaf c 1) (h g f e d c) 6) (leaf b 3) (h g f e d c b) 9) (leaf a 8) (h g f e d c b a) 17) 1176 | 1177 | ; The correct way to do it is by using adjoin-set instead of cons: 1178 | (define (successive-merge nodes) 1179 | (if (= (length nodes) 1) 1180 | (car nodes) 1181 | (successive-merge2 (adjoin-set (make-code-tree (car nodes) (cadr nodes)) 1182 | (cddr nodes))))) 1183 | (define (generate-huffman-tree pairs) 1184 | (successive-merge (make-leaf-set pairs))) 1185 | (generate-huffman-tree '((A 8) (B 3) (C 1) (D 1) (E 1) (F 1) (G 1) (H 1))) 1186 | ;((leaf a 8) ((((leaf h 1) (leaf g 1) (h g) 2) ((leaf f 1) (leaf e 1) (f e) 2) (h g f e) 4) (((leaf d 1) (leaf c 1) (d c) 2) (leaf b 3) (d c b) 5) (h g f e d c b) 9) (a h g f e d c b) 17) 1187 | 1188 | ;-- 2.70 1189 | (define rocktree (generate-huffman-tree '((A 2) (NA 16) (BOOM 1) (SHA 3) (GET 2) (YIP 9) (JOB 2) (WAH 1)))) 1190 | rocktree 1191 | ; ((leaf na 16) ((leaf yip 9) (((leaf a 2) ((leaf wah 1) (leaf boom 1) (wah boom) 2) (a wah boom) 4) ((leaf sha 3) ((leaf job 2) (leaf get 2) (job get) 4) (sha job get) 7) (a wah boom sha job get) 11) (yip a wah boom sha job get) 20) (na yip a wah boom sha job get) 36) 1192 | (define rock-song '(Get a job Sha na na na na na na na na Get a job Sha na na na na na na na na Wah yip yip yip yip yip yip yip yip yip Sha boom)) 1193 | (define encoded-rock-song (encode rock-song rocktree)) 1194 | encoded-rock-song 1195 | ; (1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 1 1 0 1 1) 1196 | (length encoded-rock-song) 1197 | ; 84 1198 | 1199 | ; If we were to use a fixed-length encoding on that rock song, we would need 1200 | ; 3 bits (8 = 2^3) per symbol, i.e.: 1201 | (* 3 (length rock-song)) 1202 | ; 108 1203 | 1204 | ; We can see a 22% gain by using the huffman encoding 1205 | 1206 | ;-- 2.71 1207 | ; Example with n=5. We will use letters from the alphabet to represent the 1208 | ; symbols. 1209 | ; {a b c d e} 31 1210 | ; / \ 1211 | ; {a b c d} 15 e 16 1212 | ; / \ 1213 | ; {a b c} 7 d 8 1214 | ; / \ 1215 | ; {a b} 3 c 4 1216 | ; / \ 1217 | ; a 1 b 2 1218 | 1219 | ; The minimum number of bits to construct a symbol (i.e. the minimum depth to 1220 | ; reach a leaf) for such trees is 1, for the symbol of weight 2^n-1. 1221 | ; The maximum number of bits will be n-1, for the two symbols of least weight. 1222 | 1223 | ;-- 2.72 1224 | ; Encoding the most frequent element as per ex. 2.71 is a mere search into the 1225 | ; symbol list, which is accomplished in O(n). 1226 | ; Encoding the least frequent element involves descending down the tree, with a 1227 | ; search in the symbol list each time. 1228 | ; The complexity is O(n) + O(n-1) + ... + O(1), akin to O(n²). 1229 | 1230 | ;-- 2.73 1231 | (define (deriv exp var) 1232 | (cond ((number? exp) 0) 1233 | ((variable? exp) (if (same-variable? exp var) 1 0)) 1234 | (else ((get 'deriv (operator exp)) (operands exp) 1235 | var)))) 1236 | (define (operator exp) (car exp)) 1237 | (define (operands exp) (cdr exp)) 1238 | 1239 | ; a. 1240 | ; What was done above: we switched to data-directed programming. Yay! 1241 | ; We cannot use this method for number? and variable? because these never have 1242 | ; the same operator. 1243 | ; By comparison, we can implement sum? and product? because the first symbol is 1244 | ; always identical (+ and *). 1245 | 1246 | ; b. 1247 | (define (install-deriv-package) 1248 | ;; internal procedures 1249 | (define (addend s) (car s)) 1250 | (define (augend s) (cadr s)) 1251 | (define (multiplier p) (car p)) 1252 | (define (multiplicand p) (cadr p)) 1253 | (define (sum? x) 1254 | (and (pair? x) (eq? (car x) '+))) 1255 | (define (product? x) 1256 | (and (pair? x) (eq? (car x) '*))) 1257 | (define (make-sum a1 a2) 1258 | (cond ((=number? a1 0) a2) 1259 | ((=number? a2 0) a1) 1260 | ((and (number? a1) (number? a2)) (+ a1 a2)) 1261 | (else (list '+ a1 a2)))) 1262 | (define (=number? exp num) 1263 | (and (number? exp) (= exp num))) 1264 | (define (make-product m1 m2) 1265 | (cond ((or (=number? m1 0) (=number? m2 0)) 0) 1266 | ((=number? m1 1) m2) 1267 | ((=number? m2 1) m1) 1268 | ((and (number? m1) (number? m2)) (* m1 m2)) 1269 | (else (list '* m1 m2)))) 1270 | (define (compute-sum sum var) 1271 | (make-sum (deriv (addend sum) var) 1272 | (deriv (augend sum) var))) 1273 | (define (compute-product pro var) 1274 | (make-sum 1275 | (make-product (multiplier pro) 1276 | (deriv (multiplicand pro) var)) 1277 | (make-product (deriv (multiplier pro) var) 1278 | (multiplicand pro)))) 1279 | ;; interface to the rest of the system 1280 | (put 'sum? '(deriv) sum?) 1281 | (put 'product? '(deriv) product?) 1282 | (put '+ 'deriv compute-sum) 1283 | (put '* 'deriv compute-product) 1284 | 'done) 1285 | 1286 | ; NB: This is all highly untested, and probably false. 1287 | ; Chapter 3 will allow us to implement tables. We'll test it when we get there. 1288 | 1289 | ; c. 1290 | (define (install-deriv-exp-package) 1291 | ; Internal: 1292 | (define (exponentiation? x) 1293 | (and (pair? x) (eq? (car x) '** ))) 1294 | (define base car) 1295 | (define exponent cadr) 1296 | (define (make-exponentiation base exponent) 1297 | (cond ((=number? base 1) 1) 1298 | ((=number? exponent 0) 1) 1299 | ((=number? exponent 1) base) 1300 | ((and (number? base) (number? exponent)) (expt base exponent)) 1301 | (else (list '** base exponent)))) 1302 | (define (compute-exponentiation exp var) 1303 | (make-product (make-product (exponent exp) 1304 | (make-exponentiation (base exp) 1305 | (if (number? (exponent exp)) 1306 | (- (exponent exp) 1) 1307 | (list '- (exponent exp) '1)))) 1308 | (deriv (base exp) var))) 1309 | ; Interface: 1310 | (put 'exponentiation? '(deriv) exponentiation?) 1311 | (put '** 'deriv compute-exponentiation) 1312 | 'done) 1313 | 1314 | ; Highly untested too. 1315 | 1316 | ; d. 1317 | ; ? 1318 | 1319 | ;-- 2.74 1320 | ; a. 1321 | ; Each division will put their method in the table. 1322 | (put 'get-record 'sales-division get-salesman) 1323 | (put 'get-record 'hr-division human-ressources-get-person) 1324 | ; etc. 1325 | ; We can then use this method to retrieve the correct record: 1326 | (define (get-record division employee) 1327 | ((get 'get-record division) employee)) 1328 | 1329 | ; b. 1330 | ; Same thing: 1331 | (put 'get-salary 'sales-division get-salesman-salary) 1332 | (put 'get-salary 'hr-division needlessly-convoluted-method-of-retrieving-salary) 1333 | 1334 | (define (get-salary division employee) 1335 | ((get 'get-salary division) (get-record division employee))) 1336 | 1337 | ; c. 1338 | (define (find-employee-record name division-list) 1339 | (if (null? division-list) 1340 | #f 1341 | (if (memq name (car division-list)) 1342 | #t 1343 | (find-employee-record name (cdr division-list))))) 1344 | 1345 | ; d. 1346 | ; Make them use an unique identifier. 1347 | 1348 | ;-- 2.75 1349 | ; We can implement make-from-real-imag in message-passing style as follows: 1350 | (define (make-from-real-imag x y) 1351 | (define (dispatch op) 1352 | (cond ((eq? op 'real-part) x) 1353 | ((eq? op 'imag-part) y) 1354 | ((eq? op 'magnitude) 1355 | (sqrt (+ (square x) (square y)))) 1356 | ((eq? op 'angle) (atan y x)) 1357 | (else 1358 | (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) 1359 | dispatch) 1360 | (define (apply-generic op arg) (arg op)) 1361 | 1362 | ; Implement the constructor make-from-mag-ang in message-passing style: 1363 | (define (make-from-mag-ang r A) 1364 | (define (dispatch op) 1365 | (cond ((eq? op 'real-part) (* r (cos A))) 1366 | ((eq? op 'imag-part) (* r (sin A))) 1367 | ((eq? op 'magnitude) r) 1368 | ((eq? op 'angle) A) 1369 | (else 1370 | (error "Unknown op -- MAKE-FROM-REAL-IMAG" op)))) 1371 | dispatch) 1372 | 1373 | ;-- 2.76 1374 | 1375 | ;-- 2.77 1376 | 1377 | ;-- 2.78 1378 | (define (attach-tag type-tag contents) 1379 | (if (not (equal? 'scheme-number type-tag)) 1380 | (cons type-tag contents))) 1381 | (define (type-tag datum) 1382 | (cond ((pair? datum) (car datum)) 1383 | ((number? datum) 'scheme-number) 1384 | (else (error "Bad tagged datum -- TYPE-TAG" datum)))) 1385 | (define (contents datum) 1386 | (cond ((pair? datum) (cdr datum)) 1387 | ((number? datum) datum) 1388 | (else (error "Bad tagged datum -- CONTENTS" datum)))) 1389 | 1390 | ;-- 2.79 1391 | (define install-equ-package 1392 | (put 'equ? '(scheme-number scheme-number) =) 1393 | (put 'equ? '(rational rational) 1394 | (lambda (x y) 1395 | (= (* (numer x) (denom y)) 1396 | (* (numer y) (denom x))))) 1397 | (put 'equ? '(complex complex) 1398 | (lambda (x y) 1399 | (and (= (real-part x) (real-part y)) 1400 | (= (imag-part x) (imag-part y))))) 1401 | 'done) 1402 | (define (equ? x y) 1403 | (apply-generic 'equ? x y)) 1404 | 1405 | ; Another version, using =zero? as defined in the next exercise: 1406 | (define (equ? x y) 1407 | (=zero? (sub x y))) 1408 | 1409 | ;-- 2.80 1410 | (define install-zero-package 1411 | (put '=zero? '(scheme-number) zero?) 1412 | (put '=zero? '(complex) 1413 | (lambda (x) (and (zero? (imag-part a)) (zero? (real-part a))))) 1414 | (put '=zero? '(rational) 1415 | (lambda (x) (zero? (numer x)))) 1416 | 'done) 1417 | (define (=zero? x) 1418 | (apply-generic '=zero? x)) 1419 | 1420 | ;-- 2.81 1421 | ; apply-generic with coercion is defined as: 1422 | (define (apply-generic op . args) 1423 | (let ((type-tags (map type-tag args))) 1424 | (let ((proc (get op type-tags))) 1425 | (if proc 1426 | (apply proc (map contents args)) 1427 | (if (= (length args) 2) 1428 | (let ((type1 (car type-tags)) 1429 | (type2 (cadr type-tags)) 1430 | (a1 (car args)) 1431 | (a2 (cadr args))) 1432 | (let ((t1->t2 (get-coercion type1 type2)) 1433 | (t2->t1 (get-coercion type2 type1))) 1434 | (cond (t1->t2 1435 | (apply-generic op (t1->t2 a1) a2)) 1436 | (t2->t1 1437 | (apply-generic op a1 (t2->t1 a2))) 1438 | (else 1439 | (error "No method for these types" 1440 | (list op type-tags)))))) 1441 | (error "No method for these types" 1442 | (list op type-tags))))))) 1443 | 1444 | ; a. 1445 | ; Given: 1446 | (define (scheme-number->scheme-number n) n) 1447 | (define (complex->complex z) z) 1448 | (put-coercion 'scheme-number 'scheme-number 1449 | scheme-number->scheme-number) 1450 | (put-coercion 'complex 'complex complex->complex) 1451 | (define (exp x y) (apply-generic 'exp x y)) 1452 | ;; following added to Scheme-number package 1453 | (put 'exp '(scheme-number scheme-number) 1454 | (lambda (x y) (tag (expt x y)))) ; using primitive expt 1455 | ; What happens if we call exp with two complex numbers as arguments? 1456 | 1457 | ; Calling exp with two complex will result in an infinite loop. apply-generic 1458 | ; will find both t1->t2 and t2->t1 procedures (both will be complex->complex) 1459 | ; and recurse into apply-generic with the same types, complex & complex. 1460 | 1461 | ; b. 1462 | ; Louis Reasoner appears to be wrong. As is, apply-generic will raise an error 1463 | ; given 1464 | ; - no method taking t1 and t2 exists 1465 | ; - no conversion between t1 and t2 is available. 1466 | 1467 | ; c. 1468 | (define (apply-generic op . args) 1469 | (let ((type-tags (map type-tag args))) 1470 | (let ((proc (get op type-tags))) 1471 | (if proc 1472 | (apply proc (map contents args)) 1473 | (if (and (= (length args) 2) (not (eq? (car type-tags) (cadr type-tags)))) 1474 | (let ((type1 (car type-tags)) 1475 | (type2 (cadr type-tags)) 1476 | (a1 (car args)) 1477 | (a2 (cadr args))) 1478 | (let ((t1->t2 (get-coercion type1 type2)) 1479 | (t2->t1 (get-coercion type2 type1))) 1480 | (cond (t1->t2 1481 | (apply-generic op (t1->t2 a1) a2)) 1482 | (t2->t1 1483 | (apply-generic op a1 (t2->t1 a2))) 1484 | (else 1485 | (error "No method for these types" 1486 | (list op type-tags)))))) 1487 | (error "No method for these types" 1488 | (list op type-tags))))))) 1489 | 1490 | ;-- 2.82 1491 | (define (apply-generic op . args) 1492 | (let ((type-tags (map type-tag args))) 1493 | (let ((proc (get op type-tags))) 1494 | (if proc 1495 | (apply proc (map contents args)) 1496 | (let ((working-type (find-working-type op args type-tags))) 1497 | (if working-type 1498 | (apply-generic op (map (lambda (arg) 1499 | (if (eq? (type-tag arg) working-type) 1500 | arg 1501 | ((get-coercion (type-tag arg) working-type) arg))) 1502 | args)) 1503 | (error "No method for these types" (list op type-tags)))))))) 1504 | ; With find-working-type defined as: 1505 | (define (find-working-type op type-tags) 1506 | (define (check-coercions type-tags new-type) 1507 | (if (null? type-tags) 1508 | #t 1509 | (if (or (eq? (car type-tags) new-type) 1510 | (get-coercion (car type-tags) new-type)) 1511 | (check-coercions (cdr type-tags) new-type) 1512 | #f))) 1513 | (define (find-iter op type-tags type-tags-to-test) 1514 | (if (null? type-tags-to-test) 1515 | #f 1516 | (let* ((tested-tag (car type-tags-to-test)) 1517 | (proc (get op (map (lambda (x) tested-tag) 1518 | type-tags)))) 1519 | (if proc ; there is a procedure that takes all arguments as tested-tag 1520 | (if (check-coercions type-tags tested-tag); and we can convert all 1521 | ; arguments to said tested-tag 1522 | tested-tag 1523 | (find-iter op type-tags (cdr to-test))))))) 1524 | (find-iter op type-tags type-tags)) 1525 | 1526 | ; NB: untested. 1527 | 1528 | ;-- 2.83 1529 | (define install-raise-package 1530 | (put 'raise '(scheme-number) 1531 | (lambda (x) (make-rat x 1))) 1532 | (put 'raise '(rational) 1533 | (lambda (x) (make-real (/ (numer x) (denom x))))) 1534 | (put 'raise '(real) 1535 | (lambda (x) (make-from-real-imag x 0))) 1536 | 'done) 1537 | (define (raise x) 1538 | (apply-generic 'raise x)) 1539 | 1540 | ;-- 2.84 1541 | (define typelist '(complex real rational scheme-number)) 1542 | (define (is-higher type1 type2) 1543 | (let* ((type1-sublist (memq type1 typelist))) 1544 | (if type1-sublist 1545 | (if (memq type2 type1-sublist) 1546 | #t 1547 | #f) 1548 | #f))) 1549 | 1550 | ; Adapting apply-generic from 2.82: 1551 | (define (apply-generic op . args) 1552 | (let ((type-tags (map type-tag args))) 1553 | (let ((proc (get op type-tags))) 1554 | (if proc 1555 | (apply proc (map contents args)) 1556 | (let ((working-type (find-working-type op args type-tags))) 1557 | (if working-type 1558 | (apply-generic op (map (lambda (arg) (raise-until working-type arg)) 1559 | args)) 1560 | (error "No method for these types" (list op type-tags)))))))) 1561 | (define (raise-until type element) 1562 | (if (eq? type (type-tage element)) 1563 | element 1564 | (raise-until type (raise element)))) 1565 | 1566 | ;-- 2.85 1567 | (define install-project-package 1568 | (put 'project '(rational) 1569 | (lambda (x) (make-scheme-number (round (/ (numer x) (denom x)))))) 1570 | (put 'project '(real) 1571 | (lambda (x) (make-rat (round x) 1))) 1572 | (put 'project '(complex) 1573 | (lambda (x) (make-real (real-part x)))) 1574 | 'done) 1575 | (define (project x) 1576 | (apply-generic 'project x)) 1577 | 1578 | (define (drop x) 1579 | (if (equ? x (raise (project x))) 1580 | (drop (project x)) 1581 | x)) 1582 | 1583 | ; In order to drop the result of apply-generic: 1584 | (define (apply-generic op . args) 1585 | (let ((type-tags (map type-tag args))) 1586 | (let ((proc (get op type-tags))) 1587 | (if proc 1588 | (drop (apply proc (map contents args))) 1589 | (let ((working-type (find-working-type op args type-tags))) 1590 | (if working-type 1591 | (drop (apply-generic op (map (lambda (arg) (raise-until working-type 1592 | arg)) 1593 | args))) 1594 | (error "No method for these types" (list op type-tags)))))))) 1595 | 1596 | ;-- 2.86 1597 | ; Complicated question. Needs further research. 1598 | 1599 | ;-- 2.87 1600 | ; Given: 1601 | (define (install-polynomial-package) 1602 | ;; internal procedures 1603 | ;; representation of poly 1604 | (define (make-poly variable term-list) 1605 | (cons variable term-list)) 1606 | (define (variable p) (car p)) 1607 | (define (term-list p) (cdr p)) 1608 | (define (variable? x) (symbol? x)) 1609 | (define (same-variable? v1 v2) 1610 | (and (variable? v1) (variable? v2) (eq? v1 v2))) 1611 | ;; representation of terms and term lists 1612 | (define (adjoin-term term term-list) 1613 | (if (=zero? (coeff term)) 1614 | term-list 1615 | (cons term term-list))) 1616 | (define (the-empty-termlist) '()) 1617 | (define (first-term term-list) (car term-list)) 1618 | (define (rest-terms term-list) (cdr term-list)) 1619 | (define (empty-termlist? term-list) (null? term-list)) 1620 | (define (make-term order coeff) (list order coeff)) 1621 | (define (order term) (car term)) 1622 | (define (coeff term) (cadr term)) 1623 | 1624 | (define (add-poly p1 p2) 1625 | (if (same-variable? (variable p1) (variable p2)) 1626 | (make-poly (variable p1) 1627 | (add-terms (term-list p1) 1628 | (term-list p2))) 1629 | (error "Polys not in same var -- ADD-POLY" 1630 | (list p1 p2)))) 1631 | (define (mul-poly p1 p2) 1632 | (if (same-variable? (variable p1) (variable p2)) 1633 | (make-poly (variable p1) 1634 | (mul-terms (term-list p1) 1635 | (term-list p2))) 1636 | (error "Polys not in same var -- MUL-POLY" 1637 | (list p1 p2)))) 1638 | ;; interface to rest of the system 1639 | (define (tag p) (attach-tag 'polynomial p)) 1640 | (put 'add '(polynomial polynomial) 1641 | (lambda (p1 p2) (tag (add-poly p1 p2)))) 1642 | (put 'mul '(polynomial polynomial) 1643 | (lambda (p1 p2) (tag (mul-poly p1 p2)))) 1644 | (put 'make 'polynomial 1645 | (lambda (var terms) (tag (make-poly var terms)))) 1646 | 'done) 1647 | (define (add-terms L1 L2) 1648 | (cond ((empty-termlist? L1) L2) 1649 | ((empty-termlist? L2) L1) 1650 | (else 1651 | (let ((t1 (first-term L1)) (t2 (first-term L2))) 1652 | (cond ((> (order t1) (order t2)) 1653 | (adjoin-term 1654 | t1 (add-terms (rest-terms L1) L2))) 1655 | ((< (order t1) (order t2)) 1656 | (adjoin-term 1657 | t2 (add-terms L1 (rest-terms L2)))) 1658 | (else 1659 | (adjoin-term 1660 | (make-term (order t1) 1661 | (add (coeff t1) (coeff t2))) 1662 | (add-terms (rest-terms L1) 1663 | (rest-terms L2))))))))) 1664 | (define (mul-terms L1 L2) 1665 | (if (empty-termlist? L1) 1666 | (the-empty-termlist) 1667 | (add-terms (mul-term-by-all-terms (first-term L1) L2) 1668 | (mul-terms (rest-terms L1) L2)))) 1669 | (define (mul-term-by-all-terms t1 L) 1670 | (if (empty-termlist? L) 1671 | (the-empty-termlist) 1672 | (let ((t2 (first-term L))) 1673 | (adjoin-term 1674 | (make-term (+ (order t1) (order t2)) 1675 | (mul (coeff t1) (coeff t2))) 1676 | (mul-term-by-all-terms t1 (rest-terms L)))))) 1677 | 1678 | (define (make-polynomial var terms) 1679 | ((get 'make 'polynomial) var terms)) 1680 | 1681 | ; Question: 1682 | (define install-zero-poly-package 1683 | (put '=zero? 'polynomial 1684 | (lambda (poly) (= 0 1685 | (fold-left + 0 (map coeff (term-list poly))))) 1686 | 'done)) 1687 | 1688 | ;-- 2.88 1689 | (define install-sub-package 1690 | (define (negation termlist) 1691 | (map (lambda (term) (make-term (order term) (- (coeff term)))) 1692 | termlist)) 1693 | (define (sub-poly p1 p2) 1694 | (if (same-variable? (variable p1) (variable p2)) 1695 | (make-poly (variable p1) 1696 | (add-terms (term-list p1) 1697 | (negation (term-list p2)))) 1698 | (error "Polys not in same var -- SUB-POLY" 1699 | (list p1 p2)))) 1700 | (put 'sub '(polynomial polynomial) 1701 | (lambda (p1 p2) (tag (sub-poly p1 p2)))) 1702 | 'done) 1703 | 1704 | ;-- 2.89 1705 | (define (install-dense-polynomial-package) 1706 | ;; representation of terms and term lists - the rest stays the same 1707 | (define (adjoin-term term term-list) 1708 | (if (=zero? (coeff term)) 1709 | term-list 1710 | (if (= (order term) (length term-list)) ; i.e. lower orders are occupied 1711 | (cons (coeff term) term-list) 1712 | (adjoin-term term (cons 0 term-list))))) ; We will pad with 0 as needed 1713 | (define (the-empty-termlist) '()) 1714 | (define (first-term term-list) 1715 | (if (null? (cdr term-list)) 1716 | (car term-list) 1717 | (first-term (cdr term-list)))) 1718 | (define (empty-termlist? term-list) (null? term-list)) 1719 | (define (order term) (car term)) 1720 | (define (coeff term) (cadr term)) 1721 | 'done) 1722 | ; And we redefine add-terms and mul-terms: 1723 | (define (zip list1 list2) 1724 | (map list list1 list2)) 1725 | (define (pad lst target-length padding) 1726 | (if (= (length lst) target-length) 1727 | lst 1728 | (pad (cons padding lst) target-length padding))) 1729 | (define (add-terms L1 L2) 1730 | ; zipping the two list will give us coefficient pairs. We will merely have 1731 | ; to sum these lists using a fold 1732 | (let ((ml (max (length L1) (length L2)))) 1733 | (map (lambda (l) (apply + l)) 1734 | (zip (pad L1 ml 0) (pad L2 ml 0))))) 1735 | (define (mul-terms L1 L2) 1736 | (let ((ml (max (length L1) (length L2)))) 1737 | (map (lambda (l) (apply * l)) 1738 | (zip (pad L1 ml 1) (pad L2 ml 1))))) 1739 | 1740 | ;-- 2.90 1741 | ; This is a major effort, not a local change. <= okay, maybe later then. 1742 | 1743 | ;-- 2.91 1744 | (define (div-terms L1 L2) 1745 | (if (empty-termlist? L1) 1746 | (list (the-empty-termlist) (the-empty-termlist)) 1747 | (let ((t1 (first-term L1)) 1748 | (t2 (first-term L2))) 1749 | (if (> (order t2) (order t1)) 1750 | (list (the-empty-termlist) L1) 1751 | (let ((new-c (div (coeff t1) (coeff t2))) 1752 | (new-o (- (order t1) (order t2)))) 1753 | (let ((rest-of-result (div-terms (rest-terms L1) (rest-terms L2)) )) 1754 | (add-terms (make-term new-c new-o) rest-of-result) 1755 | )))))) 1756 | ; NB: untested. 1757 | 1758 | ;-- 2.92 1759 | ; "(This is not easy!)" <= Hmm... Exercise 2.93 to 2.97 are in the same 1760 | ; (mathematical) vein, so I'll leave them alone for the time being. 1761 | -------------------------------------------------------------------------------- /Chapter 3.scm: -------------------------------------------------------------------------------- 1 | ;-- 3.1 2 | (define (make-accumulator acc) 3 | (lambda (x) 4 | (set! acc (+ x acc)) 5 | acc)) 6 | 7 | ;-- 3.2 8 | (define (make-monitored function) 9 | (define times-called 0) 10 | (define (mf message) 11 | (cond ((eq? message 'how-many-calls?) times-called) 12 | ((eq? message 'reset-count) (set! times-called 0)) 13 | (else (set! times-called (+ times-called 1)) 14 | (function message)))) 15 | mf) 16 | 17 | ;-- 3.3 18 | (define (make-account balance password) 19 | (define (withdraw amount) 20 | (if (>= balance amount) 21 | (begin (set! balance (- balance amount)) 22 | balance) 23 | "Insufficient funds")) 24 | (define (deposit amount) 25 | (set! balance (+ balance amount)) 26 | balance) 27 | (define (dispatch m given-password) 28 | (if (eq? password given-password) 29 | (cond ((eq? m 'withdraw) withdraw) 30 | ((eq? m 'deposit) deposit) 31 | (else (error "Unknown request -- MAKE-ACCOUNT" 32 | m))) 33 | (lambda (x) "Incorrect password"))) 34 | dispatch) 35 | 36 | ;-- 3.4 37 | (define (make-account balance password) 38 | (define wrong-tries 0) 39 | (define (withdraw amount) 40 | (if (>= balance amount) 41 | (begin (set! balance (- balance amount)) 42 | balance) 43 | "Insufficient funds")) 44 | (define (deposit amount) 45 | (set! balance (+ balance amount)) 46 | balance) 47 | (define (dispatch m given-password) 48 | (if (eq? password given-password) 49 | (begin (set! wrong-tries 0) 50 | (cond ((eq? m 'withdraw) withdraw) 51 | ((eq? m 'deposit) deposit) 52 | (else (error "Unknown request -- MAKE-ACCOUNT" 53 | m)))) 54 | (begin (set! wrong-tries (+ wrong-tries 1)) 55 | (if (> wrong-tries 7) 56 | call-the-cops 57 | (lambda (x) "Incorrect password"))))) 58 | dispatch) 59 | 60 | ; call-the-cops example: 61 | (define call-the-cops 62 | (lambda (x) "HANDS UP!")) 63 | 64 | ; Test: 65 | (define pw (make-account 100 'la)) 66 | ((pw 'withdraw 'lag) 10) 67 | ; "Incorrect password" 68 | ((pw 'withdraw 'lag) 10) 69 | ; "Incorrect password" 70 | ((pw 'withdraw 'la) 10) 71 | ; 90 72 | ((pw 'withdraw 'lag) 10) 73 | ; "Incorrect password" 74 | ((pw 'withdraw 'lag) 10) 75 | ; "Incorrect password" 76 | ((pw 'withdraw 'lag) 10) 77 | ; "Incorrect password" 78 | ((pw 'withdraw 'lag) 10) 79 | ; "Incorrect password" 80 | ((pw 'withdraw 'lag) 10) 81 | ; "Incorrect password" 82 | ((pw 'withdraw 'lag) 10) 83 | ; "Incorrect password" 84 | ((pw 'withdraw 'lag) 10) 85 | ; "Incorrect password" 86 | ((pw 'withdraw 'lag) 10) 87 | "HANDS UP!" 88 | 89 | ;-- 3.5 90 | ; Given: 91 | (define (monte-carlo trials experiment) 92 | (define (iter trials-remaining trials-passed) 93 | (cond ((= trials-remaining 0) 94 | (/ trials-passed trials)) 95 | ((experiment) 96 | (iter (- trials-remaining 1) (+ trials-passed 1))) 97 | (else 98 | (iter (- trials-remaining 1) trials-passed)))) 99 | (iter trials 0)) 100 | (define (random-in-range low high) 101 | (let ((range (- high low))) 102 | (+ low (random range)))) 103 | 104 | ; Solution: 105 | (define (P x y) 106 | (< (+ (expt (- x 5) 2) 107 | (expt (- y 7) 2)) 108 | (expt 3 2))) 109 | (define (estimate-integral P x1 x2 y1 y2 trials) 110 | (define (experiment) 111 | (P (random-in-range x1 x2) 112 | (random-in-range y1 y2))) 113 | (monte-carlo trials experiment)) 114 | 115 | ; Test: 116 | (estimate-integral P 0 12 3 17 100) 117 | 118 | ; We can estimate pi with the fact that a circle area is (pi * r²) 119 | ; Hence pi ≅ (Monte Carlo results * rectangle area) / r² 120 | (define pi-approx 121 | (/ (* (estimate-integral P 2.0 8.0 4.0 10.0 10000) 36) 122 | 9.0)) 123 | pi-approx 124 | ; 3.1336 125 | 126 | ; This function has to be tested under MIT Scheme, neither gambit-scheme or 127 | ; SISC implements (random) - actually (random) is not part of R5RS nor SRFI. 128 | 129 | ; NB: using 2.0 instead of 2 in (estimate-integral) is primordial. If you pass 130 | ; two integers to (random-in-range low high), it will return another integer 131 | ; strictly inferior to your 'high' value |  and this completely screws the 132 | ; Monte-Carlo method (it then estimates pi to ~3.00). 133 | 134 | ;-- 3.6 135 | (define rand 136 | (let ((x random-init)) 137 | (define (dispatch message) 138 | (cond ((eq? message 'generate) 139 | (begin (set! x (rand-update x)) 140 | x)) 141 | ((eq? message 'reset) 142 | (lambda (new-value) (set! x new-value))))) 143 | dispatch)) 144 | 145 | ; Test: 146 | (define random-init 0) 147 | (define (rand-update x) (+ x 1)) ; Our not-very-evolved PNRG 148 | (rand 'generate) 149 | ; 1 150 | (rand 'generate) 151 | ; 2 152 | ((rand 'reset) 0) 153 | ; 0 154 | (rand 'generate) 155 | ; 1 156 | 157 | ; It's interesting to notice that the lambda returned by a call to 158 | ; (rand 'reset) still has the closure we created as lexical scope: 159 | x 160 | ; Error: undefined variable 'x'. 161 | 162 | ;-- 3.7 163 | (define (make-account balance password) 164 | (define password-list (list password)) 165 | (define (withdraw amount) 166 | (if (>= balance amount) 167 | (begin (set! balance (- balance amount)) 168 | balance) 169 | "Insufficient funds")) 170 | (define (deposit amount) 171 | (set! balance (+ balance amount)) 172 | balance) 173 | (define (dispatch m given-password) 174 | (if (memq given-password password-list) 175 | (cond ((eq? m 'withdraw) withdraw) 176 | ((eq? m 'deposit) deposit) 177 | ((eq? m 'joint) (lambda (new-pass) 178 | (set! password-list (cons new-pass password-list)) 179 | dispatch)) 180 | (else (error "Unknown request -- MAKE-ACCOUNT" 181 | m))) 182 | (lambda (x) "Incorrect password"))) 183 | dispatch) 184 | (define (make-joint account password new-account-password) 185 | ((account 'joint password) new-account-password)) 186 | 187 | ; Test: 188 | (define peter-acc (make-account 100 'open-sesame)) 189 | ((peter-acc 'withdraw 'open-sesame) 10) 190 | ; 90 191 | (define paul-acc 192 | (make-joint peter-acc 'open-sesame 'rosebud)) 193 | ((paul-acc 'withdraw 'rosebud) 15) 194 | ; 75 195 | ((peter-acc 'withdraw 'open-sesame) 10) 196 | ; 65 197 | 198 | ; This solution works, but is not perfect. For example, now we can access 199 | ; peter's account with paul's password: 200 | ((peter-acc 'withdraw 'rosebud) 10) 201 | ; 55 202 | ; One would expect that the password would be different for each account. 203 | 204 | ;-- 3.8 205 | (define f 206 | (let ((init (- 1))) 207 | (lambda (x) (if (= init (- 1)) 208 | (set! init x) 209 | 0)))) 210 | 211 | ;-- 3.9 212 | ;-- 3.10 213 | ;-- 3.11 214 | ;-- 3.12 215 | (define (append! x y) 216 | (set-cdr! (last-pair x) y) 217 | x) 218 | (define (last-pair x) 219 | (if (null? (cdr x)) 220 | x 221 | (last-pair (cdr x)))) 222 | (define x (list 'a 'b)) 223 | ; 224 | ; x-> [*| *]->[*| /] 225 | ; | | 226 | ; v v 227 | ; [a] [b] 228 | ; 229 | (define y (list 'c 'd)) 230 | ; 231 | ; y-> [*| *]->[*| /] 232 | ; | | 233 | ; v v 234 | ; [c] [d] 235 | ; 236 | (define z (append x y)) 237 | ; 238 | ; z-> [*| *]->[*| *]->[*| *]->[*| /] 239 | ; | | | | 240 | ; v v v v 241 | ; [a] [b] [c] [d] 242 | ; 243 | (cdr x) 244 | ; (b) 245 | (define w (append! x y)) 246 | ; The trick is that now, w == x == (a b c d) 247 | ; Hence: 248 | (cdr x) 249 | ; (b c d) 250 | 251 | ;-- 3.13 252 | (define (make-cycle x) 253 | (set-cdr! (last-pair x) x) 254 | x) 255 | (define z (make-cycle (list 'a 'b 'c))) 256 | ; ___________ 257 | ; / \ 258 | ; v | 259 | ; z-> [*| *]->[*| *]->[*| *] 260 | ; | | | 261 | ; v v v 262 | ; [a] [b] [c] 263 | ; 264 | ; Trying to compute (last-pair z) would result in an infinite loop - the stop 265 | ; condition cannot occur. 266 | 267 | ;-- 3.14 268 | (define (mystery x) 269 | (define (loop x y) 270 | (if (null? x) 271 | y 272 | (let ((temp (cdr x))) 273 | (set-cdr! x y) 274 | (loop temp x)))) 275 | (loop x '())) 276 | ; Mystery looks like a list-reversal function at first glance. Is it? Let's 277 | ; unroll it! We'll try with '(1 2 3) 278 | ; 279 | ; (mystery '(1 2 3)) 280 | ; 281 | ; => (loop '(1 2 3) '()) 282 | ; ===> temp is '(2 3) 283 | ; ===> x becomes '(1) 284 | ; 285 | ; => (loop '(2 3) '(1)) 286 | ; ===> temp is '(3) 287 | ; ===> x becomes '(2 1) 288 | ; 289 | ; => (loop '(3) '(2 1)) 290 | ; ===> temp is nil 291 | ; ===> x becomes '(3 2 1) 292 | ; 293 | ; => (loop '() '(3 2 1)) 294 | ; ===> exits because x is nil ans returns y, i.e. '(3 2 1) 295 | ; 296 | ; It is a list-reversal function! Well done, self! 297 | 298 | (define v (list 'a 'b 'c 'd)) 299 | ; 300 | ; v-> [*| *]->[*| *]->[*| *]->[*| /] 301 | ; | | | | 302 | ; v v v v 303 | ; [a] [b] [c] [d] 304 | ; 305 | (define w (mystery v)) 306 | ; w-> [*| *]->[*| *]->[*| *]->[*| /] 307 | ; | | | | 308 | ; v v v v 309 | ; [d] [c] [b] [a] 310 | ; ^ 311 | ; / 312 | ; v ------------- 313 | v 314 | ; (a) 315 | w 316 | ; (d c b a) 317 | 318 | ;-- 3.16 319 | (define (count-pairs x) 320 | (if (not (pair? x)) 321 | 0 322 | (+ (count-pairs (car x)) 323 | (count-pairs (cdr x)) 324 | 1))) 325 | ; Simpler case: 326 | (define three-pairs (list 'a 'b 'c)) 327 | (count-pairs three-pairs) 328 | ; 3 329 | ; Double reference: 330 | (define alist (list 'a)) 331 | (define twice-alist (cons alist alist)) 332 | (define four-pairs (list twice-alist)) 333 | (count-pairs four-pairs) 334 | ; 4 335 | ; Double reference at another level yields 5: 336 | (define alist (list 'a)) 337 | (define alistlist (list alist)) 338 | (define five-pairs (cons alistlist alistlist)) 339 | (count-pairs five-pairs) 340 | ; 5 341 | ; And double double reference gives 7: 342 | (define alist (list 'a)) 343 | (define twice-alist (cons alist alist)) 344 | (define seven-pairs (cons twice-alist twice-alist)) 345 | (count-pairs seven-pairs) 346 | ; 7 347 | 348 | ;-- 3.17 349 | (define (count-pairs x) 350 | (define visited '()) 351 | (define count 0) 352 | (define (visit pair) 353 | (if (not (memq pair visited)) 354 | (begin (set! visited (cons pair visited)) 355 | (set! count (+ 1 count))))) 356 | (define (populate-list x) 357 | (if (pair? x) 358 | (begin (populate-list (car x)) 359 | (populate-list (cdr x)) 360 | (visit x)))) 361 | (begin (populate-list x) 362 | count)) 363 | ; Tests (as defined in 3.16): 364 | (count-pairs three-pairs) 365 | ; 3 366 | (count-pairs four-pairs) 367 | ; 3 368 | (count-pairs five-pairs) 369 | ; 3 370 | (count-pairs seven-pairs) 371 | ; 3 372 | 373 | ;-- 3.18 374 | (define (cycle? x) 375 | ; cycle? will walk the list and add each element to a stack until either the 376 | ; current element is not a pair (i.e. the list is not a cycle) or the current 377 | ; element is in the stack (i.e. there's a cycle). 378 | (define (test x stack) 379 | (if (pair? x) 380 | (if (memq x stack) 381 | #t 382 | (test (cdr x) (cons x stack))) 383 | #f)) 384 | (test x '())) 385 | ; Test: 386 | (define (last-pair x) 387 | (if (null? (cdr x)) 388 | x 389 | (last-pair (cdr x)))) 390 | (define (make-cycle x) 391 | (set-cdr! (last-pair x) x) 392 | x) 393 | (define z (make-cycle (list 'a 'b 'c))) 394 | (cycle? z) 395 | ; #t 396 | (cycle? (list 'a 'b 'c)) 397 | ; #f 398 | 399 | ;-- 3.19 400 | ; "(This requires a very clever idea.)" 401 | ; I did not have this very clever idea, but Robert Floyd did: two pointers, 402 | ; walking the list at different speed (colloquially called the "tortoise and 403 | ; the hare" algorithm). 404 | ; More info: http://en.wikipedia.org/wiki/Cycle_detection 405 | ; A solution: 406 | (define (cycle? x) 407 | (define (cycle-iter tortoise hare) 408 | (cond ((eq? tortoise hare) 409 | #t) 410 | ((or (not (pair? tortoise)) 411 | (not (pair? hare)) 412 | (not (pair? (cdr hare)))) 413 | #f) 414 | (else (cycle-iter (cdr tortoise) (cddr hare))))) 415 | (if (pair? x) 416 | (cycle-iter x (cdr x)) 417 | #f)) 418 | 419 | ; Test: 420 | (cycle? z) 421 | ; #t 422 | (cycle? (list 'a 'b 'c)) 423 | ; #f 424 | 425 | ;-- 3.20 426 | ; Environment diagrams 427 | 428 | ;-- 3.21 429 | ; Given queue functions: 430 | (define (front-ptr queue) (car queue)) 431 | (define (rear-ptr queue) (cdr queue)) 432 | (define (set-front-ptr! queue item) (set-car! queue item)) 433 | (define (set-rear-ptr! queue item) (set-cdr! queue item)) 434 | (define (empty-queue? queue) (null? (front-ptr queue))) 435 | (define (make-queue) (cons '() '())) 436 | (define (front-queue queue) 437 | (if (empty-queue? queue) 438 | (error "FRONT called with an empty queue" queue) 439 | (car (front-ptr queue)))) 440 | (define (insert-queue! queue item) 441 | (let ((new-pair (cons item '()))) 442 | (cond ((empty-queue? queue) 443 | (set-front-ptr! queue new-pair) 444 | (set-rear-ptr! queue new-pair) 445 | queue) 446 | (else 447 | (set-cdr! (rear-ptr queue) new-pair) 448 | (set-rear-ptr! queue new-pair) 449 | queue)))) 450 | (define (delete-queue! queue) 451 | (cond ((empty-queue? queue) 452 | (error "DELETE! called with an empty queue" queue)) 453 | (else 454 | (set-front-ptr! queue (cdr (front-ptr queue))) 455 | queue))) 456 | 457 | ; Answer: 458 | ; The queue is actually empty. The rear-ptr isn't updated, but it doesn't 459 | ; matter - testing for the empty queue only bothers with front-ptr, and as soon 460 | ; as we add a new element to the queue, rear-ptr will be updated. 461 | (define (print-queue q) 462 | (define (print-list l) 463 | (if (not (null? l)) 464 | (begin (display (car l)) 465 | (newline) 466 | (print-list (cdr l))))) 467 | (if (null? (car q)) 468 | (display "The queue is empty.\n") 469 | (print-list (car q)))) 470 | 471 | ; Test: 472 | (define q (make-queue)) 473 | (print-queue q) 474 | ; The queue is empty. 475 | (insert-queue! q 'a) 476 | (print-queue q) 477 | ; a 478 | (insert-queue! q 'b) 479 | (print-queue q) 480 | ; a b 481 | (delete-queue! q) 482 | (print-queue q) 483 | ; b 484 | (delete-queue! q) 485 | (print-queue q) 486 | ; The queue is empty. 487 | 488 | ;-- 3.22 489 | (define (make-queue) 490 | (let ((front-ptr '()) 491 | (rear-ptr '())) 492 | (define (empty-queue?) (null? front-ptr)) 493 | (define (front-queue) 494 | (if (empty-queue?) 495 | (error "FRONT called with an empty queue") 496 | (car front-ptr))) 497 | (define (insert-queue! item) 498 | (let ((new-pair (cons item '()))) 499 | (cond ((empty-queue?) 500 | (set! front-ptr new-pair) 501 | (set! rear-ptr new-pair)) 502 | (else 503 | (set-cdr! rear-ptr new-pair) 504 | (set! rear-ptr new-pair))))) 505 | (define (delete-queue!) 506 | (cond ((empty-queue?) 507 | (error "DELETE! called with an empty queue")) 508 | (else 509 | (set! front-ptr (cdr front-ptr))))) 510 | (define (print-queue) 511 | (define (print-iter l) 512 | (if (not (null? l)) 513 | (begin (display (car l)) 514 | (newline) 515 | (print-iter (cdr l))))) 516 | (if (empty-queue?) 517 | (display "The queue is empty.\n") 518 | (print-iter front-ptr))) 519 | (define (dispatch m) 520 | (cond ((eq? m 'front-ptr) front-ptr) 521 | ((eq? m 'rear-ptr) rear-ptr) 522 | ((eq? m 'front-queue) (front-queue)) 523 | ((eq? m 'empty-queue?) (empty-queue?)) 524 | ((eq? m 'insert-queue!) insert-queue!) 525 | ((eq? m 'delete-queue!) (delete-queue!)) 526 | ((eq? m 'print-queue) (print-queue)) 527 | (else (error "Unknown request -- MAKE-QUEUE" m)))) 528 | dispatch)) 529 | ; And some wrapper functions to behave exactly as before: 530 | (define (front-ptr q) 531 | (q 'front-ptr)) 532 | (define (rear-ptr q) 533 | (q 'rear-ptr)) 534 | (define (front-queue q) 535 | (q 'front-queue)) 536 | (define (insert-queue! q item) 537 | ((q 'insert-queue!) item)) 538 | (define (delete-queue! q) 539 | (q 'delete-queue!)) 540 | (define (print-queue q) 541 | (q 'print-queue)) 542 | 543 | ; Test (same as the previous question): 544 | (define q (make-queue)) 545 | (print-queue q) 546 | ; The queue is empty. 547 | (insert-queue! q 'a) 548 | (print-queue q) 549 | ; a 550 | (insert-queue! q 'b) 551 | (print-queue q) 552 | ; a b 553 | (delete-queue! q) 554 | (print-queue q) 555 | ; b 556 | (delete-queue! q) 557 | (print-queue q) 558 | ; The queue is empty. 559 | 560 | ;-- 3.23 561 | (define (make-deque) (cons '() '())) 562 | (define front-ptr car) 563 | (define rear-ptr cdr) 564 | (define set-front-ptr! set-car!) 565 | (define set-rear-ptr! set-cdr!) 566 | (define (empty-deque? deque) 567 | (or (null? deque) (null? (front-ptr deque)))) 568 | (define (front-deque deque) 569 | (if (empty-deque? deque) 570 | (error "FRONT called with an empty deque" deque) 571 | (caar deque))) 572 | (define (rear-deque deque) 573 | (if (empty-deque? deque) 574 | (error "REAR called with an empty deque" deque) 575 | (cadr deque))) 576 | (define (front-insert-deque! deque item) 577 | (cond ((empty-deque? deque) 578 | (let ((new-pair (cons item (cons '() '())))) 579 | (set-front-ptr! deque new-pair) 580 | (set-rear-ptr! deque new-pair) 581 | deque)) 582 | (else 583 | (let ((new-pair (cons item (cons '() (front-ptr deque))))) 584 | (set-car! (cdr (front-ptr deque)) new-pair) 585 | (set-front-ptr! deque new-pair) 586 | deque)))) 587 | (define (rear-insert-deque! deque item) 588 | (cond ((empty-deque? deque) 589 | (let ((new-pair (cons item (cons '() '())))) 590 | (set-front-ptr! deque new-pair) 591 | (set-rear-ptr! deque new-pair) 592 | deque)) 593 | (else 594 | (let ((new-pair (cons item (cons (rear-ptr deque) '())))) 595 | (set-cdr! (cdr (rear-ptr deque)) new-pair) 596 | (set-rear-ptr! deque new-pair) 597 | deque)))) 598 | (define (front-delete-deque! deque) 599 | (cond ((empty-deque? deque) 600 | (error "DELETE! called with an empty deque" deque)) 601 | (else 602 | (if (eq? (front-ptr deque) (rear-ptr deque)) 603 | (begin (set-front-ptr! deque '()) 604 | (set-rear-ptr! deque '()) 605 | deque) 606 | (begin (set-front-ptr! deque (cddr (front-ptr deque))) 607 | (set-car! (cdr (front-ptr deque)) '()) 608 | deque))))) 609 | (define (rear-delete-deque! deque) 610 | (cond ((empty-deque? deque) 611 | (error "DELETE! called with an empty deque" deque)) 612 | (else 613 | (if (eq? (front-ptr deque) (rear-ptr deque)) 614 | (begin (set-front-ptr! deque '()) 615 | (set-rear-ptr! deque '()) 616 | deque) 617 | (begin (set-rear-ptr! deque (cadr (rear-ptr deque))) 618 | (set-cdr! (cdr (rear-ptr deque)) '()) 619 | deque))))) 620 | (define (print-deque d) 621 | (define (print-iter l) 622 | (if (not (null? l)) 623 | (begin (display (car l)) 624 | (newline) 625 | (print-iter (cddr l))))) 626 | (if (empty-deque? d) 627 | (display "The deque is empty.\n") 628 | (print-iter (car d)))) 629 | 630 | ; Test: 631 | (define d (make-deque)) 632 | (print-deque d) 633 | ; The deque is empty. 634 | (front-insert-deque! d 'b) 635 | (print-deque d) 636 | ; b 637 | (front-insert-deque! d 'a) 638 | (print-deque d) 639 | ; a b 640 | (rear-insert-deque! d 'c) 641 | (print-deque d) 642 | ; a b c 643 | (front-delete-deque! d) 644 | (print-deque d) 645 | ; b c 646 | (rear-delete-deque! d) 647 | (print-deque d) 648 | ; b 649 | (rear-delete-deque! d) 650 | (print-deque d) 651 | ; The deque is empty. 652 | (rear-insert-deque! d 'z) 653 | (print-deque d) 654 | ; z 655 | 656 | ;-- 3.24 657 | (define (make-table same-key?) 658 | (let ((local-table (list '*table*))) 659 | ; We only need to redefine assoc to account for the same-key? test 660 | (define (assoc key records) 661 | (cond ((null? records) #f) 662 | ((same-key? key (caar records)) (car records)) 663 | (else (assoc key (cdr records))))) 664 | ; -- snip -- ; 665 | dispatch)) 666 | 667 | ;-- 3.25 668 | ; n-dimensional table 669 | (define (lookup keys table) 670 | (if (not (pair? table)) 671 | #f 672 | (if (null? keys) 673 | (cdr table) 674 | (lookup (cdr keys) (assoc (car keys) (cdr table)))))) 675 | ; I now suspect that the whole SICP is a practical joke to find a way 676 | ; to make people write "car keys" in Scheme. 677 | (define (insert! keys value table) 678 | (if (null? keys) 679 | #f 680 | (if (null? keys) 681 | (cdr table) 682 | (lookup (cdr keys) (assoc (car keys) (cdr table))))) 683 | (let ((subtable (assoc key-1 (cdr table)))) 684 | (if subtable 685 | (let ((record (assoc key-2 (cdr subtable)))) 686 | (if record 687 | (set-cdr! record value) 688 | (set-cdr! subtable 689 | (cons (cons key-2 value) 690 | (cdr subtable))))) 691 | (set-cdr! table 692 | (cons (list key-1 693 | (cons key-2 value)) 694 | (cdr table))))) 695 | 'ok) 696 | 697 | 698 | 699 | ;-- 3.28 700 | (define (logical-or a1 a2) 701 | (cond 702 | ((and (= a1 1) (= a2 1)) 1) 703 | ((and (= a1 1) (= a2 0)) 1) 704 | ((and (= a1 0) (= a2 1)) 1) 705 | ((and (= a1 0) (= a2 0)) 0) 706 | (else (error "Invalid signal")))) 707 | (define (or-gate o1 o2 output) 708 | (define (or-action-procedure) 709 | (let ((new-value 710 | (logical-or (get-signal o1) (get-signal o2)))) 711 | (after-delay or-gate-delay 712 | (lambda () 713 | (set-signal! output new-value))))) 714 | (add-action! o1 or-action-procedure) 715 | (add-action! o2 or-action-procedure) 716 | 'ok) 717 | 718 | ;-- 3.29 719 | ; De Morgan's law: 720 | ; a ∧ b ⇔ ¬(¬a ∨ ¬b) 721 | (define (or-gate o1 o2 output) 722 | (let ((b1 (make-wire)) 723 | (b2 (make-wire)) 724 | (c1 (make-wire))) 725 | (inverter o1 b1) 726 | (inverter o2 b2) 727 | (and-gate b1 b2 c1) 728 | (inverter c1 output) 729 | 'ok)) 730 | 731 | ; The delay is inverter-delay + and-gate-delay + inverter-delay. 732 | ; (The first two inverters work in parallel). 733 | 734 | ;-- 3.30 735 | (define (ripple-carry-adder As Bs Ss C) 736 | (if (list? As) 737 | (let ((c-out (make-wire))) 738 | (full-adder (car As) (car Bs) C (car Ss) c-out) 739 | (ripple-carry-adder (cdr As) (cdr Bs) (cdr Ss) c-out)) 740 | (full-adder As Bs C Ss (make-wire)))) 741 | 742 | ; Time complexity: 743 | ; Of one half-adder: (max (and-gate-delay+inverter-delay) (or-gate-delay)) 744 | ; + and-gate-delay 745 | ; Of one full-adder: (2 * half-adder-delay) + or-gate-delay 746 | ; Of a ripple-carry-adder of complexity n: n * full-adder-delay 747 | ; 748 | ; All in all... n * or-gate-delay 749 | ; + 2n * and-gate-delay 750 | ; + 2n * (max (and-gate-delay+inverter-delay) (or-gate-delay)) 751 | 752 | ;-- 3.31 753 | ; accept-action-procedure! needs to run the (proc) it receives a first time 754 | ; so that the (proc) will know the original value of the wire and will be able 755 | ; to tell when that value changed (for example, to display). 756 | 757 | ;-- 3.32 758 | ; Given: 759 | (define (make-wire) 760 | (let ((signal-value 0) (action-procedures '())) 761 | (define (set-my-signal! new-value) 762 | (if (not (= signal-value new-value)) 763 | (begin (set! signal-value new-value) 764 | (call-each action-procedures)) 765 | 'done)) 766 | (define (accept-action-procedure! proc) 767 | (set! action-procedures (cons proc action-procedures)) 768 | (proc)) 769 | (define (dispatch m) 770 | (cond ((eq? m 'get-signal) signal-value) 771 | ((eq? m 'set-signal!) set-my-signal!) 772 | ((eq? m 'add-action!) accept-action-procedure!) 773 | (else (error "Unknown operation -- WIRE" m)))) 774 | dispatch)) 775 | (define (call-each procedures) 776 | (if (null? procedures) 777 | 'done 778 | (begin 779 | ((car procedures)) 780 | (call-each (cdr procedures))))) 781 | (define (get-signal wire) 782 | (wire 'get-signal)) 783 | (define (set-signal! wire new-value) 784 | ((wire 'set-signal!) new-value)) 785 | (define (add-action! wire action-procedure) 786 | ((wire 'add-action!) action-procedure)) 787 | (define (after-delay delay action) 788 | (add-to-agenda! (+ delay (current-time the-agenda)) 789 | action 790 | the-agenda)) 791 | (define (propagate) 792 | (if (empty-agenda? the-agenda) 793 | 'done 794 | (let ((first-item (first-agenda-item the-agenda))) 795 | (first-item) 796 | (remove-first-agenda-item! the-agenda) 797 | (propagate)))) 798 | (define (probe name wire) 799 | (add-action! wire 800 | (lambda () 801 | (newline) 802 | (display name) 803 | (display " ") 804 | (display (current-time the-agenda)) 805 | (display " New-value = ") 806 | (display (get-signal wire))))) 807 | (define (make-time-segment time queue) 808 | (cons time queue)) 809 | (define (segment-time s) (car s)) 810 | (define (segment-queue s) (cdr s)) 811 | (define (make-agenda) (list 0)) 812 | (define (current-time agenda) (car agenda)) 813 | (define (set-current-time! agenda time) 814 | (set-car! agenda time)) 815 | (define (segments agenda) (cdr agenda)) 816 | (define (set-segments! agenda segments) 817 | (set-cdr! agenda segments)) 818 | (define (first-segment agenda) (car (segments agenda))) 819 | (define (rest-segments agenda) (cdr (segments agenda))) 820 | (define (empty-agenda? agenda) 821 | (null? (segments agenda))) 822 | (define (add-to-agenda! time action agenda) 823 | (define (belongs-before? segments) 824 | (or (null? segments) 825 | (< time (segment-time (car segments))))) 826 | (define (make-new-time-segment time action) 827 | (let ((q (make-queue))) 828 | (insert-queue! q action) 829 | (make-time-segment time q))) 830 | (define (add-to-segments! segments) 831 | (if (= (segment-time (car segments)) time) 832 | (insert-queue! (segment-queue (car segments)) 833 | action) 834 | (let ((rest (cdr segments))) 835 | (if (belongs-before? rest) 836 | (set-cdr! 837 | segments 838 | (cons (make-new-time-segment time action) 839 | (cdr segments))) 840 | (add-to-segments! rest))))) 841 | (let ((segments (segments agenda))) 842 | (if (belongs-before? segments) 843 | (set-segments! 844 | agenda 845 | (cons (make-new-time-segment time action) 846 | segments)) 847 | (add-to-segments! segments)))) 848 | (define (remove-first-agenda-item! agenda) 849 | (let ((q (segment-queue (first-segment agenda)))) 850 | (delete-queue! q) 851 | (if (empty-queue? q) 852 | (set-segments! agenda (rest-segments agenda))))) 853 | (define (first-agenda-item agenda) 854 | (if (empty-agenda? agenda) 855 | (error "Agenda is empty -- FIRST-AGENDA-ITEM") 856 | (let ((first-seg (first-segment agenda))) 857 | (set-current-time! agenda (segment-time first-seg)) 858 | (front-queue (segment-queue first-seg))))) 859 | ; And some functions from before: 860 | (define (half-adder a b s c) 861 | (let ((d (make-wire)) (e (make-wire))) 862 | (or-gate a b d) 863 | (and-gate a b c) 864 | (inverter c e) 865 | (and-gate d e s) 866 | 'ok)) 867 | (define (and-gate a1 a2 output) 868 | (define (and-action-procedure) 869 | (let ((new-value 870 | (logical-and (get-signal a1) (get-signal a2)))) 871 | (after-delay and-gate-delay 872 | (lambda () 873 | (set-signal! output new-value))))) 874 | (add-action! a1 and-action-procedure) 875 | (add-action! a2 and-action-procedure) 876 | 'ok) 877 | (define (inverter input output) 878 | (define (invert-input) 879 | (let ((new-value (logical-not (get-signal input)))) 880 | (after-delay inverter-delay 881 | (lambda () 882 | (set-signal! output new-value))))) 883 | (add-action! input invert-input) 884 | 'ok) 885 | (define (logical-not s) 886 | (cond ((= s 0) 1) 887 | ((= s 1) 0) 888 | (else (error "Invalid signal" s)))) 889 | ; The or-gate from 3.28 and not the one from 3.29! This is important for the 890 | ; delays: the or-gate we made out of and-gates and inverters will have a higher 891 | ; delay than a 'vanilla' or-gate 892 | (define (logical-or a1 a2) 893 | (cond 894 | ((and (= a1 1) (= a2 1)) 1) 895 | ((and (= a1 1) (= a2 0)) 1) 896 | ((and (= a1 0) (= a2 1)) 1) 897 | ((and (= a1 0) (= a2 0)) 0) 898 | (else (error "Invalid signal")))) 899 | (define (or-gate o1 o2 output) 900 | (define (or-action-procedure) 901 | (let ((new-value 902 | (logical-or (get-signal o1) (get-signal o2)))) 903 | (after-delay or-gate-delay 904 | (lambda () 905 | (set-signal! output new-value))))) 906 | (add-action! o1 or-action-procedure) 907 | (add-action! o2 or-action-procedure) 908 | 'ok) 909 | ; The queue from earlier: 910 | (define (front-ptr queue) (car queue)) 911 | (define (rear-ptr queue) (cdr queue)) 912 | (define (set-front-ptr! queue item) (set-car! queue item)) 913 | (define (set-rear-ptr! queue item) (set-cdr! queue item)) 914 | (define (empty-queue? queue) (null? (front-ptr queue))) 915 | (define (make-queue) (cons '() '())) 916 | (define (front-queue queue) 917 | (if (empty-queue? queue) 918 | (error "FRONT called with an empty queue" queue) 919 | (car (front-ptr queue)))) 920 | (define (insert-queue! queue item) 921 | (let ((new-pair (cons item '()))) 922 | (cond ((empty-queue? queue) 923 | (set-front-ptr! queue new-pair) 924 | (set-rear-ptr! queue new-pair) 925 | queue) 926 | (else 927 | (set-cdr! (rear-ptr queue) new-pair) 928 | (set-rear-ptr! queue new-pair) 929 | queue)))) 930 | (define (delete-queue! queue) 931 | (cond ((empty-queue? queue) 932 | (error "DELETE! called with an empty queue" queue)) 933 | (else 934 | (set-front-ptr! queue (cdr (front-ptr queue))) 935 | queue))) 936 | ; And this one that we have to add ourselves because Abelson and Sussman were 937 | ; too lazy to write it down: 938 | (define (logical-and a b) 939 | (cond ((and (= a 1) (= b 1)) 1) 940 | ((and (= a 1) (= b 0)) 0) 941 | ((and (= a 0) (= b 1)) 0) 942 | ((and (= a 0) (= b 0)) 0) 943 | (else (error "Invalid signal")))) 944 | ; Delay values: 945 | (define inverter-delay 2) 946 | (define and-gate-delay 3) 947 | (define or-gate-delay 5) 948 | ; Set up the agenda: 949 | (define the-agenda (make-agenda)) 950 | ; At this point, we can test our gates: 951 | (define a1 (make-wire)) 952 | (define a2 (make-wire)) 953 | (define and_output (make-wire)) 954 | (probe 'and_output and_output) 955 | (and-gate a1 a2 and_output) 956 | (set-signal! a1 1) 957 | (set-signal! a2 0) 958 | (propagate) 959 | ; => Nothing is printed because output stays at 0 960 | (set-signal! a2 1) 961 | (propagate) 962 | ; Should print 'and_output 6 New-value = 1' 963 | (set-signal! a2 0) 964 | (propagate) 965 | ; Should print 'and_output 9 New-value = 0' 966 | 967 | ; The simulation given in SICP: 968 | (define the-agenda (make-agenda)) ; Reset the agenda 969 | (define input-1 (make-wire)) 970 | (define input-2 (make-wire)) 971 | (define sum (make-wire)) 972 | (define carry (make-wire)) 973 | (probe 'sum sum) 974 | (probe 'carry carry) 975 | (half-adder input-1 input-2 sum carry) 976 | (set-signal! input-1 1) 977 | (propagate) 978 | ; Should print 'sum 8 New-value = 1' 979 | (set-signal! input-2 1) 980 | (propagate) 981 | ; Should print 'carry 11 New-value = 1' and 'sum 16 New-value = 0'. Yay! 982 | 983 | ; Now let's answer the question: 984 | ; "The procedures to be run during each time segment of the agenda are kept in 985 | ; a queue. Thus, the procedures for each segment are called in the order in 986 | ; which they were added to the agenda (first in, first out). Explain why this 987 | ; order must be used. In particular, trace the behavior of an and-gate whose 988 | ; inputs change from 0,1 to 1,0 in the same segment and say how the behavior 989 | ; would differ if we stored a segment's procedure in an ordinary list, adding 990 | ; and removing procedures only at the front (last in, first out). " 991 | 992 | ; Let's try with the and gate. If its two inputs are at (0, 1), there are two 993 | ; ways to sequentially change them to (1, 0): 994 | ; FIFO: (0, 1) -> (0, 0) -> (1, 0) 995 | ; LIFO: (0, 1) -> (1, 1) -> (1, 0) 996 | ; The second way will have the output flicker from 0 to 1, which we don't want. 997 | 998 | ;-- 3.33 999 | ; Given: 1000 | (define (adder a1 a2 sum) 1001 | (define (process-new-value) 1002 | (cond ((and (has-value? a1) (has-value? a2)) 1003 | (set-value! sum 1004 | (+ (get-value a1) (get-value a2)) 1005 | me)) 1006 | ((and (has-value? a1) (has-value? sum)) 1007 | (set-value! a2 1008 | (- (get-value sum) (get-value a1)) 1009 | me)) 1010 | ((and (has-value? a2) (has-value? sum)) 1011 | (set-value! a1 1012 | (- (get-value sum) (get-value a2)) 1013 | me)))) 1014 | (define (process-forget-value) 1015 | (forget-value! sum me) 1016 | (forget-value! a1 me) 1017 | (forget-value! a2 me) 1018 | (process-new-value)) 1019 | (define (me request) 1020 | (cond ((eq? request 'I-have-a-value) 1021 | (process-new-value)) 1022 | ((eq? request 'I-lost-my-value) 1023 | (process-forget-value)) 1024 | (else 1025 | (error "Unknown request -- ADDER" request)))) 1026 | (connect a1 me) 1027 | (connect a2 me) 1028 | (connect sum me) 1029 | me) 1030 | (define (inform-about-value constraint) 1031 | (constraint 'I-have-a-value)) 1032 | (define (inform-about-no-value constraint) 1033 | (constraint 'I-lost-my-value)) 1034 | (define (multiplier m1 m2 product) 1035 | (define (process-new-value) 1036 | (cond ((or (and (has-value? m1) (= (get-value m1) 0)) 1037 | (and (has-value? m2) (= (get-value m2) 0))) 1038 | (set-value! product 0 me)) 1039 | ((and (has-value? m1) (has-value? m2)) 1040 | (set-value! product 1041 | (* (get-value m1) (get-value m2)) 1042 | me)) 1043 | ((and (has-value? product) (has-value? m1)) 1044 | (set-value! m2 1045 | (/ (get-value product) (get-value m1)) 1046 | me)) 1047 | ((and (has-value? product) (has-value? m2)) 1048 | (set-value! m1 1049 | (/ (get-value product) (get-value m2)) 1050 | me)))) 1051 | (define (process-forget-value) 1052 | (forget-value! product me) 1053 | (forget-value! m1 me) 1054 | (forget-value! m2 me) 1055 | (process-new-value)) 1056 | (define (me request) 1057 | (cond ((eq? request 'I-have-a-value) 1058 | (process-new-value)) 1059 | ((eq? request 'I-lost-my-value) 1060 | (process-forget-value)) 1061 | (else 1062 | (error "Unknown request -- MULTIPLIER" request)))) 1063 | (connect m1 me) 1064 | (connect m2 me) 1065 | (connect product me) 1066 | me) 1067 | (define (constant value connector) 1068 | (define (me request) 1069 | (error "Unknown request -- CONSTANT" request)) 1070 | (connect connector me) 1071 | (set-value! connector value me) 1072 | me) 1073 | (define (probe name connector) 1074 | (define (print-probe value) 1075 | (newline) 1076 | (display "Probe: ") 1077 | (display name) 1078 | (display " = ") 1079 | (display value)) 1080 | (define (process-new-value) 1081 | (print-probe (get-value connector))) 1082 | (define (process-forget-value) 1083 | (print-probe "?")) 1084 | (define (me request) 1085 | (cond ((eq? request 'I-have-a-value) 1086 | (process-new-value)) 1087 | ((eq? request 'I-lost-my-value) 1088 | (process-forget-value)) 1089 | (else 1090 | (error "Unknown request -- PROBE" request)))) 1091 | (connect connector me) 1092 | me) 1093 | (define (make-connector) 1094 | (let ((value #f) (informant #f) (constraints '())) 1095 | (define (set-my-value newval setter) 1096 | (cond ((not (has-value? me)) 1097 | (set! value newval) 1098 | (set! informant setter) 1099 | (for-each-except setter 1100 | inform-about-value 1101 | constraints)) 1102 | ((not (= value newval)) 1103 | (error "Contradiction" (list value newval))) 1104 | (else 'ignored))) 1105 | (define (forget-my-value retractor) 1106 | (if (eq? retractor informant) 1107 | (begin (set! informant #f) 1108 | (for-each-except retractor 1109 | inform-about-no-value 1110 | constraints)) 1111 | 'ignored)) 1112 | (define (connect new-constraint) 1113 | (if (not (memq new-constraint constraints)) 1114 | (set! constraints 1115 | (cons new-constraint constraints))) 1116 | (if (has-value? me) 1117 | (inform-about-value new-constraint)) 1118 | 'done) 1119 | (define (me request) 1120 | (cond ((eq? request 'has-value?) 1121 | (if informant #t #f)) 1122 | ((eq? request 'value) value) 1123 | ((eq? request 'set-value!) set-my-value) 1124 | ((eq? request 'forget) forget-my-value) 1125 | ((eq? request 'connect) connect) 1126 | (else (error "Unknown operation -- CONNECTOR" 1127 | request)))) 1128 | me)) 1129 | (define (for-each-except exception procedure list) 1130 | (define (loop items) 1131 | (cond ((null? items) 'done) 1132 | ((eq? (car items) exception) (loop (cdr items))) 1133 | (else (procedure (car items)) 1134 | (loop (cdr items))))) 1135 | (loop list)) 1136 | (define (has-value? connector) 1137 | (connector 'has-value?)) 1138 | (define (get-value connector) 1139 | (connector 'value)) 1140 | (define (set-value! connector new-value informant) 1141 | ((connector 'set-value!) new-value informant)) 1142 | (define (forget-value! connector retractor) 1143 | ((connector 'forget) retractor)) 1144 | (define (connect connector new-constraint) 1145 | ((connector 'connect) new-constraint)) 1146 | 1147 | ; Solution: 1148 | (define (averager a b result) 1149 | (let ((sum (make-connector)) 1150 | (half (make-connector))) 1151 | (adder a b sum) 1152 | (constant 0.5 half) 1153 | (multiplier sum half result) 1154 | 'ok)) 1155 | ; Test: 1156 | (define i1 (make-connector)) 1157 | (define i2 (make-connector)) 1158 | (define o (make-connector)) 1159 | (probe "Averager output" o) 1160 | (averager i1 i2 o) 1161 | (set-value! i1 11 'user) 1162 | (set-value! i2 25 'user) 1163 | ; Probe: Averager output = 18. 1164 | (set-value! i2 13 'user) 1165 | ; *** ERROR IN (console)@212.1 -- Contradiction (25 13) 1166 | (forget-value! i2 'user) 1167 | ; Probe: Averager output = ? 1168 | (set-value! i2 13 'user) 1169 | ; Probe: Averager output = 12. 1170 | 1171 | ;-- 3.34 1172 | ; Sounds good, Louis. Let's try! 1173 | (define i (make-connector)) 1174 | (define o (make-connector)) 1175 | (probe "i" i) 1176 | (probe "o" o) 1177 | (define (squarer a b) 1178 | (multiplier a a b)) 1179 | (squarer i o) 1180 | (set-value! i 5 'user) 1181 | ; Probe: o = 25 1182 | ; Probe: i = 5 1183 | ; Awesome! Let's try the other way around! 1184 | (forget-value! i 'user) 1185 | ; Probe: o = ? 1186 | ; Probe: i = ? 1187 | (set-value! o 25 'user) 1188 | ; Probe: b = 25 1189 | ; Okay, so this won't work. Neither a (the first input of the multiplier) nor, 1190 | ; well, a (the second input of the multiplier) has any value, so multiplier 1191 | ; can't guess both inputs from the output alone. 1192 | ; And this is where everything breaks down: we know the inverse of squaring, 1193 | ; i.e. square roots, so we should be able to compute the input from the output. 1194 | ; It makes no sense whatsoever to have a squarer with an output value and no 1195 | ; input value. 1196 | ; But let's experiment some more! 1197 | (set-value! i 5 'user) 1198 | ; Probe: i = 5 1199 | ; Still ~working! And why wouldn't it? The system is coherent. 1200 | (forget-value! i 'user) 1201 | ; Probe: i = ? 1202 | (set-value! i 10 'user) 1203 | ; *** ERROR IN loop, (console)@134.17 -- Contradiction (25 100) 1204 | 1205 | ;-- 3.35 1206 | (define (squarer a b) 1207 | (define (process-new-value) 1208 | (if (has-value? b) 1209 | (if (< (get-value b) 0) 1210 | (error "square less than 0 -- SQUARER" (get-value b)) 1211 | (set-value! a (sqrt (get-value b)) me)) 1212 | (if (has-value? a) 1213 | (set-value! b (* (get-value a) (get-value a)) me)))) 1214 | (define (process-forget-value) 1215 | (forget-value! a me) 1216 | (forget-value! b me) 1217 | (process-new-value)) 1218 | (define (me request) 1219 | (cond ((eq? request 'I-have-a-value) 1220 | (process-new-value)) 1221 | ((eq? request 'I-lost-my-value) 1222 | (process-forget-value)) 1223 | (else 1224 | (error "Unknown request -- SQUARER" request)))) 1225 | (connect a me) 1226 | (connect b me) 1227 | me) 1228 | 1229 | ; Test: 1230 | (define i (make-connector)) 1231 | (define o (make-connector)) 1232 | (probe "i" i) 1233 | (probe "o" o) 1234 | (squarer i o) 1235 | (set-value! i 5 'user) 1236 | ; Probe: o = 25 1237 | ; Probe: i = 5 1238 | (set-value! o 555 'user) 1239 | ; *** ERROR IN (console)@386.1 -- Contradiction (25 30) 1240 | (forget-value! i 'user) 1241 | ; Probe: o = ? 1242 | ; Probe: i = ? 1243 | (set-value! o 36 'user) 1244 | ; Probe: i = 6 1245 | ; Probe: o = 36 1246 | 1247 | ;-- 3.36 1248 | ; #Environment diagram. 1249 | 1250 | ;-- 3.37 1251 | ; Given: 1252 | (define (c+ x y) 1253 | (let ((z (make-connector))) 1254 | (adder x y z) 1255 | z)) 1256 | ; The other ones are: 1257 | (define (c* x y) 1258 | (let ((z (make-connector))) 1259 | (multiplier x y z) 1260 | z)) 1261 | (define (cv x) 1262 | (let ((z (make-connector))) 1263 | (constant x z) 1264 | z)) 1265 | ; We will need to define subtracter and divider if we want to implement c- and 1266 | ; c/. 1267 | (define (subtracter a1 a2 sum) 1268 | (define (process-new-value) 1269 | (cond ((and (has-value? a1) (has-value? a2)) 1270 | (set-value! sum 1271 | (- (get-value a1) (get-value a2)) 1272 | me)) 1273 | ((and (has-value? a1) (has-value? sum)) 1274 | (set-value! a2 1275 | (- (get-value a1) (get-value sum)) 1276 | me)) 1277 | ((and (has-value? a2) (has-value? sum)) 1278 | (set-value! a1 1279 | (+ (get-value sum) (get-value a2)) 1280 | me)))) 1281 | (define (process-forget-value) 1282 | (forget-value! sum me) 1283 | (forget-value! a1 me) 1284 | (forget-value! a2 me) 1285 | (process-new-value)) 1286 | (define (me request) 1287 | (cond ((eq? request 'I-have-a-value) 1288 | (process-new-value)) 1289 | ((eq? request 'I-lost-my-value) 1290 | (process-forget-value)) 1291 | (else 1292 | (error "Unknown request -- SUBTRACTER" request)))) 1293 | (connect a1 me) 1294 | (connect a2 me) 1295 | (connect sum me) 1296 | me) 1297 | (define (divider m1 m2 product) 1298 | (define (process-new-value) 1299 | (cond ((or (and (has-value? m1) (= (get-value m1) 0)) 1300 | (and (has-value? m2) (= (get-value m2) 0))) 1301 | (set-value! product 0 me)) 1302 | ((and (has-value? m1) (has-value? m2)) 1303 | (set-value! product 1304 | (/ (get-value m1) (get-value m2)) 1305 | me)) 1306 | ((and (has-value? product) (has-value? m1)) 1307 | (set-value! m2 1308 | (/ (get-value m1) (get-value product)) 1309 | me)) 1310 | ((and (has-value? product) (has-value? m2)) 1311 | (set-value! m1 1312 | (* (get-value product) (get-value m2)) 1313 | me)))) 1314 | (define (process-forget-value) 1315 | (forget-value! product me) 1316 | (forget-value! m1 me) 1317 | (forget-value! m2 me) 1318 | (process-new-value)) 1319 | (define (me request) 1320 | (cond ((eq? request 'I-have-a-value) 1321 | (process-new-value)) 1322 | ((eq? request 'I-lost-my-value) 1323 | (process-forget-value)) 1324 | (else 1325 | (error "Unknown request -- DIVIDER" request)))) 1326 | (connect m1 me) 1327 | (connect m2 me) 1328 | (connect product me) 1329 | me) 1330 | 1331 | (define (c- x y) 1332 | (let ((z (make-connector))) 1333 | (subtracter x y z) 1334 | z)) 1335 | (define (c/ x y) 1336 | (let ((z (make-connector))) 1337 | (divider x y z) 1338 | z)) 1339 | 1340 | ; Test: 1341 | (define (celsius-fahrenheit-converter x) 1342 | (c+ (c* (c/ (cv 9) (cv 5)) 1343 | x) 1344 | (cv 32))) 1345 | (define C (make-connector)) 1346 | (define F (celsius-fahrenheit-converter C)) 1347 | (probe "Celsius" C) 1348 | (probe "Fahrenheit" F) 1349 | (set-value! C 22. 'user) 1350 | ; Probe: Celsius = 22. 1351 | ; Probe: Fahrenheit = 71.6 1352 | (set-value! F 90. 'user) 1353 | ; *** ERROR IN (console)@493.1 -- Contradiction (71.6 90.) 1354 | (forget-value! C 'user) 1355 | ; Probe: Celsius = ? 1356 | ; Probe: Fahrenheit = ? 1357 | (set-value! F 90. 'user) 1358 | ; Probe: Fahrenheit = 90. 1359 | ; Probe: Celsius = 32.22222222222222 1360 | 1361 | ;-- 3.38 1362 | ; The possible values if the operations are done sequentially are: 1363 | ; x1 = (100 / 2) - 20 + 10 = 40 (Mary Paul Peter) 1364 | ; x2 = ((100 - 20) / 2) + 10 = 50 (Paul Mary Peter) 1365 | ; x3 = ((100 + 10) / 2) - 20 = 35 (Peter Mary Paul) 1366 | ; x4 = (100 + 10 - 20) / 2 = 45 (Peter Paul Mary) 1367 | ; Because Peter and Paul's operation are commutable: 1368 | ; (Peter Paul Mary) == (Paul Peter Mary) and 1369 | ; (Mary Paul Peter) == (Mary Peter Paul). 1370 | ; Hence there are not 3! different permutations, but only 4. 1371 | 1372 | ; Other values if the operations weren't done sequentially could be: 1373 | ; If all access the amount at the same time and Mary sets it last: 50 1374 | ; If all access the amount at the same time and Peter sets it last: 110 1375 | ; If Peter accesses and updates (110), then Mary reads, then Paul reads and 1376 | ; updates, then Mary updates: 55 1377 | ; Etc. 1378 | 1379 | ;-- 3.39 1380 | ; First lambda then second lambda: 101 1381 | ; Second lambda then first lambda: 121 1382 | 1383 | ;-- 3.40 1384 | ; The operations are: 1385 | ; Lambda 1: read x once, read x another time, then set 1386 | ; Lambda 2: read x once, read x another time, read x a third time, then set 1387 | ; Let's call these r11, r12, r21, r22, r23, s1 and s2 1388 | ; There are 7! = 5040 possible permutations; here are a few possible results: 1389 | ; 100 1390 | ; 1000 1391 | ; 10000 1392 | ; 1000000 1393 | 1394 | ; If the operations are sequential, the two only possible values are: 1395 | ; (10*10*10) * (10*10*10) = 1 000 000 1396 | ; (10*10) * (10*10) * (10*10) = 1 000 000 1397 | 1398 | ;-- 3.41 1399 | ; No. As long as (withdraw) and (deposit) are shielded from each other, the 1400 | ; amount returned by (balance) will always be either before or after the 1401 | ; modifying operation. At worst, (balance) might return a slightly outdated 1402 | ; balance if the concurrent modifying operation didn't have the time to set the 1403 | ; new amount. 1404 | 1405 | ;-- 3.42 1406 | ; There is no difference in practice between the two versions. 1407 | 1408 | ;-- 3.43 1409 | ; If the processes are run sequentially, there is absolutely no chance that the 1410 | ; balances will end mixed up simply because there is no critical section. 1411 | 1412 | ; If the processes are run with the first account-exchange method, things like 1413 | ; these might happen: 1414 | ; - Process1 wants to swap Account1 (at $10) and Account3 (at $30). 1415 | ; It computes the difference to be $20. Pauses. 1416 | ; - Process2 wants to swap Account2 (at $20) and Account3 (at $30). 1417 | ; It computes the difference to be $10. Pauses. 1418 | ; - Process1 proceeds to withdraw $20 from Account3 and deposits it to 1419 | ; Account1. Ends. 1420 | ; - Process2 proceeds to withdraw $10 from Account3 and deposits it to 1421 | ; Account2. Ends. 1422 | ; Final balances: Account1 = $30, Account2 = $30, and Account3 = $0. 1423 | ; Sum is $60, i.e. constant. We're good. 1424 | 1425 | ; If the processes are not run sequentially at all, the balances might all end 1426 | ; up at either $10, $20 or $30 according to chance; exactly as in the previous 1427 | ; exercises. 1428 | 1429 | ;-- 3.44 1430 | ; Louis is wrong. The money transfer is simpler than the money exchange, and 1431 | ; does not need to be serialized further. Incidentally, a safe money exchange 1432 | ; would be two serialized money transfers. 1433 | 1434 | ;-- 3.45 1435 | ; If we use Louis' method, serialized-exchange will try to serialize the calls 1436 | ; to the methods of the two accounts, but the fact that these calls are already 1437 | ; serialized will break our serialized-exchange. The system will try to 1438 | ; serialize the function call with itself, meaning a deadlock. 1439 | 1440 | ;-- 3.46 1441 | ; (This will be a text-based diagram, bear with me here.) 1442 | ; - Process 1 reads the value of the cell: false. Pause. 1443 | ; - Process 2 reads the value of the cell: false. Pause. 1444 | ; - Process 1 sets the value of the cell to true, consider mutex acquired. 1445 | ; - Process 2 sets the value of the cell to true, consider mutex acquired. 1446 | ; - Chaos ensue. 1447 | 1448 | ;-- 3.47 1449 | ; Given: 1450 | (define (make-mutex) 1451 | (let ((cell (list false))) 1452 | (define (the-mutex m) 1453 | (cond ((eq? m 'acquire) 1454 | (if (test-and-set! cell) 1455 | (the-mutex 'acquire))) ; retry 1456 | ((eq? m 'release) (clear! cell)))) 1457 | the-mutex)) 1458 | (define (clear! cell) 1459 | (set-car! cell #f)) 1460 | (define (test-and-set! cell) 1461 | (if (car cell) 1462 | #t 1463 | (begin (set-car! cell #t) 1464 | #f))) 1465 | ; a. 1466 | (define (make-mutex-list n) 1467 | (if (= n 0) ; we assume n >= 0 1468 | '() 1469 | (cons (make-mutex) 1470 | (make-mutex-list (- n 1))))) 1471 | (define (acquire-nth-mutex mutex-list n) 1472 | (if (= n 1) 1473 | ((car mutex-list) 'acquire) 1474 | (acquire-nth-mutex (cdr mutex-list) (- n 1)))) 1475 | (define (release-nth-mutex mutex-list n) 1476 | (if (= n 1) 1477 | ((car mutex-list) 'release) 1478 | (release-nth-mutex (cdr mutex-list) (- n 1)))) 1479 | ; We will use a list as a stack of mutexes 1480 | (define (make-semaphore n) 1481 | (let ((counter 1) 1482 | (mutex-list (make-mutex-list n))) 1483 | (define (the-semaphore m) 1484 | (cond ((eq? m 'acquire) 1485 | (if (= n counter) 1486 | (the-semaphore 'acquire) ; wait for a free mutex 1487 | (acquire-nth-mutex mutex-list counter)) 1488 | (set! counter (+ counter 1))) 1489 | ((eq? m 'release) 1490 | (release-nth-mutex mutex-list counter) 1491 | (set! counter (- counter 1))))) 1492 | the-semaphore)) 1493 | 1494 | ; After looking at some other people's code, my solution is a pretty bad 1495 | ; solution. 1496 | ; Upon reflection, it is also completely incorrect: the counter isn't protected 1497 | ; by a mutex, which means its value can get out of sync. The whole purpose of 1498 | ; the semaphore is then defeated. 1499 | 1500 | ; A simpler (and better) solution would be to use a counter and an unique mutex 1501 | ; to change it, e.g.: 1502 | (define (make-semaphore n) 1503 | (let ((mutex (make-mutex)) 1504 | (counter 0)) 1505 | (define (the-semaphore m) 1506 | (cond ((eq? m 'acquire) 1507 | (mutex 'acquire) 1508 | (cond ((= n counter) 1509 | (mutex 'release) 1510 | (the-semaphore 'acquire)) ; wait 1511 | (else 1512 | (set! counter (+ 1 counter)) 1513 | (mutex 'release)))) 1514 | ((eq? m 'release) 1515 | (mutex 'acquire) 1516 | (if (not (= 0 counter)) 1517 | (set! counter (- counter 1))) 1518 | (mutex 'release)))) 1519 | the-semaphore)) 1520 | 1521 | ; b. would be the same, except we'd do the mutex code ourselves. 1522 | 1523 | ;-- 3.48 1524 | ; Having an account number means the two mutexes will always be acquired in the 1525 | ; same order, which means if one of the mutex is acquired, another process 1526 | ; attempting to exchange the two accounts will not try to acquire the other 1527 | ; mutex first. 1528 | 1529 | ; Given: 1530 | (define (make-mutex) 1531 | (let ((cell (list #f))) 1532 | (define (the-mutex m) 1533 | (cond ((eq? m 'acquire) 1534 | (if (test-and-set! cell) 1535 | (the-mutex 'acquire))) ; retry 1536 | ((eq? m 'release) (clear! cell)))) 1537 | the-mutex)) 1538 | (define (test-and-set! cell) 1539 | (if (car cell) 1540 | #t 1541 | (begin (set-car! cell #t) 1542 | #f))) 1543 | (define (clear! cell) 1544 | (set-car! cell #f)) 1545 | (define (make-serializer) 1546 | (let ((mutex (make-mutex))) 1547 | (lambda (p) 1548 | (define (serialized-p . args) 1549 | (mutex 'acquire) 1550 | (let ((val (apply p args))) 1551 | (mutex 'release) 1552 | val)) 1553 | serialized-p))) 1554 | (define (exchange account1 account2) 1555 | (let ((difference (- (account1 'balance) 1556 | (account2 'balance)))) 1557 | ((account1 'withdraw) difference) 1558 | ((account2 'deposit) difference))) 1559 | ; Implementation: 1560 | ; First, let's create a function that will return a unique account-number. The 1561 | ; trick is to protect this counter with a mutex: 1562 | (define new-account-number 1563 | (let ((mutex (make-mutex)) 1564 | (account-number 0)) 1565 | (define (func) 1566 | (mutex 'acquire) 1567 | (set! account-number (+ account-number 1)) 1568 | (let ((newly-created-account-number account-number)) 1569 | (mutex 'release) 1570 | newly-created-account-number)) 1571 | func)) 1572 | ; Now let's add the relevant code into make-account: 1573 | (define (make-account balance) 1574 | (define (withdraw amount) 1575 | (if (>= balance amount) 1576 | (begin (set! balance (- balance amount)) 1577 | balance) 1578 | "Insufficient funds")) 1579 | (define (deposit amount) 1580 | (set! balance (+ balance amount)) 1581 | balance) 1582 | (let ((balance-serializer (make-serializer)) 1583 | (number (new-account-number))) 1584 | (define (dispatch m) 1585 | (cond ((eq? m 'withdraw) withdraw) 1586 | ((eq? m 'deposit) deposit) 1587 | ((eq? m 'balance) balance) 1588 | ((eq? m 'number) number) 1589 | ((eq? m 'serializer) balance-serializer) 1590 | (else (error "Unknown request -- MAKE-ACCOUNT" 1591 | m)))) 1592 | dispatch)) 1593 | ; And into serialized-exchange: 1594 | (define (serialized-exchange account1 account2) 1595 | (let ((serializer1 (account1 'serializer)) 1596 | (serializer2 (account2 'serializer)) 1597 | (number1 (account1 'number)) 1598 | (number2 (account2 'number))) 1599 | ((if (= (min number1 number2) number1) 1600 | (serializer2 (serializer1 exchange)) 1601 | (serializer1 (serializer2 exchange))) 1602 | account1 1603 | account2))) 1604 | 1605 | ; Test: 1606 | (new-account-number) 1607 | ; 1 1608 | (new-account-number) 1609 | ; 2 1610 | ; Works as planned! 1611 | (define g (make-account 34)) 1612 | (g 'balance) 1613 | ; 34 1614 | (g 'number) 1615 | ; 3 1616 | ; Looks good. 1617 | (define k (make-account 21)) 1618 | (k 'balance) 1619 | ; 21 1620 | (k 'number) 1621 | ; 4 1622 | (serialized-exchange g k) 1623 | (g 'balance) 1624 | ; 21 1625 | (k 'balance) 1626 | ; 34 1627 | ; Still works as planned. I don't know how to simulate concurrent access to the 1628 | ; accounts so I'll leave it at that, but if anyone has an idea, it would be 1629 | ; much welcome. 1630 | 1631 | ;-- 3.49 1632 | ; Well, this is pretty self-explanatory. If a lookup is involved, a process has 1633 | ; no way of knowing which mutex to acquire first; hence a risk of deadlock. 1634 | 1635 | ;-- 3.50 1636 | (define (stream-map proc . argstreams) 1637 | (if (stream-null? (car argstreams)) 1638 | the-empty-stream 1639 | (cons-stream 1640 | (apply proc (map stream-car argstreams)) 1641 | (apply stream-map 1642 | (cons proc (map stream-cdr argstreams)))))) 1643 | 1644 | ; This is easier to grasp if you understand what we want to achieve with 1645 | ; stream-map: a new stream, composed of the successive results of (proc) 1646 | ; applied to the elements of the streams. 1647 | ; Something like: 1648 | ; (stream (proc (car stream1) (car stream2) (car stream3) ...) 1649 | ; (proc (cadr stream1) (cadr stream2) (cadr stream3) ...) 1650 | ; (proc (caddr stream1) (caddr stream2) (caddr stream3) ...) 1651 | ; (...)) 1652 | 1653 | ;-- 3.51 1654 | ; (stream-ref x 5) will print the numbers up to 5, because they've never been 1655 | ; computed before. 1656 | ; In contrast, (stream-ref x 7) will only print 6 and 7. The results of (show) 1657 | ; from 0 to 5 have already been computed, and stream-ref will only look up the 1658 | ; result instead of re-executing the function (which would print them). 1659 | 1660 | ;-- 3.52 1661 | ; Q: What is the value of sum after each of the above expressions is evaluated? 1662 | (define sum 0) 1663 | ; 0 (pretty straightforward so far.) 1664 | (define (accum x) 1665 | (set! sum (+ x sum)) 1666 | sum) 1667 | ; 0 1668 | (define seq (stream-map accum (stream-enumerate-interval 1 20))) 1669 | ; 1: our streams are lazy, but the first value is computed 1670 | (define y (stream-filter even? seq)) 1671 | ; 6: same for the filters, first value is computed 1672 | (define z (stream-filter (lambda (x) (= (remainder x 5) 0)) 1673 | seq)) 1674 | ; 10 1675 | (stream-ref y 7) 1676 | ; y is a stream comprised of the even numbers in our first stream. 1677 | ; What will be computed here in seq will be the following: 1678 | ; Order | seq (i.e. value of sum) | function call 1679 | ; 1 | 1 (filtered out) | 1680 | ; 2 | 3 (filtered out) | (stream-ref (6..) 7) 1681 | ; 3 | 6 (accepted in y) | (stream-ref (10..) 6) 1682 | ; 4 | 10 (accepted in y) | 1683 | ; 5 | 15 (filtered out) | 1684 | ; 6 | 21 (filtered out) | (stream-ref (28..) 5) 1685 | ; 7 | 28 (accepted in y) | (stream-ref (36..) 4) 1686 | ; 8 | 36 (accepted in y) | 1687 | ; 9 | 45 (filtered out) | 1688 | ; 10 | 55 (filtered out) | (stream-ref (66..) 3) 1689 | ; 11 | 66 (accepted in y) | (stream-ref (78..) 2) 1690 | ; 12 | 78 (accepted in y) | 1691 | ; 13 | 91 (filtered out) | 1692 | ; 14 | 105 (filtered out) | (stream-ref (120..) 1) 1693 | ; 15 | 120 (accepted in y) | (stream-ref (136..) 0) 1694 | ; 16 | 136 (accepted in y) | 1695 | 1696 | (display-stream z) 1697 | ; All of seq will be consummated here; which up to 20 gives: 1698 | ; Order | seq (i.e. value of sum) 1699 | ; 17 | 153 1700 | ; 18 | 171 1701 | ; 19 | 190 1702 | ; 20 | 210 1703 | 1704 | ; Q: What is the printed response to evaluating the stream-ref and 1705 | ; display-stream expressions? 1706 | ; stream-ref will print 136 1707 | ; display-stream will print 10, 15, 45, 55, 105, 120, 190, 210 1708 | 1709 | ; Q: Would these responses differ if we had implemented (delay ) simply as 1710 | ; (lambda () ) without using the optimization provided by memo-proc ? 1711 | ; Yes. Memoization is what makes that sum doesn't grow when the results have 1712 | ; already been computed. If we re-computed the value each time, we would have 1713 | ; the following values for sum instead: 1714 | (define seq (stream-map accum (stream-enumerate-interval 1 20))) 1715 | ; 1 1716 | (define y (stream-filter even? seq)) 1717 | ; 7 1718 | (define z (stream-filter (lambda (x) (= (remainder x 5) 0)) 1719 | seq)) 1720 | ; 17 1721 | (stream-ref y 7) 1722 | ; 153 1723 | (display-stream z) 1724 | ; 363 1725 | 1726 | ; NB: it me a good hour to get all of that right *and* understand it. 1727 | ; Now my brains hurt. 1728 | 1729 | ;-- 3.53 1730 | ; Without running the program, describe the elements of the stream defined by 1731 | (define s (cons-stream 1 (add-streams s s))) 1732 | ; This program describes the powers of 2, starting at 2^0 = 1. 1733 | 1734 | ;-- 3.54 1735 | (define (mul-streams s1 s2) 1736 | (stream-map * s1 s2)) 1737 | 1738 | (define factorials 1739 | (cons-stream 1 (mul-streams factorials integers))) 1740 | 1741 | ;-- 3.55 1742 | ; We need something like scale-stream, but with addition instead of 1743 | ; multiplication: 1744 | (define (add-to-stream stream n) 1745 | (stream-map (lambda (x) (+ x n)) stream)) 1746 | (define (partial-sums stream) 1747 | (cons-stream (car stream) 1748 | (add-to-stream (cdr-stream) (car stream)))) 1749 | 1750 | ;-- 3.56 1751 | (define S 1752 | (cons-stream 1 (merge (scale-stream S 5) 1753 | (merge (scale-stream S 2) 1754 | (scale-stream S 3))))) 1755 | 1756 | ;-- 3.57 1757 | ; Given: 1758 | (define (stream-map proc s) 1759 | (if (stream-null? s) 1760 | the-empty-stream 1761 | (cons-stream (proc (stream-car s)) 1762 | (stream-map proc (stream-cdr s))))) 1763 | (define (add-streams s1 s2) 1764 | (stream-map + s1 s2)) 1765 | (define fibs 1766 | (cons-stream 0 1767 | (cons-stream 1 1768 | (add-streams (stream-cdr fibs) 1769 | fibs)))) 1770 | ; Q:How many additions are performed when we compute the nth Fibonacci number 1771 | ; using the definition of fibs based on the add-streams procedure? 1772 | 1773 | ; Say we compute: 1774 | (fibs 6) 1775 | ; What will be called: 1776 | (fibs 0) ; <- already known 0 addition 1777 | (fibs 1) ; <- already known 0 addition 1778 | (fibs 2) ; <- 0 + 1 1 addition 1779 | (fibs 3) ; <- 1 + 1 1 addition 1780 | (fibs 4) ; <- 1 + 2 1 addition 1781 | (fibs 5) ; <- 2 + 3 1 addition 1782 | (fibs 6) ; <- 3 + 5 1 addition 1783 | ; (fibs) only need one addition per new step, because the results from the 1784 | ; previous steps are memoized. 1785 | 1786 | ; Had we implemented streams with a simple lambda, the result would have been: 1787 | (fibs 0) ; <- already known 0 addition 1788 | (fibs 1) ; <- already known 0 addition 1789 | (fibs 2) ; <- 0 + 1 1 addition 1790 | (fibs 3) ; <- 1 + (0 + 1) 2 additions 1791 | (fibs 4) ; <- (0 + 1) + (1 + (0 + 1)) 4 additions 1792 | (fibs 5) ; <- (1 + (0 + 1)) 1793 | ; + ((0 + 1) + (1 + (0 + 1))) 7 additions 1794 | (fibs 6) ; <- ((0 + 1) + (1 + (0 + 1))) 1795 | ; + ((1 + (0 + 1)) 1796 | ; + ((0 + 1) + (1 + (0 + 1)))) 12 additions 1797 | 1798 | ; i.e. exponentially greater. The number of additions needed seem to follow a 1799 | ; strange pattern of... An = (A(n-1) + A(n-2)) + 1 1800 | 1801 | ;-- 3.58 1802 | ; Q:Give an interpretation of the stream computed by the following procedure: 1803 | (define (expand num den radix) 1804 | (cons-stream 1805 | (quotient (* num radix) den) 1806 | (expand (remainder (* num radix) den) den radix))) 1807 | ; The long division of num(erator) by den(ominator), in base radix. 1808 | 1809 | ;-- 3.59 to 3.62 1810 | ; These power series are a bit too math-y to my taste. 1811 | 1812 | ;-- 3.63 1813 | ; Alyssa's answer and the rest of the question seem to hint that memo-proc can 1814 | ; optimize guesses. Indeed, if we only recurse through sqrt-stream, the guesses 1815 | ; won't be memoized and will be recomputed every time. 1816 | 1817 | ;-- 3.64 1818 | (define (stream-limit stream tolerance) 1819 | (letrec ((first-item (stream-car stream)) 1820 | (second-item (stream-car (stream-cdr stream))) 1821 | (difference (- second-item first-item))) 1822 | (if (< difference tolerance) 1823 | second-item 1824 | (stream-limit (cdr stream) tolerance)))) 1825 | 1826 | ;-- 3.65 1827 | (define (ln-summands n) 1828 | (cons-stream (/ 1.0 n) 1829 | (stream-map (** -1 n) 1830 | (ln-summands (+ n 1))))) 1831 | (define ln-stream 1832 | (partial-sums (ln-summands 1))) 1833 | (display-stream ln-stream) 1834 | 1835 | ;-- 3.66 1836 | ; (1,1) (1,2) (2,2) (1,3) (2,3) (3,3) (1,4)... 1837 | ; Q: how many pairs precede the pair (1,100)? 1838 | ; 4950 1839 | ; Q: the pair (99,100)? 1840 | ; 5048 1841 | ; Q: the pair (100,100)? 1842 | ; 5049 1843 | 1844 | ; After looking at other people's solutions on the internet, looks like I'm 1845 | ; quite wrong on that. 1846 | 1847 | ;-- 3.67 1848 | ; Modify the pairs procedure so that (pairs integers integers) will produce the 1849 | ; stream of all pairs of integers (i,j) (without the condition i < j) 1850 | (define (pairs s t) 1851 | (cons-stream 1852 | (list (stream-car s) (stream-car t)) 1853 | (interleave 1854 | (stream-map (lambda (x) (list (stream-car s) x)) 1855 | (stream-cdr t)) 1856 | (interleave (pairs (stream-cdr s) (stream-cdr t)) 1857 | (stream-map (lambda (x) (list (stream-car t) x)) 1858 | (stream-cdr s)))))) 1859 | 1860 | ;-- 3.68 1861 | ; No, this won't work: interleave will try to evaluate the first element of s2 1862 | ; in order to put it into its cons-stream, but this calls pairs again, leading 1863 | ; to an endless loop. 1864 | 1865 | ;-- 3.69 1866 | (define (triples a b c) 1867 | (pairs a (pairs b c))) 1868 | ; Sounds cool, right? Well it doesn't work. :/ 1869 | ; It will create triplets that look like (1 (1 1)) instead of the (1 1 1) we 1870 | ; want. 1871 | ; This is better: 1872 | (define (triples a b c) 1873 | (cons-stream 1874 | (list (stream-car a) (stream-car b) (stream-car c)) 1875 | (interleave 1876 | (stream-map (lambda (x) (append (list (stream-car a)) x)) 1877 | (stream-cdr (pairs b c))) 1878 | (triples (stream-cdr a) (stream-cdr b) (stream-cdr c))))) 1879 | 1880 | (define pythagorean-triples 1881 | (filter-stream (lambda (x) 1882 | (let ((i (car x)) 1883 | (j (cadr x)) 1884 | (k (caddr x))) 1885 | (= (+ (expt i 2) 1886 | (expt j 2)) 1887 | (expt k 2)))) 1888 | (triples integer integer integer))) 1889 | 1890 | ;-- 3.70 1891 | (define (merge-weighted s1 s2 weight) 1892 | (cond ((stream-null? s1) s2) 1893 | ((stream-null? s2) s1) 1894 | (else 1895 | (letrec ((s1car (stream-car s1)) 1896 | (s2car (stream-car s2)) 1897 | (w1 (weight s1)) 1898 | (w2 (weight s2))) 1899 | (if (<= w1 w2) 1900 | (cons-stream s1car (merge-weighted (stream-cdr s1) 1901 | s2 1902 | weight)) 1903 | (cons-stream s2car (merge-weighted s1 1904 | (stream-cdr s2) 1905 | weight))))))) 1906 | (define (weighted-pairs s t weight) 1907 | (cons-stream 1908 | (list (stream-car s) (stream-car t)) 1909 | (merge-weighted 1910 | (stream-map (lambda (x) (list (stream-car s) x)) 1911 | (stream-cdr t)) 1912 | (weighted-pairs (stream-cdr s) (stream-cdr t) weight)))) 1913 | 1914 | ; a. 1915 | (define a 1916 | (weighted-pairs integers 1917 | integers 1918 | (lambda (x) (+ (car x) (cadr x))))) 1919 | 1920 | ; b. 1921 | (define ints-for-b 1922 | (filter-stream integers 1923 | (lambda (x) 1924 | (and (not (= (modulo x 2) 0)) 1925 | (not (= (modulo x 3) 0)) 1926 | (not (= (modulo x 5) 0)))))) 1927 | (define b 1928 | (weighted-pairs ints-for-b 1929 | ints-for-b 1930 | (lambda (x) 1931 | (let ((i (car x)) 1932 | (j (cadr x))) 1933 | (+ (* 2 i) 1934 | (* 3 j) 1935 | (* 5 i j)))))) 1936 | 1937 | ;-- 3.71 1938 | (define (ramanujan-weight pair) 1939 | (+ (expt (car pair) 3) 1940 | (expt (cadr pair) 3))) 1941 | (define ijcube 1942 | (weighted-pairs integers 1943 | integers 1944 | ramanujan-weight)) 1945 | (define (ramanujan stream n) 1946 | (letrec ((p1 (stream-car stream)) 1947 | (p2 (stream-cadr stream)) 1948 | (w1 (ramanujan-weight p1)) 1949 | (w2 (ramanujan-weight p2))) 1950 | (if (= w1 w2) 1951 | (begin (display (list w1 (list p1 p2))) 1952 | (newline) 1953 | (ramanujan (stream-cdr stream) (- n 1))) 1954 | (ramanujan (stream-cdr stream) n)))) 1955 | 1956 | (ramanujan ijcube 5) 1957 | 1958 | ;-- 3.72 1959 | (define (stream-caddr s) 1960 | (stream-cadr (stream-cdr s))) 1961 | (define (sum-of-squares pair) 1962 | (+ (expt (car pair) 2) 1963 | (expt (cadr pair) 2))) 1964 | (define pairs-372 1965 | (weighted-pairs integers 1966 | integers 1967 | sum-of-squares)) 1968 | (define (answer-372 stream n) 1969 | (letrec ((p1 (stream-car stream)) 1970 | (p2 (stream-cadr stream)) 1971 | (p3 (stream-caddr stream)) 1972 | (w1 (sum-of-squares p1)) 1973 | (w2 (sum-of-squares p2)) 1974 | (w3 (sum-of-squares p3))) 1975 | (if (= w1 w2 w3) 1976 | (begin (display (list w1 (list p1 p2 p3))) 1977 | (newline) 1978 | (answer-372 (stream-cdr stream) (- n 1))) 1979 | (answer-372 (stream-cdr stream) n)))) 1980 | 1981 | (answer-372 pairs-372 10) 1982 | 1983 | ;-- 3.73 1984 | ; (Use the integral from 3.5x) 1985 | 1986 | ;-- 3.74 1987 | (define zero-crossings 1988 | (stream-map sign-change-detector sense-data (stream-cdr sense-data))) 1989 | 1990 | ;-- 3.75 1991 | (define (make-zero-crossings input-stream last-value) 1992 | (let ((avpt (/ (+ (stream-car input-stream) last-value) 2))) 1993 | (cons-stream (sign-change-detector avpt last-value) 1994 | (make-zero-crossings (stream-cdr input-stream) 1995 | avpt)))) 1996 | ; This program doesn't average two consecutive values from the input stream, 1997 | ; but a value to the previously computed average (here called avpt). 1998 | ; Correct version: 1999 | (define (make-zero-crossings input-stream last-value last-avpt) 2000 | (letrec ((current-value (stream-car input-stream)) 2001 | (current-avpt (/ (+ current-value last-value) 2))) 2002 | (cons-stream (sign-change-detector current-avpt last-avpt) 2003 | (make-zero-crossings (stream-cdr input-stream) 2004 | current-value 2005 | current-avpt)))) 2006 | 2007 | ;-- 3.76 2008 | (define (smooth input-stream) 2009 | (stream-cons (/ (+ (stream-car input-stream) 2010 | (stream-cadr input-stream)) 2011 | 2) 2012 | (smooth (stream-cdr input-stream)))) 2013 | (define zero-crossings 2014 | (let ((data (smooth sense-data))) 2015 | (stream-map sign-change-detector data (stream-cdr data)))) 2016 | 2017 | ;-- 3.77 to 3.80 2018 | ; Too much maths again. 2019 | 2020 | ;-- 3.81 2021 | (define (random-numbers request-stream initial-value) 2022 | (cond 2023 | ((= (stream-car request-stream) 'generate) 2024 | (cons-stream (rand-update initial-value) 2025 | (random-numbers (cdr-stream request-stream) 2026 | (rand-update initial-value)))) 2027 | ((= (stream-car request-stream) 'reset) 2028 | (cons-stream initial-value 2029 | (random-numbers (cdr-stream request-stream) 2030 | initial-value))))) 2031 | 2032 | ;-- 3.82 2033 | ; Given: 2034 | (define (map-successive-pairs f s) 2035 | (cons-stream 2036 | (f (stream-car s) (stream-car (stream-cdr s))) 2037 | (map-successive-pairs f (stream-cdr (stream-cdr s))))) 2038 | (define (monte-carlo experiment-stream passed failed) 2039 | (define (next passed failed) 2040 | (cons-stream 2041 | (/ passed (+ passed failed)) 2042 | (monte-carlo 2043 | (stream-cdr experiment-stream) passed failed))) 2044 | (if (stream-car experiment-stream) 2045 | (next (+ passed 1) failed) 2046 | (next passed (+ failed 1)))) 2047 | (define (random-in-range low high) 2048 | (let ((range (- high low))) 2049 | (+ low (random range)))) 2050 | 2051 | ; Solution: 2052 | (define (random-stream-in-range a b) 2053 | (cons-stream (random-in-range a b) 2054 | (random-stream-in-range a b))) 2055 | (define (P x y) 2056 | (< (+ (expt (- x 5) 2) 2057 | (expt (- y 7) 2)) 2058 | (expt 3 2))) 2059 | (define (estimate-integral P x1 x2 y1 y2) 2060 | (define random-xy-stream 2061 | (interleave (random-stream-in-range x1 x2) 2062 | (random-stream-in-range y1 y2))) 2063 | (monte-carlo (map-successive-pairs P random-xy-stream) 0 0)) 2064 | 2065 | --------------------------------------------------------------------------------