diff --git a/ex-2.58.scm b/ex-2.58.scm new file mode 100644 index 0000000..1254c47 --- /dev/null +++ b/ex-2.58.scm @@ -0,0 +1,272 @@ +#lang sicp + +; Thoughts before the exercise: +; The first thing that I think might be an issue here is unnecessarily nested +; expressions: +; example: (((1 + 2 * 3))). We didn't have to think about these when we were simply +; using Lisp notation, since every list was basically guarranteed to have an +; operator. In our new case, every list with a length > 1 is going to have to +; have an operator, but we need a way to deal naturally with expressions of the +; form (x), where the result of the expression is obviously x. + +; One idea would be to have a function that tries to access the innermost list. +; And then use it throughout all the other functions. But this would be quite +; painful. A better idea might be to consider this list to be a new kind of +; expression, called a grouping, we could have a predicate "grouping?", a +; selector "group-mem", and a constructor "group" (but there's no reason to ever +; use the constructor.) + +; Okay, once we know how to deal with those, everything else should be clear: a +; sum is simply a list that contains +, a product is a list that contains * but +; not +, an exponentiation is a list which contains only the ** operator +; (speaking at the top level for all of these, of course). + +; It's clear how to construct a sum, it's also clear how to get the addend and +; augend, and construction, in essence, is not complicated. However, if we want +; to try and keep the expressions somewhat simplified, like we did in previous +; exercises, we may need to do more work on the constructors. + +(define op-order '(+ * **)) + +(define (list-index lst elem) + (define (li-rec lst elem index) + (cond ((null? lst) -1) + ((eq? (car lst) elem) index) + (else (li-rec (cdr lst) elem (+ index 1))))) + (li-rec lst elem 0)) + +;compares precedence of ops +(define (lower-or-eq-op op1 op2) + (<= (list-index op-order op1) + (list-index op-order op2))) + +; finds the-top-level op for an expression list: +; e.g. (1 + (2 * 4) * 3) => + +(define (top-op exp) + (define (top-op-rec exp op-order) + (cond ((null? op-order) nil) + ((memq (car op-order) exp) (car op-order)) + (else (top-op-rec exp (cdr op-order))))) + (top-op-rec exp op-order)) + +(define (make-group exp) + (list exp)) + +; a group is just a list of length 1 +(define (group? exp) + (and (pair? exp) (null? (cdr exp)))) + +(define (degroup exp) + (car exp)) + +; not the real deconstructor, but very useful +(define (degroup-repeated exp) + (if (group? exp) + (degroup-repeated (degroup exp)) + exp)) + +; We're gonna be doing this, a lot +; turns a list such as (1 (2 * 4) 3) into (1 + (2 * 4) + 3) +(define (splice-op arglist op) + (cond ((null? arglist) nil) ; 0 args + ((null? (cdr arglist)) arglist) ; 1 arg + (else (cons (car arglist) + (cons op + (splice-op (cdr arglist) op)))))) + +; This does the opposite, assumes op is the top-op of the expression +; eg. (1 + 2 * 4 + 3) => (1 (2 * 4) 3) +(define (extract-op exp op) + (cond ((null? exp) nil) + ((null? (cdr exp)) exp) + ((null? (cddr exp)) (error "Extract-op from two-member list" exp)) + ((not (memq (cadr exp) op-order)) (error "Extract-op, second element not an op" exp)) + ((eq? (cadr exp) op) (cons (car exp) + (extract-op (cddr exp) op))) + (else (cons (grab-subexp exp op) + (extract-op (drop-subexp exp op)))))) + +; two helper functions for extract-op, extract a beginning subexpression, which uses a +; higher precedence op +; e.g. exp. (2 * 4 + 3 + 5), op: + +; (grab-subexp exp op) => (2 * 4) +; (drop-subexp exp op) => (3 + 5) +; +; exp. (2 * 4 + 3), op: + +; (grab-subexp exp op) => (2 * 4) +; (drop-subexp exp op) => (3) +; +; exp. (2 * 4), op: + +; (grab-subexp exp op) => (2 * 4) +; (drop-subexp exp op) => () +(define (grab-subexp exp op) + (if (or (null? exp) (eq? op (car exp))) + nil + ; if we reach the end of the list, or the top-level op, we stop adding elements + (cons (car exp) + (grab-subexp (cdr exp) op)))) + +(define (drop-subexp exp op) + (let ((list-from-op (memq op exp))) + (if (not list-from-op) + nil + (cdr list-from-op)))) + +; accepts a complex expression containing at least one operations +; removes parentheses around subexpressions which use an operator with higher +; precedence +(define (remove-parens list op) + (cond ((null? list) nil) + ((or (number? (car list)) + (variable? (car list)) + ; we don't want to remove parentheses around ops of the same precedence + ; since we did that while extracting argument lists. And if our operation + ; is not associative (e.g. **) this could cause an error + (lower-or-eq-op (top-op (car list)) op)) + (cons (car list) (remove-parens (cdr list) op))) + ; in any other case, it's either a grouping, or a higher-precedence op + ; and we can get rid of the parens + (else (append (car list) (remove-parens (cdr list) op))))) + +(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))))) + +; instead of the "fold" function in the previous exercise, here we have several +; "optimize" functions for arglists +(define (optimize-+ args) + (let* ((consts (filter number? args)) + (rest (filter not-number? args)) + (folded-const (apply + consts))) + (if (= folded-const 0) + rest + (append (list folded-const) rest)))) + +(define (optimize-* args) + (let* ((consts (filter number? args)) + (rest (filter not-number? args)) + (folded-const (apply * consts))) + (cond ((= folded-const 1) rest) + ((= folded-const 0) '(0)) + (else (append (list folded-const) rest))))) + +(define (optimize-** args) + (cond ((null? args) (error "Empty arg list for ** in optimize-**")) + ((null? (cdr args)) args) + (else + (let* ((new-args (cons (car args) ; if len(args)>=2, we first try to + ; compute the right hand side recursively + ; if afterwards len(args)==2, we try that too + (optimize-** (cdr args)))) + (len=2 (null? (cddr new-args))) + (fst (car new-args)) + (snd (cadr new-args))) + (cond ((and len=2 (number? fst) (number? snd)) ; both constant + (list (expt (car new-args) (cadr new-args)))) + ((and len=2 (=number? snd 1)) + (list fst)) + (else new-args)))))) + +(define (make-op op x1 x2) + (let* ((ux1 (degroup-repeated x1)) ; now we know our args are either simple nums/vars or + (ux2 (degroup-repeated x2)) ; they're an operation (+,*,**) + (exp->arglist + (lambda (exp) ; as long as our subexpression: exp. is not an operation of the exact + ; same type as the one we're creating, the list of extracted args + ; should just look like (exp). Otherwise, we need to extract the + ; operators from the list + ; e.g. op=+, x1 = (2 + 3 + 2 * 4) -> result=(2 3 (2 * 4)) + ; x2 = (2 * 4) -> result=((2 * 4)) + ; then we simply append the lists + (if (or (variable? exp) + (number? exp) + (not (eq? op (top-op exp)))) + (list exp) + (extract-op exp op)))) + (arglist1 (if (and (eq? op '**) ; if both the op we're making, and the left-hand side + (exponentiation? ux1)) ; are an exponentiation, we need to simply + (list ux1) ; parenthesise the left-hand side, don't extract args, + (exp->arglist ux1))) ; because ** is right-associative + (arglist2 (exp->arglist ux2)) + (args (append arglist1 arglist2)) + (opt-args (cond ((eq? op '+) (optimize-+ args)) + ((eq? op '*) (optimize-* args)) + ((eq? op '**) (optimize-** args))))) + ; keep in mind, after this step ** must have at least 1 argument, + ; +,* can have 0 + (cond ((and (eq? op '+) (= (length opt-args) 0)) 0) + ((and (eq? op '*) (= (length opt-args) 0)) 1) + ((= (length opt-args) 1) (car opt-args)) + (else (remove-parens (splice-op opt-args op) op))))) + +(define (make-sum a1 a2) + (make-op '+ a1 a2)) + +(define (make-product m1 m2) + (make-op '* m1 m2)) + +(define (sum? x) (and (pair? x) (eq? (top-op x) '+))) +; when we split the list using grab/drop-subexp, we might get a list of length +; 1 on either end +(define (addend s) (degroup-repeated (grab-subexp s '+))) +(define (augend s) (degroup-repeated (drop-subexp s '+))) + +(define (product? x) (and (pair? x) (eq? (top-op x) '*))) +(define (multiplier p) (degroup-repeated (grab-subexp p '*))) +(define (multiplicand p) (degroup-repeated (drop-subexp 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) + (make-op '** b e)) + +(define (exponentiation? x) (and (pair? x) (eq? (top-op x) '**))) +(define (base e) (car 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))))