mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
Stability improvements of CLOG
This commit is contained in:
parent
12ae791696
commit
c596ad7ad4
3 changed files with 34 additions and 26 deletions
|
|
@ -324,12 +324,12 @@ are stored in this string based hash in the format of:
|
|||
(:documentation "Set the ON-RESIZE-HANDLER for CLOG-OBJ. If ON-RESIZE-HANDLER
|
||||
is nil unbind the event."))
|
||||
|
||||
(defmethod set-on-resize ((obj clog-obj) on-resize-handler)
|
||||
(let ((on-resize on-resize-handler))
|
||||
(set-event obj "resize"
|
||||
(defmethod set-on-resize ((obj clog-obj) handler)
|
||||
(set-event obj "resize"
|
||||
(when handler
|
||||
(lambda (data)
|
||||
(declare (ignore data))
|
||||
(funcall on-resize obj)))))
|
||||
(funcall handler obj)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;
|
||||
;; set-on-focus ;;
|
||||
|
|
@ -493,12 +493,12 @@ on-mouse-right-click will replace this handler."))
|
|||
is nil unbind the event. Setting this event will replace an on-mouse click if
|
||||
set."))
|
||||
|
||||
(defmethod set-on-click ((obj clog-obj) on-click-handler)
|
||||
(let ((on-click on-click-handler))
|
||||
(set-event obj "click"
|
||||
(defmethod set-on-click ((obj clog-obj) handler)
|
||||
(set-event obj "click"
|
||||
(when handler
|
||||
(lambda (data)
|
||||
(declare (ignore data))
|
||||
(funcall on-click obj)))))
|
||||
(funcall handler obj)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; set-on-double-click ;;
|
||||
|
|
|
|||
|
|
@ -169,7 +169,10 @@ the default answer. (Private)"
|
|||
id (first em) (second em)))
|
||||
(bordeaux-threads:make-thread
|
||||
(lambda ()
|
||||
(funcall (gethash (first em) (get-connection-data id)) (second em))))))
|
||||
(let* ((event-hash (get-connection-data id))
|
||||
(event (when event-hash
|
||||
(gethash (first em) event-hash))))
|
||||
(when event (funcall event (second em))))))))
|
||||
(t
|
||||
(when *verbose-output*
|
||||
(format t "~A ~A = ~A~%" id (first ml) (second ml)))
|
||||
|
|
|
|||
|
|
@ -7,8 +7,7 @@
|
|||
(defun on-click (obj)
|
||||
(setf (text obj) "DEAD")
|
||||
(setf (connection-data-item obj "done") t)
|
||||
(set-on-click obj nil)
|
||||
)
|
||||
(set-on-click obj nil))
|
||||
|
||||
(defun on-new-window (body)
|
||||
(handler-case ; Disconnects from the browser can be handled gracefully using the condition system.
|
||||
|
|
@ -17,24 +16,29 @@
|
|||
|
||||
(setf (hiddenp (prog1
|
||||
(create-child body "<h2>KILL Darth's Tie Fighter - Click on it!</h2>")
|
||||
(sleep 2))) t)
|
||||
|
||||
(let* ((mover (create-child body "<div>(-o-)</div>"))
|
||||
(bounds-x (parse-integer (width (window body)) :junk-allowed t))
|
||||
(bounds-y (parse-integer (height (window body)) :junk-allowed t))
|
||||
(mover-x (random bounds-x))
|
||||
(mover-y (random bounds-y)))
|
||||
(sleep 2))) t)
|
||||
|
||||
(let* ((mover (create-child body "<div>(-o-)</div>"))
|
||||
bounds-x bounds-y mover-x mover-y)
|
||||
|
||||
(flet ((set-bounds ()
|
||||
(setf bounds-x (parse-integer (width (window body)) :junk-allowed t))
|
||||
(setf bounds-y (parse-integer (height (window body)) :junk-allowed t))))
|
||||
(set-bounds)
|
||||
(setf mover-x (random bounds-x))
|
||||
(setf mover-y (random bounds-y))
|
||||
|
||||
(set-on-resize (window body)
|
||||
(lambda (obj)
|
||||
(declare (ignore obj))
|
||||
(set-bounds))))
|
||||
|
||||
(setf (positioning mover) :fixed)
|
||||
(set-on-click mover #'on-click)
|
||||
|
||||
(set-on-resize (window body)
|
||||
(lambda (obj)
|
||||
(declare (ignore obj))
|
||||
(setf bounds-x (parse-integer (width (window body)) :junk-allowed t))
|
||||
(setf bounds-y (parse-integer (height (window body)) :junk-allowed t))))
|
||||
|
||||
(loop
|
||||
(unless (validp body)
|
||||
(return))
|
||||
(when (connection-data-item body "done")
|
||||
(return))
|
||||
|
||||
|
|
@ -59,8 +63,9 @@
|
|||
(setf mover-y bounds-y))
|
||||
|
||||
(sleep .02)))
|
||||
) (error ()
|
||||
(format t "Lost connection.~&"))))
|
||||
(format t "GAME OVER"))
|
||||
(error (c)
|
||||
(format t "Lost connection.~%~%~A" c))))
|
||||
|
||||
(defun start-tutorial ()
|
||||
"Start turtorial."
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue