-(in-package :lml)
-
-;;; Not currently used
-
-(defun brs (&optional (n 1))
- (fresh-line)
- (dotimes (i n)
- (princ "<br>"))
- (terpri))
-
-
-(defun html-file (base &optional (ext 'html))
- (format nil "~(~A~).~(~A~)" base ext))
-
-(defmacro link-item (dest text)
- `(progn
- (princ "<li>")
- (link ,dest
- (princ ,text))))
-
-(defun button (dest text)
- `(progn
- (princ "[ ")
- (link ,dest
- (princ ,text))
- (format t " ]~%")))
-
-
-(defun map3 (fn lst)
- (labels ((rec (curr prev next left)
- (funcall fn curr prev next)
- (when left
- (rec (car left)
- curr
- (cadr left)
- (cdr left)))))
- (when lst
- (rec (car lst) nil (cadr lst) (cdr lst)))))
-
-
-(defparameter *sections* nil)
-
-(defstruct item
- id title text)
-
-(defstruct section
- id title items)
-
-(defmacro defitem (id title text)
- `(setf ,id
- (make-item :id ',id
- :title ,title
- :text ,text)))
-
-(defmacro defsection (id title &body items)
- `(setf ,id
- (make-section :id ',id
- :title ,title
- :items (list ,@items))))
-
-(defmacro defsite (&body sections)
- `(progn
- (setf *sections* ,sections)))
-
-
-(defconstant contents "contents")
-(defconstant index "index")
-
-(defun gen-contents (&optional (sections *sections*))
- (page (html-file contents)
- contents
- (ol
- (dolist (s sections)
- (link-item (section-id s) (section-title s))
- (brs 2))
- (link-item index (string-capitalize index)))))
-
-(defun gen-index (&optional (sections *sections*))
- (page (html-file index)
- index
- (ol
- (dolist (i (all-items sections))
- (link-item (item-id i) (item-title i))
- (brs 2)))))
-
-(defun all-items (sections)
- (let ((is nil))
- (dolist (s sections)
- (dolist (i (section-items s))
- (setf is (merge 'list (list i) is #'title<))))
- is))
-
-(defun title< (x y)
- (string-lessp (item-title x) (item-title y)))
-
-
-(defun gen-site ()
- (map3 #'gen-section *sections*)
- (gen-contents)
- (gen-index))
-
-(defun gen-section (sect <sect sect>)
- (page (html-file (section-id sect))
- (section-title sect)
- (progn
- (with ol
- (map3 #'(lambda (item <item item>)
- (link-item (item-id item)
- (item-title item))
- (brs 2)
- (gen-item sect item <item item>))
- (section-items sect)))
- (brs 3)
- (gen-move-buttons (if <sect (section-id <sect))
- contents
- (if sect> (section-id sect>))))))
-
-(defun gen-item (sect item <item item>)
- (page (html-file (item-id item))
- (item-title item)
- (progn
- (princ (item-text item))
- (brs 3)
- (gen-move-buttons (if <item (item-id <item))
- (section-id sect)
- (if item> (item-id item>))))))
-
-(defun gen-move-buttons (back up forward)
- (if back (button back "Back"))
- (if up (button up "Up"))
- (if forward (button forward "Forward")))