2013-01-21.scm

(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))))
	((exponentation? exp) ;; ex. 2.56
	 (make-product
		 (exponent exp)
		 (make-exponentation (base exp) (make-sum (exponent exp) -1))))
	

	(else
	 (error "unknown expression type -- DERIV" exp))))

(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
	((=number? a2 0) a1)
	((and (number? a1) (number? a2)) (+ a1 a2))
	((and (sum? a1) (sum? a2))
	 (append '(+) (cdr a1) (cdr a2)))
	((sum? a1) (append a1 (list a2)))
	((sum? a2) (append (list '+ a1) (cdr a2)))
	(else (list '+ a1 a2))))
(define (=number? v n)
  (and (number? v) (= v n)))

(define (make-product a1 a2)
  (cond ((or (=number? a1 0) (=number? a2 0)) 0)
	((=number? a1 1) a2)
	((=number? a2 1) a1)
	((and (product? a1) (product? a2))
	 (append '(*) (cdr a1) (cdr a2)))
	((product? a1) (append a1 (list a2)))
	((product? a2) (append (list '* a1) (cdr a2)))
	(else (list '* a1 a2))))

(define (sum? x)
  (and (pair? x) (eq? (car x) '+)))

(define (addend s) (cadr s))
(define (augend s)
  (let ((_s (cddr s)))
    (cond ((= (length _s) 1) (car _s))
	  (else (cons '+ _s)))))

(define (product? x)
  (and (pair? x) (eq? (car x) '*)))

(define (multiplier p) (cadr p))
(define (multiplicand p)
  (let ((_p (cddr p)))
    (cond ((= (length _p) 1) (car _p))
	  (else (cons '* _p)))))

;; ex. 2.56
(define (make-exponentation a1 a2)
  (cond ((=number? a2 0) 1)
	((=number? a2 1) a1)
	(else (list '** a1 a2))))
(define (exponentation? x)
  (and (pair? x) (eq? (car x) '**)))
(define (base x) (cadr x))
(define (exponent x) (caddr x))

2013-01-21_test.scm

(load "./2013-01-21.scm")

(assert (variable? 'a) (is #t))

(assert (same-variable? 'a 'a) (is #t))
(assert (same-variable? 'a 'b) (is #f))

(assert (make-sum 'a 'b) (is '(+ a b)))
(assert (make-sum (make-sum 'a 'b) 'c) (is '(+ a b c)))
(assert (make-sum 'a (make-sum 'b 'c)) (is '(+ a b c)))
(assert (sum? (make-sum 'a 'b)) (is #t))
(assert (sum? 'a) (is #f))
(assert (addend (make-sum 'a 'b)) (is 'a))
(assert (augend (make-sum 'a 'b)) (is 'b))
(assert (addend '(+ a b c)) (is 'a))
(assert (augend '(+ a b c)) (is '(+ b c)))

(assert (make-product 'a 'b) (is '(* a b)))
(assert (make-product (make-product 'a 'b) 'c) (is '(* a b c)))
(assert (make-product 'a (make-product 'b 'c)) (is '(* a b c)))
(assert (make-product
	 (make-product 'a 'b) (make-product 'c 'd)) (is '(* a b c d)))
(assert (product? (make-sum 'a 'b)) (is #f))
(assert (product? (make-product 'a 'b)) (is #t))
(assert (product? 'a) (is #f))
(assert (multiplier (make-product 'a 'b)) (is 'a))
(assert (multiplicand (make-product 'a 'b)) (is 'b))
(assert (multiplier '(* a b c)) (is 'a))
(assert (multiplicand '(* a b c)) (is '(* b c)))

(assert (make-exponentation 'a 'b) (is '(** a b)))
(assert (make-exponentation 'a 0) (is 1))
(assert (make-exponentation 'a 1) (is 'a))
(assert (exponentation? (make-exponentation 'a 'b)) (is #t))
(assert (exponentation? (make-product 'a 'b)) (is #f))
(assert (exponentation? 'a) (is #f))
(assert (base (make-exponentation 'a 'b)) (is 'a))
(assert (exponent (make-exponentation 'a 'b)) (is 'b))

;; deriv
(assert (deriv '(+ x 3) 'x) (is 1))
(assert (deriv '(* x y) 'x) (is 'y))
(assert (deriv '(* (* x y) (+ x 3)) 'x)
	(is
	 '(+ (* x y)
	     (* y (+ x 3)))))

(assert (deriv '(** u n) 'x)
	(is '(* n (** u (+ n -1)))))

;; ex. 2.57
(assert (deriv '(* x y (+ x 3)) 'x)
	(is
	 '(+ (* x y)
	     (* y (+ x 3)))))

README.md

2013-01-21. 結局自習。

$ git clone https://gist.github.com/4251773.git gu
$ gosh -l ./gu/gu.scm ./*test.scm