blob: 52c71fd825c70fa17340f61a0f3be2750cfb0072 (
plain)
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
|
;;;; examples/10-canvas.lisp
(defpackage #:ww.examples/10
(:use #:cl)
(:export #:start))
(in-package #:ww.examples/10)
;;; CLASSES
(def:class sneking (ww:application)
(sneks snek-pit :initform nil)
(population :initform 10))
(def:class snek ()
(x y dx dy :initform 1)
(brain :initform 0.0)
(bod :initform (list))
(len :initform 4)
(color :initform (list 255 255 255))
(home :initform (list 0 0 100 100))
:documentation "A SNEK is a contiguous chain of virtual pixels (i.e. square blocks of color), all the same coloor")
(defun snek-is-home-p (snek)
(with-slots (x y home) snek
(destructuring-bind (left bottom right top) home
(and (<= left x (1- right))
(<= bottom y (1- top))))))
(defun random-between (lo hi)
(+ lo (random (1+ (- hi lo)))))
(defun snek-change-mind (snek)
(if (zerop (random 2))
(setf (dx snek) (random-between -1 1))
(setf (dy snek) (random-between -1 1))))
(defun advance-snek-pos (snek)
"Advance a snek's position. Check that the snek remains contained in
its HOME. If it isn't, revert position and have the snek change its
mind about where it wants to go. Finally, update the snek's BOD,
ensuring that its BOD is no longer than LEN, truncating it when
necessary."
(with-slots (x y dx dy home bod len) snek
(incf x dx)
(incf y dy)
(unless (snek-is-home-p snek)
(decf y dy)
(decf x dx)
(snek-change-mind snek))
(push y bod)
(push x bod)
(when (<= (* 2 len) (length bod))
(setf bod (nreverse (cddr (nreverse bod)))))))
(defun snek-thots (snek)
"A SNEK will decide to change direction the longer it has been
moving in a particular direction."
(incf (brain snek) 0.01)
(when (< (random 1.0) (brain snek))
(setf (brain snek) 0.0)
(snek-change-mind snek)))
(defun update-snek (snek)
(advance-snek-pos snek)
(snek-thots snek))
(defvar *alpha-step* 10)
(defun draw-snek (snek canvas)
"Draws a snek to a canvas. The BOD of a snek is a list of recent
positions that the snek's head had occupied. The body is drawn by
reducing the alpha of the snek's COLOR by 10 for every point in the BOD."
(with-slots (bod color) snek
(destructuring-bind (red green blue) color
(let ((alpha (max 0 (- 255 (* *alpha-step* (/ (length bod) 2))))))
(loop
for (y x . more) on (reverse bod) by #'cddr
do (ww::with-pixel (r g b a) (ww::pixel canvas x y)
(setf r red g green b blue a alpha))
(setf alpha (min 255 (+ alpha *alpha-step*))))))))
(defun random-snek (&optional (boundx 100) (boundy 100))
(make-instance 'snek
:color (list (random 256) (random 256) (random 256))
:dy (random-between -1 1)
:dx (random-between -1 1)
:len (random-between 50 100)
:home (list 0 0 boundx boundy)
:x (random boundx)
:y (random boundy)))
(ww:defhandler sneks-a-go-go
(ww::on-perframe (app ticks)
"Clears cavnas. Moves gives each snek its turn. Draws each
snek. Updates the screen."
(with-slots (sneks snek-pit) app
(ww::clear-canvas snek-pit)
(dolist (snek sneks)
(update-snek snek)
(draw-snek snek snek-pit))
(ww::blit snek-pit))))
(defmethod ww::boot ((app sneking ))
"Sets up snek-pit, a canvas to which sneks are drawn. Creates random
sneks. Adds the canvas to the app, and sets up the perframe handler."
(setf (snek-pit app)
(make-instance 'ww:canvas :pixel-width 100 :pixel-height 100)
(sneks app)
(loop repeat (population app) collect (random-snek 100 100)))
(setf (ww:width (snek-pit app)) (ww::application-width app)
(ww:height (snek-pit app)) (ww::application-width app))
(ww::add-unit (snek-pit app))
(ww:add-handler app #'sneks-a-go-go))
(defun start (&key (side 800) (population 50))
(ww::start
(make-instance
'sneking
:population population
:fps 60
:width side
:height side
:refocus-on-mousedown-p nil
:title "sneks"
:asset-root
(merge-pathnames
"examples/"
(asdf:system-source-directory :wheelwork)))))
|
