;;; ursetto html utilities

(use simple-xml doctype)

;;; configurables

(define (home-link)
  (link "http://ursetto.com" "ursetto.com"))

(define *categories*
  '((home "/" "Home")
    (resume "/resume/" "Resume")
    (articles "/docs/" "Articles")
    (services "/services/" "Services")
;;     (projects "/projects/" "Projects")
    (brochure "/brochure/" "Brochure")
    (contact "/contact/" "Contact")
;;     (siteinfo "/siteinfo/" "Site info")
    ))

(define *subcategories*
  '())

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

;;; utils

;; URL
(define (link href . body)
  `(a (@ (href ,href)) ,@body))
;; Entity
(define (& ent)
  (xml-literal (sprintf "&~A;" ent)))
;; Suffix text with » -- useful for emphasizing links
(define (raquo text)
  `(,text
    ,(& 'nbsp)
    (span (@ (class "raquo"))
          ,(& 'raquo))))
;; link to a chicken egg -- I found this useful on multiple pages
(define (egg-link name)
  (link `("http://chicken.wiki.br/" ,name) name))

(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)) ,title))))
                *categories*))))

(define (category-path cat)
  (cond ((alist-ref cat *all-categories*)
         => car)
        (else
         (error 'category-path "Invalid category" cat))))
(define (category-link cat text)
  (link (category-path cat) text))

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

(define (side-section title . body)
  `((h4 ,title)
    ,@body))

(define (sidebar . body)
  `(div (@ (id "colR"))
        ,@body
        ,(copyright)))

(define (default-sidebar-sections)
  (list (side-section "Quick links"
                      `(ul (li (a (@ (href "/resume/resume.html")) "Resume"))
                           (li (a (@ (href "/brochure/ursetto-brochure.pdf"))
                                  "Brochure"))
                           ;; (li (a (@ (href "/projects/latest.html"))
                           ;;                                         "Latest project"))
                           (li (a (@ (href "mailto:jim@ursetto.com"))
                                  "E-mail me"))))
        (side-section "Clients"
                      `(ul (li (a (@ (href "http://www.infores.com"))
                                  "Information Resources, Inc."))
                           (li (a (@ (href "http://www.acxiom.com"))
                                  "Acxiom Corporation"))
                           (li ,(link "http://cmegroup.com" "Chicago Mercantile Exchange"))))))
(define (default-sidebar)
  (sidebar (default-sidebar-sections)))

(define (copyright)
  `(p (@ (class "copyright"))
      ,(& 'copy) " 2009 Ursetto Consulting, Inc."
      (br)
      "All rights reserved."))

;; 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

;; This is used to extend our container div to include both column floats,
;; as it is a clear, non-floating element.  Note: browsers don't handle
;; <div /> -- they evidently need <div></div> -- so we force the closing
;; element with an empty string.
(define (clear)
  `(div (@ (class "clr"))
        ""))

(define (container . body)
  `(div (@ (id "wrap"))
        ,@body))

(define (content-with-sidebar sidebar . body)
  `((div (@ (id "colM"))
         ,@body)
    ,sidebar
    ,(clear)))

(define (content . body)
  (apply content-with-sidebar
         (default-sidebar)
         body))

(define (content-only . body)
  `(div (@ (id "main1"))
        ,@body))

(define (xhtml-page title . body)
  `(,(xml-literal 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 "Ursetto Consulting, Inc. specializes in UNIX software and hardware solutions.")))
                (title ,title)
                (link (@ (rel "stylesheet")
                         (href "/css/simple.css")
                         (type "text/css")))
                (link (@ (rel "stylesheet")
                         (href "/css/screen.css")
                         (type "text/css")
                         (media "screen"))))
          (body ,@body))))

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

(define (std-header category)
  `(div (@ (id "header"))
        (h1 "Ursetto Consulting, Inc.")
        ,(navbar category)))

(define (page title category . body)
  (xhtml-page title
              (std-header category)
              (container body)
              (std-footer)))

(define (std-footer)
  `(div (@ (id "footer"))
        ""
        ))

(define (render tree)
  (print (xml tree)))


;;; Macros

;; Experimental: quickly define an element at toplevel -- basically just
;; lets us omit quasiquote
(define-macro (%define-elt name)
  (let ((body (gensym)))
    `(define (,name . ,body) (cons ',name ,body))))
(define-macro (define-element . names)
  `(begin
     ,@(map (lambda (n)
              `(%define-elt ,n))
            names)))