<> [JOB] 2016-07-29 [WikiDBImage accordion_demo.png] **Overview:** 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 the a good opportunity as well. ***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 # ----------------------------------------------------------------------------- # 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.1 namespace eval accordion { namespace export accordion # this is a tk-like wrapper around my... class so that # object creation works like other tk widgets proc accordion {path args} { set obj [AccordionClass create tmp $path {*}$args] # 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 { variable thisframe variable widgetOptions constructor {path args} { 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 } # we use a frame for this specific widget class frame $path -relief flat -bd 0 -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 {}} catch {destroy $w} } method cget { {opt "" } } { 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 } { 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)] } { 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 {} { 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} { set thisframe [frame $w.frm -relief flat -bd 0] pack $thisframe -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} { return $thisframe.__$num } method InsertItem {pos win args} { 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 } # 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 $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] } 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 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 {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] } # Use a coroutine for the animation coroutine coro my SlideCmd $id } method SlideCmd {id} { 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 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 3 ====== ***demo2.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. <>Category GUI | Category Object Orientation | Category Widget