commit d45d6c523aca997977558fbfbcb3940f76b19efb
parent 920c012417317204eae9f8111b9b8202077bf840
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 15 Sep 2013 16:28:43 +0200
refactored code from jara2wad4cl, no dependencies on postmodern and hunchentoot, separated calendar and ui
Diffstat:
| A | calendar.lisp | | | 164 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | cl-rw.asd | | | 4 | +++- |
| A | counter.lisp | | | 53 | +++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | ui.lisp | | | 711 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
4 files changed, 931 insertions(+), 1 deletion(-)
diff --git a/calendar.lisp b/calendar.lisp
@@ -0,0 +1,164 @@
+(defpackage :rw.calendar
+ (:use :cl)
+ (:export))
+
+(in-package :rw.calendar)
+
+(defun iso-date (universal-time)
+ (multiple-value-bind (ss mm hh d m y dd dl z)
+ (decode-universal-time universal-time)
+ (declare (ignore ss mm hh dd dl z))
+ (format nil "~4,'0d-~2,'0d-~2,'0d" y m d)))
+
+(defun pretty-month (month)
+ #+nil
+ (ecase month
+ (1 " １月")
+ (2 " ２月")
+ (3 " ３月")
+ (4 " ４月")
+ (5 " ５月")
+ (6 " ６月")
+ (7 " ７月")
+ (8 " ８月")
+ (9 " ９月")
+ (10 "１０月")
+ (11 "１１月")
+ (12 "１２月"))
+ (ecase month
+ (1 "Jan")
+ (2 "Feb")
+ (3 "Mar")
+ (4 "Apr")
+ (5 "May")
+ (6 "Jun")
+ (7 "Jul")
+ (8 "Aug")
+ (9 "Sep")
+ (10 "Oct")
+ (11 "Nov")
+ (12 "Dec")))
+
+(defun pretty-day (day)
+ #+nil
+ (ecase day
+ (0 " 月")
+ (1 " 火")
+ (2 " 水")
+ (3 " 木")
+ (4 " 金")
+ (5 " 土")
+ (6 " 日"))
+ (ecase day
+ (0 "Mo")
+ (1 "Tu")
+ (2 "We")
+ (3 "Th")
+ (4 "Fr")
+ (5 "Sa")
+ (6 "Su")))
+
+(defun pretty-date (universal-time)
+ (multiple-value-bind (se0 mi0 ho0 da0 mo0 ye0 dow0 dst0 tz0)
+ (decode-universal-time (get-universal-time))
+ (declare (ignore se0 mi0 ho0 dow0 dst0 tz0))
+ (multiple-value-bind (se mi ho da mo ye dow dst tz)
+ (decode-universal-time universal-time)
+ (declare (ignore se mi ho dow dst tz))
+ (if (= ye0 ye)
+ (if (and (= mo0 mo) (= da0 da))
+ "Today"
+ (format nil "~a ~d" (pretty-month mo) da))
+ (iso-date universal-time)))))
+
+(defun easter (year)
+ (let* ((h1 (floor year 100))
+ (h2 (floor year 400))
+ (m (- (+ 15 h1) h2 (floor (+ 13 (* 8 h1)) 25)))
+ (n (- (+ 4 h1) h2))
+ (a (mod year 19))
+ (b (mod year 4))
+ (c (mod year 7))
+ (d (mod (+ (* 19 a) m) 30))
+ (e (mod (+ (* 2 b) (* 4 c) (* 6 d) n) 7))
+ (f (+ 22 d e)))
+ (when (= 57 f)
+ (setq f 50))
+ (when (and (= 28 d) (= 6 e) (< 10 a))
+ (setq f 49))
+ (values year
+ (if (<= f 31)
+ 3
+ (progn (decf f 31) 4))
+ f)))
+
+;; http://seed7.sourceforge.net/algorith/date.htm
+(defun leap-year-p (year)
+ (or (and (zerop (mod year 4))
+ (not (zerop (mod year 100))))
+ (zerop (mod year 400))))
+
+(defun days-in-month (year month)
+ (if (member month '(1 3 5 7 8 10 12))
+ 31
+ (if (= 2 month)
+ (if (leap-year-p year) 29 28)
+ 30)))
+
+(defun day-of-year (year month day)
+ (+ day (svref (if (leap-year-p year)
+ #(0 31 60 91 121 152 182 213 244 274 305 335)
+ #(0 31 59 90 120 151 181 212 243 273 304 334))
+ (1- month))))
+
+(defun day-of-week (year month day)
+ (when (<= month 2)
+ (decf year)
+ (incf month 12))
+ (1+ (mod (+ year
+ (floor year 4)
+ (- (floor year 100))
+ (floor year 400)
+ (floor (* 31 (- month 2)) 12)
+ day
+ -1)
+ 7)))
+
+(defun week-of-year (year day-of-year)
+ (1+ (floor (+ day-of-year (day-of-week year 1 4) -5) 7)))
+
+(defun weekend (day)
+ (member day '(5 6)))
+
+(defun collect (n stream)
+ (loop
+ for i from 0 below n
+ collect (funcall stream)))
+
+(defun day-generator (year month first-weekday)
+ (let ((d (- first-weekday (day-of-week year month 1) -1))
+ (n (days-in-month year month)))
+ (lambda ()
+ (when (<= 1 (incf d) n)
+ d))))
+
+;;(collect 40 (day-generator 2012 7 0))
+;;(collect 40 (day-generator 2012 7 6))
+
+(defun weekday-generator (first-weekday)
+ (let ((x (nthcdr first-weekday '#1=(6 0 1 2 3 4 5 . #1#))))
+ (lambda ()
+ (car (setq x (cdr x))))))
+
+;;(collect 10 (weekday-generator 0))
+;;(collect 10 (weekday-generator 6))
+
+(defun week-generator (year month)
+ (let ((w (week-of-year year (day-of-year year month 1)))
+ (n (1+ (week-of-year year (day-of-year year 12 31)))))
+ (lambda ()
+ (when (<= 1 (incf w) n)
+ w))))
+
+;;(collect 15 (week-generator 2012 1))
+;;(collect 15 (week-generator 2012 12))
diff --git a/cl-rw.asd b/cl-rw.asd
@@ -42,4 +42,6 @@
(:file "email")
(:file "os")
(:file "net")
- (:file "concurrency")))
+ (:file "concurrency")
+ (:file "calendar")
+ (:file "ui")))
diff --git a/counter.lisp b/counter.lisp
@@ -0,0 +1,53 @@
+(defpackage :jara2wad4cl.counter
+ (:use :cl))
+
+(in-package :jara2wad4cl.counter)
+
+(defun counter-widget (i rvar)
+ (jara2wad4cl:slet ((n 0 rvar))
+ (lambda ()
+ `(:p ,i ": "
+ " " ,(jara2wad4cl:link "up" (lambda () (incf n)))
+ " " ,(jara2wad4cl:link "down" (lambda () (decf n)))
+ " " (:b ,n)))))
+
+(defun toplevel-widget ()
+ (let ((w (mapcar 'counter-widget '(1 2 3 4) '(i j x y)))
+ (w2 (jara2wad4cl::calendar-widget 2012 7)))
+ (lambda ()
+ `(:html
+ (:head
+ ((:meta :http-equiv "content-type"
+ :content "text/html;charset=utf-8"))
+ ((:meta :http-equiv "cache-control" :content "no-cache,no-store"))
+ ((:meta :http-equiv "pragma" :content "no-cache"))
+ ((:meta :http-equiv "expires" :content -1))
+ (:title "counter"))
+ (:body ,@(mapcar #'funcall w) ,(funcall w2))))))
+
+(defun deconstruct ()
+ ;;(print (hunchentoot:script-name*)) => parse REST rvars
+ (values (hunchentoot:get-parameter "s")
+ (hunchentoot:get-parameter "a")
+ (list 'i (hunchentoot:get-parameter "i")
+ 'j (hunchentoot:get-parameter "j")
+ 'x (hunchentoot:get-parameter "x")
+ 'y (hunchentoot:get-parameter "y"))))
+
+(defun construct (sid aid renv)
+ (let ((prefix "/counter/"))
+ (with-output-to-string (s)
+ (format s "~a?s=~a&a=~a" prefix sid aid)
+ (loop
+ for (k v) on renv by #'cddr
+ when v
+ do (format s "&~(~a~)=~a" k v)))))
+
+(hunchentoot:define-easy-handler (counter :uri "/counter/") ()
+ (jara2wad4cl:draw (lambda () (toplevel-widget)) 'deconstruct 'construct))
+
+;;http://ondoc.logand.com/d/1129/1/
+;;/d/1129/1/ => doc 1129 pg 1
+;;/product/show/1
+;;/people/new
+;;/people/1/edit
diff --git a/ui.lisp b/ui.lisp
@@ -0,0 +1,711 @@
+(defpackage :rw.ui
+ (:use :cl)
+ (:export :checkbox
+ :choice-widget
+ :combo-item1-widget
+ :combo-item2-widget
+ :combo-widget
+ :dialog-widget
+ :draw
+ :entry
+ :file
+ :form
+ :hbox-widget
+ :link
+ :password
+ :popup-widget
+ :radio
+ :reset
+ :slet
+ :spin
+ :submit
+ :text
+ :vbox-widget
+ :visible-widget))
+
+(in-package :rw.ui)
+
+(defun style (form)
+ (loop
+ for (k v) on form by #'cddr
+ for i from 0
+ when v
+ do (flet ((out (x)
+ (typecase x
+ (symbol (format t "~(~a~)" x))
+ (t (format t "~a" x)))))
+ (when (plusp i)
+ (write-char #\;))
+ (out k)
+ (write-char #\:)
+ (out v))))
+
+;;(style '(:one 1 :two 2 :three nil :four :hello))
+
+(defun css (form)
+ (dolist (x form)
+ (let ((style (with-output-to-string (*standard-output*) (style (cdr x)))))
+ (when style
+ (flet ((out (x)
+ (typecase x
+ (symbol (format t "~(~a~)" x))
+ (t (format t "~a" x)))))
+ (out (car x))
+ (write-char #\{)
+ (write-string style)
+ (write-char #\}))))))
+
+;;(css '((:pre :one 1 :two 2 :three nil :four :hello)))
+
+(defun html (form)
+ (labels ((esc (x)
+ (loop
+ for c across x
+ do (case c
+ (#\& (write-string "&"))
+ (#\< (write-string "<"))
+ (#\> (write-string ">"))
+ (t (write-char c)))))
+ (name (x)
+ (esc (etypecase x
+ (number (format nil "~a" x))
+ (string x)
+ (symbol (format nil "~(~a~)" x)))))
+ (attribute (k v)
+ (unless (or (not v)
+ (and (consp v)
+ (eq :style (car v))
+ (not (cdr v))))
+ (write-char #\space)
+ (name k)
+ (write-char #\=)
+ (write-char #\")
+ (loop
+ for c across (etypecase v
+ (string v)
+ (number (format nil "~a" v))
+ (symbol (format nil "~(~a~)" v))
+ (cons
+ (ecase (car v)
+ (:style
+ (with-output-to-string (*standard-output*)
+ (style (cdr v)))))))
+ do (case c
+ (#\& (write-string "&"))
+ (#\" (write-string """))
+ (t (write-char c))))
+ (write-char #\")))
+ (element (e a b)
+ (case e
+ (:<style
+ (element :style a
+ (list
+ (with-output-to-string (*standard-output*)
+ (css b)))))
+ (t
+ (write-char #\<)
+ (name e)
+ (loop for (k v) on a by #'cddr do (attribute k v))
+ (when b (write-char #\>))
+ (mapc #'rec b)
+ (when b (write-char #\<))
+ (write-char #\/)
+ (when b (name e))
+ (write-char #\>))))
+ (rec (x)
+ (if (atom x)
+ (when x (name x))
+ (destructuring-bind (y &rest z) x
+ (if (atom y)
+ (element y nil z)
+ (element (car y) (cdr y) z))))))
+ (princ "<!DOCTYPE html>")
+ (terpri)
+ (rec form)))
+
+(defvar *click-link*)
+(defvar *click-form*)
+
+(defun parse-nat0 (x)
+ (when (and x (not (equal "" x)) (every #'digit-char-p x))
+ (parse-integer x)))
+
+(defun parse-ismap-value (x)
+ (when (and x (not (equal "" x)) (char= #\? (char x 0)))
+ (let ((i (position #\, x)))
+ (when (plusp i)
+ (values (parse-nat0 (subseq x 1 i))
+ (parse-nat0 (subseq x (1+ i))))))))
+
+(defun html-reply (form)
+ (setf (hunchentoot:content-type*) "text/html;charset=utf-8"
+ (hunchentoot:header-out "cache-control") "no-cache, no-store"
+ (hunchentoot:header-out "pragma") "no-cache"
+ (hunchentoot:header-out "expires") "-1")
+ (with-output-to-string (*standard-output*)
+ (html form)))
+
+(defvar *register*)
+
+(defun make-state (create)
+ (let (svars svals)
+ (flet ((store (actions)
+ (let ((env (mapcar (lambda (k) (funcall (car k))) svars)))
+ (when actions
+ (push (cons env actions) svals)))))
+ (values
+ (let ((*register* (lambda (get set)
+ (push (cons get set) svars))))
+ (prog1 (funcall create)
+ (store (list 0 (lambda ())))))
+ (lambda (aid actions2 fn)
+ (let ((cached (find-if (lambda (x) (getf (cdr x) aid)) svals)))
+ ;;(print (list :@@@======== aid cached))
+ (if cached
+ (destructuring-bind (env1 &rest actions1) cached
+ (mapc (lambda (k v) (funcall (cdr k) v)) svars env1)
+ ;;(print (list :@@@-a env1 svals))
+ (unwind-protect
+ (funcall fn
+ (lambda (k p)
+ (let ((v (getf actions1 k)))
+ (print (list :@@@ k p v))
+ (when v
+ (if p
+ (funcall v p)
+ (funcall v)))))
+ (lambda ()
+ (unless env1
+ (setq svals (delete cached svals)))))
+ (store (funcall actions2))
+ #+nil(print (list :@@@-z svals))))
+ ;; TODO indicate unexpected aid when not cached?
+ (funcall fn
+ (lambda (k p) (declare (ignore k p)))
+ (lambda ())))))))))
+
+(defmacro with-state ((state aid actions2 dispatch clear) &body body)
+ `(funcall ,state ,aid ,actions2 (lambda (,dispatch ,clear) ,@body)))
+
+(defvar *renv*)
+
+(defun handle-form (form)
+ (ecase (car form)
+ (:redirect
+ (destructuring-bind (target) (cdr form)
+ (hunchentoot:redirect target)))
+ (:html (html-reply form))))
+
+(defun make-stepper (sid create construct)
+ (let ((n 0))
+ (multiple-value-bind (draw state) (make-state create)
+ (lambda (aid)
+ (let (actions2)
+ (with-state (state aid (lambda () actions2) dispatch clear)
+ ;;(print (list :@@@ (hunchentoot:query-string*)))
+ (handle-form
+ (ecase (hunchentoot:request-method*)
+ (:post
+ (dolist (x (hunchentoot:post-parameters*))
+ (destructuring-bind (k &rest v) x
+ (let ((kk (when (char= #\z (char k 0))
+ (parse36 (subseq k 1)))))
+ (funcall dispatch kk v))))
+ (funcall dispatch aid nil)
+ `(:redirect ,(funcall construct sid (pretty36 aid) *renv*)))
+ (:get
+ (funcall dispatch aid nil)
+ (funcall clear)
+ (flet ((next (v)
+ (let ((k (incf n)))
+ (push v actions2)
+ (push k actions2)
+ k)))
+ (let* ((*click-link*
+ (lambda (click &optional idempotent)
+ ;; TODO let rvars, "let explicit svars",
+ ;; funcall click idempotent in regards to
+ ;; implicit svars
+ (let ((*renv* (copy-list *renv*)))
+ ;;(funcall idempotent) TODO !!!!!!!!!!!!!!!!!
+ (funcall construct sid (pretty36 (next click))
+ *renv*))))
+ (*click-form*
+ (lambda (set)
+ (format nil "z~a" (pretty36 (next set))))))
+ (funcall draw))))))))))))
+
+(defun register (get set)
+ (funcall *register* get set))
+
+(defmacro slet (vars &body body) ;; TODO renv
+ `(let ,(mapcar (lambda (x) (subseq x 0 2)) vars)
+ ,@(mapcar (lambda (x)
+ `(register (lambda () ,(car x))
+ (lambda (v) (setq ,(car x) v))))
+ vars)
+ ,@body))
+
+(defparameter *session-lifespan* (* 60 60))
+
+(defun make-session (sid create construct)
+ (let ((lock (bt:make-lock "session ~s"))
+ (touched (get-universal-time))
+ (stepper (make-stepper sid create construct)))
+ (lambda (aid)
+ (bt:with-lock-held (lock)
+ (cond
+ ((eq t aid)
+ (< (- (get-universal-time) touched) *session-lifespan*))
+ (t
+ (setq touched (get-universal-time))
+ (funcall stepper aid)))))))
+
+(defun rd (cnt)
+ (let ((s *standard-input*))
+ (do ((n 0 (1+ n))
+ (z (read-byte s) (+ (* 256 z) (read-byte s))))
+ ((< cnt n) z))))
+
+(defun pretty36 (x)
+ (when (and (integerp x) (<= 0 x))
+ (let ((*print-base* 36))
+ (format nil "~(~a~)" x))))
+
+(defun parse36 (x)
+ (flet ((base36 (x)
+ (find x "0123456789abcdefghijklmnopqrstuvwxyz")))
+ (when (and x (not (equal "" x)) (every #'base36 x))
+ (parse-integer x :radix 36))))
+
+;;(parse36 (pretty36 123456789))
+;;(parse36 (pretty36 37))
+;;(parse36 (pretty36 109))
+
+(defun generate-sid ()
+ ;; (< (expt 36 12) (expt 2 64) (expt 36 13))
+ (pretty36
+ #+nil(random #.(expt 36 13))
+ (with-open-file (*standard-input* "/dev/urandom"
+ :element-type '(unsigned-byte 8))
+ (rd 4))))
+
+(defun make-pool ()
+ (let ((sessions (make-hash-table :test #'equal))
+ (lock (bt:make-lock "pool ~s")))
+ (lambda (create deconstruct construct)
+ (multiple-value-bind (sid aid *renv*) (funcall deconstruct)
+ (setq aid (parse36 aid))
+ (funcall
+ (bt:with-lock-held (lock)
+ (maphash (lambda (k v)
+ (unless (funcall v t)
+ (remhash k sessions)))
+ sessions)
+ (let ((x (and sid aid (gethash sid sessions))))
+ (if x
+ (lambda () (funcall x aid))
+ (do ()
+ ((not (gethash (setq sid (generate-sid)) sessions))
+ (setf (gethash sid sessions)
+ (make-session sid create construct))
+ (lambda ()
+ (hunchentoot:redirect
+ (funcall construct sid (pretty36 0) *renv*)))))))))))))
+
+(defparameter *pool* (make-pool))
+
+(defun draw (create deconstruct construct)
+ (funcall *pool* create deconstruct construct))
+
+(defun link (draw click &key style (enabled t))
+ (flet ((%draw ()
+ (if (functionp draw) (funcall draw) draw)))
+ (if enabled
+ `((:a :href ,(funcall *click-link* click) :style ,style) ,(%draw))
+ `((:span :style "color:gray") ,(%draw)))))
+
+(defun input (set type value enabled editable style size maxlength)
+ `((:input
+ :name ,(when (and set enabled editable) (funcall *click-form* set))
+ :type ,type
+ :value ,value
+ :disabled ,(unless enabled :disabled)
+ :readonly ,(unless editable :readonly)
+ :style ,style
+ :size ,size
+ :maxlength ,maxlength)))
+
+(defun submit (label set &key (enabled t) style)
+ (input set "submit" label enabled t style nil nil))
+
+(defun yes () t)
+(defun no ())
+(defun no1 (x) (declare (ignore x)))
+
+(defun reset (label &key (enabled t) style)
+ (input 'no1 "reset" label enabled t style nil nil))
+
+(defun password (set &key (enabled t) (editable t) style)
+ (input set "password" nil enabled editable style nil nil))
+
+(defun entry (set text &key (enabled t) (editable t) style size maxlength)
+ (input set "text" text enabled editable style size maxlength))
+
+(defun entry (set text &key (enabled t) (editable t) style size maxlength)
+ (input set "text" text enabled editable style size maxlength))
+
+(defun file (set &key (enabled t) style size)
+ (input set "file" nil enabled t style size nil))
+
+(defun text (set text nrows ncols &key (enabled t) (editable t) style)
+ `((:textarea
+ :name ,(funcall *click-form* set)
+ :rows ,nrows
+ :cols ,ncols
+ :disabled ,(unless enabled :disabled)
+ :readonly ,(unless editable :readonly)
+ :style ,style)
+ ,text))
+
+(defun form (draw)
+ `((:form
+ :action ,(funcall *click-link* 'no)
+ :method "post"
+ :enctype "multipart/form-data"
+ :style "padding:0;margin:0;border:0")
+ ((:div :style "width:0;height:0;overflow:hidden") ,(submit nil 'no1))
+ ,(if (functionp draw) (funcall draw) draw)))
+
+(defun visible-widget (show draw)
+ (lambda ()
+ (when (funcall show)
+ (funcall draw))))
+
+(defun popup-widget (show draw)
+ (visible-widget
+ show
+ (lambda ()
+ `((:div :style (:style
+ :position :absolute
+ :background-color :white
+ :border "solid 1px"
+ :padding "0.5em"))
+ ((:div :style (:style :position :relative))
+ ,(funcall draw))))))
+
+(defun screen-direction-combo-widget (popup selected click align)
+ (combo-widget
+ popup
+ selected
+ click
+ (list 'no 'no 'no 'no 'no 'no 'no 'no 'no)
+ (flet ((item2 (label &rest %align)
+ (combo-item2-widget label (apply align %align))))
+ (list
+ (item2 "Top Left" :top :left)
+ (item2 "Top Center" :top :center)
+ (item2 "Top Right" :top :right)
+ (item2 "Center Left" :center :left)
+ (item2 "Center" :center :center)
+ (item2 "Center Right" :center :right)
+ (item2 "Bottom Left" :bottom :left)
+ (item2 "Bottom Center" :bottom :center)
+ (item2 "Bottom Right" :bottom :right)))))
+
+(defun screen-direction-graphics-widget (popup selected click align) ;; TODO selected
+ (dropdown-widget
+ click
+ (lambda ())
+ popup
+ (let ((n (flet ((item2 (label &rest %align) ;; TODO label as hint
+ (apply align %align)))
+ (list
+ (item2 "Top Left" :top :left)
+ (item2 "Top Center" :top :center)
+ (item2 "Top Right" :top :right)
+ (item2 "Center Left" :center :left)
+ (item2 "Center" :center :center)
+ (item2 "Center Right" :center :right)
+ (item2 "Bottom Left" :bottom :left)
+ (item2 "Bottom Center" :bottom :center)
+ (item2 "Bottom Right" :bottom :right)))))
+ (lambda ()
+ `(:pre
+ ,@(loop
+ with y = n
+ ;;with s = (funcall selected)
+ for i from 0
+ for x across "X | X | X
+--+---+--
+X | X | X
+--+---+--
+X | X | X"
+ collect (cond
+ ;; ((= s i)
+ ;; `(:b (string x)))
+ ((char= #\X x)
+ (jara2wad4cl:link (string x)
+ (let ((z (pop y)))
+ (lambda () (funcall z)))))
+ (t (string x)))))))))
+
+(defun dialog-widget (show close draw1 draw2 &optional draw3)
+ (visible-widget
+ show
+ (let* ((halign :center)
+ (valign :center)
+ popup
+ (cw (flet ((align (v h)
+ (lambda ()
+ (setq popup nil
+ halign h
+ valign v))))
+ (screen-direction-graphics-widget ;;screen-direction-combo-widget
+ (lambda () popup)
+ (lambda () 4)
+ (lambda () (setq popup (not popup)))
+ #'align))))
+ (lambda ()
+ (let (#+nil(id1 (funcall *click-form* 'no1))
+ #+nil(id2 (funcall *click-form* 'no1)))
+ `((:table :style (:style :position :fixed ;;:absolute
+ :left 0
+ :top 0
+ :width "100%"
+ :height "100%"
+ :padding 0
+ :margin 0
+ :border 0
+ :pointer-events "none"))
+ (:tr
+ ((:td :align ,halign :valign ,valign)
+ ((:table :style (:style :pointer-events "auto"
+ :border "solid 1px"
+ :background-color "#eef"))
+ ((:tr :style (:style :background-color "#dde" :padding "0.3em"))
+ (:td ,(funcall cw)
+ ,(funcall draw1)
+ ((:span :style "font-family:monospace")
+ " "
+ ,(when close (link "X" close))))
+ #+nil
+ (:td ((:span :style "font-family:monospace")
+ ,(link "X" close)
+ " ")
+ ,(funcall draw1)
+ ((:span :style "font-family:monospace")
+ " "
+ ,(link "L" (lambda () (setq halign :left)))
+ ,(link "C" (lambda () (setq halign :center)))
+ ,(link "R" (lambda () (setq halign :right)))
+ "-"
+ ,(link "T" (lambda () (setq valign :top)))
+ ,(link "C" (lambda () (setq valign :center)))
+ ,(link "B" (lambda () (setq valign :bottom))))))
+ (:tr (:td ,(funcall draw2)))
+ , (when draw3
+ `(:tr (:td ,(funcall draw3))))))))))))
+ #+nil
+ (visible-widget
+ show
+ (lambda ()
+ (let (#+nil(id1 (funcall *click-form* 'no1))
+ #+nil(id2 (funcall *click-form* 'no1)))
+ `((:div :style (:style :position :absolute :left 0 :top 0))
+ ((:div :style (:style :position :relative))
+ ((:div
+ ;;:id ,id1
+ :style (:style
+ ;;:position "absolute"
+ :border "solid 1px"
+ :background-color "#eef"))
+ ((:div
+ ;;:id ,id2
+ :style (:style :background-color "#dde" :padding "0.3em"))
+ ,(funcall draw1))
+ ((:div :style (:style :padding "0.5em")) ,(funcall draw2))
+ , (when draw3
+ `((:div :style (:style :padding "0.5em"))
+ ,(funcall draw3))))
+ #+nil
+ ((:script :type "text/javascript")
+ "draggable(w('" ,id1 "'),w('" ,id2 "'),dragDialog);")))))))
+
+(defun combo-item1-widget (label &key style)
+ (lambda ()
+ (if style
+ `((:span :style (:style :padding "0.1em" ,@style)) ,label)
+ label)))
+
+(defun combo-item2-widget (label click &key style1 style2)
+ (lambda ()
+ `((:td :style (:style ,@style1))
+ ,(link label click :style `(:style ,@style2)))
+ #+nil
+ `((:li :style (:style :padding "0.1em" ,@style1))
+ ,(link label click :style `(:style ,@style2)))))
+
+(defun dropdown-widget (click label popup draw)
+ (let ((pw (popup-widget popup draw)))
+ (lambda ()
+ `(:span ,(link "^" click) " " ,(funcall label) ,(funcall pw)))))
+
+(defun combo-widget (popup selected click items1 items2 &optional (ncols 1))
+ (dropdown-widget
+ click
+ (lambda () (funcall (nth (funcall selected) items1)))
+ popup
+ (lambda ()
+ `(:table
+ ,@ (ecase ncols
+ (1 (loop
+ for x in items2
+ collect `(:tr ,(funcall x))))
+ (2 (loop
+ for (x y) on items2 by #'cddr
+ collect `(:tr ,(funcall x) ,(funcall y))))))
+ #+nil
+ `((:ul :style (:style
+ :top 0
+ :left 0
+ :list-style :none
+ :margin 0
+ :padding 0))
+ ,@(mapcar #'funcall items2)))))
+
+(defun checkbox (selected click)
+ `((:span :style (:style :font-family :monospace))
+ "["
+ ,(link (lambda () (if (funcall selected) "X" "-")) click)
+ "]"))
+
+(defun radio (selected click)
+ `((:span :style (:style :font-family :monospace))
+ "("
+ ,(link (lambda () (if (funcall selected) "o" "-")) click)
+ ")"))
+
+(defun spin (get set min max &key enabled)
+ (let ((x (funcall get)))
+ #+nil
+ `((:input
+ :name ,(funcall *click-form* set)
+ :type "number"
+ :min ,min
+ :max ,max
+ :value ,x
+ ;;:disabled ,(unless enabled :disabled)
+ ;;:readonly ,(unless editable :readonly)
+ ;;:style ,style
+ ;;:size ,size
+ ;;:maxlength ,maxlength
+ ))
+ `(:span
+ , (let ((n (max (length (princ-to-string min))
+ (length (princ-to-string max)))))
+ (entry (lambda (x)
+ (let ((y (parse-nat0 x)))
+ (when y
+ (funcall set (max min (min max y))))))
+ x
+ :enabled enabled
+ :style "text-align:right"
+ :size n
+ :maxlength n))
+ " "
+ ,(if enabled
+ (link "▼" (lambda () (funcall set (max min (1- x)))))
+ "▼")
+ " "
+ ,(if enabled
+ (link "▲" (lambda () (funcall set (min max (1+ x)))))
+ "▲"))))
+
+(defun hbox-widget (children &optional separator)
+ (if separator
+ (lambda ()
+ `(:span
+ ,@(loop
+ for x in children
+ for i from 0
+ appending (if (plusp i)
+ (list (if (eq t separator) " " separator)
+ (funcall x))
+ (list (funcall x))))))
+ (lambda ()
+ `(:table ;;(:table :border 0 :cellpadding 0 :cellspacing 0)
+ (:tr ,@(mapcar (lambda (x) `(:td ,(funcall x))) children))))))
+
+(defun vbox-widget (children &optional div)
+ (if div
+ (lambda ()
+ `(:div
+ ,@(mapcar (lambda (x) `(:div ,(funcall x))) children)))
+ (lambda ()
+ `(:table ;;(:table :border 0 :cellpadding 0 :cellspacing 0)
+ ,@(mapcar (lambda (x) `(:tr (:td ,(funcall x)))) children)))))
+
+(defun choice-widget (selected click choices &optional horizontal)
+ (let* ((radios (loop
+ for c in choices
+ for i from 0
+ collect (let ((i i))
+ (lambda ()
+ (radio
+ (lambda () (= i (funcall selected)))
+ (lambda () (funcall click i)))))))
+ (children (mapcar (lambda (r c) (hbox-widget (list r c) t))
+ radios
+ choices)))
+ (if horizontal
+ (hbox-widget children)
+ (vbox-widget children))))
+
+(defun calendar-widget (year month &key (first-weekday 0) (show-weeks t))
+ (lambda ()
+ (let ((weeks (when show-weeks (week-generator year month))))
+ `((:table :style "font-family:monospace")
+ (:tr
+ ,@(when weeks '((:td "")))
+ ((:td :colspan 3 :align "center")
+ , (let ((y year)
+ (m (1- month)))
+ (when (< m 1)
+ (decf y)
+ (setq m 12))
+ (link "<" (lambda () (setq year y month m))))
+ " " ,(pretty-month month) " "
+ , (let ((y year)
+ (m (1+ month)))
+ (when (< 12 m)
+ (incf y)
+ (setq m 1))
+ (link ">" (lambda () (setq year y month m)))))
+ ((:td :align "center") ,(link "@" (lambda ())))
+ ((:td :colspan 3 :align "center")
+ , (let ((y (1- year)))
+ (link "<" (lambda () (setq year y))))
+ " " ,year " "
+ , (let ((y (1+ year)))
+ (link ">" (lambda () (setq year y))))))
+ (:tr
+ ,@(when weeks '((:td " ")))
+ ,@(loop
+ with g = (weekday-generator first-weekday)
+ for i from 0 below 7
+ for n = (funcall g)
+ collect `((:td :style (:style :color ,(when (weekend n) "red")))
+ ,(pretty-day n))))
+ ,@(loop
+ with g = (day-generator year month first-weekday)
+ for i from 0 below 6
+ collect `(:tr
+ ,@(when weeks `(((:td :align "right") ,(funcall weeks))))
+ ,@(loop
+ for j from 0 below 7
+ for d = (funcall g)
+ collect `((:td :align "right")
+ ,(if d
+ (link d (lambda ()))
+ "")))))))))
