smalltalk-tng: c4a0718c2d3c experiments/gui.ss

smalltalk-tng

view experiments/gui.ss @ 321:c4a0718c2d3c

Sketch of dependencies

author	Tony Garnock-Jones <tonygarnockjones@gmail.com>
date	Sat Oct 08 15:36:03 2011 -0400 (7 months ago)
parents
children

line source

1 ; GUI.SS Graphical User Interface for LISP2

2 ;

4 ; tonyg@kcbbs.gen.nz

5 ;

7 ;----------------------------------------------------------------------------;

8 ; Graphics toolbox calls.

9 ;----------------------------------------------------------------------------;

11 (require 'form)

13 (define (rectangle rule thickness x y w h)

14 (apply BitBlt screen-form '() '() rule

15 x y thickness h

16 (append clipping-rectangle '(0 0)))

17 (apply BitBlt screen-form '() '() rule

18 x y w thickness

19 (append clipping-rectangle '(0 0)))

20 (apply BitBlt screen-form '() '() rule

21 (+ x (- w thickness)) y thickness h

22 (append clipping-rectangle '(0 0)))

23 (apply BitBlt screen-form '() '() rule

24 x (+ y (- h thickness)) w thickness

25 (append clipping-rectangle '(0 0))))

27 (define (fill-rect shade rule x y w h)

28 (apply BitBlt screen-form '() shade rule

29 x y w h

30 (append clipping-rectangle '(0 0))))

32 ;----------------------------------------------------------------------------;

33 ; The window system proper.

34 ;----------------------------------------------------------------------------;

36 ;;; Class <rectangle>

37 ;;;

38 ;;; Represents a rectangle; used in screen geometry calculations.

40 (define-class <rectangle> <object> (x y w h))

42 ;;; (<rectangle> new: x y w h)

43 ;;;

44 ;;; Creates and returns a rectangle with the specified coordinates.

46 (define-class-method <rectangle> (self new: x y w h)

47 (let ((n (self new)))

48 (n set: <rectangle> x x)

49 (n set: <rectangle> y y)

50 (n set: <rectangle> w w)

51 (n set: <rectangle> h h)

52 n))

54 ;;; (rect x2)

55 ;;; (rect y2)

56 ;;;

57 ;;; Return the coordinates of the right-hand lower corner of the rectangle.

59 (define-method <rectangle> (self x2)

60 (+ (self : <rectangle> x) (self : <rectangle> w)))

62 (define-method <rectangle> (self y2)

63 (+ (self : <rectangle> y) (self : <rectangle> h)))

65 ;;; (rect write-to: port)

66 ;;; (rect display-to: port)

67 ;;;

68 ;;; Displays the textual representation of a rectangle to the given IO port.

70 (let ((method

71 (lambda (self port)

72 (display-to port "#<rectangle ")

73 (display-to port (self : <rectangle> x)) (display-to port " ")

74 (display-to port (self : <rectangle> y)) (display-to port " ")

75 (display-to port (self : <rectangle> w)) (display-to port " ")

76 (display-to port (self : <rectangle> h))

77 (display-to port ">"))))

78 (<rectangle> add-method: 'write-to: method)

79 (<rectangle> add-method: 'display-to: method))

81 ;;; (rect contains? x y)

82 ;;;

83 ;;; Returns true if the rectangle contains the point (x, y); otherwise

84 ;;; returns false.

86 (define-method <rectangle> (self contains? x y)

87 (and (>= x (self : <rectangle> x))

88 (>= y (self : <rectangle> y))

89 (<= (- x (self : <rectangle> x)) (self : <rectangle> w))

90 (<= (- y (self : <rectangle> y)) (self : <rectangle> h))))

92 ;;; (min a b)

93 ;;; (max a b)

94 ;;;

95 ;;; Return the minimum/maximum of the two arguments.

97 (define (min a b)

98 (if (< a b) a b))

100 (define (max a b)

101 (if (> a b) a b))

102

103 ;;; (rect intersect: rect2)

104 ;;;

105 ;;; Returns either a new rectangle, which is the area common to both arguments,

106 ;;; or #f if there is no overlap.

107

108 (define-method <rectangle> (self intersect: other)

109 (let ((result (<rectangle> new:

110 (max (self : <rectangle> x) (other : <rectangle> x))

111 (max (self : <rectangle> y) (other : <rectangle> y))

112 (min (self x2) (other x2))

113 (min (self y2) (other y2)))))

114 (result set: <rectangle> w

115 (- (result : <rectangle> w) (result : <rectangle> x)))

116 (result set: <rectangle> h

117 (- (result : <rectangle> h) (result : <rectangle> y)))

118 (if (or (<= (result : <rectangle> w) 0)

119 (<= (result : <rectangle> h) 0))

120 #f

121 result)))

122

123 ;;; (rect not)

124 ;;;

125 ;;; Returns a list of rectangles, which when taken together cover all of a

126 ;;; 640x480 screen excluding the area covered by the argument.

127

128 (define-method <rectangle> (self not)

129 (list

130 (<rectangle> new: 0 (self : <rectangle> y)

131 (self : <rectangle> x) (self : <rectangle> h))

132 (<rectangle> new: (self x2) (self : <rectangle> y)

133 (- 640 (self x2)) (self : <rectangle> h))

134 (<rectangle> new: 0 0

135 640 (self : <rectangle> y))

136 (<rectangle> new: 0 (self y2)

137 640 (- 480 (self y2)) )))

138

139 ;;; (rect ->list)

140 ;;;

141 ;;; Returns a list containing x, y, w and h.

142

143 (define-method <rectangle> (self ->list)

144 (list

145 (self : <rectangle> x)

146 (self : <rectangle> y)

147 (self : <rectangle> w)

148 (self : <rectangle> h)))

149

150 ;;; (rect grow: xdelta ydelta)

151 ;;;

152 ;;; Changes size of rect by adding/subtracting xdelta or ydelta to/from each

153 ;;; coordinate.

154

155 (define-method <rectangle> (self grow: x y)

156 (self set: <rectangle> x (- (self : <rectangle> x) x))

157 (self set: <rectangle> y (- (self : <rectangle> y) y))

158 (self set: <rectangle> w (+ (self : <rectangle> w) (* x 2)))

159 (self set: <rectangle> h (+ (self : <rectangle> h) (* y 2))))

160

161 ;;; (rect move: xdelta ydelta)

162 ;;;

163 ;;; Changes position of rect by adding xdelta or ydelta to each coordinate.

164

165 (define-method <rectangle> (self move: x y)

166 (self set: <rectangle> x (+ (self : <rectangle> x) x))

167 (self set: <rectangle> y (+ (self : <rectangle> y) y)))

168

169 ;;; (rect copy)

170 ;;;

171 ;;; Returns a new <rectangle> identical to the argument.

172

173 (define-method <rectangle> (self copy)

174 (apply ((self class) get-class-method: 'new:) (self class) (self ->list)))

175

176 ;;; (rect top-left)

177 ;;; (rect bottom-right)

178 ;;;

179 ;;; Return coordinates of the corner requested.

180

181 (define-method <rectangle> (self top-left)

182 (list

183 (self : <rectangle> x)

184 (self : <rectangle> y)))

185

186 (define-method <rectangle> (self bottom-right)

187 (list

188 (self x2)

189 (self y2)))

190

191 ;----------------------------------------------------------------------------;

192

193 ;;; Class <view>

194 ;;;

195 ;;; Abstract windowable (displayable) object.

196 ;;; Instance variables:

197 ;;; bounds The rectangle representing the area of the screen covered

198 ;;; by the view.

199 ;;; owner The view under which this view is logically grouped.

200 ;;; children Views logically grouped under this view.

201

202 (define-class <view> <object> (bounds owner children))

203

204 ;;; (<view> new: x y w h owner)

205 ;;;

206 ;;; Creates and returns a view with the given coordinates, and the given

207 ;;; logical owning view.

208

209 (define-class-method <view> (self new: x y w h owner)

210 (let ((n (self new)))

211 (n set: <view> bounds (<rectangle> new: x y w h))

212 (n set: <view> children '())

213 (unless (null? owner)

214 (owner add-child: n))

215 n))

216

217 ;;; (view destroy)

218 ;;;

219 ;;; Cleans up as a view is removing itself from the windowing system.

220

221 (define-method <view> (self destroy)

222 (unless (null? (self : <view> owner))

223 ((self : <view> owner) remove-child: self)))

224

225 ;;; (view has-focus?)

226 ;;;

227 ;;; Returns true if this view has the input focus.

228

229 (define-method <view> (self has-focus?)

230 (eq? (desktop : <desktop> focus) self))

231

232 ;;; (view paint: rect)

233 ;;;

234 ;;; Sets up the graphics system to draw stuff in the area specified by rect.

235

236 (define-method <view> (self paint: area)

237 (set! clipping-rectangle (area ->list)))

238

239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

240

241 ;;; (view draw: rect)

242 ;;;

243 ;;; Repaints the areas of view and its children which are contained within the

244 ;;; region of the screen represented by rect.

245 ;;;

246 ;;; WARNING: The primitive form of this method relies on the structure of the

247 ;;; classes <view> and <rectangle>. Be careful when changing those classes to

248 ;;; also update the information used by this method.

249

250 (<view> add-method: 'draw: %%draw-method-for-<view>-objects)

251

252 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

253

254 ;;; (view add-child: child)

255 ;;; (view remove-child: child)

256 ;;;

257 ;;; Add or remove child views from a view.

258

259 (define-method <view> (self add-child: child)

260 (unless (member child (self : <view> children))

261 (child set: <view> owner self)

262 (self set: <view> children

263 (cons child (self : <view> children)))))

264

265 (define-method <view> (self remove-child: child)

266 (let ((l (member child (self : <view> children))))

267 (when l

268 (child set: <view> owner '())

269 (if (null? (cdr l))

270 (set-car! l #f)

271 (begin

272 (set-car! l (cadr l))

273 (set-cdr! l (cddr l)))))))

274

275 ;----------------------------------------------------------------------------;

276

277 ;;; Class <desktop>

278 ;;;

279 ;;; The root view in the windowing system is an instance of class <desktop>.

280

281 (define-class <desktop> <view> (focus))

282

283 ;;; (<desktop> new)

284 ;;;

285 ;;; Creates a new desktop, setting its logical boundaries to the screen size.

286

287 (define-class-method <desktop> (self new)

288 (let ((n (self as: <view> new)))

289 (n set: <view> bounds

290 (<rectangle> new: 0 0 640 480))

291 (n set: <desktop> focus '())

292 n))

293

294 ;;; (desktop paint: area)

295 ;;;

296 ;;; Redraws areas of the desktop.

297

298 (define-method <desktop> (self paint: area)

299 (self as: <view> paint: area)

300 (apply fill-rect grey-25 3 ((self : <view> bounds) ->list)))

301

302 ;;; (desktop draw)

303 ;;;

304 ;;; Refresh the entire screen.

305

306 (define-method <desktop> (self draw)

307 (self draw: (self : <view> bounds)))

308

309 ;----------------------------------------------------------------------------;

310

311 ;;; Class <window>

312 ;;;

313 ;;; This is pretty self-evident :-)

314

315 (define-class <window> <view> (title flags))

316

317 ;;; (<window> new: x y w h owner title)

318 ;;;

319 ;;; Creates and returns a window with the specified attributes.

320

321 (define-class-method <window> (self new: x y w h owner title)

322 (let ((n (self as: <view> new: x y w h owner)))

323 (n set: <window> title title)

324 n))

325

326 ;;; (window paint: area)

327 ;;;

328 ;;; Refresh areas of the window.

329

330 (define-method <window> (self paint: area)

331 (self as: <view> paint: area)

332 (let ((bounds ((self : <view> bounds) copy)))

333 (apply fill-rect '() 15 (bounds ->list))

334 (apply rectangle 0 2 (bounds ->list))

335 (bounds grow: -2 -2)

336 (bounds set: <rectangle> h (+ (gui-font : <font> height) 2))

337 (screen-form print-string:

338 (self : <window> title)

339 (+ (bounds : <rectangle> x) 2)

340 (+ (bounds : <rectangle> y) 2)

341 gui-font 4)

342 (apply BitBlt screen-form '() '() 0

343 (bounds : <rectangle> x) (bounds y2)

344 (bounds : <rectangle> w) 2

345 (append clipping-rectangle '(0 0)))

346 (if (self has-focus?)

347 (apply BitBlt screen-form '() '() 10

348 (append (bounds ->list)

349 clipping-rectangle

350 '(0 0)))

351 (apply BitBlt screen-form '() grey-25 4

352 (append (bounds ->list)

353 clipping-rectangle

354 '(0 0))))))

355

356 ;----------------------------------------------------------------------------;

357

358 ;;; desktop

359 ;;;

360 ;;; The system-wide desktop.

361

362 (define desktop (<desktop> new))

363

364 (desktop add-child: (<window> new: 100 100 (- 200 100) (- 200 100) desktop "Title 2"))

365 (desktop add-child: (<window> new: 370 300 (- 620 370) (- 460 300) desktop "Title 3"))

366 (desktop add-child: (<window> new: 320 50 (- 420 320) (- 450 50) desktop "Title 4"))

367 (desktop add-child: (<window> new: 120 160 (- 500 120) (- 400 160) desktop "Title 5"))

368 (desktop add-child: (<window> new: 140 120 (- 400 140) (- 300 120) desktop "Title 9"))

369 (desktop add-child: (<window> new: 50 140 (- 550 50) (- 350 140) desktop "Title 7"))

370 (desktop add-child: (<window> new: 150 150 (- 250 150) (- 250 150) desktop "Title 14"))

371

372 (define gui-font smalthin-font) ;modernb-font)

373

374 (define (test-gui)

375 (graphics-mode)

376 (desktop draw)

377 (let ((background (<form> new: 8 16)))

378 (let loop ((state (get-mouse)))

379 (let ((x (list-ref state 0))

380 (y (list-ref state 1))

381 (b (list-ref state 2)))

382 (unless (= b 7)

383 (if (= b 3)

384 (desktop draw))

385 (set! clipping-rectangle '(0 0 640 480))

386 (BitBlt background screen-form '() 3

387 0 0 8 16

388 0 0 8 16

389 x y)

390 (screen-form print-string: "" x y system-font 4)

391 (BitBlt screen-form background '() 3

392 x y 8 16

393 0 0 640 480

394 0 0)

395 (loop (get-mouse))))))

396 (text-mode))

397