#------------------------------------------------------------------------
# Compagny	:	4Js
# Developper	:	PM
# Program	:	$PROJET/objects/widget.res
# Date		:	03.07.1995
# Last modif.	:	13.10.1995
# Title		:	Description des classes de base
#------------------------------------------------------------------------
# Explication :   
#	Widget is the default class, from witch all the graphical object
# descends. He has defined all the functions (methodes) witch are common
# to every objects, like the move, or the display methode. There are NO 
# entities of class Widget. But all objects herites from it.
#	Displaying is assumed by the methode Display_Widget, called by
# the display event of the widget. The Pack_Widget (and eventually the
# Place_Widget- ) -methodes can display it on screen.  So Display_Widget
# is tk-independant. The define event is not defined in this class, because
# it defers from one graphical object to antoher. But it is called in the
# Display_... methode.
# The display event is called with optionnaly root parameter (in this case,
# the actually widget root is lost and replaced with this new), but the
# pack_it, place_it are without root parameter, because it is
# assumed that the root is already known. 

#======================================================================

Class Widget {

	global Default
#vars :
	public int_parent	""	;# Object that is the parent
	public int_owner	""	;# Object proprietary
	public int_moveable	"N"
	public int_show_attr	"N"	;# Y, N, or H for herited
	public int_wattr_meth	""
	public int_wattr_geo	""
	public int_wattr_int	""
	public int_name		""
	public int_geoman	"place_it"
	public int_prefixes	"int geo meth"
	public int_bindings	""

	public geo_root		.
	public geo_widget	""
	public geo_x		0
	public geo_y		0
	public geo_width	0
	public geo_height	0
	public geo_padx		$Default(Widget,PadX)
	public geo_pady		$Default(Widget,PadY)
	public geo_borderwidth	$Default(Widget,BorderWidth)	;# 2
	public geo_relief     	$Default(Widget,Relief)
	public geo_bg         	$Default(Widget,Bg)
	public geo_fg         	$Default(Widget,Fg)
	public geo_active_fg    $Default(Widget,ActiveFg)
	public geo_attach	"left"
	public geo_fill		"none"
	public geo_expand	0	;# Tk default;in this object

constructor {config} {
	set int_name $this ;	# try not to use $int_name, but $this
  }

method config {config} {}

#-----------------------------------------------------------------------
# Destroy_Widget :
#	This function deletes an object's widget, and the full abstract
# structure of the object too.
# Parameters: just the name of object.
#.......................................................................

destructor {

  # puts "Destroy_Widget: on y entre pour destroyer $this"

  foreach i "$int_prefixes " {
	if { [set int_wattr_[set i]] != "" } {
#		puts "Destroy_Widget: au passage, destroyer $name(int,wattr,$i)"
		virtual show_attr_done $i
		}
	}

#  puts "Widget::destructor, destroying $geo_widget"
  if { $geo_widget != "" } {
       ::destroy	$geo_widget
       }
  if {[winfo exist $geo_widget] == 1} {
#	puts "Widget:destructor, destruction failed"
	} else {
#	puts "Widget:destructor, $geo_widget destroyed"
	}

  if { $int_parent != "" } {
	$int_parent supp_soon $this
	}
  # puts "Destroy_Widget: on en sort pour $this"
  }

#-----------------------------------------------------------------------
# Destroy_Widget :
#	Temporare, please use the destructor method with the call 
# of delete standard event.
#.......................................................................

method destroy { } {
  virtual delete
  }


method show { what } {
  puts stdout "$what is >[eval $$what]<"
  }

method widget { } {
  return $geo_widget
  }

#-----------------------------------------------------------------------
# Display_Widget :
#	Used by the most class witch herites from. It defines graphically
# the object, and then puts it on screen, in a specified container. This
# function calls 2 particular methodes : the first defines under X the
# object (button, label,...). This is why this methode can only be defined
# in a class for witch a Tk-widget is assigned, and not here. The
# Display_Widget methode can only be called for such an object. So there
# are no risks for this methode to be called without a corresponding
# define methode. In the other case, there is one or more BUG!
# Parameters :
#	name	of object
#	root	of graphical object, eventually if redefined,
#		or not defined yet
# Returns :	nothing
#.......................................................................

method display { {root .} } {

#  puts "Display_Widget: comming in"
if {$root != ""} {
  set geo_root $root
  } 


#  puts "Display_Widget: making $this"

# First define this object in graphical, if it isn't already done yet
# puts "Display_Widget: define or refresh ?"
  if {$geo_widget == ""} {
	 #puts "Display_Widget: $this geo_widget = $geo_widget"
	virtual init_res 		# rWidget particularity
	virtual define
	
   } else {
	 #puts "Display_Widget: $this refresh "
	virtual refresh
	}

# Is this widget moveable on screen?
 #puts "Display_Widget: $this moveable ?"

  if {$int_moveable != "N" }	{
	virtual init_move
	} else {
	virtual remove_move
	}

# Is this object authorized of show his attributs ?
 #puts "Display_Widget: $this show attributs  ?"

  if {$int_show_attr != "N"}	{

	set_binding <ButtonRelease-3> "
		$this init_show_attr "

	virtual init_resize
	}

# It is possible, that bindings has been set, befor widget has been defined.

  foreach cmd $int_bindings {
	#puts "Widget::display: for $this, evaluating >$cmd<"
#	puts "Display_Widget: concerned value is >[lindex $cmd 1]<"
	eval $cmd
	}

# And then, show it on screen with the appropriate geometry manager
if { $int_geoman != "" }	{
	# puts "Display_Widget:  call geoman for $_name" 
	virtual $int_geoman	;# !!! place_it or pack_it
	}

  #puts "Widget::display: going out"
  }

#-----------------------------------------------------------------------
# Place_Widget :
#	Used as standard for a sort of geometry manager. Puts graphical
# object on screen on x,y coordinates. This methode is herited by most
# of the other objects. In opposite of a Define_... methode, the methodes
# Place_Widget and Pack_Widget are (sensibly) the same for all the widgets.
# But they can be redefined in sub-classes if needed.
# Parameters :	name of object
# Returns :	nothing
#.......................................................................

method place_it { } {

#  puts "For $this, geo_x is $geo_x, and geo_y is $geo_y"
  if {$geo_widget != ""} {
     place configure $geo_widget	\
  		-x $geo_x		\
  		-y $geo_y
     }

# puts "la commande executee sera $cmd"
  }

#-----------------------------------------------------------------------
# Pack_Widget :
#	Used as standard for a sort of geometry manager. Puts graphical
# object on screen and pack it with other objects on the same container
# This methode is herited by most of the other objects. Please read the
# comments of the Place_Widget methode.
# Parameters :	name of object
# Returns :	nothing
#.......................................................................

method pack_it { } {

# puts "mode de FILLING pour $name is $name(geo,fill)"

if { $geo_padx < 0 } {
	set geo_padx 0
	}

if { $geo_pady < 0 } {
	set geo_pady 0
	}

# puts stderr "in pack_it for $this, geo_attach is $geo_attach"; flush stderr

#puts stderr "pack $geo_widget	-side	[$this getPub geo_attach ]	\
			-fill	[$this getPub -geo_fill ]	\
			-expand [$this getPub -geo_expand ]	\
			-padx	[$this getPub -geo_padx ]	\
			-pady	[$this getPub -geo_pady ]"
pack $geo_widget	-side	[$this getPub -geo_attach ]	\
			-fill	[$this getPub -geo_fill ]	\
			-expand [$this getPub -geo_expand ]	\
			-padx	[$this getPub -geo_padx ]	\
			-pady	[$this getPub -geo_pady ]
#puts stderr "ok"; flush stderr
  }

#------------------------------------------------------------------------
# Init_Move :
#	Defines the bindings necessary to move dynamically objects on screen.
# Is specially used for forms objects. That's why, it was tested if the
# object is moveable ( if ${name}(int,moveable) == "Y" )
# Parameters :	name of objects
# Return :	nothing, only moves object.
# Global variables used :	curX, curY
# Data changed :	${name}(geo,x) ${name}(geo,y) of each object
#........................................................................

method init_move { {wid_to_bind ""} } {
  global curX, curY

  if {$wid_to_bind == ""} {set wid_to_bind [$this getPub -geo_widget]}

if { $int_moveable == "H" } {
    $int_parent init_move $wid_to_bind
    return 0
  } else {
    set l_wid $this
    set obj_path $geo_widget
  }


  set curX -1000
  bind $wid_to_bind <Button-1> "
	set curX %X
	set curY %Y
	set oldcurX \[ $l_wid getPub -geo_x \]
	set oldcurY \[ $l_wid getPub -geo_y \]
	"
  bind $wid_to_bind <B1-Motion> "
      set oldcurX \[expr \$oldcurX + %X - \$curX\]
      set oldcurY \[expr \$oldcurY + %Y - \$curY\]
      place $obj_path -x \$oldcurX -y \$oldcurY
      set curX %X
      set curY %Y
	"

  bind $wid_to_bind <ButtonRelease-1> "
	$l_wid config -geo_x \$oldcurX
	$l_wid config -geo_y \$oldcurY
	"
  }

method __init_move { } {
  global curX, curY

  bind $geo_widget <Button-1> "
	set curX %X
	set curY %Y
	"
  bind $geo_widget <B1-Motion> "
	set X \[expr  %X - \$curX \]
	set Y \[expr  %Y - \$curY \]
	$this config -geo_x \[expr \[ $this getPub -geo_x \] + \$X\]
	$this config -geo_y \[expr \[ $this getPub -geo_y \] + \$Y\]
	$this place_it
	set curX %X
	set curY %Y
	"

  bind $geo_widget <ButtonRelease-1> "
	"
  }

#------------------------------------------------------------------------
# Init_Resize :
#	Defines the bindings necessary to resize dynamically objects
# on screen.  Is specially used for forms objects. That's why, it was
# tested if the object is being designed :
#		( if ${name}(int,being_designed) == "Y" )
# It is possible, that not all objects can be resize on height. For those
# objects, it is necessary to redefine the appropriate function.
# Parameters :	name of objects
# Return :	nothing, only resize object.
# Global variables used :	curX, curY
# Data changed :	attribut geo_width and geo_height of object
#........................................................................

method init_resize { } {
  global curX, curY

  bind ${geo_widget} <Meta-Button-1> "
	set curX %X
	set curY %Y
	"

  bind ${geo_widget} <Meta-B1-Motion> "
	set X \[expr  %X - \$curX \]
	set Y \[expr  %Y - \$curY \]
	$this config -geo_width \[expr \[ $this getPub -geo_width \] + \$X\]
	$this config -geo_height \[expr \[ $this getPub -geo_height \] + \$Y\]
	if { \[$this getPub -geo_width \] < 0 } { $this config -geo_width 0 }
	if { \[$this getPub -geo_height \] < 0 } { $this config -geo_height 0 }
	$this refresh
	set curX %X
	set curY %Y
	"
# $this config -geo_x \[expr \[ $this getPub -geo_x \] + \$X\]

  bind ${geo_widget} <Meta-ButtonRelease-1> " "
  }


#-----------------------------------------------------------------------
# Raise : 03.04.97
#	Sometimes, it is usefull.
# Returns: nothing, just work well.
#.......................................................................

#method raise { } {
# if {$geo_widget != ""} {
#   raise $geo_widget
#   } else {
#   # puts stderr "Calling of raise for <$this> since there is no widget"
#   }
# }

#-----------------------------------------------------------------------
# Clear_Widget :
#	Is used to delete the physical widget of the object
# ( .desi.form.tagada ), but conserve his object structur variable.
# Parameter: name of object
# Returns: nothing, just work well.
#.......................................................................

method clear { } {

# puts "Clear_Widget: on y entre pour destroyer $name(geo,widget)"

if {$geo_widget != ""} {
	::destroy	$geo_widget
	set geo_widget ""
	}
#foreach entity $name(int,soons) {
#	foreach soon $name(int,$entity) {
#		global $soon
# 		puts "Clear_Widget: clear of soon $soon, with root $name(geo,widget)"
#		set ${soon}(geo,widget) ""
#		call $soon clear
#		}
#	}
  }

#------------------------------------------------------------------------
# Remove_Move
#	Suppression of the bindings, define for the move capacity, in the
# case of a refresh after setting the show_attr attribut of an objet on "N"
#........................................................................

method remove_move { } {
  bind $geo_widget <Button-1>	{}
  bind $geo_widget <B1-Motion>	{}
  bind $geo_widget <ButtonRelease-1> {}
  }


#------------------------------------------------------------------------
# SetBg :
#	This function sets recursivelly the background for the
# specifyed object, and all those, contained in it.
# Becarefull, there is a Tk-command included.
# Parameters:	name of object, and the wanted color.
# Returns:	nothing
#........................................................................

method set_bg { color } {

  foreach entity $int_soons {
	foreach soon $int_$entity {
		$soon setbg $color
		# puts stderr "SetBg: set bg $color for $soon"
		}
	}
  $name(geo,widget) configure -bg $color
  }

#------------------------------------------------------------------------
# SetBinding:
#	Used to define for example a mouse event on the thing. Events
# can be defined befor the physicall widget itself. They will be then
# defined when the widget will be created.
# Parameters:	name of object, name of event, and instruction set.
# Return:	nothing at all
#........................................................................

method set_binding { event instructions } {

  if { $geo_widget != "" } {
	bind $geo_widget $event $instructions
      } else {
	lappend int_bindings \
	"$this set_binding $event { $instructions }"
      }
  }

#-----------------------------------------------------------------------
# Reset_Geo :
#	Very usefull in some case, to recompose frame contains
# Entry :	name : Entity name of object
# Returns :	nothing.
#.......................................................................

method reset_geo { } {
  pack forget $geo_widget
  }

#------------------------------------------------------------------------
# Copy_Widget_Entity :
#	This function copies the object given in parameters, with the same
# attribut values, for all class of objects.
# Parameters :	name of original object, and the name of the copy
# Returns:	the new object made.
#........................................................................

method copy_to { newobj } {

  set clas [$this info inherit]
  # puts stderr "The copied class is $clas"

  $class $newobj

  foreach entity [array names obj] {
	regsub -all "$_obj" "$obj($entity)" "$newobj" newobj($entity) }

  set newobj(geo,widget)	""
  return $newobj(int,name)
  }

#------------------------------------------------------------------------
# Init_Show_Attributs :
#	This function is called, when an attribut list is invoked. It
# display a menu for choosing the specification of the object attributs
# that are wanted.
# Parameters :	name of objects
# Return :	nothing.
#........................................................................

method init_show_attr { } {

if { $int_show_attr == "H" } {		;# 'H' for herited
	$int_parent init_show_attr
    } else {
#	global a_menu_$_name 
	if {[info commands a_menu_$this] == "a_menu_$this"} {
		if {a_menu_$this getPub -geo_widget != ""} {
			# puts stderr "This menu (a_menu_$this) is already existing"
			a_menu_$this raise
		   } else {
			# puts stderr  "This menu (a_menu_$this) has lost its widget"
			a_menu_$this display
		   }
		return -1
	} else {
		Rmenu a_menu_$this	\
			-int_lifetype "temporar"	\
			-int_geoman	"place_it"	\
			-geo_orientation "vertical"	\
			-geo_x		50		\
			-geo_y		30		\
			-geo_int_padx	2		\
			-geo_int_pady	2
#			-geo_title	"Witch attribut for <$this>"

		foreach prefix $int_prefixes {	;# for each sort of attribut prefix...
			switch $prefix {
				"var"	{set libel "Variables"}
				"meth"	{set libel "Methodes"}
				"geo"	{set libel "Geometry"}
				"int"	{set libel "Internal"}	}
			a_menu_$this add_member \
			     ${this}_$prefix $libel  "$this swap_wattr $prefix"  
#			puts "Widget: libel is $libel"
			}
		a_menu_$this add_member ${this}_b_esc "  Done  "  ""  
		a_menu_$this add_member ${this}_b_del " Delete "  "$this destroy"  
		a_menu_$this display 
	}
   }
  }

#------------------------------------------------------------------------
# Swap_Show_Attributs :	called by event <swap_wattr> to the class "WIDGET"
#	This function is called by a Rmenu button, when an attribut list
# has been invoked, on the widget class level, and with a attribut specification.
# This function has been written to swap, when an attributlist
# is called more than once.
# Parameters :	name of object from witch the attributs must be shown,
#		search specification, or what sort of attributs are wanted.
# Returns:	nothing yet
#........................................................................

method swap_wattr { specif} {

# puts "Swap_Show_Attributs for $this"

  if { [set int_wattr_[set specif]] == ""} {
	show_me_attr $specif
   } else {
	show_attr_done $specif
   }
  }

#------------------------------------------------------------------------
# Show_Attributs :	called by event <show_me_attr>
#	Display a new window on screen, with a list of all
# possible attributs for this object.
# Parameters :	name of object
# Returns:	nothing yet
#........................................................................

method show_me_attr { specif } {

	Attributlist ${this}_attr_${specif}	\
		-int_specif	$specif 	\
		-int_owner	$this		\
		-geo_title	"Attributs of type <$specif> for >$this<"

#puts "Show_Attributs: Ouverture de la fenetre d\'ATTRIBUT pour $_name"
#puts "Show_Attributs: Appel fonction f'affichage: $name(meth,display)"

	set int_wattr_${specif} ${this}_attr_${specif}
	${this}_attr_${specif} display
  }

#------------------------------------------------------------------------
# Show_Attributs_Done :		called by the event <show_attr_done>
#	Hide again the window, or destroy it,...
# Parameters :	name of object
# Returns:	nothing yet
#........................................................................

method show_attr_done { specif } {

# puts "Show_Attributs_Done: on y entre"

  catch "[set int_wattr_[set specif]] destroy"
  set int_wattr_${specif} ""
  virtual display

# puts "Show_Attributs_Done for $_name: on en sort"
  }

#------------------------------------------------------------------------
# Show_Attributs_Cancel :		called by the event <show_attr_cancel>
#	Hide again the window, or destroy it,...
# Parameters :	name of object
# Returns:	nothing yet
#........................................................................

method show_attr_cancel { _name specif } {

# puts "Show_Attributs_Cancel: on y entre"

  catch "[set int_wattr_[set specif]] destroy"
  set int_wattr_${specif} ""

# puts "Show_Attributs_Cancel for $_name: on en sort"
  }

#-----------------------------------------------------------------------
# init_res : dummy function. Should never have a body in this module.
#.......................................................................
method init_res  { args } {
  }
} ;# end of CLASS

#-----------------------------------------------------------------------
# Init_W_Chg_NbLines :
#	This function is the redefinition of the Init_Chg_NbLines function,
# corresponding to the <init_ch_lines> event, first defined in the
# Container class. The original function is recursiv to all class of
# type Container. But the last one of the hierarchical tree must be
# redefined: this is the case here.
#.......................................................................

METHODE Init_W_Chg_NbLines  { _name } {
global $_name
upvar #0 $_name name
global $name(int,parent)

# puts "Init_W_Chg_NbLines: initialising $_name (end of tree)"

# call name set_binding <Shift-Button-1> "puts \"Increment lines\" "
call $_name set_binding <Shift-Button-1> "call $name(int,parent) incr_lines"

# call name set_binding <Shift-Button-3> "puts \"Decrement lines\" "
call $_name set_binding <Shift-Button-3> "call $name(int,parent) decr_lines"
}
#======================================================================