120 lines
4.7 KiB
Scheme
120 lines
4.7 KiB
Scheme
#lang sicp
|
|
|
|
; For these exercises, where I'm adding extra functionality to the deriv
|
|
; system. I chose to build each new feature off of the results of the previous
|
|
; exercises, rather than the unmodified code.
|
|
; This might make the solutions a bit more complicated than they have to be
|
|
|
|
(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 (not-number? x) (not (number? x)))
|
|
|
|
(define (filter predicate sequence)
|
|
(cond ((null? sequence) nil)
|
|
((predicate (car sequence))
|
|
(cons (car sequence)
|
|
(filter predicate (cdr sequence))))
|
|
(else (filter predicate (cdr sequence)))))
|
|
|
|
; folds the constants of the top-level expression
|
|
; e.g. (+ 2 3 x 5) becomes (+ 10 x)
|
|
; (+ x y z) -> (+ x y z)
|
|
; (* 2 x 0 3) -> 0
|
|
; (+ 3 -3 x) -> x
|
|
(define (fold exp)
|
|
(if (and (not (sum? exp)) (not (product? exp)))
|
|
exp ; if you don't know how to fold the exp, just leave it
|
|
(let* ((op (car exp))
|
|
(consts (filter number? (cdr exp)))
|
|
(rest (filter not-number? (cdr exp)))
|
|
(folded-const (if (eq? op '+)
|
|
(apply + consts)
|
|
(apply * consts)))
|
|
(args (cond ((and (eq? op '*) (= folded-const 0)) '(0))
|
|
((and (eq? op '*) (= folded-const 1)) rest)
|
|
((and (eq? op '+) (= folded-const 0)) rest)
|
|
(else (append (list folded-const) rest)))))
|
|
(cond ((and (eq? op '+) (= (length args) 0)) 0)
|
|
((and (eq? op '*) (= (length args) 0)) 1)
|
|
((= (length args) 1) (car args))
|
|
(else (append (list op) args))))))
|
|
|
|
; make-sum and make-product will be changed so that any arguments which are
|
|
; sums themselves will be spliced into the list, and all numbers will be placed
|
|
; in the front and folded
|
|
(define (make-sum a1 a2)
|
|
; l1 and l2 are lists to be spliced, if they're not sums, we make them lists
|
|
; of a list, so effectively, they don't get spliced
|
|
(let ((l1 (if (sum? a1) (cdr a1) (list a1)))
|
|
(l2 (if (sum? a2) (cdr a2) (list a2))))
|
|
(fold (append '(+) l1 l2))))
|
|
|
|
(define (make-product m1 m2)
|
|
(let ((l1 (if (product? m1) (cdr m1) (list m1)))
|
|
(l2 (if (product? m2) (cdr m2) (list m2))))
|
|
(fold (append '(*) l1 l2))))
|
|
|
|
(define (sum? x) (and (pair? x) (eq? (car x) '+)))
|
|
(define (addend s) (cadr s))
|
|
(define (augend s) (if (= (length s) 3)
|
|
(caddr s)
|
|
(cons '+ (cddr s))))
|
|
(define (product? x) (and (pair? x) (eq? (car x) '*)))
|
|
(define (multiplier p) (cadr p))
|
|
(define (multiplicand p) (if (= (length p) 3)
|
|
(caddr p)
|
|
(cons '* (cddr p))))
|
|
|
|
; for the purposes of our exponentiation exercise, we need to determine whether
|
|
; the exponent is constant so that we can apply the rule correctly
|
|
(define (constant? x var)
|
|
(or (number? x)
|
|
(and (variable? x) (not (same-variable? x var)))
|
|
(and (sum? x)
|
|
(constant? (addend x) var)
|
|
(constant? (augend x) var))
|
|
(and (product? x)
|
|
(constant? (multiplier x) var)
|
|
(constant? (multiplicand x) var))
|
|
(and (exponentiation? x)
|
|
(constant? (base x) var)
|
|
(constant? (exponent x) var))))
|
|
|
|
(define (make-exponentiation b e)
|
|
(cond ((=number? e 0) 1)
|
|
((=number? e 1) b)
|
|
((=number? b 0) 0)
|
|
((and (number? b) (number? e)) (expt b e))
|
|
(else (list '** b e))))
|
|
|
|
|
|
(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))
|
|
(define (base e) (cadr e))
|
|
(define (exponent e) (caddr e))
|
|
|
|
(define (deriv exp var)
|
|
(cond ((number? exp) 0)
|
|
((variable? exp) (if (same-variable? exp var) 1 0))
|
|
((sum? exp) (make-sum (deriv (addend exp) var)
|
|
(deriv (augend exp) var)))
|
|
((product? exp)
|
|
(make-sum
|
|
(make-product (multiplier exp)
|
|
(deriv (multiplicand exp) var))
|
|
(make-product (deriv (multiplier exp) var)
|
|
(multiplicand exp))))
|
|
((exponentiation? exp)
|
|
(if (constant? (exponent exp) var)
|
|
(make-product (make-product (exponent exp)
|
|
(make-exponentiation (base exp)
|
|
(make-sum
|
|
(exponent exp)
|
|
-1)))
|
|
(deriv (base exp) var))
|
|
(error "non-constant exponents not yet supported: DERIV" exp)))
|
|
(else
|
|
(error "unknown expression type: DERIV" exp))))
|