# -----------------------------------------------------------------------------
# xtablelist_template.tcl ---
# -----------------------------------------------------------------------------
# (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software
#     johann.oberdorfer [at] gmail.com
#     www.johann-oberdorfer.eu
# -----------------------------------------------------------------------------
# This source file is distributed under the BSD license.
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#   See the BSD License for more details.
# -----------------------------------------------------------------------------
# Purpose:
#  A TclOO class template to extend tablelist functionality.
#  Might be usefull as a starting point.
# -----------------------------------------------------------------------------
# TclOO naming conventions:
# public methods  - starts with lower case declaration names, whereas
# private methods - starts with uppercase naming, so we use CamelCase ...
# -----------------------------------------------------------------------------


# for development: try to find autoscroll, etc ...
set this_file [file normalize [file dirname [info script]]]

# where to find required packages...
# set auto_path [linsert $auto_path 0 [file join $this_file ".." "contrib" ]]

package require Tk
package require TclOO
package require tablelist_tile

package provide xtablelist 0.2

namespace eval xtablelist {
        variable cnt 0

        # this is a tk-like wrapper around my... class so that
        # object creation works like other tk widgets
        
        proc xtablelist {path args} {
                variable cnt

                set obj [TablelistClass create tmp${cnt} $path {*}$args]
                incr cnt

                # rename oldName newName
                rename $obj ::$path
                return $path
        }
}

# -----------------------------------------------------------------------------
# widget interface declaration
# -----------------------------------------------------------------------------
oo::class create TablelistClass {
        
        constructor {path args} {
                my variable tblwidget
                my variable widgetOptions
                
                # declaration of all additional widget options
                array set widgetOptions {
                        -xtabheader  {}
                }
                
                # incorporate arguments to local widget options
                array set widgetOptions $args
                
                # we use a frame for this specific widget class
                set f [ttk::frame $path -class Xtablelist]
                
                # we must rename the widget command
                # since it clashes with the object being created
                set widget ${path}_
                rename $path $widget
                
                my Build $f
                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 tblwidget
                my variable widgetOptions
                
                if { [string length $opt] == 0 } {
                        return [array get widgetOptions]
                }
                if { [info exists widgetOptions($opt) ] } {
                        return $widgetOptions($opt)
                }
                return [$tblwidget cget $opt]
        }
        
        method configure { args } {
                my variable tblwidget
                my variable widgetOptions
                
                if {[llength $args] == 0}  {
                        
                        # return all tablelist options
                        set opt_list [$tblwidget configure]
                        
                        # 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 [$tblwidget cget $opt]
                }
                
                # 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 {
                                -xtabheader {
                                        my InitializeTabHeader $opt_value
                                }
                                default {
                                        # if the configure option wasn't one of our special one's,
                                        # pass control over to the original tablelist widget
                                        
                                        if {[catch {$tblwidget configure $opt_name $opt_value} result]} {
                                                return -code error $result
                                        }
                                }
                        }
                }
        }
        
        method unknown {method args} {
                my variable tblwidget
        
                # if the command wasn't one of our special one's,
                # pass control over to the original tablelist widget
                
                if {[catch {$tblwidget $method {*}$args} result]} {
                        return -code error $result
                }
                return $result
        }
}

# -----------------------------------------------------------------------------
# public methods
# -----------------------------------------------------------------------------

oo::define TablelistClass {
        
        method enablemoveover {} {
                my variable tblwidget
                
                # move-over effect:
                bind [$tblwidget bodypath] <Motion> {+
                        set t [winfo parent %W]
                        set x [expr {%x + [winfo x %W]}]
                        set y [expr {%y + [winfo y %W]}]
                        
                        # set cell [$t nearestcell $x $y]
                        # puts "Clicked on cell: $cell "
                        # set rownum  [lindex [split $cell ","] 0]
                        
                        focus $t
                        $t configure -activestyle frame
                        $t activate "@$x,$y"
                }
                
                bind [$tblwidget bodypath] <Leave> {+
                        set t [winfo parent %W]
                        $t configure -activestyle none
                }
        }
        
}

# -----------------------------------------------------------------------------
# private methods
# -----------------------------------------------------------------------------

oo::define TablelistClass {
        
        method InitializeTabHeader {kword_list} {
                my variable tblwidget
                
                set cols ""
                set cnt 0
                foreach i $kword_list {
                        set descr  [lindex $i 0]
                        set visual [lindex $i 1]
                        set orient [lindex $i 2]
                        
                        if {[string length $orient] == 0} {
                                set orient "left"
                        }
                        
                        regsub -all " " $descr "_" descr
                        if {$descr != "..." &&
                                [string range $descr end end] != ":"} {
                                set descr "${descr}:"
                        }
                        
                        # could be either a string or an integer:
                        if {$visual == "hidden"} {
                                set width 20
                        } else {
                                set width $visual
                        }
                        
                        append cols "$width $descr $orient "
                        incr cnt
                }
                
                $tblwidget configure -columns $cols
                
                # hide specific columns as indicated with "hidden" in declaration array
                set cnt 0
                foreach i $kword_list {
                        if {[set width [lindex $i 1]] == "hidden"} {
                                $tblwidget columnconfigure $cnt -hide yes
                        }
                        incr cnt
                }
                
                # expand last *visible* column
                # ----------------------------
                set cnt 0
                set lastcol 0
                # tablelist -columns option are always 3 attributes each...
                foreach {w col pos} [$tblwidget cget -columns] {
                        if {[$tblwidget columncget $cnt -hide] == 0} {set lastcol  $cnt}
                        incr cnt
                }
                if {$lastcol > 0} {
                        $tblwidget configure -stretch $lastcol
                }
        }
        
        method Build {f} {
                my variable tblwidget
                
                ::tablelist::tablelist $f.tlist
                pack $f.tlist -side top -fill both -expand true
                
                set tblwidget $f.tlist
        }
        
}


# -----------------------------------------------------------------------------
# demo code
# -----------------------------------------------------------------------------

if {1} {
        catch {console show}
        
        set t [xtablelist::xtablelist .t \
                        -showseparators yes \
                        -selectmode single  \
                        -labelcommand "tablelist::sortByColumn"]
        
        pack $t -fill both -expand true
        
        set header \
                        {{"hidden_column" "hidden" left}
                                {"Category"      22 left}
                                {"test-column"   16 left}
                                {"Hello\\nWorld" 10 left}
                                {"test"          11 center}
                                {"last\\ncolumn" 10 left}}
        
        $t configure \
                        -xtabheader $header
        
        # create some random test data...
        set data_list {}
        set cnt 0
        while {$cnt < 40} {
                lappend data_list \
                                [list $cnt \
                                [expr {$cnt +1}] [expr {$cnt +2}] \
                                [expr {$cnt +3}] [expr {$cnt +4}] \
                                [expr {$cnt +5}]]
                incr cnt
        }
        
        # ---------------------
        # object introspection:
        # ---------------------
        
        # puts [winfo class $t]
        # puts [$t configure]
        
        # catch { [$t blabla 1] } msg
        # puts $msg
        # return
        
        foreach item $data_list {
                $t insert end $item
        }
        
        # puts [$t cget -xtabheader]
        
        # how to access the tablelist widget:
        # [$t getwidgetpath] configure -columns \
        #   "12 Test1 left 12 Test2 left"
        
        # $t selection clear 0 end
        # puts [$t curselection]
        
        $t enablemoveover
}