#!/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 { set statebutton 1 } label $f1.lab2 -text "TeX:" entry $f1.ent2 $f1.ent2 insert 0 $objectinfo($id-tex) bind $f1.ent2 { 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 { set statebutton 1 } label $f2.lab2 -text "Y:" entry $f2.ent2 -width 6 $f2.ent2 insert 0 $objectinfo($id-y) bind $f2.ent2 { 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 { 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 { 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 { 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 "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 "balance x" bind $commandsframe.command_balancey "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 "spread x" bind $maincanvas "spread y" bind $maincanvas "balance x" bind $maincanvas "balance y" bind $maincanvas "set_command newline" bind $maincanvas "set_command newcp" bind $maincanvas "set_command remove" bind $maincanvas "set_command newstate" bind $maincanvas "set_command newtext" bind $maincanvas "set_command select" bind $maincanvas { canvas_clicked $currentcommand [canvascoords %x %y] } bind $maincanvas { $coordslabel configure -text [canvascoords %x %y] } bind $maincanvas { 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 { 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 { set needs_save 1 set coords [canvascoords %x %y] $coordslabel configure -text $coords if {$currentcommand == "select"} { move_objects $coords } } bind $maincanvas { if {$dragrectangleid != -1} { $maincanvas delete $dragrectangleid set dragrectangleid -1 } } bind $maincanvas { toggle_select [canvascoords %x %y] } bind $maincanvas { double_click [canvascoords %x %y] } bind $maincanvas { open_file; break } bind $maincanvas { save_file; break } bind $maincanvas { export_metapost; break } bind $maincanvas { exit_yesno; break } bind $maincanvas { 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 { move_all_delta 0 -1 } bind $maincanvas { move_all_delta 1 0 } bind $maincanvas { move_all_delta 0 1 } bind $maincanvas { 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