Check-in [d7514b9eda]

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

Overview
Comment:Initial checkin
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:d7514b9eda0776acc5cb95edc806ccd8d1bd8010
User & Date: sbron 2014-07-12 18:53:11
Context
2014-07-12
21:52
Implement a few features that were already described in the man page: - The "current" pane identifier. - The insert method moves a pane if it was already managed by the accordion. Bugfix: inserting a pane before the active pane resulted in wrong display. check-in: 421fab7984 user: schelte tags: trunk
18:53
Initial checkin check-in: d7514b9eda user: sbron tags: trunk
18:42
initial empty check-in check-in: a443dd2b51 user: schelte tags: trunk
Changes

Added accordion-1.0.tm.



























































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
# Accordion widget

namespace eval tk::accordion {

    # Switch-like command that will look for a partial match and produce an 
    # appropriate error when there is not exactly one match
    #
    proc cfgopt {what opt body} {
	# Check for an exact match first
	if {![dict exists $body $opt]} {
	    # Find all prefix matches -- assume no glob chars in the option
	    set list [lsearch -all -inline [dict keys $body] $opt*]
	    if {[llength $list] == 1} {
		# Exactly one prefix match
		set opt [lindex $list 0]
	    } else {
		# No unambiguous match found -- produce an error message
		set list [lsort -dictionary [dict keys $body]]
		if {[llength $list] > 1} {
		    lset list end "or [lindex $list end]"
		}
		set msg [format {unknown or ambiguous %s "%s": must be %s} \
		  $what $opt [join $list {, }]]
		set code [list TCL LOOKUP INDEX $what $opt]
		return -level 3 -code error -errorcode $code $msg
	    }
	}
	uplevel 1 [list switch -- $opt $body]
    }

    # Create an oo class for the widget implementation to easily keep track
    # of multiple widgets
    #
    oo::class create widget {
	constructor {opts} {
	    namespace path [linsert [namespace path] end ::tk::accordion]
	    # Extract the widget name from the object name
	    variable name [namespace tail [self object]]
	    # Initialize some other variables
	    variable row 0 panes {} speed 10 coroid "" coro ""
	    # Pass the initial options on to the cset method
	    my cset {*}$opts
	    # The widget should not resize based on its content
	    grid propagate $name 0
	    # All panes fill the available horizontal space
	    grid columnconfigure $name 0 -weight 1
	    # The first pane is initially open, once it will be created
	    grid rowconfigure $name 0 -weight 1000
	}

	method frame {num} {
	    my variable name
	    return $name.__$num
	}

	method configure {args} {
	    my variable name
	    set argc [llength $args]
	    if {$argc == 0} {
		# Return all configuration settings
		set args {-height -speed -width}
	    } elseif {$argc > 1} {
		# Set configuration
		tailcall my cset {*}$args
	    }
	    foreach opt $args {
		cfgopt option $opt {
		    -width - -height {
			lappend rc [$name configure $opt]
		    }
		    -speed {
			my variable speed
			lappend rc [list -speed speed Speed 10 $speed]
		    }
		}
	    }
	    # When a specific setting was requested, don't return it as a list
	    if {$argc == 1} {
		return [lindex $rc 0]
	    } else {
		return $rc
	    }
	}

	method cset {args} {
	    my variable name
	    # Need an even number of arguments
	    if {[llength $args] % 2 == 1} {
		set msg [format {value for "%s" missing} [lindex $args end]]
		return -code error -errorcode {TK VALUE_MISSING} $msg
	    }
	    # Set the options
	    foreach {opt val} $args {
		cfgopt option $opt {
		    -width - -height {
			$name configure $opt $val
		    }
		    -speed {
			variable speed $val
		    }
		}
	    }
	}

	method cget {option} {
	    return [lindex [my configure $option] 4]
	}

	method index {paneid} {
	    my variable panes
	    # Integer paneid's are straight-forward
	    if {[string is integer -strict $paneid]} {
		# No conversion needed
		set pos $paneid
	    } elseif {$paneid in {end last}} {
		set pos [llength $panes]
	    } else {
		# Position of the named pane
		set pos [lsearch -exact $panes $paneid]
	    }
	    if {$pos < 0 || $pos > [llength $panes]} {
		return -code error -errorcode {TK BAD_VALUE} \
		  [format {invalid pane "%s"} $paneid]
	    }
	    return $pos
	}

	method add {w args} {
	    # Add is just an alias for inserting a pane at the end
	    tailcall my insert end $w {*}$args
	}

	method insert {pos win args} {
	    my variable name panes row coro
	    # Translate pos to an integer, if necessary
	    if {[catch {my index $pos} pos info]} {
		# Rethrow the error to get a clean stack trace
		return -code error -errorcode [dict get $info -errorcode] $pos
	    }
	    # Check that an even number of args was provided
	    if {[llength $args] % 2 == 1} {
		set msg [format {value for "%s" missing} [lindex $args end]]
		return -code error -errorcode {TK VALUE_MISSING} $msg
	    }

	    # We can't handle adding panes while an animation is playing
	    if {$coro ne ""} {rename $coro ""}

	    # Add a new pane (containing a button and a frame) at the end
	    set num [llength $panes]
	    set f [frame [my frame $num]]
	    set callback [list [namespace which my] select $num]
	    set b [ttk::button $f.button -command $callback]
	    set a [frame $f.frame]
	    grid $b -in $f -sticky ew
	    grid $a -in $f -sticky snew
	    grid columnconfigure $f $b -weight 1
	    grid rowconfigure $f $a -weight 1
	    grid $f -in $name -sticky snew -row $num
	    grid remove $a
	    # Insert the new pane in the list of panes
	    set panes [linsert $panes $pos $win]
	    # Shift existing panes after the new one down
	    for {set i $num} {$i > $pos} {} {
		set w [lindex $panes $i]
		set f1 [my frame $i]
		set f2 [my frame [incr i -1]]
		$f1.button configure -text [$f2.button cget -text]
		raise $w $f1
	    }
	    if {$num == 0} {
		# This is the first pane, open it
		grid $a
		place $win -in $a -relwidth 1 -relheight 1
	    } elseif {$row >= $pos} {
	    	# Shift down the opened pane
		my open $row [expr {$row + 1}]
	    }
	    # Make sure the helper frames don't obscure their contents
	    raise $win [my frame $pos]
	    # Apply any additional configuration settings
	    if {[llength $args] > 0} {
		tailcall my pane $pos {*}$args
	    }
	    return
	}

	method pane {pos args} {
	    if {[catch {my frame [my index $pos]} f info]} {
		# Rethrow the error to get a clean stack trace
		return -code error -errorcode [dict get $info -errorcode] $f
	    }
	    set argc [llength $args]
	    if {$argc == 0} {
		set args {-compound -image -text -textvariable -underline}
	    } elseif {$argc % 2 == 0} {
		foreach {opt val} $args {
		    cfgopt option $opt {
			-compound - -image - -text - -textvariable -
			-underline {
			    $f.button configure $opt $val
			}
		    }
		}
		return
	    } elseif {$argc > 1} {
		set msg [format {value for "%s" missing} [lindex $args end]]
		return -code error -errorcode {TK VALUE_MISSING} $msg
	    }
	    foreach {opt val} $args {
		cfgopt option $opt {
		    -compound - -image - -text - -textvariable - -underline {
			lappend rc [$f.button configure $opt]
		    }
		}
	    }
	    # When a specific setting was requested, don't return it as a list
	    if {$argc == 1} {
		return [lindex $rc 0]
	    } else {
		return $rc
	    }
	}

	method select {{id ""}} {
	    my variable row panes
	    if {$id eq ""} {
		return [lindex $panes $row]
	    }

	    # Use a coroutine for the animation
	    coroutine coro my slide $id
	}

	method slide {id} {
	    my variable row name panes speed

	    # Check if the requested pane isn't already selected
	    set new [my index $id]
	    if {$new == $row} return

	    variable coro [info coroutine]
	    # Always switch to the new row when the coroutine terminates, in
	    # whatever way (run to completion, error, redefined).
	    trace add command $coro delete [list [namespace which my] open $new]

	    # Determine the final height of the new pane (same as the current)
	    set height [winfo height [lindex $panes $row]]

	    # Prepare the new frame
	    set f [my frame $new]
	    set w [lindex $panes $new]
	    grid $f.frame
	    place $w -in $f.frame -relwidth 1 -height $height -relheight 0

	    # Switch the old pane from relative- to absolute height to
	    # prevent continuous resizing during the slide animation
	    set f [my frame $row]
	    set w [lindex $panes $row]
	    place $w -in $f.frame -relwidth 1 -height $height -relheight 0

	    # Calculate a stepsize based on the configured speed setting and
	    # the distance to travel
	    set incr [expr {max($speed * 4000 / $height, 1)}]

	    # Manipulate the weight of the two rows involved to produce the
	    # animation effect
	    while {[incr step $incr] < 1000} {
		grid rowconfigure $name $row -weight [expr {1000 - $step}]
		grid rowconfigure $name $new -weight $step
		variable coroid [after 25 $coro]
		yield
	    }
	    # The command trace will take care of completing the row change
	}

	method forget {id} {
	    my variable panes row coro
	    if {[catch {my index $id} pos info]} {
		# Rethrow the error to get a clean stack trace
		return -code error -errorcode [dict get $info -errorcode] $pos
	    }

	    # We can't handle deleting panes while an animation is playing
	    if {$coro ne ""} {rename $coro ""}

	    # Unmap the contents of the pane that will be deleted
	    place forget [lindex $panes $pos]
	    # Remove the pane from the list of panes
	    set panes [lreplace $panes $pos $pos]
	    # Shift existing panes after the new one up
	    set num [llength $panes]
	    for {set i $pos} {$i < $num} {} {
		set w [lindex $panes $i]
		set f1 [my frame $i]
		set f2 [my frame [incr i]]
		$f1.button configure -text [$f2.button cget -text]
		raise $w $f1
	    }
	    # Delete the last helper frame
	    destroy [my frame $num]
	    # Make sure the correct pane is shown
	    if {$row > $pos || $row == $num && $row != 0} {
		my open [expr {$row - 1}]
	    } else {
		my open $row
	    }
	    return
	}

	method panes {} {
	    my variable panes
	    return $panes
	}

	method open {num args} {
	    my variable row panes name coroid

	    # Kill any pending attempts to resume the coroutine
	    after cancel $coroid
	    variable coro ""

	    if {$num != $row} {
		# Close the currently opened row
		if {$row < [llength $panes]} {
		    set f [my frame $row]
		    grid remove $f.frame
		}
		grid rowconfigure $name $row -weight 0
	    }
	    if {$num < [llength $panes]} {
		# (Re-)Open the new row
		set f [my frame $num]
		grid $f.frame
		set w [lindex $panes $num]
		place $w -in $f.frame -relwidth 1 -relheight 1 -height 0
		# Keep the contents just above their helper frame
		raise $w $f
	    }
	    grid rowconfigure $name $num -weight 1000
	    set row $num
	}

	# Make the internal methods private
	unexport cset destroy frame open slide
    }
}

proc accordion {w args} {
    # We can't create the outer frame inside the object constructor because
    # the widget's command proc gets the same name as the object, which
    # destroys the object 
    frame $w -class Accordion
    # Move the command proc into a namespace where the oo methods can find it
    rename $w ::tk::accordion::$w
    # Create an object of the accordion::widget class
    if {[catch {::tk::accordion::widget create $w $args} result info]} {
	# Clean up the frame
	destroy $w
	# Rethrow the error to get a clean stack trace
	return -code error -errorcode [dict get $info -errorcode] $result
    }
    # Return the widget name
    return $w
}

Added demo1.tcl.





























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
#!/usr/bin/tclsh

package require Tk

set dir [file dirname [info script]]
tcl::tm::path add $dir
package require accordion

accordion .a -width 600 -height 500 -speed 15
pack .a -fill both -expand 1

if {$argc == 0} {
    set argv [lsort -dictionary [glob -dir $dir *.tcl *.tm]]
}

foreach n $argv {
    set w [frame .a.f[incr f]]
    .a add $w -text "[file tail $n]"
    text $w.t -yscrollcommand [list $w.vs set] -background white \
      -highlightthickness 0 -relief flat -bd 4
    ttk::scrollbar $w.vs -command [list $w.t yview]
    pack $w.vs -side right -fill y
    pack $w.t -fill both -expand 1
    if {[catch {open $n} fd]} {
	$w.t insert end "$fd"
    } else {
	$w.t insert end [read -nonewline $fd]
	close $fd
    }
}

Added demo2.tcl.



































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
#!/usr/bin/tclsh

package require Tk

tcl::tm::path add [file dirname [info script]]
package require accordion

proc setspeed {value} {
    global speed
    set speed [expr {round($value)}]
    .a configure -speed $speed
    # .scale.s set $speed
}

ttk::frame .scale
pack .scale -side top -fill x

ttk::label .scale.l1 -text Speed:
ttk::scale .scale.s -from 1 -to 20 -command setspeed
ttk::label .scale.l2 -textvariable speed -width 4 -anchor center
pack .scale.l1 -side left -padx 4 -pady 4
pack .scale.l2 -side right -padx 4 -pady 4
pack .scale.s -side left -fill x -expand 1

accordion .a -width 600 -height 500
pack .a -fill both -expand 1

.scale.s set [.a cget -speed]

foreach n {green blue red yellow cyan purple} {
    set w [frame .a.f[incr f] -bg $n]
    .a add $w -text [string totitle $n]
}

Added license.terms.



























>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
Copyright (c) 2014, Schelte Bron <sbron@users.sourceforge.net>

Permission to use, copy, modify, and/or distribute this software for any
purpose with or without fee is hereby granted, provided that the above
copyright notice and this permission notice appear in all copies.

THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.