符号求导，scheme实现

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

(define variable? symbol?) (define (same-variable? a b) (and (variable? a) (variable? b) (eq? a b))) (define (sum-exp? exp) (and (pair? exp) (eq? (car exp) '+))) (define (product-exp? exp) (and (pair? exp) (eq? (car exp) '*))) (define (expon-exp? exp) (and (pair? exp) (eq? (car exp )'**))) (define (** x n) (exp (* n (log x)))) (define (make-sum lst) (let ((num (foldl + 0 (filter number? lst))) (sym (filter (lambda (x) (not (number? x))) lst))) (if (= 0 num) (cond ((= (length sym) 0) 0) ((= (length sym) 1) (car sym)) (else (cons '+ sym))) (if (= (length sym) 0) num (cons '+ (cons num sym)))))) ;(make-sum '(0 0)) ;(make-sum '(2 -2 3 -3 a b)) ;(make-sum '(2 3)) ;(make-sum '(2 -2 3 a 4 b)) ;(make-sum '((+ a b) (+ b d))) ;(make-sum '((* a 0) (* 1 (+ 0 b x)))) ;(make-sum '( (* a b) ) ) ;(make-sum '(a b) ) (define (make-product lst) (let ((num (foldl * 1 (filter number? lst))) (sym (filter (lambda (x) (not (number? x))) lst))) (cond ((= num 0) 0) ((= num 1) (if (= (length sym) 1) (car sym) (cons '* sym))) (else (cons '* (cons num sym))) ))) ;(make-product '(0 1 2)) ;(make-product '(0 a b 1 c)) ;(make-product '(0.5 2 a)) ;(make-product '(0.5 2 a c (+ a c))) ;(make-product '(a b 1 3 -1 (* f va))) (define (make-expon x n) (cond ((eq? n 0) 1) ((eq? x 0) 0) (else (list '** x n)) )) ;(make-expon 0 'a) ;(make-expon 0 0) ;(make-expon 'a 0) ;(make-expon 'a 'b) ;(make-expon 2 3) (define (deriv exp var) (cond ((number? exp) 0) ((variable? exp) (if (same-variable? exp var) 1 0)) ((sum-exp? exp) (make-sum (map (lambda (x) (deriv x var)) (cdr exp)))) ((product-exp? exp) (let ((first (cadr exp)) (second (make-product (cddr exp)))) (make-sum (list (make-product (list first (deriv second var))) (make-product (list (deriv first var) second )))) )) ((expon-exp? exp) (let ((base (cadr exp)) (n (caddr exp))) (make-product (list n (make-expon base (make-sum (list n -1))) (deriv base var) )) )) )) (deriv '(+ a (+ a a) b a) 'a) ;4 (deriv 'a 'b) ;0 (deriv '(* a b x) 'a) ;(* b x) (deriv '(* (+ (* a b) (* a c)) d) 'a) ;(* (+ b c) d) (deriv '(* (+ a b c) (* a b b)) 'a) ;(+ (* (+ a b c) (* b b)) (* a b b)) (deriv '(** x n) 'x) ;(* n (** x (+ -1 n))) (deriv '(** (* 3 a ) n) 'a) ;(* n (** (* 3 a) (+ -1 n)) (* 3))