The pattern of the code is
(sum <variable> = <start> to <end> <expression>)
Here is what we want it to mean, in mutating style:
(let ((<variable> <start>)
(end <end>) ; force single evaluation, see tutorial
(result 0))
(let loop () ; recursive procedure, no state passed on
(if (> <variable> end) result
(begin (set! result (+ result <expression>))
(set! <variable> (+ <variable> 1))
(loop)))))
Here it is in non-mutating style:
(let ((end <end>)) ; doesn't change, so not part of state below
; but force single evaluation
(let loop ((<variable> <start>) ; recursive procedure, all state passed on
(result 0)) ;
(if (> <variable> end) result
(loop (+ <variable> 1) (+ result <expression>)))))
So one solution is:
(define-syntax sum
(syntax-rules (= to) ; = and to must appear literally
((sum <variable> = <start> to <end> <expression>)
(let ((end <end>)) ; doesn't change, so not part of state below
; but force single evaluation
(let loop ((<variable> <start>) ; recursive procedure, all state passed on
(result 0)) ;
(if (> <variable> end) result
(loop (+ <variable> 1) (+ result <expression>))))))))
We either have:
The list of free variables in each case is:
Assuming we will write union and difference, here's free:
(define (free e)
(if (list? e) ; case 1 or 2
(if (and (>= (length e) 2) (equal? (car e) 'lambda)) ; case 1
(difference (free (cddr e)) (cadr e)) ; case 1
(union (map free e))) ; case 2
(if (symbol? e) (list e) '()))) ; cases 3 and 4
Changing (cadr e) to (free (cadr e)) would handle non-fixed-arity lambda as well.
For union, we'll append (see R5RS) and then make each element appear only once.
; => elements in lists in l, with each element appearing once. ; Requires: l a list of lists. ; (define (union l) (unique (apply append l)))
For unique, we do a standard car-cdr recursion:
; => list l with duplicate elements removed (leaving last occurence).
(define (unique l)
(if (null? l) l
(let ((unique-rest (unique (cdr l))))
(if (member (car l) unique-rest)
unique-rest
(cons (car l) unique-rest)))))
We used member from R5RS.
Difference is similar to unique:
; => list l1 with elements appearing in l2 removed.
(define (difference l1 l2)
(if (null? l1) l1
(let ((difference-rest (difference (cdr l1) l2)))
(if (member (car l1) l2)
difference-rest
(cons (car l1) difference-rest)))))
First consider the recursive case where the first clause ends with break:
(cond* (<test> <body> ... break) <clause> ...)
This becomes:
(if <test> (begin <body> ...) (cond* <clause> ...))
If it doesn't end with break, we want all remaining tests to be considered true if the test succeeds:
(cond* (<test> <body> ...) (<test1> <body1> ...) ...)
becomes
(if <test> (begin <body> ... (cond* #t <test1> <body1> ...) ...)
(cond* (<test1> <body1> ...) ...))
A single clause with break is the same as one without break, and that one turns into a simple if.
Now to handle else:
(cond* (else <body> ...) <clause> ...)
becomes
(cond* (#t <body> ...) <clause> ...)
and the recursion above takes over. Except we have a problem: our earlier work changes some tests by inserting #t, moving else into the body. Let's instead add elses, and remove them when we see them in the first clause. Notice that if the user has else's in the body because they have some variable else, it can only affect the result if it's the last else, so we guard against removing it by requiring at least one body element after the else:
(cond* (else else <body0> <body> ...) <clause> ...)
becomes
(cond* (else <body0> <body> ...) <clause> ...)
Putting the six clauses together, with more specific ones before more general ones:
(define-syntax cond*
(syntax-rules (break else)
((cond* (else else <body0> <body> ...) <clause> ...)
(cond* (else <body0> <body> ...) <clause> ...))
((cond* (else <body> ...) <clause> ...)
(cond* (#t <body> ...) <clause> ...))
((cond* (<test> <body> ... break))
(cond* (<test> <body> ...)))
((cond* (<test> <body> ...))
(if <test> (begin <body> ...)))
((cond* (<test> <body> ... break) <clause> ...)
(if <test> (begin <body> ...) (cond* <clause> ...)))
((cond* (<test> <body> ...) (<test1> <body1> ...) ...)
(if <test> (begin <body> ... (cond* (else <test1> <body1> ...) ...))
(cond* (<test1> <body1> ...) ...)))))
I'm assuming we didn't notice that if a clause matches we only need to make the next clause test true. If so, we could avoid the multiple else problem by seeing whether the next clause starts with else. I'll leave this as an exercise.
The question is similar to what we did with Symbolic Differentiation in lecture.
There is no arbitrary code to be selectively evaluated. Also, we have four operations on wff's, so we want to be able to treat wff's as values that we can share and pass around -- something we can't do if they only appear explicitly as pieces of literal `code'. So there's no reason to make syntactic forms, and good reason to make procedures.
(define (proposition-wff? p)
(match p
(('not p1) (proposition-wff? p1))
((p1 op p2) (and (member op '(and or implies iff)) (proposition-wff? p1) (proposition-wff? p2)))
(#t #t)
(#f #t)
(p (symbol? p))))
(define (proposition-eval p l)
(match p
(('not p1) (not (proposition-eval p1 l)))
((p1 'and p2) (and (proposition-eval p1 l) (proposition-eval p2 l)))
((p1 'or p2) (or (proposition-eval p1 l) (proposition-eval p2 l)))
((p1 'implies p2) (if (proposition-eval p1 l) (proposition-eval p2 l) #f))
((p1 'iff p2) (equal? (proposition-eval p1 l) (proposition-eval p2 l)))
(#t #t)
(#f #f)
(p (not (not (member p l)))))) ; member doesn't actually return #t when true
; so this little trick turns it into #t
(define (proposition-normalize p)
(match p
(('not ('not p)) (proposition-normalize p))
(('not (p1 'and p2)) (proposition-normalize `((not ,p1) or (not ,p2))))
(('not (p1 'or p2)) (proposition-normalize `((not ,p1) and (not ,p2))))
((p1 op p2) `(,(proposition-normalize p1) ,op ,(proposition-normalize p2)))
(('not #f) #t)
(('not #t) #f)
(p p))) ; symbol, constant or negation of symbol
For satisfiable we first make a simpler procedure than free, to find all variables:
(define (variables p)
(match p
(('not p1) (variables p1))
((p1 op p2) (union (variables p1) (variables p2)))
(p (if (symbol? p) `(,p) '()))))
Now we need all subsets, a standard car-cdr recursion:
(define (subsets l)
(if (null? l) '(())
(let ((subsets-rest (subsets (cdr l))))
(append subsets-rest
(map (lambda (s) (cons (car l) s))
subsets-rest)))))
Now we get:
(define (proposition-satisfiable? p) (member #t (map (lambda (t) (proposition-eval p t)) (subsets (variables p)))))
I'll leave it as an exercise to improve the efficiency (move the call to proposition-eval
into the subsets recursion.
We are asked to make the cond as follows:
(apply (cond ((equal? m 'size) (lambda ???))
((equal? m 'enqueue) (lambda ???))
((equal? m 'dequeue) (lambda ???)))
(cdr args))
To make this work, the lambdas must be:
(lambda () size)
(lambda (o)
(vector-set! v (modulo (+ head size) capacity) o)
(set! size (+ size 1)))
(lambda ()
(set! size (- size 1))
(let ((r (vector-ref v head)))
(set! head (modulo (+ head 1) capacity))
r))
So we have
(define (Circular-Queue capacity)
(let ((v (make-vector capacity))
(head 0)
(size 0))
(lambda args
(let ((m (car args)))
(apply (cond ((equal? m 'size)
(lambda () size))
((equal? m 'enqueue)
(lambda (o)
(vector-set! v (modulo (+ head size) capacity) o)
(set! size (+ size 1))))
((equal? m 'dequeue)
(lambda ()
(set! size (- size 1))
(let ((r (vector-ref v head)))
(set! head (modulo (+ head 1) capacity))
r))))
(cdr args))))))
The large-scale structure of class is:
(class (<argument> ...)
((<variable> <init>) ...) ; list of pairs of instance variable and initial value
(<header> <body> ...) ...) ; pairs of method header and body
It produces the (implicit) lambda above:
(lambda (<argument> ...)
???)
The instance variable pairs become the list of let variables:
(let ((<variable> <init>) ...)
???)
We follow this by the parts that don't depend on the particular methods:
(lambda args
(let ((m (car args)))
(apply (cond ???)
(cdr args))))
Each cond clause is constructed from the header name, header argument(s) and body, so we need to break <header> down further:
; pairs of method header and body
((<method-name> <method-arguments>) <body> ...) ...)
This becomes the cond clauses:
(cond ((equal? m '<method-name>) (lambda (<method-arguments>) <body> ...)) ...)
Putting this all together:
(define-syntax class
(syntax-rules ()
((class (<argument> ...)
((<variable> <init>) ...)
((<method-name> <method-arguments> ...) <body> ...) ...)
(lambda (<argument> ...)
(let ((<variable> <init>) ...)
(lambda args
(let ((m (car args)))
(apply
(cond ((equal? m '<method-name>)
(lambda (<method-arguments> ...) <body> ...)) ...)
(cdr args)))))))))
We start with the both private and public. Both kind go in the let, the public ones produce corresponding getter methods. The others get rewritten into a form with both private and public.
(define-syntax class
(syntax-rules (private public)
((class (<argument> ...)
(private (<variable> <init>) ...)
(public (<public-variable> <public-init>) ...)
((<method-name> <method-arguments> ...) <body> ...) ...)
(lambda (<argument> ...)
(let ((<variable> <init>) ...
(<public-variable> <public-init>) ...)
(lambda args
(let ((m (car args)))
(apply
(cond ((equal? m '<public-variable>)
(lambda () <public-variable>)) ...
((equal? m '<method-name>)
(lambda (<method-arguments> ...) <body> ...)) ...)
(cdr args)))))))
((class <argument-list> (public <variable-pair> ...) <method> ...)
(class <argument-list> (private) (public <variable-pair> ...) <method> ...))
((class <argument-list> (private <variable-pair> ...) <method> ...)
(class <argument-list> (private <variable-pair> ...) (public) <method> ...))
((class <argument-list> <method> ...)
(class <argument-list> (private) (public) <method> ...))))
We recursively extract the non-explicit variables into the explicit lists. When it's empty, we're done. First, we force a private and public list.
(define-syntax class
(syntax-rules (private public get)
((class (<argument> ...)
()
(private (<private-variable> <private-init>) ...)
(public (<public-variable> <public-init>) ...)
((<method-name> <method-arguments> ...) <body> ...) ...)
(lambda (<argument> ...)
(let ((<private-variable> <private-init>) ...
(<public-variable> <public-init>) ...)
(lambda args
(let ((m (car args)))
(apply
(cond ((equal? m '<public-variable>)
(lambda () <public-variable>)) ...
((equal? m '<method-name>)
(lambda (<method-arguments> ...) <body> ...)) ...)
(cdr args)))))))
((class <argument-list>
((<variable> get <init>) <variable-spec> ...) <private-list> (<public-spec> ...)
<method> ...)
(class <argument-list>
(<variable-spec> ...) <private-list> (<public-spec> ... (<variable> <init>))
<method> ...))
((class <argument-list>
((<variable> <init>) <variable-spec> ...) (<private-spec> ...) <public-list>
<method> ...)
(class <argument-list>
(<variable-spec> ...) (<private-spec> ... (<variable> <init>)) <public-list>
<method> ...))
((class <argument-list> <variable-list> <method> ...)
(class <argument-list> <variable-list> (private) (public) <method> ...))))
We add the superclass call to every clause above. In first clause, which generates the final code, the superclass call gets copied into the let. There's an extra method at the end of the cond to pass the method call to the superclass object. Then we add a clause to detect the non-superclass form and rewrite it into the superclass form, providing a dummy superclass.
(define-syntax class
(syntax-rules (private public get)
((class (<argument> ...) ((<variable> ...) ...) <rest> ...)
(class (<argument> ...) (super (lambda args 'no-such-method)) ((<variable> ...) ...) <rest> ...))
((class (<argument> ...) (super <superclass-object>)
()
(private (<private-variable> <private-init>) ...)
(public (<public-variable> <public-init>) ...)
((<method-name> <method-arguments> ...) <body> ...) ...)
(lambda (<argument> ...)
(let ((super <superclass-object>)
(<private-variable> <private-init>) ...
(<public-variable> <public-init>) ...)
(lambda args
(let ((m (car args)))
(apply
(cond ((equal? m '<public-variable>)
(lambda () <public-variable>)) ...
((equal? m '<method-name>)
(lambda (<method-arguments> ...) <body> ...)) ...
(else
(lambda m-args (apply super args))))
(cdr args)))))))
((class <argument-list> (super <superclass-object>)
((<variable> get <init>) <variable-spec> ...) <private-list> (<public-spec> ...)
<method> ...)
(class <argument-list> (super <superclass-object>)
(<variable-spec> ...) <private-list> (<public-spec> ... (<variable> <init>))
<method> ...))
((class <argument-list> (super <superclass-object>)
((<variable> <init>) <variable-spec> ...) (<private-spec> ...) <public-list>
<method> ...)
(class <argument-list> (super <superclass-object>)
(<variable-spec> ...) (<private-spec> ... (<variable> <init>)) <public-list>
<method> ...))
((class <argument-list> (super <superclass-object>) <variable-list> <method> ...)
(class <argument-list> (super <superclass-object>) <variable-list> (private) (public) <method> ...))))