kayprish/sicp-solutions
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add exercise 2.58

Browse source 
This was quite a long one, since I decided to both implement support for
constructing exponent ops, and also made sure that the expressions get
reasonably optimized once they are constructed.
This commit is contained in:
Petar Kapriš 2025-03-17 19:44:37 +01:00
parent 39d48f34f4
commit e9bede6dda
1 changed files with 272 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

272
ex-2.58.scm Normal file
View file

@ -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))))