commit 24f97a5702c9ff37a23bd5170bb5a69d1507e170
parent 7654bf9d7a108891ccce09d14fb0bcb339fd20e3
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 1 Nov 2014 12:59:32 +0100
demo-zappel added
Diffstat:
2 files changed, 235 insertions(+), 0 deletions(-)
diff --git a/cl-rw-demo-zappel.asd b/cl-rw-demo-zappel.asd
@@ -0,0 +1,31 @@
+;;; -*- lisp; -*-
+
+;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(asdf:defsystem :cl-rw-demo-zappel
+ :author "Tomas Hlavaty"
+ :maintainer "Tomas Hlavaty"
+ :licence "MIT"
+ :depends-on (:cl-rw)
+ :serial t
+ :components ((:file "demo-zappel")))
diff --git a/demo-zappel.lisp b/demo-zappel.lisp
@@ -0,0 +1,204 @@
+;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.demo.zappel
+ (:use :cl))
+
+(in-package :rw.demo.zappel)
+
+(defun %random ()
+ (- #+linux
+ (with-open-file (s "/dev/urandom" :element-type '(unsigned-byte 8))
+ (read-byte s))
+ #-linux ;; TODO this returns always the same number, due to random state and threads
+ (random n)
+ 128))
+
+(defun draw-canvas (pos i seq click)
+ (flet ((hline (y x1 x2 stroke)
+ `((:line :x1 ,x1 :y1 ,y :x2 ,x2 :y2 ,y :stroke ,stroke))))
+ (let* ((n (length seq))
+ (w (* 10 (1- n)))
+ (h 300))
+ `((:svg :xmlns "http://www.w3.org/2000/svg"
+ :xmlns\:xlink "http://www.w3.org/1999/xlink"
+ :style "border:1px solid black"
+ :with ,w :height ,h :viewbox ,(format nil "0 0 ~d ~d" w h))
+ ((:text :x 20 :y 20) ,(aref seq (mod i n)))
+ ((:g
+ :transform ,(format nil "translate(0 ~d) scale(1 -1) translate(0.5 ~d.5)"
+ h (floor h 2)))
+ ,(hline 0 0 w "red")
+ ((:g :transform ,(format nil "translate(0 ~d)" pos))
+ ,(hline 0 0 w "blue")
+ ((:polyline
+ :fill "none" :stroke "green"
+ :points , (with-output-to-string (*standard-output*)
+ (loop
+ for j from 0 below n
+ for ii from (1+ i)
+ for x from 0 by 10
+ do (let ((y (aref seq (mod ii n))))
+ (when y
+ (write-char #\space)
+ (princ x)
+ (write-char #\,)
+ (princ y)))))))
+ ,@(loop
+ for j from 0 below n
+ for ii from (1+ i)
+ for x from 0 by 10
+ collect (let ((y (aref seq (mod ii n))))
+ (when y
+ `((:a :xlink\:href ,(funcall rw.ui::*click-link*
+ (lambda ()
+ (funcall click y))))
+ ((:circle :cx ,x :cy ,y :r 5 :fill "none"
+ :style "pointer-events:all"
+ :title ,(format nil "~d ~d" x y)))))))))))))
+
+(defun toplevel-widget ()
+ (let* (single
+ (delay 2)
+ (pos 0)
+ (i 0)
+ (n 61)
+ (seq (make-array n :initial-element nil))
+ clicked)
+ (lambda ()
+ (flet ((next ()
+ (setq i (mod (1+ i) n))
+ (setf (aref seq i) (%random))))
+ `(:html
+ (:head
+ ((:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8"))
+ ((:meta :http-equiv "Pragma" :content "no-cache, no-store"))
+ ((:meta :http-equiv "Expires" :content -1))
+ ,@ (unless single
+ `(((:meta
+ :http-equiv "refresh"
+ :content ,(format nil "~d;url=~a" delay
+ (funcall rw.ui::*click-link* #'next))))))
+ (:title "Zappel demo")
+ (:<style
+ ;;(:td :padding "0.3em")
+ ;;(:th :padding "0.3em")
+ ))
+ (:body
+ ,(rw.ui:form
+ (flet ((menu (label click selected)
+ (if selected
+ `(:b ,label)
+ (rw.ui:link label click)))
+ (link (label click &optional (enabled t))
+ (rw.ui:link label click :enabled enabled)))
+ `(:div
+ (:h1 "Zappel demo")
+ (:p ,(menu "zappel" (lambda () (setq single nil)) (not single))
+ " | "
+ ,(menu "single" (lambda () (setq single t)) single))
+ (:hr)
+ (:p ,(link "faster"
+ (lambda () (setq delay (/ delay 2)))
+ (and (not single) (< 1 delay)))
+ " "
+ ,(link "slower"
+ (lambda () (setq delay (* 2 delay)))
+ (not single))
+ " " ,delay "s :: "
+ ,(link "step" #'next single))
+ (:p "clicked: " ,clicked)
+ (:p ,(draw-canvas pos i seq (lambda (x) (setq clicked x))))
+ (:p ,(link "center"
+ (lambda () (setq pos 0))
+ (not (zerop pos)))
+ " "
+ ,(link "up" (lambda () (incf pos 10)))
+ " "
+ ,(link "down" (lambda () (decf pos 10)))
+ " " ,pos "px"))))))))))
+
+(defun construct (sid aid renv)
+ (let ((prefix "/"))
+ (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)))))
+
+(defvar *query-parameters*)
+
+(defun query-parameter (key)
+ (cdr (assoc key *query-parameters* :test #'equal)))
+
+(defun deconstruct ()
+ (values (query-parameter "s")
+ (query-parameter "a")))
+
+(defun draw-zappel ()
+ (rw.ui:draw (lambda ()
+ (let ((w (toplevel-widget)))
+ (lambda ()
+ `(:http-1.0
+ :code 200
+ :headers (("Content-Type" . "text/html;charset=utf-8")
+ ("cache-control" . "no-cache,no-store")
+ ("pragma" . "no-cache")
+ ("expires" . "-1"))
+ :body ,(funcall w)))))
+ 'construct
+ 'deconstruct))
+
+(defun zappel-handler (msg stream method query protocol headers &optional body)
+ (declare (ignore protocol headers))
+ (ecase msg
+ (:read (rw:till (rw:peek-reader stream)))
+ (:write
+ (let ((rw.ui:*http-server*
+ (let ((pp (rw.http::post-parameters method body)))
+ (lambda (msg &rest args)
+ (declare (ignore args))
+ (ecase msg
+ (:method method)
+ (:post-parameters pp)))))
+ (*query-parameters* (nth-value 1 (rw.uri:parse-query-string query))))
+ (draw-zappel)))))
+
+(defun start ()
+ (rw.http:server "0.0.0.0" 2340 'zappel-handler :quit (lambda () nil)))
+
+;;(start)
+
+(defun save-image ()
+ #-sbcl
+ (error "TODO RW.DEMO.ZAPPEL::SAVE-IMAGE")
+ #+sbcl
+ (sb-ext:save-lisp-and-die "cl-rw-demo-zappel"
+ :executable t
+ :toplevel (lambda ()
+ (handler-case
+ (progn
+ (start)
+ (loop (sleep 1)))
+ (condition ()
+ (sb-ext:exit :code 1 :abort t))))))
