repos
/
qt.examples
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Use new qt:with-app.
Annotate for file src/tick-tack-toe.lisp
2009-04-14 tobias
1
;;; Copyright 2009 Tobias Rautenkranz
14:29:22 '
2
;;; License: X11 license
'
3
2009-04-05 tobias
4
(in-package :qt.examples)
15:36:46 '
5
2009-05-31 tobias
6
(defclass tick-tack-toe-board (qt:widget)
2009-04-05 tobias
7
((board :accessor board
15:36:46 '
8
:initform (make-array '(3 3)))
2009-05-31 tobias
9
(check :accessor check-slot)
21:06:50 '
10
(undo-stack :reader undo-stack
'
11
:initform (make-instance 'qt:undo-stack)))
2009-05-11 tobias
12
(:metaclass cxx:class))
2009-04-05 tobias
13
2009-05-31 tobias
14
(defmethod initialize-instance :after ((widget tick-tack-toe-board) &rest args)
21:06:50 '
15
(declare (ignore args))
'
16
(setf (check-slot widget) (qt:make-slot #'(lambda ()
'
17
(update-cell widget
'
18
(qt:sender)))))
'
19
(let ((layout (make-instance 'qt:grid-layout)))
'
20
(dotimes (x (array-dimension (board widget) 0))
'
21
(dotimes (y (array-dimension (board widget) 1))
'
22
(setf (aref (board widget) x y)
'
23
(make-instance 'chell-button :x x :y y))
'
24
(qt:connect (qt:get-signal (aref (board widget) x y)
'
25
"clicked()")
'
26
(check-slot widget))
'
27
(cxx:add-widget layout (aref (board widget) x y)
'
28
x y)))
'
29
(setf (cxx:layout widget) layout)))
'
30
'
31
2009-04-05 tobias
32
(defclass chell-button (qt:push-button)
15:36:46 '
33
((x :reader x
'
34
:initarg :x)
'
35
(y :reader y
'
36
:initarg :y))
2009-05-11 tobias
37
(:metaclass cxx:class))
2009-04-05 tobias
38
2009-05-31 tobias
39
;;; Undo
21:06:50 '
40
;;
'
41
;; Move
'
42
'
43
(defclass move (qt:undo-command)
'
44
((cell :accessor cell :initarg :cell)
'
45
(board :reader board :initarg :board))
'
46
(:metaclass cxx:class))
'
47
'
48
(defmethod cxx:undo ((move move))
'
49
(setf (cxx:text (cell move)) ""))
'
50
'
51
(defmethod cxx:id ((move move))
'
52
37)
'
53
'
54
'
55
(defclass player-move (move)
'
56
((computer-cell :accessor computer-cell))
'
57
(:metaclass cxx:class))
'
58
'
59
(defmethod cxx:redo ((move player-move))
'
60
(setf (cxx:text (cell move)) "X")
'
61
(when (slot-boundp move 'computer-cell)
'
62
(setf (cxx:text (computer-cell move)) "O")))
'
63
'
64
(defmethod cxx:undo ((move player-move))
'
65
(call-next-method)
'
66
(when (slot-boundp move 'computer-cell)
'
67
(setf (cxx:text (computer-cell move)) "")))
2009-04-05 tobias
68
2009-05-31 tobias
69
(defmethod cxx:merge-with ((move player-move) command)
21:06:50 '
70
"Merge a player and a computer move, such that undo and redo
'
71
operate on a player - computer move pair."
'
72
(when (typep command 'computer-move)
'
73
(setf (computer-cell move) (cell command))
'
74
t))
'
75
'
76
'
77
(defclass computer-move (move)
'
78
()
'
79
(:metaclass cxx:class))
'
80
'
81
(defmethod initialize-instance :after ((move computer-move) &key)
'
82
(setf (cell move) (computer-move (board move))))
'
83
'
84
(defmethod cxx:redo ((move computer-move))
'
85
(setf (cxx:text (cell move)) "O"))
'
86
'
87
'
88
'
89
;; New Game
'
90
;;
'
91
(defclass new-game (qt:undo-command)
'
92
((board :reader board :initarg :board)
'
93
(state :reader state :initform (make-array '(3 3)))
'
94
(initial-move :accessor initial-move))
'
95
(:metaclass cxx:class))
'
96
'
97
(defmethod initialize-instance :after ((new-game new-game) &key)
'
98
(dotimes (x 3)
'
99
(dotimes (y 3)
'
100
(setf (aref (state new-game) x y)
'
101
(cxx:text (aref (board new-game) x y))))))
'
102
'
103
(defmethod cxx:id ((new-game new-game))
'
104
37)
'
105
'
106
(defmethod cxx:redo ((new-game new-game))
'
107
(dotimes (x 3)
'
108
(dotimes (y 3)
'
109
(setf (cxx:text (aref (board new-game) x y)) "")))
'
110
(when (slot-boundp new-game 'initial-move)
'
111
(setf (cxx:text (initial-move new-game)) "O")))
'
112
'
113
(defmethod cxx:undo ((new-game new-game))
'
114
(dotimes (x 3)
'
115
(dotimes (y 3)
'
116
(setf (cxx:text (aref (board new-game) x y))
'
117
(aref (state new-game) x y)))))
'
118
'
119
(defmethod cxx:merge-with ((new-game new-game) command)
'
120
(when (typep command 'computer-move)
'
121
(setf (initial-move new-game) (cell command))
'
122
t))
'
123
'
124
(defun new-game (board-widget)
'
125
(cxx:push (undo-stack board-widget)
'
126
(make-instance 'new-game :board (board board-widget))))
'
127
'
128
'
129
'
130
(defun update-cell (board-widget cell)
'
131
(when (= 0 (cell-state cell))
'
132
(cxx:push (undo-stack board-widget)
'
133
(make-instance 'player-move :cell cell :board board-widget))
'
134
(check-end board-widget)
'
135
(cxx:push (undo-stack board-widget)
'
136
(make-instance 'computer-move :board board-widget))
'
137
(check-end board-widget)))
'
138
'
139
(defun computer-move (board-widget)
2009-04-05 tobias
140
(block top
2009-05-31 tobias
141
(let ((cell (random (free-cells (board board-widget)))))
2009-04-05 tobias
142
(dotimes (x 3)
15:36:46 '
143
(dotimes (y 3)
2009-05-31 tobias
144
(when (= 0 (cell-state (aref (board board-widget) x y)))
2009-04-05 tobias
145
(when (= 0 cell)
2009-05-31 tobias
146
(return-from top (aref (board board-widget) x y)))
2009-04-05 tobias
147
(decf cell)))))))
15:36:46 '
148
'
149
(defun check-end (widget)
'
150
(let ((winner (winner (board widget))))
'
151
(if winner
'
152
(progn
'
153
(qt:message-box.information widget "End"
'
154
(if (= 1 winner)
'
155
"You win."
'
156
"You lose."))
2009-05-31 tobias
157
(new-game widget))
2009-04-05 tobias
158
(when (= 0 (free-cells (board widget)))
15:36:46 '
159
(qt:message-box.information widget "End"
'
160
"Drawn.")
2009-05-31 tobias
161
(new-game widget)))))
2009-04-05 tobias
162
2009-05-31 tobias
163
21:06:50 '
164
(defun cell-state (cell)
2009-04-05 tobias
165
(if (= (length (cxx:text cell)) 0)
15:36:46 '
166
0
'
167
(ecase (aref (cxx:text cell) 0)
'
168
(#\X 1)
'
169
(#\O -1))))
'
170
'
171
(defun winner-line (board dx dy &optional (offset 0))
'
172
(let ((sum 0))
'
173
(loop for i from -1 to 1 do
2009-05-31 tobias
174
(incf sum (cell-state (aref board
2009-04-05 tobias
175
(+ 1 (* (1- dx) offset) (* dx i))
15:36:46 '
176
(+ 1 (* (1- dy) offset) (* dy i))))))
'
177
(if (= (abs sum) 3)
'
178
(floor sum 3)
'
179
nil)))
'
180
'
181
(defun free-cells (board)
'
182
(let ((sum 0))
'
183
(dotimes (x 3 sum)
'
184
(dotimes (y 3)
2009-05-31 tobias
185
(when (= 0 (cell-state (aref board x y)))
2009-04-05 tobias
186
(incf sum))))))
15:36:46 '
187
'
188
(defun winner (board)
'
189
(or (winner-line board 1 1)
'
190
(winner-line board -1 1)
'
191
'
192
(winner-line board 1 0 -1)
'
193
(winner-line board 1 0)
'
194
(winner-line board 1 0 1)
'
195
'
196
(winner-line board 0 1 -1)
'
197
(winner-line board 0 1)
'
198
(winner-line board 0 1 1)))
2009-05-31 tobias
199
21:06:50 '
200
(defclass tick-tack-toe (qt:main-window)
'
201
()
'
202
(:metaclass cxx:class))
2009-04-05 tobias
203
15:36:46 '
204
(defmethod initialize-instance :after ((widget tick-tack-toe) &rest args)
'
205
(declare (ignore args))
2009-05-31 tobias
206
(let ((board (make-instance 'tick-tack-toe-board)))
21:06:50 '
207
(cxx:set-central-widget widget board)
'
208
(let ((toolbar (cxx:add-tool-bar widget "Main")))
'
209
(cxx:add-action toolbar
'
210
(cxx:create-undo-action (undo-stack board)
'
211
widget))
'
212
(cxx:add-action toolbar
'
213
(cxx:create-redo-action (undo-stack board)
'
214
widget)))))
'
215
2009-04-05 tobias
216
(defun tick-tack-toe ()
15:36:46 '
217
"Tick Tack Toe"
2009-07-01 tobias
218
(qt:with-app ()
2009-04-05 tobias
219
(let ((widget (make-instance 'tick-tack-toe)))
15:36:46 '
220
(cxx:show widget)
2009-07-01 tobias
221
(qt:exec))))