SICP/ex-2_53-58.scm

(load "shared/util.scm")

(define (memq item x)
  (cond ((null? x) false)
        ((eq? item (car x)) x)
        (else (memq item (cdr x)))))

(display "ex-2.53 - symbols (see comments)") (newline)

(list 'a 'b 'c)                         ; (a b c)
(list (list 'george))                   ; ((george))
(cdr '((x1 x2) (y1 y2)))                ; ((y1 y2))
(cadr '((x1 x2) (y1 y2)))               ; (y1 y2)
(pair? (car '(a short list)))           ; #f
(memq 'red '((red shoes) (blue socks))) ; #f
(memq 'red '(red shoes blue socks))     ; (red shoes blue socks)
(newline)

(display "ex-2.54 - equal?") (newline)

(define (my-equal? a b)
  (cond
    ((and (null? a) (null? b)) #t)
    ((eq? (car a) (car b)) (my-equal? (cdr a) (cdr b)))
    (else #f)))

(assert (my-equal? '(this is a list) '(this is a list)) #t)
(assert (my-equal? '(this is a list) '(this (is a) list)) #f)
(newline)

(display "ex-2.55 - double quote") (newline)

; The expression after car yields `(quote abracadabra)`. Consequently car
; returns `quote`.
(display (car ''abracadabra))

(newline) (newline)
(display "example - symbolic differentiation\n")

(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 (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-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 (sum? x)
  (and (pair? x) (eq? (car x) '+)))
(define (addend s) (cadr s))
(define (augend s) (caddr s))
(define (product? x)
  (and (pair? x) (eq? (car x) '*)))
(define multiplier cadr)
(define multiplicand caddr)

(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)
         (let ((b (base exp))
               (e (exponent exp)))
           (make-product
             (make-product e (make-exponentiation b (make-sum e -1)))
             (deriv b var))))
        (else
         (error "unknown expression type -- DERIV" exp))))

(display (deriv '(+ x 3) 'x)) (newline) ; (+ 1 0)
(display (deriv '(* x y) 'x)) (newline) ; (+ (* x 0) (* 1 y))
(display (deriv '(* (* x y) (+ x 3)) 'x))
;(+ (* (* x y) (+ 1 0))
;   (* (+ (* x 0) (* 1 y))
;      (+  x 3)))


(display "\n\nex-2.56 - exponentiation\n")

(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))
(define base cadr)
(define exponent caddr)
(define (make-exponentiation b e)
  (cond
    ((=number? e 0) 1)
    ((=number? e 1) b)
    (else (list '** b e))))
; Also extended deriv above.

(display (deriv (make-exponentiation 'x 3) 'x))


(display "\n\nex-2.57 - arbitrary length sums and products") (newline)

(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-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 (addend s) (cadr s))
(define (augend s)
  (if (null? (cdddr s))
    (caddr s)
    (cons '+ (cddr s))))

(define (multiplier s) (cadr s))
(define (multiplicand s)
  (if (null? (cdddr s))
    (caddr s)
    (cons '* (cddr s))))

(define e '(* x y (+ x 3) 42))
(display e) (newline)
(display (multiplier e)) (newline)
(display (multiplicand e)) (newline)
(display (deriv '(* (* x y) (+ x 3)) 'x)) (newline)
(display (deriv '(* x y (+ x 3)) 'x))

(display "\n\nex-2.58 - infix notation") (newline)

(display "a)\n")
(define (addend s) (car s))
(define (augend s) (caddr s))
(define (multiplier s) (car s))
(define (multiplicand s) (caddr s))

(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-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 (sum? x)
  (and (pair? x) (eq? (cadr x) '+)))
(define (product? x)
  (and (pair? x) (eq? (cadr x) '*)))

(define x-infix '(x + (3 * (x + (y + 2)))))
(display x-infix) (newline)
(display (deriv x-infix 'x)) (newline)

(display "b)\n")
; If there is at least one + in the expression it is a
; sum. If it is not a sum and there is at least one * in
; the expression it is a product.

(define (sum? x)
  (cond
    ((null? (cdr x)) #f)
    ((eq? (cadr x) '+) #t)
    (else (sum? (cddr x)))))

(define (product? x)
  (cond
    ((null? (cdr x)) #f)
    ((sum? x) #f)
    ((eq? (cadr x) '*) #t)
    (else (product? (cddr x)))))

(define (lift x) (if (null? (cdr x)) (car x) x))

(define (addend s)
  (define (go-addend s)
    (cond
      ((not (pair? s)) '())
      ((eq? (cadr s) '+) (list (car s)))
      (else (cons (car s) (cons (cadr s) (go-addend (cddr s)))))))
  (lift (go-addend s)))

(define (augend s)
  (define (go-augend s)
    (cond
      ((not (pair? s)) '())
      ((eq? (cadr s) '+) (cddr s))
      (else (go-augend (cddr s)))))
  (lift (go-augend s)))

(define (multiplier s)
  (define (go-multiplier s)
    (cond
      ((not (pair? s)) '())
      ((eq? (cadr s) '*) (list (car s)))
      (else (cons (car s) (cons (cadr s) (go-multiplier (cddr s)))))))
  (lift (go-multiplier s)))

(define (multiplicand s)
  (define (go-multiplicand s)
    (cond
      ((not (pair? s)) '())
      ((eq? (cadr s) '*) (cddr s))
      (else (go-multiplicand (cddr s)))))
  (lift (go-multiplicand s)))

(define s '(a * b * (c * e) + d))
(define p '(a * b * (c + e) * d))

; some tests
(assert (sum? p) #f)
(assert (sum? s) #t)
(assert (product? p) #t)
(assert (product? s) #f)
(assert (multiplier p) 'a)
(assert (multiplicand p) '(b * (c + e) * d))
(assert (addend s) '(a * b * (c * e)))
(assert (augend s) 'd)
(assert (product? '(x * x + x)) #f)
(assert (multiplier '(x * x * x)) 'x)
(assert (multiplicand '(x * x * x)) '(x * x))
(assert (addend '(a + b)) 'a)
(assert (augend '(a + b)) 'b)
(assert (multiplier '(a * b)) 'a)
(assert (multiplicand '(a * b)) 'b)
(assert (product? '(x * x + x)) #f)
(assert (sum? '(x * x + x)) #t)

(define x-infix '(x + 3 * (x + y + 2)))

(display x-infix) (newline)
(display (deriv x-infix 'x)) (newline)