mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-06 02:30:42 -08:00
Code Issues Projects Releases Wiki Activity

added condition handling, regrestion in snake from key-code changes

Browse source
This commit is contained in:
David Botton 2021-03-19 12:19:23 -04:00
parent 8edd6e8c84
commit 516cdd5eef
2 changed files with 107 additions and 81 deletions
Download patch file Download diff file Expand all files Collapse all files

16
demos/01-demo.lisp
View file

@ -109,11 +109,15 @@
(defun on-key-down (obj event)
(let ((app (connection-data-item obj "app-data"))
(key-code (getf event :key-code)))
(cond ((or (eql key-code 65) (eql key-code 37)) (setf (snake-direction app) :left))
((or (eql key-code 87) (eql key-code 38)) (setf (snake-direction app) :up))
((or (eql key-code 83) (eql key-code 40)) (setf (snake-direction app) :down))
((or (eql key-code 68) (eql key-code 39)) (setf (snake-direction app) :right)))))
(key (getf event :key)))
(cond ((or (equalp key "ArrowLeft") (equalp key "a"))
(setf (snake-direction app) :left))
((or (equalp key "ArrowUp") (equalp key "w"))
(setf (snake-direction app) :up))
((or (equalp key "ArrowDown") (equalp key "s"))
(setf (snake-direction app) :down))
((or (equalp key "ArrowRight") (equalp key "d"))
(setf (snake-direction app) :right)))))
(defun on-click (obj)
(let ((app (connection-data-item obj "app-data"))
@ -152,7 +156,7 @@
(fill-style context :green)
(fill-text context (format nil "Score: ~A" (score app))
5 (- display-height 15))
(set-on-key-down body #'on-key-down)
(set-on-key-down body #'on-key-down :disable-default t)
(set-on-click left-btn #'on-click)
(set-on-click right-btn #'on-click)
(set-on-click up-btn #'on-click)

30
source/clog-connection.lisp
View file

@ -123,18 +123,24 @@ with DEFAULT-ANSWER in case of a time out. (Private)"
(defun wait-for-answer (id &key (timeout *query-time-out*))
"Block after prep-query and sending the query script with ID and TIMEOUT with
the default answer. (Private)"
(handler-case
(progn
(bordeaux-threads:wait-on-semaphore (gethash id *queries-sems*) :timeout timeout)
(let ((answer (gethash id *queries*)))
(bordeaux-threads:with-lock-held (*queries-lock*)
(remhash id *queries*)
(remhash id *queries-sems*))
answer))
(t (c)
(format t "Condition caught in wait-for-answer - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle-new-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun handle-new-connection (connection id)
(handler-case
(cond (id
(format t "Reconnection id - ~A to ~A~%" id connection)
(bordeaux-threads:with-lock-held (*connection-lock*)
@ -154,13 +160,17 @@ the default answer. (Private)"
(lambda ()
(funcall *on-connect-handler* id))
:name (format nil "CLOG connection ~A"
id)))))
id))))
(t (c)
(format t "Condition caught in handle-new-connection - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;;;;
;; handle-message ;;
;;;;;;;;;;;;;;;;;;;;
(defun handle-message (connection message)
(handler-case
(let ((id (gethash connection *connections*))
(ml (ppcre:split ":" message :limit 2)))
(cond ((equal (first ml) "0")
@ -188,13 +198,17 @@ the default answer. (Private)"
(bordeaux-threads:with-lock-held (*queries-lock*)
(setf (gethash (parse-integer (first ml)) *queries*) (second ml)))
(bordeaux-threads:signal-semaphore
(gethash (parse-integer (first ml)) *queries-sems*))))))
(gethash (parse-integer (first ml)) *queries-sems*)))))
(t (c)
(format t "Condition caught in handle-message - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; handle-close-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun handle-close-connection (connection)
(handler-case
(let ((id (gethash connection *connections*)))
(when id
(when *verbose-output*
@ -202,13 +216,17 @@ the default answer. (Private)"
(bordeaux-threads:with-lock-held (*connection-lock*)
(remhash id *connection-data*)
(remhash id *connection-ids*)
(remhash connection *connections*)))))
(remhash connection *connections*))))
(t (c)
(format t "Condition caught in handle-message - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;;
;; clog-server ;;
;;;;;;;;;;;;;;;;;
(defun clog-server (env)
(handler-case
(let ((ws (websocket-driver:make-server env)))
(websocket-driver:on :open ws
(lambda ()
@ -231,7 +249,11 @@ the default answer. (Private)"
(handle-close-connection ws)))
(lambda (responder)
(declare (ignore responder))
(websocket-driver:start-connection ws))))
(websocket-driver:start-connection ws)))
(t (c)
(format t "Condition caught in clog-server - ~A.~&" c)
(values 0 c))))
;;;;;;;;;;;;;;;;
;; initialize ;;