;;; 3e8 html utilities

(use simple-xml doctype)

;;; configurables

(define (home-link)
  (link "http://3e8.org" "3e8.org"))

(define *categories*
  '((home "/" "Home")
    (photos "/gallery/" "Photos")
    (hacks "/hacks/" "Hacks")
    (music "/music/" "Music")
    (writings "/writings/" "Writings")
    (hits "/searches/" "Hits")
    (zb "/zb/" "Scheme")
    (about "/about/" "?")))

(define *subcategories*
  '((brkout "/hacks/dc/" "Dreamcast")  
    (dc "/hacks/dc/" "Dreamcast")
    (ultima6 "/hacks/ultima6/" "pu6e")))

(define *all-categories*
  (append *categories* *subcategories*))

;;; utils

;; URL
(define (link href . body)
  `(a (@ (href ,href)) ,@body))
;; Entity
(define (& ent)
  (literally (sprintf "&~A;" ent)))
;; Suffix text with » -- useful for emphasizing links
(define (raquo text)
  `(,text
    ,(& 'nbsp)
    (span (@ (class "raquo"))
          ,(& 'raquo))))

(define (navbar selected)
  `(div (@ (id "nav"))
        (ul
         ,@(map (match-lambda
                 ((id path title)
                  `(li (@ (id ,(conc "nav-" id))
                          ,(if (eq? id selected)
                               `(class "selected")
                               '()))
                       (a (@ (href ,path)) (span ,title)))))
                *categories*))))

(define (navskip)
  `(p (@ (id "navskip"))
      (a (@ (href "#content")) "Skip navigation.")))

(define (side-section title . body)
  `((div (@ (class "sidetitle")) ,title)
    (div (@ (class "side")) ,@body)))

(define (sidebar)
  `(div (@ (id "sub"))
        (div (@ (id "links"))
             ,(side-section "Deep Links"
                            `(ul (li (a (@ (href "/hacks/brkout/")) "brkout - DC breakout clone"))
                                 (li (a (@ (href "/hacks/ultima6/")) "pu6e - Ultima 6 editor"))
                                 (li (a (@ (href "/hacks/dc/")) "Dreamcast hacks"))
                                 (li (a (@ (href "/gallery/Japan-2007/")) "Japan photos"))
                                 (li (a (@ (href "/zb/")) "Zbigniew's Scheme page"))))
             ,(side-section "3e8.org is" "Jim Ursetto")

             (div (@ (class "sidetitle") (id "validated")) "and I feel validated")
             (div (@ (class "side") (id "validator"))
                  (ul
                   (li ,(link "http://validator.w3.org/check?uri=referer"
                              `(img (@ (src "/images/valid-xhtml10-blue.png")
                                       (alt "Valid XHTML 1.0 Strict")
                                       (height "31")
                                       (width "88")))))
                   (li ,(link "http://jigsaw.w3.org/css-validator/check/referer"
                              `(img (@ (style "border:0;width:88px;height:31px")
                                       (src "/images/vcss-blue.gif")
                                       (alt "Valid CSS")))))))
             )))

;; tables
(define (section name id . body)
  `(div (@ (class "section")
           (id ,id))
        (h3 ,name)
        (table ,@body)))
(define (program name . desc)
  `(tr (td (@ (class "prog"))
           ,name)
       (td ,@desc)))

;; Not used.  L is a list of symbols abbreviating each language.
;; Would require: knowledge of our page filename, or a mod_rewrite rule.
(define (languages . L)
  (define abbrs '((en . "English") (eo . "Esperanto")))
  `(div (@ (class "language"))
        (ul ,@(map (lambda (x)
                     (cond ((alist-ref x abbrs)
                            => (cut list 'li <>))
                           (else '())))
                   L))))

;; Alternatively: have a path like '(hacks dreamcast) and automatically
;; generate the links and the 3e8.org >> hacks >> dreamcast text.  However,
;; some pages have different names vs. filenames and some (like brkout)
;; are even colorful.
(define (call-resp path desc)
  `(div (@ (class "call"))
        (h4 ,(intersperse path
                          (list " " (& 'raquo) " ")))
        (h5 ,desc)))
;; Create a path for call-resp.  Symbols are looked up in *all-categories*
;; and the associated links and text are used.  Everything else is inserted
;; verbatim.  This weirdness is because the text, pathname, category path
;; and category name aren't always regular.  Unfortunately, that also means
;; we can't derive regular paths.
;; Example use: (call-resp (category 'writings "Proverbs.e38") "Annoy roommate")
(define (category . cats)
  (define (cat c)
    (cond ((not (symbol? c)) c)
          ((alist-ref c *all-categories*)
           => (cut apply link <>))
          (else c)))
  (cons (home-link)
        (map cat cats)))


;;; screenshots

(define (thumb url w h . alt)
  (let ((alt (if (null? alt) '("screenshot") alt)))
    `(img (@ (src ,url)
             (width ,w)
             (height ,h)
             (alt ,@alt)))))
(define (shot url thumb desc #!optional (size #f))
  `(div (@ (class "screenshot"))
        ,(link url thumb)
        ,(if size
             `(p ,desc " "
                 (span (@ (class size)) "(" ,size ")"))
             `(p ,desc))))
(define (screenshots . shots)
  ;; The empty &nbsp; div gives the screenshot contents mass (otherwise, they don't take up any space).
  ;; I feel this method is a kludge.
  (define (mass-kludge)
    `(div (@ (class mass-kludge))
          ,(& 'nbsp)))
  `(div (@ (class "screenshots"))
        ,(mass-kludge)
        ,shots
        ,(mass-kludge)))

;;; page render

(define (main . body)
  `(div (@ (id "content"))
        (div (@ (id "main"))
             ,@body)
        ,(sidebar)))
(define (main1 . body)            ;; single calumny
  `(div (@ (id "content"))
        (div (@ (id "main1"))
             ,@body)))

(define (xhtml-page title . body)
  `(,(literally doctype:xhtml-1.0-strict)
    ,(xml-comment "Generated with Chicken Scheme " (chicken-version))
    (html (@ (xmlns "http://www.w3.org/1999/xhtml"))
          (head (meta (@ (http-equiv "Content-Type")
                         (content "text/html; charset=utf-8")))
                (meta (@ (name "description")
                         (content "Jim Ursetto's code, photos, music and writings.")))
                (title ,title)
                (link (@ (rel "stylesheet")
                         (href "/css/screen.css")
                         (type "text/css")))
                )
          (body ,@body))))

(define (render-page title . body)
  (print (xml (apply xhtml-page title body))))