(define functionU (require-library-unit/sig "functior.ss"))
(define prettyU (require-library-unit/sig "prettyr.ss"))
(define-signature htmlS
(make-html-hrule html-hrule?
make-html-list html-list-items html-list-numbered? html-list?
make-html-paragraph html-paragraph-contents html-paragraph?
make-html-section html-section-heading html-section-level
html-section-center-heading? html-section-contents html-section?
make-html-table html-table-header html-table-rows html-table-grid?
html-table?
make-html-link html-link-URL html-link-text html-link?
make-html-center html-center-contents html-center?
make-html-image html-image-file html-image-description html-image?
make-html-page html-page-title html-page-bgcolor html-page-contents
html-page?
html-to-file))
(define HtmlU
(unit/sig htmlS
(import mzlib:function^ mzlib:pretty-print^)
(define-struct html-hrule ())
(define-struct html-list (items numbered?))
(define-struct html-paragraph (contents))
(define-struct html-section (heading level center-heading? contents))
(define-struct html-table (header rows grid?))
(define-struct html-link (URL text))
(define-struct html-center (contents))
(define-struct html-image (file description))
(define-struct html-page (title bgcolor contents))
(define (enclose-in-tag tag str . attr)
(if (null? attr)
(format "<~a>~a~a>
" tag str tag)
(format "<~a ~a>~a~a>
" tag (car attr) str tag)))
(define (render-lohtml html-elts)
(apply string-append
(map (lambda (item) (format " ~a " (render-html item))) html-elts)))
;; html-elt or list of html-elt -> string
(define (render-contents contents . tag)
(let ([content-str
(if (list? contents)
(render-lohtml contents)
(render-html contents))])
(if (null? tag) content-str (enclose-in-tag (car tag) content-str))))
;; enclose-each-and-combine : string list-of html-elts -> string
(define (enclose-each-and-combine tag html-elts)
(apply string-append
(map (lambda (elt) (enclose-in-tag tag (render-html elt)))
html-elts)))
;; render-html : html-elt -> string
(define (render-html html-elt)
(cond [(string? html-elt) html-elt]
[(number? html-elt) (number->string html-elt)]
[(symbol? html-elt) (symbol->string html-elt)]
[(html-hrule? html-elt) "
"]
[(html-list? html-elt)
(let ([items (apply string-append
(map (lambda (item)
(format " ~a" (render-html item)))
(html-list-items html-elt)))])
(if (html-list-numbered? html-elt)
(enclose-in-tag "ol" items)
(enclose-in-tag "ul" items)))]
[(html-paragraph? html-elt)
(render-contents (html-paragraph-contents html-elt) "p")]
[(html-section? html-elt)
(let ([header (enclose-in-tag (format "h~a" (html-section-level html-elt))
(html-section-heading html-elt))])
(if (html-section-center-heading? html-elt)
(string-append (enclose-in-tag "center" header)
(render-contents (html-section-contents html-elt)))
(string-append header
(render-contents (html-section-contents html-elt)))))]
[(html-table? html-elt)
(let ([table-contents
(apply string-append
(cons (enclose-in-tag
"tr" (enclose-each-and-combine
"th" (html-table-header html-elt)))
(map (lambda (row)
(enclose-in-tag
"tr" (enclose-each-and-combine "td" row)))
(html-table-rows html-elt))))])
(if (html-table-grid? html-elt)
(enclose-in-tag "table" table-contents "border=3")
(enclose-in-tag "table" table-contents)))]
[(html-link? html-elt)
(enclose-in-tag "a" (html-link-text html-elt)
(format "href=~s" (html-link-URL html-elt)))]
[(html-center? html-elt)
(render-contents (html-center-contents html-elt) "center")]
[(html-image? html-elt)
(format ""
(html-image-file html-elt) (html-image-description html-elt))]
[(html-page? html-elt)
(enclose-in-tag "html"
(string-append
(enclose-in-tag "title" (html-page-title html-elt))
(enclose-in-tag
"body"
(render-contents (html-page-contents html-elt))
(format "bgcolor=~a" (html-page-bgcolor html-elt)))))]))
; (define (popup-html html-elt)
; (let* ([html-string (render-html html-elt)]
; [port (open-input-string html-string)])
; (open-url port)
; (close-input-port port)
; #t))
(define (html-to-file html-elt filename)
(let ([html-string (render-html html-elt)]
[port (open-output-file filename 'replace)])
(pretty-display html-string port)
(close-output-port port)
#t))
))
(define-signature hwk2S
(make-album album-artist album-title album-category album?
make-format format-type format-copies format-price format?
make-stock stock-album stock-cd stock-tape stock?
make-lst lst-first lst-rest lst?
gen-page/1 gen-page/2 gen-page/3 gen-page/4
update-db base-inventory
))
(define CoreHwk2U
(unit/sig hwk2S
(import htmlS plt:userspace^)
(define-struct album (artist title category))
(define-struct format (type copies price))
(define-struct stock (album cd tape))
;; inventory is a list of stock
(define-struct lst (first rest))
(define (make-list->list mlist)
(cond [(empty? mlist) null]
[else (cons (lst-first mlist) (make-list->list (lst-rest mlist)))]))
(define (^inca a-stock category)
(let ([c (lambda (e) (apply (apply compose
(list album-category stock-album))
(cons e '())))])
(symbol=? category (c a-stock))))
(define (!*appup?* an-update a-stock)
(printf "in *appup*~n")
(and (string=?
(album-artist (stock-album a-stock))
(with-handlers
([exn:else?
(lambda (exn) (cons exn empty))])
(update-artist an-update)))
(string=?
(update-title an-update)
(with-handlers
([exn:struct?
(lambda (exn) (cons exn empty))])
(album-title (stock-album a-stock))))))
(define (cohabitators name selector1 a-stock an-update selector2)
(let ((cohorts (lambda (format-what selector update-what)
(+ (format-what (selector a-stock))
(update-what an-update)))))
(make-format name
(cohorts format-copies selector1 update-change-in-copies)
(cohorts format-price selector2 update-change-in-price))))
(define (upst** an-update a-stock)
(cond [(symbol=? (update-type an-update) 'cd)
(make-stock (stock-album a-stock)
(cohabitators 'cd stock-cd a-stock an-update stock-cd)
(stock-tape a-stock))]
[(symbol=? (update-type an-update) 'tape)
(make-stock (stock-album a-stock)
(stock-cd a-stock)
(cohabitators 'tape stock-tape a-stock an-update stock-tape))]))
(define (gad++ a-stock)
(let ([gap (lambda (a-format)
(if a-format (format-price a-format) "N/A"))])
(let ((lst->list (lambda (l)
(let lp ((l l))
(if (null? l) l
(cons (lst-first l) (lp (lst-rest l)))))))
(list->lst (lambda (l)
(foldr make-lst empty l))))
(list->lst
(apply list (map (lambda (f)
(f a-stock))
(lst->list
(make-lst
(lambda (e) (album-artist (stock-album e)))
(make-lst
(lambda (e) (album-title (stock-album e)))
(make-lst
(lambda (e) (gap (stock-cd e)))
(make-lst
(lambda (e) (gap (stock-tape e)))
empty)))))))))))
(define (get-stock type inventory)
(filter (lambda (a-stock) (in-category? a-stock type))
inventory))
(define (update-db apply-update? update-stock an-update inventory)
(foldr (lambda (a-stock rst)
((lambda (tst tb fb)
(if tst (tb a-stock rst) (fb a-stock rst)))
(apply-update? an-update a-stock)
(lambda (f r) (cons (update-stock an-update f) r))
cons))
() inventory))
(define (make-section-table inventory)
(make-html-table
(let ([fst "Artist"] [snd "Album"])
(append (list fst snd) (list "CD Price") (list "Cassette Price")))
(map (lambda (a-stock)
(with-handlers ([exn:else? (lambda (exn) (cons exn empty))])
(make-list->list (get-album-data a-stock))))
inventory)
#t))
;; gen-first-page : inventory -> boolean
;; generates web page for an inventory
(define (gen-first-page inventory)
(let ([classical (get-stock 'classical inventory)]
[rock (get-stock 'rock inventory)]
[blues (get-stock 'blues inventory)])
(html-to-file
(make-html-page
"Sammy's Music Prices" "WHITE"
(make-html-section
"Sammy's Music" 1 #t
(list
(make-html-paragraph
(make-html-center "Check out our Inventory!"))
(make-html-hrule)
(make-html-section "Classical" 2 #f (make-section-table classical))
(make-html-paragraph "")
(make-html-hrule)
(make-html-section "Rock" 2 #f (make-section-table rock))
(make-html-paragraph "")
(make-html-hrule)
(make-html-section "Blues" 2 #f (make-section-table blues))
(make-html-paragraph "")
(make-html-hrule)
)))
"210Music.html")
#t))
(define (make-gen-page sub-in-category? sub-apply-update?
sub-update-stock sub-get-album-data)
(if sub-in-category?
(set! in-category? sub-in-category?)
(set! in-category? ^inca))
(if sub-apply-update?
(set! apply-update? sub-apply-update?)
(set! apply-update? !*appup?*))
(if sub-update-stock
(set! update-stock sub-update-stock)
(set! update-stock upst**))
(if sub-get-album-data
(set! get-album-data sub-get-album-data)
(set! get-album-data gad++))
(lambda (inventory)
(gen-first-page inventory)))
(define in-category? #f)
(define apply-update? #f)
(define update-stock #f)
(define get-album-data #f)
(define update-artist #f)
(define update-title #f)
(define update-type #f)
(define update-change-in-copies #f)
(define update-change-in-price #f)
(define (gen-page/1 in-category? inventory)
((make-gen-page in-category? #f #f #f) inventory))
(define (gen-page/2 inventory)
((make-gen-page #f #f #f #f) inventory))
(define (gen-page/3 get-album-data inventory)
((make-gen-page #f #f #f get-album-data) inventory))
(define (gen-page/4 in-category? get-album-data inventory)
((make-gen-page in-category? #f #f get-album-data)
inventory))
;; inventory data
(define a1 (make-album "Bach" "Brandenburg Concertos" 'classical))
(define a2 (make-album "Pink Floyd" "The Wall" 'rock))
(define a3 (make-album "Vivaldi" "The Four Seasons" 'classical))
(define a4 (make-album "Beatles" "Abbey Road" 'rock))
(define a5 (make-album "BB King" "The Thrill is Gone" 'blues))
(define a6 (make-album "Beatles" "Yellow Submarine" 'rock))
(define base-inventory
(list (make-stock a1
(make-format 'cd 4 8.99)
(make-format 'tape 3 5.99))
(make-stock a2
(make-format 'cd 8 12.99)
(make-format 'tape 0 7.99))
(make-stock a3
(make-format 'cd 6 8.99)
#f)
(make-stock a4
#f
(make-format 'tape 9 12.99))
(make-stock a5
(make-format 'cd 4 11.99)
#f)
(make-stock a6
(make-format 'cd 5 11.99)
(make-format 'tape 6 8.99))
))
))
(define hwk2U
(compound-unit/sig
(import (PLT : plt:userspace^))
(link
(FUNCTION : mzlib:function^ (functionU))
(PRETTY : mzlib:pretty-print^ (prettyU))
(HTML : htmlS (HtmlU FUNCTION PRETTY))
(HWK2 : hwk2S (CoreHwk2U HTML PLT)))
(export (open HTML) (open HWK2))))
hwk2U