From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- graphics/finomaton/finomaton.tcl | 1735 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 1735 insertions(+) create mode 100644 graphics/finomaton/finomaton.tcl (limited to 'graphics/finomaton/finomaton.tcl') 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 { 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 -- cgit v1.2.3