diff options
| -rw-r--r-- | HW01.rkt | 54 | ||||
| -rw-r--r-- | HW02.rkt | 35 | ||||
| -rw-r--r-- | HW03.rkt | 42 | ||||
| -rw-r--r-- | HW05a.scm | 48 | ||||
| -rw-r--r-- | HW05a_adt.scm | 61 | ||||
| -rw-r--r-- | HW05a_rib.scm | 50 | ||||
| -rw-r--r-- | hw02.scm | 156 | ||||
| -rw-r--r-- | hw03.scm | 133 | ||||
| -rw-r--r-- | hw04_bintree.scm | 191 | ||||
| -rw-r--r-- | hw04_path.scm | 21 | ||||
| -rw-r--r-- | hw05_arith_scanner.scm | 38 | ||||
| -rw-r--r-- | hw06.zip | bin | 0 -> 2855 bytes | |||
| -rw-r--r-- | hw06/hw06_alpha.scm | 52 | ||||
| -rw-r--r-- | hw06/hw06_combinators.scm | 21 | ||||
| -rw-r--r-- | hw06/hw06_eta.scm | 50 | ||||
| -rw-r--r-- | hw06_alpha.scm | 52 | ||||
| -rw-r--r-- | hw06_combinators.scm | 21 | ||||
| -rw-r--r-- | hw06_eta.scm | 50 | ||||
| -rw-r--r-- | hw07.scm | 278 | ||||
| -rw-r--r-- | hw08.rkt | 403 | ||||
| -rw-r--r-- | hw08.scm | 394 |
21 files changed, 2150 insertions, 0 deletions
diff --git a/HW01.rkt b/HW01.rkt new file mode 100644 index 0000000..4885c33 --- /dev/null +++ b/HW01.rkt @@ -0,0 +1,54 @@ +#lang scheme + +;; circlearea +;; +;; find the area of a circle with radius r +(define + (circlearea r) + (* 3.142 (expt r 2)) +) + +;; between? +;; +;; check whether a is between x and y +(define + (between? a x y) + (if + (or + (and (< y a) (> x a)) ;; y < a < x + (and (> y a) (< x a)) ;; x < a < y + ) + #t + #f + ) +) + +;; shorter +;; +;; returns the list with fewer elements +(define + (shorter a b) + (if + (< (length a) (length b)) + a + b + ) +) + +;; righttri? +;; +;; checks whether 3 integers can be the side lengths +;; of a right triangle. +(define + (righttri? a b c) + (cond + ;; a is largest (b^2 + c^2 = a^2) + [ (and (> a b) (> a c)) (= (+ (expt b 2) (expt c 2)) (expt a 2)) ] + + ;; b is largest (a^2 + c^2 = b^2) + [ (and (> b a) (> b c)) (= (+ (expt a 2) (expt c 2)) (expt b 2)) ] + + ;; c is largest (a^2 + b^2 = c^2) + [ (and (> c a) (> c b)) (= (+ (expt a 2) (expt b 2)) (expt c 2)) ] + ) +)
\ No newline at end of file diff --git a/HW02.rkt b/HW02.rkt new file mode 100644 index 0000000..5e26219 --- /dev/null +++ b/HW02.rkt @@ -0,0 +1,35 @@ +#lang scheme + +;; invert +;; +;; takes a list of 2-lists and returns a list with each +;; 2-list reversed +(define + (invert list) + list +) + +;; vector-index +;; +;; returns the zero-based index of the first occurrence of +;; a parameter in a vector, or -1 if there is no occurrence +(define + (vector-index needle haystack) + haystack +) + +;; count-occurrences +;; +;; returns the number of occurrences of a parameter in a list +(define + (count-occurrences needle haystack) + haystack +) + +;; compose23 +;; +;; +(define + (compose23 a b c) + (a (b c)) +)
\ No newline at end of file diff --git a/HW03.rkt b/HW03.rkt new file mode 100644 index 0000000..b6310a1 --- /dev/null +++ b/HW03.rkt @@ -0,0 +1,42 @@ +#lang scheme + +; ------------------------------------------------------------ +; PROGRAM NAME: HW02.rkt +; +; DESCRIPTION: Second homework assignment for CSI310 +; +; AUTHOR: Ben Burwell ; CS 310: Theory of Programming Languages +; Muhlenberg College +; + +;; --------- +;; NAME: invert +;; DESC: takes a list of 2-lists (lists of length 2), and returns a list with each 2-list reversed. + +(define invert + (lambda (l) + (map swap l))) + +(define swap + (lambda (l) + (if (= 2 (length l)) + (list (cadr l) (car l)) + (display "Error")))) + +;; TEST +(invert '((2 1) (4 3) (6 5))) ;; should return (1 2) (3 4) (5 6) + + +;; --------- +;; NAME: compose23 +;; DESC: that takes 1, 2, or 3 procedures and composes them, as specified by the equation: +;; (compose f g h) = (compose f (compose g h)) + +(define compose23 + (lambda funcs + (if (= (length funcs) 1) + (car funcs) + (if (= (length funcs) 2) + ((car funcs) (cadr funcs)) + (if (= (length funcs) 3) + ((car funcs (cadr funcs) (caddr funcs))))))))
\ No newline at end of file diff --git a/HW05a.scm b/HW05a.scm new file mode 100644 index 0000000..869ceec --- /dev/null +++ b/HW05a.scm @@ -0,0 +1,48 @@ +#lang eopl + +;; HW05a - Environments +;; Part 1: Procedural Implementation +;; +;; CSI-310 Programming Languages +;; Due: 2013-02-25 +;; Name: Ben Burwell + +;; empty environment +(define empty-env + (lambda () + (lambda (sym) (eopl:error 'apply-env "No binding for ~s" sym)))) + +;; helpers +(define in-sym-list + (lambda (item lst) + (cond + [ (equal? (length lst) 0) #f ] + [ (equal? (caar lst) item) #t ] + [ else (in-sym-list item (cdr lst)) ] + ))) + +(define get-val + (lambda (sym lst) + (cond + [ (equal? (length lst) 0) 'err ] + [ (equal? (caar lst) sym) (cadar lst) ] + [ else (get-val sym (cdr lst)) ] + ))) + +;; extend environment +(define extend-env + (lambda (sym-val-lst env) + (lambda (sym) + (if (in-sym-list sym sym-val-lst) + (get-val sym sym-val-lst) + (apply-env env sym))))) + +;; apply environment +(define apply-env + (lambda (env sym) + (env sym))) + +;; tests +(apply-env (extend-env '((a 5) (b 9)) (extend-env '((a 1) (b 2) (c 3)) (empty-env))) 'a) +(apply-env (extend-env '((a 5) (b 9)) (extend-env '((a 1) (b 2) (c 3)) (empty-env))) 'b) +(apply-env (extend-env '((a 5) (b 9)) (extend-env '((a 1) (b 2) (c 3)) (empty-env))) 'c)
\ No newline at end of file diff --git a/HW05a_adt.scm b/HW05a_adt.scm new file mode 100644 index 0000000..5f8bd34 --- /dev/null +++ b/HW05a_adt.scm @@ -0,0 +1,61 @@ +#lang eopl + +;; HW05a - Environments +;; Part 2: Abstract Syntax Tree +;; +;; CSI-310 Programming Languages +;; Due: 2013-02-25 +;; Name: Ben Burwell + + +;; helpers and data types +(define scheme-value? + (lambda (a) #t)) + +(define-datatype env env? + (empty-env-record) + (extended-env-record + (defs (list-of (list-of scheme-value?))) + (prev-env env?))) + +;; some basics +(define empty-env + (lambda () + (empty-env-record))) + +(define extend-env + (lambda (defs prev-env) + (extended-env-record defs prev-env))) + +;; more helpers +(define def-exists? + (lambda (sym defs) + (cond + [ (equal? (length defs) 0) #f ] + [ (equal? (caar defs) sym) #t ] + [ else (def-exists? sym (cdr defs)) ] + ))) + +(define get-def + (lambda (sym defs) + (cond + [ (equal? (length defs) 0) 'error ] + [ (equal? (caar defs) sym) (cadar defs) ] + [ else (get-def sym (cdr defs)) ] + ))) + +;; now the fun stuff +(define apply-env + (lambda (this-env sym) + (cases env this-env + (empty-env-record + () + (eopl:error 'apply-env "No binding for ~s" sym)) + (extended-env-record + (defs prev-env) + (if (def-exists? sym defs) + (get-def sym defs) + (apply-env prev-env sym)))))) + +;; tests +(apply-env (extend-env '((a 4) (b 5)) (extend-env '((a 1) (b 2) (c 3)) (empty-env))) 'a)
\ No newline at end of file diff --git a/HW05a_rib.scm b/HW05a_rib.scm new file mode 100644 index 0000000..e057a8e --- /dev/null +++ b/HW05a_rib.scm @@ -0,0 +1,50 @@ +#lang eopl + +;; HW05a - Environments +;; Part 3: Rib-Cage Implementation +;; +;; CSI-310 Programming Languages +;; Due: 2013-02-25 +;; Name: Ben Burwell + +;; empty environment +(define empty-env + (lambda () '(()) + )) + +;; extend environment +(define extend-env + (lambda (sym-val-lst env) + (cons sym-val-lst env))) + +;; helper +(define in-sym-list? + (lambda (item lst) + (cond + [ (equal? (length lst) 0) #f ] + [ (equal? (caar lst) item) #t ] + [ else (in-sym-list? item (cdr lst)) ] + ))) + +(define get-val + (lambda (sym lst) + (cond + [ (equal? (length lst) 0) 'err ] + [ (equal? (caar lst) sym) (cadar lst) ] + [ else (get-val sym (cdr lst)) ] + ))) + +;; apply environment +(define apply-env + (lambda (env sym) + (cond + [ (in-sym-list? sym (car env)) (get-val sym (car env)) ] + [ (equal? (length (car env)) 0) (eopl:error "No binding for" sym) ] + [ else (apply-env (cdr env) sym) ] + ))) + + +;; tests +(apply-env (extend-env '((a 5) (b 9)) (extend-env '((a 1) (b 2) (c 3)) (empty-env))) 'a) +(apply-env (extend-env '((a 5) (b 9)) (extend-env '((a 1) (b 2) (c 3)) (empty-env))) 'b) +(apply-env (extend-env '((a 5) (b 9)) (extend-env '((a 1) (b 2) (c 3)) (empty-env))) 'c)
\ No newline at end of file diff --git a/hw02.scm b/hw02.scm new file mode 100644 index 0000000..9f551a4 --- /dev/null +++ b/hw02.scm @@ -0,0 +1,156 @@ +#lang scheme + +;; PROGRAM NAME: hw02.rkt +;; DESCRIPTION: Homework 2 for CSI 310 +;; AUTHOR: Ben Burwell +;; HISTORY: Turned in 2013-01-29 +;; NOTES: When this program runs, a series of expected and +;; actual results will print out. Compare them to +;; ensure the code functions properly. + +;; ============ PROCEDURE ============ +;; NAME: invert +;; +;; DESC: +;; takes a list of 2-lists and inverts each of the lists +;; hence, the list +;; ((2 1) (4 3) (6 5)) +;; will become +;; ((1 2) (3 4) (5 6)) + +(define invert + (λ (lst) + (cond + [ (null? lst) null ] + [ (not (list? lst)) (display "Invalid Parameters") ] + [ (null? (cdr lst)) (list (invert-reverse (car lst))) ] + [ else (append (list (invert-reverse (car lst))) (invert (cdr lst))) ] ))) + +;; a helper function that reverses a 2-list +;; PRECONDITION: lst is a list of the form (a b) +;; POSTCONDITION: lst is a list of the form (b a) +;; ERROR: lst is not a list with 2 elements +(define invert-reverse + (λ (lst) + (cond + [ (null? lst) null ] + [ (not (list? lst)) (display "Invalid Parameters") ] + [ (not (equal? (length lst) 2)) (display "Invalid Parameters") ] + [ else (list (cadr lst) (car lst)) ] ))) + +;; ============ TEST CODE ============ +(newline) +(display "Testing (invert) =========================================") +(newline) + +(display "Expected output: () ") +(invert '()) + +(display "Expected output: ((1 2)) ") +(invert '((2 1))) + +(display "Expected output: ((1 2) (3 4) (5 6)) ") +(invert '((2 1) (4 3) (6 5))) + + +;; ============ PROCEDURE ============ +;; NAME: vector-index +;; +;; DESC: +;; returns the zero-based index of the first +;; occurence of a parameter in a vector, or +;; -1 if there is no occurrence. +(define vector-index + (λ (needle haystack) + (cond + [ (null? needle) (display "Invalid Parameters") ] + [ (vector? haystack) (list-index needle (vector->list haystack)) ] + [ else (display "Invalid Parameters") ] ))) + +;; a helper function +;; PRECONDITION: haystack is a non-nested list (e.g. the result of vector->list) +(define list-index + (λ (needle haystack) + (if (null? haystack) + -1 + (if (equal? (car haystack) needle) + 0 + (if (equal? (list-index needle (cdr haystack)) -1) + -1 + (+ 1 (list-index needle (cdr haystack)))))))) + +;; ============ TEST CODE ============ +(newline) +(display "Testing (vector-index) ===================================") +(newline) + +(display "Expected output: 2 ") +(vector-index 3 #(1 2 3 4 5 6 7 8 9)) + +(display "Expected output: -1 ") +(vector-index 4 #(1 2 3)) + +(display "Expected output: -1 ") +(vector-index 3 #()) + + +;; ============ PROCEDURE ============ +;; NAME: count-occurrences +;; +;; DESC: +;; counts the occurrences of needle in haystack +(define count-occurrences + (λ (needle haystack) + (cond + [ (null? needle) (display "Error: nothing to search for") ] + [ (null? haystack) 0 ] + [ (list? (car haystack)) (+ (count-occurrences needle (car haystack)) (count-occurrences needle (cdr haystack))) ] + [ (equal? (car haystack) needle) (+ 1 (count-occurrences needle (cdr haystack))) ] + [ else (count-occurrences needle (cdr haystack)) ] ))) + +;; ============ TEST CODE ============ +(newline) +(display "Testing (count-occurrences) ==============================") +(newline) + +(display "Expected output: 10 ") +(count-occurrences 'a '(a b a c d (((((((((a))))))))) e f a b a a (d e) (a) c (a (a (a))))) + +(display "Expected output: 0 ") +(count-occurrences 'a '()) + +(display "Expected output: 1 ") +(count-occurrences 'a '(a)) + +;; ============ PROCEDURE ============ +;; NAME: compose +;; +;; DESC: +;; takes 1, 2, or 3 procedures and composes them, as specified by the equation: +;; (compose f g h) = (compose f (compose g h)) +(define compose + (λ funcs + (cond + [ (equal? (length funcs) 1) (car funcs) ] + [ (equal? (length funcs) 2) (λ (x) ((car funcs) ((cadr funcs) x))) ] + [ (equal? (length funcs) 3) (λ (x) ((car funcs) ((cadr funcs) ((caddr funcs) x)))) ] + [ else (display "Invalid parameters") ] ))) + +;; ============ TEST CODE ============ +(newline) +(display "Testing (compose) ========================================") +(newline) + +(display "Expected output: 1 ") +((compose car cdr cdr) '(0 2 1 3)) + +(display "Expected output: 1 ") +((compose car) '(1 2 3 4)) + +(display "Expected output: 1 ") +((compose car cdr) '(0 1 2 3)) + +(display "Expected output: 1 ") +((compose - -) 1) + +;; =========== END OF FILE ===========
\ No newline at end of file diff --git a/hw03.scm b/hw03.scm new file mode 100644 index 0000000..eced079 --- /dev/null +++ b/hw03.scm @@ -0,0 +1,133 @@ +#lang scheme +;; NAME: hw03.scm +;; AUTHOR: Ben Burwell +;; DESC: CSI310 - Programming Languages - Homework 3 +;; HISTORY: Created 2013-01-31 + +;; ========== PROCEDURE ========== +;; NAME: merge +;; DESC: returns a sorted list of all of the numbers in +;; the two parameters +(define merge + (λ (lon1 lon2) + (qsort (append lon1 lon2)) + )) + +;; helper function +;; this is an implementation of quicksort +(define qsp-helper + (λ (all check less more) + (cond + [ (null? all) (cons less (cons check (cons more '()))) ] + [ else (let ((x (car all))) + (if (<= x check) + (qsp-helper (cdr all) check (cons x less) more) + (qsp-helper (cdr all) check less (cons x more)))) ] + ))) + +(define qspartition + (λ (lst) + (qsp-helper (cdr lst) (car lst) '() '()) + )) + +(define qsort + (λ (lst) + (cond + [ (null? lst) lst ] + [ else (let ((list1 (qspartition lst))) + (append + (qsort (car list1)) + (cons + (cadr list1) + (qsort (caddr list1))) + )) ] + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (merge) ==========================================================================") +(newline) + +(display "Expected output: (1 2 3 4 5 6) ") +(merge '(1 3 5) '(2 4 6)) + +(display "Expected output: (1 2 2 3) ") +(merge '(1 2) '(2 3)) + +;; ========== PROCEDURE ========== +;; NAME: car&cdr +;; DESC: returns the code for a procedure +;; that takes a list with the same structure +;; as slst and returns the value in the +;; same position as the leftmost occurrence +;; of s in slst. If s does not occur in +;; slst then errval is returned. +(define car&cdr-help + (λ (s slst errval var) + (cond + [ (null? slst) errval ] + [ (equal? (car slst) s) (list 'λ '(lst) (list 'car var)) ] + [ (and (list? (car slst)) (car&cdr-help s (car slst) errval (list 'car var))) ] + [ (car&cdr-help s (cdr slst) errval (list 'cdr var)) ] + [ else errval ] + ))) + +(define car&cdr + (λ (s slst errval) + (cond + [ (not (list? slst)) (display "Not a list") ] + [ (list? s) (display "Cannot find a list") ] + [ else (car&cdr-help s slst errval 'lst) ] + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (car&cdr) ========================================================================") +(newline) + +(display "Expected output: (λ (lst) (car (cdr (cdr lst)))) ") +(car&cdr 'c '(a b c d) 'fail) + +(display "Expected output: pass ") +(car&cdr 'a '(b c d) 'pass) + + + + +;; ========== PROCEDURE ========== +;; NAME: if->cond +;; DESC: that takes an if expression and +;; returns the corresponding cond +;; expression. + +(define if->cond + (λ (condlist) + (cond + [ (equal? 3 (length condlist)) (list 'cond (list 'else (list 'if (cadr condlist) (caddr condlist)))) ] + [ (list? (cadddr condlist)) (cons 'cond (ifcondhelper condlist)) ] + [ else (list 'cond (list (cadr condlist) (caddr condlist)) (list 'else (cadddr condlist))) ] + ))) + +(define ifcondhelper + (λ (condlist) + (cond + [ (list? (cadddr condlist)) (cons (list (cadr condlist) (caddr condlist)) (ifcondhelper (cadddr condlist))) ] + [ else (list (list (cadr condlist) (caddr condlist)) (list 'else (cadddr condlist))) ] + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (if->cond) =======================================================================") +(newline) + +(display "Expected output: (cond (else (if a b))) ") +(if->cond '(if a b)) + +(display "Expected output: (cond (a b) (else c)) ") +(if->cond '(if a b c)) + +(display "Expected output: (cond (a b) (c d) (else e)) ") +(if->cond '(if a b (if c d e))) + +(display "Expected output: (cond (a (if b c d)) (e f) (else g)) ") +(if->cond '(if a (if b c d) (if e f g)))
\ No newline at end of file diff --git a/hw04_bintree.scm b/hw04_bintree.scm new file mode 100644 index 0000000..dbff02c --- /dev/null +++ b/hw04_bintree.scm @@ -0,0 +1,191 @@ +#lang scheme + +;; NAME: hw04_bintree.scm +;; AUTHOR: Ben Burwell +;; DESC: CSI310 - Programming Languages - Homework 4 - Binary Tree +;; HISTORY: Created 2013-02-11 + +;; ========== PROCEDURE ========== +;; NAME: tree? +;; DESC: takes a parameter and returns true if it is a tree +;; and false otherwise +(define tree? + (λ (arg) + ;; a tree has the following properties: + (and + + ;; it is a list + (list? arg) + + ;; it has three elements + (equal? (length arg) 3) + + ;; its first element is a number + (number? (car arg)) + + ;; its second element has one of the following: + (or + + ;; it is an empty list... + (and (list? (cadr arg)) (equal? (length (cadr arg)) 0)) + + ;; ...or it is a tree + (tree? (cadr arg))) + + ;; its third element also has one of the above conditions + (or + (and (list? (caddr arg)) (equal? (length (caddr arg)) 0)) + (tree? (caddr arg))) + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (tree?) ==========================================================================") +(newline) + +(display "Expected output: #t ") +(tree? '(1 () ())) + +(display "Expected output: #t ") +(tree? '(5 (2 () ()) ())) + +(display "Expected output: #f ") +(tree? '()) + +(display "Expected output: #f ") +(tree? 1) + +(display "Expected output: #t ") +(tree? '( 14 (7 () (12 () ())) (26 (20 (17 () ()) ()) (31 () ())))) + + + + + +;; ========== PROCEDURE ========== +;; NAME: make-tree +;; DESC: makes a tree from three parameters +(define make-tree + (λ (val lc rc) + (cond + [ (and (tree? lc) (tree? rc)) (list val lc rc) ] + [ (tree? lc) (list val lc '()) ] + [ (tree? rc) (list val '() rc) ] + [ else (list val '() '()) ] + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (make-tree) ======================================================================") +(newline) + +(display "Expected output: (1 () ()) ") +(make-tree 1 '() '()) + +(display "Expected output: (5 (4 (3 (2 (1 () ()) ()) ()) ()) ()) ") +(make-tree 5 (make-tree 4 (make-tree 3 (make-tree 2 (make-tree 1 '() '()) '()) '()) '()) '()) + + +;; ========== PROCEDURE ========== +;; NAME: get-value +;; DESC: returns the value of the root element of the +;; tree parameter, not-a-tree if the argument is +;; not a tree +(define get-value + (λ (tree) + (if (tree? tree) + (car tree) + 'not-a-tree + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (get-value) ======================================================================") +(newline) + +(display "Expected output: 1 ") +(get-value (make-tree 1 '() '())) + +(display "Expected output: 5 ") +(get-value (make-tree 5 (make-tree 4 (make-tree 3 (make-tree 2 (make-tree 1 '() '()) '()) '()) '()) '())) + +;; ========== PROCEDURE ========== +;; NAME: get-left +;; DESC: returns the left child of the tree parameter +;; or not-a-tree if the parameter is not a tree +(define get-left + (λ (tree) + (if (tree? tree) + (cadr tree) + 'not-a-tree + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (get-left) =======================================================================") +(newline) + +(display "Expected output: (1 () ()) ") +(get-left (make-tree 5 (make-tree 1 '() '()) '())) + +;; ========== PROCEDURE ========== +;; NAME: get-right +;; DESC: returns the right child of the tree parameter +;; or not-a-tree if the parameter is not a tree +(define get-right + (λ (tree) + (if (tree? tree) + (caddr tree) + 'not-a-tree + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (get-right) ======================================================================") +(newline) + +(display "Expected output: (1 () ()) ") +(get-right (make-tree 5 '() (make-tree 1 '() '()))) + +;; ========== HELP FUNC ========== +;; takes a number to find in a bst as well as a path to append to +(define path-helper + (λ (n bst pth) + (cond + + ;; we have found the path + [ (equal? (get-value bst) n) pth ] + + ;; the element is not in the tree, return not-found + [ (and (not (tree? (get-left bst))) (not (tree? (get-right bst)))) 'not-found ] + + ;; n < value, we must go left + [ (< n (get-value bst)) (cons 'left (path-helper n (get-left bst) pth)) ] + + ;; n > value, we must go right + [ (> n (get-value bst)) (cons 'right (path-helper n (get-right bst) pth)) ] + ))) + +;; ========== PROCEDURE ========== +;; NAME: path +;; DESC: takes a number and a binary search tree in which +;; to find it and returns a list containing the +;; appropriate "left"s and "right"s to navigate from +;; the root of the tree to the element +;; +;; returns not-found if the needle is not in the +;; haystack. +(define path + (λ (n bst) + (cond + [ (not (tree? bst)) 'not-a-tree ] + [ else (path-helper n bst '()) ] + ))) + +;; ========== TEST CODE ========== +(newline) +(display "Testing (path) ===========================================================================") +(newline) + +(display "Expected output: (right left left) ") +(path 17 '( 14 (7 () (12 () ())) (26 (20 (17 () ()) ()) (31 () ()))))
\ No newline at end of file diff --git a/hw04_path.scm b/hw04_path.scm new file mode 100644 index 0000000..4d404fb --- /dev/null +++ b/hw04_path.scm @@ -0,0 +1,21 @@ +#lang scheme + +;; NAME: hw04_bintree.scm +;; AUTHOR: Ben Burwell +;; DESC: CSI310 - Programming Languages - Homework 4 - Binary Tree +;; HISTORY: Created 2013-02-11 + +(define path-helper + (λ (n bst pth) + [ (equal? (get-value bst) n) pth ] + [ (< n (get-value bst)) (cons 'left (path-helper n (get-left bst))) ] + [ (> n (get-value bst)) (cons 'right (path-helper n (get-right bst))) ] + )) + + +(define path + (λ (n bst) + (cond + [ (not (tree? bst)) 'not-a-tree ] + [ else (path-helper n bst '()) ] + )))
\ No newline at end of file diff --git a/hw05_arith_scanner.scm b/hw05_arith_scanner.scm new file mode 100644 index 0000000..f15833f --- /dev/null +++ b/hw05_arith_scanner.scm @@ -0,0 +1,38 @@ +#lang eopl + +;; <arith-expr> ::== <arith-term> { <add-op> <arith-term> }* +;; <arith-term> ::== <arith-factor> { <mult-op> <arith-factor> }* +;; <arith-factor> ::== <number> +;; <arith-factor> ::== ( <arith-expr> ) +;; <add-op> ::== + | - +;; <mult-op> ::== * | / + +(define arith-scanner + '( + (add-op (or "+" "-") symbol) + (mult-op (or "*" "/") symbol) + (number (digit (arbno digit)) number) + )) + +(define arith-grammar + '( + (expression (number) arith-factor) + ;(expression (number add-op number) arith-factor) + ;(expression (expression add-op expression) arith-factor) + )) + +(sllgen:make-define-datatypes arith-scanner arith-grammar) + +(define list-the-datatypes + (lambda () + (sllgen:list-define-datatypes arith-scanner arith-grammar))) + +(define just-scan + (sllgen:make-string-scanner arith-scanner '())) + +(define scan&parse + (sllgen:make-string-parser arith-scanner arith-grammar) ) + +(define read-eval-print + (sllgen:make-rep-loop "--> " stmt-evaluator + (sllgen:make-stream-parser arith-scanner arith-grammar) ))
\ No newline at end of file diff --git a/hw06.zip b/hw06.zip Binary files differnew file mode 100644 index 0000000..81f5916 --- /dev/null +++ b/hw06.zip diff --git a/hw06/hw06_alpha.scm b/hw06/hw06_alpha.scm new file mode 100644 index 0000000..1a6cb1b --- /dev/null +++ b/hw06/hw06_alpha.scm @@ -0,0 +1,52 @@ +#lang eopl + +; Ben Burwell +; Dr. Kussmaul +; CSI-310 :: Programming Languages +; Homework 6: Alpha conversions + +;; ========== PROCEDURE ========== +;; NAME: alpha-conv +;; DESC: returns the alpha conversion of an expression if +;; it exists. If there is no alpha conversion, the +;; expression itself is returned. +(define alpha-conv + (lambda (from to exp) + (if + (list? exp) + (if + (equal? (length exp) 3) + (if + (and + (equal? (car exp) 'lambda) + (list? (cadr exp)) + (equal? (length (cadr exp)) 1) + (list? (caddr exp)) + ) + (list 'lambda (list to) (list-repl from to (caddr exp))) + exp) + exp) + exp))) + +;; ========== PROCEDURE ========== +;; NAME: list-repl +;; DESC: a helper function for the alpha conversion +;; replaces all occurrences of from with to in +;; exp unless there is a nested lambda function, +;; in which case it remains intact. +(define list-repl + (lambda (from to exp) + (cond + [ (equal? (length exp) 0) '() ] + [ (equal? (car exp) from) (cons to (list-repl from to (cdr exp))) ] + [ (and (list? (car exp)) (equal? (caar exp) 'lambda)) (cons (car exp) (list-repl from to (cdr exp))) ] + [ (list? (car exp)) (cons (list-repl from to (car exp)) (list-repl from to (cdr exp))) ] + [ else (cons (car exp) (list-repl from to (cdr exp))) ] + ))) + +;; ========== TEST CODE ========== +(alpha-conv 'x 'y '(x z)) +(alpha-conv 'x 'y '((lambda ( x ) (+ x 5)) 2)) +(alpha-conv 'x 'y '(lambda ( x ) (x z x))) +(alpha-conv 'x 'y '(lambda ( y ) (y z y))) +(alpha-conv 'x 'y '(lambda ( x ) (+ x ((lambda (x) (* 2 x)) 7))))
\ No newline at end of file diff --git a/hw06/hw06_combinators.scm b/hw06/hw06_combinators.scm new file mode 100644 index 0000000..0c3fdaf --- /dev/null +++ b/hw06/hw06_combinators.scm @@ -0,0 +1,21 @@ +#lang eopl + +; Ben Burwell +; Dr. Kussmaul +; CSI-310 Programming Languages +; HW06 :: Combinators + +; A. evaluate boolean logic expression +(or F (and T (not F))) +(or F (and T T)) +(or F T) +T + +; B. compute 2+1 using Church numerals +(increment 2) + +((λ (n) (λ (f) (λ (x) (f ((n f) x))))) (λ (f) (λ (x) (f (f x))))) +( λ (f) (λ (x) (f (((λ (f) (λ (x) (f (f x)))) f) x)))) +( λ (f) (λ (x) (f ( (λ (x) (f (f x))) x)))) +( λ (f) (λ (x) (f (f (f x))))) +(λ (f) (λ (x) (f (f (f x)))))
\ No newline at end of file diff --git a/hw06/hw06_eta.scm b/hw06/hw06_eta.scm new file mode 100644 index 0000000..991ee65 --- /dev/null +++ b/hw06/hw06_eta.scm @@ -0,0 +1,50 @@ +#lang eopl + +; Ben Burwell +; Dr. Kussmaul +; CSI-310 :: Programming Languages +; Homework 6: Eta Conversion + +;; ========== PROCEDURE ========== +;; NAME: eta-conv +;; DESC: takes a lambda expression and returns +;; its eta conversion. If the expression +;; does not have an eta-conversion, it +;; returns the expression itself. + +(define eta-conv + (lambda (lst) + (if ;; check that the parameter is a list of length 3 + (and + (list? lst) + (equal? (length lst) 3) + ) + (if ;; it is a list with the correct length, check + ;; that it has an eta-conversion + (and + (equal? (car lst) 'lambda) + (list? (cadr lst)) + (equal? (length (cadr lst)) 1) + (list? (caddr lst)) + (equal? (length (caddr lst)) 2) + (equal? (caadr lst) (cadr (caddr lst))) + ) + + ;; it does, so return the conversion + (car (caddr lst)) + + ;; it doesn't, so return the expression + lst) + + ;; not a parseable expression, return it + lst))) + +;; ========== TEST CODE ========== +;; should return a: +(eta-conv '(lambda (x) (a x))) + +;; should return (lambda (x) (x a)) +(eta-conv '(lambda (x) (x a))) + +;; should return () +(eta-conv '()) diff --git a/hw06_alpha.scm b/hw06_alpha.scm new file mode 100644 index 0000000..1a6cb1b --- /dev/null +++ b/hw06_alpha.scm @@ -0,0 +1,52 @@ +#lang eopl + +; Ben Burwell +; Dr. Kussmaul +; CSI-310 :: Programming Languages +; Homework 6: Alpha conversions + +;; ========== PROCEDURE ========== +;; NAME: alpha-conv +;; DESC: returns the alpha conversion of an expression if +;; it exists. If there is no alpha conversion, the +;; expression itself is returned. +(define alpha-conv + (lambda (from to exp) + (if + (list? exp) + (if + (equal? (length exp) 3) + (if + (and + (equal? (car exp) 'lambda) + (list? (cadr exp)) + (equal? (length (cadr exp)) 1) + (list? (caddr exp)) + ) + (list 'lambda (list to) (list-repl from to (caddr exp))) + exp) + exp) + exp))) + +;; ========== PROCEDURE ========== +;; NAME: list-repl +;; DESC: a helper function for the alpha conversion +;; replaces all occurrences of from with to in +;; exp unless there is a nested lambda function, +;; in which case it remains intact. +(define list-repl + (lambda (from to exp) + (cond + [ (equal? (length exp) 0) '() ] + [ (equal? (car exp) from) (cons to (list-repl from to (cdr exp))) ] + [ (and (list? (car exp)) (equal? (caar exp) 'lambda)) (cons (car exp) (list-repl from to (cdr exp))) ] + [ (list? (car exp)) (cons (list-repl from to (car exp)) (list-repl from to (cdr exp))) ] + [ else (cons (car exp) (list-repl from to (cdr exp))) ] + ))) + +;; ========== TEST CODE ========== +(alpha-conv 'x 'y '(x z)) +(alpha-conv 'x 'y '((lambda ( x ) (+ x 5)) 2)) +(alpha-conv 'x 'y '(lambda ( x ) (x z x))) +(alpha-conv 'x 'y '(lambda ( y ) (y z y))) +(alpha-conv 'x 'y '(lambda ( x ) (+ x ((lambda (x) (* 2 x)) 7))))
\ No newline at end of file diff --git a/hw06_combinators.scm b/hw06_combinators.scm new file mode 100644 index 0000000..0c3fdaf --- /dev/null +++ b/hw06_combinators.scm @@ -0,0 +1,21 @@ +#lang eopl + +; Ben Burwell +; Dr. Kussmaul +; CSI-310 Programming Languages +; HW06 :: Combinators + +; A. evaluate boolean logic expression +(or F (and T (not F))) +(or F (and T T)) +(or F T) +T + +; B. compute 2+1 using Church numerals +(increment 2) + +((λ (n) (λ (f) (λ (x) (f ((n f) x))))) (λ (f) (λ (x) (f (f x))))) +( λ (f) (λ (x) (f (((λ (f) (λ (x) (f (f x)))) f) x)))) +( λ (f) (λ (x) (f ( (λ (x) (f (f x))) x)))) +( λ (f) (λ (x) (f (f (f x))))) +(λ (f) (λ (x) (f (f (f x)))))
\ No newline at end of file diff --git a/hw06_eta.scm b/hw06_eta.scm new file mode 100644 index 0000000..991ee65 --- /dev/null +++ b/hw06_eta.scm @@ -0,0 +1,50 @@ +#lang eopl + +; Ben Burwell +; Dr. Kussmaul +; CSI-310 :: Programming Languages +; Homework 6: Eta Conversion + +;; ========== PROCEDURE ========== +;; NAME: eta-conv +;; DESC: takes a lambda expression and returns +;; its eta conversion. If the expression +;; does not have an eta-conversion, it +;; returns the expression itself. + +(define eta-conv + (lambda (lst) + (if ;; check that the parameter is a list of length 3 + (and + (list? lst) + (equal? (length lst) 3) + ) + (if ;; it is a list with the correct length, check + ;; that it has an eta-conversion + (and + (equal? (car lst) 'lambda) + (list? (cadr lst)) + (equal? (length (cadr lst)) 1) + (list? (caddr lst)) + (equal? (length (caddr lst)) 2) + (equal? (caadr lst) (cadr (caddr lst))) + ) + + ;; it does, so return the conversion + (car (caddr lst)) + + ;; it doesn't, so return the expression + lst) + + ;; not a parseable expression, return it + lst))) + +;; ========== TEST CODE ========== +;; should return a: +(eta-conv '(lambda (x) (a x))) + +;; should return (lambda (x) (x a)) +(eta-conv '(lambda (x) (x a))) + +;; should return () +(eta-conv '()) diff --git a/hw07.scm b/hw07.scm new file mode 100644 index 0000000..5434729 --- /dev/null +++ b/hw07.scm @@ -0,0 +1,278 @@ +#lang eopl + +; 3.4 INTERPRETER +; - this interpreter consists of several components +; - SCANNER - converts characters to tokens +; - PARSER - converts tokens to abstract syntax trees +; - ENVIRONMENT - maps identifiers to values +; - EVALUATOR - converts abstract syntax trees to values/results +; - this interpreter supports: +; - (3.1) basic functionality +; - whitespace & comments (skipped) +; - integers & built-in defined constants +; - 3 binary primitive operations - add, sub, mult +; - 2 unary primitive operations - incr, decr +; - (3.3) conditionals - if-then-else +; - (3.4) local bindings - let +; +; - things to do (save as 3.4a) +; + +; ------------------------------------------------------------ +; scanner specification + +(define scanner-spec + '( + (whitespace (whitespace) skip) + (comment ("%" (arbno (not #\newline))) skip) + (identifier (letter (arbno (or letter digit "?"))) symbol) + (number (digit (arbno digit)) number) )) + +; ------------------------------------------------------------ +; grammar specification + +(define grammar + '( + ; (3.1) program + (program (expression) + a-program) + ; (3.1) expressions + (expression (number) + lit-exp) + (expression (identifier) + var-exp) + + (expression (primitive "(" (separated-list expression ",") ")" ) + primapp-exp) + + (expression (primitive-one "(" expression ")") primapp-one-exp) + + (expression (primitive-two "(" expression "," expression ")") primapp-two-exp) + + ; (3.3) conditional + (expression ("if" expression "then" expression "else" expression) + if-exp) + ; (3.4) local binding + (expression ("let" (arbno identifier "=" expression) "in" expression) + let-exp) + + (expression ("cond" (arbno expression "==>" expression) "end") cond-exp) + + ; (3.1) primitives + (primitive ("+") add-prim) + (primitive ("*") mult-prim) + (primitive ("cons") cons-prim) + (primitive ("car") car-prim) + (primitive ("cdr") cdr-prim) + (primitive ("list") list-prim) + + (primitive-one ("add1") incr-prim) + (primitive-one ("sub1") decr-prim) + + (primitive-two ("-") subtract-prim) + )) + +; ------------------------------------------------------------ +; define datatypes before defining interpreter + +(sllgen:make-define-datatypes scanner-spec grammar) +(define dump-datatypes + (lambda () (sllgen:list-define-datatypes scanner-spec grammar))) + +; ------------------------------------------------------------ +; environment (using ribcage implementation - see 2.3.4) +; - maps identifiers to values + +(define-datatype environment environment? + (empty-env-record) + (extended-env-record + (syms (list-of symbol?)) + (vec vector?) ; can use this for anything. + (env environment?)) + ) + +(define empty-env + (lambda () + (extend-env '(emptylist) '(()) (empty-env-record)))) + +(define extend-env + (lambda (syms vals env) + (extended-env-record syms (list->vector vals) env))) + +(define apply-env + (lambda (env sym) + (cases environment env + (empty-env-record () + (eopl:error 'apply-env "No binding for ~s" sym)) + (extended-env-record (syms vals env) + (let ((position (rib-find-position sym syms))) + (if (number? position) + (vector-ref vals position) + (apply-env env sym))))))) + +(define rib-find-position + (lambda (sym los) + (list-find-position sym los))) + +(define list-find-position + (lambda (sym los) + (list-index (lambda (sym1) (eqv? sym1 sym)) los))) + +(define list-index + (lambda (pred ls) + (cond + ((null? ls) #f) + ((pred (car ls)) 0) + (else (let ((list-index-r (list-index pred (cdr ls)))) + (if (number? list-index-r) + (+ list-index-r 1) + #f)))))) + +; ------------------------------------------------------------ +; evaluator + +; evaluate program +(define eval-program + (lambda (pgm) + (cases program pgm + (a-program (body) (eval-expression body (init-env)) )))) + +; evaluate expression +(define eval-expression + (lambda (exp env) + (cases expression exp + ; (3.1) literals, variables, primitive applications + (lit-exp (datum) datum) + (var-exp (id) (apply-env env id)) + (primapp-exp (prim rands) + (let ((args (eval-rands rands env))) + (apply-primitive prim args) )) + (primapp-one-exp (prim rand) + (let ((arg (eval-rand rand env))) + (apply-primitive-one prim arg))) + + (primapp-two-exp (prim rand1 rand2) + (apply-primitive-two prim (eval-rand rand1 env) (eval-rand rand2 env))) + + ; (3.3) conditional + (if-exp (test-exp true-exp false-exp) + (if (true-value? (eval-expression test-exp env)) + (eval-expression true-exp env) + (eval-expression false-exp env))) + ; (3.4) local binding + (let-exp (ids rands body) + (let ((args (eval-rands rands env))) + (eval-expression body (extend-env ids args env)))) + + (cond-exp (conditions returns) + (eval-cond conditions returns env)) + ))) + +; (3.3) 0=false, anything else is true +; - placeholder for other definitions of true & false +(define true-value? + (lambda (x) (not (zero? x)))) + +; (3.4) evaluate operands for a procedure call +(define eval-rands + (lambda (rands env) (map (lambda (x) (eval-rand x env)) rands) )) +(define eval-rand + (lambda (rand env) (eval-expression rand env) )) + +(define eval-cond + (lambda (conditions returns env) + (if (null? conditions) + 0 + (if (true-value? (eval-expression (car conditions) env)) + (eval-expression (car returns) env) + (eval-cond (cdr conditions) (cdr returns) env))))) + + +; find list sum +(define list-sum + (lambda (lst) + (if + (equal? (length lst) 0) + (eopl:error "Trying to add nothing?!?! Absolutely NOT!") + (if + (equal? (length lst) 1) + (car lst) + (+ (car lst) (list-sum (cdr lst))))))) + +; find list product +(define list-prod + (lambda (lst) + (if + (equal? (length lst) 0) + (eopl:error "Trying to multiply nothing?!?! Absolutely NOT!") + (if + (equal? (length lst) 1) + (car lst) + (* (car lst) (list-prod (cdr lst))))))) + +; (3.1) apply primitive procedure to arguments +(define apply-primitive + (lambda (prim args) + (cases primitive prim + (add-prim () (list-sum args)) + (mult-prim () (* (list-prod args))) + (car-prim () (car args)) + (cdr-prim () (cdar args)) + (cons-prim () (cons (car args) (cadr args))) + (list-prim () args)))) + +(define apply-primitive-one + (lambda (prim arg) + (cases primitive-one prim + (incr-prim () (+ arg 1)) + (decr-prim () (- arg 1))))) + +(define apply-primitive-two + (lambda (prim arg1 arg2) + (cases primitive-two prim + (subtract-prim () (- arg1 arg2))))) + +; initial environment (named constants only, since it can't be changed) +(define init-env + (lambda () (extend-env '(i v x) '(1 5 10) (empty-env)) )) + +; ------------------------------------------------------------ +; interpreter + +(define scan + (sllgen:make-string-scanner scanner-spec + grammar)) +(define scan&parse + (sllgen:make-string-parser scanner-spec + grammar)) +(define read-dump + (sllgen:make-rep-loop "--> " (lambda (tree) tree) + (sllgen:make-stream-parser scanner-spec + grammar))) + +(define scan&parse&eval + (lambda (s) (eval-program(scan&parse s))) ) + +(define read-eval-print + (sllgen:make-rep-loop "--> " eval-program + (sllgen:make-stream-parser scanner-spec + grammar))) + +; ------------------------------------------------------------ +; testing - use (scan), (scan&parse), (read-dump), (read-eval-print) + +(define test-3.1a "add1(2)") + +; ignores extra parameters +(define test-3.1b "add1(2,3)") +(define test-3.1c "+(3,4,5)") + +; more tests +(define test-3.1d "+(add1(2),-(6,4))") +(define test-3.1e "*(2,+(3,sub1(4)))") +(define test-3.3a "if -(3,+(1,2)) then 2 else 3") +(define test-3.4a "let x = 5 y = 6 in +(x,y)") +(scan&parse test-3.3a) +(scan&parse test-3.4a) + +(read-eval-print)
\ No newline at end of file diff --git a/hw08.rkt b/hw08.rkt new file mode 100644 index 0000000..718432f --- /dev/null +++ b/hw08.rkt @@ -0,0 +1,403 @@ +#lang eopl + +; 3.9 INTERPRETER +; - the interpreter consists of several components +; - SCANNER - converts characters to tokens +; - PARSER - converts tokens to abstract syntax trees +; - ENVIRONMENT - maps identifiers to values +; - EVALUATOR - converts abstract syntax trees to values/results +; - this interpreter supports: +; - (3.1) basic functionality +; - whitespace & comments (skipped) +; - integers & built-in defined constants +; - 3 binary primitive operations - add, sub, mult +; - 2 unary primitive operations - incr, decr +; - (3.3) conditionals - if-then-else +; - (3.4) local bindings - let +; - (3.5) procedures - proc, app-exp +; - (3.6) recursion - letrec +; - (3.7) variable assignment - set +; - (3.9) statements - assign, print, compound, if, while, block +; +; THINGS DO DO (save as 3.9a) + +; ------------------------------------------------------------ +; scanner specification + +(define scanner-spec + '( + (whitespace (whitespace) skip) + (comment ("%" (arbno (not #\newline))) skip) + (identifier (letter (arbno (or letter digit "?"))) make-symbol) + (number (digit (arbno digit)) make-number) )) + +; ------------------------------------------------------------ +; grammar specification + +(define grammar + '( + ; (3.1) program + (program (statement) a-program) + + ; (3.9) statements + (statement (identifier "=" expression) + assign-statement) + (statement ("print" "(" expression ")") + print-statement) + (statement ("{" (separated-list statement ";") "}") + compound-statement) + (statement ("if" expression statement statement) + if-statement) + (statement ("while" expression "do" statement) + while-statement) + (statement ("var" (separated-list identifier ",") ";" statement) + block-statement) + (statement ("do" "{" statement "}" "while" expression) do-while-statement) + + ; (3.1) expressions + (expression (number) lit-exp) + (expression (identifier) var-exp) + (expression (primitive "(" (separated-list expression ",") ")") + primapp-exp) + + ; (3.3) conditional evaluation + (expression ("if" expression "then" expression "else" expression) + if-exp) + ; (3.4) local binding + (expression ("let" (arbno identifier "=" expression) "in" expression) + let-exp) + + ; (3.5) procedure definition & application + (expression ("proc" "(" (separated-list identifier ",") ")" expression) + proc-exp) + (expression ("(" expression (arbno expression) ")") + app-exp) + + ; (3.6) recursion + (expression ("letrec" + (arbno identifier "(" (separated-list identifier ",") ")" + "=" expression) + "in" expression) + letrec-exp) + + ; (3.7) variable assignment + (expression ("set" identifier "=" expression) + varassign-exp) + + ; (3.7 HW) sequential expressions + (expression ("begin" expression (arbno ";" expression) "end") + begin-exp) + + ; (3.1) primitives + (primitive ("+") add-prim) + (primitive ("-") subtract-prim) + (primitive ("*") mult-prim) + (primitive ("add1") incr-prim) + (primitive ("sub1") decr-prim) + ; (3.3) primitives + (primitive ("equal?") equal-prim) + (primitive ("zero?") zero-prim) + (primitive ("greater?") greater-prim) + (primitive ("less?") less-prim) + )) + +; ------------------------------------------------------------ +; define datatypes before defining interpreter + +(sllgen:make-define-datatypes scanner-spec grammar) +(define dump-datatypes + (lambda () (sllgen:list-define-datatypes scanner-spec grammar))) + +; ------------------------------------------------------------ +; booleans + +(define truth 1) +(define falsity 0) + +(define true-value? (lambda (x) (not (zero? x)))) + +; ------------------------------------------------------------ +; environments + +(define init-env + (lambda () (extend-env '(stdout) '(*uninitialized*) (empty-env)) )) + +(define-datatype environment environment? + (empty-env-record) + (extended-env-record + (syms (list-of symbol?)) + (vec vector?) ; can use this for anything + (env environment?) )) + +(define empty-env (lambda () (empty-env-record))) + +(define extend-env + (lambda (syms vals env) (extended-env-record syms (list->vector vals) env))) + +(define extend-env-recursively + (lambda (proc-names idss bodies old-env) + (let ((len (length proc-names))) + (let ((vec (make-vector len))) + (let ((env (extended-env-record proc-names vec old-env))) + (for-each + (lambda (pos ids body) + (vector-set! vec pos (closure ids body env))) + (iota len) + idss + bodies) + env))))) + +(define apply-env-ref + (lambda (env sym) + (cases environment env + (empty-env-record () + (eopl:error 'apply-env "no association for symbol ~s" sym)) + (extended-env-record (syms vals env) + (let ((position (env-find-position sym syms))) + (if (number? position) (a-ref position vals) (apply-env-ref env sym))))))) + +(define apply-env + (lambda (env sym) (deref (apply-env-ref env sym)))) + +(define env-find-position + (lambda (sym los) (list-find-position sym los))) + +(define list-find-position + (lambda (sym los) (list-index (lambda (sym1) (eqv? sym1 sym)) los))) + +(define list-index + (lambda (pred ls) + (cond + ((null? ls) #f) + ((pred (car ls)) 0) + (else (let ((list-index-r (list-index pred (cdr ls)))) + (if (number? list-index-r) (+ list-index-r 1) #f)))))) + +(define iota + (lambda ( n ) (do ((n n (- n 1)) (x '() (cons (- n 1) x))) ((zero? n) x)))) + +; ------------------------------------------------------------ +; evaluator + +; evaluator for root of abstract syntax tree +(define execute-program + (lambda (pgm) + (cases program pgm + (a-program (statement) + (execute-statement statement (init-env)) )))) + +; (3.9) statement evaluator +(define execute-statement + (lambda (stmt env) + (cases statement stmt + + (assign-statement (id exp) + (setref! + (apply-env-ref env id) + (eval-expression exp env) )) + + (print-statement (exp) + (write (eval-expression exp env)) (newline) ) + + (compound-statement (statements) + (for-each + (lambda (statement) (execute-statement statement env)) + statements) ) + + (if-statement (exp true-statement false-statement) + (if (true-value? (eval-expression exp env)) + (execute-statement true-statement env) + (execute-statement false-statement env) )) + + ; alternate "named" LET syntax + (while-statement (exp statement) + (let loop () + (if (true-value? (eval-expression exp env)) + (begin + (execute-statement statement env) + (loop) )))) + + (do-while-statement (stmt exp) + (execute-statement stmt env) + (let loop () + (if (true-value? (eval-expression exp env)) + (begin + (execute-statement stmt env) + (loop)) ))) + + + (block-statement (ids statement) + (execute-statement statement + (extend-env ids (map (lambda (id) 0) ids) env) )) + ))) + +; expression evaluator +(define eval-expression + (lambda (exp env) + (cases expression exp + (lit-exp (datum) datum) + (var-exp (id) (apply-env env id)) + + (primapp-exp (prim rands) + (let ((args (eval-rands rands env))) + (apply-primitive prim args))) + + ; (3.3) conditional evaluation + (if-exp (test-exp true-exp false-exp) + (if (true-value? (eval-expression test-exp env)) + (eval-expression true-exp env) + (eval-expression false-exp env) )) + + ; (3.4) local binding + (let-exp (ids rands body) + (let ((args (eval-rands rands env))) + (eval-expression body (extend-env ids args env)))) + + ; (3.5) procedure definition + (proc-exp (ids body) (closure ids body env)) + + ; (3.5) procedure application + (app-exp (rator rands) + (let ((proc (eval-expression rator env)) + (args (eval-rands rands env)) ) + (if (procval? proc) + (apply-procval proc args) + (eopl:error 'eval-expression + "attempt to apply non-procedure ~s" + proc)))) + + ; (3.6) recursion + (letrec-exp (proc-names idss bodies letrec-body) + (eval-expression letrec-body + (extend-env-recursively proc-names idss bodies env))) + + ; (3.7) variable assignment + (varassign-exp (id rhs-exp) + (begin (setref! + (apply-env-ref env id) + (eval-expression rhs-exp env)) + 1)) + + ; (3.7) sequential expressions + (begin-exp (exp1 exps) + (letrec + ((loop (lambda (acc exps) + (if (null? exps) acc + (loop (eval-expression (car exps) env) + (cdr exps)))))) + (loop (eval-expression exp1 env) exps))) + ))) + +; (3.4) evaluate operands +(define eval-rands + (lambda (rands env) (map (lambda (x) (eval-rand x env)) rands))) +(define eval-rand + (lambda (rand env) (eval-expression rand env))) + +; (3.1) apply primitive operations +(define apply-primitive + (lambda (prim args) + (define (check arity) + (if (not (= arity (length args))) + (eopl:error 'apply-primitive + "wrong number of arguments to primitive ~s" + prim))) + (cases primitive prim + (add-prim () (check 2) (+ (car args) (cadr args))) + (subtract-prim () (check 2) (- (car args) (cadr args))) + (mult-prim () (check 2) (* (car args) (cadr args))) + (incr-prim () (check 1) (+ (car args) 1)) + (decr-prim () (check 1) (- (car args) 1)) + (equal-prim () (check 2) (if (= (car args) (cadr args)) truth falsity)) + (zero-prim () (check 1) (if (zero? (car args)) truth falsity)) + (greater-prim () (check 2) (if (> (car args) (cadr args)) truth falsity)) + (less-prim () (check 2) (if (< (car args) (cadr args)) truth falsity)) + ))) + +; ------------------------------------------------------------ +; procedures (3.5) + +(define-datatype procval procval? + (closure + (ids (list-of symbol?)) ; formal parameters + (body expression?) ; procedure body + (env environment?))) ; closure (calling environment) + +(define apply-procval + (lambda (proc args) + (cases procval proc + (closure (ids body env) + (if (= (length ids) (length args)) + (eval-expression body (extend-env ids args env)) + (eopl:error 'apply-procval + "wrong number of arguments to procedure ~s" + ids)))))) + +; ------------------------------------------------------------ +; references - for variable assignment (3.7) + +(define-datatype reference reference? + (a-ref + (position integer?) + (vec vector?) )) + +(define primitive-deref + (lambda (ref) + (cases reference ref + (a-ref (pos vec) + (vector-ref vec pos) )))) + +(define primitive-setref! + (lambda (ref value) + (cases reference ref + (a-ref (pos vec) + (vector-set! vec pos value))))) + +(define deref (lambda (ref) (primitive-deref ref))) +(define setref! (lambda (ref value) (primitive-setref! ref value))) + +; ------------------------------------------------------------ +; interpreter + +; scanner only, and parser only +(define scan + (sllgen:make-string-scanner scanner-spec grammar)) +(define scan&parse + (sllgen:make-string-parser scanner-spec grammar)) +(define read-dump + (sllgen:make-rep-loop "--> " (lambda (tree) tree) + (sllgen:make-stream-parser scanner-spec grammar))) + +(define scan&parse&eval + (lambda (s) (execute-program (scan&parse s))) ) + +(define read-eval-print + (sllgen:make-rep-loop "--> " execute-program + (sllgen:make-stream-parser scanner-spec grammar))) + +; ------------------------------------------------------------ +; tests + +(define test-3.1a "add1(2)") +; ignores extra parameters +(define test-3.1b "add1(2,3)") +(define test-3.1c "+(3,4,5)") +; more tests +(define test-3.1d "+(add1(2),-(6,4))") +(define test-3.1e "*(2,+(3,sub1(4)))") +(define test-3.3a "if -(3,+(1,2)) then 2 else 3") +(define test-3.4a "let x = 5 y = 6 in +(x,y)") + +(define test3.5a "print(let f=proc(y,z) +(y,-(z,5)) in (f 2 28))") +(define test3.5b "print((proc (x) +(x,2) 4))") +(define test3.5c "print(let x=5 in let f=proc(y,z) +(y,-(z,x)) x=28 in (f 2 x))") + +(define test3.6a "print(letrec fact(x)=if zero?(x) then 1 else *(x,(fact sub1(x))) +in (fact 6))") +(define test3.6b "print(letrec even(x)=if zero?(x) then 1 else (odd sub1(x)) +odd(x)=if zero?(x) then 0 else (even sub1(x)) +in (odd 13))") + +(define test3.9a "var x,y; {x=3; y=4; print(+(x,y))}") +(define test3.9b "var x,y,z; {x=3; y=4; z=0; +while x do {z=+(z,y); x=sub1(x)}; print(z)}")
\ No newline at end of file diff --git a/hw08.scm b/hw08.scm new file mode 100644 index 0000000..fe329f2 --- /dev/null +++ b/hw08.scm @@ -0,0 +1,394 @@ +#lang eopl + +; 3.9 INTERPRETER +; - the interpreter consists of several components +; - SCANNER - converts characters to tokens +; - PARSER - converts tokens to abstract syntax trees +; - ENVIRONMENT - maps identifiers to values +; - EVALUATOR - converts abstract syntax trees to values/results +; - this interpreter supports: +; - (3.1) basic functionality +; - whitespace & comments (skipped) +; - integers & built-in defined constants +; - 3 binary primitive operations - add, sub, mult +; - 2 unary primitive operations - incr, decr +; - (3.3) conditionals - if-then-else +; - (3.4) local bindings - let +; - (3.5) procedures - proc, app-exp +; - (3.6) recursion - letrec +; - (3.7) variable assignment - set +; - (3.9) statements - assign, print, compound, if, while, block +; +; THINGS DO DO (save as 3.9a) + +; ------------------------------------------------------------ +; scanner specification + +(define scanner-spec + '( + (whitespace (whitespace) skip) + (comment ("%" (arbno (not #\newline))) skip) + (identifier (letter (arbno (or letter digit "?"))) make-symbol) + (number (digit (arbno digit)) make-number) )) + +; ------------------------------------------------------------ +; grammar specification + +(define grammar + '( + ; (3.1) program + (program (statement) a-program) + + ; (3.9) statements + (statement (identifier "=" expression) + assign-statement) + (statement ("print" "(" expression ")") + print-statement) + (statement ("{" (separated-list statement ";") "}") + compound-statement) + (statement ("if" expression statement statement) + if-statement) + (statement ("while" expression "do" statement) + while-statement) + (statement ("var" (separated-list identifier ",") ";" statement) + block-statement) + + ; (3.1) expressions + (expression (number) lit-exp) + (expression (identifier) var-exp) + (expression (primitive "(" (separated-list expression ",") ")") + primapp-exp) + + ; (3.3) conditional evaluation + (expression ("if" expression "then" expression "else" expression) + if-exp) + ; (3.4) local binding + (expression ("let" (arbno identifier "=" expression) "in" expression) + let-exp) + + ; (3.5) procedure definition & application + (expression ("proc" "(" (separated-list identifier ",") ")" expression) + proc-exp) + (expression ("(" expression (arbno expression) ")") + app-exp) + + ; (3.6) recursion + (expression ("letrec" + (arbno identifier "(" (separated-list identifier ",") ")" + "=" expression) + "in" expression) + letrec-exp) + + ; (3.7) variable assignment + (expression ("set" identifier "=" expression) + varassign-exp) + + ; (3.7 HW) sequential expressions + (expression ("begin" expression (arbno ";" expression) "end") + begin-exp) + + ; (3.1) primitives + (primitive ("+") add-prim) + (primitive ("-") subtract-prim) + (primitive ("*") mult-prim) + (primitive ("add1") incr-prim) + (primitive ("sub1") decr-prim) + ; (3.3) primitives + (primitive ("equal?") equal-prim) + (primitive ("zero?") zero-prim) + (primitive ("greater?") greater-prim) + (primitive ("less?") less-prim) + )) + +; ------------------------------------------------------------ +; define datatypes before defining interpreter + +(sllgen:make-define-datatypes scanner-spec grammar) +(define dump-datatypes + (lambda () (sllgen:list-define-datatypes scanner-spec grammar))) + +; ------------------------------------------------------------ +; booleans + +(define truth 1) +(define falsity 0) + +(define true-value? (lambda (x) (not (zero? x)))) + +; ------------------------------------------------------------ +; environments + +(define init-env + (lambda () (extend-env '(stdout) '(*uninitialized*) (empty-env)) )) + +(define-datatype environment environment? + (empty-env-record) + (extended-env-record + (syms (list-of symbol?)) + (vec vector?) ; can use this for anything + (env environment?) )) + +(define empty-env (lambda () (empty-env-record))) + +(define extend-env + (lambda (syms vals env) (extended-env-record syms (list->vector vals) env))) + +(define extend-env-recursively + (lambda (proc-names idss bodies old-env) + (let ((len (length proc-names))) + (let ((vec (make-vector len))) + (let ((env (extended-env-record proc-names vec old-env))) + (for-each + (lambda (pos ids body) + (vector-set! vec pos (closure ids body env))) + (iota len) + idss + bodies) + env))))) + +(define apply-env-ref + (lambda (env sym) + (cases environment env + (empty-env-record () + (eopl:error 'apply-env "no association for symbol ~s" sym)) + (extended-env-record (syms vals env) + (let ((position (env-find-position sym syms))) + (if (number? position) (a-ref position vals) (apply-env-ref env sym))))))) + +(define apply-env + (lambda (env sym) (deref (apply-env-ref env sym)))) + +(define env-find-position + (lambda (sym los) (list-find-position sym los))) + +(define list-find-position + (lambda (sym los) (list-index (lambda (sym1) (eqv? sym1 sym)) los))) + +(define list-index + (lambda (pred ls) + (cond + ((null? ls) #f) + ((pred (car ls)) 0) + (else (let ((list-index-r (list-index pred (cdr ls)))) + (if (number? list-index-r) (+ list-index-r 1) #f)))))) + +(define iota + (lambda ( n ) (do ((n n (- n 1)) (x '() (cons (- n 1) x))) ((zero? n) x)))) + +; ------------------------------------------------------------ +; evaluator + +; evaluator for root of abstract syntax tree +(define execute-program + (lambda (pgm) + (cases program pgm + (a-program (statement) + (execute-statement statement (init-env)) )))) + +; (3.9) statement evaluator +(define execute-statement + (lambda (stmt env) + (cases statement stmt + + (assign-statement (id exp) + (setref! + (apply-env-ref env id) + (eval-expression exp env) )) + + (print-statement (exp) + (write (eval-expression exp env)) (newline) ) + + (compound-statement (statements) + (for-each + (lambda (statement) (execute-statement statement env)) + statements) ) + + (if-statement (exp true-statement false-statement) + (if (true-value? (eval-expression exp env)) + (execute-statement true-statement env) + (execute-statement false-statement env) )) + + ; alternate "named" LET syntax + (while-statement (exp statement) (while-loop exp statement env)) + + (block-statement (ids statement) + (execute-statement statement + (extend-env ids (map (lambda (id) 0) ids) env) )) + ))) + +(define while-loop + (lambda (exp stmt env) + (if (true-value? exp) + (lambda () (execute-statement stmt env) (while-loop exp stmt env)) + (#f)))) + +; expression evaluator +(define eval-expression + (lambda (exp env) + (cases expression exp + (lit-exp (datum) datum) + (var-exp (id) (apply-env env id)) + + (primapp-exp (prim rands) + (let ((args (eval-rands rands env))) + (apply-primitive prim args))) + + ; (3.3) conditional evaluation + (if-exp (test-exp true-exp false-exp) + (if (true-value? (eval-expression test-exp env)) + (eval-expression true-exp env) + (eval-expression false-exp env) )) + + ; (3.4) local binding + (let-exp (ids rands body) + (let ((args (eval-rands rands env))) + (eval-expression body (extend-env ids args env)))) + + ; (3.5) procedure definition + (proc-exp (ids body) (closure ids body env)) + + ; (3.5) procedure application + (app-exp (rator rands) + (let ((proc (eval-expression rator env)) + (args (eval-rands rands env)) ) + (if (procval? proc) + (apply-procval proc args) + (eopl:error 'eval-expression + "attempt to apply non-procedure ~s" + proc)))) + + ; (3.6) recursion + (letrec-exp (proc-names idss bodies letrec-body) + (eval-expression letrec-body + (extend-env-recursively proc-names idss bodies env))) + + ; (3.7) variable assignment + (varassign-exp (id rhs-exp) + (begin (setref! + (apply-env-ref env id) + (eval-expression rhs-exp env)) + 1)) + + ; (3.7) sequential expressions + (begin-exp (exp1 exps) + (letrec + ((loop (lambda (acc exps) + (if (null? exps) acc + (loop (eval-expression (car exps) env) + (cdr exps)))))) + (loop (eval-expression exp1 env) exps))) + ))) + +; (3.4) evaluate operands +(define eval-rands + (lambda (rands env) (map (lambda (x) (eval-rand x env)) rands))) +(define eval-rand + (lambda (rand env) (eval-expression rand env))) + +; (3.1) apply primitive operations +(define apply-primitive + (lambda (prim args) + (define (check arity) + (if (not (= arity (length args))) + (eopl:error 'apply-primitive + "wrong number of arguments to primitive ~s" + prim))) + (cases primitive prim + (add-prim () (check 2) (+ (car args) (cadr args))) + (subtract-prim () (check 2) (- (car args) (cadr args))) + (mult-prim () (check 2) (* (car args) (cadr args))) + (incr-prim () (check 1) (+ (car args) 1)) + (decr-prim () (check 1) (- (car args) 1)) + (equal-prim () (check 2) (if (= (car args) (cadr args)) truth falsity)) + (zero-prim () (check 1) (if (zero? (car args)) truth falsity)) + (greater-prim () (check 2) (if (> (car args) (cadr args)) truth falsity)) + (less-prim () (check 2) (if (< (car args) (cadr args)) truth falsity)) + ))) + +; ------------------------------------------------------------ +; procedures (3.5) + +(define-datatype procval procval? + (closure + (ids (list-of symbol?)) ; formal parameters + (body expression?) ; procedure body + (env environment?))) ; closure (calling environment) + +(define apply-procval + (lambda (proc args) + (cases procval proc + (closure (ids body env) + (if (= (length ids) (length args)) + (eval-expression body (extend-env ids args env)) + (eopl:error 'apply-procval + "wrong number of arguments to procedure ~s" + ids)))))) + +; ------------------------------------------------------------ +; references - for variable assignment (3.7) + +(define-datatype reference reference? + (a-ref + (position integer?) + (vec vector?) )) + +(define primitive-deref + (lambda (ref) + (cases reference ref + (a-ref (pos vec) + (vector-ref vec pos) )))) + +(define primitive-setref! + (lambda (ref value) + (cases reference ref + (a-ref (pos vec) + (vector-set! vec pos value))))) + +(define deref (lambda (ref) (primitive-deref ref))) +(define setref! (lambda (ref value) (primitive-setref! ref value))) + +; ------------------------------------------------------------ +; interpreter + +; scanner only, and parser only +(define scan + (sllgen:make-string-scanner scanner-spec grammar)) +(define scan&parse + (sllgen:make-string-parser scanner-spec grammar)) +(define read-dump + (sllgen:make-rep-loop "--> " (lambda (tree) tree) + (sllgen:make-stream-parser scanner-spec grammar))) + +(define scan&parse&eval + (lambda (s) (execute-program (scan&parse s))) ) + +(define read-eval-print + (sllgen:make-rep-loop "--> " execute-program + (sllgen:make-stream-parser scanner-spec grammar))) + +; ------------------------------------------------------------ +; tests + +(define test-3.1a "add1(2)") +; ignores extra parameters +(define test-3.1b "add1(2,3)") +(define test-3.1c "+(3,4,5)") +; more tests +(define test-3.1d "+(add1(2),-(6,4))") +(define test-3.1e "*(2,+(3,sub1(4)))") +(define test-3.3a "if -(3,+(1,2)) then 2 else 3") +(define test-3.4a "let x = 5 y = 6 in +(x,y)") + +(define test3.5a "print(let f=proc(y,z) +(y,-(z,5)) in (f 2 28))") +(define test3.5b "print((proc (x) +(x,2) 4))") +(define test3.5c "print(let x=5 in let f=proc(y,z) +(y,-(z,x)) x=28 in (f 2 x))") + +(define test3.6a "print(letrec fact(x)=if zero?(x) then 1 else *(x,(fact sub1(x))) +in (fact 6))") +(define test3.6b "print(letrec even(x)=if zero?(x) then 1 else (odd sub1(x)) +odd(x)=if zero?(x) then 0 else (even sub1(x)) +in (odd 13))") + +(define test3.9a "var x,y; {x=3; y=4; print(+(x,y))}") +(define test3.9b "var x,y,z; {x=3; y=4; z=0; +while x do {z=+(z,y); x=sub1(x)}; print(z)}")
\ No newline at end of file |