; fwd/next buttons nare unlinked
; prev button uinknown
; files in wrong dir
;caption above pic.

(require-library "functios.ss")
(define (true?  x) (and (boolean? x)      x ))
(define (false? x) (and (boolean? x) (not x)))

(define  list-ref0          list-ref)
(define (list-ref1 items n) (list-ref items (sub1 n)))

(require-library "date.ss")  ; For current-time to stamp on web page.
(require-library "file.ss")  ; For filename processing: file-extension.

(require-library "xml.ss" "xml")
(collapse-whitespace true) ; When reading xml, collapse all white space to a single space.

(define (one? n) (= n 1))
(define (length1? lst) (one? (length lst)))

;; pad2: number-->string
;; Like number->string but string has length 2 (padded with leading 0 if needed).
;; Bug: well, this prepends a 0 any time the number was only one digit.
;;
(define (pad2 num)
  (let* {[str  (number->string num)]}
    (if (one? (string-length str))
        (string-append "0" str)
        str)))


;; remove-suffix: string, string --> string
;; Return str, less suff.
;;
(define (remove-suffix str suff)
  (unless (and (>= (string-length str) (string-length suff))
               (string-ci=? suff (substring str (- (string-length str) (string-length suff))
                                                (string-length str))))
    (error 'remove-suffix (format "~s doesn't end in ~s." str suff)))
  (substring str 0 (- (string-length str) (string-length suff))))




;; with-output-overwrite-file:
;; Like with-output-to-file, except that if the file already exists
;; it deletes the file.
;; BUG: probably this should (have a flag allowing) output to a temporary file,
;;      and only delete the original once the output succeeded.
;;
(define (with-output-overwrite-file pathname thunk)
  (begin (when (file-exists? pathname) (delete-file pathname))
         (with-output-to-file pathname thunk)))






;; assoc-Q&A: Q&A-list --> (list value) or false
;; Like assoc, but instead of a key tested with eq?,
;; use the provided test.  If the test passes,
;; return a box:
;; the result of applying the association asnwer to the input.
;; Otherwise return false.
;;
(define (assoc-Q&A target qalist)
  (cond [(empty? qalist)                   false]
        [((first (first qalist)) target)   (box ((second (first qalist)) target))]
        [else                              (assoc-Q&A target (rest qalist))]))




;; map*:     NOT QUITE: (list* alpha), (alpha->beta) --> (list* beta)
;; Like map, except if given list, first recursively map* each element of that list,
;; before applying "fn".
;; Notes: evaluation is left-to-right, and is a post-order.
;; (that is, process a list *after* first processing each element in the list.)
;;
(define (map* fn val)
  (cond [(list? val)  (fn (map (lambda (elt) (map* fn elt))
                               val))]
        [else         (fn val)]))




;; xexpr-assoc->qapair: association or qapair --> qapair
;;    (A helper function for map*-selective.)
;; If the first element of the association is a key (symbol),
;; turn it into a test, testing if it was given a list
;; whose first element is that key.
;; If the second element of the input was a function,
;; then the result is a question/answer pair (see assoc-Q&A).
;;
;; Example:
;; (even? 'some-value)  is mapped to  (even? 'some-value)
;; ('hi   'other-value) is mapped to  (list-starting-w-hi? 'other-value)
;;    where  list-starting-w-hi?  is a boolean function
;;    which tests its argument as indicated.
;; 
(define (xexpr-assoc->qapair association-or-qapair)
  (let* {[test-or-key (first  association-or-qapair)]
         [value       (second association-or-qapair)]}
    (list (if (procedure? test-or-key)
              test-or-key
              (lambda (item) (and (cons? item) (eq? test-or-key (first item)))))
          value)))


;; map*-selective
;; The main transforming function:
;; Given an xexpr, and a list of tags-and-functions to work on elements with that tag,
;; transform the xexpr.
;;
;; map*-selective recurs in a pre-order way; note that if you are (say) transforming
;; "title" elements, there is no way to distinguish between a top-level title and
;; a title of an interior element (perhaps, a document title vs a table's title);
;; both will get the same transform.
;; Also, map*-selective evaluates left-to-right,
;; useful if your transform produces side-effects.
;;
(define map*-selective
  (case-lambda
   [(tag-test morpher elts)
    (map*-selective (list (list tag-test morpher)) elts)]
   [(morpher-q-and-alist elts)
    (let* {[morpher-qalist (map xexpr-assoc->qapair morpher-q-and-alist)]
           [apply-selectively (lambda (elt)
                                (let* {[morph-or-not (assoc-Q&A elt morpher-qalist)]}
                                  (if (false? morph-or-not)
                                      elt
                                      (unbox morph-or-not))))]}
      (map* apply-selectively elts))]))
;
;; Examples:
;;
;; For all 'hello xexprs, remove that initial tag (via "rest"):
;;
;(map*-selective 'hello rest '(hi there hello (this is (hello hell) okay) (hello bye)))
;= '(hi there hello (this is (hell) okay) (bye))


; You can provide not just a single tag and transformer,
; but a list of tag/transformer pairs.
; If several tags apply, only the first transformer is applied.
;
(define (greeting? lst) (and (list? lst) (not (false? (memq (first lst) '(hi hello aloha))))))
(define (wave-goodbye grting) (cons 'adios grting))
;(map*-selective `((hello ,rest) (this ,empty?) (,greeting? ,wave-goodbye))
;                '(hi there hello (hi indeed!) (this is (this) (hello (this) hell) okay) (hello bye)))
;= '(adios hi there hello (adios hi indeed!) #f (bye))


 
 
;; filter-tag: symbol, xexpr --> (list-of xexpr)
;; return a list of all sub-elements of xexpr which start with key.
;;
(define (filter-tag key xexpr)
  (cond [(empty? xexpr) empty]
        [(and (cons? (first xexpr)) (eq? key (first (first xexpr))))
         (cons (first xexpr) (filter-tag key (rest xexpr)))]
        [else (filter-tag key (rest xexpr))]))
;(filter-tag 'hi '(html (head "over heels") (body "this is" (em "a" (hi "greeting")) (hi "aloha"))))
;= '((hi "greeting") (hi "aloha"))

(define (filter-tag1 key xexpr)
  (let* {[tags (filter-tag key xexpr)]}
    (unless (length1? tags) (error 'filter-tag1 "Should only be one ~s in ~s.~n"))
    (first tags)))


;==========================================================
; Now use those utilities to define some helpful functions.


;; trim-white-string: string --> string
;; trim-white-chars: (list* char) --> (list* char)
;; Remove all leading and trailing white-space.
;;
(define (trim-white-chars chars)
  (cond [(empty? chars) empty]
        [(char-whitespace? (first chars))
         (trim-white-chars (rest chars))]
        [else chars]))
(define (trim-white-string str)
  (list->string (reverse (trim-white-chars (reverse (trim-white-chars (string->list str)))))))

;(trim-white-string "   \t hello   \nthere\n") = "hello  \nthere"
;(8

;; Recur into an xexpr, trimming initial and final white space from all strings.
;;
(define (xexpr-trim-spaces xexpr)
  (map*-selective string? trim-white-string xexpr))














(define image-dir-url "http://www.cs.rice.edu/~ian/Images/")
(define next-img-url (string-append image-dir-url "next.gif"))
(define prev-img-url (string-append image-dir-url "previous.gif"))
(define next-img `(img {[src ,next-img-url] [alt "next"]} ))
(define prev-img `(img {[src ,prev-img-url] [alt "previous"]} ))

(define gallery-dir  (build-absolute-path "stratus:" "ian" "blitzen" "2001.07 friends, bartok"))
;(current-directory gallery-dir)

(define gallery-info (build-path gallery-dir "gallery.xml"))
(define the-info '())
(with-input-from-file gallery-info 
  (lambda () (set! the-info (xml->xexpr ((eliminate-whitespace '(gallery picture) identity) (document-element (read-xml)))))))


;(xexpr-trim-spaces the-info)
;(map*-selective 'picture (lambda (p) (printf "picture: ~s.~n" p)) the-info)






(define link-to-home '(a {(href "http://www.cs.rice.edu/~ian/")} "Ian Barland"))
(define email-addr "ian@cs.rice.edu")

 



;; date->ian-string:
;; Like date->string, but in the format i like.
;; (Cf. date-display-format)
;;
(define date->ian-string 
  (case-lambda 
   [(date)
    (date->ian-string date true)]
   [(date include-time?)
    (let* {[weekday-names-short '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")]
           [month-names-short   '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")]
           [date-string (format "~a.~a.~a (~a)"
                                (date-year date) (list-ref1 month-names-short (date-month date)) (pad2 (date-day date)) 
                                (list-ref0 weekday-names-short (date-week-day date)))]
           [time-string (format "~a:~a:~a"
                                (pad2 (date-hour date)) (pad2 (date-minute date)) (pad2 (date-second date)))]}
      (if include-time?
          (string-append date-string ", " time-string)
          date-string))]))

(date->ian-string (seconds->date (current-seconds)) true)

;; standard-page-foot: --> xexpr/html
;; Return an xexpr which can be appended to the innards of an html "body" xexpr,
;; and has "page maintained by" and "last updated" info.
;;
(define (standard-page-foot)
  `{(hr {})
    (address {} (table {(align "center")}
                       (tr {[width "100%"]}
                        (td {[align "left"]} "Maintained by " ,link-to-home)
                        (td {[align "center"]} "Please " (a {(mailto ,email-addr)} "notify me")
                               " of broken links, errors, or suggestions.")
                        (td {[align "right"]} "Last updated " ,(date->ian-string (seconds->date (current-seconds)) false)))))})

;; picture->pagename: xexpr/picture --> string
;; Given a picture (which includes a .jpg filename),
;; return the name for the page which (will) display that picture.
;;
(define (picture->pagename pict)
  (let* {[image-filename (second (filter-tag1 'filename (second pict)))]
         }
    (string-append (remove-suffix image-filename (filename-extension image-filename)) "html")))


;; pictures->xexpr-roadmap
;; Return the overview roadmap for all pics.
;;
(define (pictures->xexpr-roadmap pics)
  `{(ol {} ,@(map (lambda (pict) 
                    `(li {} (a {[href ,(picture->pagename pict)]} ,@(rest (rest (filter-tag1 'title pict))))))
                  pics))})

;; create-gallery-page: xexpr/gallery --> xexpr/page
;;
(define (create-gallery-page gallery)
  (let* {[title       (filter-tag1 'title gallery)]
         [title-attrs (second title)]
         [title-body  (rest (rest title))]
         [intro       (filter-tag1 'intro   gallery)]
         [pictures    (filter-tag  'picture gallery)]
         [_           (when (empty? pictures) (error 'create-gallery-page (format "No pictures in ~s." gallery)))]
         [first-pic   (first pictures)]
         }
    `(html (head {} (title {} ,@title-body))
           (body {} (h2 {[align "center"] ,@title-attrs} ,@title-body)
                    (p  {[align "center"]} ,@(rest (rest intro)))
                    ,@(pictures->xexpr-roadmap pictures)
                    ,@(standard-page-foot)))))


(define (filename->url fn)
  ; For the moment, just use a relative url:
  fn)
         
(define (frame num pictures)
  (let* {[the-pic          (list-ref1 pictures num)]
         [picture-filename (second (filter-tag1 'filename (second the-pic)))]
         [picture-url      (filename->url picture-filename)]
         [indicator (string-append  "Picture " (pad2 num) " of " (pad2 (length pictures)) ".")]
         [the-img `(img {(src ,picture-url) (alt ,picture-filename) (border "0")})]
         [next-pict-num  (if (= num (length pictures)) 1                 (add1 num))]
         [prev-pict-num  (if (= num 1)                 (length pictures) (sub1 num))]
         [link-next `(a {(href ,(picture->pagename (list-ref1 pictures next-pict-num)))} ,next-img)]
         [link-prev `(a {(href ,(picture->pagename (list-ref1 pictures prev-pict-num)))} ,prev-img)]
         [caption   (filter-tag1 'caption the-pic)]
         }
  `(table {[align "center"] [bgcolor "#ffff66"] [cellpadding "30"]}
          (tr {} (td {} (table {(align "center")} (tr {(align "center")} (td {} ,the-img) (td {} ,caption)))))
          (tr {} (td {} (table {(align "center")} (tr {(align "center")} (td {} ,link-prev)
                                                                         (td {} ,indicator)
                                                                         (td {} ,link-next))))))))





(define the-pics (filter-tag  'picture the-info))
                                                



(define (picture->html  pics n)
  (let* {[the-pic (list-ref1 pics n)]
         [pic-filename (filter-tag1 'filename (second the-pic))]
         [pic-pagename (picture->pagename the-pic)]
         [title        (filter-tag1 'title the-pic)]
         [title-attrs  (second title)]
         [title-body   (rest (rest title))]}
    `(html (head {} (title {} ,@title-body))
           (body {} (h2 {[align "center"] ,@title-attrs} ,@title-body)
                    ,(frame n pics)
                    ,@(standard-page-foot)))))



;;
;;
(define (create-picture-page! pics n)
  (with-output-overwrite-file (build-path gallery-dir (picture->pagename (list-ref1 pics n)))
                              (lambda () (write-xml/content (xexpr->xml (picture->html pics n))))))


;; create-picture-page: xexpr/picture --> xexpr/page
;;
(define (create-picture-pages! pics n)
  (cond [(zero? n) (void)]
        [else (begin (create-picture-page!  pics n)
                     (create-picture-pages! pics (sub1 n)))]))

(with-output-overwrite-file (build-path gallery-dir "gallery.html")
                            (lambda () (write-xml/content (xexpr->xml (create-gallery-page the-info)))))
(create-picture-pages! the-pics 2)