Tcl Source Code

Check-in [ab96ed1ba7]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Full emulation of the Google-balls demo. 40fps, but 3x CPU consumption
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | ferrieux-nacl
Files: files | file ages | folders
SHA1: ab96ed1ba72d8b9b226b52b7063f06068a3e7704
User & Date: ferrieux 2011-04-11 21:11:35
Context
2011-04-11
21:40
Fix wobbling by int($x+0.5) check-in: 164a94c046 user: ferrieux tags: ferrieux-nacl
21:11
Full emulation of the Google-balls demo. 40fps, but 3x CPU consumption check-in: ab96ed1ba7 user: ferrieux tags: ferrieux-nacl
2011-04-10
23:11
First step of a Tk canvas emulation in NaTcl based on the HTML5 canvas. Optimized for move-only upda... check-in: 6f398fb8ef user: ferrieux tags: ferrieux-nacl
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to nacl/README.

︙︙
124
125
126
127
128
129
130

























131
132
133
134
135

     (in   the   same  domain   as   the   page   serving  the   NaTcl
     plugin). Relative URLs work: [source foo.natcl].

   - in all cases, falling back  out of the main scripts is equivalent
     to going  back to the Tk eventloop  in wish (except it  is the JS
     eventloop).


























Future work
-----------

 Coming soon: [domget], [canvas], and a decent bouncing-balls demo ;-)









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|


124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

     (in   the   same  domain   as   the   page   serving  the   NaTcl
     plugin). Relative URLs work: [source foo.natcl].

   - in all cases, falling back  out of the main scripts is equivalent
     to going  back to the Tk eventloop  in wish (except it  is the JS
     eventloop).


The "Google Balls" demo
-----------------------

If you point your chrome to "balls.html" (eg with chrd), you'll get a
full NaTcl emulation of the nice Javascript demo at:

 http://www.html5canvastutorials.com/labs/html5-canvas-google-bouncing-balls

This uses a canvas emulation script "canv.natcl", which demonstrates a
possible  (among  many)  way  of  organizing  Tcl-JS  interaction  for
graphics.  In the balls demo,  items are never destroyed nor shuffled,
which is  a favourable case for  lazy recompilation of  the JS repaint
function (basically the func is written just once, and only the coords
stored in a global array get updated, hence allowing for JIT compiling
of this function).

Perf measurements: the NaTcl version currently costs 3x the CPU of the
JS version,  so at  40fps it consumes  a full  core of my  2GHz laptop
(against 33% for the JS one). 

One should  note that the pure  string API used precludes  any used of
the  internal reps of  coordinates, so  there are  many string/integer
conversions. To be continued.

Future work
-----------

 Coming soon: [domget], more [canvas] features, and optimizations ;-)

Changes to nacl/balls.html.

︙︙
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141

        // It's possible that the Native Client module onload event fired
        // before the page's onload event.  In this case, the status message
        // will reflect 'SUCCESS', but won't be displayed.  This call will
        // display the current message.
        updateStatus();
    }
}

function doeval() {
    try {
        alert(tclModule.eval(this.the_form.input_id.value));
    } catch(e) {
        alert(e.message);
    }
}


</script>
</head>

<body onload="pageDidLoad()">

<h1>NaTcl -- Native Client Tcl Module</h1>








<
<
<
<
<
<
<
<
<








119
120
121
122
123
124
125









126
127
128
129
130
131
132

        // It's possible that the Native Client module onload event fired
        // before the page's onload event.  In this case, the status message
        // will reflect 'SUCCESS', but won't be displayed.  This call will
        // display the current message.
        updateStatus();
    }
}










</script>
</head>

<body onload="pageDidLoad()">

<h1>NaTcl -- Native Client Tcl Module</h1>
︙︙
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168

         id="tcl"
         width=0 height=0
         nacl="tcl.nmf"
         type="application/x-nacl"
         onload="moduleDidLoad();" />
</p>

<p>If the module is working correctly, a click on the "Call eval()" button
  should open a popup dialog containing the Tcl result as its value.</p>

<h2>Status</h2>
<div id="modstatus">NO-STATUS</div>
<hr>
</body>
</html>








|
<







145
146
147
148
149
150
151
152

153
154
155
156
157
158

         id="tcl"
         width=0 height=0
         nacl="tcl.nmf"
         type="application/x-nacl"
         onload="moduleDidLoad();" />
</p>

<p>This is a NaTcl emulation of the "Google Balls" Javascript demo at <a href="http://www.html5canvastutorials.com/labs/html5-canvas-google-bouncing-balls/">http://www.html5canvastutorials.com/labs/html5-canvas-google-bouncing-balls/</a></p>


<h2>Status</h2>
<div id="modstatus">NO-STATUS</div>
<hr>
</body>
</html>

Changes to nacl/balls.natcl. 



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



printf BEFORE-TOPLEVEL-SOURCE



source a.natcl



source b.natcl


source canv.natcl





printf AFTER-TOPLEVEL-SOURCE




















































































































set cnt 0















proc daemon {} {


    after 1000 daemon
    printf DAEMON:$::cnt







    domset statusField "<h1 align='center'>DAEMON:$::cnt</h1>"








    incr ::cnt
    if {$::cnt>10} {
       error "Oh, I barfed !"








    }




}





proc daemon2 {} {




    after 100 daemon2








    foreach id $::lst {
        canv_move $id [expr {-3+int(rand()*7)}] [expr {-3+int(rand()*7)}]



    }


}













#------ Runtime
printf Salut!!!

lappend lst [canv_create rect 100 60 150 80 -fill "#FF0000" -outline "#00FF00"]
lappend lst [canv_create rect 110 70 120 90 -fill "#0000FF" -outline "#FFFF00"]
lappend lst [canv_create rect 150 30 180 40 -fill "#FF00FF" -outline "#00FFFF"]




daemon
daemon2

>
>
|
>
>
>
|
>
>
>
|
>
>
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
|
<
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
|
<
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
|
|
>
>
>
>
|
>
>
>
>
>
>
>
>
|
|
>
>
>
|
>
>

>
>
>
>
>
>
>
>
>
>
>
>




|
|
|
>
>


<
<

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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239



source canv.natcl
domset statusField "Running..."

# will be retrieved by [domget]
set width 576
set height 300

# animation globals
set t 0
set frameInterval 25

# ball globals
set ballRadius 10

# physics global
set collisionDamper 0.3
set floorFriction [expr {0.0005*$frameInterval}]
set mouseForceMultiplier [expr {1.0*$frameInterval}]
set restoreForce  [expr {0.002*$frameInterval}]

set mouseX 99999
set mouseY 99999
 
set balls {}

set blue   "#3A5BCD"
set red    "#EF2B36"
set yellow "#FFC636"
set green  "#02A817"

proc newball {x y vx vy col} {
    set id [canv_create circle $x $y $::ballRadius -fill $col -outline ""]
    set ::b($id) [list $x $y $vx $vy $x $y]
    lappend ::balls $id
}

# G
newball 173 63 0 0 $blue
newball 158 53 0 0 $blue
newball 143 52 0 0 $blue
newball 130 53 0 0 $blue
newball 117 58 0 0 $blue
newball 110 70 0 0 $blue
newball 102 82 0 0 $blue
newball 104 96 0 0 $blue
newball 105 107 0 0 $blue
newball 110 120 0 0 $blue
newball 124 130 0 0 $blue
newball 139 136 0 0 $blue
newball 152 136 0 0 $blue
newball 166 136 0 0 $blue
newball 174 127 0 0 $blue
newball 179 110 0 0 $blue
newball 166 109 0 0 $blue
newball 156 110 0 0 $blue
 
# O
newball 210 81 0 0 $red
newball 197 91 0 0 $red
newball 196 103 0 0 $red
newball 200 116 0 0 $red
newball 209 127 0 0 $red
newball 223 130 0 0 $red
newball 237 127 0 0 $red
newball 244 114 0 0 $red
newball 242 98 0 0 $red
newball 237 86 0 0 $red
newball 225 81 0 0 $red
 
# O
set oOffset 67
newball [expr {$oOffset + 210}] 81 0 0 $yellow
newball [expr {$oOffset + 197}] 91 0 0 $yellow
newball [expr {$oOffset + 196}] 103 0 0 $yellow
newball [expr {$oOffset + 200}] 116 0 0 $yellow
newball [expr {$oOffset + 209}] 127 0 0 $yellow
newball [expr {$oOffset + 223}] 130 0 0 $yellow
newball [expr {$oOffset + 237}] 127 0 0 $yellow
newball [expr {$oOffset + 244}] 114 0 0 $yellow
newball [expr {$oOffset + 242}] 98 0 0 $yellow
newball [expr {$oOffset + 237}] 86 0 0 $yellow
newball [expr {$oOffset + 225}] 81 0 0 $yellow
 
# G
newball 370 80 0 0 $blue
newball 358 79 0 0 $blue
newball 346 79 0 0 $blue
newball 335 84 0 0 $blue
newball 330 98 0 0 $blue
newball 334 111 0 0 $blue
newball 348 116 0 0 $blue
newball 362 109 0 0 $blue
newball 362 94 0 0 $blue
newball 355 128 0 0 $blue
newball 340 135 0 0 $blue
newball 327 142 0 0 $blue
newball 325 155 0 0 $blue
newball 339 165 0 0 $blue
newball 352 166 0 0 $blue
newball 367 161 0 0 $blue
newball 371 149 0 0 $blue
newball 366 137 0 0 $blue
 
# L
newball 394 49 0 0 $green
newball 381 50 0 0 $green
newball 391 61 0 0 $green
newball 390 73 0 0 $green
newball 392 89 0 0 $green
newball 390 105 0 0 $green
newball 390 118 0 0 $green
newball 388 128 0 0 $green
newball 400 128 0 0 $green
 
# E
newball 426 101 0 0 $red
newball 436 98 0 0 $red
newball 451 95 0 0 $red
newball 449 83 0 0 $red
newball 443 78 0 0 $red
newball 430 77 0 0 $red
newball 418 82 0 0 $red
newball 414 93 0 0 $red
newball 412 108 0 0 $red
newball 420 120 0 0 $red
newball 430 127 0 0 $red
newball 442 130 0 0 $red
newball 450 125 0 0 $red

set oldcnt 0
proc computeFps {} {
     set fps [expr $::cnt-$::oldcnt]
     set ::oldcnt $::cnt
     domset statusField "Running - $fps fps"
}

set cnt 0
proc updateStage {} {
    incr ::cnt
    foreach id $::balls {
	foreach {x y vx vy rx ry} $::b($id) break
	# set ball position based on velocity
	set x [expr {$x+$vx}]
	set y [expr {$y+$vy}]
	# restore forces
	if {$x>$rx} {
	    set vx [expr {$vx-$::restoreForce}]
	} else {
	    set vx [expr {$vx+$::restoreForce}]
	}
	if {$y>$ry} {
	    set vy [expr {$vy-$::restoreForce}]
	} else {
	    set vy [expr {$vy+$::restoreForce}]
	}
	# mouse forces

	set distX [expr {$x-$::mouseX}]
	set distY [expr {$y-$::mouseY}]
	set radius [expr {hypot($distX,$distY)}]
	set totalDist [expr {abs($distX)+abs($distY)}]
	set forceX [expr {(abs($distX)/double($totalDist))*(1.0/$radius)*$::mouseForceMultiplier}]
	set forceY [expr {(abs($distY)/double($totalDist))*(1.0/$radius)*$::mouseForceMultiplier}]
	if {$distX>0} { # mouse is left of ball
	    set vx [expr {$vx+$forceX}]
	} else {
	    set vx [expr {$vx-$forceX}]
	}
	if {$distY>0} { # mouse is on top of ball
	    set vy [expr {$vy+$forceY}]
	} else {
	    set vy [expr {$vy-$forceY}]
	}
	# floor friction
	if {$vx>0} {

	    set vx [expr {$vx-$::floorFriction}]
	} elseif {$vx<0} {
	    set vx [expr {$vx+$::floorFriction}]
	}
	if {$vy>0} {
	    set vy [expr {$vy-$::floorFriction}]
	} elseif {$vy<0} {
	    set vy [expr {$vy+$::floorFriction}]
	}
	# floor condition
	if {$y>($::height-$::ballRadius)} {
	    set y [expr {$::height-$::ballRadius-2}]
	    set vy [expr {-$vy*(1.0-$::collisionDamper)}]
	}
	# ceiling condition
	if {$y<$::ballRadius} {
	    set y [expr {$::ballRadius+2}]
	    set vy [expr {-$vy*(1.0-$::collisionDamper)}]
	}
	# right wall condition
	if {$x>($::width-$::ballRadius)} {
	    set x [expr {$::width-$::ballRadius-2}]
	    set vx [expr {-$vx*(1.0-$::collisionDamper)}]
	}
	# left wall condition
	if {$x<$::ballRadius} {
	    set x [expr {$::ballRadius+2}]
	    set vx [expr {-$vx*(1.0-$::collisionDamper)}]
	}
	set ::b($id) [list $x $y $vx $vy $rx $ry]
	canv_moveto $id [expr {int($x)}] [expr {int($y)}]
    }
}
    

proc motioncb {x y} {
    set ::mouseX $x
    set ::mouseY $y
}
proc entercb {} {
    printf "Enter Canvas !!!"
}
proc leavecb {} {
    printf "Leave Canvas !!!"
    set ::mouseX 99999
    set ::mouseY 99999
}

canv_bind <Motion> motioncb
canv_bind <Enter> entercb
canv_bind <Leave> leavecb

every $frameInterval updateStage
every 1000 computeFps

#------ Runtime
printf Salut!!!

#lappend lst [canv_create rect 100 60 150 80 -fill "#FF0000" -outline "#00FF00"]
#lappend lst [canv_create rect 110 70 120 90 -fill "#0000FF" -outline "#FFFF00"]
#lappend lst [canv_create rect 150 30 180 40 -fill "#FF00FF" -outline "#00FFFF"]
#lappend lst [canv_create circle 170 90 40 -fill "#FF0000" -outline ""]
#lappend lst [canv_create circle 90 30 20 -fill "" -outline "#FF00FF"]

Changes to nacl/canv.natcl. 

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

#
#  crude canvas emulation for NaTcl -- mapping to HTML5 canvas
#


set ::canv_uniq 1
set ::canv_hooked 0
set ::canv_tlist {}
set ::canv_jlist {}
set ::canv_status_func 0
set ::canv_status_coords 0

# canv_status_coords : 1: some old items moved
# canv_status_func: 0:unchanged 1:new-items-on-top 2:changed

proc canv_addhook {} {
    if {$::canv_hooked} return
    set ::canv_hooked 1
    lappend ::naclhooks canv_hook
}

proc canv_new_items {} {
    return [lrange $::canv_tlist [llength $::canv_jlist] end]
}

proc canv_compile_repaint l {
    set j ""
    set oldprep ""
    foreach i $l {
	set prep $::canv_jprep($i)




>




|













|








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

#
#  crude canvas emulation for NaTcl -- mapping to HTML5 canvas
#
set ::canv_verbose 0

set ::canv_uniq 1
set ::canv_hooked 0
set ::canv_tlist {}
set ::canv_jcnt 0
set ::canv_status_func 0
set ::canv_status_coords 0

# canv_status_coords : 1: some old items moved
# canv_status_func: 0:unchanged 1:new-items-on-top 2:changed

proc canv_addhook {} {
    if {$::canv_hooked} return
    set ::canv_hooked 1
    lappend ::naclhooks canv_hook
}

proc canv_new_items {} {
    return [lrange $::canv_tlist $::canv_jcnt end]
}

proc canv_compile_repaint l {
    set j ""
    set oldprep ""
    foreach i $l {
	set prep $::canv_jprep($i)
︙︙
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

97
98




99
100










101
102
103

104
105
106
107
108
109
110
111
112
113
114
115
116
117

118


119



120
121
122
123
124
125






















	    set jnew [canv_compile_repaint [canv_new_items]]
	    append ::canv_jcode $jnew
	    append js "repaint = function(){\n$::canv_jcode\n}\n"
	    if {!$repaint} {
		# old ones didn't move: just draw the new ones
		append js $jnew
	    }
	    set ::canv_jlist $::canv_tlist
	}
	2 {
	    # invalid, recompute
	    set ::canv_jcode "context.clearRect(0,0,canvas.width,canvas.height);
\n"
	    append ::canv_jcode [canv_compile_repaint $::canv_tlist]
	    append js "repaint=function(){\n$::canv_jcode\n}\n"
	    set ::canv_jlist $::canv_tlist
	    set repaint 1
	}
    }
    foreach i [array names ::canv_moved] {
	append js "canvcoords\[$i\]=\[[join $::canv_coords($i) ,]\];\n"
    }
    if {$repaint} {
	append js "repaint();\n"
    }
    set ::canv_status_func 0
    set ::canv_status_coords 0
    array unset ::canv_moved

    if {[info exists js]} {

	printf "CANV_HOOK emits:\n$js\n"

	append ::JS $js
    }
}




































proc canv_create {ty args} {
    set id $::canv_uniq
    incr ::canv_uniq
    lappend ::canv_tlist $id
    set att(-fill) "#FFFFFF"
    set att(-outline) "#000000"
    switch -exact -- $ty {
	rect {

	    set ::canv_coords($id) [lrange $args 0 3]
	    array set att [lrange $args 4 end]




	    set ::canv_jprep($id) "context.strokeStyle='$att(-outline)';context.fillStyle='$att(-fill)';\n"
	    set ::canv_jdraw($id) "context.beginPath();context.rect(canvcoords\[$id\]\[0\],canvcoords\[$id\]\[1\],canvcoords\[$id\]\[2\]-canvcoords\[$id\]\[0\],canvcoords\[$id\]\[3\]-canvcoords\[$id\]\[1\]);context.fill();context.stroke();\n"










	}
	default {error "Unknown canv item type '$ty'"}
    }

    if {!$::canv_status_func} {
	# incremental
	set ::canv_status_func 1
    }
    set ::canv_moved($id) 1
    canv_addhook
    return $id
}

proc canv_move {id dx dy} {
    set cc {}
    foreach {x y} $::canv_coords($id) {
	incr x $dx
	incr y $dy

	lappend cc $x $y


    }



    set ::canv_coords($id) $cc
    if {![info exists ::canv_moved($id)]} {
	set ::canv_moved($id) 1
	set ::canv_status_coords 1
    }
}





























|







|














>
|
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









>
|

>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>



>










<
|
|
|
>
|
>
>

>
>
>
|





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205

	    set jnew [canv_compile_repaint [canv_new_items]]
	    append ::canv_jcode $jnew
	    append js "repaint = function(){\n$::canv_jcode\n}\n"
	    if {!$repaint} {
		# old ones didn't move: just draw the new ones
		append js $jnew
	    }
	    set ::canv_jcnt [llength $::canv_tlist]
	}
	2 {
	    # invalid, recompute
	    set ::canv_jcode "context.clearRect(0,0,canvas.width,canvas.height);
\n"
	    append ::canv_jcode [canv_compile_repaint $::canv_tlist]
	    append js "repaint=function(){\n$::canv_jcode\n}\n"
	    set ::canv_jcnt [llength $::canv_tlist]
	    set repaint 1
	}
    }
    foreach i [array names ::canv_moved] {
	append js "canvcoords\[$i\]=\[[join $::canv_coords($i) ,]\];\n"
    }
    if {$repaint} {
	append js "repaint();\n"
    }
    set ::canv_status_func 0
    set ::canv_status_coords 0
    array unset ::canv_moved

    if {[info exists js]} {
	if {$::canv_verbose} {
	    printf "CANV_HOOK emits:\n$js\n"
	}
	append ::JS $js
    }
}

proc lremove {l e} {
     set out {}
    foreach x $l {
	if {$x==$e} continue
	lappend out $x
    }
    return $out
}

proc canv_delete id { 
    if {$id=="all"} {
	array unset ::canv_moved
	array unset ::canv_coords
	array unset ::canv_jprep
	array unset ::canv_jdraw
	set ::canv_tlist {}
	set ::canv_status_func 2
    } else {
	catch {unset ::canv_moved($id)}
	unset ::canv_coords($id)
	unset ::canv_jprep($id)
	unset ::canv_jdraw($id)
	set ::canv_tlist [lremove $::canv_tlist $id]
	set ::canv_status_func 2
    }
    canv_addhook
}

proc canv_find tag {
    if {$tag!="all"} {
	error "Unsupported tag '$tag'"
    }
    return $::canv_tlist
}

proc canv_create {ty args} {
    set id $::canv_uniq
    incr ::canv_uniq
    lappend ::canv_tlist $id
    set att(-fill) "#FFFFFF"
    set att(-outline) "#000000"
    switch -exact -- $ty {
	rect {
	    foreach {x1 y1 x2 y2} $args break
	    set ::canv_coords($id) [list $x1 $y1 [expr {$x2-$x1}] [expr {$y2-$y1}]]
	    array set att [lrange $args 4 end]
	    set prep ""
	    set draw ""
	    if {$att(-outline)!=""} {append prep "context.strokeStyle='$att(-outline)';";append draw "context.stroke();"}
	    if {$att(-fill)!=""} {append prep "context.fillStyle='$att(-fill)';";append draw "context.fill();"}
	    set ::canv_jprep($id) $prep
	    set ::canv_jdraw($id) "context.beginPath();context.rect(canvcoords\[$id\]\[0\],canvcoords\[$id\]\[1\],canvcoords\[$id\]\[2\],canvcoords\[$id\]\[3\]);$draw\n"
	}
	circle {
	    set ::canv_coords($id) [lrange $args 0 2]
	    array set att [lrange $args 3 end]
	    set prep ""
	    set draw ""
	    if {$att(-outline)!=""} {append prep "context.strokeStyle='$att(-outline)';";append draw "context.stroke();"}
	    if {$att(-fill)!=""} {append prep "context.fillStyle='$att(-fill)';";append draw "context.fill();"}
	    set ::canv_jprep($id) $prep
	    set ::canv_jdraw($id) "context.beginPath();context.arc(canvcoords\[$id\]\[0\],canvcoords\[$id\]\[1\],canvcoords\[$id\]\[2\],0,2*Math.PI,0);$draw\n"
	}
	default {error "Unknown canv item type '$ty'"}
    }
    set ::canv_type($id) $ty
    if {!$::canv_status_func} {
	# incremental
	set ::canv_status_func 1
    }
    set ::canv_moved($id) 1
    canv_addhook
    return $id
}

proc canv_move {id dx dy} {

    foreach {x y} $::canv_coords($id) break
    incr x $dx
    incr y $dy
    set ::canv_coords($id) [concat [list $x $y] [lrange $::canv_coords($id) 2 end]]
    if {![info exists ::canv_moved($id)]} {
	set ::canv_moved($id) 1
	set ::canv_status_coords 1
    }
}

proc canv_moveto {id x y} {
    set ::canv_coords($id) [concat [list $x $y] [lrange $::canv_coords($id) 2 end]]
    if {![info exists ::canv_moved($id)]} {
	set ::canv_moved($id) 1
	set ::canv_status_coords 1
    }
}

proc canv_bind {evt cb} {
    switch -exact -- $evt {
	<Motion> {
	    append ::JS "canvas.onmousemove = function (evt) {
			tclDo([jsquote "$cb "]+(evt.clientX-canvas.offsetLeft)+' '+(evt.clientY-canvas.offsetTop));
		};\n"
	}
	<Leave> {
	    append ::JS "canvas.onmouseout = function (evt) {
			tclDo([jsquote "$cb "]);
		};\n"
	}
	<Enter> {
	    append ::JS "canvas.onmouseover = function (evt) {
			tclDo([jsquote "$cb "]);
		};\n"
	}
	default {error "Unsupported event '$evt'"}
    }
}

Changes to nacl/init.natcl.

︙︙
36
37
38
39
40
41
42






43
44
45
46
47
48

}

# Async [after] using JS's setTimeout()
proc after {ms script} {
    if {[regexp \n $script]} {error "JS hates multiline :)"}
    append ::JS "setTimeout(\"tclDo([jsquote $script])\",$ms);\n"
}







# Delayed DOM-setting through the tclDo() trampoline
proc domset {element inner} {
    append ::JS "$element.innerHTML=[jsquote $inner];\n"
}









>
>
>
>
>
>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

}

# Async [after] using JS's setTimeout()
proc after {ms script} {
    if {[regexp \n $script]} {error "JS hates multiline :)"}
    append ::JS "setTimeout(\"tclDo([jsquote $script])\",$ms);\n"
}

# Async [every] using JS's setInterval()
proc every {ms script} {
    if {[regexp \n $script]} {error "JS hates multiline :)"}
    append ::JS "setInterval(\"tclDo([jsquote $script])\",$ms);\n"
}

# Delayed DOM-setting through the tclDo() trampoline
proc domset {element inner} {
    append ::JS "$element.innerHTML=[jsquote $inner];\n"
}

This page was generated in about 0.017s by Fossil 2.24 [f4ffefe708] 2024-04-17 14:02:19