Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.

Dismiss

v23i007: pips - a generic graphical editor for Petri Nets, Part01/03

7 views

Skip to first unread message

Gunther Schadow

unread,

Mar 14, 1995, 9:57:09 PM3/14/95

Submitted-by: gu...@zedat.fu-berlin.de (Gunther Schadow)
Posting-number: Volume 23, Issue 7
Archive-name: pips/part01
Environment: X11, Tcl/Tk, petri nets

[I had some trouble with this, possibly due to an old version of Tk/Tcl]
[ -- chris ]

*****
*
* Pips -- a generic graphical editor for Petri Nets
*
*****

Questionnaire completion date: 15. September 1994

Address
- -----
Tool name: Pips
Version: 0.1 (alpha)
Completion date: 14. September 1994
Contact person(s): Gunther Schadow
Organisation name:
Organisation address:
Phone: +49 30 661 8841
Fax: +49 30 661 8841
Email: gu...@fub46.zedat.fu-berlin.de
Other distributors: comp.sources.x

Environment
- ---------
Computer systems (ex. DOS, Unix, OS2, ect.): Unix
Graphical systems (ex. Motif, OpenLook, Windows, etc.): X11, Tk
Other software required (ex. Run-times): Tcl

Availability
- ----------
Tool fee: free
Maintenance fee: free
Maintenance services: e-mail help
Price for university: free
FTP site where to get the tool: any site which archives comp.sources.x

Functionality:
- --------------
Kind of petri net supported (ex. CPN, SPN , etc.): not restricted to a
certain kind. Current features: place capacities, arrow weights,
individual tokens. Supports modular design.
Availability of a graphical editor ( Yes, No, comments): Yes, Pips
*is* an editor (and currently nothing more, unless I or You extend
it with new features). Pips allows Petri Nets to be graphically
edited, saved, and printed as a PostScript document. The save
files are text files, which can be further processed to interface
arbitrary P/N tools that lack an editor. It is also possible to
implement support for other tools directly into the program, since
Pips is written in Tcl those extensions are easy to realize.
Type of animation: none
Type of performance analysis (ex. steady state, continuous): none
How are the results presented (ex. Graphical repport): no `results'
Additionnal Functionality : Support for modular design. Currently very
scarce, but will be improved in the future. Modules are black
boxes, that interact with their environments only via interface
transitions (also called `parameters'). Thus Modules can be
regarded as `supertransitions'. The inner subnet of a module will
be edited as an extra file on an extra window.

Documentation et informations
- ----------------------------
References:
FTP sites where to get references:
Number of copy released:
Machine implementation language : Tcl/Tk
Language for model annotation : Tcl/Tk
Language of user interface : English
Documentation language: English

Future plans
- ----------
The Module facility will be fully developed, to be able to edit the
module subnet, it's interface and its concrete instance within an
environment. Pips shall eventually work together with LOOPN from
which it is inspired a lot. Thus a graphical animated simulation could
be realized. The future of Pips depends a lot on what people
contribute: any ideas, comments, fixes and extensions are welcome.

#! /bin/sh
# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".
# Contents: pips-0.1-alpha pips-0.1-alpha/COPYING
# pips-0.1-alpha/module.tcl pips-0.1-alpha/transition.tcl
# Wrapped by chris@ftp on Tue Mar 14 17:26:37 1995
PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin:$PATH ; export PATH
echo If this archive is complete, you will see the following message:
echo ' "shar: End of archive 1 (of 3)."'
if test ! -d 'pips-0.1-alpha' ; then
echo shar: Creating directory \"'pips-0.1-alpha'\"
mkdir 'pips-0.1-alpha'
fi
if test -f 'pips-0.1-alpha/COPYING' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/COPYING'\"
else
echo shar: Extracting \"'pips-0.1-alpha/COPYING'\" $17982 characters$
sed "s/^X//" >'pips-0.1-alpha/COPYING' <<'END_OF_FILE'
X GNU GENERAL PUBLIC LICENSE
X Version 2, June 1991
X
X Copyright (C) 1989, 1991 Free Software Foundation, Inc.
X 675 Mass Ave, Cambridge, MA 02139, USA
X Everyone is permitted to copy and distribute verbatim copies
X of this license document, but changing it is not allowed.
X
X Preamble
X
X The licenses for most software are designed to take away your
Xfreedom to share and change it. By contrast, the GNU General Public
XLicense is intended to guarantee your freedom to share and change free
Xsoftware--to make sure the software is free for all its users. This
XGeneral Public License applies to most of the Free Software
XFoundation's software and to any other program whose authors commit to
Xusing it. (Some other Free Software Foundation software is covered by
Xthe GNU Library General Public License instead.) You can apply it to
Xyour programs, too.
X
X When we speak of free software, we are referring to freedom, not
Xprice. Our General Public Licenses are designed to make sure that you
Xhave the freedom to distribute copies of free software (and charge for
Xthis service if you wish), that you receive source code or can get it
Xif you want it, that you can change the software or use pieces of it
Xin new free programs; and that you know you can do these things.
X
X To protect your rights, we need to make restrictions that forbid
Xanyone to deny you these rights or to ask you to surrender the rights.
XThese restrictions translate to certain responsibilities for you if you
Xdistribute copies of the software, or if you modify it.
X
X For example, if you distribute copies of such a program, whether
Xgratis or for a fee, you must give the recipients all the rights that
Xyou have. You must make sure that they, too, receive or can get the
Xsource code. And you must show them these terms so they know their
Xrights.
X
X We protect your rights with two steps: (1) copyright the software, and
X(2) offer you this license which gives you legal permission to copy,
Xdistribute and/or modify the software.
X
X Also, for each author's protection and ours, we want to make certain
Xthat everyone understands that there is no warranty for this free
Xsoftware. If the software is modified by someone else and passed on, we
Xwant its recipients to know that what they have is not the original, so
Xthat any problems introduced by others will not reflect on the original
Xauthors' reputations.
X
X Finally, any free program is threatened constantly by software
Xpatents. We wish to avoid the danger that redistributors of a free
Xprogram will individually obtain patent licenses, in effect making the
Xprogram proprietary. To prevent this, we have made it clear that any
Xpatent must be licensed for everyone's free use or not licensed at all.
X
X The precise terms and conditions for copying, distribution and
Xmodification follow.
X
X GNU GENERAL PUBLIC LICENSE
X TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
X
X 0. This License applies to any program or other work which contains
Xa notice placed by the copyright holder saying it may be distributed
Xunder the terms of this General Public License. The "Program", below,
Xrefers to any such program or work, and a "work based on the Program"
Xmeans either the Program or any derivative work under copyright law:
Xthat is to say, a work containing the Program or a portion of it,
Xeither verbatim or with modifications and/or translated into another
Xlanguage. (Hereinafter, translation is included without limitation in
Xthe term "modification".) Each licensee is addressed as "you".
X
XActivities other than copying, distribution and modification are not
Xcovered by this License; they are outside its scope. The act of
Xrunning the Program is not restricted, and the output from the Program
Xis covered only if its contents constitute a work based on the
XProgram (independent of having been made by running the Program).
XWhether that is true depends on what the Program does.
X
X 1. You may copy and distribute verbatim copies of the Program's
Xsource code as you receive it, in any medium, provided that you
Xconspicuously and appropriately publish on each copy an appropriate
Xcopyright notice and disclaimer of warranty; keep intact all the
Xnotices that refer to this License and to the absence of any warranty;
Xand give any other recipients of the Program a copy of this License
Xalong with the Program.
X
XYou may charge a fee for the physical act of transferring a copy, and
Xyou may at your option offer warranty protection in exchange for a fee.
X
X 2. You may modify your copy or copies of the Program or any portion
Xof it, thus forming a work based on the Program, and copy and
Xdistribute such modifications or work under the terms of Section 1
Xabove, provided that you also meet all of these conditions:
X
X a) You must cause the modified files to carry prominent notices
X stating that you changed the files and the date of any change.
X
X b) You must cause any work that you distribute or publish, that in
X whole or in part contains or is derived from the Program or any
X part thereof, to be licensed as a whole at no charge to all third
X parties under the terms of this License.
X
X c) If the modified program normally reads commands interactively
X when run, you must cause it, when started running for such
X interactive use in the most ordinary way, to print or display an
X announcement including an appropriate copyright notice and a
X notice that there is no warranty (or else, saying that you provide
X a warranty) and that users may redistribute the program under
X these conditions, and telling the user how to view a copy of this
X License. (Exception: if the Program itself is interactive but
X does not normally print such an announcement, your work based on
X the Program is not required to print an announcement.)
X
XThese requirements apply to the modified work as a whole. If
Xidentifiable sections of that work are not derived from the Program,
Xand can be reasonably considered independent and separate works in
Xthemselves, then this License, and its terms, do not apply to those
Xsections when you distribute them as separate works. But when you
Xdistribute the same sections as part of a whole which is a work based
Xon the Program, the distribution of the whole must be on the terms of
Xthis License, whose permissions for other licensees extend to the
Xentire whole, and thus to each and every part regardless of who wrote it.
X
XThus, it is not the intent of this section to claim rights or contest
Xyour rights to work written entirely by you; rather, the intent is to
Xexercise the right to control the distribution of derivative or
Xcollective works based on the Program.
X
XIn addition, mere aggregation of another work not based on the Program
Xwith the Program (or with a work based on the Program) on a volume of
Xa storage or distribution medium does not bring the other work under
Xthe scope of this License.
X
X 3. You may copy and distribute the Program (or a work based on it,
Xunder Section 2) in object code or executable form under the terms of
XSections 1 and 2 above provided that you also do one of the following:
X
X a) Accompany it with the complete corresponding machine-readable
X source code, which must be distributed under the terms of Sections
X 1 and 2 above on a medium customarily used for software interchange; or,
X
X b) Accompany it with a written offer, valid for at least three
X years, to give any third party, for a charge no more than your
X cost of physically performing source distribution, a complete
X machine-readable copy of the corresponding source code, to be
X distributed under the terms of Sections 1 and 2 above on a medium
X customarily used for software interchange; or,
X
X c) Accompany it with the information you received as to the offer
X to distribute corresponding source code. (This alternative is
X allowed only for noncommercial distribution and only if you
X received the program in object code or executable form with such
X an offer, in accord with Subsection b above.)
X
XThe source code for a work means the preferred form of the work for
Xmaking modifications to it. For an executable work, complete source
Xcode means all the source code for all modules it contains, plus any
Xassociated interface definition files, plus the scripts used to
Xcontrol compilation and installation of the executable. However, as a
Xspecial exception, the source code distributed need not include
Xanything that is normally distributed (in either source or binary
Xform) with the major components (compiler, kernel, and so on) of the
Xoperating system on which the executable runs, unless that component
Xitself accompanies the executable.
X
XIf distribution of executable or object code is made by offering
Xaccess to copy from a designated place, then offering equivalent
Xaccess to copy the source code from the same place counts as
Xdistribution of the source code, even though third parties are not
Xcompelled to copy the source along with the object code.
X
X 4. You may not copy, modify, sublicense, or distribute the Program
Xexcept as expressly provided under this License. Any attempt
Xotherwise to copy, modify, sublicense or distribute the Program is
Xvoid, and will automatically terminate your rights under this License.
XHowever, parties who have received copies, or rights, from you under
Xthis License will not have their licenses terminated so long as such
Xparties remain in full compliance.
X
X 5. You are not required to accept this License, since you have not
Xsigned it. However, nothing else grants you permission to modify or
Xdistribute the Program or its derivative works. These actions are
Xprohibited by law if you do not accept this License. Therefore, by
Xmodifying or distributing the Program (or any work based on the
XProgram), you indicate your acceptance of this License to do so, and
Xall its terms and conditions for copying, distributing or modifying
Xthe Program or works based on it.
X
X 6. Each time you redistribute the Program (or any work based on the
XProgram), the recipient automatically receives a license from the
Xoriginal licensor to copy, distribute or modify the Program subject to
Xthese terms and conditions. You may not impose any further
Xrestrictions on the recipients' exercise of the rights granted herein.
XYou are not responsible for enforcing compliance by third parties to
Xthis License.
X
X 7. If, as a consequence of a court judgment or allegation of patent
Xinfringement or for any other reason (not limited to patent issues),
Xconditions are imposed on you (whether by court order, agreement or
Xotherwise) that contradict the conditions of this License, they do not
Xexcuse you from the conditions of this License. If you cannot
Xdistribute so as to satisfy simultaneously your obligations under this
XLicense and any other pertinent obligations, then as a consequence you
Xmay not distribute the Program at all. For example, if a patent
Xlicense would not permit royalty-free redistribution of the Program by
Xall those who receive copies directly or indirectly through you, then
Xthe only way you could satisfy both it and this License would be to
Xrefrain entirely from distribution of the Program.
X
XIf any portion of this section is held invalid or unenforceable under
Xany particular circumstance, the balance of the section is intended to
Xapply and the section as a whole is intended to apply in other
Xcircumstances.
X
XIt is not the purpose of this section to induce you to infringe any
Xpatents or other property right claims or to contest validity of any
Xsuch claims; this section has the sole purpose of protecting the
Xintegrity of the free software distribution system, which is
Ximplemented by public license practices. Many people have made
Xgenerous contributions to the wide range of software distributed
Xthrough that system in reliance on consistent application of that
Xsystem; it is up to the author/donor to decide if he or she is willing
Xto distribute software through any other system and a licensee cannot
Ximpose that choice.
X
XThis section is intended to make thoroughly clear what is believed to
Xbe a consequence of the rest of this License.
X
X 8. If the distribution and/or use of the Program is restricted in
Xcertain countries either by patents or by copyrighted interfaces, the
Xoriginal copyright holder who places the Program under this License
Xmay add an explicit geographical distribution limitation excluding
Xthose countries, so that distribution is permitted only in or among
Xcountries not thus excluded. In such case, this License incorporates
Xthe limitation as if written in the body of this License.
X
X 9. The Free Software Foundation may publish revised and/or new versions
Xof the General Public License from time to time. Such new versions will
Xbe similar in spirit to the present version, but may differ in detail to
Xaddress new problems or concerns.
X
XEach version is given a distinguishing version number. If the Program
Xspecifies a version number of this License which applies to it and "any
Xlater version", you have the option of following the terms and conditions
Xeither of that version or of any later version published by the Free
XSoftware Foundation. If the Program does not specify a version number of
Xthis License, you may choose any version ever published by the Free Software
XFoundation.
X
X 10. If you wish to incorporate parts of the Program into other free
Xprograms whose distribution conditions are different, write to the author
Xto ask for permission. For software which is copyrighted by the Free
XSoftware Foundation, write to the Free Software Foundation; we sometimes
Xmake exceptions for this. Our decision will be guided by the two goals
Xof preserving the free status of all derivatives of our free software and
Xof promoting the sharing and reuse of software generally.
X
X NO WARRANTY
X
X 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
XFOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
XOTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
XPROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
XOR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
XMERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
XTO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
XPROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
XREPAIR OR CORRECTION.
X
X 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
XWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
XREDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
XINCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
XOUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
XTO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
XYOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
XPROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
XPOSSIBILITY OF SUCH DAMAGES.
X
X END OF TERMS AND CONDITIONS
X
X Appendix: How to Apply These Terms to Your New Programs
X
X If you develop a new program, and you want it to be of the greatest
Xpossible use to the public, the best way to achieve this is to make it
Xfree software which everyone can redistribute and change under these terms.
X
X To do so, attach the following notices to the program. It is safest
Xto attach them to the start of each source file to most effectively
Xconvey the exclusion of warranty; and each file should have at least
Xthe "copyright" line and a pointer to where the full notice is found.
X
X <one line to give the program's name and a brief idea of what it does.>
X Copyright (C) 19yy <name of author>
X
X This program is free software; you can redistribute it and/or modify
X it under the terms of the GNU General Public License as published by
X the Free Software Foundation; either version 2 of the License, or
X (at your option) any later version.
X
X This program is distributed in the hope that it will be useful,
X but WITHOUT ANY WARRANTY; without even the implied warranty of
X MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
X GNU General Public License for more details.
X
X You should have received a copy of the GNU General Public License
X along with this program; if not, write to the Free Software
X Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
X
XAlso add information on how to contact you by electronic and paper mail.
X
XIf the program is interactive, make it output a short notice like this
Xwhen it starts in an interactive mode:
X
X Gnomovision version 69, Copyright (C) 19yy name of author
X Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
X This is free software, and you are welcome to redistribute it
X under certain conditions; type `show c' for details.
X
XThe hypothetical commands `show w' and `show c' should show the appropriate
Xparts of the General Public License. Of course, the commands you use may
Xbe called something other than `show w' and `show c'; they could even be
Xmouse-clicks or menu items--whatever suits your program.
X
XYou should also get your employer (if you work as a programmer) or your
Xschool, if any, to sign a "copyright disclaimer" for the program, if
Xnecessary. Here is a sample; alter the names:
X
X Yoyodyne, Inc., hereby disclaims all copyright interest in the program
X `Gnomovision' (which makes passes at compilers) written by James Hacker.
X
X <signature of Ty Coon>, 1 April 1989
X Ty Coon, President of Vice
X
XThis General Public License does not permit incorporating your program into
Xproprietary programs. If your program is a subroutine library, you may
Xconsider it more useful to permit linking proprietary applications with the
Xlibrary. If this is what you want to do, use the GNU Library General
XPublic License instead of this License.
END_OF_FILE
if test 17982 -ne `wc -c <'pips-0.1-alpha/COPYING'`; then
echo shar: \"'pips-0.1-alpha/COPYING'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/COPYING'
fi
if test -f 'pips-0.1-alpha/module.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/module.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/module.tcl'\" $24019 characters$
sed "s/^X//" >'pips-0.1-alpha/module.tcl' <<'END_OF_FILE'
X# module.tcl -- procedures for modules and interface transitions
X#
X# Copyright (C) 1994 Gunther Schadow
X#
X# This file is part of Pips, an editor for Petri Nets.
X#
X# Pips is free software; you can redistribute it and/or modify it under
X# the terms of the GNU General Public License as published by the Free
X# Software Foundation; either version 2, or (at your option) any later
X# version.
X#
X# Pips is distributed in the hope that it will be useful, but WITHOUT
X# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
X# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
X# for more details.
X#
X# You should have received a copy of the GNU General Public License
X# along with Pips; see the file COPYING. If not, write to the Free
X# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
X#
X
X# color defaults
Xset module.fill.color #ffffff
Xset module.outline.color #000000
Xset module.hi.fill.color #ffffff
Xset module.hi.outline.color #808080
Xset mpar.fill.color #ffffff
Xset mpar.outline.color #000000
Xset mpar.hi.fill.color #ffffff
Xset mpar.hi.outline.color #808080
X
X# Procedure: moduleAdd
Xproc moduleAdd { c {item ""} x1 y1 x2 y2 {module ""}} {
X global module.fill.color module.outline.color
X global modules mpars names
X
X if {$item == ""} {
X set item [$c create rectangle $x1 $y1 $x2 $y2 -fill ${module.fill.color} -outline ${module.outline.color}]
X } else {
X $c coords $item $x1 $y1 $x2 $y2
X }
X
X if {$module == ""} {
X set module [nameGen $c module]
X }
X
X set names($item) $module
X
X $c itemconfigure $item -fill ${module.fill.color} -outline ${module.outline.color} -tags "module $module ${module}-part ${item}-part"
X
X set tic1 [ticNew $c $x1 $y1 module $module "$item"]
X set tic2 [ticNew $c $x2 $y2 module $module "$item"]
X
X set modules($module) [list pos "$x1 $y1 $x2 $y2" tic "$tic1 $tic2" cid $item]
X set names($item) $module
X set mpars(nr-$module) 0
X set mpars(ip-$module) {}
X return $module
X}
X
X# Procedure: moduleAddParameter
Xproc moduleAddParameter { c x y {m ""} {name ""}} {
X global mpar.fill.color mpar.outline.color
X global names mpars nodetypes modules
X
X if {$m == ""} {
X set m $names([$c find withtag current])
X }
X if {$name != ""} {set name $m.$name}
X
X set record $modules($m)
X set pos [propGet $record pos]
X set x1 [lindex $pos 0]
X set y1 [lindex $pos 1]
X set x2 [lindex $pos 2]
X set y2 [lindex $pos 3]
X set e 12
X set r 6
X
X if {$x < ($x1 + $e)} {
X set x $x1
X } elseif {$x > ($x2 - $e)} {
X set x $x2
X } elseif {$y < ($y1 + $e)} {
X set y $y1
X } elseif {$y > ($y2 - $e)} {
X set y $y2
X } else {
X set x $x1
X }
X
X set nr [incr mpars(nr-$m)]
X if {$name == ""} {set name $m.mpar$nr}
X set nodetypes($name) mpar
X lappend mpars(ip-$m) $name
X lappend modules(mp-$name) $m
X
X set item [$c create rectangle [expr $x - $r] [expr $y - $r] [expr $x + $r] [expr $y + $r] -fill ${mpar.fill.color} -outline ${mpar.outline.color} -tags "mpar node $m-part $name"]
X
X set record {}
X propPut record pos "$x $y"
X propPut record cid $item
X propPut record pid $nr
X propPut record limit inout
X propPut record desc {}
X set mpars($name) $record
X set names($item) $name
X return $name
X}
X
X
X# Procedure: moduleAnchor
Xproc moduleAnchor { c x y} {
X global lastX lastY anchorX anchorY cDx cDy
X set anchorX $x
X set anchorY $y
X set lastX $x
X set lastY $y
X set cDx 0
X set cDy 0
X
X set item [$c create rectangle $anchorX $anchorY $anchorX $anchorY -outline #808080]
X
X bind $c <1> ""
X bind $c <Button1-ButtonRelease> "moduleFix $c $item \[xlat %W %x\] \[ylat %W %y\]"
X bind $c <Any-Motion> "moduleSpan $c $item \[xlat %W %x\] \[ylat %W %y\]"
X}
X
X
X# Procedure: moduleDelete
Xproc moduleDelete { c {item ""}} {
X global names mpars nodetypes modules tics tictypes
X if {$item == ""} {
X set item [$c find withtag current]
X }
X set module $names($item)
X
X foreach mpar $mpars(ip-$module) {
X mparDelete $c -1 $mpar
X }
X
X foreach tic [propGet $modules($module) tic] {
X unset tics($tic)
X unset tictypes($tic)
X }
X
X unset modules($module)
X unset mpars(ip-$module)
X unset mpars(nr-$module)
X unset names($item)
X $c delete $module-part
X}
X
X# Procedure: mparDelete
Xproc mparDelete { c {item ""} {mpar ""}} {
X global names mpars nodetypes modules
X if {$item == ""} {
X set item [$c find withtag current]
X }
X if {$mpar == ""} {
X set mpar $names($item)
X }
X
X set module $modules(mp-$mpar)
X
X set record $mpars($mpar)
X propIter i e [propGet $record in] {
X arrowDelete $c $i $e $mpar
X }
X propIter i e [propGet $record out] {
X arrowDelete $c $i $mpar $e
X }
X
X unset names([propGet $record cid])
X unset nodetypes($mpar)
X unset mpars($mpar)
X unset modules(mp-$mpar)
X
X set ipmpn [lsearch $mpars(ip-$module) $mpar]
X if {$ipmpn == -1} {
X error "assertion failed in mparDelete
X } else {
X set mpars(ip-$module) [lreplace $mpars(ip-$module) $ipmpn $ipmpn]
X }
X $c delete $mpar
X}
X
X
X# Procedure: moduleDrag
Xproc moduleDrag { c module inlist outlist x y} {
X global lastX lastY cDx cDy
X $c move ${module}-part [expr $x-$lastX] [expr $y-$lastY]
X set cDx [expr $cDx + $x - $lastX]
X set cDy [expr $cDy + $y - $lastY]
X set lastX $x
X set lastY $y
X foreach i $inlist {
X eval arrowDragIn $i $c $cDx $cDy
X }
X foreach i $outlist {
X eval arrowDragOut $i $c $cDx $cDy
X }
X}
X
X
X# Procedure: moduleDragBegin
Xproc moduleDragBegin { c x y} {
X global modules mpars arrows places names lastX lastY cDx cDy
X set module $names([$c find withtag current])
X set cDx 0
X set cDy 0
X set lastX $x
X set lastY $y
X
X set inlist {}
X set outlist {}
X foreach p $mpars(ip-$module) {
X set mp [propGet $mpars($p) pos]
X set x [lindex $mp 0]
X set y [lindex $mp 1]
X propIter arrow end [propGet $mpars($p) in] {
X lappend inlist "$x $y $arrow [propGet $places($end) pos] \"[propGet $arrows($arrow) path]\""
X }
X propIter arrow end [propGet $mpars($p) out] {
X lappend outlist "$x $y $arrow [propGet $places($end) pos] \"[propGet $arrows($arrow) path]\""
X }
X }
X
X $c bind $module <Any-Button3-Motion> "moduleDrag %W $module \{$inlist\} \{$outlist\} \[xlat %W %x\] \[ylat %W %y\]"
X $c bind $module <Any-Button3-ButtonRelease> "moduleDragEnd %W $module \{$inlist\} \{$outlist\} \[xlat %W %x\] \[ylat %W %y\]"
X}
X
X
X# Procedure: moduleDragEnd
Xproc moduleDragEnd { c module inlist outlist x y} {
X $c bind $module <Any-Button3-Motion> ""
X $c bind $module <Any-Button3-ButtonRelease> ""
X
X global lastX lastY cDx cDy modules mpars
X
X $c move ${module}-part [expr $x-$lastX] [expr $y-$lastY]
X
X set cDx [expr $cDx + $x - $lastX]
X set cDy [expr $cDy + $y - $lastY]
X
X set pos [propGet $modules($module) pos]
X set x1 [expr $cDx + [lindex $pos 0]]
X set y1 [expr $cDy + [lindex $pos 1]]
X set x2 [expr $cDx + [lindex $pos 2]]
X set y2 [expr $cDy + [lindex $pos 3]]
X propPut modules($module) pos [list $x1 $y1 $x2 $y2]
X
X foreach i $inlist {
X eval arrowDragIn $i $c $cDx $cDy
X }
X foreach i $outlist {
X eval arrowDragOut $i $c $cDx $cDy
X }
X
X foreach p $mpars(ip-$module) {
X set mp [propGet $mpars($p) pos]
X set x [lindex $mp 0]
X set y [lindex $mp 1]
X propPut mpars($p) pos [list [expr $x + $cDx] [expr $y + $cDy]]
X }
X}
X
X
X# Procedure: moduleEditBegin
Xproc moduleEditBegin { c {w ""}} {
X global modules names
X global moduleName moduleDesc
X
X set module $names([$c find withtag current])
X set moduleName $module
X set moduleRec $modules($module)
X set moduleDesc [propGet $moduleRec desc]
X
X # build widget ${w}.moduleEdit
X catch "destroy ${w}.moduleEdit"
X toplevel ${w}.moduleEdit
X
X # Window manager configurations
X wm positionfrom ${w}.moduleEdit ""
X wm sizefrom ${w}.moduleEdit ""
X wm title ${w}.moduleEdit {Module}
X
X wdg_entry ${w}.moduleEdit.name {Name:} moduleName
X wdg_text ${w}.moduleEdit.desc Description moduleDesc
X wdg_confirm ${w}.moduleEdit.confirm "moduleEditEnd $c $w.moduleEdit $module"
X
X # pack widget ${w}.moduleEdit
X pack ${w}.moduleEdit.name -side top -fill x
X pack ${w}.moduleEdit.desc -side top -fill x
X pack ${w}.moduleEdit.confirm -side top -fill x
X
X tkwait visibility ${w}.moduleEdit
X grab set ${w}.moduleEdit
X}
X
X
X# Procedure: moduleEditEnd
Xproc moduleEditEnd { c w module ok} {
X destroy $w
X
X if {$ok == "ok"} {
X global modules
X global moduleName moduleDesc
X
X set moduleRec $modules($module)
X if {$moduleName != $module} {
X moduleRename $c $module $moduleName
X set module $moduleName
X }
X
X propPut moduleRec desc $moduleDesc
X
X set modules($module) $moduleRec
X }
X}
X
X
X# Procedure: moduleEnter
Xproc moduleEnter { c} {
X global module.hi.fill.color module.hi.outline.color
X global names currentNode
X set module [$c find withtag current]
X set currentNode $names($module)
X $c itemconfigure $module -fill ${module.hi.fill.color} -outline ${module.hi.outline.color}
X}
X
X
X# Procedure: moduleFix
Xproc moduleFix { c item x y} {
X global anchorX anchorY modules names
X
X bind $c <1> {moduleAnchor %W [xlat %W %x] [ylat %W %y]}
X bind $c <Button1-ButtonRelease> ""
X bind $c <Any-Motion> ""
X
X modulePosOrd anchorX anchorY x y
X
X moduleAdd $c $item $anchorX $anchorY $x $y
X}
X
X
X# Procedure: moduleLeave
Xproc moduleLeave { c} {
X global module.fill.color module.outline.color
X global currentNode
X set currentNode {}
X set module [$c find withtag current]
X $c itemconfigure $module -fill ${module.fill.color} -outline ${module.outline.color}
X}
X
X
X# Procedure: moduleModeEnter
Xproc moduleModeEnter { c} {
X bind $c <1> {moduleAnchor %W [xlat %W %x] [ylat %W %y]}
X $c bind module <3> {moduleAddParameter %W [xlat %W %x] [ylat %W %y]}
X}
X
X
X# Procedure: moduleModeLeave
Xproc moduleModeLeave { c} {
X bind $c <1> ""
X $c bind module <3> ""
X}
X
X
X# Procedure: modulePosOrd
Xproc modulePosOrd { px1 py1 px2 py2} {
X upvar $px1 x1 $px2 x2 $py1 y1 $py2 y2
X if {$x1 > $x2} {set a $x1 ; set x1 $x2 ; set x2 $a}
X if {$y1 > $y2} {set a $y1 ; set y1 $y2 ; set y2 $a}
X}
X
X
X# Procedure: moduleRename
Xproc moduleRename { c oldname newname} {
X global nodetypes names arrows transitions places mpars modules tics
X
X if {[$c find withtag $newname] == ""} {
X # change name entry in canvas objects
X $c addtag $newname withtag $oldname
X $c dtag $newname $oldname
X
X # change name entry in id -> name mapping
X set names([$c find withtag $newname]) $newname
X
X # change name entry in plist array
X set modules($newname) $modules($oldname)
X unset modules($oldname)
X
X # change name entry in tics
X $c addtag $newname-part withtag $oldname-part
X $c dtag $newname-part $oldname-part
X $c addtag $newname-tic withtag $oldname-tic
X $c dtag $newname-tic $oldname-tic
X
X foreach tic [propGet $modules($newname) tic] {
X set tics($tic) $newname
X }
X
X # cange name for parameter list
X set mparl [set mpars(ip-$newname) $mpars(ip-$oldname)]
X unset mpars(ip-$oldname)
X set mpars(nr-$newname) $mpars(nr-$oldname)
X unset mpars(nr-$oldname)
X
X foreach oldnamemp $mparl {
X if {[regsub "^$oldname\\.(.+)\$" $oldnamemp "$newname.\\1" newnamemp]
X == 0} {
X error "assertion failed in moduleRename, fatal!"
X }
X
X if {[$c find withtag $newnamemp] == ""} {
X # change namemp entry in canvas objects
X $c addtag $newnamemp withtag $oldnamemp
X $c dtag $newnamemp $oldnamemp
X
X # change namemp entry in id -> namemp mapping
X set names([$c find withtag $newnamemp]) $newnamemp
X
X # change namemp in nodetypes
X set nodetypes($newnamemp) $nodetypes($oldnamemp)
X unset nodetypes($oldnamemp)
X
X # change namemp entry in plist array
X set mpars($newnamemp) $mpars($oldnamemp)
X unset mpars($oldnamemp)
X
X # change namemp entries in references
X propIter arrow end [propGet $mpars($newnamemp) in] {
X propPut arrows($arrow) aim $newnamemp
X set reflist [eval propGet $$nodetypes($end)s($end) out]
X propPut reflist $arrow $newnamemp
X propPut $nodetypes($end)s($end) out $reflist
X }
X propIter arrow end [propGet $mpars($newnamemp) out] {
X propPut arrows($arrow) org $newnamemp
X set reflist [eval propGet $$nodetypes($end)s($end) in]
X propPut reflist $arrow $newnamemp
X propPut $nodetypes($end)s($end) in $reflist
X }
X
X set modules(mp-$newnamemp) $newname
X unset modules(mp-$oldnamemp)
X set mip $mpars(ip-$newname)
X set mipnr [lsearch $mip $oldnamemp]
X if {$mipnr == -1} {
X error "assertion failed in nodeRenamemp"
X }
X set mpars(ip-$newname) [lreplace $mip $mipnr $mipnr $newnamemp]
X } else {
X error "new name is not unique: $newname. This is a very fatal error! You better save now and edit the text!"
X }
X }
X } else {
X error "new name is not unique: $newname"
X }
X}
X
X
X# Procedure: moduleSpan
Xproc moduleSpan { c item x y {xmin "-1"} {xmax "-1"} {ymin "-1"} {ymax "-1"} {mvl ""} {mhl ""}} {
X
X global lastX lastY anchorX anchorY
X global cDx cDy
X
X if {($xmax != -1) && ($x > $xmax)} {set x $xmax}
X if {($xmin != -1) && ($x < $xmin)} {set x $xmin}
X if {($ymax != -1) && ($y > $ymax)} {set y $ymax}
X if {($ymin != -1) && ($y < $ymin)} {set y $ymin}
X
X $c coords $item $anchorX $anchorY $x $y
X
X set dx [expr $x - $lastX]
X set dy [expr $y - $lastY]
X set cDx [expr $cDx + $dx]
X set cDy [expr $cDy + $dy]
X set lastX $x
X set lastY $y
X
X if {$dx != 0} {
X propIter par arrs $mvl {
X $c move $par $dx 0
X foreach a $arrs {
X eval eval arrowDrag$a $c $cDx 0
X }
X }
X }
X if {$dy != 0} {
X propIter par arrs $mhl {
X $c move $par 0 $dy
X foreach a $arrs {
X eval eval arrowDrag$a $c 0 $cDy
X }
X }
X }
X}
X
X
X# Procedure: moduleTicBegin
Xproc moduleTicBegin { c} {
X
X global lastX lastY anchorX anchorY cDx cDy
X global module tic tics ticbinding
X global modules mpars places arrows
X
X set tic [$c find withtag current]
X set module $tics($tic)
X set plist $modules($module)
X set ticl [propGet $plist tic]
X set pos [propGet $plist pos]
X
X set cDx 0
X set cDy 0
X set xmin -1
X set ymin -1
X set xmax -1
X set ymax -1
X
X if {$tic == [lindex $ticl 0]} {
X set anchorX [lindex $pos 2]
X set anchorY [lindex $pos 3]
X set lastX [lindex $pos 0]
X set lastY [lindex $pos 1]
X
X set mvl {}
X set mhl {}
X foreach p $mpars(ip-$module) {
X set ppos [propGet $mpars($p) pos]
X set px [lindex $ppos 0]
X set py [lindex $ppos 1]
X if {(($py == $anchorY) || ($py == $lastY))
X && (($px < $xmax) || ($xmax == -1))} {set xmax $px}
X if {(($px == $anchorX) || ($px == $lastX))
X && (($py < $ymax) || ($ymax == -1))} {set ymax $py}
X if {($px == $lastX)} {
X set arlist {}
X propIter arrow end [propGet $mpars($p) in] {
X lappend arlist [list In $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X propIter arrow end [propGet $mpars($p) out] {
X lappend arlist [list Out $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X lappend mvl $p $arlist
X }
X if {($py == $lastY)} {
X set arlist {}
X propIter arrow end [propGet $mpars($p) in] {
X lappend arlist [list In $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X propIter arrow end [propGet $mpars($p) out] {
X lappend arlist [list Out $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X lappend mhl $p $arlist
X }
X }
X } else {
X set anchorX [lindex $pos 0]
X set anchorY [lindex $pos 1]
X set lastX [lindex $pos 2]
X set lastY [lindex $pos 3]
X
X set mvl {}
X set mhl {}
X foreach p $mpars(ip-$module) {
X set ppos [propGet $mpars($p) pos]
X set px [lindex $ppos 0]
X set py [lindex $ppos 1]
X if {(($py == $anchorY) || ($py == $lastY))
X && (($px > $xmin) || ($xmin == -1))} {set xmin $px}
X if {(($px == $anchorX) || ($px == $lastX))
X && (($py > $ymin) || ($ymin == -1))} {set ymin $py}
X if {($px == $lastX)} {
X set arlist {}
X propIter arrow end [propGet $mpars($p) in] {
X lappend arlist [list In $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X propIter arrow end [propGet $mpars($p) out] {
X lappend arlist [list Out $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X lappend mvl $p $arlist
X }
X if {($py == $lastY)} {
X set arlist {}
X propIter arrow end [propGet $mpars($p) in] {
X lappend arlist [list In $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X propIter arrow end [propGet $mpars($p) out] {
X lappend arlist [list Out $px $py $arrow [propGet $places($end) pos] \{[propGet $arrows($arrow) path]\}]
X }
X lappend mhl $p $arlist
X }
X }
X }
X
X $c itemconfigure $module -outline #808080
X
X $c bind $tic <Any-Any-Motion> "ticPos %W $tic \[xlat %W %x\] \[ylat %W %y\]"
X set ticbinding [$c bind $tic <Shift-3>]
X $c bind $tic <Shift-3> ""
X
X bind $c <Any-Button3-ButtonRelease> "moduleTicEnd $c \"$ticl\" \[xlat %W %x\] \[ylat %W %y\] $xmin $xmax $ymin $ymax \{$mvl\} \{$mhl\}"
X bind $c <Any-Button3-Motion> "moduleSpan $c $module \[xlat %W %x\] \[ylat %W %y\] $xmin $xmax $ymin $ymax \{$mvl\} \{$mhl\}"
X}
X
X
X# Procedure: moduleTicEnd
Xproc moduleTicEnd { c ticl x y xmin xmax ymin ymax mvl mhl} {
X global module.fill.color module.outline.color module.fill
X global anchorX anchorY cDx cDy lastX lastY
X global module mpars tic modules ticbinding
X
X $c bind $tic <Any-Any-Motion> ""
X bind $c <Shift-3> ""
X $c bind $tic <Shift-3> "$ticbinding"
X bind $c <Any-Button3-ButtonRelease> ""
X bind $c <Any-Button3-Motion> ""
X
X if {($xmax != -1) && ($x > $xmax)} {set x $xmax}
X if {($xmin != -1) && ($x < $xmin)} {set x $xmin}
X if {($ymax != -1) && ($y > $ymax)} {set y $ymax}
X if {($ymin != -1) && ($y < $ymin)} {set y $ymin}
X
X $c itemconfigure $module -outline ${module.outline.color} -fill ${module.fill.color}
X
X set dx [expr $x - $lastX]
X set dy [expr $y - $lastY]
X set cDx [expr $cDx + $dx]
X set cDy [expr $cDy + $dy]
X set lastX $x
X set lastY $y
X
X propIter par arrs $mvl {
X set ppos [propGet $mpars($par) pos]
X set px [expr $cDx + [lindex $ppos 0]]
X set py [lindex $ppos 1]
X propPut mpars($par) pos [list $px $py]
X $c move $par $dx 0
X foreach a $arrs {
X eval eval arrowDrag$a $c $cDx 0
X }
X }
X propIter par arrs $mhl {
X set ppos [propGet $mpars($par) pos]
X set px [lindex $ppos 0]
X set py [expr $cDy + [lindex $ppos 1]]
X propPut mpars($par) pos [list $px $py]
X $c move $par 0 $dy
X foreach a $arrs {
X eval eval arrowDrag$a $c 0 $cDy
X }
X }
X
X modulePosOrd anchorX anchorY x y
X $c coords $module $anchorX $anchorY $x $y
X propPut modules($module) pos [list $anchorX $anchorY $x $y]
X ticPos $c [lindex $ticl 0] $anchorX $anchorY
X ticPos $c [lindex $ticl 1] $x $y
X}
X
X
X# Procedure: moduleWrite
Xproc moduleWrite { m {f "file1"}} {
X if {[regexp {^mp-[^.]+\..+$} $m] == 1} return
X
X global modules mpars arrows
X set record $modules($m)
X puts $f "MODULE $m \{"
X puts $f " desc \{[propGet $m desc]\}"
X set pos [propGet $record pos]
X set x1 [lindex $pos 0]
X set y1 [lindex $pos 1]
X set sx [expr [lindex $pos 2] - $x1]
X set sy [expr [lindex $pos 3] - $y1]
X puts $f " pos \{$x1 $y1\}"
X puts $f " size \{$sx $sy\}"
X puts $f " parameters \{"
X foreach par $mpars(ip-$m) {
X set prec $mpars($par)
X regsub {[^.]*.(.*)} $par {\1} pname
X puts $f " $pname \{"
X puts $f " desc \{[propGet $prec desc]\}"
X puts $f " pos \{[propGet $prec pos]\}"
X puts $f " in \{"
X propIter i org [propGet $prec in] {
X set arr $arrows($i)
X puts $f " $org \{"
X foreach j {weight nota path smooth} {
X puts $f " $j \{[propGet $arr $j]\}"
X }
X puts $f " \}"
X }
X puts $f " \}"
X puts $f " out \{"
X propIter i aim [propGet $prec out] {
X set arr $arrows($i)
X puts $f " $aim \{"
X foreach j {weight nota path smooth} {
X puts $f " $j \{[propGet $arr $j]\}"
X }
X puts $f " \}"
X }
X puts $f " \}"
X puts $f " \}"
X }
X puts $f " \}"
X puts $f "\}"
X}
X
X
X# Procedure: mparEditBegin
Xproc mparEditBegin { c {w ""}} {
X global mpars names modules
X global mparName mparDesc
X
X set mpar $names([$c find withtag current])
X set module $modules(mp-$mpar)
X if {[regsub "^$module\\.(.+)$" $mpar {\1} mparName] == 0} {
X error "assertion failed in mparEditBegin"
X }
X set mparRec $mpars($mpar)
X set mparDesc [propGet $mparRec desc]
X set pid [propGet $mparRec pid]
X
X # build widget ${w}.mparEdit
X catch "destroy ${w}.mparEdit"
X toplevel ${w}.mparEdit
X
X # Window manager configurations
X wm positionfrom ${w}.mparEdit ""
X wm sizefrom ${w}.mparEdit ""
X wm title ${w}.mparEdit "Parameter $module.$pid"
X
X wdg_entry ${w}.mparEdit.name {Name:} mparName
X wdg_text ${w}.mparEdit.desc Description mparDesc
X wdg_confirm ${w}.mparEdit.confirm "mparEditEnd $c $w.mparEdit $module $mparName"
X
X # pack widget ${w}.mparEdit
X pack ${w}.mparEdit.name -side top -fill x
X pack ${w}.mparEdit.desc -side top -fill x
X pack ${w}.mparEdit.confirm -side top -fill x
X
X tkwait visibility ${w}.mparEdit
X grab set ${w}.mparEdit
X}
X
X
X# Procedure: mparEditEnd
Xproc mparEditEnd { c w module mpar ok} {
X destroy $w
X
X if {$ok == "ok"} {
X global mpars
X global mparName mparDesc
X
X if {$mparName != $mpar} {
X nodeRename $c $module.$mpar $module.$mparName
X }
X
X set mpar $module.$mparName
X set mparRec $mpars($mpar)
X propPut mparRec desc $mparDesc
X
X set mpars($mpar) $mparRec
X }
X}
X
X
X# Procedure: mparEnter
Xproc mparEnter { c} {
X global mpar.hi.fill.color mpar.hi.outline.color
X global names currentNode
X set mpar [$c find withtag current]
X set currentNode $names($mpar)
X $c itemconfigure $mpar -fill ${mpar.hi.fill.color} -outline ${mpar.hi.outline.color}
X}
X
X
X# Procedure: mparGetArrows
Xproc mparGetArrows { c p io} {
X global mpars
X propGet $mpars($p) $io
X}
X
X
X# Procedure: mparLeave
Xproc mparLeave { c} {
X global mpar.fill.color mpar.outline.color
X global currentNode
X set currentNode {}
X set mpar [$c find withtag current]
X $c itemconfigure $mpar -fill ${mpar.fill.color} -outline ${mpar.outline.color}
X}
X
X
X# Procedure: mparPutArrow
Xproc mparPutArrow { c p io i e} {
X global mpars
X propPut mpars($p) $io [linsert [propGet $mpars($p) $io] 0 $i $e]
X}
X
X
X# Procedure: mparRemArrow
Xproc mparRemArrow { c p io i} {
X global mpars
X set a [propGet $mpars($p) $io]
X propRem a $io $i
X propPut mpars($p) $io $a
X}
X
X
X# Procedure: MODULE
Xproc MODULE { name plist} {
X global loadCanvas arrows places modules mpars
X
X set pos [propGet $plist pos]
X set size [propGet $plist size]
X set x1 [lindex $pos 0]
X set y1 [lindex $pos 1]
X set x2 [expr $x1 + [lindex $size 0]]
X set y2 [expr $y1 + [lindex $size 1]]
X set name [moduleAdd $loadCanvas "" $x1 $y1 $x2 $y2 $name]
X update
X set rec $modules($name)
X propPut rec desc [propGet $plist desc]
X propIter par prec [propGet $plist parameters] {
X set pos [propGet $prec pos]
X set x [lindex $pos 0]
X set y [lindex $pos 1]
X set par [moduleAddParameter $loadCanvas $x $y $name $par]
X update
X propPut mpars($par) desc [propGet $prec desc]
X
X propIter orig areci [propGet $prec in] {
X set path [propGet $areci path]
X set arrow [arrowAdd $loadCanvas {} $orig $par $path [propGet $areci smooth]]
X set arec $arrows($arrow)
X foreach i {weight nota} {
X propPut arec $i [propGet $areci $i]
X }
X set arrows($arrow) $arec
X }
X
X propIter aim areci [propGet $prec out] {
X set path [propGet $areci path]
X set arrow [arrowAdd $loadCanvas {} $par $aim $path [propGet $areci smooth]]
X set arec $arrows($arrow)
X foreach i {weight nota} {
X propPut arec $i [propGet $areci $i]
X }
X set arrows($arrow) $arec
X }
X }
X}
X
END_OF_FILE
if test 24019 -ne `wc -c <'pips-0.1-alpha/module.tcl'`; then
echo shar: \"'pips-0.1-alpha/module.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/module.tcl'
fi
if test -f 'pips-0.1-alpha/transition.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/transition.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/transition.tcl'\" $7181 characters$
sed "s/^X//" >'pips-0.1-alpha/transition.tcl' <<'END_OF_FILE'
X# transition.tcl -- procedures that handle transitions
X#
X# Copyright (C) 1994 Gunther Schadow
X#
X# This file is part of Pips, an editor for Petri Nets.
X#
X# Pips is free software; you can redistribute it and/or modify it under
X# the terms of the GNU General Public License as published by the Free
X# Software Foundation; either version 2, or (at your option) any later
X# version.
X#
X# Pips is distributed in the hope that it will be useful, but WITHOUT
X# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
X# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
X# for more details.
X#
X# You should have received a copy of the GNU General Public License
X# along with Pips; see the file COPYING. If not, write to the Free
X# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
X#
X
X# color default settings
Xset transition.outline.color #000000
Xset transition.hi.outline.color #a0a0a0
Xset transition.fill.color #ffffff
Xset transition.hi.fill.color #ffffff
X
X# Procedure: transitionAdd
Xproc transitionAdd { c x y args} {
X global transition.fill.color transition.outline.color
X global transitions names nodetypes
X set radius 6
X if {$args == ""} {
X set transition [nameGen $c transition]
X } else {
X if {[$c find withtag $args] == ""} {
X set transition $args
X } else {
X error "transitionname redefined: $args"
X }
X }
X
X set item [$c create rectangle [expr $x - $radius] [expr $y - $radius] [expr $x + $radius] [expr $y + $radius] -fill ${transition.fill.color} -outline ${transition.outline.color} -tags "transition node $transition"]
X
X set names($item) $transition
X
X set nodetypes($transition) transition
X
X set record {}
X propPut record cid $item
X propPut record pos "$x $y"
X set transitions($transition) $record
X
X return $transition
X}
X
X
X# Procedure: transitionDelete
Xproc transitionDelete { c {item ""}} {
X global names transitions nodetypes
X if {$item == ""} {
X set item [$c find withtag current]
X }
X set transition $names($item)
X set record $transitions($transition)
X propIter i e [propGet $record in] {
X arrowDelete $c $i $e $transition
X }
X propIter i e [propGet $record out] {
X arrowDelete $c $i $transition $e
X }
X unset names([propGet $record cid])
X unset nodetypes($transition)
X unset transitions($transition)
X $c delete $transition
X}
X
X
X# Procedure: transitionEditBegin
Xproc transitionEditBegin { c {w ""}} {
X global transitions names
X global transitionName transitionAction transitionDesc
X
X set transition $names([$c find withtag current])
X set transitionName $transition
X set transitionRec $transitions($transition)
X set transitionAction [propGet $transitionRec action]
X set transitionDesc [propGet $transitionRec desc]
X
X # build widget ${w}.transitionEdit
X catch "destroy ${w}.transitionEdit"
X toplevel ${w}.transitionEdit
X
X # Window manager configurations
X wm positionfrom ${w}.transitionEdit ""
X wm sizefrom ${w}.transitionEdit ""
X wm title ${w}.transitionEdit {Transition}
X
X wdg_entry ${w}.transitionEdit.name {Name:} transitionName
X wdg_text ${w}.transitionEdit.action Action transitionAction
X wdg_text ${w}.transitionEdit.desc Description transitionDesc
X wdg_confirm ${w}.transitionEdit.confirm "transitionEditEnd $c $w.transitionEdit $transition"
X
X # pack widget ${w}.transitionEdit
X pack ${w}.transitionEdit.name -side top -fill x
X pack ${w}.transitionEdit.action -side top -fill x
X pack ${w}.transitionEdit.desc -side top -fill x
X pack ${w}.transitionEdit.confirm -side top -fill x
X
X tkwait visibility ${w}.transitionEdit
X grab set ${w}.transitionEdit
X}
X
X
X# Procedure: transitionEditEnd
Xproc transitionEditEnd { c w transition ok} {
X destroy $w
X
X if {$ok == "ok"} {
X global transitions
X global transitionName transitionAction transitionDesc
X
X set transitionRec $transitions($transition)
X if {$transitionName != $transition} {
X nodeRename $c $transition $transitionName
X set transition $transitionName
X }
X
X propPut transitionRec action $transitionAction
X propPut transitionRec desc $transitionDesc
X
X set transitions($transition) $transitionRec
X }
X}
X
X
X# Procedure: transitionEnter
Xproc transitionEnter { c} {
X global transition.hi.fill.color transition.hi.outline.color
X global currentNode names
X set currentNode $names([$c find withtag current])
X $c itemconfigure current -fill ${transition.hi.fill.color} -outline ${transition.hi.outline.color}
X}
X
X
X# Procedure: transitionGetArrows
Xproc transitionGetArrows { c p io} {
X global transitions
X propGet $transitions($p) $io
X}
X
X
X# Procedure: transitionLeave
Xproc transitionLeave { c} {
X global transition.fill.color transition.outline.color
X global currentNode
X set currentNode {}
X $c itemconfigure current -fill ${transition.fill.color} -outline ${transition.outline.color}
X}
X
X
X# Procedure: transitionModeEnter
Xproc transitionModeEnter { c} {
X bind $c <1> "transitionAdd $c \[xlat %W %x\] \[ylat %W %y\]"
X}
X
X
X# Procedure: transitionModeLeave
Xproc transitionModeLeave { c} {
X bind $c <1> ""
X}
X
X
X# Procedure: transitionPutArrow
Xproc transitionPutArrow { c t io i e} {
X global transitions
X propPut transitions($t) $io [linsert [propGet $transitions($t) $io] 0 $i $e]
X}
X
X
X# Procedure: transitionRemArrow
Xproc transitionRemArrow { c p io i} {
X global transitions
X set a [propGet $transitions($p) $io]
X propRem a $io $i
X propPut transitions($p) $io $a
X}
X
X
X# Procedure: transitionWrite
Xproc transitionWrite { t {file "file1"}} {
X global arrows places transitions
X set rec $transitions($t)
X puts $file "TRANSITION $t \{"
X foreach i {desc action pos} {
X puts $file " $i \{[propGet $rec $i]\}"
X }
X puts $file " in \{"
X propIter i org [propGet $rec in] {
X set arr $arrows($i)
X puts $file " $org \{"
X foreach j {weight nota path smooth} {
X puts $file " $j \{[propGet $arr $j]\}"
X }
X puts $file " \}"
X }
X puts $file " \}"
X puts $file " out \{"
X propIter i aim [propGet $rec out] {
X set arr $arrows($i)
X puts $file " $aim \{"
X foreach j {weight nota path smooth} {
X puts $file " $j \{[propGet $arr $j]\}"
X }
X puts $file " \}"
X }
X puts $file " \}"
X puts $file "\}"
X}
X
X
X
X# Procedure: TRANSITION
Xproc TRANSITION { name plist} {
X global loadCanvas transitions places arrows
X
X set pos [propGet $plist pos]
X set x [lindex $pos 0]
X set y [lindex $pos 1]
X set name [transitionAdd $loadCanvas $x $y $name]
X update
X set rec $transitions($name)
X foreach p {desc action} {
X propPut rec $p [propGet $plist $p]
X }
X set transitions($name) $rec
X propIter orig areci [propGet $plist in] {
X set path [propGet $areci path]
X set arrow [arrowAdd $loadCanvas {} $orig $name $path [propGet $areci smooth]]
X set arec $arrows($arrow)
X foreach i {weight nota} {
X propPut arec $i [propGet $areci $i]
X }
X set arrows($arrow) $arec
X }
X
X propIter aim areci [propGet $plist out] {
X set path [propGet $areci path]
X set arrow [arrowAdd $loadCanvas {} $name $aim $path [propGet $areci smooth]]
X set arec $arrows($arrow)
X foreach i {weight nota} {
X propPut arec $i [propGet $areci $i]
X }
X set arrows($arrow) $arec
X }
X}
X
END_OF_FILE
if test 7181 -ne `wc -c <'pips-0.1-alpha/transition.tcl'`; then
echo shar: \"'pips-0.1-alpha/transition.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/transition.tcl'
fi
echo shar: End of archive 1 $of 3$.
cp /dev/null ark1isdone
MISSING=""
for I in 1 2 3 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 3 archives.
rm -f ark[1-9]isdone
else
echo You still must unpack the following archives:
echo " " ${MISSING}
fi
exit 0
exit 0 # Just in case...
--
// ch...@Sterling.COM | Send comp.sources.x submissions to:
\X/ Amiga: The only way to fly! | sour...@sterling.com
GCS d++(--) h++ s++:+ g+++(?) p? au(*)(0) a w+ v-(*) C++ US+++ P+ L+ 3 N++ K
!W M V-- -po+ Y+ t+ 5++ j- r+ G+ v b+++ D- b-- e+ u+ h- f+ r+++ !n y+++

Gunther Schadow

unread,

Mar 14, 1995, 9:57:18 PM3/14/95

Submitted-by: gu...@zedat.fu-berlin.de (Gunther Schadow)
Posting-number: Volume 23, Issue 8
Archive-name: pips/part02

Environment: X11, Tcl/Tk, petri nets

#! /bin/sh

# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".

# Contents: pips-0.1-alpha/README pips-0.1-alpha/arrow.tcl
# pips-0.1-alpha/node.tcl pips-0.1-alpha/pips
# pips-0.1-alpha/place.tcl pips-0.1-alpha/test.prn
# pips-0.1-alpha/widget.tcl
# Wrapped by chris@ftp on Tue Mar 14 17:26:38 1995

PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin:$PATH ; export PATH
echo If this archive is complete, you will see the following message:

echo ' "shar: End of archive 2 (of 3)."'
if test -f 'pips-0.1-alpha/README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/README'\"
else
echo shar: Extracting \"'pips-0.1-alpha/README'\" $5511 characters$
sed "s/^X//" >'pips-0.1-alpha/README' <<'END_OF_FILE'
X
X Pips (v0.1a) -- A graphical Editor for Petri Nets
X
X
XPREFACE
X
XThis is my first Tk application, and it is still very much alpha state
Xsoftfare. There are a lot of features missing, which you would expect
Xfrom a graphical editor. No selection, no cut/copy/paste etc.
XEverything is very simple up to now and there is only the very basic
Xfunctionality provided. Nevertheless, since I wrote this program in
Xonly two weeks it can't be too hard to fill in the rest.
X
X
XINSTALLATION
X
XEdit the Makefile to fit your file system layout. Then choose a
Xcolor.tcl file by renaming one of the color.tcl.* files or just use
Xthe default one. Then type
X
X$ make install
X
XNow you can invoke pips with
X
X$ pips [filename]
X
XThere are currently no other command line options of relevance to the
Xuser and no resources-like application-defaults.
X
X
XFUNCTIONALITY
X
XThe basic functionality is to place nodes onto the paper, move them
Xaround, provide them with names and other parameters like capacities
Xfor places and actions for transitions. Arrows can be drawn between
Xthe nodes, parameters like weight can be edited. Arrows don't need to
Xrun the shortest way between two nodes they can rather have an
Xarbitrary path. Any object can be moved around while arrows are
Xdynamically redrawn. The net can be saved loaded and printed via a
Xpostscript file.
X
XA speciality of this editor is the support for modular design. Even
Xthough the module feature is still quite underdeveloped, it will
Xbecome more powerful in the future. For now you can place
Xinstantinations of modules into the net. Modules are kind of black
Xboxes. They interact with their invironment only by their interface
Xtransacrions which are also called `parameters' here. Thus a module
Xcan be regarded as a supertransition. In fact, you cannot see or edit
Xthe internal subnet of a module. In the future the inner subnet of a
XModule can be edited in an extra editing area, and it's instatination
Xwithin a certain environment can be matched with the actual definition
Xof the module. This concept of modularization is very much inspired by
XLOOPN, which is a compiler for Petri Nets to C Programs. LOOPN is free
Xsoftware, I recommend to grab it and read the documenting paper.
X
XOK. now comes a short description of how to use Pips: First of all,
Xjust try it out, it is pretty much self explaining. Here I give only
Xa few hints which aren't that obvious:
X
XThe file selection window has a directory list feature, which you can
Xinvoke by double clicking button 2 in the file name entry field. The
Xlistbox shows all files that match the pattern in the file name entry.
XDouble clicking button 1 on an entry in the list will hide the listbox
Xagain and move the filename into the file name entry.
X
XParameters of objects can be edited by clicking button 2 over the
Xobject. Objects can be moved with Shift-Button3. When you are in the
X`Move' ore `Edit' mode, moving or editing can be done by clicking
Xbutton 1 over an object.
X
XIt may be worthwhile to read a file that is saved by Pips. The files
Xgenerated are text files which look like programs and are pretty good
Xstructured and readable. In fact they are parsed by the Tcl internal
Xparser just like Tcl programs. The keywords `PLACE', `TRANSITION' etc.
Xare in fact procedure names that handle the rest of the input as
Xparameters. Becuase of this, the Tcl rules apply, which are different
Xfrom what you know of C even though the files look somewhat like C.
XNotably line breaks do have a meaning in Tcl, that's why opening
Xbraces happen to end a line, instead of to start the following
Xline. The net files are meant to be eventually translated into LOOPN
Xsources which can be used to apply simulation to the designed net. A
Xsimulation could be animated by letting the LOOPN generated program to
Xinteract with the editor by means of Tk.
X
X
XPATCHES ARE APPRECIATED
X
XSince I won't have time to work on this program for the next weeks,
Xyou are envited to make extensions to the code and send the patches
Xto me. It shouldn't be too hard to understand the code, even though, I
Xmade little annotations and there are still some inconsistencies. But
XI tried to keep the procedures small and name them in a standardized
Xway. Any name of a procedure that is meant to handle a specific class of
Xobject starts with the name of that class. All procedures to a certain
Xclass are grouped in one file. Thus `place.tcl' contains procedures
Xthat act on places, and `node.tcl' has procedures that act on places,
Xtransitions and module parameters.
X
XTcl unfortunately does not provide good means of data structuring. I
Xrealized the `Record' (or `struct') kind of data type by property
Xlists. A property list is a list, which contains a sequence of name
Xvalue pairs. These lists are accessed throug standardized interfaces.
XThe procedure propPut puts a new property on the list or replaces an
Xold one, propGet extracts the value of a property, propRem removes a
Xproperty. There is a procedure propIter, which iterates over a
Xproperty list (like `foreach' but with two running variables). Because
Xthis mechanism of data structuring is quite inefficient, I used global
Xarrays for lists that can grow large, like the list of all places.
XArrays in Tcl have the andvantage that they represent association
Xlists and are interfaced by Tcl primitives. On the other hand, the
Xbig disadvantage is that you can not act on arrays as a whole, thus
Xyou cannot let an array be part of a list. Thus I could use arrays
Xonly for outer data structures.
X
X
Xenjoy
X- Gunther Schadow
END_OF_FILE
if test 5511 -ne `wc -c <'pips-0.1-alpha/README'`; then
echo shar: \"'pips-0.1-alpha/README'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/README'
fi
if test -f 'pips-0.1-alpha/arrow.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/arrow.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/arrow.tcl'\" $13572 characters$
sed "s/^X//" >'pips-0.1-alpha/arrow.tcl' <<'END_OF_FILE'
X# arrow.tcl -- procedures on arrows, note that nodes do very much on
X# arrows too

X#
X# Copyright (C) 1994 Gunther Schadow
X#
X# This file is part of Pips, an editor for Petri Nets.
X#
X# Pips is free software; you can redistribute it and/or modify it under
X# the terms of the GNU General Public License as published by the Free
X# Software Foundation; either version 2, or (at your option) any later
X# version.
X#
X# Pips is distributed in the hope that it will be useful, but WITHOUT
X# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
X# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
X# for more details.
X#
X# You should have received a copy of the GNU General Public License
X# along with Pips; see the file COPYING. If not, write to the Free
X# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
X#
X
X# color default settings

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080
X
X# Procedure: arrowAdd
Xproc arrowAdd { c item origin aim path {smooth "0"}} {
X global arrow.color
X global names places transitions arrows nodetypes mpars
X
X set otype $nodetypes($origin)
X switch $otype {
X place {
X set p $origin
X set orec $places($origin)
X set origPos [propGet $orec pos]
X set ox [lindex $origPos 0]
X set oy [lindex $origPos 1]
X }
X transition {
X set t $origin
X set orec $transitions($origin)
X set origPos [propGet $orec pos]
X set ox [lindex $origPos 0]
X set oy [lindex $origPos 1]
X }
X mpar {
X set t $origin
X set orec $mpars($origin)
X set origPos [propGet $orec pos]
X set ox [lindex $origPos 0]
X set oy [lindex $origPos 1]
X }}
X
X set atype $nodetypes($aim)
X switch $atype {
X place {
X set p $aim
X set arec $places($aim)
X set aimPos [propGet $arec pos]
X set ax [lindex $aimPos 0]
X set ay [lindex $aimPos 1]
X }
X transition {
X set t $aim
X set arec $transitions($aim)
X set aimPos [propGet $arec pos]
X set ax [lindex $aimPos 0]
X set ay [lindex $aimPos 1]
X }
X mpar {
X set t $aim
X set arec $mpars($aim)
X set aimPos [propGet $arec pos]
X set ax [lindex $aimPos 0]
X set ay [lindex $aimPos 1]
X }}
X
X arrowClip ox oy ax ay $path

X
X if {$item == ""} {

X set item [eval eval $c create line $ox $oy $path $ax $ay -arrow last -fill ${arrow.color}]
X } else {
X eval eval $c coords $item $ox $oy $path $ax $ay
X }
X
X set ticl {}
X foreach t $path {
X lappend ticl [eval ticNew $c $t arrow $item]
X }
X
X set a {}
X propPut a cid $item
X propPut a tic $ticl
X propPut a org $origin
X propPut a aim $aim
X propPut a path $path
X propPut a smooth $smooth
X propPut a weight 1
X set arrows($item) $a
X
X $c itemconfigure $item -fill ${arrow.color} -smooth $smooth -tags "arrow $p,$t $origin>$aim"
X
X ${otype}PutArrow $c $origin out $item $aim
X ${atype}PutArrow $c $aim in $item $origin
X
X return $item
X}
X
X
X# Procedure: arrowAnchor
Xproc arrowAnchor { c} {
X global arrow.new.color
X global anchorX anchorY arrow path origin
X global places transitions names nodetypes mpars
X
X set origin $names([$c find withtag current])
X set otype $nodetypes($origin)
X
X switch $otype {
X place {
X set origPos [propGet $places($origin) pos]
X set anchorX [lindex $origPos 0]
X set anchorY [lindex $origPos 1]
X
X $c bind transition <Button1-ButtonRelease> "arrowFix %W"
X $c bind mpar <Button1-ButtonRelease> "arrowFix %W"
X }
X transition {
X set origPos [propGet $transitions($origin) pos]
X set anchorX [lindex $origPos 0]
X set anchorY [lindex $origPos 1]
X
X $c bind place <Button1-ButtonRelease> "arrowFix %W"
X }
X mpar {
X set origPos [propGet $mpars($origin) pos]
X set anchorX [lindex $origPos 0]
X set anchorY [lindex $origPos 1]
X
X $c bind place <Button1-ButtonRelease> "arrowFix %W"
X }
X default { error "failor in program!" }
X }
X
X $c bind node <1> ""
X bind $c <3> {arrowStep %W [xlat %W %x] [ylat %W %y]}
X bind $c <Any-Motion> {arrowSpan %W [xlat %W %x] [ylat %W %y]}
X
X set path {}
X
X set arrow [$c create line $anchorX $anchorY $anchorX $anchorY -arrow last -fill ${arrow.new.color}]
X $c lower $arrow
X}
X
X
X# Procedure: arrowClip
Xproc arrowClip { pxp1 pyp1 pxp2 pyp2 {path ""}} {
X upvar $pxp1 xp1 $pyp1 yp1 $pxp2 xp2 $pyp2 yp2
X if {$path == {}} {
X set dx [expr $xp2 - $xp1]
X set dy [expr $yp2 - $yp1]
X set r 10
X set d [expr hypot($dx, $dy) ]
X if {$d == 0} {return}
X set k [expr ( $d - $r ) / $d]
X set xp1o $xp1
X set yp1o $yp1
X set xp1 [expr $xp2 - $dx * $k ]
X set yp1 [expr $yp2 - $dy * $k ]
X set xp2 [expr $xp1o + $dx * $k ]
X set yp2 [expr $yp1o + $dy * $k ]
X } else {
X set s0 [lindex $path 0]
X set sn [lindex $path [expr [llength $path] -1]]
X eval arrowClip1 xp1 yp1 $s0
X eval arrowClip1 xp2 yp2 $sn
X }
X}
X
X
X# Procedure: arrowClip1
Xproc arrowClip1 { pxp pyp xp2 yp2} {
X upvar $pxp xp1 $pyp yp1
X set dx [expr $xp2 - $xp1]
X set dy [expr $yp2 - $yp1]
X set r 10
X set d [expr hypot($dx, $dy) ]
X if {$d == 0} {return}
X set k [expr ( $d - $r ) / $d]
X set xp1 [expr $xp2 - $dx * $k ]
X set yp1 [expr $yp2 - $dy * $k ]
X}
X
X
X# Procedure: arrowDelete
Xproc arrowDelete { c {item ""} {orig ""} {aim ""}} {
X global arrows nodetypes places transitions mpars

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

X set record $arrows($item)
X
X if {$orig == ""} {
X set orig [propGet $record org]
X }
X if {$aim == ""} {
X set aim [propGet $record aim]
X }
X
X set type $nodetypes($orig)
X eval set orec $${type}s($orig)
X set outl [propGet $orec out]
X propRem outl $item
X propPut orec out $outl
X set ${type}s($orig) $orec
X
X set type $nodetypes($aim)
X eval set arec $${type}s($aim)
X set inl [propGet $arec in]
X propRem inl $item
X propPut arec in $inl
X set ${type}s($aim) $arec
X
X foreach tic [propGet $record tic] {
X ticKill $c $tic
X }
X unset arrows($item)
X $c delete $item
X}
X
X
X# Procedure: arrowDragIn
Xproc arrowDragIn { x y item x1 y1 path c dx dy} {
X set x2 [expr $x + $dx]
X set y2 [expr $y + $dy]
X arrowClip x1 y1 x2 y2 $path
X eval eval $c coords $item $x1 $y1 $path $x2 $y2
X}
X
X
X# Procedure: arrowDragOut
Xproc arrowDragOut { x y item x2 y2 path c dx dy} {
X set x1 [expr $x + $dx]
X set y1 [expr $y + $dy]
X arrowClip x1 y1 x2 y2 $path
X eval eval $c coords $item $x1 $y1 $path $x2 $y2
X}
X
X
X# Procedure: arrowEditBegin
Xproc arrowEditBegin { c {w ""}} {
X global arrows names
X global arrowWeight arrowNota arrowSmooth arrowPath
X
X set arrow [$c find withtag current]
X set arrowRec $arrows($arrow)
X
X set arrowNota [propGet $arrowRec nota]
X set arrowPath [propGet $arrowRec path]
X
X if {[propGet $arrowRec smooth] == 1} {
X set arrowSmooth 1
X } else {
X set arrowSmooth 0
X }
X
X if {[set arrowWeight [propGet $arrowRec weight]] == ""} {
X set arrowWeight 1
X }
X
X # build widget ${w}.arrowEdit
X catch "destroy ${w}.arrowEdit"
X toplevel ${w}.arrowEdit

X
X # Window manager configurations

X global tkVersion
X wm positionfrom ${w}.arrowEdit ""
X wm sizefrom ${w}.arrowEdit ""
X wm title ${w}.arrowEdit {Arrow}
X
X wdg_scale ${w}.arrowEdit.weight Weight arrowWeight 1 100
X wdg_entry ${w}.arrowEdit.path Path arrowPath
X wdg_text ${w}.arrowEdit.nota Annotations arrowNota
X wdg_confirm ${w}.arrowEdit.confirm "arrowEditEnd $c $w.arrowEdit $arrow"
X checkbutton ${w}.arrowEdit.smooth -text smooth -variable arrowSmooth -onvalue 1 -offvalue 0
X
X # pack widget ${w}.arrowEdit
X pack ${w}.arrowEdit.weight -side top -fill x
X pack ${w}.arrowEdit.path -side top -fill x
X pack ${w}.arrowEdit.nota -side top -fill x
X pack ${w}.arrowEdit.confirm -side left
X pack ${w}.arrowEdit.smooth -side right -pady 2 -pady 2
X
X tkwait visibility ${w}.arrowEdit
X grab set ${w}.arrowEdit
X}
X
X
X# Procedure: arrowEditEnd
Xproc arrowEditEnd { c w arrow ok} {

X destroy $w
X
X if {$ok == "ok"} {

X global arrows
X global arrowWeight arrowNota arrowSmooth arrowPath
X
X set arrowRec $arrows($arrow)
X propPut arrowRec weight $arrowWeight
X propPut arrowRec nota $arrowNota
X propPut arrowRec path $arrowPath
X propPut arrowRec smooth $arrowSmooth
X set arrows($arrow) $arrowRec
X }
X
X arrowRedraw $c $arrow
X}
X
X
X# Procedure: arrowEnter
Xproc arrowEnter { c} {
X global arrow.hi.color
X $c itemconfigure current -fill ${arrow.hi.color}
X}
X
X
X# Procedure: arrowFix
Xproc arrowFix { c} {
X global arrow origin path places transitions names
X
X set aim $names([$c find withtag current])
X
X arrowAdd $c $arrow $origin $aim $path
X
X $c bind transition <Button1-ButtonRelease> ""
X $c bind place <Button1-ButtonRelease> ""
X $c bind mpar <Button1-ButtonRelease> ""
X bind $c <Any-Motion> ""
X $c bind node <1> "arrowAnchor %W"
X bind $c <3> ""
X}
X
X
X# Procedure: arrowLeave
Xproc arrowLeave { c} {
X global arrow.color
X $c itemconfigure current -fill ${arrow.color}
X}
X
X
X# Procedure: arrowModeEnter
Xproc arrowModeEnter { c} {
X $c bind node <1> "arrowAnchor $c"
X $c bind arrow <Shift-Button-3> {arrowTicAdd %W [%W canvasx %x] [%W canvasy %y]}
X}
X
X
X# Procedure: arrowModeLeave
Xproc arrowModeLeave { c} {
X $c bind node <1> ""
X $c bind arrow <Shift-Button-3> ""
X}
X
X
X# Procedure: arrowRedraw
Xproc arrowRedraw { c arrow} {
X global arrows nodetypes places transitions mpars
X
X set apl $arrows($arrow)
X
X set orig [propGet $apl org]
X set otype $nodetypes($orig)
X set origPos [eval propGet $${otype}s($orig) pos]
X set ox [lindex $origPos 0]
X set oy [lindex $origPos 1]
X
X set aim [propGet $apl aim]
X set atype $nodetypes($aim)
X set aimPos [eval propGet $${atype}s($aim) pos]
X set ax [lindex $aimPos 0]
X set ay [lindex $aimPos 1]
X
X set path [propGet $apl path]
X arrowClip ox oy ax ay $path
X eval eval $c coords $arrow $ox $oy $path $ax $ay
X $c itemconfigure $arrow -smooth [propGet $apl smooth]
X}
X
X
X# Procedure: arrowSpan
Xproc arrowSpan { c x y} {
X global anchorX anchorY arrow path
X eval eval $c coords $arrow $anchorX $anchorY $path $x $y
X $c lower $arrow
X}
X
X
X# Procedure: arrowStep
Xproc arrowStep { c x y} {
X global arrow path anchorX anchorY
X lappend path [list $x $y]
X eval eval $c coords $arrow $anchorX $anchorY $path
X}
X
X
X# Procedure: arrowTic
Xproc arrowTic { c arrow po path pa} {
X eval eval $c coords $arrow $po $path $pa
X}
X
X
X# Procedure: arrowTicAdd
Xproc arrowTicAdd { c x y} {
X global arrows places transitions mpars nodetypes
X set arrow [$c find withtag current]
X set record $arrows($arrow)
X set org [propGet $record org]
X set aim [propGet $record aim]
X set path [propGet $record path]
X set ticl [propGet $record tic]
X set porg [eval propGet $$nodetypes($org)s($org) pos]
X set paim [eval propGet $$nodetypes($aim)s($aim) pos]
X set xr [lindex $porg 0]
X set yr [lindex $porg 1]
X set i 0
X set flag 0
X foreach s "$path \{$paim\}" {
X set xs [lindex $s 0]
X set ys [lindex $s 1]
X set dx [expr $xs - $xr]
X set dy [expr $ys - $yr]
X if {$dx == 0} {
X if {($x == $xr)} {
X set ky [expr ( $y - $yr ) / $dy]
X if {($ky >= 0) && ($ky <= 1)} {
X set flag 1
X break
X }
X }
X } elseif {$dy == 0} {
X if {($y == $yr)} {
X set kx [expr ( $x - $xr ) / $dx]
X if {($kx >= 0) && ($kx <= 1)} {
X set flag 1
X break
X }
X }
X } else {
X set kx [expr ( $x - $xr ) / $dx]
X set ky [expr ( $y - $yr ) / $dy]
X if {($kx == $ky) && ($kx >= 0) && ($kx <= 1)} {
X set flag 1
X break
X }
X }
X set xr $xs
X set yr $ys
X incr i
X }
X if {$flag == 0} {
X puts "Sorry, please try again!"
X return
X }
X propPut arrows($arrow) path [linsert $path $i "$x $y"]
X set tic [ticNew $c $x $y arrow $arrow ""]
X propPut arrows($arrow) tic [linsert $ticl $i $tic]
X arrowRedraw $c $arrow
X}
X
X
X# Procedure: arrowTicBegin
Xproc arrowTicBegin { c} {
X global tics arrows nodetypes places transitions mpars ticbinding tic

X set tic [$c find withtag current]

X set arrow $tics($tic)
X set record $arrows($arrow)
X set step [lsearch [propGet $record tic] $tic]
X set path [propGet $record path]
X set lowpath [lrange $path 0 [expr $step - 1]]
X set focus [lindex $path $step]
X set highpath [lrange $path [expr $step + 1] end]
X set org [propGet $record org]
X set aim [propGet $record aim]
X set po [eval propGet $$nodetypes($org)s($org) pos]
X set pa [eval propGet $$nodetypes($aim)s($aim) pos]

X
X $c bind $tic <Any-Any-Motion> "ticPos %W $tic \[xlat %W %x\] \[ylat %W %y\]"
X set ticbinding [$c bind $tic <Shift-3>]
X $c bind $tic <Shift-3> ""
X

X bind $c <Any-Button3-Motion> "arrowTic %W $arrow \{$po\} \{$lowpath \{\[xlat %W %x\] \[ylat %W %y\]\} $highpath\} \{$pa\}"
X bind $c <Any-Button3-ButtonRelease> "arrowTicEnd %W $arrow \{$po\} \{$lowpath\} \[xlat %W %x\] \[ylat %W %y\] \{$highpath\} \{$pa\}"
X}
X
X
X# Procedure: arrowTicDelete
Xproc arrowTicDelete { c {tic ""} {arrow ""}} {
X global tics arrows
X
X if {$tic == ""} {set tic [$c find withtag current]}
X if {$arrow == ""} {set arrow $tics($tic)}
X
X set record $arrows($arrow)
X set ticl [propGet $record tic]
X set path [propGet $record path]
X set step [lsearch $ticl $tic]
X set newpath [concat [lrange $path 0 [expr $step - 1]] [lrange $path [expr $step + 1] end]]
X set newticl [concat [lrange $ticl 0 [expr $step - 1]] [lrange $ticl [expr $step + 1] end]]
X propPut arrows($arrow) path $newpath
X propPut arrows($arrow) tic $newticl
X arrowRedraw $c $arrow
X}
X
X
X# Procedure: arrowTicEnd
Xproc arrowTicEnd { c arrow po lopath x y highpath pa} {
X global arrows tic ticbinding

X
X $c bind $tic <Any-Any-Motion> ""
X bind $c <Shift-3> ""
X $c bind $tic <Shift-3> "$ticbinding"

X bind $c <Any-Button3-Motion> ""

X bind $c <Any-Button3-ButtonRelease> ""
X

X propPut arrows($arrow) path "$lopath \{$x $y\} $highpath"
X arrowRedraw $c $arrow
X}
X
END_OF_FILE
if test 13572 -ne `wc -c <'pips-0.1-alpha/arrow.tcl'`; then
echo shar: \"'pips-0.1-alpha/arrow.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/arrow.tcl'
fi
if test -f 'pips-0.1-alpha/node.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/node.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/node.tcl'\" $5380 characters$
sed "s/^X//" >'pips-0.1-alpha/node.tcl' <<'END_OF_FILE'
X# node.tcl -- nodes is the superclass of places and transitions

X# Procedure: nodeDrag
Xproc nodeDrag { c node inlist outlist x y {xmin ""} {xmax ""} {ymin ""} {ymax ""}} {

X global lastX lastY cDx cDy
X

X if {($xmax != "") && ($x > $xmax)} {set x $xmax}
X if {($xmin != "") && ($x < $xmin)} {set x $xmin}
X if {($ymax != "") && ($y > $ymax)} {set y $ymax}
X if {($ymin != "") && ($y < $ymin)} {set y $ymin}
X
X $c move current [expr $x-$lastX] [expr $y-$lastY]

X set cDx [expr $cDx + $x - $lastX]
X set cDy [expr $cDy + $y - $lastY]
X set lastX $x
X set lastY $y
X foreach i $inlist {
X eval arrowDragIn $i $c $cDx $cDy
X }
X foreach i $outlist {
X eval arrowDragOut $i $c $cDx $cDy
X }
X}
X
X

X# Procedure: nodeDragBegin
Xproc nodeDragBegin { c x y} {
X global places transitions mpars names arrows nodetypes modules

X global lastX lastY cDx cDy
X

X set node $names([$c find withtag current])
X set type $nodetypes($node)
X set pos [eval propGet $${type}s($node) pos]

X set lastX [lindex $pos 0]
X set lastY [lindex $pos 1]

X $c move current [expr $x-$lastX] [expr $y-$lastY]
X set cDx [expr $x - $lastX]
X set cDy [expr $y - $lastY]
X
X if {$type == "mpar"} {
X set mpos [propGet $modules($modules(mp-$node)) pos]
X set xmin [lindex $mpos 0]
X set ymin [lindex $mpos 1]
X set xmax [lindex $mpos 2]
X set ymax [lindex $mpos 3]
X } else {
X set xmin {}
X set xmax {}
X set ymin {}
X set ymax {}
X }
X
X set inlist {}
X propIter arrow end [eval propGet $${type}s($node) in] {
X lappend inlist "$lastX $lastY $arrow [eval propGet $$nodetypes($end)s($end) pos] \"[propGet $arrows($arrow) path]\""
X }
X set outlist {}
X propIter arrow end [eval propGet $${type}s($node) out] {
X lappend outlist "$lastX $lastY $arrow [eval propGet $$nodetypes($end)s($end) pos] \"[propGet $arrows($arrow) path]\""
X }
X
X $c bind $node <Any-Button3-Motion> "nodeDrag %W $node \{$inlist\} \{$outlist\} \[xlat %W %x\] \[ylat %W %y\] $xmin $xmax $ymin $ymax"
X $c bind $node <Any-Button3-ButtonRelease> "nodeDragEnd %W $type $node \{$inlist\} \{$outlist\} \[xlat %W %x\] \[ylat %W %y\] $xmin $xmax $ymin $ymax"
X

X set lastX $x
X set lastY $y
X}
X

X
X# Procedure: nodeDragEnd
Xproc nodeDragEnd { c type node inlist outlist x y {xmin ""} {xmax ""} {ymin ""} {ymax ""}} {
X $c bind $node <Any-Button3-Motion> ""
X $c bind $node <Any-Button3-ButtonRelease> ""
X
X if {($xmax != "") && ($x > $xmax)} {set x $xmax}
X if {($xmin != "") && ($x < $xmin)} {set x $xmin}
X if {($ymax != "") && ($y > $ymax)} {set y $ymax}
X if {($ymin != "") && ($y < $ymin)} {set y $ymin}
X
X global places transitions mpars lastX lastY cDx cDy
X $c move current [expr $x-$lastX] [expr $y-$lastY]

X set cDx [expr $cDx + $x - $lastX]
X set cDy [expr $cDy + $y - $lastY]
X

X propPut ${type}s($node) pos [list $x $y]

X
X foreach i $inlist {
X eval arrowDragIn $i $c $cDx $cDy
X }
X foreach i $outlist {
X eval arrowDragOut $i $c $cDx $cDy
X }
X}
X

X
X# Procedure: nodeRename
Xproc nodeRename { c oldname newname} {

X global nodetypes names arrows transitions places mpars modules

X
X if {[$c find withtag $newname] == ""} {
X # change name entry in canvas objects
X $c addtag $newname withtag $oldname
X $c dtag $newname $oldname
X
X # change name entry in id -> name mapping
X set names([$c find withtag $newname]) $newname
X

X # change name in nodetypes
X set type [set nodetypes($newname) $nodetypes($oldname)]
X unset nodetypes($oldname)

X
X # change name entry in plist array

X eval set ${type}s($newname) $${type}s($oldname)
X unset ${type}s($oldname)
X
X # change name entries in references
X propIter arrow end [eval propGet $${type}s($newname) in] {

X propPut arrows($arrow) aim $newname

X set reflist [eval propGet $$nodetypes($end)s($end) out]
X propPut reflist $arrow $newname

X propPut $nodetypes($end)s($end) out $reflist
X }

X propIter arrow end [eval propGet $${type}s($newname) out] {

X propPut arrows($arrow) org $newname

X set reflist [eval propGet $$nodetypes($end)s($end) in]
X propPut reflist $arrow $newname

X propPut $nodetypes($end)s($end) in $reflist
X }
X

X if {$type == "mpar"} {
X set mod [set modules(mp-$newname) $modules(mp-$oldname)]
X unset modules(mp-$oldname)
X set mip $mpars(ip-$mod)
X set mipnr [lsearch $mip $oldname]

X if {$mipnr == -1} {
X error "assertion failed in nodeRename"

X }
X set mpars(ip-$mod) [lreplace $mip $mipnr $mipnr $newname]

X }
X } else {
X error "new name is not unique: $newname"
X }
X}
X

END_OF_FILE
if test 5380 -ne `wc -c <'pips-0.1-alpha/node.tcl'`; then
echo shar: \"'pips-0.1-alpha/node.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/node.tcl'
fi
if test -f 'pips-0.1-alpha/pips' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/pips'\"
else
echo shar: Extracting \"'pips-0.1-alpha/pips'\" $63 characters$
sed "s/^X//" >'pips-0.1-alpha/pips' <<'END_OF_FILE'
X#!/bin/sh
X/usr/local/lib/pips/pips.tcl -x /usr/local/lib/pips
END_OF_FILE
if test 63 -ne `wc -c <'pips-0.1-alpha/pips'`; then
echo shar: \"'pips-0.1-alpha/pips'\" unpacked with wrong size!
fi
chmod +x 'pips-0.1-alpha/pips'
# end of 'pips-0.1-alpha/pips'
fi
if test -f 'pips-0.1-alpha/place.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/place.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/place.tcl'\" $5863 characters$
sed "s/^X//" >'pips-0.1-alpha/place.tcl' <<'END_OF_FILE'
X# place.tcl -- procedures concerned with places

Xset place.outline.color #000000
Xset place.hi.outline.color #a0a0a0
Xset place.fill.color #ffffff
Xset place.hi.fill.color #ffffff
X
X# Procedure: placeAdd
Xproc placeAdd { c x y args} {
X global place.outline.color place.fill.color
X global places names nodetypes

X set radius 6
X if {$args == ""} {

X set place [nameGen $c place]

X } else {
X if {[$c find withtag $args] == ""} {

X set place $args
X } else {
X error "placename redefined: $args"
X }
X }
X
X set item [$c create oval [expr $x - $radius] [expr $y - $radius] [expr $x + $radius] [expr $y + $radius] -outline ${place.outline.color} -fill ${place.fill.color} -tags "place node $place"]
X
X set names($item) $place
X
X set nodetypes($place) place
X
X set placeRec {}
X
X propPut placeRec cid $item
X propPut placeRec cap 1
X propPut placeRec type null
X propPut placeRec pos "$x $y"
X
X set places($place) $placeRec
X
X return $place
X}
X
X
X# Procedure: placeDelete
Xproc placeDelete { c {item ""}} {
X global names places nodetypes

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

X set place $names($item)
X set record $places($place)

X propIter i e [propGet $record in] {

X arrowDelete $c $i $e $place

X }
X propIter i e [propGet $record out] {

X arrowDelete $c $i $place $e

X }
X unset names([propGet $record cid])

X unset nodetypes($place)
X unset places($place)
X $c delete $place
X}
X
X
X# Procedure: placeEditBegin
Xproc placeEditBegin { c {w ""}} {
X global places tokentypes names
X global placeName placeType placeCap placeDesc
X
X set place $names([$c find withtag current])
X set placeName $place
X set placeRec $places($place)
X set placeType [propGet $placeRec type]
X set placeCap [propGet $placeRec cap]
X set placeDesc [propGet $placeRec desc]
X
X # build widget ${w}.placeEdit
X catch "destroy ${w}.placeEdit"
X toplevel ${w}.placeEdit

X
X # Window manager configurations

X global tkVersion
X wm positionfrom ${w}.placeEdit ""
X wm sizefrom ${w}.placeEdit ""
X wm title ${w}.placeEdit {Place}
X
X wdg_entry ${w}.placeEdit.name {Name:} placeName
X wdg_entry ${w}.placeEdit.tokenType {Token Type:} placeType [array names tokentypes]
X wdg_scale ${w}.placeEdit.capacity Capacity placeCap 1 100
X wdg_text ${w}.placeEdit.desc Description placeDesc
X wdg_confirm ${w}.placeEdit.confirm "placeEditEnd $c $w.placeEdit $place"
X
X # pack widget ${w}.placeEdit
X pack ${w}.placeEdit.name -side top -fill x
X pack ${w}.placeEdit.capacity -side top -fill x
X pack ${w}.placeEdit.tokenType -side top -fill x
X pack ${w}.placeEdit.desc -side top -fill x
X pack ${w}.placeEdit.confirm -side top -fill x
X
X tkwait visibility ${w}.placeEdit
X grab set ${w}.placeEdit
X}
X
X
X# Procedure: placeEditEnd
Xproc placeEditEnd { c w place ok} {

X destroy $w
X
X if {$ok == "ok"} {

X global places tokentypes
X global placeName placeType placeCap placeDesc
X
X if {[lsearch [array names tokentypes] $placeType] == -1} {
X tokenAdd $placeType
X }
X
X set placeRec $places($place)
X if {$placeName != $place} {
X nodeRename $c $place $placeName
X set place $placeName
X }
X
X propPut placeRec type $placeType
X propPut placeRec cap $placeCap
X propPut placeRec desc $placeDesc
X
X set places($place) $placeRec
X }
X}
X
X
X# Procedure: placeEnter
Xproc placeEnter { c} {
X global place.hi.outline.color place.hi.fill.color

X global currentNode names
X set currentNode $names([$c find withtag current])

X $c itemconfigure current -outline ${place.hi.outline.color} -fill ${place.hi.fill.color}
X}
X
X
X# Procedure: placeGetArrows
Xproc placeGetArrows { c p io} {
X global places
X propGet $places($p) $io
X}
X
X
X# Procedure: placeLeave
Xproc placeLeave { c} {
X global place.outline.color place.fill.color

X global currentNode
X set currentNode {}

X $c itemconfigure current -outline ${place.outline.color} -fill ${place.fill.color}
X}
X
X
X# Procedure: placeModeEnter
Xproc placeModeEnter { c} {
X bind $c <1> "placeAdd $c \[xlat %W %x\] \[ylat %W %y\]"
X}
X
X
X# Procedure: placeModeLeave
Xproc placeModeLeave { c} {

X bind $c <1> ""
X}
X
X

X# Procedure: placePutArrow
Xproc placePutArrow { c p io i e} {
X global places
X propPut places($p) $io [linsert [propGet $places($p) $io] 0 $i $e]
X}
X
X
X# Procedure: placeRemArrow
Xproc placeRemArrow { c p io i} {
X global places
X set a [propGet $places($p) $io]

X propRem a $io $i

X propPut places($p) $io $a
X}
X
X
X# Procedure: placeWrite
Xproc placeWrite { p {file "file1"}} {
X global places
X set rec $places($p)
X puts $file "PLACE $p \{"
X foreach i {desc type cap pos} {

X puts $file " $i \{[propGet $rec $i]\}"
X }

X puts $file "\}"
X}
X
X# Procedure: PLACE
Xproc PLACE { name plist} {
X global loadCanvas places tokentypes

X set pos [propGet $plist pos]
X set x [lindex $pos 0]
X set y [lindex $pos 1]

X set name [placeAdd $loadCanvas $x $y $name]
X update
X set rec $places($name)
X set type [propGet $plist type]
X if {[lsearch [array names tokentypes] $type] == -1} {
X tokenAdd $type
X }
X foreach p {desc type cap} {

X propPut rec $p [propGet $plist $p]
X }

X set places($name) $rec
X}
X
X
END_OF_FILE
if test 5863 -ne `wc -c <'pips-0.1-alpha/place.tcl'`; then
echo shar: \"'pips-0.1-alpha/place.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/place.tcl'
fi
if test -f 'pips-0.1-alpha/test.prn' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/test.prn'\"
else
echo shar: Extracting \"'pips-0.1-alpha/test.prn'\" $7877 characters$
sed "s/^X//" >'pips-0.1-alpha/test.prn' <<'END_OF_FILE'
X%!PS-Adobe-3.0 EPSF-3.0
X%%Creator: Tk Canvas Widget
X%%For: & Schadow,Hopfenweg 19; Berlin 12357,,(030)6618841
X%%Title: Window .mainframe.canvas
X%%CreationDate: Thu Sep 15 02:25:38 1994
X%%BoundingBox: 18 234 594 558
X%%Pages: 1
X%%DocumentData: Clean7Bit
X%%Orientation: Portrait
X%%EndComments
X
X% This file contains the standard Postscript prolog used when
X% generating Postscript from canvas widgets.
X%
X% $Header: /user6/ouster/wish/library/RCS/prolog.ps,v 1.6 93/04/01 14:03:52 ouster Exp $ SPRITE (Berkeley);
X
X%%BeginProlog
X50 dict begin
X
X% The definitions below just define all of the variables used in
X% any of the procedures here. This is needed for obscure reasons
X% explained on p. 716 of the Postscript manual (Section H.2.7,
X% "Initializing Variables," in the section on Encapsulated Postscript).
X
X/baseline 0 def
X/stipimage 0 def
X/height 0 def
X/justify 0 def
X/maxwidth 0 def
X/spacing 0 def
X/stipple 0 def
X/strings 0 def
X/xoffset 0 def
X/yoffset 0 def
X/tmpstip null def
X/encoding {ISOLatin1Encoding} def
X
X% Override setfont to automatically encode the font in the style defined by
X% by 'encoding' (ISO Latin1 by default).
X
Xsystemdict /encodefont known {
X /realsetfont /setfont load def
X /setfont {
X encoding encodefont realsetfont
X } def
X} if
X
X% desiredSize EvenPixels closestSize
X%
X% The procedure below is used for stippling. Given the optimal size
X% of a dot in a stipple pattern in the current user coordinate system,
X% compute the closest size that is an exact multiple of the device's
X% pixel size. This allows stipple patterns to be displayed without
X% aliasing effects.
X
X/EvenPixels {
X % Compute exact number of device pixels per stipple dot.
X dup 0 matrix currentmatrix dtransform
X dup mul exch dup mul add sqrt
X
X % Round to an integer, make sure the number is at least 1, and compute
X % user coord distance corresponding to this.
X dup round dup 1 lt {pop 1} if
X exch div mul
X} bind def
X
X% width height string filled StippleFill --
X%
X% Given a path and other graphics information already set up, this
X% procedure will fill the current path in a stippled fashion. "String"
X% contains a proper image description of the stipple pattern and
X% "width" and "height" give its dimensions. If "filled" is true then
X% it means that the area to be stippled is gotten by filling the
X% current path (e.g. the interior of a polygon); if it's false, the
X% area is gotten by stroking the current path (e.g. a wide line).
X% Each stipple dot is assumed to be about one unit across in the
X% current user coordinate system.
X
X/StippleFill {
X % Turn the path into a clip region that we can then cover with
X % lots of images corresponding to the stipple pattern. Warning:
X % some Postscript interpreters get errors during strokepath for
X % dashed lines. If this happens, turn off dashes and try again.
X
X 1 index /tmpstip exch def %% Works around NeWSprint bug
X
X gsave
X {eoclip}
X {{strokepath} stopped {grestore gsave [] 0 setdash strokepath} if clip}
X ifelse
X
X % Change the scaling so that one user unit in user coordinates
X % corresponds to the size of one stipple dot.
X 1 EvenPixels dup scale
X
X % Compute the bounding box occupied by the path (which is now
X % the clipping region), and round the lower coordinates down
X % to the nearest starting point for the stipple pattern.
X
X pathbbox
X 4 2 roll
X 5 index div cvi 5 index mul 4 1 roll
X 6 index div cvi 6 index mul 3 2 roll
X
X % Stack now: width height string y1 y2 x1 x2
X % Below is a doubly-nested for loop to iterate across this area
X % in units of the stipple pattern size, going up columns then
X % across rows, blasting out a stipple-pattern-sized rectangle at
X % each position
X
X 6 index exch {
X 2 index 5 index 3 index {
X % Stack now: width height string y1 y2 x y
X
X gsave
X 1 index exch translate
X 5 index 5 index true matrix tmpstip imagemask
X grestore
X } for
X pop
X } for
X pop pop pop pop pop
X grestore
X newpath
X} bind def
X
X% -- AdjustColor --
X% Given a color value already set for output by the caller, adjusts
X% that value to a grayscale or mono value if requested by the CL
X% variable.
X
X/AdjustColor {
X CL 2 lt {
X currentgray
X CL 0 eq {
X .5 lt {0} {1} ifelse
X } if
X setgray
X } if
X} bind def
X
X% x y strings spacing xoffset yoffset justify stipple stipimage DrawText --
X% This procedure does all of the real work of drawing text. The
X% color and font must already have been set by the caller, and the
X% following arguments must be on the stack:
X%
X% x, y - Coordinates at which to draw text.
X% strings - An array of strings, one for each line of the text item,
X% in order from top to bottom.
X% spacing - Spacing between lines.
X% xoffset - Horizontal offset for text bbox relative to x and y: 0 for
X% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.
X% yoffset - Vertical offset for text bbox relative to x and y: 0 for
X% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.
X% justify - 0 for left justification, 0.5 for center, 1 for right justify.
X% stipple - Boolean value indicating whether or not text is to be
X% drawn in stippled fashion.
X% stipimage - Image for stippling, if stipple is True.
X%
X% Also, when this procedure is invoked, the color and font must already
X% have been set for the text.
X
X/DrawText {
X /stipimage exch def
X /stipple exch def
X /justify exch def
X /yoffset exch def
X /xoffset exch def
X /spacing exch def
X /strings exch def
X
X % First scan through all of the text to find the widest line.
X
X /maxwidth 0 def
X strings {
X stringwidth pop
X dup maxwidth gt {/maxwidth exch def} {pop} ifelse
X newpath
X } forall
X
X % Compute the baseline offset and the actual font height.
X
X 0 0 moveto (TXygqPZ) false charpath
X pathbbox dup /baseline exch def
X exch pop exch sub /height exch def pop
X newpath
X
X % Translate coordinates first so that the origin is at the upper-left
X % corner of the text's bounding box. Remember that x and y for
X % positioning are still on the stack.
X
X translate
X maxwidth xoffset mul
X strings length 1 sub spacing mul height add yoffset mul translate
X
X % Now use the baseline and justification information to translate so
X % that the origin is at the baseline and positioning point for the
X % first line of text.
X
X justify maxwidth mul baseline neg translate
X
X % Iterate over each of the lines to output it. For each line,
X % compute its width again so it can be properly justified, then
X % display it.
X
X strings {
X dup stringwidth pop
X justify neg mul 0 moveto
X show
X 0 spacing neg translate
X } forall
X} bind def
X
X%%EndProlog
X%%BeginSetup
X/CL 2 def
X%%EndSetup
X
X%%Page: 1 1
Xsave
X306.0 396.0 translate
X0.9578 0.9578 scale
X-300 -169 translate
X0 338 moveto 600 338 lineto 600 0 lineto 0 0 lineto closepath clip newpath
Xgsave
Xmatrix currentmatrix
X90 158 translate 6 6 scale 1 0 moveto 0 0 1 0 360 arc
Xsetmatrix
X0.000 0.889 0.000 setrgbcolor AdjustColor
Xfill
Xmatrix currentmatrix
X90 158 translate 6 6 scale 1 0 moveto 0 0 1 0 360 arc
Xsetmatrix
X1 setlinewidth 0 setlinejoin 2 setlinecap
X0.000 0.000 0.000 setrgbcolor AdjustColor
Xstroke
Xgrestore
Xgsave
Xmatrix currentmatrix
X90 140 translate 6 6 scale 1 0 moveto 0 0 1 0 360 arc
Xsetmatrix
X0.000 0.889 0.000 setrgbcolor AdjustColor
Xfill
Xmatrix currentmatrix
X90 140 translate 6 6 scale 1 0 moveto 0 0 1 0 360 arc
Xsetmatrix
X1 setlinewidth 0 setlinejoin 2 setlinecap
X0.000 0.000 0.000 setrgbcolor AdjustColor
Xstroke
Xgrestore
Xgsave
Xmatrix currentmatrix
X90 122 translate 6 6 scale 1 0 moveto 0 0 1 0 360 arc
Xsetmatrix
X0.000 0.889 0.000 setrgbcolor AdjustColor
Xfill
Xmatrix currentmatrix
X90 122 translate 6 6 scale 1 0 moveto 0 0 1 0 360 arc
Xsetmatrix
X1 setlinewidth 0 setlinejoin 2 setlinecap
X0.000 0.000 0.000 setrgbcolor AdjustColor
Xstroke
Xgrestore
Xrestore showpage
X
X%%Trailer
Xend
X%%EOF
END_OF_FILE
if test 7877 -ne `wc -c <'pips-0.1-alpha/test.prn'`; then
echo shar: \"'pips-0.1-alpha/test.prn'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/test.prn'
fi
if test -f 'pips-0.1-alpha/widget.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/widget.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/widget.tcl'\" $11087 characters$
sed "s/^X//" >'pips-0.1-alpha/widget.tcl' <<'END_OF_FILE'
X# widget.tcl -- things that focus on Tk widgets

X# default color settings
Xset canvas.color #ffffff
X
X# procedure to show root window
Xproc root {} {

X # Window manager configurations

X wm positionfrom . ""
X wm sizefrom . program
X wm geometry . 600x500
X wm maxsize . 1024 1024
X wm minsize . 430 400
X wm title . {Pips:unnamed.net}
X
X # build widget .topmenu
X frame .topmenu \
X -borderwidth {2} \
X -relief {raised}
X
X # build widget .topmenu.file
X menubutton .topmenu.file \
X -menu {.topmenu.file.m} \
X -text {File}
X
X # build widget .topmenu.file.m
X menu .topmenu.file.m
X .topmenu.file.m add command \
X -command {netNew .mainframe.canvas} \
X -label {New}
X .topmenu.file.m add command \
X -command {fileSelectBegin {netLoad .mainframe.canvas} Open} \
X -label {Open}
X .topmenu.file.m add separator
X .topmenu.file.m add command \
X -command {netSave .mainframe.canvas $NETNAME} \
X -label {Save}
X .topmenu.file.m add command \
X -command {fileSelectBegin {netSave .mainframe.canvas} {Save as ...}} \
X -label {Save as ...}
X .topmenu.file.m add separator
X .topmenu.file.m add command \
X -command {netPrintBegin .mainframe.canvas} \
X -label {Print}
X .topmenu.file.m add separator
X .topmenu.file.m add command \
X -command {exit} \
X -label {Exit}
X .topmenu.file.m add separator
X .topmenu.file.m add command \
X -command {showGlobals} \
X -label {Debug}
X
X # build widget .topmenu.edit
X menubutton .topmenu.edit \
X -menu {.topmenu.edit.m} \
X -text {Edit}
X
X # build widget .topmenu.edit.m
X menu .topmenu.edit.m
X .topmenu.edit.m add cascade \
X -label {Insert} \
X -menu {.topmenu.edit.m.insert}
X .topmenu.edit.m add radiobutton \
X -command {modeSwitch move .mainframe.canvas} \
X -label {Move} \
X -value {move} \
X -variable {currentModeRB}
X .topmenu.edit.m add radiobutton \
X -command {modeSwitch edit .mainframe.canvas} \
X -label {Edit} \
X -value {edit} \
X -variable {currentModeRB}
X .topmenu.edit.m add radiobutton \
X -command {modeSwitch delete .mainframe.canvas} \
X -label {Delete} \
X -value {delete} \
X -variable {currentModeRB}
X .topmenu.edit.m add separator
X .topmenu.edit.m add radiobutton \
X -command {modeSwitch lower .mainframe.canvas} \
X -label {Lower} \
X -value {lower} \
X -variable {currentModeRB}
X .topmenu.edit.m add radiobutton \
X -command {modeSwitch raise .mainframe.canvas} \
X -label {Raise} \
X -value {raise} \
X -variable {currentModeRB}
X
X # build widget .topmenu.edit.m.insert
X menu .topmenu.edit.m.insert
X .topmenu.edit.m.insert add radiobutton \
X -command {modeSwitch place .mainframe.canvas} \
X -label {Place} \
X -value {place} \
X -variable {currentModeRB}
X .topmenu.edit.m.insert add radiobutton \
X -command {modeSwitch transition .mainframe.canvas} \
X -label {Transition} \
X -value {transition} \
X -variable {currentModeRB}
X .topmenu.edit.m.insert add radiobutton \
X -command {modeSwitch arrow .mainframe.canvas} \
X -label {Arrow} \
X -value {arrow} \
X -variable {currentModeRB}
X .topmenu.edit.m.insert add radiobutton \
X -command {modeSwitch module .mainframe.canvas} \
X -label {Module} \
X -value {module} \
X -variable {currentModeRB}
X
X # pack widget .topmenu
X pack append .topmenu \
X .topmenu.file {left frame nw} \
X .topmenu.edit {left frame center}
X
X # build widget .mainframe
X frame .mainframe \
X -borderwidth {2} \
X -relief {raised}
X
X # build widget .mainframe.scrolly
X scrollbar .mainframe.scrolly \
X -command {.mainframe.canvas yview} \
X -relief {groove} \
X -width {12}
X
X # build widget .mainframe.scrollx
X scrollbar .mainframe.scrollx \
X -command {.mainframe.canvas xview} \
X -orient {horizontal} \
X -relief {groove} \
X -width {12}
X
X # build widget .mainframe.canvas
X global canvas.color
X canvas .mainframe.canvas \
X -background ${canvas.color} \
X -height {207} \
X -insertofftime {600} \
X -relief {sunken} \
X -scrollregion {0c 0c 100c 100c} \
X -width {296} \
X -xscrollcommand {.mainframe.scrollx set} \
X -yscrollcommand {.mainframe.scrolly set}
X
X # pack widget .mainframe
X pack append .mainframe \
X .mainframe.scrolly {left frame center filly} \
X .mainframe.scrollx {bottom frame center fillx} \
X .mainframe.canvas {top frame nw expand fill}
X
X # build widget .modeline
X frame .modeline \
X -borderwidth {2} \
X -cursor {hand1} \
X -relief {raised}
X
X # build widget .modeline.place
X radiobutton .modeline.place \
X -command {modeSwitch place .mainframe.canvas} \
X -cursor {hand1} \
X -relief {flat} \
X -text {Place} \
X -value {place} \
X -variable {currentModeRB}
X
X # build widget .modeline.transition
X radiobutton .modeline.transition \
X -command {modeSwitch transition .mainframe.canvas} \
X -cursor {hand1} \
X -relief {flat} \
X -text {Transition} \
X -value {transition} \
X -variable {currentModeRB}
X
X # build widget .modeline.arrow
X radiobutton .modeline.arrow \
X -command {modeSwitch arrow .mainframe.canvas} \
X -cursor {hand1} \
X -relief {flat} \
X -text {Arrow} \
X -value {arrow} \
X -variable {currentModeRB}
X
X # build widget .modeline.module
X radiobutton .modeline.module \
X -command {modeSwitch module .mainframe.canvas} \
X -cursor {hand1} \
X -relief {flat} \
X -text {Module} \
X -value {module} \
X -variable {currentModeRB}
X
X # build widget .modeline.current
X entry .modeline.current \
X -relief {sunken} \
X -textvariable {currentNode} \
X -width {18}
X
X # pack widget .modeline
X pack append .modeline \
X .modeline.place {left frame center} \
X .modeline.transition {left frame center} \
X .modeline.arrow {left frame center} \
X .modeline.module {left frame center} \
X .modeline.current {right frame center}
X
X # pack widget .
X pack append . \
X .topmenu {top frame nw fillx} \
X .mainframe {top frame center expand fill} \
X .modeline {top frame center fillx}
X
X}
X
X
X# Procedure: xlat
Xproc xlat { c x} {
X global GRID
X return [$c canvasx $x $GRID]
X}
X
X
X# Procedure: ylat
Xproc ylat { c y} {
X global GRID
X return [$c canvasy $y $GRID]
X}
X
X
X# Procedure: fileSelectBegin
Xproc fileSelectBegin { cmd title} {
X global fileName
X
X set fileName "*"
X set w ""
X
X # build widget ${w}.file
X catch "destroy ${w}.file"
X toplevel ${w}.file

X
X # Window manager configurations

X wm positionfrom ${w}.file ""
X wm sizefrom ${w}.file ""
X wm title ${w}.file "$title"
X
X wdg_entry ${w}.file.name {File:} fileName {[glob $fileName]}
X wdg_confirm ${w}.file.confirm "fileSelectEnd $w.file \{$cmd\}"
X
X # pack widget ${w}.file
X pack ${w}.file.name -side top -fill x
X pack ${w}.file.confirm -side top -fill x
X
X tkwait visibility ${w}.file
X grab set ${w}.file
X}
X
X
X# Procedure: fileSelectEnd
Xproc fileSelectEnd { w cmd ok} {
X destroy $w
X
X global fileName

X
X if {$ok == "ok"} {

X eval $cmd $fileName
X }
X}
X
X
X# Procedure: wdg_buttons
Xproc wdg_buttons { w plist} {
X frame ${w} -borderwidth {2} -relief {flat}
X
X set i 0
X propIter type def $plist {
X eval $type ${w}.button$i $def
X pack ${w}.button$i -side left
X incr i
X }
X}
X
X
X# Procedure: wdg_confirm
Xproc wdg_confirm { w command} {

X # build widget ${w}

X frame ${w} -borderwidth {2} -relief {flat}
X
X # build widget ${w}.ok
X button ${w}.ok -command "$command ok" -text {O.K.}
X
X # build widget ${w}.cancel
X button ${w}.cancel -command "$command cancel" -text {Cancel}

X
X # pack widget ${w}

X pack append ${w} ${w}.ok {left frame center} ${w}.cancel {left frame center}
X}
X
X
X# Procedure: wdg_entry
Xproc wdg_entry { w label variable {list ""}} {
X # build widget $w
X frame ${w} -borderwidth {2} -relief {flat}
X
X # build widget ${w}.label
X label ${w}.label -text "$label"
X
X # build widget ${w}.entry
X entry ${w}.entry -relief {sunken} -textvariable "$variable" -width {26}

X
X # pack widget ${w}

X pack append ${w} ${w}.label {left frame center expand} ${w}.entry {left frame center}
X
X if {$list != ""} {
X bind ${w}.entry <2> "wdg_select %W %X %Y \"$label\" $variable \"$list\""
X }
X}
X
X
X# Procedure: wdg_listbox
Xproc wdg_listbox { w variable list} {
X global $variable
X
X # build widget ${w}.scrollbar
X scrollbar ${w}.scrollbar -relief groove -command "${w}.list yview" -width 12 -cursor hand1
X
X # build widget ${w}.list
X listbox ${w}.list -relief {sunken} -yscrollcommand "${w}.scrollbar set" -cursor hand1
X
X # bindings
X bind ${w}.list <1> {%W select from [%W nearest %y]}
X bind ${w}.list <Double-Button-1> "
X set $variable \[%W get \[%W nearest %y\]\]
X destroy ${w}"

X
X # pack widget ${w}

X pack ${w}.scrollbar -side right -fill y
X pack ${w}.list
X
X foreach i [lsort $list] {
X ${w}.list insert end $i
X }
X}
X
X
X# Procedure: wdg_scale
Xproc wdg_scale { w label variable min max} {
X global $variable

X
X # build widget ${w}

X frame ${w} -borderwidth {2} -relief {flat}
X
X # build widget ${w}.scale
X scale ${w}.scale -command "set $variable" -from "$min" -to "$max" -label "$label" -orient {horizontal} -sliderlength {24} -width {8}
X
X eval ${w}.scale set $$variable

X
X # pack widget ${w}

X pack append ${w} ${w}.scale {top frame w fillx}
X}
X
X
X# Procedure: wdg_select
Xproc wdg_select { w x y label variable list} {
X set v ${w}.$variable
X
X catch "destroy ${v}"
X toplevel ${v} -relief {raised}

X
X # Window manager configurations

X wm overrideredirect ${v} 1
X wm positionfrom ${v} program
X wm geometry ${v} +${x}+${y}
X wm title ${v} "$label"
X wm transient ${v} ${v}
X
X wdg_listbox ${v} $variable $list
X
X tkwait visibility $v
X grab set $v
X}
X
X
X# Procedure: wdg_text
Xproc wdg_text { w label variable} {
X global $variable

X
X # build widget ${w}

X frame ${w} -borderwidth {2} -relief {flat}
X
X # build widget ${w}.label
X label ${w}.label -text "$label" -relief {flat}
X
X # build widget ${w}.vscroll
X scrollbar ${w}.vscroll -orient {vertical} -relief {groove} -command "${w}.text yview" -width {12}
X
X # build widget ${w}.text
X text ${w}.text -relief {sunken} -borderwidth {2} -height {10} -width {35} -yscrollcommand "${w}.vscroll set" -wrap {word}

X
X # pack widget ${w}

X pack ${w}.label -side top -fill x
X pack ${w}.vscroll -side right -fill y
X pack ${w}.text
X
X eval ${w}.text insert end $$variable
X bind ${w}.text <Any-KeyRelease> "set $variable \[${w}.text get 1.0 end\]"
X}
X
END_OF_FILE
if test 11087 -ne `wc -c <'pips-0.1-alpha/widget.tcl'`; then
echo shar: \"'pips-0.1-alpha/widget.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/widget.tcl'
fi
echo shar: End of archive 2 $of 3$.
cp /dev/null ark2isdone

Gunther Schadow

unread,

Mar 14, 1995, 9:57:29 PM3/14/95

Submitted-by: gu...@zedat.fu-berlin.de (Gunther Schadow)
Posting-number: Volume 23, Issue 9
Archive-name: pips/part03

Environment: X11, Tcl/Tk, petri nets

#! /bin/sh

# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".

# Contents: pips-0.1-alpha/Makefile pips-0.1-alpha/colors.tcl
# pips-0.1-alpha/colors.tcl.bw pips-0.1-alpha/colors.tcl.co1
# pips-0.1-alpha/colors.tcl.co2 pips-0.1-alpha/colors.tcl.co3
# pips-0.1-alpha/colors.tcl.gr pips-0.1-alpha/colors.tcl.nofill
# pips-0.1-alpha/debug.tcl pips-0.1-alpha/edit.tcl
# pips-0.1-alpha/net.tcl pips-0.1-alpha/pips.tcl
# pips-0.1-alpha/structure.tcl pips-0.1-alpha/tic.tcl
# pips-0.1-alpha/tokentype.tcl
# Wrapped by chris@ftp on Tue Mar 14 17:26:38 1995

PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin:$PATH ; export PATH
echo If this archive is complete, you will see the following message:

echo ' "shar: End of archive 3 (of 3)."'
if test -f 'pips-0.1-alpha/Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/Makefile'\"
else
echo shar: Extracting \"'pips-0.1-alpha/Makefile'\" $634 characters$
sed "s/^X//" >'pips-0.1-alpha/Makefile' <<'END_OF_FILE'
X#
X# Pips makefile
X#
X
Xprefix = /usr/local
Xbindir = $(prefix)/bin
Xlibdir = $(prefix)/lib/pips
X
XINSTALL = install -c
X
X# you don't need to change anything below
X
Xallsrc = arrow.tcl debug.tcl edit.tcl module.tcl net.tcl node.tcl \
X place.tcl structure.tcl tic.tcl tokentype.tcl transition.tcl \
X widget.tcl colors.tcl
X
Xmain = pips.tcl
X
Xexec = pips
X
Xall: $(allsrc) $(main) $(exec)
X
Xinstall: all
X mkdir -p $(libdir)
X $(INSTALL) -m 644 $(allsrc) $(libdir)
X $(INSTALL) -m 755 $(main) $(libdir)
X $(INSTALL) -m 755 $(exec) $(bindir)
X
X$(exec): Makefile
X @echo "#!/bin/sh" > $(exec)
X @echo "$(libdir)/pips.tcl -x $(libdir) $$*" >> $(exec)
END_OF_FILE
if test 634 -ne `wc -c <'pips-0.1-alpha/Makefile'`; then
echo shar: \"'pips-0.1-alpha/Makefile'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/Makefile'
fi
if test -f 'pips-0.1-alpha/colors.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/colors.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/colors.tcl'\" $798 characters$
sed "s/^X//" >'pips-0.1-alpha/colors.tcl' <<'END_OF_FILE'
X# color default settings for Pips
X

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080

Xset canvas.color #f8f8f8
Xset module.fill.color {}
Xset module.outline.color #000000
Xset module.hi.fill.color {}
Xset module.hi.outline.color #808080
Xset mpar.fill.color #e0e000
Xset mpar.outline.color #000000
Xset mpar.hi.fill.color #ffff00
Xset mpar.hi.outline.color #808080
Xset place.outline.color #000000
Xset place.hi.outline.color #808080
Xset place.fill.color #00e000
Xset place.hi.fill.color #00ff00
Xset tic.hi.fill.color #c0c0c0
Xset tic.hi.outline.color #c0c0c0
Xset tic.fill.color #606060
Xset tic.outline.color #606060
Xset transition.outline.color #000000
Xset transition.hi.outline.color #808080
Xset transition.fill.color #e00000
Xset transition.hi.fill.color #ff0000
X
X
END_OF_FILE
if test 798 -ne `wc -c <'pips-0.1-alpha/colors.tcl'`; then
echo shar: \"'pips-0.1-alpha/colors.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/colors.tcl'
fi
if test -f 'pips-0.1-alpha/colors.tcl.bw' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/colors.tcl.bw'\"
else
echo shar: Extracting \"'pips-0.1-alpha/colors.tcl.bw'\" $799 characters$
sed "s/^X//" >'pips-0.1-alpha/colors.tcl.bw' <<'END_OF_FILE'
X# color default settings
X

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080

Xset canvas.color #ffffff

Xset module.fill.color #ffffff
Xset module.outline.color #000000
Xset module.hi.fill.color #ffffff
Xset module.hi.outline.color #808080
Xset mpar.fill.color #ffffff
Xset mpar.outline.color #000000
Xset mpar.hi.fill.color #ffffff
Xset mpar.hi.outline.color #808080

Xset place.outline.color #000000
Xset place.hi.outline.color #808080

Xset place.fill.color #ffffff
Xset place.hi.fill.color #ffffff

Xset tic.hi.fill.color #808080
Xset tic.hi.outline.color #000000
Xset tic.fill.color #808080
Xset tic.outline.color #808080
Xset transition.outline.color #000000
Xset transition.hi.outline.color #808080

Xset transition.fill.color #ffffff
Xset transition.hi.fill.color #ffffff
X
X

END_OF_FILE
if test 799 -ne `wc -c <'pips-0.1-alpha/colors.tcl.bw'`; then
echo shar: \"'pips-0.1-alpha/colors.tcl.bw'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/colors.tcl.bw'
fi
if test -f 'pips-0.1-alpha/colors.tcl.co1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/colors.tcl.co1'\"
else
echo shar: Extracting \"'pips-0.1-alpha/colors.tcl.co1'\" $799 characters$
sed "s/^X//" >'pips-0.1-alpha/colors.tcl.co1' <<'END_OF_FILE'
X# color default settings
X

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080

Xset canvas.color #f8f8f8
Xset module.fill.color #00e0e0
Xset module.outline.color #00e0e0
Xset module.hi.fill.color #00ffff
Xset module.hi.outline.color #00ffff
Xset mpar.fill.color #e0e000
Xset mpar.outline.color #e0e000
Xset mpar.hi.fill.color #ffff00
Xset mpar.hi.outline.color #ffff00
Xset place.outline.color #00e000
Xset place.hi.outline.color #00ff00
Xset place.fill.color #00e000
Xset place.hi.fill.color #00ff00
Xset tic.hi.fill.color #a0a0a0
Xset tic.hi.outline.color #a0a0a0
Xset tic.fill.color #606060
Xset tic.outline.color #606060
Xset transition.outline.color #e000e0
Xset transition.hi.outline.color #ff00ff
Xset transition.fill.color #e000e0
Xset transition.hi.fill.color #ff00ff
X
X
END_OF_FILE
if test 799 -ne `wc -c <'pips-0.1-alpha/colors.tcl.co1'`; then
echo shar: \"'pips-0.1-alpha/colors.tcl.co1'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/colors.tcl.co1'
fi
if test -f 'pips-0.1-alpha/colors.tcl.co2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/colors.tcl.co2'\"
else
echo shar: Extracting \"'pips-0.1-alpha/colors.tcl.co2'\" $799 characters$
sed "s/^X//" >'pips-0.1-alpha/colors.tcl.co2' <<'END_OF_FILE'
X# color default settings
X

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080

Xset canvas.color #f8f8f8
Xset module.fill.color #0000e0
Xset module.outline.color #0000e0
Xset module.hi.fill.color #0000ff
Xset module.hi.outline.color #0000ff
Xset mpar.fill.color #e0e000
Xset mpar.outline.color #e0e000
Xset mpar.hi.fill.color #ffff00
Xset mpar.hi.outline.color #ffff00
Xset place.outline.color #00e000
Xset place.hi.outline.color #00ff00
Xset place.fill.color #00e000
Xset place.hi.fill.color #00ff00
Xset tic.hi.fill.color #a0a0a0
Xset tic.hi.outline.color #a0a0a0
Xset tic.fill.color #606060
Xset tic.outline.color #606060
Xset transition.outline.color #e000e0
Xset transition.hi.outline.color #ff0000
Xset transition.fill.color #e00000
Xset transition.hi.fill.color #ff0000
X
X
END_OF_FILE
if test 799 -ne `wc -c <'pips-0.1-alpha/colors.tcl.co2'`; then
echo shar: \"'pips-0.1-alpha/colors.tcl.co2'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/colors.tcl.co2'
fi
if test -f 'pips-0.1-alpha/colors.tcl.co3' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/colors.tcl.co3'\"
else
echo shar: Extracting \"'pips-0.1-alpha/colors.tcl.co3'\" $798 characters$
sed "s/^X//" >'pips-0.1-alpha/colors.tcl.co3' <<'END_OF_FILE'
X# color default settings for Pips
X

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080

Xset canvas.color #f8f8f8
Xset module.fill.color {}
Xset module.outline.color #000000
Xset module.hi.fill.color {}
Xset module.hi.outline.color #808080
Xset mpar.fill.color #e0e000
Xset mpar.outline.color #000000
Xset mpar.hi.fill.color #ffff00
Xset mpar.hi.outline.color #808080
Xset place.outline.color #000000
Xset place.hi.outline.color #808080
Xset place.fill.color #00e000
Xset place.hi.fill.color #00ff00
Xset tic.hi.fill.color #c0c0c0
Xset tic.hi.outline.color #c0c0c0
Xset tic.fill.color #606060
Xset tic.outline.color #606060
Xset transition.outline.color #000000
Xset transition.hi.outline.color #808080
Xset transition.fill.color #e00000
Xset transition.hi.fill.color #ff0000
X
X
END_OF_FILE
if test 798 -ne `wc -c <'pips-0.1-alpha/colors.tcl.co3'`; then
echo shar: \"'pips-0.1-alpha/colors.tcl.co3'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/colors.tcl.co3'
fi
if test -f 'pips-0.1-alpha/colors.tcl.gr' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/colors.tcl.gr'\"
else
echo shar: Extracting \"'pips-0.1-alpha/colors.tcl.gr'\" $799 characters$
sed "s/^X//" >'pips-0.1-alpha/colors.tcl.gr' <<'END_OF_FILE'
X# color default settings
X

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080

Xset canvas.color #f8f8f8
Xset module.fill.color #f8f8f8
Xset module.outline.color #000000
Xset module.hi.fill.color #f8f8f8
Xset module.hi.outline.color #808080
Xset mpar.fill.color #f8f8f8
Xset mpar.outline.color #000000
Xset mpar.hi.fill.color #f8f8f8
Xset mpar.hi.outline.color #808080
Xset place.outline.color #000000
Xset place.hi.outline.color #808080
Xset place.fill.color #f8f8f8
Xset place.hi.fill.color #f8f8f8
Xset tic.hi.fill.color #808080
Xset tic.hi.outline.color #000000
Xset tic.fill.color #808080
Xset tic.outline.color #808080
Xset transition.outline.color #000000
Xset transition.hi.outline.color #808080
Xset transition.fill.color #f8f8f8
Xset transition.hi.fill.color #f8f8f8
X
X
END_OF_FILE
if test 799 -ne `wc -c <'pips-0.1-alpha/colors.tcl.gr'`; then
echo shar: \"'pips-0.1-alpha/colors.tcl.gr'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/colors.tcl.gr'
fi
if test -f 'pips-0.1-alpha/colors.tcl.nofill' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/colors.tcl.nofill'\"
else
echo shar: Extracting \"'pips-0.1-alpha/colors.tcl.nofill'\" $798 characters$
sed "s/^X//" >'pips-0.1-alpha/colors.tcl.nofill' <<'END_OF_FILE'
X# color default settings for Pips
X

Xset arrow.color #000000
Xset arrow.hi.color #808080
Xset arrow.new.color #808080

Xset canvas.color #f8f8f8
Xset module.fill.color {}
Xset module.outline.color #000000
Xset module.hi.fill.color {}
Xset module.hi.outline.color #808080
Xset mpar.fill.color #e0e000
Xset mpar.outline.color #000000
Xset mpar.hi.fill.color #ffff00
Xset mpar.hi.outline.color #808080
Xset place.outline.color #000000
Xset place.hi.outline.color #808080
Xset place.fill.color #00e000
Xset place.hi.fill.color #00ff00
Xset tic.hi.fill.color #c0c0c0
Xset tic.hi.outline.color #c0c0c0
Xset tic.fill.color #606060
Xset tic.outline.color #606060
Xset transition.outline.color #000000
Xset transition.hi.outline.color #808080
Xset transition.fill.color #e00000
Xset transition.hi.fill.color #ff0000
X
X
END_OF_FILE
if test 798 -ne `wc -c <'pips-0.1-alpha/colors.tcl.nofill'`; then
echo shar: \"'pips-0.1-alpha/colors.tcl.nofill'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/colors.tcl.nofill'
fi
if test -f 'pips-0.1-alpha/debug.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/debug.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/debug.tcl'\" $1130 characters$
sed "s/^X//" >'pips-0.1-alpha/debug.tcl' <<'END_OF_FILE'
X# debug.tcl -- things that I use to debug pips

X# Procedure: showGlobals
Xproc showGlobals {} {
X foreach i {tokentypes names modules nodetypes places transitions mpars arrows tics tictypes} {
X global $i
X puts $i
X arrIter n p $i {puts "$n: $p"}
X }
X}
X
X
X# Procedure: tracevar
Xproc tracevar { n {e ""} {o ""}} {
X upvar $n x
X puts "trace $n $e $o: $x"
X}
X
X
END_OF_FILE
if test 1130 -ne `wc -c <'pips-0.1-alpha/debug.tcl'`; then
echo shar: \"'pips-0.1-alpha/debug.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/debug.tcl'
fi
if test -f 'pips-0.1-alpha/edit.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/edit.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/edit.tcl'\" $2364 characters$
sed "s/^X//" >'pips-0.1-alpha/edit.tcl' <<'END_OF_FILE'
X# edit.tcl -- misc editing procedures

X# Procedure: modeSwitch
Xproc modeSwitch { m c} {
X global currentMode
X ${currentMode}ModeLeave $c
X ${m}ModeEnter $c
X set currentMode $m
X set currentModeRB $m
X}
X
X
X# Procedure: delete
Xproc delete { c} {
X set object [$c find withtag current]
X set tags [$c gettags $object]
X foreach i {place transition arrow module mpar tic} {
X if {[lsearch $tags $i] != -1} {
X ${i}Delete $c $object
X return
X }
X }
X}
X
X# Procedure: deleteModeEnter
Xproc deleteModeEnter { c} {
X $c configure -cursor pirate
X $c bind all <1> "delete %W"
X}
X
X
X# Procedure: deleteModeLeave
Xproc deleteModeLeave { c} {
X $c configure -cursor top_left_arrow
X $c bind all <1> ""
X}
X
X
X# Procedure: editModeEnter
Xproc editModeEnter { c} {
X $c bind place <1> "placeEditBegin %W"
X $c bind transition <1> "transitionEditBegin %W"
X $c bind arrow <1> "arrowEditBegin %W"
X $c bind module <1> "moduleEditBegin %W"
X $c bind mpar <1> "mparEditBegin %W"
X}
X
X
X# Procedure: editModeLeave
Xproc editModeLeave { c} {
X $c bind place <1> ""
X $c bind transition <1> ""
X $c bind arrow <1> ""
X $c bind module <1> ""
X $c bind mpar <1> ""
X}
X
X
X# Procedure: moveModeEnter
Xproc moveModeEnter { c} {
X $c bind node <3> {nodeDragBegin %W [xlat %W %x] [ylat %W %y]}
X $c bind module <3> {moduleDragBegin %W [xlat %W %x] [ylat %W %y]}
X $c bind arrow-tic <3> "arrowTicBegin %W"
X $c bind arrow <1> {arrowTicAdd %W [%W canvasx %x] [%W canvasy %y]}
X}
X
X
X# Procedure: moveModeLeave
Xproc moveModeLeave { c} {
X $c bind node <3> ""

X $c bind module <3> ""

X $c bind arrow-tic <3> ""
X $c bind arrow <1> ""
X}
END_OF_FILE
if test 2364 -ne `wc -c <'pips-0.1-alpha/edit.tcl'`; then
echo shar: \"'pips-0.1-alpha/edit.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/edit.tcl'
fi
if test -f 'pips-0.1-alpha/net.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/net.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/net.tcl'\" $3367 characters$
sed "s/^X//" >'pips-0.1-alpha/net.tcl' <<'END_OF_FILE'
X# net.tcl -- here we act on a net as a whole (file saving, printing, etc.)

X# Procedure: netLoad
Xproc netLoad { c {filename "unnamed.net"}} {
X global NETNAME
X netNew $c
X set NETNAME $filename
X wm title . "Pips:$NETNAME"
X global loadCanvas
X set loadCanvas $c
X source $filename
X}
X
X
X# Procedure: netNew
Xproc netNew {c} {
X $c delete all
X foreach i {places transitions arrows nodetypes tokentypes
X mpars modules tics tictypes names} {
X global $i
X catch "unset $i"
X set ${i}() 1
X unset ${i}()
X }
X tokenAdd null
X global GRID
X set GRID 18
X
X global currentMode currentModeRB
X set currentMode place
X set currentModeRB place
X

X global currentNode
X set currentNode {}
X

X global NETNAME
X set NETNAME unnamed.net
X wm title . "Pips:$NETNAME"
X}
X
X
X# Procedure: netSave
Xproc netSave { c {filename "unnamed.net"}} {
X global tokentypes places transitions modules
X
X global NETNAME
X set NETNAME $filename
X wm title . "Pips:$NETNAME"
X
X set file [open $filename w]
X foreach t [array names tokentypes] {
X tokenWrite $t $file
X }
X foreach p [array names places] {
X placeWrite $p $file
X }
X foreach m [array names modules] {
X moduleWrite $m $file
X }
X foreach t [array names transitions] {
X transitionWrite $t $file
X }
X close $file
X}
X
X
X# Procedure: netPrintBegin
Xproc netPrintBegin {c} {
X
X global printName printCmode
X set printName "*"
X set printCmode "color"
X
X set w ""
X
X # build widget ${w}.print
X catch "destroy ${w}.print"
X toplevel ${w}.print

X
X # Window manager configurations

X wm positionfrom ${w}.print ""
X wm sizefrom ${w}.print ""
X wm title ${w}.print "Print"
X
X wdg_entry ${w}.print.name {to File:} printName {[glob $printName]}
X wdg_buttons ${w}.print.color {
X radiobutton {-text "Color" -variable "printCmode" -value "color"}
X radiobutton {-text "Gray" -variable "printCmode" -value "gray"}
X radiobutton {-text "Mono" -variable "printCmode" -value "mono"}
X }
X wdg_confirm ${w}.print.confirm "netPrintEnd $c $w.print"
X
X # pack widget ${w}.print
X pack ${w}.print.name -side top -fill x
X pack ${w}.print.color -side top -fill x
X pack ${w}.print.confirm -side top -fill x
X
X tkwait visibility ${w}.print
X grab set ${w}.print
X}
X
X
X# Procedure: netPrintEnd
Xproc netPrintEnd {c w ok} {
X destroy $w
X global printName printCmode

X if {$ok == "ok"} {

X $c postscript -file "$printName" -colormode "$printCmode"
X }
X}
X
X
X# Procedure: nameGen
Xproc nameGen { c type} {
X global ${type}s
X for {
X set i 0
X set name $type$i
X } {[$c find withtag $name] != ""} {
X incr i
X set name $type$i
X } {}

X return $name
X}
X
X
X

END_OF_FILE
if test 3367 -ne `wc -c <'pips-0.1-alpha/net.tcl'`; then
echo shar: \"'pips-0.1-alpha/net.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/net.tcl'
fi
if test -f 'pips-0.1-alpha/pips.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/pips.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/pips.tcl'\" $2617 characters$
sed "s/^X//" >'pips-0.1-alpha/pips.tcl' <<'END_OF_FILE'
X#!/usr/local/bin/wish -f
X# Tcl version: 7.3 (Tcl/Tk/XF)
X# Tk version: 3.6
X#
X# pips.tcl -- the main tcl program that includes the other files

Xif {($argc > 1) && ([lindex $argv 0] == "-x")} {
X set PIPSLIB [lindex $argv 1]
X incr argc -2
X set argv [lrange $argv 2 end]
X} else {
X set PIPSLIB .
X}
X
Xsource $PIPSLIB/net.tcl
Xsource $PIPSLIB/tokentype.tcl
Xsource $PIPSLIB/place.tcl
Xsource $PIPSLIB/transition.tcl
Xsource $PIPSLIB/node.tcl
Xsource $PIPSLIB/arrow.tcl
Xsource $PIPSLIB/module.tcl
Xsource $PIPSLIB/tic.tcl
Xsource $PIPSLIB/edit.tcl
Xsource $PIPSLIB/widget.tcl
Xsource $PIPSLIB/structure.tcl
Xsource $PIPSLIB/debug.tcl
X
Xsource $PIPSLIB/colors.tcl
X
X# Procedure: initialize
Xproc initialize { c} {
X global currentMode currentModeRB
X set currentMode place
X set currentModeRB place
X placeModeEnter $c
X
X $c bind arrow <Any-Enter> "arrowEnter %W"
X $c bind arrow <Any-Leave> "arrowLeave %W"
X $c bind arrow <2> "arrowEditBegin %W"
X $c bind place <Any-Enter> "placeEnter %W"
X $c bind place <Any-Leave> "placeLeave %W"
X $c bind place <2> "placeEditBegin %W"
X $c bind transition <Any-Enter> "transitionEnter %W"
X $c bind transition <Any-Leave> "transitionLeave %W"
X $c bind transition <2> "transitionEditBegin %W"
X $c bind module <Any-Any-Enter> "moduleEnter %W"
X $c bind module <Any-Any-Leave> "moduleLeave %W"
X $c bind module <Shift-3> {moduleDragBegin %W [xlat %W %x] [ylat %W %y]}
X $c bind module <2> "moduleEditBegin %W"
X $c bind mpar <Any-Any-Enter> "mparEnter %W"
X $c bind mpar <Any-Any-Leave> "mparLeave %W"
X $c bind mpar <2> "mparEditBegin %W"
X $c bind tic <Any-Enter> "ticEnter %W"
X $c bind tic <Any-Leave> "ticLeave %W"
X $c bind node <Shift-3> {nodeDragBegin %W [xlat %W %x] [ylat %W %y]}
X}
X
Xroot
Xinitialize .mainframe.canvas
Xif {$argc > 0} {
X netLoad .mainframe.canvas [lindex $argv 0]
X} else {
X netNew .mainframe.canvas
X}
END_OF_FILE
if test 2617 -ne `wc -c <'pips-0.1-alpha/pips.tcl'`; then
echo shar: \"'pips-0.1-alpha/pips.tcl'\" unpacked with wrong size!
fi
chmod +x 'pips-0.1-alpha/pips.tcl'
# end of 'pips-0.1-alpha/pips.tcl'
fi
if test -f 'pips-0.1-alpha/structure.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/structure.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/structure.tcl'\" $2915 characters$
sed "s/^X//" >'pips-0.1-alpha/structure.tcl' <<'END_OF_FILE'
X# structure.tcl -- property list and array handling routines

X# Procedure: arr2prop
Xproc arr2prop { arrname} {
X upvar $arrname array
X set res {}
X arrIter n p array {
X lappend res $n $p
X }
X return $res
X}
X
X
X# Procedure: arrIter
Xproc arrIter { namevar propvar arrname body} {
X global errorInfo errorCode
X upvar $arrname a
X upvar $namevar n
X upvar $propvar p
X set sid [array startsearch a]
X while {[array anymore a $sid] == 1} {
X set n [array nextelement a $sid]
X set p $a($n)
X switch [catch {uplevel $body} string] {
X 1 {return -code error -errorinfo $errorInfo -errorcode $errorCode $string }
X 2 {return -code return $string}
X 3 return

X }
X }
X}
X
X

X# Procedure: prop2arr
Xproc prop2arr { plist arrname} {
X upvar $arrname array
X propIter n p $plist {
X set array($n) "$p"
X }
X}
X
X
X# Procedure: propGet
Xproc propGet { plist pname} {
X set idx [expr 1 + [propSearch $plist $pname]]
X if {$idx > 0} {return [lindex $plist $idx]}
X return {}
X}
X
X
X# Procedure: propIter
Xproc propIter { namevar propvar plist body} {
X global errorInfo errorCode
X upvar $namevar n
X upvar $propvar p
X set len [llength $plist]
X for {set i 0} {$i < $len} {incr i} {
X set n [lindex $plist $i]
X set p [lindex $plist [incr i]]
X switch [catch {uplevel $body} string] {
X 1 {return -code error -errorinfo $errorInfo -errorcode $errorCode $string }
X 2 {return -code return $string}
X 3 return

X }
X }
X}
X
X

X# Procedure: propNames
Xproc propNames { plist} {
X set res {}
X propIter n p $plist {
X lappend res $n
X }
X return $res
X}
X
X
X# Procedure: propPut
Xproc propPut { plist pname val} {
X upvar $plist x
X set len [llength $x]
X for {set i 0} {$i < $len} {incr i 2} {
X if {[lindex $x $i] == $pname} {
X incr i
X set x [lreplace $x $i $i $val]
X return
X }
X }
X lappend x $pname $val
X return $val
X}
X
X
X# Procedure: propRem
Xproc propRem { plist pname} {
X upvar $plist x
X set idx [propSearch $x $pname]
X if {$idx != -1} {set x [lreplace $x $idx [incr idx]]}
X return $pname
X}
X
X
X# Procedure: propSearch
Xproc propSearch { plist pname} {
X set i 0
X propIter n p $plist {
X if {$n == $pname} {return $i}
X incr i 2
X }
X return -1
X}
X
END_OF_FILE
if test 2915 -ne `wc -c <'pips-0.1-alpha/structure.tcl'`; then
echo shar: \"'pips-0.1-alpha/structure.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/structure.tcl'
fi
if test -f 'pips-0.1-alpha/tic.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/tic.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/tic.tcl'\" $2650 characters$
sed "s/^X//" >'pips-0.1-alpha/tic.tcl' <<'END_OF_FILE'
X# tic.tcl -- tics are the 2x2 pixel squares that are used as handles
X# for various things (like module size, arrow path steps).

Xset tic.hi.fill.color #000000
Xset tic.hi.outline.color #000000
Xset tic.fill.color #808080
Xset tic.outline.color #808080
X
X
X# Procedure: ticDelete
Xproc ticDelete { c {item ""}} {
X global tics tictypes

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

X eval $tictypes($item)TicDelete $c $item $tics($item)
X unset tics($item)
X unset tictypes($item)
X $c delete $item
X}
X
X
X# Procedure: ticEnter
Xproc ticEnter { c} {
X global tic.hi.fill.color tic.hi.outline.color

X set tic [$c find withtag current]

X $c itemconfigure $tic -outline ${tic.hi.outline.color} -fill ${tic.hi.fill.color}
X}
X
X
X# Procedure: ticKill
Xproc ticKill { c item} {
X global tics tictypes
X unset tics($item)
X unset tictypes($item)
X $c delete $item
X}
X
X
X# Procedure: ticLeave
Xproc ticLeave { c} {
X global tic.fill.color tic.outline.color

X set tic [$c find withtag current]

X $c itemconfigure $tic -outline ${tic.outline.color} -fill ${tic.fill.color}
X}
X
X
X# Procedure: ticMove
Xproc ticMove { c tic dx dy} {
X $c move $tic $dx $dy
X $c raise $tic
X}
X
X
X# Procedure: ticNew
Xproc ticNew { c x y type item {tags ""}} {
X global tic.fill.color tic.outline.color
X global tics tictypes
X set a 2
X set tic [$c create rectangle [expr $x - $a] [expr $y - $a] [expr $x + $a] [expr $y + $a] -outline ${tic.outline.color} -fill ${tic.fill.color} -tags tic]
X $c raise $tic
X $c bind $tic <Shift-3> "${type}TicBegin %W"
X set tictypes($tic) $type
X set tics($tic) $item
X foreach i "$type $item $tags" {
X $c addtag ${i}-tic withtag $tic
X $c addtag ${i}-part withtag $tic
X }
X return $tic
X}
X
X
X# Procedure: ticPos
Xproc ticPos { c tic x y} {
X set a 2
X $c coord $tic [expr $x - $a] [expr $y - $a] [expr $x + $a] [expr $y + $a]
X $c raise $tic
X}
X
END_OF_FILE
if test 2650 -ne `wc -c <'pips-0.1-alpha/tic.tcl'`; then
echo shar: \"'pips-0.1-alpha/tic.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/tic.tcl'
fi
if test -f 'pips-0.1-alpha/tokentype.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'pips-0.1-alpha/tokentype.tcl'\"
else
echo shar: Extracting \"'pips-0.1-alpha/tokentype.tcl'\" $1188 characters$
sed "s/^X//" >'pips-0.1-alpha/tokentype.tcl' <<'END_OF_FILE'
X# tokentype.tcl -- procedures that handle tokentypes (not many so far)

X# Procedure: tokenAdd
Xproc tokenAdd { name} {
X global tokentypes
X set tokentypes($name) {}
X}
X
X
X# Procedure: tokenWrite
Xproc tokenWrite { name {file "file1"}} {
X global tokentypes
X puts $file "TOKENTYPE $name \{$tokentypes($name)\}"
X}
X
X
X# Procedure: TOKENTYPE
Xproc TOKENTYPE { name plist} {
X global tokentypes
X set tokentypes($name) $plist
X}
X
X
END_OF_FILE
if test 1188 -ne `wc -c <'pips-0.1-alpha/tokentype.tcl'`; then
echo shar: \"'pips-0.1-alpha/tokentype.tcl'\" unpacked with wrong size!
fi
# end of 'pips-0.1-alpha/tokentype.tcl'
fi
echo shar: End of archive 3 $of 3$.
cp /dev/null ark3isdone

0 new messages