Tcl Source Code

Check-in [6f398fb8ef]
Login

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

Overview
Comment:First step of a Tk canvas emulation in NaTcl based on the HTML5 canvas. Optimized for move-only updates.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | ferrieux-nacl
Files: files | file ages | folders
SHA1: 6f398fb8eff95b265baed0df6e81a65d3984887f
User & Date: ferrieux 2011-04-10 23:11:38
Context
2011-04-11
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
11:25
Cleanup of init, wrappers now compiled in. Coro-based [source $url]. Detailed description in README. check-in: 4d49dfa58c user: ferrieux tags: ferrieux-nacl
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to nacl/balls.html.

9
10
11
12
13
14
15
16







17
18
19
20
21
22
23

    <title>NaTcl : Tcl in Nacl</title>

  <script type="text/javascript">

     // NaTcl -- JS glue
     
tclModule = null;  // our singleton Tcl interp








// debugging stuff

function printf(s)
{
    // I like debugging to stderr instead of console.log,
    // because when things go wrong, the JS console is not







|
>
>
>
>
>
>
>







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

    <title>NaTcl : Tcl in Nacl</title>

  <script type="text/javascript">

     // NaTcl -- JS glue
     
var tclModule = null;  // our singleton Tcl interp

var canvas = null;
var context = null;
var canvcoords = [];

// give it global scope. will be regen'd by canv code.
function repaint() {}

// debugging stuff

function printf(s)
{
    // I like debugging to stderr instead of console.log,
    // because when things go wrong, the JS console is not
100
101
102
103
104
105
106


107
108
109
110
111
112
113

// If the page loads before the Native Client module loads, then set the
// status message indicating that the module is still loading.  Otherwise,
// do not change the status message.

function pageDidLoad() {
    statusField = document.getElementById('modstatus');


    if (tclModule == null) {
        updateStatus('Loading Nacl...');
    } else {
        // 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.







>
>







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

// If the page loads before the Native Client module loads, then set the
// status message indicating that the module is still loading.  Otherwise,
// do not change the status message.

function pageDidLoad() {
    statusField = document.getElementById('modstatus');
    canvas=document.getElementById('canvas');
    context=canvas.getContext("2d");
    if (tclModule == null) {
        updateStatus('Loading Nacl...');
    } else {
        // 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.
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
</script>
</head>

<body onload="pageDidLoad()">

<h1>NaTcl -- Native Client Tcl Module</h1>
<p>
  <form name="the_form" action="" method="get">
  <textarea id="input_id" name="inputbox" rows="15" cols="80">list a b c
</textarea><p>
  <input type="button" value="Call eval()" onclick="doeval()">
  </form>
  <!-- Load the published .nexe.  This includes the 'nacl' attribute which
  shows how to load multi-architecture modules.  Each entry in the "nexes"
  object in the  .nmf manifest file is a key-value pair: the key is the runtime
  ('x86-32', 'x86-64', etc.); the value is a URL for the desired NaCl module.
  To load the debug versions of your .nexes, set the 'nacl' attribute to the
  _dbg.nmf version of the manifest file.
  -->







|
|
|
<
<







136
137
138
139
140
141
142
143
144
145


146
147
148
149
150
151
152
</script>
</head>

<body onload="pageDidLoad()">

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

  <canvas id="canvas" width="576" height="300"></canvas>



  <!-- Load the published .nexe.  This includes the 'nacl' attribute which
  shows how to load multi-architecture modules.  Each entry in the "nexes"
  object in the  .nmf manifest file is a key-value pair: the key is the runtime
  ('x86-32', 'x86-64', etc.); the value is a URL for the desired NaCl module.
  To load the debug versions of your .nexes, set the 'nacl' attribute to the
  _dbg.nmf version of the manifest file.
  -->

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

printf BEFORE-TOPLEVEL-SOURCE
source a.natcl
source b.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 !"
    }
}








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






daemon




>













>
>
>
>
>
>
>



>
>
>
>
>
>

>
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

Added 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
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
#
#  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)
	if {[string compare $prep $oldprep]} {
	    set oldprep $prep
	    append j $prep
	}
	append j $::canv_jdraw($i)
    }
    return $j
}

proc canv_hook {} {
    set ::canv_hooked 0
    set repaint 0
    if {$::canv_status_coords} {
	set repaint 1
    }
    if {![info exists ::canv_jcode]} {
	set ::canv_status_func 2
    }
    switch $::canv_status_func {
	0 {
	    # valid, do nothing
	}
	1 {
	    # incremental, append
	    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
    }
}

Changes to nacl/init.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
#------ Standard NaTcl preamble


# core JS/Tcl interaction
proc jsquote s {
    regsub -all {[''\\]} $s {\\&} s
    regsub -all \n $s {'+"\\n"+'} s
    return '${s}'
}

proc bgerror s {
    printf "### BGERROR: $s"
    set ::JS "alert([jsquote "BGERROR: $s"]);"
}



proc naclwrap s {
    set ::JS ""
    if {[catch {uplevel 1 $s} err]} {



	printf "Wrapper error: $err"
	bgerror $err
    }
    return $::JS
}

# Coro-based [source] necessary for bootstrapping











|



>
>


|
>
>
>







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
#------ Standard NaTcl preamble


# core JS/Tcl interaction
proc jsquote s {
    regsub -all {[''\\]} $s {\\&} s
    regsub -all \n $s {'+"\\n"+'} s
    return '${s}'
}

proc bgerror s {
    printf "### BGERROR: $s\n# [info errorstack]"
    set ::JS "alert([jsquote "BGERROR: $s"]);"
}

set ::naclhooks {}

proc naclwrap s {
    set ::JS ""
    if {[catch {
	uplevel 1 $s
	foreach x $::naclhooks {uplevel #0 $x}
    } err]} {
	printf "Wrapper error: $err"
	bgerror $err
    }
    return $::JS
}

# Coro-based [source] necessary for bootstrapping