summaryrefslogtreecommitdiff
path: root/graphics/finomaton/finomaton.tcl
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /graphics/finomaton/finomaton.tcl
Initial commit
Diffstat (limited to 'graphics/finomaton/finomaton.tcl')
-rw-r--r--graphics/finomaton/finomaton.tcl1735
1 files changed, 1735 insertions, 0 deletions
diff --git a/graphics/finomaton/finomaton.tcl b/graphics/finomaton/finomaton.tcl
new file mode 100644
index 0000000000..e3af7d8db8
--- /dev/null
+++ b/graphics/finomaton/finomaton.tcl
@@ -0,0 +1,1735 @@
+#!/bin/sh
+# the next line restarts using wish \
+exec wish "$0" "$@"
+
+# Finomaton - Draw Finite State Machines
+# Copyright (C) 2003, 2006, 2007 Markus Triska (triska@gmx.at)
+#
+# 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., 59 Temple Place, Suite 330, Boston, MA 02111 USA
+
+
+if {[info tclversion] < 8.3} {
+ puts "This program requires Tcl >= 8.3. You have: [info tclversion]"
+ exit
+}
+
+set PROGRAM "Finomaton"
+set VERSION 1.0
+set PI [expr atan(1)*4]
+set windowtitle $PROGRAM
+set batchmode 0
+
+set default_stateradius 20
+set default_linelength 80
+set default_cpradius 6
+set magnetic_radius 7
+set highlight "#3078d8"
+set metapost_scale_default 0.5
+set metapost_scale $metapost_scale_default
+
+set selectedlist {}
+set dragobject -1
+set dragstart "0 0"
+set dragend "0 0"
+set dragrectangleid -1
+set currentcommand ""
+set anchormenu ""
+set needs_save 0
+set currentfile ""
+set export_mp_file_default ""
+set export_mp_file $export_mp_file_default
+set export_ps_file ""
+set filecomment_default ""
+set filecomment $filecomment_default
+set ahangle_default 35
+set ahangle $ahangle_default
+set ahlength_default 4
+set ahlength $ahlength_default
+set fileauthor_default ""
+set fileauthor $fileauthor_default
+set verbatimtex_default ""
+set verbatimtex $verbatimtex_default
+set graphstyle "automaton"
+set graphstyle_default "automaton"
+set modifiable_params {metapost_scale ahangle ahlength filecomment \
+ export_mp_file fileauthor verbatimtex graphstyle}
+array set objectinfo {}
+
+
+proc digraph {} {
+ global graphstyle
+ return [string equal $graphstyle "digraph"]
+}
+
+proc automaton {} {
+ return [expr ![digraph]]
+}
+
+proc reset_parameter {param} {
+ upvar #0 $param p
+ upvar #0 ${param}_default pd
+ set p $pd
+}
+
+proc reset_all_parameters {} {
+ global modifiable_params
+ foreach mp $modifiable_params { reset_parameter $mp }
+}
+
+proc is_numeric {s} {
+ return [regexp {^[+-]?\d*\.?\d+$} $s]
+}
+
+proc check_parameters {} {
+ global metapost_scale ahangle ahlength
+ foreach numericparam {metapost_scale ahangle ahlength} {
+ if {![is_numeric [subst $$numericparam]]} {
+ reset_parameter $numericparam
+ }
+ }
+}
+
+set unid 0
+proc unique_id {} {
+ # simulate behaviour of the canvas widget in batch mode
+ global unid
+ incr unid
+ return $unid
+}
+
+proc get_objects_type {type} {
+ global objectinfo
+ set objlist ""
+ foreach id [array names objectinfo {*-id}] {
+ set id [string replace $id [string first "-" $id] end]
+ if {$objectinfo($id-type) == $type} { lappend objlist $id }
+ }
+ return $objlist
+}
+
+proc set_command {command} {
+ global currentcommand commandsframe
+ if {$currentcommand != ""} {
+ set path "$commandsframe.command_$currentcommand"
+ $path configure -relief raised
+ }
+
+ set newpath "$commandsframe.command_$command"
+ $newpath configure -relief sunken
+ set currentcommand $command
+}
+
+proc dist {x1 y1 x2 y2} {
+ set dx [expr {$x2 - $x1}]
+ set dy [expr {$y2 - $y1}]
+ return [expr hypot($dx, $dy)]
+}
+
+proc inside_object {X Y} {
+ upvar #0 objectinfo oi
+
+ # check control points first since they can be inside states
+ foreach id [get_objects_type "controlpoint"] {
+ if {[dist $oi($id-x) $oi($id-y) $X $Y] <= $oi($id-radius)} {
+ return $id
+ }
+ }
+
+ foreach id [get_objects_type "state"] {
+ if {[dist $oi($id-x) $oi($id-y) $X $Y] <= $oi($id-radius)} {
+ return $id
+ }
+ }
+ return -1
+}
+
+proc correct_angle {angle a} {
+ set corr 7
+ if {($angle >= $a - $corr) && ($angle <= $a + $corr)} { return $a }
+ return $angle
+}
+
+proc magnetic_anchor {X Y} {
+ # pull control points to states (outline or center), return stateid
+ # and angle to attach line (-1 for center), or -1 if no state found
+
+ global magnetic_radius
+
+ foreach id [get_objects_type "state"] {
+ upvar #0 objectinfo oi
+ set d [dist $X $Y $oi($id-x) $oi($id-y)]
+ if {abs($d - $oi($id-radius)) <= $magnetic_radius} {
+ # pull to point on outline
+ set dx [expr {$X - $oi($id-x)}]
+ set cos [expr {$dx / $d}]
+ global PI
+ set angle [expr {(acos($cos)/$PI*180)}]
+ if {$Y > $oi($id-y)} { set angle [expr {360 - $angle}] }
+ foreach a {0 90 180 270 360} {
+ # set angle [correct_angle $angle $a]
+ }
+ return "$id [expr round($angle)]"
+ } elseif {$d <= $magnetic_radius} {
+ # pull to center
+ return "$id -1"
+ }
+ }
+ return -1
+}
+
+proc anchor_coords {stateid angle} {
+ global objectinfo PI
+ set x $objectinfo($stateid-x)
+ set y $objectinfo($stateid-y)
+ if {$angle == -1} { return "$x $y" }
+
+ set r $objectinfo($stateid-radius)
+ set anchx [expr {$x + $r*cos($angle*$PI/180)}]
+ set anchy [expr {$y - $r*sin($angle*$PI/180)}]
+ return "$anchx $anchy"
+}
+
+proc create_state {X Y r} {
+ global maincanvas objectinfo batchmode
+
+ set id 0
+ if {$batchmode} {
+ set id [unique_id]
+ set labelid [unique_id]
+ } else {
+ set id [$maincanvas create oval 0 0 0 0 -tags state]
+ set labelid [$maincanvas create text $X $Y -text "s"]
+ }
+ set objectinfo($id-radius) $r
+ set objectinfo($id-x) $X
+ set objectinfo($id-y) $Y
+ set objectinfo($id-id) $id
+ set objectinfo($id-type) "state"
+ set objectinfo($id-label) ""
+ set objectinfo($id-tex) ""
+ set objectinfo($id-accept) 0
+ set objectinfo($id-acceptid) -1
+ set objectinfo($id-start) 0
+ set objectinfo($id-labelid) $labelid
+ set objectinfo($labelid-type) "statelabel"
+
+ update_object $id
+ return $id
+}
+
+proc add_control_point {line X Y {interactive 1}} {
+ global objectinfo maincanvas default_cpradius batchmode
+
+ set id 0
+ if {$batchmode} {
+ set id [unique_id]
+ } else {
+ set id [$maincanvas create oval 0 0 0 0 -tags cp]
+ }
+ set objectinfo($id-x) $X
+ set objectinfo($id-y) $Y
+ set objectinfo($id-type) "controlpoint"
+ set objectinfo($id-line) $line
+ set objectinfo($id-id) $id
+
+ set insertpos end
+ if {$interactive} {
+ set insertpos 1
+ if {[llength $objectinfo($line-cplist)] == 3} {
+ # insert it depending on which endpoint is nearer
+ set ep1 [lindex $objectinfo($line-cplist) 0]
+ set ep2 [lindex $objectinfo($line-cplist) 2]
+ set d1 [dist $objectinfo($ep1-x) $objectinfo($ep1-y) $X $Y]
+ set d2 [dist $objectinfo($ep2-x) $objectinfo($ep2-y) $X $Y]
+ if {$d2 < $d1} { set insertpos 2 }
+ }
+ }
+
+ set objectinfo($line-cplist) [linsert $objectinfo($line-cplist) \
+ $insertpos $id]
+ set objectinfo($id-radius) $default_cpradius
+ set objectinfo($id-attached) -1
+ set objectinfo($id-angle) 0
+ # don't use update_object here, because the line might not be finished yet
+ update_oval $id
+ return $id
+}
+
+proc create_line {X Y {interactive 1}} {
+ global maincanvas default_linelength objectinfo batchmode
+ # set control points
+ set cp1x $X
+ set cp2x [expr {$X + ($default_linelength / 2)}]
+ set cp3x [expr {$X + $default_linelength}]
+ set lid 0
+ if {$batchmode} {
+ set lid [unique_id]
+ } else {
+ set lid [$maincanvas create line $cp1x $Y $cp2x $Y $cp3x $Y \
+ -smooth 1 -arrow last -tags line]
+ }
+ set objectinfo($lid-type) "line"
+ set objectinfo($lid-id) $lid
+ set objectinfo($lid-tex) ""
+ set objectinfo($lid-texpos) 0.5
+ set objectinfo($lid-anchor) "top"
+ set objectinfo($lid-cplist) ""
+ set objectinfo($lid-bisect) 1
+ # coordinates for lines are used to compute relative movement when
+ # the line is being dragged. meaningless otherwise.
+ set objectinfo($lid-x) 0
+ set objectinfo($lid-y) 0
+
+ if {$interactive} {
+ foreach cp {cp1 cp2 cp3} {
+ set cpx [subst $${cp}x]
+ add_control_point $lid $cpx $Y 0
+ }
+ update_object $lid
+ }
+ return $lid
+}
+
+proc create_text {X Y} {
+ global maincanvas objectinfo batchmode
+ set id 0
+ if {$batchmode} {
+ set id [unique_id]
+ } else {
+ set id [$maincanvas create text $X $Y -text "text" -tags text]
+ }
+ set objectinfo($id-type) "text"
+ set objectinfo($id-x) $X
+ set objectinfo($id-y) $Y
+ set objectinfo($id-label) "text"
+ set objectinfo($id-tex) ""
+ set objectinfo($id-id) $id
+ return $id
+}
+
+proc remove_object {id {interactive 1}} {
+ global objectinfo maincanvas
+
+ if {$objectinfo($id-type) == "controlpoint"} {
+ set lid $objectinfo($id-line)
+ set cplist $objectinfo($lid-cplist)
+ set i [lsearch $cplist $id]
+ set objectinfo($lid-cplist) [lreplace $cplist $i $i]
+ if {$interactive} {
+ # called by user, not when deleting whole line
+ if {[llength $objectinfo($lid-cplist)] <= 1} {
+ remove_object $lid
+ } else {
+ update_object $lid
+ }
+ }
+ } elseif {$objectinfo($id-type) == "line"} {
+ foreach cp $objectinfo($id-cplist) { remove_object $cp 0 }
+ } elseif {$objectinfo($id-type) == "state"} {
+ remove_object $objectinfo($id-labelid)
+ if {$objectinfo($id-accept)} {
+ remove_object $objectinfo($id-acceptid)
+ }
+ foreach cpid [get_objects_type "controlpoint"] {
+ if {$objectinfo($cpid-attached) == $id} {
+ set objectinfo($cpid-attached) -1
+ }
+ }
+ }
+
+ remove_select $id
+ $maincanvas delete $id
+ array unset objectinfo "$id-*"
+}
+
+proc update_oval {id} {
+ global maincanvas batchmode objectinfo
+ if {$batchmode} { return }
+
+ set r $objectinfo($id-radius)
+ set x1 [expr {$objectinfo($id-x) - $r}]
+ set x2 [expr {$objectinfo($id-x) + $r}]
+ set y1 [expr {$objectinfo($id-y) - $r}]
+ set y2 [expr {$objectinfo($id-y) + $r}]
+ $maincanvas coords $id $x1 $y1 $x2 $y2
+}
+
+proc update_object {id} {
+ global objectinfo maincanvas batchmode
+ if {$batchmode} { return }
+ if {$objectinfo($id-type) == "line"} {
+ set points ""
+ foreach cp $objectinfo($id-cplist) {
+ set points [concat $points "$objectinfo($cp-x) $objectinfo($cp-y)"]
+ }
+ $maincanvas coords $id $points
+ } elseif {$objectinfo($id-type) == "controlpoint"} {
+ update_oval $id
+ update_object $objectinfo($id-line)
+ } elseif {$objectinfo($id-type) == "state"} {
+ update_oval $id
+ if {$objectinfo($id-start)} {
+ $maincanvas itemconfigure $id -width 3
+ } else {
+ $maincanvas itemconfigure $id -width 1
+ }
+
+ if {$objectinfo($id-accept)} {
+ set accid $objectinfo($id-acceptid)
+ if {$accid == -1} {
+ set accid [$maincanvas create oval 0 0 0 0]
+ global default_stateradius
+ set objectinfo($accid-radius) [expr {$default_stateradius - 4}]
+ set objectinfo($accid-type) "acceptcircle"
+ set objectinfo($id-acceptid) $accid
+ }
+ set objectinfo($accid-x) $objectinfo($id-x)
+ set objectinfo($accid-y) $objectinfo($id-y)
+ update_oval $accid
+ } else {
+ if {$objectinfo($id-acceptid) != -1} {
+ remove_object $objectinfo($id-acceptid)
+ set objectinfo($id-acceptid) -1
+ }
+ }
+ $maincanvas itemconfigure $objectinfo($id-labelid) -text \
+ $objectinfo($id-label)
+ $maincanvas coords $objectinfo($id-labelid) \
+ $objectinfo($id-x) $objectinfo($id-y)
+ foreach cp [get_objects_type "controlpoint"] {
+ if {$objectinfo($cp-attached) == $id} {
+ set c [anchor_coords $id $objectinfo($cp-angle)]
+ set objectinfo($cp-x) [lindex $c 0]
+ set objectinfo($cp-y) [lindex $c 1]
+ update_object $cp
+ }
+ }
+ } elseif {$objectinfo($id-type) == "text"} {
+ $maincanvas itemconfigure $id -text $objectinfo($id-label)
+ $maincanvas coords $id $objectinfo($id-x) $objectinfo($id-y)
+ }
+}
+
+proc move_delta {id dx dy} {
+ global objectinfo
+ set objectinfo($id-x) [expr {$objectinfo($id-x) + $dx}]
+ set objectinfo($id-y) [expr {$objectinfo($id-y) + $dy}]
+ if {$objectinfo($id-x) < 0} { set objectinfo($id-x) 0 }
+ if {$objectinfo($id-y) < 0} { set objectinfo($id-y) 0 }
+ update_object $id
+}
+
+
+proc move_objects {coords} {
+ global selectedlist objectinfo dragobject
+ if {$dragobject == -1} { return }
+
+ set X [lindex $coords 0]
+ set Y [lindex $coords 1]
+
+ set newx $X
+ set newy $Y
+
+ # a control point might be moved to coordinates different from ($X/$Y)
+ # because of magnetic states. so check this first.
+ if {$objectinfo($dragobject-type) == "controlpoint"} {
+ set magna [magnetic_anchor $X $Y]
+ if {$magna != -1} {
+ set magid [lindex $magna 0]
+ set angle [lindex $magna 1]
+ set coords [anchor_coords $magid $angle]
+ set newx [lindex $coords 0]
+ set newy [lindex $coords 1]
+ set objectinfo($dragobject-attached) $magid
+ set objectinfo($dragobject-angle) $angle
+ } else {
+ set objectinfo($dragobject-attached) -1
+ set objectinfo($dragobject-angle) 0
+ }
+ }
+
+ # now compute the relative movement of the primarily dragged object
+ set dx [expr {$newx - $objectinfo($dragobject-x)}]
+ set dy [expr {$newy - $objectinfo($dragobject-y)}]
+
+ # move all selected objects accordingly (includes dragged object)
+ foreach id $selectedlist {
+ if {$id != $dragobject && $objectinfo($id-type) == "controlpoint"} {
+ # detach other control points if necessary
+ set s $objectinfo($id-attached)
+ if {$s != -1 && [lsearch $selectedlist $s] == -1} {
+ set objectinfo($id-attached) -1
+ }
+ }
+ move_delta $id $dx $dy
+ }
+}
+
+proc hide_control_points {} {
+ global maincanvas
+ $maincanvas itemconfigure cp -outline ""
+}
+
+proc add_select {id} {
+ global selectedlist maincanvas objectinfo highlight
+ if {[lsearch $selectedlist $id] == -1} {
+ lappend selectedlist $id
+ }
+
+ if {$objectinfo($id-type) == "line" || $objectinfo($id-type) == "text"} {
+ $maincanvas itemconfigure $id -fill $highlight
+ } else {
+ $maincanvas itemconfigure $id -outline $highlight
+ }
+
+ if {$objectinfo($id-type) == "line"} {
+ foreach cp $objectinfo($id-cplist) { add_select $cp }
+ }
+}
+
+proc remove_select {id} {
+ global selectedlist objectinfo maincanvas
+ set pos [lsearch $selectedlist $id]
+ if {$pos != -1} {
+ set selectedlist [lreplace $selectedlist $pos $pos]
+ if {$objectinfo($id-type) == "line" || \
+ $objectinfo($id-type) == "text"} {
+ $maincanvas itemconfigure $id -fill black
+ } else {
+ $maincanvas itemconfigure $id -outline black
+ }
+ }
+ global dragobject
+ if {$dragobject == $id} {
+ set dragobject -1
+ }
+}
+
+proc toggle_item {id} {
+ global selectedlist dragobject
+ if {[lsearch $selectedlist $id] == -1} {
+ add_select $id
+ set dragobject $id
+ } else {
+ remove_select $id
+ }
+}
+
+proc closest_item {coords} {
+ global maincanvas objectinfo
+ set X [lindex $coords 0]
+ set Y [lindex $coords 1]
+
+ set id [inside_object $X $Y]
+ if {$id != -1} { return $id }
+
+ set id [$maincanvas find closest $X $Y]
+ if {$id != ""} {
+ if {$objectinfo($id-type) == "line"} {
+ return $id
+ } elseif {$objectinfo($id-type) == "text"} {
+ return $id
+ }
+ }
+ return -1
+}
+
+proc toggle_select {coords} {
+ global objectinfo
+ set id [closest_item $coords]
+ if {$id != -1} {
+ toggle_item $id
+ if {$objectinfo($id-type) == "line"} {
+ set objectinfo($id-x) [lindex $coords 0]
+ set objectinfo($id-y) [lindex $coords 1]
+ }
+ }
+}
+
+
+proc canvas_clicked {command coords} {
+ global maincanvas objectinfo default_stateradius needs_save
+ set X [lindex $coords 0]
+ set Y [lindex $coords 1]
+ if {$command == "newstate"} {
+ create_state $X $Y $default_stateradius
+ hide_control_points
+ set needs_save 1
+ } elseif {$command == "newline"} {
+ create_line $X $Y
+ set needs_save 1
+ } elseif {$command == "newcp"} {
+ set id [$maincanvas find closest $X $Y]
+ if {$id == "" || $objectinfo($id-type) != "line"} { return }
+ if {[llength $objectinfo($id-cplist)] < 4} {
+ add_control_point $id $X $Y
+ update_object $id
+ set needs_save 1
+ }
+ } elseif {$command == "newtext"} {
+ create_text $X $Y
+ set needs_save 1
+ } elseif {$command == "select"} {
+ global dragobject selectedlist
+ set id [closest_item "$X $Y"]
+
+ if {$id == -1 || [lsearch $selectedlist $id] == -1} {
+ foreach sid $selectedlist { remove_select $sid }
+ }
+
+ if {$id == -1} {
+ hide_control_points
+ set dragobject -1
+ global dragstart dragend dragrectangleid
+ set dragstart "$X $Y"
+ set dragend $dragstart
+ set dragrectangleid [$maincanvas create rectangle $X $Y $X $Y]
+ return
+ }
+
+ if {$objectinfo($id-type) == "state"} {
+ hide_control_points
+ } elseif {$objectinfo($id-type) == "line"} {
+ # here, the line is assigned coordinates to compute
+ # relative movement when dragged
+ set objectinfo($id-x) $X
+ set objectinfo($id-y) $Y
+ } elseif {$objectinfo($id-type) == "controlpoint"} {
+ set lid $objectinfo($id-line)
+ remove_select $lid
+ foreach cp $objectinfo($lid-cplist) {
+ remove_select $cp
+ }
+ }
+
+ set dragobject $id
+ add_select $id
+ } elseif {$command == "remove"} {
+ set id [closest_item "$X $Y"]
+ if {$id != -1} {
+ remove_object $id
+ set needs_save 1
+ }
+ }
+}
+
+proc center_window {win} {
+ set x [expr {[winfo rootx .] + [winfo reqwidth .]/2 \
+ - [winfo reqwidth $win]/2}]
+ set y [expr {[winfo rooty .] + [winfo reqheight .]/2 \
+ - [winfo reqheight $win]/2}]
+ wm geometry $win "+$x+$y"
+}
+
+proc set_geometry {win} {
+ wm withdraw $win
+ update idletasks
+ center_window $win
+ wm deiconify $win
+ wm minsize $win [winfo reqwidth $win] [winfo reqheight $win]
+}
+
+proc transient_window {win title} {
+ if {[winfo exists $win]} {
+ center_window $win
+ return -1
+ }
+ toplevel $win
+ wm title $win $title
+ wm transient $win .
+ return $win
+}
+
+proc double_click {coords} {
+ global objectinfo
+ set id [closest_item $coords]
+ if {$id == -1} { return }
+
+ if {$objectinfo($id-type) == "text"} {
+ edit_text $id
+ } elseif {$objectinfo($id-type) == "line"} {
+ edit_line $id
+ } elseif {$objectinfo($id-type) == "state"} {
+ edit_state $id
+ }
+}
+
+
+proc edit_state {id} {
+ set w [transient_window .editstate "Edit state"]
+ if {$w == -1} { return }
+
+ wm protocol $w WM_DELETE_WINDOW { set statebutton 0 }
+
+ global objectinfo
+ set f1 [frame $w.f1]
+ label $f1.lab1 -text "Label:"
+ entry $f1.ent1
+ $f1.ent1 insert 0 $objectinfo($id-label)
+ bind $f1.ent1 <Return> { set statebutton 1 }
+
+ label $f1.lab2 -text "TeX:"
+ entry $f1.ent2
+ $f1.ent2 insert 0 $objectinfo($id-tex)
+ bind $f1.ent2 <Return> { set statebutton 1 }
+
+ label $f1.lab3 -text \
+ "Tip for TeX: Include a \\strut to\nmake the circle bigger"
+
+ grid $f1.lab1 $f1.ent1 -padx 5 -pady 5
+ grid $f1.lab2 $f1.ent2 -padx 5 -pady 5
+ grid $f1.lab3 -
+ grid configure $f1.lab1 -sticky w
+ grid configure $f1.lab2 -sticky w
+ grid configure $f1.ent1 -sticky e
+ grid configure $f1.ent2 -sticky nesw
+ grid columnconfigure $f1 1 -weight 1
+ pack $f1 -expand yes -fill both
+
+ set f2 [frame $w.f2]
+ label $f2.lab1 -text "X:"
+ entry $f2.ent1 -width 6
+ $f2.ent1 insert 0 $objectinfo($id-x)
+ bind $f2.ent1 <Return> { set statebutton 1 }
+
+ label $f2.lab2 -text "Y:"
+ entry $f2.ent2 -width 6
+ $f2.ent2 insert 0 $objectinfo($id-y)
+ bind $f2.ent2 <Return> { set statebutton 1 }
+
+ grid $f2.lab1 $f2.ent1 -padx 5 -pady 5
+ grid $f2.lab2 $f2.ent2 -padx 5 -pady 5
+ grid configure $f2.lab1 -sticky w
+ grid configure $f2.lab2 -sticky w
+ grid configure $f2.ent1 -sticky e
+ grid configure $f2.ent2 -sticky e
+ grid columnconfigure $f2 1 -weight 1
+ pack $f2 -expand yes -fill both
+
+ global acceptcheck startcheck
+
+ set f3 [frame $w.f3]
+ label $f3.lab -text "Accepting state:"
+ pack $f3.lab -side left -padx 5 -pady 5
+ pack [checkbutton $f3.acceptcheck] -side left -expand yes -anchor e
+ set acceptcheck $objectinfo($id-accept)
+ pack $f3 -expand yes -fill both
+
+ set f4 [frame $w.f4]
+ label $f4.lab -text "Starting state:"
+ pack $f4.lab -side left -padx 5 -pady 5
+ pack [checkbutton $f4.startcheck] -side left -expand yes -anchor e
+ set startcheck $objectinfo($id-start)
+ pack $f4 -expand yes -fill both
+
+
+ global statebutton needs_save
+ set statebutton ""
+ set f5 [frame $w.f5]
+ button $f5.ok -text " OK " -command { set statebutton 1 }
+ pack $f5.ok -side left -padx 5 -pady 5
+ button $f5.cancel -text " Cancel " -command { set statebutton 0 }
+ pack $f5.cancel -side left -padx 5 -pady 5
+ pack $f5 -padx 5 -pady 5
+
+ set_geometry $w
+ focus $f1.ent1
+ tkwait variable statebutton
+ if {$statebutton == 1} {
+ set objectinfo($id-label) [$f1.ent1 get]
+ set objectinfo($id-tex) [$f1.ent2 get]
+ set x [$f2.ent1 get]
+ set y [$f2.ent2 get]
+ if {[is_numeric $x] && $x >= 0} { set objectinfo($id-x) $x }
+ if {[is_numeric $y] && $y >= 0} { set objectinfo($id-y) $y }
+ set objectinfo($id-accept) $acceptcheck
+ set objectinfo($id-start) $startcheck
+ set needs_save 1
+ update_object $id
+ }
+ destroy $w
+}
+
+proc edit_text {id} {
+ set w [transient_window .edittext "Edit text"]
+ if {$w == -1} { return }
+
+ wm protocol $w WM_DELETE_WINDOW { set textbutton 0 }
+
+ global objectinfo
+ set f1 [frame $w.f1]
+ label $f1.lab -text "Label:"
+ pack $f1.lab -side left -padx 5 -pady 5
+ entry $f1.ent
+ pack $f1.ent -side left -padx 5 -pady 5 -expand yes -fill x
+ $f1.ent insert 0 $objectinfo($id-label)
+ pack $f1 -padx 5 -pady 5 -fill both -expand yes -anchor e
+ bind $f1.ent <Return> { set textbutton 1 }
+
+ set f2 [frame $w.f2]
+ label $f2.lab -text "TeX:"
+ pack $f2.lab -side left -padx 5 -pady 5
+ entry $f2.ent
+ pack $f2.ent -side left -padx 5 -pady 5 -expand yes -fill x
+ $f2.ent insert 0 $objectinfo($id-tex)
+ pack $f2 -padx 5 -pady 5 -fill both -expand yes -anchor e
+ bind $f2.ent <Return> { set textbutton 1 }
+
+ global textbutton needs_save
+ set textbutton ""
+ set f3 [frame $w.f3]
+ button $f3.ok -text " OK " -command { set textbutton 1 }
+ pack $f3.ok -side left -padx 5 -pady 5
+ button $f3.cancel -text " Cancel " -command { set textbutton 0 }
+ pack $f3.cancel -side left -padx 5 -pady 5
+ pack $f3 -padx 5 -pady 5
+
+ set_geometry $w
+ focus $f1.ent
+ tkwait variable textbutton
+ if {$textbutton == 1} {
+ set objectinfo($id-label) [$f1.ent get]
+ set objectinfo($id-tex) [$f2.ent get]
+ set needs_save 1
+ update_object $id
+ }
+ destroy $w
+}
+
+proc edit_line {id} {
+ set w [transient_window .editline "Edit line"]
+ if {$w == -1} { return }
+
+ wm protocol $w WM_DELETE_WINDOW { set linebutton 0 }
+
+ global objectinfo
+ set f1 [frame $w.f1]
+ label $f1.lab -text "Label (TeX):"
+ pack $f1.lab -side left -padx 5 -pady 5
+ entry $f1.ent
+ pack $f1.ent -side left -padx 5 -pady 5 -expand yes -fill x
+ $f1.ent insert 0 $objectinfo($id-tex)
+ pack $f1 -fill both -expand yes
+ bind $f1.ent <Return> { set linebutton 1 }
+
+ set f2 [frame $w.f2]
+ label $f2.lab -text "How far along (percent):"
+ pack $f2.lab -side left -padx 5 -pady 5
+ scale $f2.pos -from 0 -to 100 -orient horizontal
+ pack $f2.pos -side left -padx 5 -pady 5 -expand yes -fill x
+ pack $f2 -fill both -expand yes
+ $f2.pos set [expr {$objectinfo($id-texpos) * 100}]
+
+ set f3 [frame $w.f3]
+ label $f3.lab -text "Label position:"
+ pack $f3.lab -side left -padx 5 -pady 5
+ set mb [menubutton $f3.mbutton -menu $f3.mbutton.menu -relief raised]
+ pack $mb -side left -padx 5 -pady 5
+
+ global anchorpos
+ set anchorpos $objectinfo($id-anchor)
+ set m [menu $f3.mbutton.menu -tearoff 0]
+ foreach {l p} {Top top Right rt Bottom bot Left lft "Upper right" urt \
+ "Lower right" lrt "Lower left" llft "Upper left" ulft} {
+ if {$anchorpos == $p} { $mb configure -text $l }
+ $m add command -label $l -command \
+ "set anchorpos $p; $mb configure -text [list $l]"
+ }
+ pack $f3 -fill both -expand yes
+
+ global bisectcheck
+ set f4 [frame $w.f4]
+ label $f4.lab -text "Interpolate control points:"
+ pack $f4.lab -side left -padx 5 -pady 5
+ pack [checkbutton $f4.bisectcheck] -side left -expand yes -anchor e
+ set bisectcheck $objectinfo($id-bisect)
+ pack $f4 -expand yes -fill both
+
+ global linebutton
+ set linebutton ""
+ set f5 [frame $w.f5]
+ button $f5.ok -text " OK " -command { set linebutton 1 }
+ pack $f5.ok -side left -padx 5 -pady 5
+ button $f5.cancel -text " Cancel " -command { set linebutton 0 }
+ pack $f5.cancel -side left -padx 5 -pady 5
+ pack $f5 -padx 5 -pady 5
+
+ set_geometry $w
+ focus $f1.ent
+ tkwait variable linebutton
+ if {$linebutton == 1} {
+ set objectinfo($id-tex) [$f1.ent get]
+ set objectinfo($id-texpos) [expr {[$f2.pos get] / 100.0}]
+ set objectinfo($id-anchor) $anchorpos
+ set objectinfo($id-bisect) $bisectcheck
+ global needs_save
+ set needs_save 1
+ }
+ destroy $w
+}
+
+proc settings {} {
+ global metapost_scale filecomment ahangle ahlength fileauthor
+ global verbatimtex graphstyle
+ set w [transient_window .settings "Settings for this file"]
+ if {$w == -1} { return }
+
+ wm protocol $w WM_DELETE_WINDOW { set settingsbutton 0 }
+
+ set f1 [frame $w.f1]
+ label $f1.lab -text "MetaPost scale factor:"
+ pack $f1.lab -side left -padx 5 -pady 5
+ entry $f1.ent -width 3
+ $f1.ent insert 0 $metapost_scale
+ pack $f1.ent -side left -padx 5 -pady 5 -expand yes -anchor e
+ pack $f1 -fill x
+
+ set f2 [frame $w.f2]
+ label $f2.lab -text "Arrowhead breadth:"
+ pack $f2.lab -side left -padx 5 -pady 5
+ entry $f2.ent -width 3
+ pack $f2.ent -side left -padx 5 -pady 5 -expand yes -anchor e
+ $f2.ent insert 0 $ahangle
+ pack $f2 -fill x
+
+ set f3 [frame $w.f3]
+ label $f3.lab -text "Arrowhead length (bp):"
+ pack $f3.lab -side left -padx 5 -pady 5
+ entry $f3.ent -width 3
+ pack $f3.ent -side left -padx 5 -pady 5 -expand yes -anchor e
+ $f3.ent insert 0 $ahlength
+ pack $f3 -fill x
+
+ set f4 [frame $w.f4]
+ label $f4.lab -text "Export style:"
+ pack $f4.lab -side left -padx 5 -pady 5
+ set mb [menubutton $f4.mbutton -menu $f4.mbutton.menu \
+ -text $graphstyle -relief raised]
+ pack $mb -side left -padx 5 -pady 5
+
+ set m [menu $f4.mbutton.menu -tearoff 0]
+ foreach gs {automaton digraph} {
+ $m add command -label $gs -command "$mb configure -text $gs"
+ }
+ pack $f4 -fill x
+
+ set tp [frame $w.textparent]
+
+ label $tp.authorlab -text "Author:"
+ entry $tp.authorent -width 20
+ $tp.authorent insert 0 $fileauthor
+
+ label $tp.commentlab -text "File comment:"
+ text $tp.commentent -width 40 -height 5
+ $tp.commentent insert end $filecomment
+
+ label $tp.verbatimlab -text "TeX macros:"
+ text $tp.verbatiment -width 40 -height 7
+ $tp.verbatiment insert end $verbatimtex
+
+ grid $tp.authorlab $tp.authorent -padx 5 -pady 5
+ grid $tp.commentlab $tp.commentent -padx 5 -pady 5
+ grid $tp.verbatimlab $tp.verbatiment -padx 5 -pady 5
+ grid configure $tp.authorent -sticky w
+ grid configure $tp.commentent -sticky nesw
+ grid configure $tp.verbatiment -sticky nesw
+ grid columnconfigure $tp 1 -weight 1
+ grid rowconfigure $tp 1 -weight 1
+ grid rowconfigure $tp 2 -weight 1
+ pack $tp -expand yes -fill both
+
+ global settingsbutton needs_save
+ set settingsbutton ""
+
+ set f5 [frame $w.f5]
+ button $f5.ok -text " OK " -command { set settingsbutton 1 }
+ pack $f5.ok -side left -padx 5 -pady 5
+ button $f5.cancel -text " Cancel " -command { set settingsbutton 0 }
+ pack $f5.cancel -side left -padx 5 -pady 5
+ pack $f5 -padx 5 -pady 5
+
+ set_geometry $w
+ focus $f1.ent
+
+ tkwait variable settingsbutton
+ if {$settingsbutton == 1} {
+ set needs_save 1
+ set metapost_scale [$f1.ent get]
+ set ahangle [$f2.ent get]
+ set ahlength [$f3.ent get]
+ set graphstyle [$f4.mbutton cget -text]
+ set fileauthor [$tp.authorent get]
+ set filecomment [string trim [$tp.commentent get 1.0 end]]
+ set verbatimtex [string trim [$tp.verbatiment get 1.0 end]]
+ check_parameters
+ }
+ destroy $w
+}
+
+proc about {} {
+ global PROGRAM VERSION
+ set aboutwin [transient_window .aboutwin "About $PROGRAM"]
+ if {$aboutwin == ""} { return }
+ label $aboutwin.copyright -text \
+ "$PROGRAM $VERSION - Draw Finite State Machines\n\n\
+ $PROGRAM comes with ABSOLUTELY NO WARRANTY. This is\n\
+ free software, and you are welcome to distribute it\n\
+ under certain conditions. Read the file COPYING for\n\
+ more information.\n\n\
+ Copyright (C) 2003, 2006, 2007 Markus Triska triska@gmx.at"
+ button $aboutwin.ok -text "OK" -command { destroy .aboutwin }
+ pack $aboutwin.copyright -pady 10 -padx 20
+ pack $aboutwin.ok -pady 4
+ set_geometry $aboutwin
+ focus $aboutwin.ok
+}
+
+
+# The rest is about loading, saving and exporting.
+
+
+proc mpost_scale {coord} {
+ global metapost_scale
+ set newcoord [expr {$metapost_scale * $coord}]
+ return $newcoord
+}
+
+proc mpost_coords {id} {
+ global objectinfo
+ if {$objectinfo($id-type) == "controlpoint"} {
+ set attid $objectinfo($id-attached)
+ if {$attid != -1} {
+ return "(s$attid.c)"
+ }
+ }
+
+ # MetaPost y coordinate is reversed (from our standpoint)
+ set y [expr {- $objectinfo($id-y)}]
+ return "([mpost_scale $objectinfo($id-x)], [mpost_scale $y])"
+}
+
+proc mpost_line {id} {
+ # approximate the given line in MetaPost syntax
+ global objectinfo
+ set firstid [lindex $objectinfo($id-cplist) 0]
+ set lastid [lindex $objectinfo($id-cplist) end]
+ set numcp [llength $objectinfo($id-cplist)]
+ set coord1 [mpost_coords $firstid]
+ set coord2 [mpost_coords [lindex $objectinfo($id-cplist) 1]]
+
+ set coords ""
+ set loop 0
+ if {$numcp == 2} {
+ set coords "$coord1--$coord2"
+ } elseif {$numcp == 3} {
+ set coord3 [mpost_coords $lastid]
+ if {$objectinfo($firstid-attached) != -1 && \
+ $objectinfo($firstid-attached) == $objectinfo($lastid-attached)} {
+ # state points to itself, use angles
+ set loop 1
+ set point "s$objectinfo($firstid-attached)"
+ set startangle $objectinfo($firstid-angle)
+ set endangle [expr {$objectinfo($lastid-angle) + 180}]
+ if {[automaton]} {
+ set coords "directionpoint dir [expr {$startangle + 90}] of bpath $point..controls $coord2 and $coord2..directionpoint dir [expr {$endangle - 90}] of bpath $point"
+ } else {
+ set coords "$point.c..controls $coord2 and $coord2..$point.c"
+ }
+ } else {
+ if {$objectinfo($id-bisect)} {
+ # interpolate the two control points by bisecting the
+ # lines from the endpoints to the single control point
+ set coords "$coord1..controls .5\[$coord1,$coord2\] and .5\[$coord2,$coord3\]..$coord3"
+ } else {
+ # use the endpoint as second control point
+ set coords "$coord1..controls $coord2 and $coord3..$coord3"
+ }
+ }
+ } elseif {$numcp == 4} {
+ if {$objectinfo($firstid-attached) != -1 && \
+ $objectinfo($firstid-attached) == $objectinfo($lastid-attached)} {
+ # state points to itself, use angles
+ set loop 1
+ set coord3 [mpost_coords [lindex $objectinfo($id-cplist) 2]]
+ set startangle $objectinfo($firstid-angle)
+ set endangle [expr {$objectinfo($lastid-angle) + 180}]
+ set point "s$objectinfo($firstid-attached)"
+ if {[automaton]} {
+ set coords "directionpoint dir [expr {$startangle + 90}] of bpath $point..controls $coord2 and $coord3..directionpoint dir [expr {$endangle - 90}] of bpath $point"
+ } else {
+ set coords "$point.c..controls $coord2 and $coord3..$point.c"
+ }
+ } else {
+ set coord3 [mpost_coords [lindex $objectinfo($id-cplist) 2]]
+ set coord4 [mpost_coords $lastid]
+ set coords "$coord1..controls $coord2 and $coord3..$coord4"
+ }
+ }
+
+ if {[automaton] && !$loop} {
+ if {$objectinfo($firstid-attached) != -1} {
+ set coords "$coords cutbefore bpath s$objectinfo($firstid-attached)"
+ }
+
+ if {$objectinfo($lastid-attached) != -1} {
+ set coords "$coords cutafter bpath s$objectinfo($lastid-attached)"
+ }
+ }
+
+ return $coords;
+}
+
+proc save_metapost {file} {
+ global PROGRAM VERSION objectinfo ahangle ahlength filecomment
+ global fileauthor verbatimtex
+
+ set fid [open $file w]
+ puts $fid "% Creator: $PROGRAM $VERSION"
+ puts $fid "% Creation-Date: [clock format [clock seconds]]"
+ if {$fileauthor != ""} { puts $fid "% Author: $fileauthor" }
+ regsub -all {\n} $filecomment "\n% " exportcomment
+ if {$exportcomment != ""} { puts $fid "% Comment: $exportcomment" }
+
+ if {$verbatimtex != ""} { puts $fid "verbatimtex $verbatimtex etex" }
+ puts $fid ""
+ puts $fid "input boxes"
+ puts $fid "% Breadth of arrowheads (MetaPost default is 45)"
+ puts $fid "ahangle := $ahangle;"
+ puts $fid "% Length of arrowheads (MetaPost default is 4bp)"
+ puts $fid "ahlength := $ahlength;"
+ puts $fid "beginfig(1);"
+ puts $fid "% for temporary paths (might be unused)"
+ puts $fid {path p[];}
+ puts $fid ""
+ puts $fid "% First, define and draw all the states"
+
+ if {[digraph]} { puts $fid {pair s[].c;} }
+
+ foreach id [lsort -integer [get_objects_type "state"]] {
+ set lbl "\"$objectinfo($id-label)\""
+ if {$objectinfo($id-tex) != ""} {
+ set lbl "btex $objectinfo($id-tex) etex"
+ }
+
+ if {[automaton]} {
+ puts $fid "circleit.s${id}($lbl);"
+ puts $fid "s$id.c = [mpost_coords $id];"
+ if {$objectinfo($id-start)} {
+ puts $fid "pickup pencircle scaled 1.2bp;"
+ puts $fid "drawboxed(s$id);"
+ puts $fid "pickup defaultpen;"
+ } else {
+ puts $fid "drawboxed(s$id);"
+ }
+ if {$objectinfo($id-accept)} {
+ puts $fid "draw fullcircle scaled 0.85(ypart s$id.n - ypart s$id.s) shifted s$id.c;"
+ }
+ } elseif {[digraph]} {
+ puts $fid "s$id.c = [mpost_coords $id];"
+ puts $fid "draw s$id.c withpen pencircle scaled 5pt;"
+ }
+ puts $fid ""
+ }
+
+
+ puts $fid "\n% Next, draw the lines"
+ foreach id [lsort -integer [get_objects_type "line"]] {
+ set coords [mpost_line $id]
+ if {$objectinfo($id-tex) != ""} {
+ puts $fid "p$id = $coords;"
+ if {[automaton]} {
+ puts $fid "drawarrow p$id;"
+ } else {
+ puts $fid "drawarrow subpath (0,0.86) of p$id;"
+ }
+ puts $fid "label.$objectinfo($id-anchor)(btex $objectinfo($id-tex) etex, point $objectinfo($id-texpos) of p$id);"
+ } else {
+ if {[automaton]} {
+ puts $fid "drawarrow $coords;"
+ } else {
+ set numcp [llength $objectinfo($id-cplist)]
+ if {$numcp == 2} {
+ puts $fid "drawarrow subpath (0,0.92) of ($coords);"
+ } else {
+ puts $fid "drawarrow subpath (0,0.82) of ($coords);"
+ }
+ }
+ }
+ puts $fid ""
+ }
+
+ puts $fid "\n% Finally, create labels"
+ foreach id [lsort -integer [get_objects_type "text"]] {
+ set x [mpost_scale $objectinfo($id-x)]
+ set y [mpost_scale [expr {-$objectinfo($id-y)}]]
+ set lbl "\"$objectinfo($id-label)\""
+ if {$objectinfo($id-tex) != ""} {
+ set lbl "btex $objectinfo($id-tex) etex"
+ }
+ puts $fid "label($lbl, ($x, $y));"
+ }
+
+ puts $fid "\nendfig;\nend"
+ close $fid
+}
+
+proc export_metapost {{choose 0}} {
+ global export_mp_file batchmode currentfile
+ if {$batchmode} {
+ if {[regexp "\.fin$" $currentfile]} {
+ regsub {fin$} $currentfile {mp} export_mp_file
+ } else {
+ set export_mp_file "${currentfile}.mp"
+ }
+ puts "Exporting to $export_mp_file."
+ } else {
+ if {$export_mp_file == "" || $choose} {
+ set ifile "[file rootname [file tail $currentfile]].mp"
+ set export_mp_file [tk_getSaveFile -defaultextension ".mp" -initialfile $ifile -filetypes {{MetaPost .mp} {All *}}]
+ if {$export_mp_file == ""} { return -1 }
+ global needs_save
+ set needs_save 1
+ }
+ }
+
+ if {[catch [list save_metapost $export_mp_file]]} {
+ set msg "Could not write to $export_mp_file."
+ if {$batchmode} {
+ puts "Error: $msg"
+ } else {
+ tk_messageBox -icon error -message $msg
+ }
+ return -1
+ }
+
+ return 0
+}
+
+
+proc save_native {file} {
+ global VERSION PROGRAM
+ upvar #0 objectinfo oi
+
+ set fid [open $file w]
+ puts $fid "# Creator: $PROGRAM $VERSION"
+ puts $fid "# Creation-Date: [clock format [clock seconds]]"
+
+ # internal IDs of states are normalised to 1...n to avoid
+ # introducing differences by saving an unchanged file
+
+ array set statemap {}
+ set stateid 0
+
+ foreach id [lsort -integer [get_objects_type "state"]] {
+ set lblstring "label [list $oi($id-label)]"
+ set texstring "tex [list $oi($id-tex)]"
+ incr stateid
+ set statemap($id) $stateid
+ puts $fid "object state id $stateid x $oi($id-x) y $oi($id-y) radius $oi($id-radius) $lblstring $texstring accept $oi($id-accept) start $oi($id-start)"
+ }
+
+ foreach id [lsort -integer [get_objects_type "line"]] {
+ puts -nonewline $fid "object line"
+ set cpnum 0
+ foreach cp $oi($id-cplist) {
+ incr cpnum
+ if {$oi($cp-attached) == -1} {
+ puts -nonewline $fid " cp${cpnum}attached -1 cp${cpnum}x $oi($cp-x) cp${cpnum}y $oi($cp-y)"
+ } else {
+ puts -nonewline $fid " cp${cpnum}attached $statemap($oi($cp-attached)) cp${cpnum}angle $oi($cp-angle)"
+ }
+ }
+ set texstring "tex [list $oi($id-tex)] texpos $oi($id-texpos) anchor $oi($id-anchor)"
+ puts $fid " cpnum $cpnum $texstring bisect $oi($id-bisect)"
+ }
+
+ foreach id [lsort -integer [get_objects_type "text"]] {
+ set lblstring "label [list $oi($id-label)]"
+ set texstring "tex [list $oi($id-tex)]"
+
+ puts $fid "object text x $oi($id-x) y $oi($id-y) $lblstring $texstring"
+ }
+
+ global modifiable_params
+ foreach mp $modifiable_params {
+ if {[uplevel #0 "string compare $$mp $${mp}_default"]} {
+ global $mp
+ set val [list [subst $$mp]]
+ puts $fid "object setting variable $mp value $val"
+ }
+ }
+
+ close $fid
+}
+
+proc clear_all {} {
+ global objectinfo maincanvas selectedlist needs_save batchmode
+ if {!$batchmode} { $maincanvas delete all }
+ array unset objectinfo
+ set selectedlist ""
+ set needs_save 0
+ reset_all_parameters
+}
+
+proc save_file {{choose 0}} {
+ global currentfile needs_save
+ set oldcurrentfile $currentfile
+ if {$currentfile == "" || $choose} {
+ set currentfile [tk_getSaveFile -defaultextension ".fin" -filetypes {{Finomaton .fin} {All *}}]
+ if {$currentfile == ""} { return -1 }
+ }
+
+ if {[catch [list save_native $currentfile]]} {
+ tk_messageBox -icon error -message "Could not write to $currentfile."
+ set currentfile $oldcurrentfile
+ return -1
+ }
+
+ set needs_save 0
+ set_window_title
+ return 0
+}
+
+
+proc load_native {file} {
+ global objectinfo modifiable_params
+
+ array set statemap {}
+ set fid [open $file r]
+ set wholeobject ""
+ while {![eof $fid]} {
+ gets $fid oneline
+ if {[eof $fid]} { break }
+ if {$wholeobject == "" && [regexp {^#} $oneline]} { continue }
+ append wholeobject $oneline
+ if {![info complete $wholeobject]} {
+ append wholeobject "\n"
+ continue
+ }
+
+ eval "array set object {$wholeobject}"
+ set wholeobject ""
+
+ if {$object(object) == "setting"} {
+ set var $object(variable)
+ if {[lsearch $modifiable_params $var] == -1} {
+ continue
+ }
+ uplevel #0 [list set $var $object(value)]
+ array unset object
+ continue
+ }
+
+ set id -1
+ if {$object(object) == "state"} {
+ set id [create_state $object(x) $object(y) $object(radius)]
+ set statemap($object(id)) $id
+ set objectinfo($id-label) $object(label)
+ set objectinfo($id-tex) $object(tex)
+ set objectinfo($id-accept) $object(accept)
+ set objectinfo($id-start) $object(start)
+ } elseif {$object(object) == "line"} {
+ set id [create_line 0 0 0]
+ set objectinfo($id-tex) $object(tex)
+ set objectinfo($id-texpos) $object(texpos)
+ set objectinfo($id-anchor) $object(anchor)
+ set objectinfo($id-bisect) \
+ [expr [info exists object(bisect)] ? {$object(bisect)} : 0]
+
+ for {set i 1} {$i <= $object(cpnum)} {incr i} {
+ set cp [add_control_point $id 0 0 0]
+ if {$object(cp${i}attached) != -1} {
+ set attachedto $statemap($object(cp${i}attached))
+ set objectinfo($cp-attached) $attachedto
+ set objectinfo($cp-angle) $object(cp${i}angle)
+ set coords [anchor_coords $attachedto $objectinfo($cp-angle)]
+ set objectinfo($cp-x) [lindex $coords 0]
+ set objectinfo($cp-y) [lindex $coords 1]
+ } else {
+ set objectinfo($cp-x) $object(cp${i}x)
+ set objectinfo($cp-y) $object(cp${i}y)
+ }
+ # don't use update_object, since the line might not be complete
+ update_oval $cp
+ }
+ } elseif {$object(object) == "text"} {
+ set id [create_text $object(x) $object(y)]
+ set objectinfo($id-label) $object(label)
+ set objectinfo($id-tex) $object(tex)
+ }
+ update_object $id
+ array unset object
+ }
+
+ if {$wholeobject != ""} { error "premature end of file" }
+ close $fid
+ check_parameters
+}
+
+proc ask_save {title} {
+ set response [tk_messageBox -icon question -type yesnocancel -title $title -message "File modified. Save changes?"]
+ return $response
+}
+
+proc needs_save {} {
+ global needs_save
+ return $needs_save
+}
+
+proc exit_yesno {} {
+ global PROGRAM
+ if {[needs_save]} {
+ set response [ask_save "Exit"]
+ if {$response == "cancel"} {
+ return
+ } elseif {$response == "yes"} {
+ if {[save_file] == -1} {
+ return
+ }
+ }
+ exit
+ } else {
+ set response [tk_messageBox -icon question -type yesno -title "Exit" -message "Really exit $PROGRAM?"]
+ if {$response} { exit }
+ }
+}
+
+proc set_window_title {} {
+ global windowtitle currentfile
+ if {$currentfile == ""} {
+ wm title . $windowtitle
+ } else {
+ wm title . "$windowtitle - $currentfile"
+ }
+}
+
+proc new_file {} {
+ if {[needs_save]} {
+ set response [ask_save "New"]
+ if {$response == "yes"} {
+ if {[save_file] == -1} {
+ return
+ }
+ } elseif {$response == "cancel"} {
+ return
+ }
+ }
+ global currentfile
+ set currentfile ""
+ set_window_title
+ clear_all
+}
+
+proc load_file {file} {
+ global PROGRAM batchmode
+ if {![file exists $file] || ![file readable $file]} {
+ set msg "File $file does not exist or is not readable."
+ if {$batchmode} {
+ puts "Error: $msg"
+ } else {
+ tk_messageBox -icon error -message $msg
+ }
+ return -1
+ }
+
+ clear_all
+ if {[catch [list load_native $file]]} {
+ set msg "File $file contains no or corrupted graph, or your version of $PROGRAM is outdated."
+ if {$batchmode} {
+ puts "Error: $msg"
+ } else {
+ tk_messageBox -icon error -message $msg
+ }
+ clear_all
+ return -1
+ } else {
+ global currentfile
+ set currentfile $file
+
+ if {!$batchmode} {
+ set_window_title
+ hide_control_points
+ }
+ }
+ return 0
+}
+
+proc open_file {} {
+ if {[needs_save]} {
+ set response [ask_save "Open"]
+ if {$response == "cancel"} {
+ return
+ } elseif {$response == "yes"} {
+ if {[save_file] == -1} {
+ return
+ }
+ }
+ }
+ set file [tk_getOpenFile -defaultextension ".fin" -filetypes {{Finomaton .fin} {All *}}]
+ if {$file == ""} { return }
+ load_file $file
+}
+
+# Execution entry point. Batch-process or set up the main window.
+
+
+if {[llength $argv] > 0 && [lindex $argv 0] == "-exportmp"} {
+ set filelist [lreplace $argv 0 0]
+ if {[llength $filelist] > 0} {
+ set batchmode 1
+ foreach file $filelist {
+ set unid 0
+ if {[load_file $file] != -1} {
+ puts "Processing $file..."
+ export_metapost
+ }
+ }
+ exit
+ }
+}
+
+frame .themenu
+menubutton .themenu.file -text "File" -menu .themenu.file.m
+set m [menu .themenu.file.m]
+$m add command -label "New" -command new_file
+$m add command -label "Open... (C-o)" -command open_file
+$m add command -label "Save (C-s)" -command save_file
+$m add command -label "Save as..." -command "save_file 1"
+$m add command -label "Settings..." -command settings
+$m add command -label "Export MetaPost... (C-m)" -command "export_metapost 1"
+
+$m add separator
+$m add command -label Exit -command exit_yesno
+
+menubutton .themenu.help -text "Help" -menu .themenu.help.m
+set m [menu .themenu.help.m]
+$m add command -label "About..." -command about
+pack .themenu.file -side left -padx 5 -pady 5
+pack .themenu.help -side right -padx 5 -pady 5
+pack .themenu -fill x
+
+
+set commandsframe [frame .commands]
+# these variable names must equal the respective button's name
+set command_select \
+ [button $commandsframe.command_select -text "Select" -underline 1]
+set command_newstate \
+ [button $commandsframe.command_newstate -text "New state" -underline 4]
+set command_newline \
+ [button $commandsframe.command_newline -text "New line" -underline 4]
+set command_newtext \
+ [button $commandsframe.command_newtext -text "New text" -underline 4]
+set command_newcp \
+ [button $commandsframe.command_newcp -text "Control point" -underline 0]
+set command_remove \
+ [button $commandsframe.command_remove -text "Remove" -underline 0]
+set command_balancex \
+ [button $commandsframe.command_balancex -text "| x" -underline 4]
+set command_balancey \
+ [button $commandsframe.command_balancey -text "-- y" -underline 4]
+
+foreach b {select newstate newline newtext newcp remove balancex balancey} {
+ set path [subst "\$command_$b"]
+ pack $path -side top -fill both -expand yes -padx 5 -pady 5
+ bind $path <ButtonPress-1> "set_command $b ; break"
+}
+
+set coordslabel [label $commandsframe.corodslabel]
+pack $coordslabel -side bottom -expand yes -padx 5 -pady 5
+
+proc balance {which} {
+ global selectedlist objectinfo
+
+ set first [lindex $selectedlist 0]
+ foreach id $selectedlist {
+ set objectinfo($id-$which) $objectinfo($first-$which)
+ update_object $id
+ }
+}
+
+bind $commandsframe.command_balancex <ButtonPress-1> "balance x"
+bind $commandsframe.command_balancey <ButtonPress-1> "balance y"
+
+set canvasframe [frame .canvasframe]
+set border [frame $canvasframe.border -relief ridge -borderwidth 5]
+set maincanvas [canvas $border.maincanvas -width 320 -height 300 \
+ -xscrollcommand "$canvasframe.xbar set" \
+ -yscrollcommand "$canvasframe.ybar set" -scrollregion "0 0 800 640"]
+pack $maincanvas -expand yes -fill both
+
+set xbar [scrollbar $canvasframe.xbar -orient horizontal \
+ -command "$maincanvas xview"]
+set ybar [scrollbar $canvasframe.ybar -orient vertical \
+ -command "$maincanvas yview"]
+grid $border $ybar
+grid $xbar x
+grid configure $border -sticky nesw
+grid configure $xbar -sticky ew
+grid configure $ybar -sticky ns
+grid columnconfigure $canvasframe 0 -weight 1
+grid rowconfigure $canvasframe 0 -weight 1
+
+pack $commandsframe -side left -padx 5 -pady 5
+pack $canvasframe -side left -padx 5 -pady 5 -expand yes -fill both
+
+proc canvascoords {x y} {
+ global maincanvas
+ return "[$maincanvas canvasx $x] [$maincanvas canvasy $y]"
+}
+
+proc spread {which} {
+ global selectedlist objectinfo
+
+ if {[llength $selectedlist] <= 1} { return }
+ set min ""
+ set max ""
+ set objs {}
+ foreach id $selectedlist {
+ set obj $objectinfo($id-$which)
+ lappend objs [list $obj $id]
+ if {$min == "" || $obj < $min} { set min $obj }
+ if {$max == "" || $obj > $max} { set max $obj }
+ }
+
+ set range [expr {$max - $min}]
+ if {$range == 0} { return }
+
+ set increment [expr double($range) / ([llength $selectedlist] - 1)]
+
+ set curr $min
+ foreach e [lsort -real -index 0 $objs] {
+ set id [lindex $e 1]
+ set objectinfo($id-$which) $curr
+ update_object $id
+ set curr [expr {$curr + $increment}]
+ }
+}
+
+bind $maincanvas <h> "spread x"
+bind $maincanvas <v> "spread y"
+
+bind $maincanvas <x> "balance x"
+bind $maincanvas <y> "balance y"
+
+bind $maincanvas <l> "set_command newline"
+bind $maincanvas <c> "set_command newcp"
+bind $maincanvas <r> "set_command remove"
+bind $maincanvas <s> "set_command newstate"
+bind $maincanvas <t> "set_command newtext"
+bind $maincanvas <e> "set_command select"
+
+bind $maincanvas <ButtonPress-1> {
+ canvas_clicked $currentcommand [canvascoords %x %y]
+}
+
+bind $maincanvas <Motion> {
+ $coordslabel configure -text [canvascoords %x %y]
+}
+
+bind $maincanvas <B1-Motion> {
+ set coords [canvascoords %x %y]
+ $coordslabel configure -text $coords
+ if {$dragobject == -1} {
+ set dragend $coords
+ eval $maincanvas coords $dragrectangleid $dragstart $dragend
+ } else {
+ if {$currentcommand == "select"} {
+ set needs_save 1
+ move_objects [canvascoords %x %y]
+ }
+ }
+}
+
+bind $maincanvas <ButtonRelease-1> {
+ if {$dragobject == -1 && $currentcommand == "select"} {
+ if {$dragrectangleid != -1} {
+ $maincanvas delete $dragrectangleid
+ }
+ set dragrectangleid -1
+ set x [lsort -real "[lindex $dragstart 0] [lindex $dragend 0]"]
+ set y [lsort -real "[lindex $dragstart 1] [lindex $dragend 1]"]
+ set items [$maincanvas find enclosed [lindex $x 0] \
+ [lindex $y 0] [lindex $x 1] [lindex $y 1]]
+ foreach i $items {
+ if {$objectinfo($i-type) == "statelabel" || \
+ $objectinfo($i-type) == "acceptcircle"} {
+ continue
+ }
+ add_select $i
+ }
+ }
+}
+
+
+bind $maincanvas <Control-B1-Motion> {
+ set needs_save 1
+ set coords [canvascoords %x %y]
+ $coordslabel configure -text $coords
+ if {$currentcommand == "select"} { move_objects $coords }
+}
+
+bind $maincanvas <Control-ButtonRelease-1> {
+ if {$dragrectangleid != -1} {
+ $maincanvas delete $dragrectangleid
+ set dragrectangleid -1
+ }
+}
+
+bind $maincanvas <Control-ButtonPress-1> { toggle_select [canvascoords %x %y] }
+bind $maincanvas <Double-Button-1> { double_click [canvascoords %x %y] }
+bind $maincanvas <Control-o> { open_file; break }
+bind $maincanvas <Control-s> { save_file; break }
+bind $maincanvas <Control-m> { export_metapost; break }
+bind $maincanvas <Alt-x> { exit_yesno; break }
+bind $maincanvas <Delete> {
+ while {[llength $selectedlist] > 0} {
+ remove_object [lindex $selectedlist 0]
+ }
+}
+
+proc move_all_delta {dx dy} {
+ # this differs from move_objects in that magnetic states are ignored
+ global selectedlist objectinfo needs_save
+ set needs_save 1
+ foreach id $selectedlist {
+ if {$objectinfo($id-type) == "controlpoint"} {
+ set objectinfo($id-attached) -1
+ }
+ move_delta $id $dx $dy
+ }
+}
+
+bind $maincanvas <Up> { move_all_delta 0 -1 }
+bind $maincanvas <Right> { move_all_delta 1 0 }
+bind $maincanvas <Down> { move_all_delta 0 1 }
+bind $maincanvas <Left> { move_all_delta -1 0 }
+
+wm title . $windowtitle
+wm protocol . WM_DELETE_WINDOW { exit_yesno }
+
+set win .
+wm withdraw $win
+update idletasks
+set x [expr {[winfo screenwidth $win]/2 - [winfo reqwidth $win]/2}]
+set y [expr {[winfo screenheight $win]/2 - [winfo reqheight $win]/2}]
+wm geometry $win "+$x+$y"
+wm deiconify $win
+wm minsize $win [winfo reqwidth $win] [winfo reqheight $win]
+
+set_command select
+
+if {$argc > 0} { load_file [lindex $argv 0] }
+
+focus $maincanvas