darcs - qt.examples

3 ;;; Contact: Qt Software Information (qt-info@nokia.com)

4 ;;;

5 ;;; This file is part of the examples of the Qt Toolkit.

6 ;;;

7 ;;; $QT_BEGIN_LICENSE:LGPL$

8 ;;; Commercial Usage

9 ;;; Licensees holding valid Qt Commercial licenses may use this file in

10 ;;; accordance with the Qt Commercial License Agreement provided with the

11 ;;; Software or, alternatively, in accordance with the terms contained in

12 ;;; a written agreement between you and Nokia.

13 ;;;

14 ;;; GNU Lesser General Public License Usage

15 ;;; Alternatively, this file may be used under the terms of the GNU Lesser

16 ;;; General Public License version 2.1 as published by the Free Software

17 ;;; Foundation and appearing in the file LICENSE.LGPL included in the

18 ;;; packaging of this file. Please review the following information to

19 ;;; ensure the GNU Lesser General Public License version 2.1 requirements

20 ;;; will be met: http://www.gnu.org/licenses/old-licenses/lgpl-2.1.html.

21 ;;;

22 ;;; In addition, as a special exception, Nokia gives you certain

23 ;;; additional rights. These rights are described in the Nokia Qt LGPL

24 ;;; Exception version 1.0, included in the file LGPL_EXCEPTION.txt in this

25 ;;; package.

26 ;;;

27 ;;; GNU General Public License Usage

28 ;;; Alternatively, this file may be used under the terms of the GNU

29 ;;; General Public License version 3.0 as published by the Free Software

30 ;;; Foundation and appearing in the file LICENSE.GPL included in the

31 ;;; packaging of this file. Please review the following information to

32 ;;; ensure the GNU General Public License version 3.0 requirements will be

33 ;;; met: http://www.gnu.org/copyleft/gpl.html.

34 ;;;

35 ;;; If you are unsure which license is appropriate for your use, please

36 ;;; contact the sales department at qt-sales@nokia.com.

37 ;;; $QT_END_LICENSE$

39 (in-package :qt.examples)

41 (defun normalize-angle (angle)

42 (loop while (< angle 0) do

43 (incf angle (* 2 Pi)))

44 (loop while (> angle (* 2 Pi)) do

45 (decf angle (* 2 Pi)))

46 angle)

48 (defclass mouse (qt:graphics-item)

49 ((angle :initform 0d0 :accessor angle)

50 (speed :initform 0d0 :accessor mouse-speed)

51 (eye-direction :initform 0d0 :accessor eye-direction)

52 (color :initform (make-instance 'qt:color

53 :arg0 (random 256)

54 :arg1 (random 256)

55 :arg2 (random 256))

56 :accessor color))

57 (:metaclass cxx:class))

59 (defmethod initialize-instance :after ((mouse mouse) &rest initargs)

60 (declare (ignore initargs))

61 (cxx:rotate mouse (random (* 360 16))))

63 (defmethod cxx:bounding-rect ((mouse mouse))

64 (let ((adjust 0.5d0))

65 (make-instance 'qt:rect-f :args (list (- -18 adjust) (- -22 adjust)

66 (+ 36 adjust) (+ 60 adjust)))))

68 (defmethod cxx:shape ((mouse mouse))

69 (let ((path (make-instance 'qt:painter-path)))

70 (cxx:add-rect path -10 -20 20 40)

71 path))

73 (defmethod cxx:paint ((mouse mouse) painter option widget)

74 (declare (ignore option widget))

75 ;; Body

76 (cxx:set-brush painter (color mouse))

77 (cxx:draw-ellipse painter -10 -20 20 40)

79 ;; Eyes

80 (cxx:set-brush painter qt:+white+)

81 (cxx:draw-ellipse painter -10 -17 8 8)

82 (cxx:draw-ellipse painter 2 -17 8 8)

84 ;; Nose

85 (cxx:set-brush painter qt:+black+)

86 (cxx:draw-ellipse painter -2 -22 4 4)

88 ;; Pupils

89 (cxx:draw-ellipse painter

90 (make-instance 'qt:rect-f

91 :arg0 (+ -8d0 (eye-direction mouse))

92 :arg1 -17

93 :arg2 4 :arg3 4))

94 (cxx:draw-ellipse painter

95 (make-instance 'qt:rect-f

96 :arg0 (+ 4d0 (eye-direction mouse))

97 :arg1 -17

98 :arg2 4 :arg3 4))

100 ;; Ears

101 (cxx:set-brush painter

102 (if (zerop (length (cxx:colliding-items (cxx:scene mouse)

103 mouse)))

104 qt:+dark-yellow+

105 qt:+red+))

106 (cxx:draw-ellipse painter -17 -12 16 16)

107 (cxx:draw-ellipse painter 1 -12 16 16)

108

109 ;; Tail

110 (let ((path (make-instance 'qt:painter-path

111 :arg0 (make-instance 'qt:point-f :args '(0 20)))))

112 (cxx:cubic-to path -5 22 -5 22 0 25)

113 (cxx:cubic-to path 5 27 5 32 0 30)

114 (cxx:cubic-to path -5 32 -5 42 0 35)

115 (cxx:set-brush painter qt:+no-brush+)

116 (cxx:draw-path painter path)))

117

118 (defmethod cxx:advance ((mouse mouse) step)

119 (unless (zerop step)

120 ;; Don't move too far away

121 (let ((line-to-center (make-instance 'qt:line-f

122 :arg0 (make-instance 'qt:point-f

123 :args '(0 0))

124 :arg1 (cxx:map-from-scene mouse 0 0))))

125 (if (> (cxx:length line-to-center) 150)

126 (let ((angle-to-center (acos (/ (cxx:dx line-to-center)

127 (cxx:length line-to-center)))))

128 (when (< (cxx:dy line-to-center) 0)

129 (setf angle-to-center (- (* 2 Pi) angle-to-center)))

130 (setf angle-to-center (normalize-angle (+ (- Pi angle-to-center)

131 (/ Pi 2))))

132 (if (< (/ pi 4) angle-to-center pi)

133 ;; Rotate left

134 (incf (angle mouse) (if (< (angle mouse) (/ Pi -2))

135 0.25 -0.25))

136 (when (and (>= angle-to-center Pi)

137 (< angle-to-center (+ Pi (/ Pi 2) (/ Pi 4))))

138 ;; Rotate right

139 (incf (angle mouse) (if (< (angle mouse) (/ Pi 2))

140 0.25 -0.25)))))

141 (incf (angle mouse) (* (signum (angle mouse)) 0.25))))

142

143 ;; Try not to crash with any other mice

144 (let ((danger-mice

145 (cxx:items (cxx:scene mouse)

146 (make-instance 'qt:polygon-f

147 :arg0

148 (vector (cxx:map-to-scene mouse 0 0)

149 (cxx:map-to-scene mouse -30 -50)

150 (cxx:map-to-scene mouse 30 -50))))))

151 (loop for item across danger-mice

152 unless (eq item mouse) do

153 (let* ((line-to-mouse (make-instance

154 'qt:line-f

155 :arg0 (make-instance 'qt:point-f

156 :args '(0 0))

157 :arg1 (cxx:map-from-item mouse item 0 0)))

158 (angle-to-mouse (acos (/ (cxx:dx line-to-mouse)

159 (cxx:length line-to-mouse)))))

160 (when (< (cxx:dy line-to-mouse) 0)

161 (setf angle-to-mouse (- (* 2 Pi) angle-to-mouse)))

162 (setf angle-to-mouse (normalize-angle (+ (- Pi angle-to-mouse)

163 (/ Pi 2))))

164 (if (and (>= angle-to-mouse 0) (< angle-to-mouse (/ Pi 2)))

165 ;; Rotate right

166 (incf (angle mouse) 0.5)

167 (when (and (<= angle-to-mouse (* 2 Pi))

168 (> angle-to-mouse (- (* 2 Pi) (/ Pi 2))))

169 ;; Rotate left

170 (decf (angle mouse) 0.5)))))

171

172 ;; Add some random movement

173 (when (and (> (length danger-mice) 1)

174 (zerop (random 10)))

175 (if (zerop (random 2))

176 (incf (angle mouse) (/ (random 100) 500d0))

177 (decf (angle mouse) (/ (random 100) 500d0))))

178

179 (incf (mouse-speed mouse) (/ (+ -50 (random 100)) 100d0))

180

181 (let ((dx (* (sin (angle mouse)) 10)))

182 (setf (eye-direction mouse)

183 (if (< (abs (/ dx 5)) 1) 0 (/ dx 5)))

184 (cxx:rotate mouse dx))

185 (cxx:set-pos mouse

186 (cxx:map-to-parent mouse

187 0

188 (- (+ 3

189 (* (sin (mouse-speed mouse))

190 3))))))))

191

192

193 (defconstant +mouse-count+ 7)

194

195 (defun colliding-mice ()

196 "Colliding Mice"

197 (qt:with-app ()

198 (let* ((scene (make-instance 'qt:graphics-scene))

199 (view (make-instance 'qt:graphics-view :arg0 scene))

200 (items)

201 (timer (make-instance 'qt:timer)))

202 ;; Prevent SECENE and TIMER from beeing GCed before VIEW.

203 (setf (qt:property view 'closure)

204 (qt:make-lisp-variant (cons scene timer)))

205 (cxx:set-scene-rect scene -300 -300 600 600)

206 (cxx:set-item-index-method scene qt:graphics-scene.+no-index+)

207 (dotimes (i +mouse-count+)

208 (let ((mouse (make-instance 'mouse)))

209 (cxx:set-pos mouse

210 (* (sin (/ (* i 6.28) +mouse-count+)) 200)

211 (* (cos (/ (* i 6.28) +mouse-count+)) 200))

212 (push mouse items)

213 (cxx:add-item scene mouse)))

214 (cxx:set-render-hint view qt:painter.+antialiasing+)

215 (cxx:set-background-brush

216 view

217 (make-instance 'qt:pixmap

218 :arg0 (concatenate 'string

219 (namestring *source-path*)

220 "/qt/images/cheese.jpg")))

221 (cxx:set-cache-mode view qt:graphics-view.+cache-background+)

222 (cxx:set-viewport-update-mode view qt:graphics-view.+bounding-rect-viewport-update+)

223 (cxx:set-drag-mode view qt:graphics-view.+scroll-hand-drag+)

224 (cxx:set-window-title view "Colliding Mice")

225 (cxx:resize view 400 300)

226 (cxx:show view)

227 (qt:connect (qt:get-signal timer "timeout()")

228 (qt:get-slot scene "advance()"))

229 (cxx:start timer (floor 1000 33))

230 (qt:exec))))