# $id: scrolledtreeview.wgt,v 1.1 2013/01/09 02:18:13 rozen Exp rozen $

##############################################################################
#
# Visual TCL - A cross-platform application development environment
#
# Copyright (C) 2001 Christian Gavin
#
# Description file for [Incr Widgets]
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# 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
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

##############################################################################
#

# Rozen. Started from scrolledtext in itcl, borrowed from here, there,
# and everywhere.
Class       Scrolledtreeview
Lib     ttk
TtkWidget       yes

#CreateCmd  ::iwidgets::scrolledtext
CreateCmd  vTcl::widgets::ttk::scrolledtreeview::CreateCmd
# Rozen may not use loadcommand at this level.
#NewOption -loadcommand {loadcmd} command {}
#ClassOption -loadcommand
#DefaultOptions   -width 125 -height 75

# # Experimental code 10/5/19
# ClassOption -headerbg
# NewOption -headerbg "header bg" color   {}  Colors
# OptionConfigCmd -headerbg get vTcl::widgets::ttk::scrolledtreeview::get_header_bg
# OptionConfigCmd -headerbg update vTcl::widgets::ttk::scrolledtreeview::update_header_bg
# OptionConfigCmd -headerbg config vTcl::widgets::ttk::scrolledtreeview::config_header_bg

#TagsCmd         vTcl:lib_itcl:tagscmd
Icon         icon_tixTree.gif
#DumpChildren    yes
#MegaWidget  no
DumpChildren    yes
MegaWidget  no
#DontSaveOptions -sbwidth
#GetFontsCmd     vTcl::widgets::iwidgets::scrolledlistbox::getFontsCmd
#ResizeCmd vTcl::widgets::ttk::scrolledtreeview::ResizeCmd

DumpCmd         ::vTcl::widgets::ttk::scrolledtreeview::dumpCmd
DumpInfoCmd     ::vTcl::widgets::ttk::scrolledtreeview::dumpInfoCmd

InsertCmd        ::vTcl::widgets::ttk::scrolledtreeview::insertCmd

lappend vTcl(complex_class) Scrolledtreeview
Function "Fill Container"  vTcl::widgets::ttk::scrolledtreeview::fill_container

VirtualEvents <<TreeviewSelect>> <<TreeviewOpen>> <<TreeviewClose>>

namespace eval ::vTcl::widgets::ttk::scrolledtreeview {

#    proc getFontsCmd {target} {
#        set result ""
#    set labelfont [$target cget -labelfont]
#    set textfont  [$target cget -textfont]
#    if {$labelfont != ""} {
#        lappend result $labelfont
#    }
#    if {$textfont != ""} {
#        lappend result $textfont
#    }
#    return $result
#    }

   proc fill_container {} {
         # Rozen function to expand widget to fill container.
         set w $::vTcl(w,widget)
         vTcl:fill_container $w
    }

    proc insertCmd {target} {
        # Add one column to the tree named Col1 and set the text to
        # the same. From the create below I know that the treeview widget
        # is target.01.
        global vTcl basenames classes
        set class  [vTcl:get_class $target.01]
        $classes($class,insertCmd) $target.01
    }

    proc CreateCmd {target args} {
        # Rozen Routine Based on the compound widget -"Scrollable Text"
        global vTcl
        namespace eval ::widgets::${target}::variant {}  ;# 10/4/19
        namespace eval ::widgets::${target}::options {}
        namespace eval ::widgets::${target}::save    {}
        namespace eval ::widgets::${target}.01::options {}
        namespace eval ::widgets::${target}.01::save    {}
        namespace eval ::widgets::${target}.02::options {}
        namespace eval ::widgets::${target}.02::save    {}
        namespace eval ::widgets::${target}.03::options {}
        namespace eval ::widgets::${target}.03::save    {}

        frame $target  -height 15 -width 30 -class Scrolledtreeview
        # Removed following line because multiple instances ended up
        # with the same name in the Python code. Don't know why it was
        # here in the first place. 10/23/10
        #vTcl:DefineAlias "$target" "Frame8" vTcl:WidgetProc "Toplevel1" 1
        ttk::treeview $target.01   -height 4

        scrollbar $target.scroll -bg $vTcl(actual_gui_bg) \
            -troughcolor $vTcl(actual_gui_bg)
        #ttk::scrollbar $target.scroll
        pack $target.scroll -in $target -side right -fill y

        pack $target.01 -in $target -fill both -expand yes
    }

    # Picked up this routine from frame.wgt
    proc dumpCmd {target basename} {
        global vTcl basenames classes
		
        set result [vTcl:dump_widget_opt $target $basename]
# NEEDS WORK - conf1 seems to have the stuff I want, but I never seem
        # to use it.
#        set conf1 [vTcl:dump_widget_opt $target.01 $basename.01]
        set class_opt [vTcl:get_class_opts $target.01]
        foreach {co val} $class_opt {
            append result $vTcl(tab)
            append result "global vTcl\n"
            append result $vTcl(tab)
            append result "set vTcl($target.01,$co) $val\n"
            append result $vTcl(tab)
            append result "namespace eval ::widgets::$target.01 \{\}\n"
            append result $vTcl(tab)
            append result "set ::widgets::$target.01::ClassOption($co) $val\n"
            append result $vTcl(tab)
            append result "set ::widgets::$target.01::options($co) $val\n"
            append result $vTcl(tab)
            append result \
                "set ::widgets::$target.01::save($co) [expr {$val != ""}]\n"
        }
        # Rozen moving this stuff to ttreeview::dumpInfoCmd
        set config [$target.01 configure]
         # I am trying to get the options with nondefault values.
         set attr {}
         foreach i $config {
             set option [lindex $i 0]
             set default [lindex $i 3]
             set value [lindex $i 4]
             if {$option == "-class"} {
                 # Because class is a read-only option.
                 continue }
             if {$default == $value} { continue }
             if {[string first " " $value] > -1} {
                 set new {}
                 set value [append new "\"" $value "\""]
             }
             if {[string bytelength $attr] > 0} {
				 #append attr " \\\n" $vTcl(tab)$vTcl(tab)$option " " $value
                 append attr " " $option " " $value
             } else {
				 if {$vTcl(copy)} {
					 set base_target  $basename
				 } else {
					 set base_target [regsub {^\.top\d+} $target "\$base"]
				 }	
                 append attr "\n$vTcl(tab2)$base_target.01 configure "
                 append attr $option " " $value
             }

        }
        append attr "\n"  ;# Ends the attributs of the list box.
        #set clean [vTcl:clean_pairs $c1]
        append result $attr
        set children [winfo children $target]
        set child [lrange $children 0 0]
        if {[regexp {\.scroll} $child]} {
			set child [lrange $children 1 1]
		}
        # append result [header_info  $child $target ]
        append result [header_info  $child $basename ]
        return $result
    }

    # Picked up this routine from frame.wgt
    # Not sure ever use this routine.
    proc dumpInfoCmd {target basename} {
        global vTcl basenames classes
        set result [vTcl:dump:widget_info $target $basename]
        set children [vTcl:get_children $target]
        if {$children == ""} {
            ## the frame is empty, don't bother
            return $result
        }
        append result "$::vTcl(tab)"
        set sitevariable "site_[llength [split $target .]]_0"
        append result "set $sitevariable $basename\n"
        set basenames($target) \$$sitevariable
        foreach i $children {
            set basename [vTcl:base_name $i]
            set basenames($i) $basename
            set class [vTcl:get_class $i]
            append result [$classes($class,dumpInfoCmd) $i $basename]
            catch {unset basenames($i)}
        }
        catch {unset basenames($target)}
        return $result
    }

   proc header_info {child parent} {
       # Generates the code necessary filling in the column configuration.
       global vTcl
       set cols [$child cget -columns]
       set child_base [regsub {^\.top\d+} $child "\$base"]
if {$vTcl(copy)} {
       set child_base $parent.01
}
       append hi "$vTcl(tab2)$child_base configure -columns {$cols}\n"
       set column_names [concat "#0" $cols]
       foreach c $column_names {
           set heading($c) [$child heading $c]
           set column($c) [$child column $c]
       }
       foreach c $column_names {
           foreach {o v} $heading($c) {
               if {$v == ""} continue
               if {[string range $o 0 0] == "-"} {
                   set sub [string range $o 1 end]
               }
               if {$o == "-text"} {
                   # append hi "$vTcl(tab2)$child heading $c -$sub {$v}\n"
                   append hi "$vTcl(tab2)$child_base heading $c -$sub {$v}\n"
               } else {
                   # append hi  "$vTcl(tab2)$child heading $c -$sub $v\n"
                   append hi  "$vTcl(tab2)$child_base heading $c -$sub $v\n"
               }
           }
           foreach {o v} $column($c) {
               if {$v == ""} continue
               if {$o == "-id"} continue
               if {[string range $o 0 0] == "-"} {
                   set sub [string range $o 1 end]
               }
               append hi \
                   "$vTcl(tab2)$child_base column $c -$sub $v\n"
           }
       }
       return $hi
   }
}
