From cd57e7c557d01f9d74e6849c6988b61d827d182a Mon Sep 17 00:00:00 2001 From: bnewbold Date: Mon, 20 Apr 2009 19:41:39 -0400 Subject: ps08 done --- ps08_conspiracies/bnewbold_ps08_work.scm | 214 +++++++++++++++++++++++++++++++ 1 file changed, 214 insertions(+) create mode 100644 ps08_conspiracies/bnewbold_ps08_work.scm (limited to 'ps08_conspiracies/bnewbold_ps08_work.scm') diff --git a/ps08_conspiracies/bnewbold_ps08_work.scm b/ps08_conspiracies/bnewbold_ps08_work.scm new file mode 100644 index 0000000..42686ec --- /dev/null +++ b/ps08_conspiracies/bnewbold_ps08_work.scm @@ -0,0 +1,214 @@ +;;; 6.945 Problem Set #8 Source Code +;;; 04/19/2009 +;;; Bryan Newbold + +(load "load") + +;;;------------------------------------------------------------------------ +;;; Problem 8.2B: + +(define the-empty-stream (stream)) + +(define (lazy-fringe subtree) + (define (lazy-walk subtree ans) + (cond ((pair? subtree) + (lazy-walk (car subtree) + (lazy-walk (cdr subtree) ans))) + ((null? subtree) ans) + (else (cons-stream subtree ans)))) + (lazy-walk subtree the-empty-stream)) + +(define (lazy-same-fringe? tree1 tree2) + (let lp ((f1 (lazy-fringe tree1)) + (f2 (lazy-fringe tree2))) + (cond ((and (stream-null? f1) (stream-null? f2)) #t) + ((or (stream-null? f1) (stream-null? f2)) #f) + ((eq? (stream-car f1) (stream-car f2)) + (lp (stream-cdr f1) (stream-cdr f2))) + (else #f)))) + +#| Test it! +(lazy-same-fringe? + '((a b) c ((d)) e (f ((g h)))) + '(a b c ((d) () e) (f (g (h))))) +;Value: #t + +(lazy-same-fringe? + '((a b) c ((d)) e (f ((g h)))) + '(a b c ((d) () e) (g (f (h))))) +;Value: #f +|# + +;;;------------------------------------------------------------------------ +;;; Problem 8.5: + +(define (make-pipe) + (let ((queue (queue:make)) + (lock (conspire:make-lock))) + (list lock queue))) + +(define (pipe-writer p) + (lambda (thing) + (conspire:acquire-lock (car p)) + (queue:add-to-end! (cadr p) thing) + (conspire:unlock (car p)))) + +(define (pipe-reader p) + (lambda () + (let lp ((nothing-here 0)) + (conspire:acquire-lock (car p)) + (cond ((queue:empty? (cadr p)) + (conspire:unlock (car p)) + (conspire:thread-yield) + (lp 0)) + (else + (let ((ans (queue:get-first (cadr p)))) + (conspire:unlock (car p)) + ans)))))) + +#| Test! + +(with-conspiracy + (lambda () + (define test-pipe (make-pipe)) + (define reader (pipe-reader test-pipe)) + (define writer (pipe-writer test-pipe)) + (writer 10) + (writer 20) + (reader))) +;Value: 10 + +|# + + + + (define *done* (list '*done*)) + + (define (piped-same-fringe? tree1 tree2) + (let ((p1 (make-pipe)) (p2 (make-pipe))) + (let ((thread1 + (conspire:make-thread + conspire:runnable + (lambda () + (piped-fringe-generator tree1 (pipe-writer p1))))) + (thread2 + (conspire:make-thread + conspire:runnable + (lambda () + (piped-fringe-generator tree2 (pipe-writer p2))))) + (f1 (pipe-reader p1)) + (f2 (pipe-reader p2))) + (let lp ((x1 (f1)) (x2 (f2))) + (cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t) + ((or (eq? x1 *done*) (eq? x2 *done*)) #f) + ((eq? x1 x2) (lp (f1) (f2))) + (else #f)))))) + + (define (piped-fringe-generator tree return) + (define (lp tree) + (cond ((pair? tree) + (lp (car tree)) + (lp (cdr tree))) + ((null? tree) unspecific) + (else + (return tree)))) + (lp tree) + (return *done*)) + +#| Test some more! + +(with-conspiracy + (lambda () + (piped-same-fringe? '((a b) c ((d)) e (f ((g h)))) + '(a b c ((d) () e) (f (g (h))))))) +;Value: #t +(with-conspiracy + (lambda () + (piped-same-fringe? '((a b) c ((d)) e (f ((g h)))) + '(a b c ((d) () e) (g (g (h))))))) +;Value: #f + +|# + +;;;------------------------------------------------------------------------ +;;; Problem 8.6: + +(define (make-threaded-filter thunker) + (let ((pipe (make-pipe))) + (conspire:make-thread + conspire:runnable + (thunker (pipe-writer pipe))) + (pipe-reader pipe))) + +#| Testy! + +(with-conspiracy + (lambda () + (make-threaded-filter (lambda x x)))) +;Value: #[compound-procedure 31] + +(with-conspiracy + (lambda () + (define make-an-int + (let ((count 0)) + (lambda () + (set! count (+ count 1)) + count))) + (define (return-an-int return) + (return (make-an-int))) + (return-an-int pp) + (define go + (make-threaded-filter return-an-int)) + (go))) +;Value: 2 + +|# + +(define *done* (list '*done*)) + +(define (tf-piped-same-fringe? tree1 tree2) + (let ((f1 (make-threaded-filter (tf-piped-fringe-generator tree1))) + (f2 (make-threaded-filter (tf-piped-fringe-generator tree2)))) + (let lp ((x1 (f1)) (x2 (f2))) + (cond ((and (eq? x1 *done*) (eq? x2 *done*)) #t) + ((or (eq? x1 *done*) (eq? x2 *done*)) #f) + ((eq? x1 x2) (lp (f1) (f2))) + (else #f))))) + +(define (tf-piped-fringe-generator tree) + (lambda (return) + (define (lp tree) + (cond ((pair? tree) + (lp (car tree)) + (lp (cdr tree))) + ((null? tree) unspecific) + (else + (return tree)))) + (lp tree) + (return *done*))) + +#| +(with-time-sharing-conspiracy + (lambda () + (tf-piped-same-fringe? + '((a b) c ((d)) e (f ((g h)))) + '(a b c ((d) () e) (f (g (h))))) + )) +;Value: #t + +(with-time-sharing-conspiracy + (lambda () + (tf-piped-same-fringe? + '((a b) c ((d)) e (f ((g h)))) + '(a b c ((d) () e) (g (f (h))))) + )) +;Value: #f + +(with-time-sharing-conspiracy + (lambda () + (tf-piped-same-fringe? + '((a b) c ((d)) e (f ((g h)))) + '(a b c ((d) () e) (g (f )))) + )) +;Value: #f +|# -- cgit v1.2.3