blob: 26e456a5576ad80fe682b63a03dc6ada0c784767 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
#lang racket
(require "../../shared/lists.rkt")
;; a. Number and variable are primitives that return a boolean.
;; But what you want is a type assertion that has the same signature as the rest.
;; The operator procedure for example returns the symbol that indicates whether the expression is a sum or product.
;; Get fetches a procedure from the dispatch table that defines how to take the derivative of the expression. But that is not a problem because you can define
;; the derivatives of a number or variable as procedures. This is one step that needs to be done first.
;;
;; The get and put procedures on the dispatch table just need to support the type-tag of the expression, which is not supported for booleans. (i think?)
;; So you might type tag variables and expressions. But this changes the underlying representation of the expression. Which we are not interested in right now.
;; b.
(define (variable? x) (symbol? x))
(define (same-variable? x y) (and (variable? x) (variable? y) (eq? x y)))
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
(define (make-eq-type? type)
(lambda (d)
(eq? (type-tag d) type)))
(define (make-dispatch-table)
(define dispatch-table '())
(define (get op type)
(let ((op-entry (find-first (make-eq-type? op)
dispatch-table)))
(if (pair? op-entry)
(let ((installed-types (cdr op-entry)))
(let ((dispatch-proc-entry (find-first (make-eq-type? type)
installed-types)))
(if (pair? dispatch-proc-entry)
(cdr dispatch-proc-entry)
(error "Bad op or op not defined for type -- GET" op type dispatch-proc-entry))))
(error "Not found or bad entry -- GET" op type op-entry))))
(define (put op type item)
(if (find-first (make-eq-type? op) dispatch-table)
(set! dispatch-table
(map (lambda (op-entry) ;;just copy the table for now, don't want to mutate yet
(if (not (eq? (type-tag op-entry) op))
op-entry
(attach-tag op
(let ((installed-types (map (lambda (type-entry)
(if (not (eq? (type-tag type-entry) type))
type-entry
(attach-tag type item)))
(cdr op-entry))))
(if (find-first (make-eq-type? type) installed-types)
installed-types
(cons (attach-tag type item) installed-types))))))
dispatch-table))
(set! dispatch-table (cons
(attach-tag op
(list (attach-tag type item)))
dispatch-table))))
(list dispatch-table get put))
(define (getter t)
(cadr t))
(define (putter t)
(caddr t))
(define t (make-dispatch-table))
(define get (getter t))
(define put (putter t))
;; prefix combination notation of expression? (+ a b)
(define (operator ex)
(car ex))
(define (operands ex)
(cdr ex))
(define (deriv ex var)
(cond ((number? ex) 0)
((variable? ex) (if (same-variable? ex var) 1 0))
(else ((get 'deriv (operator ex)) (operands ex) var))))
(define (install-basic-deriv-rules)
(define (=number? x num)
(and (number? x) (= x 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 (addend s) (car s))
(define (augend s)
(cond ((null? (cddr s)) (cadr s))
(else (cons '+ (cdr s)))))
(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 (multiplier p)
(car p))
(define (multiplicand p)
(cond ((null? (cddr p))
(cadr p))
(else (cons '* (cdr p)))))
(define (make-exponent e p)
(cond ((=number? p 0) 1)
((=number? p 1) e)
(else (list '** e p))))
(define (base expo)
(car expo))
(define (exponent expo)
(cadr expo))
;;b
(put 'deriv '+ (lambda (ex var)
(make-sum
(deriv (addend ex) var)
(deriv (augend ex) var))))
(put 'deriv '* (lambda (ex var)
(make-sum
(make-product
(multiplier ex)
(deriv (multiplicand ex) var))
(make-product
(deriv (multiplier ex) var)
(multiplicand ex)))))
;;c
(put 'deriv '** (lambda (ex var)
(make-product
(deriv (base ex) var)
(make-product
(exponent ex)
(make-exponent (base ex) (- (exponent ex) 1)))))))
(install-basic-deriv-rules)
(deriv '(+ (* 3 x) (* 2 x)) 'x)
(deriv '(** x 2) 'x)
;;d
;; No changes to the derivative system are necessary so long as (op, 'deriv) points
;; to the same method as ('deriv, op) in the dispatch table of the consuming package.
;; I guess you could argue that the put arguments should be reversed in the derivative system.
;; But the actual items in the dispatch table don't have to change since the call signature is the same.
|
