CMPUT 325 Schedule and Outcomes8. Week 6 - Feb 10define directly instead of a lambda that is then named. We used the lambda form just to emphasize what is going on, and that a function is just like any other value. So, normall use define, as in the second form of each example below: (define f (lambda (x y) (+ x y)))
(define (f x y) (+ x y))
(define f (lambda args (print args)))
(define (f1 . args) (print args))
(define g (lambda (x y . args) (list (list x) (list y) (list args))))
(define (g1 x y . args) (list (list x) (list y) (list args)))
if statements into cond statements, and all let statements into applications of a lambda (as per the examples in the notes). #lang racket |
|
(define (transform-if-to-cond code) |
; locates every occurrence of an if expression in code and |
; transforms it into an equivalent cond |
|
; (if c p q) => (cond (c p) (else q )) |
|
(define (trans c p q) |
(list 'cond (list c p) (list 'else q) ) ) |
|
(if (and (list? code) (not (null? code)) (eq? 'if (first code))) |
|
; recursively transform the parts of the if before transforming the if |
(apply trans (map transform-if-to-cond (rest code))) |
|
(if (list? code) |
; recursively transform expressions |
(map transform-if-to-cond code) |
; leaf expression, leave alone |
code) |
)) |
|
(define (transform-let-to-apply code) |
; locates every occurrence of an let expression in code and |
; transforms it into an equivalent lambda applied to the defining expresions. |
|
; (let ( (v1 e1) (v2 e2) ... (vn en) ) b1 b2 ... bk ) |
; => |
; ((lambda (v1 v2 ... vn) b1 b2 ... bk) e1 e2 ... en) |
|
) |
transform-if-to-cond function is implemented, but the transform-let-into-apply is not. (define code-1 |
'(let ( (x 1) (y 2) ) |
;(displayln (list "got" x y)) |
(let ( (z (+ x y)) ) |
;(displayln (list "z" z)) |
(if (< x y) |
(list "x smaller") |
(list "y smaller") |
) |
) |
)) |
|
(define (test-1) |
(newline) |
(displayln code-1) |
(displayln (eval code-1)) |
(newline) |
|
; test the if transform |
(define t1 (transform-if-to-cond code-1)) |
(displayln t1) |
(displayln (eval t1)) |
(newline) |
|
; test the let transform |
(define t2 (transform-let-to-apply code-1)) |
(displayln t2) |
(displayln (eval t2)) |
(newline) |
|
; test the two different composition orders of the transforms |
(define t3 (transform-let-to-apply (transform-if-to-cond code-1))) |
(displayln t3) |
(displayln (eval t3)) |
(newline) |
(define t4 (transform-if-to-cond(transform-let-to-apply code-1))) |
(displayln t4) |
(displayln (eval t4)) |
) |
> (test-1) |
|
'(let ((x 1) (y 2)) (let ((z (+ x y))) (if (< x y) (list "x smaller") (list "y smaller")))) |
'("x smaller") |
|
'(let ((x 1) (y 2)) (let ((z (+ x y))) (cond ((< x y) (list "x smaller")) (else (list "y smaller"))))) |
'("x smaller") |
|
'((lambda (x y) ((lambda (z) (if (< x y) (list "x smaller") (list "y smaller"))) (+ x y))) 1 2) |
'("x smaller") |
|
'((lambda (x y) ((lambda (z) (cond ((< x y) (list "x smaller")) (else (list "y smaller")))) (+ x y))) 1 2) |
'("x smaller") |
|
'((lambda (x y) ((lambda (z) (cond ((< x y) (list "x smaller")) (else (list "y smaller")))) (+ x y))) 1 2) |
'("x smaller") |
transform-let-to-apply. -- data types are defined by constructor patterns |
-- Eq equality can be derived from structural equality |
|
-- a binary tree consisting of leaves L or internal nodes N |
data BinTree = L | N BinTree BinTree deriving (Eq, Show) |
|
-- this function creates the full binary tree of size 2^(n+1) -1 |
makeBinTree 0 = L |
makeBinTree n = N (makeBinTree (n-1)) (makeBinTree (n-1)) |
|
-- this function computes the size of a binary tree |
size L = 1 |
size (N t1 t2) = 1 + size t1 + size t2 |
$ ghci |
|
GHCi, version 7.6.3: http://www.haskell.org/ghc/ :? for help |
Loading package ghc-prim ... linking ... done. |
Loading package integer-gmp ... linking ... done. |
Loading package base ... linking ... done. |
Prelude> load assign-2-tree.hs |
|
Prelude> :load assign-2-tree.hs |
[1 of 1] Compiling Main ( assign-2-tree.hs, interpreted ) |
Ok, modules loaded: Main. |
|
*Main> makeBinTree 3 |
N (N (N L L) (N L L)) (N (N L L) (N L L)) |
|
*Main> let t1 = makeBinTree 3 |
|
*Main> t1 |
N (N (N L L) (N L L)) (N (N L L) (N L L)) |
|
*Main> size t1 |
15 |
BinTree, each internal N node must have two sub trees. Thus there is no way to construct a tree of size 2. If you want a binary tree that can be of any size, then you need to introduce a new constructor N1 to BinTree that allows an internal node with only one subtree. Make this modification to BinTree.
size to account for this modification.
depth that gives the depth of the modified BinTree tree. The depth of a tree of size 1 is 1.
makeABinTree such that makeABinTree s constructs a BinTree of size exactly s and that has minimum possible depth. I.e. a long stringy tree is not allowed. #lang racket |
|
|
(define (transform-if-to-cond code) |
; locates every occurrence of an if expression in code and |
; transforms it into an equivalent cond |
|
; (if c p q) => (cond (c p) (else q )) |
|
(define (trans c p q) |
(list 'cond (list c p) (list 'else q) ) ) |
|
(if (and (list? code) (not (null? code)) (eq? 'if (first code))) |
|
; recursively transform the parts of the if before transforming the if |
(apply trans (map transform-if-to-cond (rest code))) |
|
(if (list? code) |
; recursively transform expressions |
(map transform-if-to-cond code) |
; leaf expression, leave alone |
code) |
)) |
|
(define (transform-let-to-apply code) |
; locates every occurrence of an let expression in code and |
; transforms it into an equivalent lambda applied to the values. |
|
; (let ( (v1 e1) (v2 e2) ... (vn en) ) b1 b2 ... bk ) |
; => |
; ((lambda (v1 v2 ... vn) b1 b2 ... bk) e1 e2 ... en) |
|
; vars: list of variables being defined (v1 v2 ... vn) |
; exprs list of defining expressions (e1 e2 ... en) to evaluate |
; body: list of code inside the let (b1 b2 ... bk) |
|
(define (trans vars exprs body) |
(append (list (append (list 'lambda vars) body)) exprs) |
) |
|
(if (and (list? code) (not (null? code)) (eq? 'let (first code))) |
|
(let ( (vars (map first (second code)) ) |
(exprs (map second (second code)) ) |
(body (rest (rest code)) ) |
) |
; recursively transform |
(trans vars (map transform-let-to-apply exprs) (map transform-let-to-apply body)) |
) |
|
|
(if (list? code) |
; recursively transform expressions |
(map transform-let-to-apply code) |
; leaf expression, leave alone |
code) |
)) |
|
|
(define c1 |
'(if #t |
"c1-true" |
"c1-false" |
)) |
|
(define c2 |
'(if #f |
(if (and #t (if #f #t #f)) |
"c11" |
"c12" |
) |
"c21" |
)) |
|
(define c3 |
'(let ( (x 1) (y (+ 2 3)) (z (if #t 42 -1)) ) (println "let-1") (+ x y z) ) |
) |
|
(define code-1 |
'(let ( (x 1) (y 2) ) |
;(println (list "got" x y)) |
(let ( (z (+ x y)) ) |
;(println (list "z" z)) |
(if (< x y) |
(list "x smaller") |
(list "y smaller") |
) |
) |
)) |
|
; why this does not work is explained in http://docs.racket-lang.org/guide/eval.html |
; the definitions window does not have a namespace by default. |
(define ns (make-base-namespace)) |
|
(define (test1) |
(println c1) |
(println (eval c1 ns)) |
(println (transform-if-to-cond c1)) |
(println (eval (transform-if-to-cond c1) ns)) |
(newline) |
(println c2) |
(println (eval c2 ns)) |
(println (transform-if-to-cond c2)) |
(println (eval (transform-if-to-cond c2) ns)) |
) |
|
;(test1) |
|
; our own println |
; displayln will drop the " " around strings, which makes it difficult to |
; read the transformed code. So we use println instead. |
(define (println s) (print s) (newline)) |
|
(define (test2a) |
(println c3) |
(println (eval c3 ns)) |
(println (transform-let-to-apply c3)) |
(println (eval (transform-let-to-apply c3) ns)) |
(newline) |
(println code-1) |
(println (eval code-1 ns)) |
(println (transform-let-to-apply code-1)) |
(println (eval (transform-let-to-apply code-1) ns)) |
|
) |
|
(define (test-1) |
(newline) |
(println code-1) |
(println (eval code-1)) |
(newline) |
|
; test the if transform |
(define t1 (transform-if-to-cond code-1)) |
(println t1) |
(println (eval t1)) |
(newline) |
|
; test the let transform |
(define t2 (transform-let-to-apply code-1)) |
(println t2) |
(println (eval t2)) |
(newline) |
|
; test the two different composition orders of the transforms |
(define t3 (transform-let-to-apply (transform-if-to-cond code-1))) |
(println t3) |
(println (eval t3)) |
(newline) |
(define t4 (transform-if-to-cond(transform-let-to-apply code-1))) |
(println t4) |
(println (eval t4)) |
) |
-- data types are defined by constructor patterns |
-- Eq equality can be derived from structural equality |
|
-- a binary tree consisting of leaves L or internal nodes N |
data BinTree = L | N1 BinTree | N BinTree BinTree deriving (Eq, Show) |
|
-- this function creates the full binary tree of size 2^(n+1) -1 |
makeBinTree 0 = L |
makeBinTree n = N (makeBinTree (n-1)) (makeBinTree (n-1)) |
|
-- this function computes the size of a binary tree |
size L = 1 |
size (N1 t1) = 1 + size t1 |
size (N t1 t2) = 1 + (size t1) + (size t2) |
|
-- this function computes the depth of a binary tree |
depth L = 1 |
depth (N1 t1) = 1 + (depth t1) |
depth (N t1 t2) = 1 + max (depth t1) (depth t2) |
|
-- makeABinTree creates a binary tree of size s of minimum depth |
-- in mixed prefix/infix form: (quot (s-1) 2) + (rem (s-1) 2) |
-- in pure prefix form: ( (+) (quot (s-1) 2) (rem (s-1) 2)) |
|
makeABinTree :: Integral a => a -> BinTree |
makeABinTree s |
| s <= 1 = L |
| s == 2 = N1 L |
| otherwise = |
N (makeABinTree (sizeLeft s)) (makeABinTree (sizeRight s)) |
where |
sizeLeft :: Integral a => a -> a |
sizeRight :: Integral a => a -> a |
|
sizeLeft s = max 1 ( (s-1) `quot` 2 + (s-1) `rem` 2) |
sizeRight s = max 1 ((s-1) `quot` 2) |
|
|
if expressions. It negates the condition and exchanges the true and false parts, thus preserving the logic but rewriting the expression. #lang racket |
|
(define (modify-if trans code) |
; locates every occurrence of an if expression in code and |
; applies the transform function to it. |
|
(if (and (list? code) (not (null? code)) (eq? 'if (first code))) |
; found an (if ...) expr, transform the parts |
(trans (second code) (third code) (fourth code) ) |
|
; not an if, so if a ( ) then transform each of the parts |
; otherwise leave alone |
(if (list? code) |
(map (lambda (c) (modify-if trans c)) code) |
code) |
)) |
|
|
(define c1 |
'(if true |
"c1-true" |
"c1-false" |
)) |
|
(define c2 |
'(if false |
(if (and true (if false true false)) |
"c11" |
"c12" |
) |
"c21" |
)) |
|
; transform (if c p q) into (if (not c) q p) |
(define (trans-1 c p q) |
(list 'if (list 'not c) q p) |
) |
|
(define (test1) |
(displayln (eval c1)) |
(displayln (modify-if trans-1 c1)) |
(displayln (eval (modify-if trans-1 c1))) |
(newline) |
(displayln (modify-if trans-1 c2)) |
) |
|
; (test1) |
#lang racket |
|
(define (modify-if trans code) |
; locates every occurrence of an if expression in code and |
; applies the transform function to it. |
|
; remember the trans function |
(define (mf c) (modify-if trans c)) |
|
(if (and (list? code) (not (null? code)) (eq? 'if (first code))) |
|
; recursivley transform the parts of the if before transforming the if |
(apply trans (map mf (rest code))) |
; Note above is better than |
; (trans (mf (second code)) (mf (third code)) (mf (fourth code))) |
|
(if (list? code) |
; recursively transform expressions |
(map mf code) |
; leaf expression, leave alone |
code) |
)) |
|
|
(define c1 |
'(if true |
"c1-true" |
"c1-false" |
)) |
|
(define c2 |
'(if false |
(if (and true (if false true false)) |
"c11" |
"c12" |
) |
"c21" |
)) |
|
(define (wrap-not x) |
(list 'not x) ) |
|
; transform (if c p q) into (if (not c) q p) |
(define (trans-1 c p q) |
(list 'if (wrap-not c) q p) |
) |
|
(define (test1) |
(displayln c1) |
;(displayln (eval c1)) |
(displayln (modify-if trans-1 c1)) |
(displayln (eval (modify-if trans-1 c1))) |
(newline) |
(displayln c2) |
(displayln (modify-if trans-1 c2)) |
) |
|
; (test1) |
if into a cond. #lang racket |
|
; a e-tree represents the kinds of program structures that we want to |
; manipulate. Defined recursively: |
|
; atom := a single primative unstructured element, like a number 42 |
; or symbol 'x |
|
; e-tree := atom | ( e-tree * ) |
; that is, an e-tree is an atom, or a list of 0 or more e-trees |
|
; a path in an e-tree is a list of indexes that navigate to a |
; sub-component of the e-tree. Navigation via a path is defined |
; by the following function, modelled after list-ref |
|
(define (e-tree-ref e-tree path) |
(if (null? path) e-tree |
(e-tree-ref (list-ref e-tree (first path)) (rest path))) |
) |
|
; examples: |
(define (test-e-tree-ref) |
(define t1 '(a (b c) (d (e f) (g h (i j))))) |
|
(map displayln (list |
t1 |
" " |
(e-tree-ref t1 '()) |
(e-tree-ref t1 '(0)) |
(e-tree-ref t1 '(2)) |
(e-tree-ref t1 '(2 1 1)) |
(e-tree-ref t1 '(2 2 2 1)) |
|
)) |
(void) |
) |
|
; given an e-tree and a path, we would like to edit the sub e-tree |
; at the endpoint of the path. |
|
; first we need a primative for editing an element a list |
|
; given editing function edit-fn, list l, and position n inside l, |
; return a list |
; which is l with (list-ref l n) replaced with (fn (list-ref l n)) |
|
(define (list-edit edit-fn l n) |
(let-values |
( [ (a b) (split-at l n) ] ) ; note capture a 2 value result |
|
(if (null? b) |
(error (format "edit-list n of ~a >= length l of ~a" n l)) |
(append a (list (edit-fn (first b))) (rest b)) |
) |
) |
) |
|
; given tree e-tree, and path edit-path, return an e-tree |
; which is the original with the subtree t reached by edit-path |
; repaced by (edit-fn t) |
|
(define (e-tree-edit edit-fn e-tree edit-path) |
(cond |
; empty path edits entire e-tree |
[ (null? edit-path) (edit-fn e-tree) ] |
|
; for longer path, replace the (first edit-path) position in e-tree with the |
; result of recursing down the sub e-tree at that position using the rest |
; of the edit path |
|
[ else (list-edit |
(lambda (sub-e-tree) (e-tree-edit edit-fn sub-e-tree (rest edit-path))) |
e-tree |
(first edit-path)) |
] |
)) |
|
(define (test-e-tree-edit) |
(define t1 '(a (b c) (d (e f) (g h (i j))))) |
|
(map displayln (list |
t1 |
" " |
(e-tree-edit (lambda (s) (rest s)) t1 '()) |
(e-tree-edit (lambda (s) 'f1) t1 '(0)) |
(e-tree-edit (lambda (s) (list (second s) (first s))) t1 '(1)) |
(e-tree-edit (lambda (s) (list 'f2 s) ) t1 '(2 1 1)) |
(e-tree-edit (lambda (s) (list 'lambda (list (e-tree-ref s '(1))) s) ) t1 '(2 2 2)) |
|
)) |
(void) |
) |
|
; perform the same edit at multiple points in the tree. You need |
; to be careful if the paths intersect in the sense that the endpoint |
; of one path is in a sub e-tree below the endpoint of another path. |
|
(define (e-tree-edit-many edit-fn in-tree edit-paths) |
(foldl (lambda (path cur-e-tree) (e-tree-edit edit-fn cur-e-tree path)) |
in-tree edit-paths) |
) |
|
(define (test-e-tree-edit-many) |
(define t1 '(a (b c) (d (e f) (g h (i j))))) |
|
(map displayln (list |
t1 |
" " |
(e-tree-edit-many (lambda (s) 'f1) t1 '( (0) (1 1))) |
(e-tree-edit-many (lambda (s) (list 'f2 s) ) t1 '( (2 1 1) (2 2 2)) ) |
|
)) |
(void) |
) |
|
; find paths to all instances of term in expression expr |
; A path is a list of 0-origin indexes into the expression tree |
; indicating how to navigate down to the root to locate the term |
|
(define (e-tree-find-paths target-e-tree e-tree [paths '()] [rootpath '()] ) |
(cond |
; are we at a matching term? |
[ (equal? target-e-tree e-tree) (append paths (list rootpath) ) ] |
|
; ok, no match, no recursion since e-tree empty |
[ (null? e-tree) paths ] |
|
; recurse into sub e-trees accumulating paths to matches |
[ (list? e-tree) |
(second |
(foldl |
; (e s) is current sub e-tree e, prior state s |
; s state is (n p) where |
; n is position of e in containing e-tree, |
; p collection of paths found so far |
(lambda (e s) |
(let ( |
; pull apart state |
(n (first s)) |
(p (second s)) |
) |
; new state - next position, add newly found paths |
(list |
(add1 n) |
(e-tree-find-paths target-e-tree e p (append rootpath (list n))) |
) |
) |
) |
(list 0 paths) e-tree |
) |
) ] |
|
[ else paths ] |
) |
) |
|
(define (test-e-tree-find-paths) |
(define t1 '(a (b a) (b (a f) (f h (b a))))) |
|
(map displayln (list |
t1 |
" " |
(e-tree-find-paths 'a t1) |
(e-tree-find-paths 'b t1) |
(e-tree-find-paths '(b a) t1) |
|
|
(e-tree-edit-many (lambda (s) 'delta) t1 (e-tree-find-paths 'a t1)) |
(e-tree-edit-many (lambda (s) 'delta) t1 (e-tree-find-paths '(b a) t1) ) |
)) |
(void) |
) |
|
; NOTE: write a version of e-tree-find-paths that has a test predicate |
; other than equal? |
|
; Program transformations |
|
; Here is an attempt to extract out the continuation for a term |
; inside a e-tree. |
|
; assuming that e-tree contains non special forms, then extract the |
; continuation context about the term at point path. |
|
|
(define (extract-continuation-1 e-tree path) |
(cond |
; if the path has length 1, we are at a term ( ... ) |
|
; in first position of list, it is a fn call |
[ (equal? path '(0)) '(lambda (x) x) ] |
|
; in other positions it is a term to evaluate then pass up to |
; enclosing expressions |
[ (null? (rest path)) |
(let ( [ var (gensym 'v- ) ] ) |
(list 'lambda (list var) (list-edit (lambda (s) var) e-tree (first path)) ) |
)] |
|
; the path descends, so we need to capture the context around and |
; descend further |
|
[ else |
(let ( [ var (gensym 'v- ) ] ) |
(list 'lambda (list var) (e-tree-edit (lambda (s) var) e-tree path)) |
)] |
|
|
)) |
|
(define (f-test x y) |
(if (null? x) y (cons (first x) (f-test (rest x) (cons (first x) y))) ) |
) |
|
; run this test by doing |
; (eval (test-convert)) |
; (test-cc '(a b) '(1 2)) |
; you should get: '(a b b a 1 2) |
; |
(define (test-convert) |
(define e1 ' |
(define (f x y) |
(if (null? x) y (cons (first x) (f (rest x) (cons (first x) y))) ) |
)) |
|
(eval (convert-to-cc-style e1 'test-cc)) |
|
) |
|
; converts a cannonical recursive definition into continuation- |
; passing style. |
; the function MUST have the form |
; (define (f ... ) |
; (if (basecase? ...) base-expression recursion-expression) ) |
; |
(define (convert-to-cc-style defn new-fn-name) |
|
(or (eq? 'if (e-tree-ref defn '(2 0))) |
(error (format "not a if-style definition ~a" defn))) |
|
; get the parts of the definition |
(let ( |
[ args (e-tree-ref defn '(1)) ] |
[ fn-name (e-tree-ref defn '(1 0)) ] |
[ base-test (e-tree-ref defn '(2 1)) ] |
[ base-case (e-tree-ref defn '(2 2)) ] |
[ recursion (e-tree-ref defn '(2 3)) ] |
) |
|
|
; locate the recursive call in the recursion |
(define p1 (e-tree-find-paths fn-name recursion)) |
|
; make sure only one call |
(or (= 1 (length p1)) |
(error (format "not a single recursion in ~a" defn) ) ) |
|
; move up to expression that needs result of recursive call |
; and make that the continuation |
(define cc1 (list-edit |
(lambda (s) (list 'cc s)) |
(extract-continuation-1 recursion (drop-right (first p1) 1)) |
2)) |
(displayln cc1) |
|
; insert continuation into the original recursion |
(define new-rec (append (e-tree-ref recursion (drop-right (first p1) 1)) (list cc1))) |
|
(displayln new-rec) |
|
; create the default continuation |
|
; rewrite defintion to be in continuation passing style |
(define new-def |
(list 'define (append (second defn) '( (cc (lambda (x) x)))) |
(list 'if base-test (list 'cc base-case) new-rec) ) |
) |
|
|
(displayln new-def) |
|
; rename the original function to the new name |
(define final-def |
(e-tree-edit-many (lambda (s) new-fn-name) new-def (e-tree-find-paths fn-name new-def)) ) |
|
(displayln final-def) |
|
; then eval the final result to create the new function. |
|
final-def |
|
)) |
|
|
8. Week 6 - Feb 10 CMPUT 325 Schedule / Version 2.31 2014-04-04 |