pgsite.cl

   1 (in-package :lml)
   2
   3 ;;; Not currently used
   4
   5 (defun brs (&optional (n 1))
   6   (fresh-line)
   7   (dotimes (i n)
   8     (princ "<br>"))
   9   (terpri))
  10
  11
  12 (defun html-file (base &optional (ext 'html))
  13   (format nil "~(~A~).~(~A~)" base ext))
  14
  15 (defmacro link-item (dest text)
  16   `(progn
  17      (princ "<li>")
  18      (link ,dest
  19            (princ ,text))))
  20
  21 (defun button (dest text)
  22   `(progn
  23      (princ "[ ")
  24      (link ,dest
  25            (princ ,text))
  26      (format t " ]~%")))
  27
  28
  29 (defun map3 (fn lst)
  30   (labels ((rec (curr prev next left)
  31              (funcall fn curr prev next)
  32              (when left
  33                (rec (car left)
  34                     curr
  35                     (cadr left)
  36                     (cdr left)))))
  37     (when lst
  38       (rec (car lst) nil (cadr lst) (cdr lst)))))
  39
  40
  41 (defparameter *sections* nil)
  42
  43 (defstruct item
  44   id title text)
  45
  46 (defstruct section
  47   id title items)
  48
  49 (defmacro defitem (id title text)
  50   `(setf ,id
  51          (make-item :id     ',id
  52                     :title  ,title
  53                     :text   ,text)))
  54
  55 (defmacro defsection (id title &body items)
  56   `(setf ,id
  57          (make-section :id    ',id
  58                        :title ,title
  59                        :items (list ,@items))))
  60
  61 (defmacro defsite (&body sections)
  62   `(progn
  63     (setf *sections* ,sections)))
  64
  65
  66 (defconstant contents "contents")
  67 (defconstant index    "index")
  68
  69 (defun gen-contents (&optional (sections *sections*))
  70   (page (html-file contents)
  71         contents
  72         (ol
  73          (dolist (s sections)
  74            (link-item (section-id s) (section-title s))
  75            (brs 2))
  76          (link-item index (string-capitalize index)))))
  77
  78 (defun gen-index (&optional (sections *sections*))
  79   (page (html-file index)
  80         index
  81         (ol
  82          (dolist (i (all-items sections))
  83            (link-item (item-id i) (item-title i))
  84            (brs 2)))))
  85
  86 (defun all-items (sections)
  87   (let ((is nil))
  88     (dolist (s sections)
  89       (dolist (i (section-items s))
  90         (setf is (merge 'list (list i) is #'title<))))
  91     is))
  92
  93 (defun title< (x y)
  94   (string-lessp (item-title x) (item-title y)))
  95
  96
  97 (defun gen-site ()
  98   (map3 #'gen-section *sections*)
  99   (gen-contents)
 100   (gen-index))
 101
 102 (defun gen-section (sect <sect sect>)
 103   (page (html-file (section-id sect))
 104         (section-title sect)
 105         (progn
 106           (with ol
 107                 (map3 #'(lambda (item <item item>)
 108                           (link-item (item-id item)
 109                                      (item-title item))
 110                           (brs 2)
 111                           (gen-item sect item <item item>))
 112                       (section-items sect)))
 113           (brs 3)
 114           (gen-move-buttons (if <sect (section-id <sect))
 115                             contents
 116                             (if sect> (section-id sect>))))))
 117
 118 (defun gen-item (sect item <item item>)
 119   (page (html-file (item-id item))
 120         (item-title item)
 121         (progn
 122           (princ (item-text item))
 123           (brs 3)
 124           (gen-move-buttons (if <item (item-id <item))
 125                             (section-id sect)
 126                             (if item> (item-id item>))))))
 127
 128 (defun gen-move-buttons (back up forward)
 129   (if back (button back "Back"))
 130   (if up (button up "Up"))
 131   (if forward (button forward "Forward")))