cl-rw

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

demo-zappel.lisp (10019B)

      1 ;;; Copyright (C) 2013, 2014, 2015 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 (defpackage :rw.demo.zappel
     24   (:use :cl))
     25 
     26 (in-package :rw.demo.zappel)
     27 
     28 (defun %random ()
     29   (- #+linux
     30      (with-open-file (s "/dev/urandom" :element-type '(unsigned-byte 8))
     31        (read-byte s))
     32      #-linux ;; TODO this returns always the same number, due to random state and threads
     33      (random n)
     34      128))
     35 
     36 (defun draw-canvas (pos i seq click)
     37   (flet ((hline (y x1 x2 stroke)
     38            `((:line :x1 ,x1 :y1 ,y :x2 ,x2 :y2 ,y :stroke ,stroke))))
     39     (let* ((n (length seq))
     40            (w (* 10 (1- n)))
     41            (h 300))
     42       `((:svg :xmlns "http://www.w3.org/2000/svg"
     43               :xmlns\:xlink "http://www.w3.org/1999/xlink"
     44               :style "border:1px solid black"
     45               :with ,w :height ,h :viewbox ,(format nil "0 0 ~d ~d" w h))
     46         ((:text :x 20 :y 20) ,(aref seq (mod i n)))
     47         ((:g
     48           :transform ,(format nil "translate(0 ~d) scale(1 -1) translate(0.5 ~d.5)"
     49                               h (floor h 2)))
     50          ,(hline 0 0 w "red")
     51          ((:g :transform ,(format nil "translate(0 ~d)" pos))
     52           ,(hline 0 0 w "blue")
     53           ((:polyline
     54             :fill "none" :stroke "green"
     55             :points , (with-output-to-string (*standard-output*)
     56                         (loop
     57                            for j from 0 below n
     58                            for ii from (1+ i)
     59                            for x from 0 by 10
     60                            do (let ((y (aref seq (mod ii n))))
     61                                 (when y
     62                                   (write-char #\space)
     63                                   (princ x)
     64                                   (write-char #\,)
     65                                   (princ y)))))))
     66           ,@(loop
     67                for j from 0 below n
     68                for ii from (1+ i)
     69                for x from 0 by 10
     70                collect (let ((y (aref seq (mod ii n))))
     71                          (when y
     72                            `((:a :xlink\:href ,(funcall rw.ui::*click-link*
     73                                                         (lambda ()
     74                                                           (funcall click y))))
     75                              ((:circle :cx ,x :cy ,y :r 5 :fill "none"
     76                                        :style "pointer-events:all"
     77                                        :title ,(format nil "~d ~d" x y)))))))))))))
     78 
     79 (defun toplevel-widget ()
     80   (let* (single
     81          (delay 2)
     82          (pos 0)
     83          (i 0)
     84          (n 61)
     85          (seq (make-array n :initial-element nil))
     86          clicked)
     87     (lambda ()
     88       (flet ((next ()
     89                (setq i (mod (1+ i) n))
     90                (setf (aref seq i) (%random))))
     91         `(:html
     92           (:head
     93            ((:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8"))
     94            ((:meta :http-equiv "Pragma" :content "no-cache, no-store"))
     95            ((:meta :http-equiv "Expires" :content -1))
     96            ,@ (unless single
     97                 `(((:meta
     98                     :http-equiv "refresh"
     99                     :content ,(format nil "~d;url=~a" delay
    100                                       (funcall rw.ui::*click-link* #'next))))))
    101            (:title "Zappel demo")
    102            (:<style
    103             ;;(:td :padding "0.3em")
    104             ;;(:th :padding "0.3em")
    105             ))
    106           (:body
    107            ,(rw.ui:form
    108              (flet ((menu (label click selected)
    109                       (if selected
    110                           `(:b ,label)
    111                           (rw.ui:link label click)))
    112                     (link (label click &optional (enabled t))
    113                       (rw.ui:link label click :enabled enabled)))
    114                `(:div
    115                  (:h1 "Zappel demo")
    116                  (:p ,(menu "zappel" (lambda () (setq single nil)) (not single))
    117                      " | "
    118                      ,(menu "single" (lambda () (setq single t)) single))
    119                  (:hr)
    120                  (:p ,(link "faster"
    121                             (lambda () (setq delay (/ delay 2)))
    122                             (and (not single) (< 1 delay)))
    123                      " "
    124                      ,(link "slower"
    125                             (lambda () (setq delay (* 2 delay)))
    126                             (not single))
    127                      " " ,delay "s :: "
    128                      ,(link "step" #'next single))
    129                  (:p "clicked: " ,clicked)
    130                  (:p ,(draw-canvas pos i seq (lambda (x) (setq clicked x))))
    131                  (:p ,(link "center"
    132                             (lambda () (setq pos 0))
    133                             (not (zerop pos)))
    134                      " "
    135                      ,(link "up" (lambda () (incf pos 10)))
    136                      " "
    137                      ,(link "down" (lambda () (decf pos 10)))
    138                      " " ,pos "px"))))))))))
    139 
    140 (defun construct (sid aid renv)
    141   (let ((prefix "/"))
    142     (with-output-to-string (s)
    143       (format s "~a?s=~a&a=~a" prefix sid aid)
    144       (loop
    145          for (k v) on renv by #'cddr
    146          when v
    147          do (format s "&~(~a~)=~a" k v)))))
    148 
    149 (defvar *query-parameters*)
    150 
    151 (defun query-parameter (key)
    152   (cdr (assoc key *query-parameters* :test #'equal)))
    153 
    154 (defun deconstruct ()
    155   (values (query-parameter "s")
    156           (query-parameter "a")))
    157 
    158 (defun draw-zappel ()
    159   (rw.ui:draw (lambda ()
    160                 (let ((w (toplevel-widget)))
    161                   (lambda ()
    162                     `(:http-1.0
    163                       :code 200
    164                       :headers (("Content-Type" . "text/html;charset=utf-8")
    165                                 ("cache-control" . "no-cache,no-store")
    166                                 ("pragma" . "no-cache")
    167                                 ("expires" . "-1"))
    168                       :body ,(funcall w)))))
    169               'construct
    170               'deconstruct))
    171 
    172 (defun zappel-handler (msg stream method query protocol headers &optional body)
    173   (declare (ignore protocol headers))
    174   (ecase msg
    175     (:read (rw:till (rw:peek-reader stream)))
    176     (:write
    177      (let ((rw.ui:*http-server*
    178             (let ((pp (rw.http::post-parameters method body)))
    179               (lambda (msg &rest args)
    180                 (declare (ignore args))
    181                 (ecase msg
    182                   (:method method)
    183                   (:post-parameters pp)))))
    184            (*query-parameters* (nth-value 1 (rw.uri:parse-query-string query))))
    185        (draw-zappel)))))
    186 
    187 (defun start ()
    188   (rw.http:server (rw.socket:make-ipv4-address "0.0.0.0")
    189                   2340
    190                   'zappel-handler
    191                   :quit (lambda () nil)
    192                   :allowed-methods '(:get :post)
    193                   :ignore-errors-p t))
    194 
    195 ;;(start)
    196 
    197 (defun save-image ()
    198   #-(or ccl cmucl sbcl)
    199   (error "TODO RW.DEMO.ZAPPEL::SAVE-IMAGE")
    200   #+clisp
    201   (ext:saveinitmem "cl-rw-demo-zappel"
    202                    :executable t
    203                    :quiet t
    204                    :norc
    205                    :init-function (lambda ()
    206                                     (handler-case
    207                                         (progn
    208                                           (start)
    209                                           (loop (sleep 1)))
    210                                       (condition ()
    211                                         (quit 1)))))
    212   #+ccl ;; TODO no debug on ^C
    213   (ccl:save-application "cl-rw-demo-zappel"
    214                         :prepend-kernel t
    215                         :error-handler :quit-quietly
    216                         :toplevel-function (lambda ()
    217                                              (handler-case
    218                                                  (progn
    219                                                    (start)
    220                                                    (loop (sleep 1)))
    221                                                (condition ()
    222                                                  (ccl:quit 1)))))
    223   #+cmu
    224   (ext:save-lisp "cl-rw-demo-zappel"
    225                  :executable t
    226                  :batch-mode t
    227                  :print-herald nil
    228                  :process-command-line nil
    229                  :load-init-file nil
    230                  :init-function (lambda ()
    231                                   (handler-case
    232                                       (progn
    233                                         (start)
    234                                         (loop (sleep 1)))
    235                                     (condition ()
    236                                       (ext:quit)))))
    237   #+sbcl
    238   (sb-ext:save-lisp-and-die "cl-rw-demo-zappel"
    239                             :executable t
    240                             :toplevel (lambda ()
    241                                         (handler-case
    242                                             (progn
    243                                               (start)
    244                                               (loop (sleep 1)))
    245                                           (condition ()
    246                                             (sb-ext:exit :code 1 :abort t))))))