+;;;; -*- 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: genpage.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $
+;;;;
+;;;; 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))
+
+
+
+