darcs - qt.examples

2 ;;; License: X11 license

4 (in-package :qt.examples)

6 (defclass tick-tack-toe-board (qt:widget)

7 ((board :accessor board

8 :initform (make-array '(3 3)))

9 (check :accessor check-slot)

10 (undo-stack :reader undo-stack

11 :initform (make-instance 'qt:undo-stack)))

12 (:metaclass cxx:class))

14 (defmethod initialize-instance :after ((widget tick-tack-toe-board) &rest args)

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)))

32 (defclass chell-button (qt:push-button)

33 ((x :reader x

34 :initarg :x)

35 (y :reader y

36 :initarg :y))

37 (:metaclass cxx:class))

39 ;;; Undo

40 ;;

41 ;; Move

43 (defclass move (qt:undo-command)

44 ((cell :accessor cell :initarg :cell)

45 (board :reader board :initarg :board))

46 (:metaclass cxx:class))

48 (defmethod cxx:undo ((move move))

49 (setf (cxx:text (cell move)) ""))

51 (defmethod cxx:id ((move move))

52 37)

55 (defclass player-move (move)

56 ((computer-cell :accessor computer-cell))

57 (:metaclass cxx:class))

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")))

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)) "")))

69 (defmethod cxx:merge-with ((move player-move) command)

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))

77 (defclass computer-move (move)

78 ()

79 (:metaclass cxx:class))

81 (defmethod initialize-instance :after ((move computer-move) &key)

82 (setf (cell move) (computer-move (board move))))

84 (defmethod cxx:redo ((move computer-move))

85 (setf (cxx:text (cell move)) "O"))

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))

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)

140 (block top

141 (let ((cell (random (free-cells (board board-widget)))))

142 (dotimes (x 3)

143 (dotimes (y 3)

144 (when (= 0 (cell-state (aref (board board-widget) x y)))

145 (when (= 0 cell)

146 (return-from top (aref (board board-widget) x y)))

147 (decf cell)))))))

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."))

157 (new-game widget))

158 (when (= 0 (free-cells (board widget)))

159 (qt:message-box.information widget "End"

160 "Drawn.")

161 (new-game widget)))))

162

163

164 (defun cell-state (cell)

165 (if (= (length (cxx:text cell)) 0)

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

174 (incf sum (cell-state (aref board

175 (+ 1 (* (1- dx) offset) (* dx i))

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)

185 (when (= 0 (cell-state (aref board x y)))

186 (incf sum))))))

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)))

199

200 (defclass tick-tack-toe (qt:main-window)

201 ()

202 (:metaclass cxx:class))

203

204 (defmethod initialize-instance :after ((widget tick-tack-toe) &rest args)

205 (declare (ignore args))

206 (let ((board (make-instance 'tick-tack-toe-board)))

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

216 (defun tick-tack-toe ()

217 "Tick Tack Toe"

218 (qt:with-app ()

219 (let ((widget (make-instance 'tick-tack-toe)))

220 (cxx:show widget)

221 (qt:exec))))