Snake Game Demo

clog-base.lisp

@@ -795,7 +795,7 @@ will replace a on-key-press"))
 	     (when handler
 	       (lambda (data)
 	       (let ((f (parse-keyboard-event data)))
-		 (funcall handler obj (code-char (getf f ':char-code))))))
+		 (funcall handler obj (code-char (getf f :char-code))))))
 	     :call-back-script keyboard-event-script))
 
 ;;;;;;;;;;;;;;;;;;;;;

demos/01-snake-game.lisp

@@ -0,0 +1,178 @@
+(defpackage #:clog-user
+  (:use #:cl #:clog)
+  (:export start-demo))
+
+(in-package :clog-user)
+
+;; Game Display
+(defconstant display-width 400)
+(defconstant display-height 400)
+
+;; Snake Parameters
+(defconstant initial-length 5)
+(defconstant segment-size 10)
+
+(deftype snake-direction-type () '(member :left :right :up :down))
+
+(defun new-food ()
+  (list (random (floor (- (/ display-width segment-size) 1))) 
+	(random (floor (- (/ display-height segment-size) 1)))))
+
+(defclass app-data ()
+  ((snake-direction
+    :initform :right
+    :accessor snake-direction)
+   (score
+    :initform 0
+    :accessor score)
+   (food
+    :initform (new-food)
+    :accessor food)
+   (snake
+    :initform nil
+    :accessor snake)))
+
+(defun display-splash (body)
+  (let* ((splash
+	   (create-div body :content
+"<H1>(Sparky The Snake)</H1>
+ <br />
+ <p>Use your kebyoard to move Sparky to pick up batteries.</p>
+ <i>Be careful...</i><br />
+ If sparky hits his tail he electrocute himself to <b>death!!</b>
+ <br /><br />
+  Use the arrow keys or a,w,s,d for direction keys.<br/><br/>"))
+	 (ticker (create-span splash)))
+    
+    (setf (width splash) "100%")
+    (setf (text-alignment splash) :center)
+    (dotimes (n 10)
+      (setf (text ticker) (format nil "~A *" (text ticker)))
+      (sleep .1))
+    (setf (hiddenp splash) t)))
+
+(defun paint (cx app)
+  (let ((game-over nil)
+	(head-cell (car (snake app))))
+
+    (flet ((draw-segment (cell)
+	     (fill-rect cx
+			(* (car cell) segment-size)
+			(* (cadr cell) segment-size)
+			segment-size
+			segment-size))
+	   
+	   (self-collision ()
+	     (dolist (cell (snake app))
+	       (when (equal cell head-cell)
+		 (return t)))))
+
+      (cond ((eq :right (snake-direction app))
+	      (setf head-cell (list (1+ (car head-cell))
+				    (cadr head-cell))))
+	    ((eq :left (snake-direction app))
+	      (setf head-cell (list (1- (car head-cell))
+				    (cadr head-cell))))
+	    ((eq :up (snake-direction app))
+	      (setf head-cell (list (car head-cell)
+				    (1- (cadr head-cell)))))
+	    ((eq :down (snake-direction app))
+	      (setf head-cell (list (car head-cell)
+				    (1+ (cadr head-cell))))))
+
+      
+      (if (or (< (car head-cell) 0)
+	      (< (cadr head-cell) 0)
+	      (>= (* (car head-cell) segment-size) display-width)
+	      (>= (* (cadr head-cell) segment-size) display-height)
+	      (self-collision))
+	  (progn
+	    (fill-style cx :red)
+	    (font-style cx "bold 20px sans-serif")
+	    (fill-text cx "GAME OVER" 30 30)
+	    (setf game-over t))
+	  (progn
+	    (fill-style cx :purple)
+	    (push head-cell (snake app))
+	    (dolist (cell (snake app))
+	      (draw-segment cell))
+
+	    (fill-style cx :white)
+
+	    (if (equal head-cell (food app))
+		(progn
+		  (fill-text cx (format nil "Score: ~A" (score app))
+			     5 (- display-height 15))
+		  (setf (score app) (+ (score app) 10))
+
+		  (fill-style cx :green)
+		  (fill-text cx (format nil "Score: ~A" (score app))
+			     5 (- display-height 15))
+		  
+		  (setf (food app) (new-food)))
+		(progn
+		  (draw-segment (car (last (snake app))))
+		  (setf (snake app) (butlast (snake app))))))
+	  
+	  (fill-style cx :brown)
+	  (draw-segment (food app)))
+      
+      game-over)))
+
+(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)))))
+	  
+
+(defun start-game (body)
+  (let ((app (connection-data-item body "app-data"))
+	(disp (create-canvas body
+			     :width display-width
+			     :height display-height))
+	context)
+
+    ;; Initialize display
+    (setf (background-color body) :orange)
+    
+    (setf (display disp) :block)
+    (setf (background-color disp) :white)
+    (set-margin disp :auto :auto :auto :auto)
+    (set-border disp :thin :solid :white)
+    (setf (border-radius disp) "10px")
+    (setf (box-shadow disp) "3px 3px 5px")
+
+    ;; Initialize snake
+    (dotimes (n initial-length)
+      (push (list n 0) (snake app)))
+
+    (setf context (create-context2d disp))
+    (font-style context "normal 20px sans-serif")
+    (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)
+    
+    ;; Game loop
+    (loop
+      (unless (validp body) (return))
+      (when (paint context app) (return))
+      (sleep .1))))
+
+(defun on-new-window (body)
+  (let ((app (make-instance 'app-data)))
+    (setf (connection-data-item body "app-data") app))
+  
+  (display-splash body)
+  (start-game body))
+
+(defun start-demo ()
+  "Start demo."
+
+  (initialize #'on-new-window)
+  (open-browser))

demos/README.md

@@ -32,10 +32,6 @@ Boot file default : /boot.html
 
 Most demos startup a browser, if not use http://127.0.0.1:8080
 
-When done with a demo can run:
+Demo Summary
 
-```
-(clog:shutdown)
-```
-
-This will shutdown clog and then can load up another demo.
+- 01-snake-game.lisp - Snake Gamey

test/test-clog.lisp

@@ -47,7 +47,7 @@
     (create-div win :content "Hello World! p")
     (create-div win :content "Hello World! div")
     (create-br win) 
-    (create-span win "Hello World! span")
+    (create-span win :content "Hello World! span")
     (create-hr win) 
     (create-a win :link "http://www.google.com" :content "Link" :target "new")
     (setf (title (html-document win)) "CLOG Test App")