accordion - yet another TclOO implementation

Overview:

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 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 <[email protected]>
# -----------------------------------------------------------------------------
# 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 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