blob: e4dcf92bf2f89a1b9c08dcb5930db16d95efd502 (
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
|
package require sdl
package require oo
set xres 640
set yres 384
set s [sdl.screen $xres $yres "Jim Tcl - SDL, Eventloop integration"]
set col(cyan) {0 255 255}
set col(yellow) {255 255 0}
set col(red) {255 0 0}
set col(green) {0 255 0}
set col(white) {255 255 255}
set col(blue) {0 0 255}
set ncols [dict size $col]
set grey {50 50 50}
class ball {
name -
pos {x 256 y 256}
color {255 255 255}
res {x 512 y 512}
delta {x 3 y 3}
radius 40
havetext 1
}
ball method draw {s} {
$s fcircle $pos(x) $pos(y) $radius {*}$color
if {$havetext} {
$s text "($pos(x),$pos(y))" $pos(x)-25 $pos(y)-5 0 0 0
}
foreach xy {x y} {
incr pos($xy) $delta($xy)
if {$pos($xy) <= $radius + $delta($xy) || $pos($xy) >= $res($xy) - $radius - $delta($xy) || [rand 50] == 1} {
set delta($xy) $(-1 * $delta($xy))
incr pos($xy) $(2 * $delta($xy))
}
}
}
ball method setvar {name_ value_} {
set $name_ $value_
}
try {
$s font [file dirname [info script]]/FreeSans.ttf 12
set havetext 1
} on error msg {
puts $msg
set havetext 0
}
foreach c [dict keys $col] {
set b [ball]
$b setvar name $c
$b setvar res(x) $xres
$b setvar res(y) $yres
$b setvar pos(x) $($xres/2)
$b setvar pos(y) $($yres/2)
$b setvar color [list {*}$col($c) 150]
$b setvar havetext $havetext
lappend balls $b
}
proc draw {balls} {s} {
$s clear {*}$::grey
foreach ball $balls {
$ball draw $s
}
$s flip
}
# Example of integrating the Tcl event loop with SDL
# We need to always be polling SDL, and also run the Tcl event loop
# The Tcl event loop runs from within the SDL poll loop via
# a (non-blocking) call to update
proc heartbeat {} {
puts $([clock millis] % 1000000)
after 250 heartbeat
}
set t1 [clock millis]
draw $balls
heartbeat
$s poll {
draw $balls
update
set t2 [clock millis]
# 33ms = 30 frames/second
if {$t2 - $t1 < 33} {
after $(33 - ($t2 - $t1))
}
set t1 $t2
}
|
