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: |
ab96ed1ba72d8b9b226b52b7063f0606 |
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
Changes to nacl/README.
︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 | (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 ----------- | > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 | // 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(); } } | < < < < < < < < < | 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 | id="tcl" width=0 height=0 nacl="tcl.nmf" type="application/x-nacl" onload="moduleDidLoad();" /> </p> | | < | 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 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 | # # crude canvas emulation for NaTcl -- mapping to HTML5 canvas # set ::canv_uniq 1 set ::canv_hooked 0 set ::canv_tlist {} | > | | | 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 | 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 } | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | > > > > > > > > > > > < | | | > | > > > > > | > > > > > > > > > > > > > > > > > > > > > | 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" } |