forked from rabbibotton/clog
-
Notifications
You must be signed in to change notification settings - Fork 0
/
01-demo.lisp
202 lines (187 loc) · 7.64 KB
/
01-demo.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
(defpackage #:clog-demo-1
(:use #:cl #:clog)
(:export start-demo))
(in-package :clog-demo-1)
(defparameter *app-mode* nil
"Run application once and shutdown")
;; Game Display
(defconstant display-width 375)
(defconstant display-height 375)
;; 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 keyboard 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 (body 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))))))
(cond ((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))
(setf (fill-style cx) :red
(font-style cx) "bold 20px sans-serif")
(fill-text cx "GAME OVER" 30 30)
(play-media (create-audio body :source "/demo/game-over.wav" :controls nil))
(setf game-over t))
(t
(setf (fill-style cx) :purple)
(push head-cell (snake app))
(dolist (cell (snake app))
(draw-segment cell))
(setf (fill-style cx) :white)
(cond ((equal head-cell (food app))
(fill-text cx (format nil "Score: ~A" (score app))
5 (- display-height 15))
(setf (score app) (+ (score app) 10))
(setf (fill-style cx) :green)
(fill-text cx (format nil "Score: ~A" (score app))
5 (- display-height 15))
(play-media (create-audio body :source "/demo/eat.wav" :controls nil))
(setf (food app) (new-food)))
(t
(draw-segment (car (last (snake app))))
(setf (snake app) (butlast (snake app)))))
(setf (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 (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"))
(btn-txt (text obj)))
(cond ((equal btn-txt "<--") (setf (snake-direction app) :left))
((equal btn-txt "-->") (setf (snake-direction app) :right))
((equal btn-txt "-^-") (setf (snake-direction app) :up))
((equal btn-txt "-v-") (setf (snake-direction app) :down)))))
(defun start-game (body)
(let* ((app (connection-data-item body "app-data"))
(disp (create-canvas body
:width display-width
:height display-height))
(br (create-br body))
(controls (create-div body))
(left-btn (create-button controls :content "<--"))
(right-btn (create-button controls :content "-->"))
(up-btn (create-button controls :content "-^-"))
(down-btn (create-button controls :content "-v-"))
context)
(declare (ignore br))
;; 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))
(setf (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 :disable-default t)
(set-on-click left-btn #'on-click)
(set-on-click right-btn #'on-click)
(set-on-click up-btn #'on-click)
(set-on-click down-btn #'on-click)
(play-media (create-audio body :source "/demo/start.wav" :controls nil))
;; Game loop
(loop
(unless (validp body) (return))
(when (paint body context app) (return))
(sleep .1))))
(defun on-new-window (body)
(set-html-on-close body "Connection Lost")
(let ((app (make-instance 'app-data)))
(setf (connection-data-item body "app-data") app))
(display-splash body)
(start-game body)
;; When *app-mode* set only run the game once and then shutdown the app
(when *app-mode*
(sleep 2) ;; let end music play
(js-execute body "clogframe_quit()") ;; does nothing if not in clogframe
(clog:shutdown)
(uiop:quit)))
(defun start-demo (&key (host "0.0.0.0") (port 8080) (start-browser t) clogframe app)
"Start demo. If app is t, runs one game and shutsdown."
(when (eql port 0)
(setf port (clog-connection:random-port)))
(initialize 'on-new-window :host host :port port)
(when app
(setf *app-mode* app))
(when clogframe
(uiop:run-program (list "./clogframe"
"CLOG Snake"
(format nil "~A" port)
(format nil "~A" 640) (format nil "~A" 420))))
(when start-browser
(format t "If browser does not start go to http://127.0.0.1:~A" port)
(open-browser :url (format nil "http://127.0.0.1:~A" port))))