# This software is distributed under the Lesser General Public License
#
# widgets/widget.tcl
#
# Generic code for implementing new widgets
#
#------------------------------------------ CVS
#
# CVS Headers -- The following headers are generated by the CVS
# version control system. Note that especially the attribute
# Author is not necessarily the author of the code.
#
# $Source: /home/br/CVS/graphlet/lib/graphscript/widgets/widget.tcl,v $
# $Author: forster $
# $Revision: 1.2 $
# $Date: 1999/02/03 22:54:53 $
# $Locker:  $
# $State: Exp $
#
#------------------------------------------ CVS
#
# (C) University of Passau 1995-1999, Graphlet Project
#     Author: Michael Forster

package require Graphlet
package provide Graphscript [gt_version]

namespace eval Widget {

    namespace export create_type create

    proc create_type { type args } {
	variable _Forward
	variable _Options
	variable _Commands

	set _Forward($type) {}
	set _Options($type) {}
	set _Commands($type) {}

	set resources {}
	set options {}
	
	foreach { arg value } $args {
	    switch -exact -- $arg {

		"-resources"         { set resources $value }
		"-options"	     { set options $value }
		"-forward_options"   { set _Forward($type,options) $value }
		"-forward_commands"  { set _Forward($type,commands) $value }
		"-commands"          {
		    foreach { alias command } $value {
			set _Commands($type,$alias) $command
		    }
		}
		default {
		    return -code error "unknown option \"$arg\""
		}
	    }
	}

	# options
	
	foreach { opt resName resClass defValue } $options {

	    set _Options($type,$opt,resource_name) $resName
	    set _Options($type,$opt,resource_class) $resClass
	    set _Options($type,$opt,configure_info) \
		[list $opt $resName $resClass $defValue]
	    
	    lappend _Options($type) $opt
	    lappend resources $resName $defValue
	}

	# resources
	
	foreach { resource value } $resources {
	    option add *$type.$resource $value widgetDefault
	}
    }
    
    proc create { type widget } {

	# create frame
	
	frame $widget -class $type

	# set up widget command
	
	rename ::$widget ::$widget.frame
	proc ::$widget { args } "eval ::Widget::cmd $type $widget \$args"
	bind $widget <Destroy> [list rename $widget "" ]
    }

    proc init { type widget args }  {
	variable _Options
	
	# default values
	
	foreach opt $_Options($type) {
	    set default_value \
		[option get $widget \
		     $_Options($type,$opt,resource_name) \
		     $_Options($type,$opt,resource_class)]

	    $widget configure $opt $default_value
	}

	# creation options

	if { ![GT::lempty $args] } {
	    eval $widget configure $args
	}
	
	return $widget
    }

    #================================================== widget command
    
    proc cmd { type widget args } {
	variable _Forward
	variable _Commands

	if [GT::lempty $args] {
	    return -code error \
		"wrong # args: should be \"$widget option ?arg arg ...?\""
	}

	set subcmd [lindex $args 0]
	set subcmds [list "cget" "configure"]

	# cget & configure
	
	set code {
	    "^(cget|configure)$" {
		return [eval $subcmd $type $widget [lrange $args 1 end]]
	    }
	}

	# user defined subcommands
	
	foreach name [array names _Commands $type,*] {
	    set cmd [lindex [split $name ","] end]
	    lappend subcmds $cmd
	    lappend code "^$cmd\$" \
		"return \[eval $_Commands($name) $widget \[lrange \$args 1 end\]\]"
	}

	# forwarded commands
	
	foreach { subwidget commands } $_Forward($type,commands) {
	    eval lappend subcmds $commands
	    lappend code "^([join $commands |])$" \
		"return \[eval \$widget.$subwidget \$args\]"
	}

	# error code for unknown commands
	
	lappend code default {

	    set subcmds [lsort $subcmds]
	    set allbutlast [lrange $subcmds 0 [expr [llength $subcmds]-2]]
	    set last [lindex $subcmds end]
	    
	    append errmsg \
		"bad option \"$subcmd\": must be " \
		[join $allbutlast ", "] \
		", or " \
		$last
	    
	    return -code error $errmsg
	}

	switch -regexp -- $subcmd $code
    }
    
    proc configure { type widget args } {
	switch [llength $args] {
	    0 {
		return [configure_get_all $type $widget]
	    }
	    1 {
		return [configure_get_one $type $widget [lindex $args 0]]
	    }
	    default {
		return [eval configure_set $type $widget $args]
	    }
	}
    }
    
    proc configure_get_all { type widget } {
	variable _Options

	return -code error "NOT IMPLEMENTED YET"

	set result {}
	foreach opt [concat $_InwidgetrOpts $_OuterOpts $_Options] {
	    set val [configure_get_one $widget $opt]
	    if { ![GT::streq $opt [lindex $val 0]] } {
		set val [list $opt [lindex $val 1]]
	    }
	    lappend result $val
	}
	return $result
    }
    
    proc configure_get_one { type widget opt } {
	variable _Options

	return -code error "NOT IMPLEMENTED YET"

	if [GT::lcontains $_InwidgetrOpts $opt] {
	    return [$widget.e configure $opt]
	} elseif [GT::lcontains $_OuterOpts $opt] {
	    return [$widget.frame configure $opt]
	} elseif [GT::lcontains $_Options $opt] {
	    set result $_ConfigureInfo($opt)
	    lappend result $_Options($widget,$opt)
	    return $result
	} else {
	    error "unknown option \"$opt\""
	}
    }
    
    proc configure_set { type widget args } {
	variable _Options
	variable _Forward

	set pattern "^[join $_Options($type) |]$"
	set code  { set _Options($widget,$opt) $value }
	
	set switch_code [list $pattern $code]

	foreach { subwidgets options } $_Forward($type,options) {
	    lappend switch_code "^-([join $options |])$" \
		"foreach subwidget {$subwidgets} {
                     \$widget.\$subwidget configure \$opt \$value
                 }"
	}
	lappend switch_code "default" {
	    return -code error \
		"unknown option \"$opt\""
	}

	foreach { opt value } $args {
	    switch -regexp -- $opt $switch_code
	}
    }
    
    proc cget { type widget opt } {
	variable _Options
	variable _Forward

	set pattern "^[join $_Options($type) |]$"
	set code  { return $_Options($widget,$opt) }
	
	set switch_code [list $pattern $code]

	foreach { subwidgets options } $_Forward($type,options) {
	    lappend switch_code "^-([join $options |])$" \
		"return \[\$widget.[lindex $subwidgets 0] cget $opt\]"
	}

	lappend switch_code "default" {
	    return -code error \
		"unknown option \"$opt\""
	}

	switch -regexp -- $opt $switch_code
    }
    
}

#---------------------------------------------------------------------------
#   Set emacs variables
#---------------------------------------------------------------------------
# ;;; Local Variables: ***
# ;;; mode: tcl ***
# ;;; tcl-indent-level: 4 ***
# ;;; End: ***
#---------------------------------------------------------------------------
#   end of file
#---------------------------------------------------------------------------
