;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          genpage.lisp
;;;; Purpose:       HTML Pages creation functions
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Jun 2003
;;;;
;;;; $Id$
;;;;
;;;; This file, part of wol, is Copyright (c) 2003 by Kevin M. Rosenberg
;;;; *************************************************************************

(in-package #:wol)

(defvar *header-table* (make-hash-table :size 100 :test 'eq)
  "Table of header functions indexed by site")
(defvar *banner-table* (make-hash-table :size 100 :test 'eq)
  "Table of banner functions indexed by site")
(defvar *contents-table* (make-hash-table :size 100 :test 'eq)
  "Table of table of content functions indexed by site")
(defvar *page-table* (make-hash-table :size 100 :test 'equal)
  "Table of page functions indexed by site-pagename")
(defvar *footer-table* (make-hash-table :size 100 :test 'eq)
  "Table of footer functions indexed by site")

(defun maybe-gen-header (site plist command)
  (awhen (gethash site *header-table*) (funcall it plist command)))

(defun maybe-gen-footer (site plist command)
  (awhen (gethash site *footer-table*) (funcall it plist command)))

(defun maybe-gen-banner (site plist command)
  (awhen (gethash site *banner-table*) (funcall it plist command)))

(defun maybe-gen-contents (site plist command)
  (awhen (gethash site *contents-table*) (funcall it plist command)))

(defmacro def-stdsite-header (site &body body)
  `(setf (gethash ',site *header-table*)
	 #'(lambda (plist command)
	     (declare (ignorable plist command))
	     ,@body)))

(defmacro def-stdsite-footer (site &body body)
  `(setf (gethash ',site *footer-table*)
	 #'(lambda (plist command)
	     (declare (ignorable plist command))
	     ,@body)))

(defmacro def-stdsite-banner (site &body body)
  `(setf (gethash ',site *banner-table*)
	 #'(lambda (plist command)
	     (declare (ignorable plist command))
	     ,@body)))

(defmacro def-stdsite-contents (site &body body)
  `(setf (gethash ',site *contents-table*)
	 #'(lambda (plist command)
	     (declare (ignorable plist command))
	     ,@body)))


(defmacro gen-std-head (title site plist command &body body)
  `(html
    (:head 
     (when ,title
       (html (:title ,title)))
     (maybe-gen-header ',site ,plist ,command)
     ,@body)))

(defmacro gen-std-footer (site plist command)
  `(html
    ((:div class "disclaimsec")
     (maybe-gen-footer ',site ,plist ,command))))


(defmacro gen-std-body (site plist command &body body)
  `(progn
    ;;(maybe-gen-banner ',site ,plist ,command)
    (html
     ((:div class "stdbodytable")
      ((:div :style "width:160px;position:fixed;left:3;right:auto;top:0")
       ((:img :src "/images/umlisp-logo.png" :alt "logo" 
	      :style "border:0;width:160;height:55"))
       (maybe-gen-contents ',site ,plist ,command))
      ((:div :style "position:absolute;left:170px;top:0")
       ((:div :style
	      "font-size:20pt;color:#777;text-align:center;margin-bottom:4pt")
	"High Performance Common Lisp Interface to the Unified Medical Langauge System")
       ,@body
	(gen-std-footer ,site ,plist ,command))))))


(defun ml-head (title-str &optional (css "http://b9.com/main.css") altcss)
  (html
   (:head
    ((:link :rel "stylesheet" :href css :type "text/css"))
    (when altcss
      (html
       ((:link :rel "stylesheet" :type "text/css"
	       :href (if (eq altcss t)
			 "http://b9.com/umls.css" altcss)))))
    (when title-str
      (html (:title (lml-write-string title-str)))))))


(defun page-prologue (title format css altcss)
  (ecase format
    (:xml
     (dtd-prologue format)
     (lml-format "<?xml-stylesheet type=\"text/css\" href=\"~A\" ?>~%"
		 (aif css it "http://b9.com/umlsxml.css"))
     (lml-write-string "<pagedata xmlns:xlink=\"http://www.w3.org/1999/xlink\" xmlns:html=\"http://www.w3.org/TR/REC-html40\">")
     (lml-write-char #\Newline)
     (when title
       (lml-format "<pagetitle>~A</pagetitle>" title))
     (lml-write-char #\Newline))
    (:html
     (dtd-prologue format)
     (lml-write-string "<html>")
     (ml-head title (aif css it "http://b9.com/main.css") altcss)
     (lml-write-string "<body>"))
    ((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
      :xhtml10-frameset)
     (dtd-prologue format)
     (lml-write-string
      "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\">")
     (ml-head title (aif css it "http://b9.com/main.css") altcss)
     (lml-write-string "<body>"))
    (:text
     ;; nothing to do
     )))

(defun page-epilogue (format)
  (ecase format
    ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
      :xhtml10-frameset)
     (lml-write-string "</body></html>"))
    (:xml
     (lml-print "</pagedata>"))
    (:text
     ;; nothing to do
     )))



(defun page-keyword-format (format)
  (ecase format
    ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
	    :xhtml10-frameset)
     :html)
    (:xml
     :xml)
    (:text
     :text)))

(defmacro with-lml-page ((title &key (format :xhtml) css altcss (precompute t))
			 &rest body)
  (let ((fmt (gensym "FMT-")))
    `(let ((,fmt ,format))
      (with-ml-page (:format (page-keyword-format ,fmt) :precompute ,precompute)
	(let ((*html-stream* *modlisp-socket*))
	  (prog1
	      (progn
		(page-prologue ,title ,format ,css ,altcss)
		,@body)
	    (page-epilogue ,format)))))))


(defmacro gen-std-page ((site plist command title &key css altcss
			      (precompute t) (format :xhtml))
			&body body)
  `(let ((*print-circle* nil))
    (with-lml-page (,title :css ,css :altcss ,altcss :format ,format
		    :precompute ,precompute)
      (gen-std-body ,site ,plist ,command ,@body))))




(defmacro with-ml-link ((href &key (format :html)) &rest body)
  `(case ,format
     (:xml
      (lml-princ "<xmllink xlink:type=\"simple\" xlink:href=\"")
      (lml-princ ,href)
      (lml-princ "\">")
      ,@body
      (lml-princ "</xmllink>"))
    (:ie-xml
      (lml-princ "<html:a href=\"")
      (lml-princ ,href)
      (lml-princ "\">")
     ,@body
     (lml-princ "</html:a>"))
    ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
	    :xhtml10-frameset)
      (lml-princ "<a href=\"")
     (lml-princ ,href)
     (lml-princ "\">")
     ,@body
     (lml-princ "</a>"))))

(defun ml-link (page name session-id &key (format :html))
  (case format
    ((:html :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional
	    :xhtml10-frameset)
     (html
      ((:div class "homelink")
       "Return to "
       (with-ml-link ((make-ml-url page :session-id session-id :html t))
	 (lml-write-string name))
       " page.")))
    ((:xml :ie-xml)
     (lml-princ "<homelink>Return to ")
     (with-ml-link ((make-ml-url page :session-id session-id :html t)
		    :format format)
       (lml-write-string name))
     (lml-write-string " page.</homelink>"))))

(defun ml-home-link (session-id &key (format :html))
  (ml-link "index" "home" session-id :format format))

(defun ml-search-link (session-id &key (format :html))
  (ml-link "search" "search" session-id :format format))