(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 " tag str tag) (format "<~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 "\"~a\"" (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