144 lines
4.2 KiB
Racket
144 lines
4.2 KiB
Racket
#lang sicp
|
|
|
|
(define (variable? x) (symbol? x))
|
|
|
|
(define (same-variable? v1 v2)
|
|
(and (variable? v1) (variable? v2) (eq? v1 v2)))
|
|
|
|
(define (=number? exp num)
|
|
(and (number? exp) (= exp num)))
|
|
|
|
(define (make-sum a1 a2)
|
|
(cond ((=number? a1 0) a2)
|
|
((=number? a2 0) a1)
|
|
((and (number? a1) (number? a2)) (+ a1 a2))
|
|
(else (list '+ a1 a2))))
|
|
|
|
(define (make-product m1 m2)
|
|
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
|
|
((=number? m1 1) m2)
|
|
((=number? m2 1) m1)
|
|
((and (number? m1) (number? m2)) (* m1 m2))
|
|
(else (list '* m1 m2))))
|
|
|
|
(define (sum? x)
|
|
(and (pair? x) (eq? (cadr x) '+)))
|
|
|
|
(define (addend s) (car s))
|
|
|
|
;; Special case of multiplication distributing across addition. It
|
|
;; should be possible to rewrite augend and/or multiplicand to deal
|
|
;; with this case
|
|
|
|
(define (augend s)
|
|
(if (product? (cddr s))
|
|
(cddr s)
|
|
(caddr s)))
|
|
|
|
(define (product? x)
|
|
(and (pair? x) (eq? (cadr x) '*)))
|
|
|
|
(define (multiplier p) (car p))
|
|
|
|
(define (multiplicand p) (caddr p))
|
|
|
|
;; 2.73: (a) The logic to decide how to derive expressions was moved from the derive
|
|
;; procedure into the table. It isn't possible to use number and variable in the data
|
|
;; dispatch because they don't have a tag that could be used to distinguish them.
|
|
|
|
;; (b)
|
|
|
|
;;;-----------
|
|
;;;from section 3.3.3 for section 2.4.3
|
|
;;; to support operation/type table for data-directed dispatch
|
|
|
|
(define (assoc key records)
|
|
(cond ((null? records) false)
|
|
((equal? key (caar records)) (car records))
|
|
(else (assoc key (cdr records)))))
|
|
|
|
(define (make-table)
|
|
(let ((local-table (list '*table*)))
|
|
(define (lookup key-1 key-2)
|
|
(let ((subtable (assoc key-1 (cdr local-table))))
|
|
(if subtable
|
|
(let ((record (assoc key-2 (cdr subtable))))
|
|
(if record
|
|
(cdr record)
|
|
false))
|
|
false)))
|
|
(define (insert! key-1 key-2 value)
|
|
(let ((subtable (assoc key-1 (cdr local-table))))
|
|
(if subtable
|
|
(let ((record (assoc key-2 (cdr subtable))))
|
|
(if record
|
|
(set-cdr! record value)
|
|
(set-cdr! subtable
|
|
(cons (cons key-2 value)
|
|
(cdr subtable)))))
|
|
(set-cdr! local-table
|
|
(cons (list key-1
|
|
(cons key-2 value))
|
|
(cdr local-table)))))
|
|
'ok)
|
|
(define (dispatch m)
|
|
(cond ((eq? m 'lookup-proc) lookup)
|
|
((eq? m 'insert-proc!) insert!)
|
|
(else (error "Unknown operation -- TABLE" m))))
|
|
dispatch))
|
|
|
|
(define operation-table (make-table))
|
|
(define get (operation-table 'lookup-proc))
|
|
(define put (operation-table 'insert-proc!))
|
|
|
|
;;;-----------
|
|
|
|
(define (deriv exp var)
|
|
(cond ((number? exp) 0)
|
|
((variable? exp) (if (same-variable? exp var) 1 0))
|
|
(else ((get 'deriv (operator exp)) (operands exp)
|
|
var))))
|
|
|
|
(define (operator exp) (car exp))
|
|
|
|
(define (operands exp) (cdr exp))
|
|
|
|
|
|
(define (deriv-sum operands var)
|
|
(cond ((null? operands) 0)
|
|
((null? (cdr operands)) (deriv (car operands) var))
|
|
(else (make-sum (deriv (car operands) var)
|
|
(deriv (cadr operands) var)))))
|
|
|
|
(define (deriv-prod operands var)
|
|
(cond ((null? operands) 1)
|
|
((null? (cdr operands)) (deriv (car operands) var))
|
|
(else
|
|
(let ((op1 (car operands))
|
|
(op2 (cadr operands)))
|
|
(make-sum (make-product op1 (deriv op2 var))
|
|
(make-product (deriv op1 var) op2))))))
|
|
|
|
(define (make-exponentiation b p)
|
|
(cond ((=number? p 0) 1)
|
|
((=number? p 1) b)
|
|
((and (number? b) (number? p)) (expt b p))
|
|
(else (list '** b p))))
|
|
|
|
(define (base e) (cadr e))
|
|
(define (exponent e) (caddr e))
|
|
|
|
(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))
|
|
|
|
(define (deriv-exp operands var)
|
|
(let ((base (car operands))
|
|
(exponent (cadr operands)))
|
|
(make-product exponent
|
|
(make-product
|
|
(make-exponentiation base (- exponent 1))
|
|
(deriv base var)))))
|
|
|
|
(put 'deriv '+ deriv-sum)
|
|
(put 'deriv '* deriv-prod)
|
|
(put 'deriv '** deriv-exp)
|