JOB 2016-07-29
Overview: edit
Another approach for a megawidget in TclOO. Also noticed recently that there is an undocumented
::tk::Megawidget interface which comes along with Tk? Nevertheless, the following code follows the rules of TclOO - which seems to be a good opportunity as well. For the animation effect a
coroutine is in place.
accordion.tcl
# -----------------------------------------------------------------------------
# accordion.tcl ---
# -----------------------------------------------------------------------------
# Credits:
# Source code was carried over from the original accordion.tm file
# and slightly modified to go together with TclOO.
# Thanks to:
# 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.
# -----------------------------------------------------------------------------
# Modified by:
# 2016, Johann Oberdorfer - Engineering Support | CAD | Software
# johann.oberdorfer [at] gmail.com, www.johann-oberdorfer.eu
# -----------------------------------------------------------------------------
package require Tk
package require TclOO
package require tile
package provide accordion 0.2
namespace eval accordion {
namespace export accordion
variable cnt 0
# this is a tk-like wrapper around my... class so that
# object creation works like other tk widgets
proc accordion {path args} {
variable cnt
set obj [AccordionClass create tmp${cnt} $path {*}$args]
incr cnt
# rename oldName newName
rename $obj ::$path
return $path
}
ttk::style configure Higlighted.TButton \
-background [ttk::style configure . -selectbackground]
}
# -----------------------------------------------------------------------------
# widget interface declaration
# -----------------------------------------------------------------------------
oo::class create AccordionClass {
constructor {path args} {
my variable thisframe
my variable widgetOptions
my variable row
my variable panes
my variable buttons
my variable coroid
my variable coro
set row 0
set panes {}
set buttons {}
set coroid ""
set coro ""
# declaration of all additional widget options
array set widgetOptions {
-width 10
-height 300
-speed 20
}
array set widgetOptions $args
# we use a frame for this specific widget class
ttk::frame $path -class accordion
# we must rename the widget command
# since it clashes with the object being created
set widget ${path}_
rename $path $widget
my Build $path
my configure {*}$args
}
destructor {
# clean up once the widget get's destroyed
set w [namespace tail [self]]
catch {bind $w <Destroy> {}}
catch {destroy $w}
}
method cget { {opt "" } } {
my variable widgetOptions
if { [string length $opt] == 0 } {
return [array get widgetOptions]
}
if { [info exists widgetOptions($opt) ] } {
return $widgetOptions($opt)
}
return -code error "option \"$opt\" is not available"
}
method configure { args } {
my variable thisframe
my variable widgetOptions
if {[llength $args] == 0} {
# as well as all custom options
foreach xopt [array get widgetOptions] {
lappend opt_list $xopt
}
return $opt_list
} elseif {[llength $args] == 1} {
# return configuration value for this option
set opt $args
if { [info exists widgetOptions($opt) ] } {
return $widgetOptions($opt)
}
return -code error "value for \"[lindex $args end]\" is not declared"
}
# error checking
# if {[expr {[llength $args]%2}] == 1} {
# return -code error "value for \"[lindex $args end]\" missing"
#}
# process the new configuration options...
array set opts $args
foreach opt_name [array names opts] {
set opt_value $opts($opt_name)
# overwrite with new value
if { [info exists widgetOptions($opt_name)] } {
puts "--> $opt_name : $opt_value"
set widgetOptions($opt_name) $opt_value
}
# some options need action from the widgets side
switch -- $opt_name {
-width {
$thisframe configure -width $opt_value
}
-height {
$thisframe configure -height $opt_value
}
-speed {}
default {
return -code error "option \"$opt_name\" is not valid"
}
}
}
}
method unknown {method args} {
return -code error "method \"$method\" is unknown"
}
}
# -----------------------------------------------------------------------------
# class method declarations
# -----------------------------------------------------------------------------
oo::define AccordionClass {
# --------------
# public methods
# --------------
method add {win args} {
# Add is just an alias for inserting a pane at the end
tailcall my InsertItem end $win {*}$args
}
method getframe {} {
my variable thisframe
return $thisframe
}
method showpane {idx} {
my variable panes
my variable buttons
if {[expr {$idx -1}] >= [llength $panes]} {
return
}
my SelectCmd [lindex $buttons $idx] "" $idx
}
# ---------------
# private methods
# ---------------
method Build {w} {
my variable thisframe
set thisframe [ttk::frame $w.frm]
pack $thisframe -padx 2 -pady 2 -fill both -expand true
# The widget should not resize based on its content
grid propagate $thisframe 0
# All panes fill the available horizontal space
grid columnconfigure $thisframe 0 -weight 1
# The first pane is initially open, once it will be created
grid rowconfigure $thisframe 0 -weight 1000
}
method CreateFrame {num} {
my variable thisframe
return $thisframe.__$num
}
method GetArg {args keystr arg} {
upvar $arg cvalue
set cvalue ""
while {[set i [lsearch -exact $args $keystr]] >= 0} {
set j [expr $i + 1]
set cvalue [lindex $args $j]
set args [lreplace $args $i $j]
}
return $args
}
method InsertItem {pos win args} {
my variable thisframe
my variable row
my variable panes
my variable buttons
my variable coro
# Translate pos to an integer, if necessary
if {[catch {my GetPaneIndex $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
}
# callback command given as an argument ?
set args [my GetArg $args "-accordioncmd" accordioncmd]
# We can't handle adding panes while an animation is playing
if {$coro ne ""} {rename $coro ""}
# If win is already managed by the accordion, delete the old pane
set old [lsearch -exact $panes $win]
if {$old >= 0} {
my ForgetCmd $old
if {$old < $pos} {incr pos -1}
}
# Add a new pane (containing a button and a frame) at the end
set num [llength $panes]
set f [ttk::frame [my CreateFrame $num]]
set callback [list [namespace which my] SelectCmd $f.button $accordioncmd $num]
set b [ttk::button $f.button -command $callback]
lappend buttons $b
set a [ttk::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 $thisframe -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 p [lindex $panes $i]
set f1 [my CreateFrame $i]
set f2 [my CreateFrame [incr i -1]]
$f1.button configure -text [$f2.button cget -text]
raise $p $f1
}
if {$num == 0} {
# This is the first pane, open it
grid $a
place $win -in $a -relwidth 1 -relheight 1
my SelectCmd [lindex $buttons 0] $accordioncmd
} elseif {$row >= $pos} {
# Shift down the opened pane
my OpenCmd [expr {$row + 1}]
}
# Make sure the helper frames don't obscure their contents
raise $win [my CreateFrame $pos]
# Apply any additional configuration settings
if {[llength $args] > 0} {
tailcall my CreatePane $pos {*}$args
}
return
}
method CreatePane {pos args} {
my variable thisframe
my variable paneopts
if {[catch {my CreateFrame [my GetPaneIndex $pos]} f info]} {
# Rethrow the error to get a clean stack trace
return -code error -errorcode [dict get $info -errorcode] $f
}
set paneopts {-compound -image -text -textvariable -underline -style}
set argc [llength $args]
if {$argc == 0} {
foreach opt $paneopts {lappend rc $opt [$f.button cget $opt]}
return $rc
} elseif {$argc == 1} {
set opt [lindex $args 0]
if {$opt in $paneopts} {return [$f.button cget $opt]}
# Fall through to error message
} elseif {$argc % 2 == 1} {
set opt [lindex $args end]
if {$opt in $paneopts} {
return -code error -errorcode {TK VALUE_MISSING} \
set msg [format {value for "%s" missing} $opt]
}
# Fall through to error message
} else {
set opt [apply {
{thisframe valid opts} {
foreach {opt val} $opts {
if {$opt ni $valid} {return $opt}
catch {
$thisframe configure $opt $val
}
}
}
} $f.button $paneopts $args]
if {$opt eq ""} return
# Fall through to error message
}
set valid [lreplace $paneopts end end "or [lindex $paneopts end]"]
return -code error -errorcode [list TK LOOKUP OPTION $opt] \
"bad option \"$opt\": must be [join $valid {, }]"
}
method GetPaneIndex {paneid} {
my variable row
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]
} elseif {$paneid eq "current"} {
set pos $row
} 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 SelectCmd {wbttn cmd {id ""}} {
my variable row
my variable panes
my variable buttons
# reset button styles
foreach b $buttons { $b configure -style "" -state normal}
# and set button style to indicate selected button
$wbttn configure -style Higlighted.TButton -state disabled
if {$id eq ""} {
return [lindex $panes $row]
}
# execute user command...
if {[string length $cmd] != 0} {
uplevel $cmd $wbttn
}
# Use a coroutine for the animation
coroutine coro my SlideCmd $id
}
method SlideCmd {id} {
my variable thisframe
my variable widgetOptions
my variable row
my variable panes
# Check if the requested pane isn't already selected
set new [my GetPaneIndex $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] OpenCmd $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 CreateFrame $new]
set p [lindex $panes $new]
grid $f.frame
place $p -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 CreateFrame $row]
set p [lindex $panes $row]
place $p -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($widgetOptions(-speed) * 4000 / $height, 1)}]
# Manipulate the weight of the two rows involved to produce the
# animation effect
while {[incr step $incr] < 1000} {
grid rowconfigure $thisframe $row -weight [expr {1000 - $step}]
grid rowconfigure $thisframe $new -weight $step
variable coroid [after 25 $coro]
yield
}
# The command trace will take care of completing the row change
}
method ForgetCmd {id} {
my variable row
my variable panes
my variable coro
if {[catch {my GetPaneIndex $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 p [lindex $panes $i]
set f1 [my CreateFrame $i]
set f2 [my CreateFrame [incr i]]
$f1.button configure -text [$f2.button cget -text]
raise $p $f1
}
# Delete the last helper frame
destroy [my CreateFrame $num]
# Make sure the correct pane is shown
if {$row > $pos || $row == $num && $row != 0} {
my OpenCmd [expr {$row - 1}]
} else {
my OpenCmd $row
}
return
}
method OpenCmd {num args} {
my variable thisframe
my variable row
my variable panes
my variable 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 CreateFrame $row]
grid remove $f.frame
}
grid rowconfigure $thisframe $row -weight 0
}
if {$num < [llength $panes]} {
# (Re-)Open the new row
set f [my CreateFrame $num]
grid $f.frame
set p [lindex $panes $num]
place $p -in $f.frame -relwidth 1 -relheight 1 -height 0
# Keep the contents just above their helper frame
raise $p $f
}
grid rowconfigure $thisframe $num -weight 1000
set row $num
}
}
demo1.tcl
#!/usr/bin/tclsh
set dir [file dirname [info script]]
lappend auto_path [file join $dir "."]
package require Tk
package require accordion
# demo code ...
catch {console show}
accordion::accordion \
.a -width 600 -height 500 -speed 15
pack .a -fill both -expand 1
proc addSpaces {str} {
set maxlen 40
while {[string length $str] < $maxlen} {
append str " "
}
return $str
}
set accframe [.a getframe]
# create some arbitrary data...
set flist [lsort -dictionary [glob -dir $dir "*.tcl"]]
foreach n $flist {
set fnew [ttk::frame $accframe.f[incr f]]
.a add $fnew \
-text [addSpaces "[file tail $n]"]
text $fnew.t \
-yscrollcommand [list $fnew.vs set] \
-background white \
-highlightthickness 0 \
-relief flat \
-bd 4
ttk::scrollbar $fnew.vs -command [list $fnew.t yview]
pack $fnew.vs -side right -fill y
pack $fnew.t -fill both -expand 1
if {[catch {open $n} fd]} {
$fnew.t insert end "$fd"
} else {
$fnew.t insert end [read -nonewline $fd]
close $fd
}
}
# show specific pane ...
.a showpane 3demo2.tcl
#!/usr/bin/tclsh
set dir [file dirname [info script]]
lappend auto_path [file join $dir "."]
package require Tk
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::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 getframe].f[incr f] -bg $n]
.a add $w -text [string totitle $n]
}
Have fun.
