WXME0105 ## wxtext wxtab wxmedia wximage $(lib "comment-snip.ss" "framework") +(lib "collapsed-snipclass.ss" "framework") drscheme:sexp-snip drscheme:syntax-snipclass% drscheme:number ,(lib "number-snip.ss" "drscheme" "private") drscheme:bindings-snipclass% drscheme:lambda-snip% drscheme:define-snip% "drscheme:vertical-separator-snip% wxbad drscheme:test-suite:helper% case% def% drscheme:xml-snip (lib "xml-snipclass.ss" "xml") drscheme:scheme-snip "(lib "scheme-snipclass.ss" "xml") wxloc . K ZZ Standard K Monospace ZZ ? \ ? ? ? "" Matching Parenthesis Style ? \ ? ? ? "" ? \ ? ? ? ( drscheme:check-syntax:keyword ? \ ? ? ? ( ? ? ? ? 'drscheme:check-syntax:unbound-variable ? ? ? ? ? ? ? ? %drscheme:check-syntax:bound-variable ? ? ? ? drscheme:check-syntax:primitive ? ? ? ? ? ? ? ? 3' drscheme:check-syntax:constant ? ? ? ? 3' ? \ ? ? ? drscheme:check-syntax:tail-call ? \ ? ? ? ? ? ? ? ** drscheme:check-syntax:base ? ? ? ? ** F ? ? ? ? ? ? ? XML F ? ? ? ? ? ? ? K Monospace ZZ G ? ? ? ? ? ? ? ? ? ? ? G ? ? ? ? G ? ? ? ? d ? ? ? ? ? \ ? ^ ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? K Monospace ZZ ? \] ? ? ? syntax-coloring:Java:keyword ? \] ? ? ? ? \] ? ? ? syntax-coloring:Java:string ? \] ? ? ? syntax-coloring:Java:literal ? \] ? ? ? ? \] ? ? ? ? ? ? syntax-coloring:Java:comment ? \] ? ? ? ? ? ? ? \] ? ? ? syntax-coloring:Java:error ? \] ? ? ? ? \] ? ? ? syntax-coloring:Java:identifier ? \] ? ? ? syntax-coloring:Java:default ? \] ? ? ? ? ? ? ? F ZZ I /;; This code runs in the "Pretty Big" language,
1;; which is under "PLT" in the list of languages.
-;; The code implements a family-tree database
0;; with operations for adding a mother or father
2;; for someone already in the tree. The web server
.;; shows the current tree (using HTML tables).
1;; After running this code, use a web browser on
";; the same machine and connect to
;; http://localhost:4000/
2;; Of course, if you change the 4000 below, change
;; the URL above, too.
6;; You can add people to the family tree in DrScheme's
0;; interactions window, then refresh the page in
,;; your web browser to see the updated tree.
4;; For a simpler server (just puts random numbers in
3;; a table), see the code in the comment box at the
;; end of this file.
?;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
*;; The family-tree model, same as previous
;; lecture.
; A family-tree is either
; - empty
-; - (make-child family-tree family-tree sym)
;(define-struct child (father mother name) (make-inspector))
4(define MY-FAMILY (make-child empty empty 'Matthew))
*; ----------------------------------------
; add-mother! : sym sym -> void
#(define (add-mother! c-name m-name)
8 (set! MY-FAMILY (add-mother MY-FAMILY c-name m-name)))
; add-father! : sym sym -> void
#(define (add-father! c-name f-name)
8 (set! MY-FAMILY (add-father MY-FAMILY c-name f-name)))
*; ----------------------------------------
1; add-mother : family-tree sym sym -> family-tree
(define (add-mother ft cn mn)
(add-parent ft cn
(lambda (f m n)
(make-child f
7 (make-child empty empty mn)
! n))))
1; add-father : family-tree sym sym -> family-tree
(define (add-father ft cn fn)
(add-parent ft cn
(lambda (f m n)
7 (make-child (make-child empty empty fn)
m
! n))))
; add-parent : family-tree sym
9; (family-tree family-tree sym -> family-tree)
; -> family-tree
(define (add-parent ft cn add)
(cond
((empty? ft) empty)
(else
(cond
% ((symbol=? cn (child-name ft))
(add (child-father ft)
(child-mother ft)
cn))
(else
9 (make-child (add-parent (child-father ft) cn add)
9 (add-parent (child-mother ft) cn add)
) (child-name ft)))))))
*; ----------------------------------------
-; find-relative : sym -> family-tree-or-false
(define (find-relative c-name)
! (find-person MY-FAMILY c-name))
7; find-person : family-tree sym -> family-tree-or-false
(define (find-person ft cn)
(cond
((empty? ft) false)
(else (cond
. ((symbol=? cn (child-name ft)) ft)
(else
3 (or (find-person (child-father ft) cn)
9 (find-person (child-mother ft) cn)))))))
*; ----------------------------------------
*;; family-tree->sexp : family-tree -> sexp
(define (family-tree->sexp ft)
(cond
[(empty? ft) '()]
5 [else (list (family-tree->sexp (child-father ft))
5 (family-tree->sexp (child-mother ft))
# (child-name ft))]))
)(family-tree->sexp empty) "should be" '()
5(family-tree->sexp (make-child empty empty 'Matthew))
"should be" '(() () Matthew)
(family-tree->sexp
? (make-child (make-child empty empty 'Raymond) empty 'Matthew))
)"should be" '((() () Raymond) () Matthew)
6;; write-family-tree : family-tree output-port -> void
(define (write-family-tree ft p)
# (write (family-tree->sexp ft) p))
); (define o (open-output-port "my tree"))
!; (write-family-tree MY-FAMILY o)
; (close-output-port o)
*;; sexp->family-tree : sexp -> family-tree
(define (sexp->family-tree sexp)
(cond
[(empty? sexp) empty]
[else (make-child
+ (sexp->family-tree (first sexp))
, (sexp->family-tree (second sexp))
(third sexp))]))
)(sexp->family-tree '()) "should be" empty
$(sexp->family-tree '(() () Matthew))
-"should be" (make-child empty empty 'Matthew)
/;; read-family-tree : input-port -> family-tree
(define (read-family-tree i)
(sexp->family-tree (read i)))
';(define i (open-input-port "my tree"))
&;(set! MY-FAMILY (read-family-tree i))
;(close-input-port i)
?;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; The web server for displaying family tree.
3;; The display is a little prettier than we left it
;; at the end of lecture.
A(define l (tcp-listen 4000)) ; you may have to change this number
(require (lib "xml.ss" "xml"))
%; tree->table : familty-tree -> xexpr
(define (tree->table ft)
(cond
[(empty? ft) $ unknown ]
[else
( | 6 (symbol->string (child-name ft))
|
| 5 (tree->table (child-father ft)) |
5 (tree->table (child-mother ft)) |
]))
(tree->table empty) "should be" $ unknown
/(tree->table (make-child empty empty 'Matthew))
"should be"
;| Matthew |
3 | unknown |
7 unknown |
; serve-connection : -> void
(define (serve-connection)
/ (local [(define-values (i o) (tcp-accept l))]
4 (display (xexpr->string (tree->table MY-FAMILY))
o)
(close-output-port o)
(serve-connection)))
8;; "thread" means "run this function in the background":
(thread serve-connection)
:;; Use "add-mother!" and "add-father!" in the interactions
$;; window, and use a web browser at
;; http://127.0.0.1:4000/
5;; to see the result. (If you change the 4000 in the
:;; definition of "l", also change it in the browser URL.)
;; Our original server:
L # (define l (tcp-listen 4005))
(require (lib "xml.ss" "xml"))
; random-row : -> xexpr
(define (random-row)
d | 2 (number->string (random 10))
|
)
; serve-connection : -> void
(define (serve-connection)
/ (local [(define-values (i o) (tcp-accept l))]
(display (xexpr->string
" (random-row)
" (random-row)
" (random-row)
)
o)
(close-output-port o)
(serve-connection)))
(serve-connection)