#lang racket/base ;; Symbolic differentiation program. (provide deriv) ;; List of supported binary operators. `^' means exponentiation. (define binary-operator-list '(+ - * / ^)) ;; List of operators with right-to-left associativity. (define right-associative-operator '(^)) ;; List of supported trignometric functions. (define trigonometric-list '(sin cos tan)) ;;; Constructors (define (make-sine x) (cond [(number? x) (sin x)] [else (list 'sin x)])) (define (make-cosine x) (cond [(number? x) (cos x)] [else (list 'cos x)])) (define (make-tangent x) (cond [(number? x) (tan x)] [else (list 'tan x)])) (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-difference s1 s2) (cond [(=number? s2 0) s1] [(=number? s1 0) (list '- s2)] [(and (number? s1) (number? s2)) (- s1 s2)] [else (list '- s1 s2)])) (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)])) ;; TODO 2021-08-19: Simplify 0 / x cases. (define (make-ratio n d) (cond [(=number? d 0) (raise-arguments-error 'make-ratio "invalid denominator" "d" d)] [(and (number? n) (number? d)) (let* ((g (gcd n d)) (tmp-1 (/ n g)) (tmp-2 (/ d g))) (cond ;; Normalize the -ve sign [(or (and (positive? tmp-1) (negative? tmp-2)) (and (negative? tmp-1) (negative? tmp-2))) (list '/ (* -1 tmp-1) (* -1 tmp-2))] [else (list '/ tmp-1 tmp-2)]))] [else (list '/ n d)])) (define (make-exponentiation base exponent) (cond [(=number? exponent 0) 1] [(=number? exponent 1) base] [(and (number? base) (number? exponent)) (expt base exponent)] [else (list '^ base exponent)])) (define (make-expr op . exprs) (cond [(eq? op '+) (make-sum (car exprs) (cadr exprs))] [(eq? op '-) (make-difference (car exprs) (cadr exprs))] [(eq? op '*) (make-product (car exprs) (cadr exprs))] [(eq? op '/) (make-ratio (car exprs) (cadr exprs))] [(eq? op '^) (make-exponentiation (car exprs) (cadr exprs))] [(eq? op 'sin) (make-sine (car exprs))] [(eq? op 'cos) (make-cosine (car exprs))] [(eq? op 'tan) (make-tangent (car exprs))] [else (raise-arguments-error 'make-expr "invalid operator" "op" op)])) ;;; Selectors (define (addend s) (cadr s)) (define (augend s) (caddr s)) (define (minuend s) (cadr s)) (define (subtrahend s) (caddr s)) (define (multiplier p) (cadr p)) (define (multiplicand p) (caddr p)) (define (dividend d) (cadr d)) (define (divisor d) (caddr d)) (define (base e) (cadr e)) (define (exponent e) (caddr e)) ;; Return argument of a compund unary expression e. (define (argument e) (cadr e)) ;;; Predicates (define (binary-operator? x) (memq x binary-operator-list)) (define (right-associative-operator? x) (memq x right-associative-operator)) (define (trigonometric-operator? x) (memq x trigonometric-list)) (define (unary-operator? x) (or (trigonometric-operator? x))) ;; Is expression EXPR equal to number NUM. (define (=number? expr num) (and (number? expr) (= expr num))) (define (variable? x) (symbol? x)) (define (same-variable? v1 v2) (and (variable? v1) (variable? v2) (eq? v1 v2))) (define (sum? x) (and (pair? x) (eq? (car x) '+))) (define (difference? x) (and (pair? x) (eq? (car x) '-))) (define (product? x) (and (pair? x) (eq? (car x) '*))) (define (division? x) (and (pair? x) (eq? (car x) '/))) (define (exponent? x) (and (pair? x) (eq? (car x) '^))) (define (sine? x) (and (pair? x) (eq? (car x) 'sin))) (define (cosine? x) (and (pair? x) (eq? (car x) 'cos))) (define (tangent? x) (and (pair? x) (eq? (car x) 'tan))) (define (unary-expr? x) (and (pair? x) (unary-operator? (car x)))) ;; Is operator OP1 capable of removing operator OP2 from operator stack (used in ;; infix->prefix). (define (pop-operator? op1 op2) (and (not (right-associative-operator? op1)) (<= (precedence op2) (precedence op1)))) ;;; General Procedures ;; Order of precedence for operator OP (lower is better). (define (precedence op) (cond [(eq? op '*) 1] [(eq? op '/) 1] [(eq? op '+) 2] [(eq? op '-) 2] [else 0])) ;; Apply operation OP by popping operands from list OPERANDS. (define (pop op operands) (cond [(unary-operator? op) (cons (make-expr op (car operands)) (cdr operands))] [(binary-operator? op) (let ((expr1 (car operands)) (expr2 (cadr operands))) (cons (make-expr op expr2 expr1) ; HACK: Note the order of expressions. (cddr operands)))] [else (raise-arguments-error 'pop "unknown operation" "op" op)])) ;; Convert infix expression EXPR to prefix using Edsger Dijkstra's Shutting Yard ;; algorithm. (define (infix->prefix expr) (define (iter input output operator) (cond [(and (null? input) (null? operator)) (car output)] ; TODO 2021-08-12: Can we remove this CAR? ;; If input is null, pop all operators. [(null? input) (iter input (pop (car operator) output) (cdr operator))] [else (let ((x (car input))) (cond ;; sub-expressions with parentheses [(pair? x) (iter (cdr input) (cons (infix->prefix x) output) operator)] [(or (unary-operator? x) (binary-operator? x)) (if (or (null? operator) (not (pop-operator? x (car operator)))) (iter (cdr input) output (cons x operator)) (iter (cdr input) (pop (car operator) output) (cons x (cdr operator))))] [else (iter (cdr input) (cons x output) operator)]))])) (iter expr null null)) (define (deriv expr var) ;; Derive unary expression EXPR (define (deriv-unary expr) (let ((arg (argument expr))) (cond [(sine? expr) (make-cosine arg)] [(cosine? expr) (make-product -1 (make-sine arg))] [(tangent? expr) (make-product (make-ratio 1 (make-cosine arg)) (make-ratio 1 (make-cosine arg)))]))) ;; Derive prefix expression EXPR in VAR. (define (deriv-prefix expr var) (cond ;; constant expression [(number? expr) 0] ;; dx/dx = 1 [(variable? expr) (if (same-variable? expr var) 1 0)] ;; (f + g)' = f' + g' [sum rule] [(sum? expr) (make-sum (deriv-prefix (addend expr) var) (deriv-prefix (augend expr) var))] ;; (f - g)' = f' - g' [difference rule] [(difference? expr) (make-difference (deriv-prefix (minuend expr) var) (deriv-prefix (subtrahend expr) var))] ;; (f * g)' = f'*g + f*g' [product rule] [(product? expr) (let ((m1 (multiplier expr)) (m2 (multiplicand expr))) (make-sum (make-product m1 (deriv-prefix m2 var)) (make-product m2 (deriv-prefix m1 var))))] ;; (f ^ n) = n*f ^ (n-1) [elementary power rule] [(exponent? expr) (let ((b (base expr)) (e (exponent expr))) (make-product (make-product e (make-exponentiation b (make-sum e -1))) (deriv-prefix b var)))] ;; (f / g)' = (f'*g - g*'f) / g^2 [divisibility rule] [(division? expr) (let ((d1 (dividend expr)) (d2 (divisor expr))) (make-ratio (make-difference (make-product d2 (deriv-prefix d1 var)) (make-product d1 (deriv-prefix d2 var))) (make-exponentiation d2 2)))] ;; (f(g(x)))'= f'(g(x)) * g'(x) [chain rule] [(unary-expr? expr) (make-product (deriv-unary expr) (deriv-prefix (argument expr) var))] [else (raise-arguments-error 'deriv "unknown exprression type" "expr" expr)])) (deriv-prefix (infix->prefix expr) var))