(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) "<hr>"]
            [(html-list? html-elt)
             (let ([items (apply string-append
                                 (map (lambda (item)
                                        (format "<li> ~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 "<IMG SRC=\"~a\" ALT=\"~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