# SpecTcl, by S. A. Uhler and Ken Corey
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.txt" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# experimental version for generating java code

# compile a jui into a java program
#  file:  the unix file containing the ui description
#  out:	  The file to write the tk program to (defaults to stdout)
#  prefix: The procedure prefix
#  run:	  Invoke the generated procedure (not used)

set Boiler {
public static void main(String[] args) {
    Frame f = new Frame("%1$s Test");
    %1$s win = new %1$s();
    win.init();
    f.add("Center", win);
    f.pack();
    f.show();
}

private void reset(GridBagConstraints con) {
    con.gridx = GridBagConstraints.RELATIVE;
    con.gridy = GridBagConstraints.RELATIVE;
    con.gridwidth = 1;
    con.gridheight = 1;
 
    con.weightx = 0;
    con.weighty = 0;
    con.anchor = GridBagConstraints.CENTER;
    con.fill = GridBagConstraints.NONE;
 
    con.insets = new Insets(0, 0, 0, 0);
    con.ipadx = 0;
    con.ipady = 0;
}
}

array set Javamap {
	label	Label
	entry	TextField
	text	TextArea
	button	Button
	scrollbar Scrollbar
	frame	Panel
	checkbutton	Checkbox
	radiobutton	Checkbox
	menubutton  Choice
	listbox List
	canvas Canvas
}
	
# Value is the
array set Javamap {
	label.text		$var.setText("$value");
	entry.text		$var.setText("$value");
	entry.show		$var.setEchoCharacter('$value');
	checkbutton.text $var.setLabel("$value");
	radiobutton.text $var.setLabel("$value");
	radiobutton.variable "$var.setCheckboxGroup($value);"
	button.text		$var.setLabel("$value");
	menubutton.text {[choice_text $var $value]}
	*.font			{$var.setFont([jfont $value]);}
	*.foreground	{$var.setForeground([jcolor $value]);}
	*.background	{$var.setBackground([jcolor $value]);}
	*.editable	{[do_editable $var $value]}
}
# This used to be a part of Javamap, but what's it supposed
# to do?
#	entry.width		[entry_width]

array set Javaanchormap {
    sticky:nw   NORTHWEST
    sticky:n    NORTH
    sticky:ne   NORTHEAST
    sticky:new  NORTH
    sticky:w    WEST
    sticky:c    CENTER
    sticky:     CENTER
    sticky:e    EAST
    sticky:ew   CENTER
    sticky:sw   SOUTHWEST
    sticky:s    SOUTH
    sticky:es   SOUTHEAST
    sticky:esw  SOUTH
    sticky:nsw  WEST
    sticky:ns   CENTER
    sticky:nes  EAST
    sticky:nesw CENTER
}
array set Javafillmap {
    sticky:nw   NONE
    sticky:n    NONE
    sticky:ne   NONE
    sticky:new  HORIZONTAL
    sticky:w    NONE
    sticky:c    NONE
    sticky:     NONE
    sticky:e    NONE
    sticky:ew   HORIZONTAL
    sticky:sw   NONE
    sticky:s    NONE
    sticky:es   NONE
    sticky:esw  HORIZONTAL
    sticky:nsw  VERTICAL
    sticky:ns   VERTICAL
    sticky:nes  VERTICAL
    sticky:nesw BOTH
}

# set up some java specific preferences

set P(extends) java.applet.Applet

proc compile_jui {file {out ""} {prefix ""} {run ""}} {
	global Widget_data Format Masters Version Javamap Javaanchormap Javafillmap Boiler P
	global CB_Groups
	catch "unset CB_Groups"
	set Id "WidGet file"
	catch "unset Masters"
	array set map {row height column width}
	set widget_names ""

	if {![file readable $file]} {
		set msg "$file does not exist, can't compile it."
		tk_dialog .open "Compile error" $msg "error" 0 OK
		return 1
	}
	set fd [open "$file" r]

	set line ""
	gets $fd line
	if {[string first $Id $line] != 0} {
		set msg "$file is not a UI file"
		tk_dialog .open "Open Error" $msg "error" 0 OK
		close $fd
		return 1
	}

	set out_fd [Jopen_out $out]
	if {$out_fd == ""} {
	    return 1
	}

	# Gather up all of the data for each widget.
	# Put it in the arrays __X_$name, generally used
	# under the alias "data"

	while {1} {
		gets $fd line
		if {[eof $fd]} break

		# gather entire line

		while {![info complete $line]} {
			append line "\n[gets $fd]"
			# puts stderr gulp
			}
		if {[string first Widget $line] == 0} {
			set name [lindex $line 1]
			lappend names $name
			upvar #0 __X_$name data
			# Set default attributes
			set data(geometry,fill) none
			set data(geometry,anchor) c
		    set data(geometry,sticky) c
		} else {
			set index -1
			foreach i {type option value} {
				set $i [lindex $line [incr index]]
			}

			if {$option == "master"} {
				set Masters([string trimleft [expr {$value=="" ? "f" : $value}] .]) 1
			}
			set data($type,$option) $value
		}
	}
	close $fd

	########################################################
	# end of pass 1

	# Prefix is the name of the project (and Applet class)
	if {$prefix == ""} {
		set prefix [file root [file tail $file]]
	}

	# Sort names:
	set names [lsort -command "frames_first" $names]

	# Rename all user-level item_names to use _ not #
	foreach name $names {
		upvar #0 __X_$name data
		regsub # $data(other,item_name) _ data(other,item_name)
	}
		

	############################################################
	# Output the info as Java code:
	#
	# $names is a list of all the internal names of the widgets
	# "f" is the top-level container.
	#
	# $data($type, $option) = $value for each specified
	# attribute of each element of the form, where "data"
	# is upleveled (one array for each widget)
	############################################################

	# Initial boilerplate and class declaration:
	puts $out_fd "// SpecTcl generated class $prefix, version $P(Version)\n"
	if {[info exists P(package)]} {
		if {![regexp $P(package) {^[ 	]*$}]} {
			puts $out_fd "package $P(package);"
		}
	}
	puts $out_fd "import java.awt.*;"
	if {[info exists P(imports)]} {
		foreach import $P(imports) {
			puts $out_fd "import $import;"
		}
	}
	if {[info exists P(implements)]} {
		if {![regexp $P(implements) {^[ 	]*$}]} {
			set imp "implements $P(implements) "
		}
	}
	append imp {}

	puts $out_fd ""
	puts $out_fd "public class $prefix extends $P(extends) $imp\{		\n"

	# make a "client data" slot
	puts $out_fd "// a slot to hold an arbitrary object pointer that can"
	puts $out_fd "// be filled in by the app. and referenced in actions"

	set arg Object
	if {[info exists P(arg)]} {
		if {![regexp $P(arg) {^[ 	]*$}]} {
			set arg $P(arg)
		}
	}
	puts $out_fd "public $arg arg;\n"

	# Declare an instance variable for each widget:
	foreach name $names {
		upvar #0 __X_$name data
		if {$name == "f" } continue

		set var $data(other,item_name)
		set type $data(other,type)

		# allow user's to use subclass of awt widgets
		# look for:
		#   SubClass
		#   SubClass.init_method(args)

		set data(call) ""
		if {$data(other,subclass) != ""} {
			regexp {([^. ]+)(\.(.*))?} $data(other,subclass) x \
				data(actual) x data(call)
		} else {
			set data(actual) $Javamap($type)
		}
		catch {puts $out_fd "public $data(actual) $var;"}
		if {$type == "radiobutton"} {
			set group default_group
			catch {set group $data(configure,variable)}
			if {![info exists CB_Groups($group)]} {
				set CB_Groups($group) 1
				puts $out_fd "public CheckboxGroup $group = new CheckboxGroup();"
				append widget_names \"$group\",
			}
		}
		append widget_names \"$var\",
		set name_map($var) $name
	}

	# make lists of widget pointers and names available to apps

	puts $out_fd "\n//methods to support form introspection"
	puts $out_fd "public static String names\[] = \{\n\t$widget_names\n\};"
	puts $out_fd "public String\[] getNames() \{\n\treturn names;\n\}"

	regsub -all {"} $widget_names {} widget_names
	regsub {,$} $widget_names {} widget_names
	set list [split $widget_names ,]
	puts $out_fd "\n//There should be an easier way to do this"
	puts $out_fd "public Object\[] getWidgets() \{\n\tObject\[] list = new Object\[[llength $list]];"
	set count -1
	foreach i $list {
		puts $out_fd "\tlist\[[incr count]] = $i;"
	}
	puts $out_fd "\treturn list;\n\}"

	# pass through application specific behvior

	if {[info exists P(export)]} {
		puts $out_fd "\n// Application specific widget data"
		foreach export $P(export) {
			puts $out_fd "private static String ${export}_private\[] = \{"
			set value ""
			foreach name $list {
				catch {upvar #0 __X_$name_map($name) data}
				if {![info exists data]} {
					append value "null, "
				} elseif {[info exists data(other,$export)]} {
					append value "\"$data(other,$export)\", "
				} else {
					append value "null, "
				}
			}
			puts $out_fd "\t$value\n\};"
			puts $out_fd "public String\[] ${export}() \{"
			puts $out_fd "\treturn ${export}_private;"
			puts $out_fd "\}\n"
		}
	}
	# More boilerplate
	puts $out_fd "\npublic void init() \{"

	# Now code to create the widgets
	set count -1
	foreach name $names {
		upvar #0 __X_$name data

		if {$name == "f" } {
			puts $out_fd "\n\t// main panel"
			puts $out_fd "	GridBagLayout grid = new GridBagLayout();"
			out_constraints f {} $out_fd
			continue
		}

		# Type is the widget type (not converted to Java)
		set type $data(other,type)
		if {![info exists Javamap($type)]} {
			puts stderr "No mapping for widget $data(other,type)"
			continue
		}

		# Var is the user variable name
		set var $data(other,item_name)

		if {[info exists data(other,min_row)]} {
			puts $out_fd "\n\t// container $var in [Jreal_master $name]"
			puts $out_fd "	GridBagLayout ${var}_grid = new GridBagLayout();"
			out_constraints $name ${var}_ $out_fd
		}

		# Generate special case initialization code.
		puts $out_fd ""
		if {$type == "entry"} {
			set width 20
			catch {set width $data(configure,width)}
			puts $out_fd "\t$var = new TextField($width);"
		} elseif {$type == "scrollbar"} {
			set orient VERTICAL
			catch {
				if {[string match "h*" $data(configure,orient)]} {
					set orient HORIZONTAL
				}
			}
			puts $out_fd "\t$var = new Scrollbar(Scrollbar.$orient);"
		} elseif {$type == "text"} {
			set rows 5; set cols 20
			catch {set rows $data(configure,height)}
			catch {set cols $data(configure,width)}
			puts $out_fd "\t$var = new TextArea($rows,$cols);"
		} elseif {$type == "listbox"} {
			set rows 4; set multi false
			catch {set rows $data(configure,height)}
			catch {set multi [expr { \
					$data(configure,selectmode) == "multiple" ? "true" : "false"}]}
			if {$rows == 0} {set rows 4}
			puts $out_fd "\t$var = new List($rows,$multi);"
		} elseif {$type == "menubutton" && $data(other,items) != ""} {
			puts $out_fd "\t$var = new $data(actual)();"
			foreach i [split $data(other,items) ,] {
				puts $out_fd "\t$var.addItem(\"$i\");"
			}
		} else {
			puts $out_fd "\t$var = new $data(actual)();"
		}

		# do any sub-class initialization
		if {$data(call) != ""} {
			puts $out_fd "\t$var.$data(call);	// $data(actual) initialization"
		}

		# Set all specified "configure" options:
		set options [lsort [array names data configure,*]]
		append options  " " [lsort [array names data other,*]]
		set font ""
		foreach option $options {
			regsub configure, $option {} param
			regsub other, $param {} param
			set value $data($option)
			if {[info exists Javamap($type.$param)]} {
				set result [subst $Javamap($type.$param)]
				if {$result != {}} {
					puts $out_fd "\t$result"
				}
			} elseif {[info exists Javamap(*.$param)]} {
				set result [subst $Javamap(*.$param)]
				if {$result != {}} {
					puts $out_fd "\t$result"
				}
			}
			# puts "+++ ($option) $type.$param ($value) <$m1> <$m2>"
		}
		puts $out_fd "	[Jreal_master $name]add($var);"
		# puts $out_fd "\twidgets\[[incr count]] = $var;\n"
                if {[info exists P(java_include_comments)] && $P(java_include_comments) != 0} {
                    puts $out_fd "\t$data(other,comments)"
                } 
	}

	# Create the geometry management commands:
	puts $out_fd "\n\t// Geometry management"
	puts $out_fd "	GridBagConstraints con = new GridBagConstraints();"
	foreach name $names {
		upvar #0 __X_$name data
		if {$name == "f" } continue

		set type $data(other,type)
		set var $data(other,item_name)
		puts  $out_fd "\treset(con);"
		puts  $out_fd "\tcon.gridx = $data(geometry,column);"
		puts  $out_fd "\tcon.gridy = $data(geometry,row);"
		catch {puts  $out_fd "\tcon.ipadx = $data(geometry,ipadx);"}
		catch {puts  $out_fd "\tcon.ipady = $data(geometry,ipady);"}
		catch {puts $out_fd "\tcon.gridwidth = $data(geometry,columnspan);"}
		catch {puts $out_fd "\tcon.gridheight = $data(geometry,rowspan);"}
		
		set t 0; set l 0
		catch {set t $data(geometry,pady)}
		catch {set l $data(geometry,padx)}
		if {$t || $l} {
			puts $out_fd "\tcon.insets = new Insets($t, $l, $t, $l);"
		}
		puts  $out_fd "\tcon.anchor = GridBagConstraints.$Javaanchormap(sticky:$data(geometry,sticky));"
		puts  $out_fd "\tcon.fill = GridBagConstraints.$Javafillmap(sticky:$data(geometry,sticky));"

		# FIX THIS
		puts  $out_fd "\t[Jreal_master2 $name]grid.setConstraints($var, con);"
		puts  $out_fd ""
	}

	# Now for the resize behavior.  This is only run for geometry masters.
	puts $out_fd "\n\t// Resize behavior management and parent heirarchy"
	foreach name [array names Masters] {
		upvar #0 __X_$name data

		if {$name == "f" } {set uname ""; set vname ""} else {
		    set uname $data(other,item_name).
		    set vname $data(other,item_name)_
		}
		puts $out_fd "	${uname}setLayout(${vname}grid);"
	}
	puts $out_fd "\n\t// Give the application a chance to do its initialization"
        set init ""
	catch {set init $P(init)}
	puts $out_fd "\t$init\n\}\n"

	# write the handle event procedure

	puts $out_fd "public boolean handleEvent(Event event) \{"
	foreach name $names {
		upvar #0 __X_$name data
		if {[info exists data(other,action)]} {
			if {$data(other,action) != ""} {
				puts $out_fd "\tif (event.target == $data(other,item_name) && event.id == event.ACTION_EVENT) \{"
				if {[info proc action_override] != {}} {
					puts $out_fd [action_override __X_$name $data(other,action)]
				} else {
					puts $out_fd "\t\t$data(other,action)"
				}
				puts $out_fd "\t\} else"
			}
		}
	}

	# temporary escape to quit app.
	puts $out_fd "\tif (event.id==event.KEY_ACTION && event.key==event.F4 && event.modifiers==event.ALT_MASK) \{  // Alt-F4 always exits"
	puts $out_fd "\t\tSystem.exit(3);"
	puts $out_fd "\t\} else"

	# call parent's event handler
	puts $out_fd "\t\treturn super.handleEvent(event);\n\treturn true;"
	puts $out_fd "\}"

	# read in other methods from an external file

	if {[file readable $prefix.include.java]} {
		set fd [open "$prefix.include.java" r]
		set code [read $fd]
		close $fd
		puts $out_fd "\n// code sourced from $prefix.include.java"
		puts $out_fd $code
	}

	# Put out final boilerplate to end the "init" function
	# and the class:

	puts $out_fd [format $Boiler $prefix]
	puts $out_fd \}

	# Close any opened file.
	if {$out_fd != "stdout"} {
		close $out_fd
	}


	############################################################
	# Write <project_name>Data.java
	############################################################

	# Cleanup global data!!
	foreach i [info globals __X_*] {
		global $i
		unset $i
	}
}


############################################################################
# Utility functions
############################################################################

# Convert SpecTcl to Java fonts

proc jfont {value} {
	set font [split $value ,]
	set family [lindex $font) 0]
	set size [lindex $font 1]
	set style "Font.PLAIN "
	foreach i [lrange $font 2 end] {
		append style "+ Font.[string toupper $i] "
	}
	return "new Font(\"$family\",$style, $size)"
}

# convert colors

proc jcolor {value} {
	regsub -all " " "[winfo rgb . $value] " "/256 " new
	return "new Color([join $new ,])"
}

# figure out the resize behavior

proc get_resize {list} {
	set index 0
	set result ""
	foreach i $list {
		if {[lindex "x $list" [incr index]] > 1} {
			lappend result $index
		}
	}
	return $result
}

# Sort the widgets to generate the proper stacking order
# * Create all the frames first.  Make sure all outer frames are 
#   created before the inner ones
# * Create all widgets in the specified tabbing order.  If the tab order is the
#   same, then use row/col order based on the coordinates of the containing
#   table cell

# This version depends upon the running state of SpecTcl, and needs to be
# re-written to permit the compiler to be invoked as a separate app

proc frames_first {name1 name2} {
	upvar #0 __X_$name1 data1 __X_$name2 data2
	dputs "compare $name1 $name2"

	# both frames
	if {$data1(other,type) == "frame" && $data2(other,type) == "frame"} {
		dputs "  frames: $data2(other,level) - $data1(other,level)"
		return [expr $data1(other,level) - $data2(other,level)]
	}

	# 1 frame, 1 widget
	if {$data1(other,type) == "frame"} {
		return -1
	} elseif {$data2(other,type) == "frame"} {
		return 1
	}

	# sort by explicit tabbing order field
	if {[set result [string compare $data1(other,tabbing) $data2(other,tabbing)]] != 0} {
		dputs "  order $result"
		return $result
	}

	# compute order based on cell coords

	set c1 [list $data1(geometry,row) $data1(geometry,column)]
	set c2 [list $data2(geometry,row) $data2(geometry,column)]

	foreach index {0 1} {
		set diff [expr [lindex $c1 $index] - [lindex $c2 $index]]
		dputs "  diff ($index) -> $diff"
		if {$diff != 0} {return $diff}
	}
	dputs "   equal??"
	return 0
}


# find the real master of this window, as the user may have changed its name.

proc Jreal_master {name} {
	upvar #0 __X_$name data
	
	if {$name == "f" } {return "this."}
	
	set master [string trimleft $data(other,master) .]
	if {$master == ""} {return "this."}
	if {$master == "f"} {return "this."}
	
	# the name of the master may have been changed!
	upvar #0 __X_$master m
	return $m(other,item_name).
}

proc Jreal_master2 {name} {
	upvar #0 __X_$name data
	
	if {$name == "f" } {return ""}
	
	set master [string trimleft $data(other,master) .]
	if {$master == ""} {return ""}
	if {$master == "f"} {return ""}
	
	# the name of the master may have been changed!
	upvar #0 __X_$master m
	return $m(other,item_name)_
}

proc Jopen_out {out} {
	if {$out == ""} {
	    return stdout
	} elseif {[catch {open "$out" w} out_fd]} {
	    tk_dialog .save "save error" $out_fd error 0 OK
	    return ""
	} else {
	    return $out_fd
	}
}	

proc out_constraints {frame prefix fd} {
		upvar #0 __X_$frame data

		puts -nonewline $fd "\tint ${prefix}rowHeights\[] = \{"
		puts $fd "0,[join $data(other,min_row) ,]\};"

		puts -nonewline $fd "\tint ${prefix}columnWidths\[] = \{"
		puts $fd "0,[join $data(other,min_column) ,]\};"

		foreach i {row column} {
			set weight $data(other,resize_$i)
			regsub -all {[01]} $weight 0.0 weight
			regsub -all {[23]} $weight 1.0 weight
			puts -nonewline $fd "\tdouble ${prefix}${i}Weights\[] = \{"
			puts $fd "0.0,[join $weight ,]\};"
		}

        puts $fd "\t${prefix}grid.rowHeights = ${prefix}rowHeights;"
        puts $fd "\t${prefix}grid.columnWidths = ${prefix}columnWidths;"
        puts $fd "\t${prefix}grid.rowWeights = ${prefix}rowWeights;"
        puts $fd "\t${prefix}grid.columnWeights = ${prefix}columnWeights;"
}

proc choice_text {var value} {
	if {$value == ""} {
		return {}
	} else {
		return $var.addItem("$value")\;
	}
}

proc do_editable {var value} {
    switch -- $value {
	0     -
	false -
	no {
	    return $var.setEditable(false)\;
	}
	default {
	    return {}
	}
    }
}
