From cffea6af691c9d2a847f4b113c436808c6ff53ef Mon Sep 17 00:00:00 2001 From: David Botton Date: Sun, 17 Jan 2021 03:09:53 -0500 Subject: [PATCH] Snake Game Demo --- clog-base.lisp | 2 +- demos/01-snake-game.lisp | 178 +++++++++++++++++++++++++++++++++++++++ demos/README.md | 8 +- test/test-clog.lisp | 2 +- 4 files changed, 182 insertions(+), 8 deletions(-) create mode 100644 demos/01-snake-game.lisp diff --git a/clog-base.lisp b/clog-base.lisp index abe0641..b21d575 100644 --- a/clog-base.lisp +++ b/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)) ;;;;;;;;;;;;;;;;;;;;; diff --git a/demos/01-snake-game.lisp b/demos/01-snake-game.lisp new file mode 100644 index 0000000..a049bcc --- /dev/null +++ b/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 +"

(Sparky The Snake)

+
+

Use your kebyoard to move Sparky to pick up batteries.

+ Be careful...
+ If sparky hits his tail he electrocute himself to death!! +

+ Use the arrow keys or a,w,s,d for direction keys.

")) + (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)) diff --git a/demos/README.md b/demos/README.md index a2705f0..b551fed 100644 --- a/demos/README.md +++ b/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 diff --git a/test/test-clog.lisp b/test/test-clog.lisp index b4e9fc7..a48a39b 100644 --- a/test/test-clog.lisp +++ b/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")