### Copyright (C) 1995 Jesper K. Pedersen
### 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.


############################################################
#           This funktion, save the templates.             
############################################################
proc generate {} {
  global progList saveInfo answers shortDesc ok \
      editInfo setup  module
  set noSave 0
  set initProg $editInfo(name)

  # first of all check the actual page
  if {[checkPage] == 0} return
  catch {unset answers}
  
  ### Making the window for print.
  if {$setup(print)} {
    foreach elm $setup(dotfile) {
      set w .output[lindex $elm 0]
      set activeWin([lindex $elm 0]) 0
      set answers([lindex $elm 0]) ""
      if {[winfo exists $w]} {
	$w.text delete 1.0 end
      } else {
	toplevel $w
	wm withdraw $w
	wm title $w [lindex $elm 1]

	button $w.ok -text OK -command "destroy $w"
	pack $w.ok -padx 3m -pady 3m -ipadx 2m -ipady 1m -side bottom
	
	text $w.text -relief raised -bd 2 -yscrollcommand "$w.scroll set" \
	    -setgrid true
	scrollbar $w.scroll -relief flat -command "$w.text yview"
	pack $w.scroll -side right -fill y
	pack $w.text -side left -expand yes -fill both
	wm geometry $w 50x15-0+0
      }
    }
  }

  ### opening the file for output
  if {$setup(file)} {
    foreach elm $setup(dotfile) {
      set OUTPUT([lindex $elm 0]) [open [lindex $elm 2] w]
    }
  }

  ### printing the overall description file
  foreach elm $setup(dotfile) {
    set commentChar [lindex $elm 3]
    if {$setup(print)} {
      eval .output[lindex $elm 0].text insert end \"$module(overAllDesc)\"
    }
    if {$setup(file)} {
      eval puts $OUTPUT([lindex $elm 0]) \"$module(overAllDesc)\"
    }
  }
  unset commentChar

  ### decide how much to save
  if {$setup(onePage)} {
    set plist $editInfo(name)
  } else {
    set plist $progList
  }

  ### runs through all the files, which have to be saved
  foreach prog $plist {
    if {(!$setup(onePage) && $saveInfo($prog) == 0)} continue

    unlink top
    set editInfo(name) $prog
    linkVars $prog top

    set err [catch {uplevel \#0 $ok($prog)} errmsg]

    ### saveing the menu gave an error
    if {$err} {
      global errorInfo pathProgsNames
      set info $errorInfo
      set what [tk_dialog .dialog "Error while saving" "an error occurred in module: \"$pathProgsNames($prog)\", with the following error message: \"$errmsg\". What do you want to do?" error -1 "Continue without saving this module" "Goto errornous module" "see stack trace"]
      if {$what == 1} {
	eval $prog
	return
      }
      if {$what == 2} {
	set w .tkerrorTrace
	catch {destroy $w}
	toplevel $w -class ErrorTrace
	wm minsize $w 1 1
	wm title $w "Stack Trace for Error"
	wm iconname $w "Stack Trace"
	button $w.ok -text OK -command "destroy $w;eval $prog"
	text $w.text -relief raised -bd 2 -yscrollcommand "$w.scroll set" \
	    -setgrid true -width 40 -height 10
	scrollbar $w.scroll -relief flat -command "$w.text yview"
	pack $w.ok -side bottom -padx 3m -pady 3m -ipadx 2m -ipady 1m
	pack $w.scroll -side right -fill y
	pack $w.text -side left -expand yes -fill both
	$w.text insert 0.0 $info
	$w.text mark set insert 0.0
	
	# Center the window on the screen.
	
	wm withdraw $w
	update idletasks
	set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
		   - [winfo vrootx [winfo parent $w]]]
	set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
		   - [winfo vrooty [winfo parent $w]]]
	wm geom $w +$x+$y
	wm deiconify $w
	eval $prog
	return
      }
    } else {
      ### no error occured, printing and/or saving
      foreach elm $setup(dotfile) {
	if {[info exists shortDesc($prog)] && \
		$answers([lindex $elm 0]) != ""} {
	  if {$setup(print)} {
	    .output[lindex $elm 0].text insert end \
		"\n[lindex $elm 3] $shortDesc($prog)\n"
	  }
	  if {$setup(file)} {
	    puts $OUTPUT([lindex $elm 0]) "\n[lindex $elm 3] $shortDesc($prog)"
	  }
	}
	if {$answers([lindex $elm 0]) != ""} {
	  set  activeWin([lindex $elm 0]) 1
	  if {$setup(print)} {
	    .output[lindex $elm 0].text insert end $answers([lindex $elm 0])
	  }
	  if {$setup(file)} {
	    puts $OUTPUT([lindex $elm 0]) $answers([lindex $elm 0])
	  }
	}
	set answers([lindex $elm 0]) ""
      }
    }
  }
  ### opennig the window, and closing the files.
  if {$setup(print)} {
    foreach elm $setup(dotfile) {
      if {$activeWin([lindex $elm 0])} {
	wm deiconify .output[lindex $elm 0]
	raise .output[lindex $elm 0]
      }
    }
  }
  if {$setup(file)} {
    foreach elm $setup(dotfile) {
      close $OUTPUT([lindex $elm 0])
    }
  }

  # exporting
  if {$setup(saveOnGenerate) == 1} {
    saveFile
  }
  
  # creating the original window
  if {$editInfo(name) != $initProg && $initProg != ""} {
    unlink top
    #loadMenu $initProg
    set editInfo(name) $initProg
    linkVars $initProg  top
  } elseif {$initProg == ""} {
    unlink top
    set editInfo(name) ""
  }
}

############################################################
#    This procedure link variables to their basic names.
############################################################
proc linkVars {prefix parent} {
  global editInfo widgetArgs children
  set function $editInfo(name)

  foreach child $children(${function}__$parent) {
    set type $widgetArgs(${function}__${child}__type)
    upvar \#0 ${prefix}_$child prefixChild
    upvar \#0 $child ch

    if {[trace vinfo ch] != ""} {
      error "trace on variable $child: [trace vinfo ch]"
    }
    if {[trace vinfo ch(index)] != ""} {
      error "trace on variable ${child}(index): [trace vinfo ch(index)]"
    }
    
    switch -exact -- $type {
      checkbox -
      int   -
      float -
      label -
      textbox -
      entry {
	trace variable ch rw "linkBasic $child ${prefix}_$child"
	set ch
      }
      
      frame {
	linkVars ${prefix}_$child $child

      }

      menu -
      listbox -
      radio {
	### the create the traces.
	trace variable ch(index) w \
	    "linkTrace_${type}Write $child ${prefix}_$child"
	trace variable ch(index) r \
	    "linkTrace_${type}Read $child ${prefix}_$child"
	trace variable ch(name) w \
	    "linkTrace_${type}Write $child ${prefix}_$child"
	trace variable ch(name) r \
	    "linkTrace_${type}Read $child ${prefix}_$child"
	set ch(index)
	set ch(name)
      }

      extentry -
      line -
      header -
      filloutelm {
	# Nothing It just have to be here.
      }
      fillout {
	trace variable ch w \
	    "linkTrace_filloutWrite $child ${prefix}_$child"
	trace variable ch r \
	    "linkTrace_filloutRead $child ${prefix}_$child"
	set ch
      }
      default {
	error "Unknow type $type"
      }
    }
  }
}
proc linkBasic {basename prefixname dummy arrayname operation} {
  upvar \#0 $prefixname prefixChild
  upvar \#0 $basename child
  
  if {$operation == "r"} {
    set child $prefixChild
  } else {
    set prefixChild $child
  }
}
############################################################
# This function link 'Menu'
# from bacis to prefix Ie. when the bacis element changes,
# this function change the prefix form too
# Ie. name -> $prefix_name
############################################################
proc linkTrace_menuWrite {basename prefixname dummy arrayname operation} {
  global widgetArgs editInfo


  ### first of all check whether an trace allready is in progress
  if {$editInfo(trace)} return
  set editInfo(trace) 1
  set function $editInfo(name)
  set entries $widgetArgs(${function}__${basename}__entries)
  
  upvar \#0 $prefixname prefixChild
  upvar \#0 $basename child

  if {$arrayname == "index"} {
    ### the index elements has been changed
    set index $child(index)
    if {$index<0 || $index>=[llength $entries]} {
      set editInfo(trace) 0
      error "Index \"$index\" is out of range for $basename"
    }
    ### setting the variable
    set prefixChild [lindex $entries $child(index)]
    set child(name) [lindex $entries $child(index)]

  } else {
    ### the name element has been changed.
    if {[lsearch -exact $entries $child(name)] == -1} {
      set editInfo(trace) 0
      error [concat "\"$child(name)\" isn't a valid element in Menu" \
		 "\"$basename\" should be one of \"$entries\""]
    }
    ### settring the variable
    set prefixChild $child(name)
    set child(index) [lsearch -exact $entries $child(name)]
  }

  ### remove the trace flag.
  set editInfo(trace) 0
}
############################################################
# This function link 'Menu'
# from prefix to bacis Ie. when the prefix element changes,
# this function change the bacis form too
# Ie. prefix_name -> name
############################################################
proc linkTrace_menuRead {basename prefixname dummy arrayname operation } {
  global widgetArgs editInfo

  ### first of all check whether an trace allready is in progress
  if {$editInfo(trace)} return
  set editInfo(trace) 1

  set function $editInfo(name)
  set entries $widgetArgs(${function}__${basename}__entries)

  upvar \#0 $basename child
  upvar \#0 $prefixname prefixChild
  set child(name) $prefixChild
  set child(index) [lsearch -exact $entries $prefixChild]

  ### remove the trace flag
  set editInfo(trace) 0
}

############################################################
# This function link 'ListBox'
# from bacis to prefix Ie. when the bacis element changes,
# this function change the prefix form too
# Ie. name -> $prefix_name
############################################################
proc linkTrace_listboxWrite {basename prefixname dummy arrayname operation} {
  global widgetArgs editInfo

  ### first of all check whether an trace allready is in progress
  if {$editInfo(trace)} return
  set editInfo(trace) 1
  set function $editInfo(name)
  set entries $widgetArgs(${function}__${basename}__entries)
  
  upvar \#0 $prefixname prefixChild
  upvar \#0 $basename child

  if {$arrayname == "index"} {
    ### the index elements has been changed
    set list {}
    foreach index $child(index) {
      if {$index<0 || $index>=[llength $entries]} {
	set editInfo(trace) 0
	error "Index \"$index\" is out of range for $basename"
      }
      lappend list [lindex $entries $index]
    }
    ### setting the variable
    set prefixChild $child(index)
    set child(name) $list

  } else {
    ### the name element has been changed.
    set list {}
    foreach elm $child(name) {
      set index [lsearch -exact $entries $elm]
      if {$index  == -1} {
	set editInfo(trace) 0
	error [concat "\"$elm\" isn't a valid element in ListBox" \
		   "\"$basename\" should be one of \"$entries\""]
      }
      lappend list $index
    }
    
    ### settring the variable
    set prefixChild $list
    set child(index) $list
  }

  ### remove the trace flag.
  set editInfo(trace) 0
}
############################################################
# This function link 'Listbox'
# from prefix to bacis Ie. when the prefix element changes,
# this function change the bacis form too
# Ie. prefix_name -> name
############################################################
proc linkTrace_listboxRead {basename prefixname dummy arrayname operation } {
  global widgetArgs editInfo

  ### first of all check whether an trace allready is in progress
  if {$editInfo(trace)} return
  set editInfo(trace) 1

  set function $editInfo(name)
  set entries $widgetArgs(${function}__${basename}__entries)

  upvar \#0 $prefixname prefixChild
  upvar \#0 $basename child

  set child(name) {}
  set child(index) {}
  foreach elm $prefixChild {
    lappend child(name) [lindex $entries $elm]
    lappend child(index) $elm
  }

  ### remove the trace flag
  set editInfo(trace) 0
}

############################################################
# This function link 'Radio'
# from bacis to prefix Ie. when the bacis element changes,
# this function change the prefix form too
# Ie. name -> $prefix_name
############################################################
proc linkTrace_radioWrite {basename prefixname dummy arrayname operation} {
  global widgetArgs editInfo

  ### first of all check whether an trace allready is in progress
  if {$editInfo(trace)} return
  set editInfo(trace) 1
  set function $editInfo(name)
  set entries $widgetArgs(${function}__${basename}__entries)
  
  upvar \#0 $prefixname prefixChild
  upvar \#0 $basename child

  if {$arrayname == "index"} {
    ### the index elements has been changed
    set index $child(index)
    if {$index<0 || $index>=[llength $entries]} {
      set editInfo(trace) 0
      error "Index \"$index\" is out of range for $basename"
    }

    ### setting the variable
    set prefixChild $index
    set child(name) [lindex $entries $index]

  } else {
    ### the name element has been changed.
    set index [lsearch -exact $entries $child(name)]
    if {$index  == -1} {
      set editInfo(trace) 0
      error [concat "\"$child(name)\" isn't a valid element in ListBox" \
		 "\"$basename\" should be one of \"$entries\""]
    }
    
    ### settring the variable
    set prefixChild $index
    set child(index) $index
  }

  ### remove the trace flag.
  set editInfo(trace) 0
}
############################################################
# This function link 'Radio'
# from prefix to bacis Ie. when the prefix element changes,
# this function change the bacis form too
# Ie. prefix_name -> name
############################################################
proc linkTrace_radioRead {basename prefixname summy arrayname operation } {
  global widgetArgs editInfo

  ### first of all check whether an trace allready is in progress
  if {$editInfo(trace)} return
  set editInfo(trace) 1

  set function $editInfo(name)
  set entries $widgetArgs(${function}__${basename}__entries)

  upvar \#0 $prefixname prefixChild
  upvar \#0 $basename child

  set child(name) [lindex $entries $prefixChild]
  set child(index) $prefixChild

  ### remove the trace flag
  set editInfo(trace) 0
}
############################################################
# This function link 'Radio'
# from bacis to prefix Ie. when the bacis element changes,
# this function change the prefix form too
# Ie. name -> $prefix_name
############################################################
proc linkTrace_filloutWrite {basename prefixname dummy arrayname operation} {
  error "It is not posible to set an fillOut element, this is a readonly variable"
}
############################################################
# This function link 'Radio'
# from prefix to bacis Ie. when the prefix element changes,
# this function change the bacis form too
# Ie. prefix_name -> name
############################################################
proc linkTrace_filloutRead {basename prefixname summy arrayname operation } {
  fillOutSave $basename
}

############################################################
# This function unlink the variables
# If its argument is a frame or an extentry, then all
# there children are unlinked.
############################################################
proc unlink {name} {
  global widgetArgs editInfo children
  set function $editInfo(name)
  if {$function == ""} return
  if {$name == "top"} {
    set type frame
  } else {
    set type $widgetArgs(${function}__${name}__type)
  }
  switch -exact -- $type {
    checkbox -
    int   -
    float -
    label -
    textbox -
    entry -
    menu -
    listbox -
    radio {
      uplevel \#0 "catch {unset $name}"
    }
    frame -
    extentry -
    filloutelm {
      foreach child $children(${function}__$name) {
	unlink $child
      }
    }
    fillout {
      uplevel \#0 "catch {unset $name}"
      foreach child $children(${function}__$name) {
	unlink $child
      }
    }
    line -
    header {}

    default {
      error "Unknown type: $type"
    }
  }
}
############################################################
# This function is called from the makeChange function.
# It takes care of linking the right variables, and
# no more than what is nessecary.
############################################################
proc UpdateActive {name prefix} {
  global widgetArgs children activeNivau editInfo parent
  set function $editInfo(name)
  set par $parent(${function}__$name)

  if {$par == "top"} return

  ### the element is part of an extentry.
  # calculating the prefix path up to the top.
  set prefixList {}
  while {$par != "top"} {
    set prefixList "$par $prefixList"
    set par $parent(${function}__$par)
  }

  # removeing the function name from the prefix
  regexp "^${function}_(.*)\$" $prefix all prefix
  set prefix ${prefix}_
  set indexList {}

  # calculating the index's
  foreach pre $prefixList {
    set type $widgetArgs(${function}__${pre}__type)
    switch $type {
      extentry {
	if {![regexp "^${pre}(\[0-9\]+)_(.*)\$" $prefix all index rest]} {
	  error "Coulnd't parse \"$prefix\" with \"$pre\""
	}
	lappend indexList $index
      }
      frame -
      fillout {
	if {![regexp "^${pre}_(.*)\$" $prefix all rest]} {
	  error "Coulnd't parse \"$prefix\" with \"$pre\""
	}
      }
      filloutelm {
	if {![regexp "^(\[0-9\]+)_(.*)\$" $prefix all index rest]} {
	  error "Coulnd't parse \"$prefix\" for $pre"
	}
	lappend indexList $index
      }
      default {
	error "unknown type $type"
      }
    }
    set prefix $rest
  }
  # relinking variables
  set changed 0
  set index 0
  set prefix "$function"
  foreach pre $prefixList {
    switch $widgetArgs(${function}__${pre}__type) {
      frame -
      fillout {
	append prefix "_$pre"
	continue
      }
      filloutelm {
	append prefix "_[lindex $indexList $index]"
      }
      extentry {
	append prefix "_$pre[lindex $indexList $index]"
      }
      default {
	error "wrong type: $widgetArgs(${function}__${pre}__type)"
      }
    }
    if {!$changed && (![info exists activeNivau($pre)] ||
		      $activeNivau($pre) != [lindex $indexList $index])} {
      set changed 1
      unlink $pre
    }
    if {$changed} {
      linkVars $prefix $pre
      set activeNivau($pre) [lindex $indexList $index]
    }
    incr index
  }

  # reseting links below
  foreach child $children(${function}__$pre) {
    set type $widgetArgs(${function}__${child}__type)
    if {$type == "extentry" || $type == "frame"} {
      resetBelow $child
    }
  }
}

############################################################
# This function delete the activity for extentry's
# below the on which just have been selected.
############################################################
proc resetBelow {parent} {
  global children activeNivau editInfo widgetArgs
  set function $editInfo(name)

  if {$widgetArgs(${function}__${parent}__type) == "extentry"} {
    catch "unset activeNivau($parent)"
  }
    
  foreach child $children(${function}__$parent) {
    set type $widgetArgs(${function}__${child}__type)
    if {$type == "extentry" || $type == "frame"} {
      resetBelow $child
    }
  }
}
############################################################
#    This procedure is used to run through an extentry
############################################################
proc forevery {name proc} {
  global widgetArgs activeNivau editInfo parent scrollValue
  set function $editInfo(name)
  set type $widgetArgs(${function}__${name}__type)

  if {$type != "extentry"} {
    error "forevery may only be used on extentries. type of \"$name\" is \"$type\""
  }

  set prefix "[buildPath $name]_$name"
  set count [lindex $scrollValue($prefix) 0]

  ### evaluateing proc for each prompt.
  for {set i 0} {$i < $count} {incr i} {
    unlink $name
    linkVars $prefix$i $name
    set activeNivau($name) $i
    set result [catch {uplevel \#0 $proc} err]
    switch $result {
      1 {error $err}
      3 break
    }
  }
  resetBelow $name
}

############################################################
#    This procedure enables or disables widgets
############################################################
proc Enable {args} {
  global editInfo children
  set function $editInfo(name)

  foreach widget $args {
    enable_disable normal $widget
  }
}

proc Disable {args} {
  global editInfo children
  set function $editInfo(name)

  foreach widget $args {
    enable_disable disabled $widget
  }
}
proc enable_disable {mode name} {
  global state editInfo widgetArgs var2path children
  set function $editInfo(name)
  if {![info exists widgetArgs(${function}__${name}__type)]} {
    error "Enable/Disable called with an unknow widget: \"$name\""
  }
  set type $widgetArgs(${function}__${name}__type)
  set prefix [buildPath $name]
  # check if state information exists
  if {![info exists state(${prefix}_$name)]} {
    set state(${prefix}_$name) "normal"
  }

  # seting the state if it has changed.
  if {$state(${prefix}_$name) != $mode} {
    set state(${prefix}_$name) $mode
    if {[info exists var2path(${prefix}_$name)] } {
      setState $var2path(${prefix}_$name) $prefix $name
    }
    if {$type == "extentry"} {
      forevery $name "foreach child {[set children(${function}__$name)]} {enable_disable $mode \$child}"
    }
    if {$type == "frame"} {
      foreach child $children(${function}__$name) {
	enable_disable $mode $child
      }
    }
  }
}
############################################################
# Given an extentry, this function create a variable
# prefix all the way down through the active elements
# including the function as prefix.
############################################################
proc buildPath {name} {
  global parent editInfo activeNivau state widgetArgs
  set function $editInfo(name)
  
  set par $parent(${function}__$name)
  # calculating the prefix path up to the top.
  set prefixList {}
  while {$par != "top"} {
    set prefixList "$par $prefixList"
    set par $parent(${function}__$par)
  }

  # creating the prefix
  set prefix "${function}"

  foreach pre $prefixList {
    set type $widgetArgs(${function}__${pre}__type)
    switch $type {
      extentry {
	if {![info exists activeNivau($pre)]} {
	  error "Missing a forevery on $pre"
	}
	append prefix "_$pre$activeNivau($pre)"
      }
      filloutelm {
	if {![info exists activeNivau($pre)]} {
	  error "Fillout page for $pre have to be visable, before you can refer to it."
	}
	append prefix "_$activeNivau($pre)"
      }
      frame -
      fillout {
	append prefix "_$pre"
      }
      fillout {
      }
      default {
	error "unknow type $type"
      }
    }
  }
  return $prefix
}
