#!/usr/local/bin/wish -f

# Graphical state machine editor

# Stephen Edwards
# sedwards@eecs.berkeley.edu

# Change log:

# 950323: Added "Resize State Bubbles" menu command and amended the file format
#	  to allow this information to be loaded/saved
#	  Made all states white; reset states' outlines thicker
#
# 950304: Made file load/save more robust
#	Spaces in state names, transition labels, converted to underscores
#	on write, vice-versa on read
#
#	transition labels without slashes are treated as label/- during write
#	reversed on read

# 940721: Added more elaborate file selector dialog
#	Improved monochrome screen support
#

# Global variables:

# itemtype(id) itemdata(id) - type of the object with the given ID
#   stcirc statetag		State circle
#   sttext statetag		State text label
#   trarc transtag		Transition arc
#   trtext transtag		Transition label
#   trselfarc transtag		Transition arc for a self-loop
#   ftext -			Floating Text

# State-related information
#
# slabelid(statetag) - ID of state label
# scircid(statetag) - ID of state shape
#
# slabel(statetag) - State labels
# sx(statetag) sy(statetag) - State coordinates
# stranstag(statetag) - List of transitions (tags) connected to each state

# Transition-related information
#
# tlabelid(transtag) - ID of transition label
# tarcid(transtag) - ID of transition arc
#
# tlabel(transtag) - Transition labels
# tss(transtag) tes(transtag) - Starting state tags/ending state tags
# tp(transtag) - Fraction of bend in transition arc

# transnum - counter for transition IDs
# statenum - counter for state IDs

set stateradius 30		;# Radius of state circles
set statesep 50			;# Distance between states when read
set stateoutline black		;# color of outline
set statefill white		;# fill color
set statehighlight red		;# color when state selected
set statetext black		;# color of text
set resetstatefill white	;# color of the reset state
set stateoutlinewidth 1		;# width of state outlines
set resetstateoutlinewidth 2	;# width of the reset state's outline

set selfloopspace 0.75		;# radians between ends of a self-loop
set selflooprad 60		;# radius of outermost self-loop

set transitionfill black	;# fill color
set transitionhighlight red	;# color when selected

set selectedbuttonbackground red ;# color when button is selected
set selectedbuttonactivebackground pink ;# color when button is selected & active

set texthighlight red		;# color when text is selected
set textnormal black		;# normal fill color

# Character values for the various cursors in the cursor font
# taken from "...include/X11/cursorfont.h"
set XC_top_left_arrow "\204"
set XC_circle "\030"
set XC_exchange "\062"
#set XC_pirate "\130"

wm title . "States"
wm minsize . 100 100

frame .frame -relief raised -bd 2
set c .frame.c
canvas $c -scrollregion {0 0 1024 1024} \
    -xscroll ".frame.xscroll set" -yscroll ".frame.yscroll set" \
    -closeenough 5
scrollbar .frame.xscroll -orient horiz -relief sunken -command "$c xview"
scrollbar .frame.yscroll -orient vert  -relief sunken -command "$c yview"

frame .frame.modes
button .frame.modes.arrow -text $XC_top_left_arrow -font "cursor" \
    -bd 3 -command "modeArrow"
button .frame.modes.newstate -text $XC_circle -font "cursor" \
    -bd 3 -command "modeNewstate"
button .frame.modes.newtrans -text $XC_exchange -font "cursor" \
    -bd 3 -command "modeNewtrans"
button .frame.modes.text -text "A" \
    -bd 3 -font "-*-times-bold-r-normal-*-*-180-*-*-*-*-*-*" \
    -command "modeText"
set defaultbuttonbackground \
    [lindex [.frame.modes.arrow config -background] 4]
set defaultbuttonactivebackground \
    [lindex [.frame.modes.arrow config -activebackground] 4]
#button .frame.modes.delete -text $XC_pirate -font "cursor" \
#    -command "modeDelete"

frame .frame.modes.spaceholder
pack .frame.modes.arrow .frame.modes.newstate .frame.modes.newtrans \
    .frame.modes.text \
    -fill x -side top
#    .frame.modes.delete -side top
pack .frame.modes.spaceholder -side bottom -fill y

pack .frame.yscroll -side right -fill y
pack .frame.xscroll -side bottom -fill x
pack .frame.modes -side left -fill y
pack $c -expand yes -fill both -side left

frame .menu -relief raised -borderwidth 3

set m .menu.file.m
menubutton .menu.file -text "File" -menu $m
pack .menu.file -side left
menu $m
$m add command -label "Load KISS..." -accelerator "C-l" \
    -command "menuLoadKiss"
bind . <Control-Key-l> "menuLoadKiss"
bind $c <Control-Key-l> "menuLoadKiss"
$m add command -label "Save KISS..." -accelerator "C-s" \
    -command "menuSaveKiss"
bind . <Control-Key-s> "menuSaveKiss"
bind $c <Control-Key-s> "menuSaveKiss"
$m add sep
$m add command -label "Create PostScript" -command "menuPrintPS"
$m add sep
$m add command -label "Quit" -accelerator "C-q" \
    -command "menuQuit"
bind $c <Control-Key-q> "menuQuit"
bind . <Control-Key-q> "menuQuit"

set m .menu.edit.m
menubutton .menu.edit -text "Edit" -menu $m
pack .menu.edit -side left
menu $m
$m add command -label "Delete" -accelerator "Del" \
    -command "delSelected $c"
$m add sep
$m add command -label "Straighten" \
    -command "straightenSelected $c"
$m add command -label "Set Reset State" \
    -command "setReset $c"
$m add sep
$m add command -label "Resize State Bubbles" -command menuResizeStates

set m .menu.help.m
menubutton .menu.help -text "Help" -menu $m
pack .menu.help -side right
menu $m
$m add command -label "About..." -command "menuAbout .about"
$m add command -label "On Editing" -command "menuHelpEdit .helpedit"
$m add command -label "File Formats" -command "menuHelpFile .helpfile"

label .menu.filebeingedited -relief ridge -textvariable fileBeingEdited
pack .menu.filebeingedited -side top

pack .menu -side top -fill x
pack .frame -side bottom -fill both -expand yes

proc menuLoadKiss {} {
    global fileBeingEdited
    set filename [getFilename .modal "Load KISS" "Load the KISS file" \
		      $fileBeingEdited]
    if { $filename != "" } {
	loadKissFile $filename
	set fileBeingEdited $filename
    }
}

proc menuSaveKiss {} {
    global fileBeingEdited
    set filename [getFilename .modal "Save Kiss" "Save the KISS file" \
		     $fileBeingEdited]
    if { $filename != "" } {
	writeKissFile $filename
	set fileBeingEdited $filename
    }
}

proc menuPrintPS {} {
    global c
    global fileBeingEdited
    regsub {[.][^.]*$} $fileBeingEdited ".ps" filename
    set filename [getFilename .modal "Create PS" "Create the PostScript file" \
		      $filename
		 ]
    if { $filename != "" } {
	$c postscript -file $filename
    }
}

proc menuQuit {} {
    destroy .
}

proc menuResizeStates {} {

    toplevel .rs -class Dialog
    wm title .rs "Resize State Bubbles"
    wm iconname .rs "Resize State Bubbles"

    label .rs.l -text "State Bubble Radius:"
    entry .rs.e -textvariable stateradius -relief sunken -bd 2
    bind .rs.e <Return> "placeStates ; placeTransitions"
    button .rs.b -text "OK" -command "placeStates ; placeTransitions ; destroy .rs"

    pack .rs.l -side top -pady 3
    pack .rs.e -side top -pady 3
    pack .rs.b -side bottom -padx 3 -pady 3 -ipadx 3 -ipady 3

    focus .rs.e

    tkwait visibility .rs
    grab .rs
    tkwait window .rs

    focus .
}

# getFilename - Allows the user to enter a filename
# 
# w - name of window to create
# title - title of that window
# text - prompt for filename

proc getFilename {w title text fname} {

    global filename
    global filewindow
    set filewindow $w
    set filename $fname

    trace variable filename w filenameChanged

    toplevel $w -class Dialog
    wm title $w $title
    wm iconname $w $title
    wm minsize $w 10 10

    label $w.text -text $text

    pack $w.text -side top -pady 2

    entry $w.filename -relief sunken -textvariable filename
    pack $w.filename -side bottom -fill x -padx 2 -pady 2

    frame $w.buttons
    pack $w.buttons -side right

    button $w.buttons.open -text "Open" -command "FSOpen"
    button $w.buttons.cancel -text "Cancel" \
	-command "set filename {} ; destroy $w"
    button $w.buttons.rescan -text "Rescan" \
	-command "FSRescanDir $w.filelist.files $w.filelist.updirs"

    pack $w.buttons.open $w.buttons.cancel $w.buttons.rescan \
	-side top -fill x -pady 10 -padx 3

    frame $w.filelist -bd 20
    pack $w.filelist -expand yes -fill both

    set m $w.filelist.updirs
    menubutton $m  -text "." -menu $m.m -relief raised
    menu $m.m
    $m.m add command -label "fred"

    pack $m -side top

    scrollbar $w.filelist.yscroll -command "$w.filelist.files yview" \
	-relief raised -bd 2
    pack $w.filelist.yscroll -side right -fill y
    listbox $w.filelist.files -yscroll "$w.filelist.yscroll set" \
	-relief raised -setgrid yes -exportselection no
    pack $w.filelist.files -side left -fill both -expand yes

    bind $w.filelist.files <Button-1> "FSButton1 %W %y"
    bind $w.filelist.files <B1-Motion> "FSButton1 %W %y"
    bind $w.filelist.files <Shift-1> "FSButton1 %W %y"
    bind $w.filelist.files <Shift-B1-Motion> "FSButton1 %W %y"
    bind $w.filelist.files <Double-1> "FSOpen"

    bind $w.filename <KeyPress-Return> "FSOpen"
    bind $w.filename <KeyPress>/ {FSOpen ; set filename ""}
    bind $w.filename <KeyPress-Tab> "FStab $w.filelist.files"

    FSRescanDir $w.filelist.files $w.filelist.updirs

    tkwait visibility $w
    grab $w
    tkwait window $w

    trace vdelete filename w filenameChanged
    focus .
    return $filename
}

proc FStab {l} {
    global filename
    set index [$l curselection]
    if { $index != "" } {
	set filename [$l get $index]
    }
}

proc FSButton1 {w y} {
    set index [$w nearest $y]
    global filename

    $w select from $index
    regsub {[*=@/]$} [$w get $index] "" newfilename
    set filename $newfilename
}

proc FSRescanDir {l m} {
    $l delete 0 end
    set wd [pwd]
    foreach i [exec ls -AF $wd] {
	$l insert end $i
    }

    $m config -text [format "%s/" [file tail $wd]]
    set wd [file dirname $wd]

    $m.m delete 0 last
    for {} {$wd != "/"} {set wd [file dirname $wd] } {
	$m.m add command -label [format "%s/" [file tail $wd]] \
	    -command [format "cd %s ; FSRescanDir %s %s" $wd $l $m]
    }
    $m.m add command -label "/" -command [format "cd / ; FSRescanDir %s %s" $l $m]
}

proc filenameChanged {name element op} {
    global filewindow
    global filename
    set index 0

    while { [$filewindow.filelist.files get $index] < $filename } {
	incr index
	if { $index > [$filewindow.filelist.files size] } {
	    break
	}
    }

    $filewindow.filelist.files select from $index

    set scrollinfo [$filewindow.filelist.yscroll get]
    set firstUnit [lindex $scrollinfo 2]
    set lastUnit [lindex $scrollinfo 3]

    if { $index < $firstUnit || $index > $lastUnit } {
	set firstUnit [expr $index - ($lastUnit - $firstUnit)/2]
	if {$firstUnit < 0} {
	    $filewindow.filelist.files yview 0
	} else {
	    $filewindow.filelist.files yview $firstUnit
	}
    }
}

proc FSOpen {} {
    global filename
    global filewindow

    set realfilename [lindex [glob -nocomplain $filename] 0]
    if { $realfilename != "" } {
	while { [ file type $realfilename] == "link" } {
	    set realfilename [file readlink $realfilename]
	}
	if { [ file isdirectory $realfilename ] } {
	    cd $realfilename
	    FSRescanDir $filewindow.filelist.files $filewindow.filelist.updirs
	    set filename ""
	}
    }

    if { $filename != "" } {
	destroy $filewindow
    }

}


# safeUnset - Like "unset," but checks to see if the variable (or array)
#		exists before attempting to delete it.

proc safeUnset args {
    foreach var $args {
	upvar $var v
	if { [info exists v] } { unset v }
    }
}

# fpIncr - Like "incr," but allows for floating-point increments

proc fpIncr {var {increment 1}} {
    upvar $var v
    set v [expr $v + $increment]
}

# splitIO - takes a string of the form a/b and puts
# "a" into variable i, "b" into variable o

proc splitIO {string i o} {
    upvar $i input
    upvar $o output

    set slash [string first / $string]
    if {$slash == -1} {
	set input $string
	set output "-"
    } else {
	set input [string range $string 0 [expr $slash - 1] ]
	set output [string range $string [expr $slash + 1] end ]
    }
}

# loadKissFile - Loads the KISS file with the given filename, arranging them
# if necessary

proc loadKissFile {filename} {
    global slabel sx sy
    global tlabel tss tes tp
    global transnum
    global resetstate
    global slabelid scircid tlabelid tarcid
    global c

    safeUnset slabel sx sy
    safeUnset tlabel tss tes tp

    safeUnset slabelid scircid tlabelid tarcid

    $c delete all

    set transnum 1		;# Start at the first transition
    set resetstate ""

    set hasnographicdata 1	;# assume no graphic data was provided

    set f [open $filename r]
    while { [ gets $f line ] >= 0 } {
	set firstchar [string index $line 0]
	set secondchar [string index $line 1]

	# A comment line of the form:
	#$ statetag sx sy
	# contains state-related graphical data

	if { $firstchar == "\#" && $secondchar == "$" } {
	    scan $line "\#$ %s %f %f" st stx sty
	    regsub -all "_" $st " " st
	    set sx($st) $stx
	    set sy($st) $sty
	    set hasnographicdata 0
	}

	# A comment line of the form following a transition: 
	#~ tp
	# contains transition-related graphical data

	if { $firstchar == "\#" && $secondchar == "~" } {
	    scan $line "\#~ %f" p
	    set tp($transtag) $p
	    set hasnographicdata 0
	}

	# A comment line of the form
	#& x y text
	# describes floating text

	if { $firstchar == "\#" && $secondchar == "&" } {
	    scan $line "\#& %f %f" x y
	    regsub "\#& \[^ ]* \[^ ]* " $line "" t
	    createFloatText $x $y $t
	}

	# A comment line of the form
	#p variable value
	# describes the value of some variable

	if { $firstchar == "\#" && $secondchar == "p" } {
	    scan $line "\#p %s %s" var val
	    global $var
	    set $var $val
	}

	# the reset state:
	# .r statelabel

	if { $firstchar == "." && $secondchar == "r" } {
	    scan $line ".r %s" resetstate
	}

	# non-comment lines

	if { $firstchar != "\#" && $firstchar != "." &&
	     [string length $line] > 0 } {

	    scan $line "%s %s %s %s" input fromstate tostate output
	    regsub -all "_" $input " " input
	    regsub -all "_" $fromstate " " fromstate
	    regsub -all "_" $tostate " " tostate
	    regsub -all "_" $output " " output

	    if { $resetstate == "" } {
		set resetstate $fromstate
	    }

	    if { ![info exists slabel($fromstate)] } {
		set slabel($fromstate) $fromstate
	    }

	    if { ![info exists slabel($tostate)] } {
		set slabel($tostate) $tostate
	    }

	    set transtag [format "T%d" $transnum]
	    incr transnum
	    set tss($transtag) $fromstate
	    set tes($transtag) $tostate
	    if {$output != "-"} {
		set tlabel($transtag) [format "%s/%s" $input $output]
	    } else {
		set tlabel($transtag) $input
	    }

	}
	
    }
    close $f

    createStates
    createTransitions

    if { $hasnographicdata } {
	arrangeMachine
    }

    placeStates
    placeTransitions
}

# writeKissFile - Writes the current machine to the file with the given name

proc writeKissFile {filename} {
    global slabel sx sy
    global tlabel tss tes tp
    global resetstate
    global stateradius
    global c

    set numstates [array size slabel]
    set numtrans [array size tlabel]
    
    set inputs 0
    set outputs 0

    foreach tl [array names tlabel] {
	splitIO $tlabel($tl) input output
	if { [string length $input] > $inputs } {
	    set inputs [string length $input]
	}
	if { [string length $output] > $outputs } {
	    set outputs [string length $output]
	}
    }

    set f [ open $filename w ]

    puts $f "\# KISS file written by states"
    puts $f [ format ".i %d" $inputs ]
    puts $f [ format ".o %d" $outputs ]
    puts $f [ format ".s %d" $numstates ]
    puts $f [ format ".p %d" $numtrans ]
    puts $f [ format ".r %s" $resetstate ]

    puts $f "\# Transition data"

    foreach tl [array names tlabel] {
	splitIO $tlabel($tl) input output
	regsub -all " " $input "_" input
	regsub -all " " $output "_" output
	set fromstate $slabel($tss($tl))
	regsub -all " " $fromstate "_" fromstate
	set tostate $slabel($tes($tl))     
	regsub -all " " $tostate "_" tostate  
	puts $f [ format "%s %s %s %s" $input $fromstate $tostate $output ]
	puts $f [ format "\#~ %f" $tp($tl) ]
    }

    puts $f "\# State graphic data"

    foreach sl [array names slabel] {
	set state $slabel($sl)
	regsub -all " " $state "_" state  
	puts $f [ format "\#$ %s %f %f" $state $sx($sl) $sy($sl) ]
    }

    puts $f "\# Floating text"

    foreach id [$c find withtag ftext] {
	set coords [$c coords $id]
	puts $f [ format "\#& %f %f %s" [lindex $coords 0] [lindex $coords 1] \
		      [lindex [$c itemconfigure $id -text] 4] ]
    }

    puts $f "\# Other parameters"
    puts $f "\#p stateradius $stateradius"

    puts $f ".e"

    close $f

}

# Create all the canvas objects for the list of states

proc createStates {} {
    global slabel
    global slabelid scircid

    foreach st [array names slabel] {
	createState $st
    }

}

proc createState {statetag} {
    global c stateoutline statefill statetext resetstatefill
    global stateoutlinewidth resetstateoutlinewidth
    global slabel stranstag
    global itemtype itemdata
    global slabelid scircid
    global resetstate

    if { $statetag == $resetstate } {
	set id \
	    [ $c create oval 0 0 10 10 -outline $stateoutline \
		  -fill $resetstatefill -width $resetstateoutlinewidth]
    } else {
	set id \
	    [ $c create oval 0 0 10 10 -outline $stateoutline \
		  -fill $statefill -width $stateoutlinewidth]
    }
    set itemtype($id) stcirc
    set itemdata($id) $statetag
    set scircid($statetag) $id

    set id \
	[ $c create text 5 5 -text $slabel($statetag) \
	      -anchor center -fill $statetext ]
    set itemtype($id) sttext
    set itemdata($id) $statetag
    set slabelid($statetag) $id

    set stranstag($statetag) ""
}

# Create all the canvas objects for the transitions

proc createTransitions {} {
    global tlabel

    foreach tt [array names tlabel] {
	createTransition $tt
    }

}

proc createTransition {transtag} {
    global tlabel
    global stranstag
    global c transitionfill
    global itemtype itemdata
    global tss tes
    global tarcid tlabelid

    # add this transition to its starting state
    lappend stranstag($tss($transtag)) $transtag

    if { $tss($transtag) == $tes($transtag) } {
	set itemt trselfarc
    } else {
	set itemt trarc
	# add this transition to its ending state
	lappend stranstag($tes($transtag)) $transtag
    }

    set id \
	[ $c create line 0 0 5 5 10 10 -arrow last -smooth 1 ]
    set itemtype($id) $itemt
    set itemdata($id) $transtag
    set tarcid($transtag) $id

    set id \
	[ $c create text 5 5 -text $tlabel($transtag) -anchor center ]
    set itemtype($id) trtext
    set itemdata($id) $transtag
    set tlabelid($transtag) $id

}

proc createFloatText {x y st} {
    global c
    global itemtype textnormal

    set id [$c create text $x $y -text $st -anchor center -tags ftext \
	       -fill $textnormal ]

    set itemtype($id) ftext

    return $id
}

# arrangeMachine - arrange the states in the machine in a circle with
# enough space

proc arrangeMachine {} {

    global slabel sx sy
    global tlabel tp tss tes
    global statesep stateradius

    set numstates [array size slabel]

    # set the radius of the circle large enough so that there is a space
    # of approximately $statesep between states

    set radius [ expr $numstates * ($statesep + 2 * $stateradius) / 6.28 ]

    set theta 0
    set thetainc [expr 6.28 / $numstates]

    # arrange the states in a circle

    foreach sl [array names slabel] {
	set sx($sl) [expr int($radius * (1 + cos($theta)) + $stateradius * 3) ]
	set sy($sl) [expr int($radius * (1 + sin($theta)) + $stateradius * 3) ]
	fpIncr theta $thetainc
    }

    # set all the arcs on the transitions

    set pincr 0.07
    set pssincr 0.9

    foreach tl [array names tlabel] {
	set key $tss($tl),$tes($tl)
	if { [info exists p($key)]  } {
	    if { $tss($tl) == $tes($tl) } {
		fpIncr p($key) $pssincr
	    } else {
		fpIncr p($key) $pincr
	    }
	    set tp($tl) $p($key)
	} else {
	    set tp($tl) $pincr
	    set p($key) $pincr
	}
    }

}

# placeStates - Position the state canvas objects

proc placeStates {} {
    global slabel

    foreach sl [array names slabel] {
	placeState $sl
    }
}

proc placeState {statetag} {
    global c
    global sx sy
    global slabelid scircid
    global stateradius
    global resetstate statefill resetstatefill
    global resetstateoutlinewidth stateoutlinewidth
    
    $c coords $slabelid($statetag) $sx($statetag) $sy($statetag)
    $c coords $scircid($statetag) \
	[expr $sx($statetag) - $stateradius] \
	[expr $sy($statetag) - $stateradius] \
	[expr $sx($statetag) + $stateradius] \
	[expr $sy($statetag) + $stateradius]

    if { [tk colormodel .] == "color" } {
	if { $statetag == $resetstate } {
	    $c itemconfig $scircid($statetag) -fill $resetstatefill \
		-width $resetstateoutlinewidth
	} else {
	    $c itemconfig $scircid($statetag) -fill $statefill \
		-width $stateoutlinewidth
	}
    } else {
	if { $statetag == $resetstate } {
	    $c itemconfig $scircid($statetag) -width $resetstateoutlinewidth
	} else {
	    $c itemconfig $scircid($statetag) -width $stateoutlinewidth
	}
	    
    }

}

# placeTransitions - Position all of the transitions

proc placeTransitions {} {
    global tlabel

    foreach tl [array names tlabel] {
	placeTransition $tl
    }
}

proc placeTransition {transtag} {
    global c
    global sx sy
    global tss tes tp
    global stateradius selflooprad selfloopspace
    global tarcid tlabelid

    set sx1 $sx($tss($transtag)) ; set sy1 $sy($tss($transtag))
    set sx2 $sx($tes($transtag)) ; set sy2 $sy($tes($transtag))

    set p $tp($transtag)

    if { $tss($transtag) == $tes($transtag) } {

	# a self-loop

	set x1 [expr $sx1 + sin($p) * $stateradius]
	set y1 [expr $sy1 - cos($p) * $stateradius]
	set x2 [expr $sx1 + sin($p) * $selflooprad]
	set y2 [expr $sy1 - cos($p) * $selflooprad]

	set x3 [expr $sx1 + sin($p + $selfloopspace) * $selflooprad]
	set y3 [expr $sy1 - cos($p + $selfloopspace) * $selflooprad]
	set x4 [expr $sx1 + sin($p + $selfloopspace) * $stateradius]
	set y4 [expr $sy1 - cos($p + $selfloopspace) * $stateradius]

	$c coords $tarcid($transtag) $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4
	$c coords $tlabelid($transtag) \
	    [expr ($x2 + $x3)/2] [expr ($y2 + $y3)/2]
	$c itemconfigure $tlabelid($transtag) -anchor \
	    [ anchorPos [expr sin($p + $selfloopspace * 0.5)] \
		  [expr -cos($p + $selfloopspace * 0.5) ] ]

    } else {

	# not a self-loop

	set dx1 [expr ($sy1 - $sy2) * $p]
	set dy1 [expr ($sx2 - $sx1) * $p]
       
	set x2 [expr ($sx1 + $sx2)/2 + $dx1 ]
	set y2 [expr ($sy1 + $sy2)/2 + $dy1 ]

	set dx [expr $x2 - $sx1]
	set dy [expr $y2 - $sy1]
	set size [ expr $stateradius / sqrt($dx * $dx + $dy * $dy) ]

	set x1 [expr $sx1 + $dx * $size]
	set y1 [expr $sy1 + $dy * $size]
	set x3 [expr $sx2 + ($x2 - $sx2) * $size ]
	set y3 [expr $sy2 + ($y2 - $sy2) * $size ]

	# correct for the effect of the Bezier
	# This places the midpoint of the curve at (x2,y2)
	# Tk finds the two control points by taking 2/3rds of the
	# midpoint and adding 1/3 or the starting point
	# and draws a standard Bezier as a piecewise-linear approximation

	set x2a [expr 2*$x2 - 0.5*($x1 + $x3) ]
	set y2a [expr 2*$y2 - 0.5*($y1 + $y3) ]

	$c coords $tarcid($transtag) $x1 $y1 $x2a $y2a $x3 $y3
	$c coords $tlabelid($transtag) $x2 $y2

	if { abs($p) < 0.01 } {
	    set p [expr $p < 0 ? -0.01 : 0.01]
	    set dx1 [expr ($sy1 - $sy2) * $p]
	    set dy1 [expr ($sx2 - $sx1) * $p]
	}

	$c itemconfigure $tlabelid($transtag) -anchor [anchorPos $dx1 $dy1]
    }

}

# anchorPos - Given a direction (dx,dy), return the "right"
# anchor point for it

set anchorfor(110) w
set anchorfor(111) nw
set anchorfor(112) n
set anchorfor(012) n
set anchorfor(011) ne
set anchorfor(010) e
set anchorfor(000) e
set anchorfor(001) se
set anchorfor(002) s
set anchorfor(102) s
set anchorfor(101) sw
set anchorfor(100) w

proc anchorPos {dx dy} {
    global anchorfor
    if { $dx == 0 } { set dx 0.0001 }
    if { $dy == 0 } { set dy 0.0001 }

    set slope [expr abs($dy / $dx)]

    set direction [ format "%d%d%d" \
			[ expr $dx < 0 ? "0" : "1" ] \
			[ expr $dy < 0 ? "0" : "1" ] \
			[ expr $slope < 0.5 ? "0" : ($slope > 2) ? "2" : "1" ]
		   ]

    return $anchorfor($direction)

}

# unselectAll - unselects every selected item

proc unselectAll {} {
    global c
    global textfocus
    global itemtype itemdata resetstate
    global statefill resetstatefill transitionfill
    global tlabelid

    foreach id [$c find withtag selected] {
	if { [info exists itemtype($id) ] } {
	    unselectItem $id
	}
    }

    if { [info exists itemtype($textfocus)] } {
	if { $itemtype($textfocus) == "ftext" } {
	    if { [lindex [$c itemconfigure $textfocus -text] 4] == "" } {
		delId $c $textfocus
	    }
	}
    }

    $c focus ""
    $c select clear
    set textfocus 0

#    $c dtag all selected
}

proc unselectItem {id} {
    global c
    global itemtype itemdata resetstate
    global statefill resetstatefill transitionfill
    global tlabelid slabelid
    global textnormal

    if { [tk colormodel .] == "color" } {

	switch $itemtype($id) {

	    stcirc {
		if { $itemdata($id) == $resetstate } {
		    $c itemconfigure $id -fill $resetstatefill
		} else {
		    $c itemconfigure $id -fill $statefill
		}
		$c dtag $slabelid($itemdata($id))
	    }
	    
	    trarc -
	    trselfarc { $c itemconfigure $id -fill $transitionfill
		$c itemconfigure $tlabelid($itemdata($id)) \
			    -fill $transitionfill
	    }
	    
	    ftext {
		$c itemconfigure $id -fill $textnormal
	    }
	    
	}
    } else {

	switch $itemtype($id) {

	    stcirc {
		if { $itemdata($id) == $resetstate } {
		    $c itemconfig $id -fill white -width 3
		} else {
		    $c itemconfig $id -fill white -width 1
		}
	    }

	    trarc -
	    trselfarc {
		$c itemconfigure $id -width 1
		$c itemconfigure $tlabelid($itemdata($id)) \
		    -stipple ""
	    }
	    
	    ftext {
		$c itemconfigure $id -stipple ""
	    }
	    
	}

    }


    $c dtag $id selected

}

proc selectItem {id} {
    global c
    global itemtype itemdata resetstate
    global statefill resetstatefill transitionfill
    global tlabelid
    global scircid slabelid tlabelid tarcid
    global statehighlight transitionhighlight texthighlight

    if { [tk colormodel .] == "color" } {
	switch $itemtype($id) {

	    stcirc -
	    sttext {
		set stid $scircid($itemdata($id))
		$c addtag selected withtag $stid
		$c addtag selected withtag $slabelid($itemdata($id))
		$c itemconfigure $stid -fill $statehighlight
	    }

	    trarc -
	    trselfarc -
	    trtext {
		set tid $tarcid($itemdata($id))
		$c addtag selected withtag $tid
		$c addtag selected withtag $tlabelid($itemdata($id))
		$c itemconfigure $tid -fill $transitionhighlight
		$c itemconfigure $tlabelid($itemdata($id)) \
		    -fill $transitionhighlight
	    }

	    ftext {
		$c addtag selected withtag $id
		$c itemconfigure $id -fill $texthighlight
	    }

	}

    } else {
	switch $itemtype($id) {

	    stcirc -
	    sttext {
		set stid $scircid($itemdata($id))
		$c addtag selected withtag $stid
		$c addtag selected withtag $slabelid($itemdata($id))
		$c itemconfigure $stid -stipple gray50 -fill black
	    }

	    trarc -
	    trselfarc -
	    trtext {
		set tid $tarcid($itemdata($id))
		$c addtag selected withtag $tid
		$c addtag selected withtag $tlabelid($itemdata($id))
		$c itemconfigure $tid -width 2
		$c itemconfigure $tlabelid($itemdata($id)) \
		    -stipple gray50
	    }

	    ftext {
		$c addtag selected withtag $id
		$c itemconfigure $id -stipple gray50
	    }

	}

    }

}

proc itemSelect {c x y} {

    if { [lsearch -exact [$c gettags current] selected] < 0 } {
	unselectAll
    }
    itemSelectMore $c $x $y 1
}

proc itemSelectMore {c x y {donttoggle 0} } {
    global lastX lastY
    global areaX1 areaY1
    global areaX2 areaY2

    set lastX [$c canvasx $x]
    set lastY [$c canvasy $y]

    set id [$c find withtag current]

    if { $id != "" } {
	selectMoreId $c $id $donttoggle
    } else {
	set areaX1 $lastX
	set areaY1 $lastY
	set areaX2 $lastX
	set areaY2 $lastY
	$c create rect $areaX1 $areaY1 $areaX2 $areaY2 -outline black \
	    -tags selectarea
    }
}

proc selectMoreId {c id donttoggle} {
    global itemtype itemdata

    if { [info exists itemtype($id)] } {
	if { [lsearch -exact [$c gettags $id] selected] >= 0 && \
		 $donttoggle == 0 } {
	    unselectItem $id
	} else {
	    selectItem $id
	}
    }
}

proc Drag {c x y} {
    global lastX lastY
    global areaX1 areaX2 areaY1 areaY2
    global itemtype itemdata
    global tp tss tes
    global stranstag selfloopspace
    global sx sy
    global slabelid

    set dx [expr [$c canvasx $x] - $lastX]
    set dy [expr [$c canvasy $y] - $lastY]
    
    set lastX [$c canvasx $x] ; set lastY [$c canvasy $y]

    if { [lsearch -exact [$c gettags current] selected] >= 0 } {

	foreach id [$c find withtag selected] {
	    if { [info exists itemtype($id)] } {
		switch $itemtype($id) {
		    
		    # state circle - move the circle and adjust all the
		    # attached transitions

		    stcirc {
			$c move $id $dx $dy
			$c move $slabelid($itemdata($id)) $dx $dy
			fpIncr sx($itemdata($id)) $dx
			fpIncr sy($itemdata($id)) $dy

			foreach tid $stranstag($itemdata($id)) {
			    placeTransition $tid
			}

		    }

		    trarc {

			set transtag $itemdata($id)

			# transition arc - project dx/dy along the perpendicular
			# and use this to recalculate p

			# form C, the vector between the states

			set cx [expr $sx($tss($transtag)) - $sx($tes($transtag)) ]
			set cy [expr $sy($tss($transtag)) - $sy($tes($transtag)) ]

			# change p by A.Cperp / C.C

			fpIncr tp($transtag) \
			    [expr (0.0 + $dx * $cy - $dy * $cx) / \
				 ($cx * $cx + $cy * $cy) ]
			
			placeTransition $transtag
		    }

		    trselfarc {
			set transtag $itemdata($id)

			set cx [expr [$c canvasx $x] - $sx($tss($transtag))]
			set cy [expr [$c canvasy $y] - $sy($tss($transtag))]
			set atn [expr atan2($cx,$cy)]
			set tp($transtag) [expr 3.141592653589 - $atn - $selfloopspace / 2 ]
			placeTransition $transtag
		    }

		    ftext {
			$c move $id $dx $dy
		    }

		}
	    }
	}

    }

    set id [$c find withtag selectarea]

    if { $id != "" } {
	set areaX2 $lastX
	set areaY2 $lastY
	$c coords $id $areaX1 $areaY1 $areaX2 $areaY2
    }
    
}

proc arrowB1Release {c x y donttoggle} {
    global areaX1 areaY1 areaX2 areaY2
    global itemtype

    set id [$c find withtag selectarea]

    if { $id != "" } {
	$c delete $id
	foreach sid [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] {
	    if { [info exists itemtype($sid)] } {
		switch $itemtype($sid) {
		    stcirc -
		    ftext {
			selectMoreId $c $sid $donttoggle
		    }
		}
	    }
	}
    }


}

proc delSelected {c} {
    global itemtype
    foreach id [$c find withtag selected] {
	if { [info exists itemtype($id)] } {
	    delId $c $id
	}
    }
}

# Turns selected transitions into straight lines

proc straightenSelected {c} {
    global itemtype itemdata
    global tp
    foreach id [$c find withtag selected] {
	if { [ info exists itemtype($id)] } {
	    switch $itemtype($id) {
		trarc {
		    set tp($itemdata($id)) 0.0
		    placeTransition $itemdata($id)
		}
	    }
	}
    }
}

# Sets the reset state to the last selected state

proc setReset {c} {
    global itemtype itemdata
    global resetstate

    foreach id [$c find withtag selected] {
	if { [ info exists itemtype($id)] } {
	    if { $itemtype($id) == "stcirc" } {
		set oldreset $resetstate
		set resetstate $itemdata($id)
		placeState $oldreset
	    }
	}
    }

    unselectAll

}

proc delId {c id} {
    global itemtype itemdata
    global slabelid scircid slabel sx sy stranstag
    switch $itemtype($id) {
	stcirc {
	    set stag $itemdata($id)
	    foreach transtag $stranstag($stag) {
		delTrans $c $transtag
	    }
	    $c delete $scircid($stag)
	    $c delete $slabelid($stag)
	    unset itemtype($id) itemdata($id)
	    unset itemtype($slabelid($stag)) itemdata($slabelid($stag))
	    unset slabelid($stag) scircid($stag)
	    unset slabel($stag) sx($stag) sy($stag) stranstag($stag)
	}
	trarc -
	trselfarc {
	    delTrans $c $itemdata($id)
	}

	ftext {
	    $c delete $id
	    unset itemtype($id)
	}

    }
}

proc delTrans {c transtag} {
    global tlabel tlabelid tarcid tss tes tp
    global stranstag
    global itemtype itemdata
    if { [info exists tlabel($transtag)] } {
	unset tlabel($transtag)
	set tindex [lsearch -exact $stranstag($tss($transtag)) $transtag]
	set stranstag($tss($transtag)) \
	    [lreplace $stranstag($tss($transtag)) $tindex $tindex]

	if { $tss($transtag) != $tes($transtag) } {
	    set tindex [lsearch -exact $stranstag($tes($transtag)) $transtag]
	    set stranstag($tes($transtag)) \
		[lreplace $stranstag($tes($transtag)) $tindex $tindex]
	}

	unset tss($transtag) tes($transtag) tp($transtag)
	$c delete $tlabelid($transtag) $tarcid($transtag)
	unset itemtype($tlabelid($transtag)) itemtype($tarcid($transtag))
	unset itemdata($tlabelid($transtag)) itemdata($tarcid($transtag))
	unset tlabelid($transtag) tarcid($transtag)
    }
}

proc updateText {c} {
    global textfocus
    global itemtype itemdata
    global slabel tlabel

    set thetext [lindex [$c itemconfigure $textfocus -text] 4]
    switch $itemtype($textfocus) {
	sttext {
	    set slabel($itemdata($textfocus)) $thetext
	}
	trtext {
	    set tlabel($itemdata($textfocus)) $thetext
	}
    }
}

proc textB1 {c x y} {
    global textfocus
    global itemtype itemdata

    unselectAll

    set id [$c find withtag current]

    if { [info exists itemtype($id)] } {
	switch $itemtype($id) {

	    sttext -
	    trtext -
	    ftext {
		$c icursor $id @$x,$y
		$c focus $id
		$c select clear
		$c select from $id @$x,$y
		focus $c
		set textfocus $id		
	    }

	}

    }

}

proc floatTextB1 {c x y} {
    global textfocus

    set id [$c find withtag current]

    if { $id == "" } {
	set id [createFloatText [$c canvasx $x] [$c canvasy $y] ""]
	$c select clear
	$c icursor $id @$x,$y
	$c focus $id
	$c select from $id @$x,$y
	focus $c
	set textfocus $id
    }

}

proc textB1Motion {c x y} {
    global textfocus

    if { $textfocus } {
	$c select to $textfocus @$x,$y
    }

}

proc textKey {c string} {
    global textfocus

    if { $textfocus } {
	if { [$c select item] != "" } {
	    $c dchars $textfocus sel.first sel.last
	}
	$c insert $textfocus insert $string
	$c select from $textfocus insert
	updateText $c
    }
}

proc textDel {c} {
    global textfocus

    if { $textfocus } {
	if { [$c select item] != "" } {
	    $c dchars $textfocus sel.first sel.last
	    $c select clear
	} else {
	    set char [expr [$c index $textfocus insert] - 1 ]
	    if { $char >= 0 } {
		$c dchar $textfocus $char
		$c icursor $textfocus $char
	    }
	}
	$c select from $textfocus insert
	updateText $c
    }
}

proc textBegin {c} {
    global textfocus

    if { $textfocus } {
	$c icursor $textfocus 0
	$c select from $textfocus insert
    }
}

proc textEnd {c} {
    global textfocus

    if { $textfocus } {
	$c icursor $textfocus end
	$c select from $textfocus insert
    }
}

proc textLeft {c {shift 0} } {
    global textfocus

    if { $textfocus } {
	set char [expr [$c index $textfocus insert] - 1 ]
	if { $char >= 0 } {
	    $c icursor $textfocus $char
	    if { $shift } {
		$c select to $textfocus insert
	    } else {
		$c select clear
	    }
	}
    }
}

proc textRight {c {shift 0}} {
    global textfocus

    if { $textfocus } {
	set char [expr [$c index $textfocus insert] + 1 ]
	if { $char <= [$c index $textfocus end] } {
	    $c icursor $textfocus $char
	    if { $shift } {
		$c select to $textfocus insert
	    } else {
		$c select clear
	    }
	}
    }
}

proc textPaste {c} {
    global textfocus

    if { $textfocus } {
	$c insert $textfocus insert [selection get]
	$c select from $textfocus insert
	updateText $c
    }
}

proc newStateB1 {c x y} {

    global sx sy slabel
    global statenum resetstate
    global slabelid
    global textfocus

    if { [$c find withtag current] == "" } {

	set label [format "S%d" $statenum]

	if { $resetstate == "" } {
	    set resetstate $label
	}

	set slabel($label) $label
	set sx($label) [$c canvasx $x]
	set sy($label) [$c canvasy $y]

	createState $label
	placeState $label

	set id $slabelid($label)

	$c icursor $id end
	$c focus $id
	$c select adjust $id 0
	$c select to $id end
	focus $c
	set textfocus $id

	incr statenum
    }

}

proc newTransB1 {c x y} {
    global itemtype itemdata
    global startstate
    global ssx ssy sx sy

    set id [$c find withtag current]

    set startstate ""
    set endstate ""

    if { [info exists itemtype($id)] } {
	switch $itemtype($id) {
	    stcirc -
	    sttext {
		set startstate $itemdata($id)
		set endstate ""
		set ssx $sx($startstate)
		set ssy $sy($startstate)
		$c create line $ssx $ssy [$c canvasx $x] [$c canvasy $y] \
		    -arrow last -tags tinp
	    }

	}
	
    }
}

proc newTransB1Motion {c x y} {
    global ssx ssy startstate endstate resetstate
    global statefill resetstatefill statehighlight
    global scircid itemtype itemdata stateradius
    global slabel sx sy

    set endstate ""

    if { $startstate != "" } {
	set ourx [$c canvasx $x]
	set oury [$c canvasy $y]
	$c coords tinp $ssx $ssy $ourx $oury

#	foreach id [$c find withtag targetstate] {
#	    if { $itemdata($id) != $resetstate } {
#		$c itemconfigure $id -fill $statefill
#	    } else {
#		$c itemconfigure $id -fill $resetstatefill
#	    }
#	}
	
#	$c dtag targetstate
	
	foreach id [$c find closest $ourx $oury 5 tinp] {
	    if { [info exists itemtype($id)] } {
		switch $itemtype($id) {
		    stcirc -
		    sttext {
			set scid $scircid($itemdata($id))
#			$c addtag targetstate withtag $scid
#			$c itemconfigure $scid -fill $statehighlight
			set endstate $itemdata($id)
			if { $startstate == $endstate } {
			    $c coords tinp \
				$ssx $ssy $sx($endstate) $sy($endstate)
			} else {
			    set dx [expr $sx($endstate) - $ssx]
			    set dy [expr $sy($endstate) - $ssy]
			    set size [expr $stateradius / \
					  sqrt($dx * $dx + $dy * $dy) ]
			    $c coords tinp \
				[expr $ssx + $size * $dx] \
				[expr $ssy + $size * $dy] \
				[expr $sx($endstate) - $size * $dx] \
				[expr $sy($endstate) - $size * $dy]
			}
		    }
		}
	    }
	}
    }
    
}

proc newTransB1Release {c x y} {
    global startstate endstate resetstate statefill resetstatefill
    global transnum itemdata
    global textfocus
    global tss tes tlabel tp tlabelid
    global stranstag

    $c delete tinp 
#    foreach id [$c find withtag targetstate] {
#	if { $itemdata($id) != $resetstate } {
#	    $c itemconfigure $id -fill $statefill
#	} else {
#	    $c itemconfigure $id -fill $resetstatefill
#	}
#    }

    if { $startstate != "" && $endstate != "" } {
	set transtag [format "T%d" $transnum]
	set tss($transtag) $startstate
	set tes($transtag) $endstate
	set tlabel($transtag) "-/-"

	set maxp -0.1

	foreach tt $stranstag($startstate) {
	    if { $tes($tt) == $endstate } {
		if { $tp($tt) > $maxp } {
		    set maxp $tp($tt)
		}
	    }
	}

	foreach tt $stranstag($endstate) {
	    if { $tes($tt) == $startstate } {
		if { -$tp($tt) > $maxp } {
		    set maxp -$tp($tt)
		}
	    }
	}

	set tp($transtag) [expr $maxp + 0.1]
	if { $startstate == $endstate } {
	    fpIncr tp($transtag) 0.8
	}

	createTransition $transtag
	placeTransition $transtag

	set id $tlabelid($transtag)

	$c icursor $id end
	$c focus $id
	$c select adjust $id 0
	$c select to $id end
	focus $c
	set textfocus $id

	incr transnum
    }

    set startstate ""
    set endstate ""
}

proc clearBindings {c} {
    bind $c <Button-1> ""
    bind $c <Shift-Button-1> ""
    bind $c <B1-Motion> ""
    bind $c <Shift-B1-Motion> ""
    bind $c <ButtonRelease-1> ""
    bind $c <Shift-ButtonRelease-1> ""
    bind $c <KeyPress> ""
    bind $c <Button-2> ""
}

proc textBindings {c} {
    bind $c <Button-1> "+textB1 $c %x %y"
    bind $c <B1-Motion> "+textB1Motion $c %x %y"
    bind $c <KeyPress> "textKey $c %A"
    bind $c <Control-h> "textDel $c"
    bind $c <Control-a> "textBegin $c"
    bind $c <Control-e> "textEnd $c"
    bind $c <Delete> "textDel $c"
    bind $c <Left> "textLeft $c"
    bind $c <Right> "textRight $c"
    bind $c <Shift-Left> "textLeft $c 1"
    bind $c <Shift-Right> "textRight $c 1"
    bind $c <Meta-Left> "textLeft $c 1"
    bind $c <Meta-Right> "textRight $c 1"
    bind $c <Button-2> "textPaste $c"
}

proc modeArrow {} {
    global c

    clearBindings $c

    bind $c <Button-1> "itemSelect $c %x %y"
    bind $c <Shift-Button-1> "itemSelectMore $c %x %y"
    bind $c <B1-Motion> "Drag $c %x %y"
    bind $c <Shift-B1-Motion> "Drag $c %x %y"
    bind $c <ButtonRelease-1> "arrowB1Release $c %x %y 1"
    bind $c <Shift-ButtonRelease-1> "arrowB1Release $c %x %y 0"

    bind $c <Delete> "+delSelected $c"
    bind $c <Control-h> "+delSelected $c"

    $c config -cursor top_left_arrow
    unselectAll

    setButtons arrow
}

proc modeNewstate {} {
    global c

    clearBindings $c

    textBindings $c
    bind $c <Button-1> "+newStateB1 $c %x %y"

    $c config -cursor circle
    unselectAll

    setButtons newstate
}

proc modeNewtrans {} {
    global c

    clearBindings $c

    textBindings $c

    bind $c <Button-1> "+newTransB1 $c %x %y"
    bind $c <B1-Motion> "newTransB1Motion $c %x %y"
    bind $c <ButtonRelease-1> "newTransB1Release $c %x %y"

    $c config -cursor exchange
    unselectAll

    setButtons newtrans
}

proc modeText {} {
    global c

    clearBindings $c

    textBindings $c

    bind $c <Button-1> "+floatTextB1 $c %x %y"

    $c config -cursor xterm
    unselectAll

    setButtons text

}

proc setButtons {mode} {
    set b .frame.modes

    highlightButton $b.arrow [expr {$mode == "arrow"}]
    highlightButton $b.newstate [expr {$mode == "newstate"}]
    highlightButton $b.newtrans [expr {$mode == "newtrans"}]
    highlightButton $b.text [expr {$mode == "text"}]

}

proc highlightButton {b should} {

    global selectedbuttonbackground
    global selectedbuttonactivebackground
    global defaultbuttonbackground
    global defaultbuttonactivebackground

    if { [tk colormodel .] == "color" } {

	if { $should } {

	    $b config -background $selectedbuttonbackground \
		-activebackground $selectedbuttonactivebackground

	} else {

	    $b config -background $defaultbuttonbackground \
		-activebackground $defaultbuttonactivebackground 

	}

    } else {

	if { $should } {

	    $b config -relief raised

	} else {

	    $b config -relief ridge

	}

    }

}

proc menuAbout {w} {
    toplevel $w -class Dialog
    wm title $w "About States"
    wm iconname $w "About States"
    wm minsize $w 50 50
    
    button $w.ok -text "OK" -command "destroy $w"
    pack $w.ok -fill x -side bottom

    text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -wrap word
    scrollbar $w.s -relief flat -command "$w.t yview"
    pack $w.s -side right -fill y
    pack $w.t -expand yes -fill both

    $w.t tag configure normal -font -*-times-medium-r-normal-*-*-140-*-*-*-*-*-*
    $w.t tag configure highlight -font -*-times-bold-r-normal-*-*-140-*-*-*-*-*-*
    $w.t tag configure courier -font -adobe-courier-medium-r-normal-*-*-120-*-*-*-*-*-*

    insertWithTags $w.t {States} highlight
    insertWithTags $w.t {\
is a graphical manipulation tool for finite state machines. It can read and write the KISS file format (see the ``File Formats'' menu), and can produce PostScript renderings of the machines.

The primary operations supported are adding states, adding transitions, moving states around, bending transitions (for esthetic reasons), editing state and transition labels, and adding floating text labels.

It it my hope that this program is self-expanatory, but it remains under development.  Comments, concerns, corrections, and bug reports are very much encouraged.

Stephen Edwards
} normal

insertWithTags $w.t {\
sedwards@eecs.berkeley.edu
} courier

   $w.t config -state disabled

}

proc menuHelpEdit {w} {
    global XC_top_left_arrow
    global XC_circle
    global XC_exchange

    toplevel $w -class Dialog
    wm title $w "Edit Help"
    wm iconname $w "Edit Help"
    wm minsize $w 50 50
    
    button $w.ok -text "OK" -command "destroy $w"
    pack $w.ok -fill x -side bottom

    text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -wrap word
    scrollbar $w.s -relief flat -command "$w.t yview"
    pack $w.s -side right -fill y
    pack $w.t -expand yes -fill both

    $w.t tag configure normal -font -*-times-medium-r-normal-*-*-140-*-*-*-*-*-*
    $w.t tag configure cursorfont -font cursor -relief raised -borderwidth 1 \
	-background \#eed5b7
    $w.t tag configure largetimes \
	-font -*-times-bold-r-normal-*-*-180-*-*-*-*-*-* \
	-relief raised -borderwidth 1 -background \#eed5b7
    $w.t tag configure highlight -font -*-times-bold-r-normal-*-*-140-*-*-*-*-*-*
    insertWithTags $w.t {\

The four buttons along the left side of the canvas select various editing modes:

} normal

    insertWithTags $w.t $XC_top_left_arrow cursorfont
    insertWithTags $w.t {  Moving, selecting, deleting, bending, etc.
} highlight

    insertWithTags $w.t {
* Objects can be selected by clicking.
* More objects can be selected by shift-clicking.
* Dragging out a rectangle (starting away from an object) selects all the objects touching that area.  Shift-dragging toggles their selection.
* Dragging a selected object moves that object and all other selected objects.
* Dragging a transition bends that transition.
* The delete/backspace key deletes selected states, transitions, and floating labels.

} normal

insertWithTags $w.t "o" largetimes
insertWithTags $w.t {  Adding states
} highlight
insertWithTags $w.t {
* States can be added by clicking in empty space.
* Clicking on text (e.g., state labels) allows it to be edited

} normal

insertWithTags $w.t $XC_exchange cursorfont
insertWithTags $w.t {Adding transitions
} highlight
insertWithTags $w.t {
* Click on a state and drag to another state to add a transition
* Click on a state and drag back to it to add a self-loop
* Clicking on text (e.g., transition labels) allows it to be edited

} normal

insertWithTags $w.t "A" largetimes
insertWithTags $w.t {  Editing Text, adding floating labels} highlight
insertWithTags $w.t {
* Click on text to edit it (set the insertion cursor).
* Click on blank space to add a floating label.
* Drag over text to select it.
* The delete/backspace key deletes the character to the left of the insertion cursor, or deletes the selected text.
* Typing inserts a character.  If text has been selected, it is deleted and replaced with that new character.
* States always have labels in their center.
* Transitions always have labels near their center on the ``outside'' of the curve.
} normal

    $w.t config -state disabled

}

proc menuHelpFile {w} {

    toplevel $w -class Dialog
    wm title $w "File Formats"
    wm iconname $w "File Formats"
    wm minsize $w 50 50

    button $w.ok -text "OK" -command "destroy $w"
    pack $w.ok -fill x -side bottom

    text $w.t -relief raised -bd 2 -yscrollcommand "$w.s set" -wrap word
    scrollbar $w.s -relief flat -command "$w.t yview"
    pack $w.s -side right -fill y
    pack $w.t -expand yes -fill both

    $w.t tag configure normal -font -*-times-medium-r-normal-*-*-140-*-*-*-*-*-*
    $w.t tag configure highlight -font -*-times-bold-r-normal-*-*-140-*-*-*-*-*-*
    $w.t tag configure courier -font -adobe-courier-medium-r-normal-*-*-120-*-*-*-*-*-*
    $w.t tag configure courierslant -font -adobe-courier-medium-o-normal-*-*-120-*-*-*-*-*-*

    insertWithTags $w.t {\
States reads and writes a slightly augmented version of the KISS file format.

Lines beginning with a pound sign (} normal
insertWithTags $w.t {#} courier
insertWithTags $w.t {) are comments in the standard KISS format.  States hides its graphical data in comments as described below.

The KISS format begins with a number of directives:

} normal

    insertWithTags $w.t {.i } courier
    insertWithTags $w.t {numberOfInputBits
} courierslant
    insertWithTags $w.t {.o } courier
    insertWithTags $w.t {numberOfOutputBits
} courierslant
    insertWithTags $w.t {.s } courier
    insertWithTags $w.t {numberOfStates
} courierslant
    insertWithTags $w.t {.p } courier
    insertWithTags $w.t {numberOfTransitions
} courierslant
    insertWithTags $w.t {.r } courier
    insertWithTags $w.t {nameOfResetState
} courierslant

    insertWithTags $w.t {
Following this, each transition is listed in the following format:

}

    insertWithTags $w.t {input sourceState destinationState output
} courierslant
insertWithTags $w.t {#~ } courier
insertWithTags $w.t {transitionBowFraction

transitionBowFraction} courierslant

insertWithTags $w.t { is a floating-point number which represents the ratio of the distance between the transition's two states and the distance from the line between the two states and the transition's label.  Thus 0.0 represents a straight line and 1.0 represents a highly curved transition.  For self-loops, this number is the anchor point for the start of looped transition in radians.

Following all the transitions, the positions of the states are described in comments of the following form:

} normal

insertWithTags $w.t {#$ } courier
insertWithTags $w.t {stateName x y} courierslant

insertWithTags $w.t {

The two coordinates locate the center of the states (in pixels).

Next, any floating text is described with lines of the form

} normal

insertWithTags $w.t {#& } courier
    insertWithTags $w.t {x y text} courierslant

    insertWithTags $w.t {

The two coordinates locate the center of the text.  The text may contain spaces (it is assumed to continue to the end-of-line).

Next, global parameters are set with lines of the form

} normal

insertWithTags $w.t {#p } courier
insertWithTags $w.t {variable value} courier

insertWithTags $w.t {

    Currently, the only variable so-defined is } normal
insertWithTags $w.t {stateradius} courier
insertWithTags $w.t {, which defines the radius of the state bubbles.

Finally, a

} normal

insertWithTags $w.t {.e} courier

insertWithTags $w.t {

directive terminates the file.

Currently, states is fairly simple-minded when it writes a KISS file.  Technically, inputs and outputs should only consist of zeros, ones, and dashes, and should all be the same length (as specified by the .i and .o directives).  However, states simply splits each transition's label at a slash and assumes the strings preceeding and following this slash are the inputs and outputs respectively.  This allows for symbolic inputs and outputs, but also allows for ill-formed KISS files.  The numbers specified in the .i and .o directives in such a case are the number of characters in the largest input and output strings respectively.

Also, it is almost a guarantee that transitions and states will be written out in an unexpected order.
} normal

    $w.t config -state disabled
}

proc insertWithTags {w text args} {
    set start [$w index insert]
    $w insert insert $text
    foreach tag [$w tag names $start] {
	$w tag remove $tag $start insert
    }
    foreach i $args {
	$w tag add $i $start insert
    }
}

##############################
#
# Procedures intended for send-based program communication
#

proc stateNames {} {
    global slabel

    foreach stlab [array names slabel] {
	lappend result $stlab
    }

    return $result
}

proc destStates {statetag} {
    
    global stranstag
    global tes tss

    foreach transtag $stranstag($statetag) {
	if { $tss($transtag) == $statetag } {
	    lappend result $tes($transtag)
	}
    }

    return $result

}

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

#proc tkerror {errmsg} {
#    puts $errmsg
#}

proc changeFile {name element op} {
    global fileBeingEdited

    .menu.filebeingedited config -text $fileBeingEdited
}

set textfocus 0

set statenum 0
set transnum 1
set resetstate ""
set startstate ""
set endstate ""

set fileBeingEdited ""

trace variable fileBeingEdited w "changeFile"

set fileBeingEdited "untitled.kiss"

modeArrow

if { $argc >= 1 } {
    set fileBeingEdited [lindex $argv 0]
    loadKissFile $fileBeingEdited
}

## File type information for Emacs
##
## Local Variables:
## mode: tcl
## End: