cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

commit 24f97a5702c9ff37a23bd5170bb5a69d1507e170
parent 7654bf9d7a108891ccce09d14fb0bcb339fd20e3
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sat,  1 Nov 2014 12:59:32 +0100

demo-zappel added

Diffstat:
Acl-rw-demo-zappel.asd | 31+++++++++++++++++++++++++++++++
Ademo-zappel.lisp | 204+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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))))))