#! /bin/env tclsh
#
# tkduke: 2D drawing tool
#
# [1998/11/03] OSHIRO Naoki.
# [1999/01/21] OSHIRO Naoki. add polyAdd,Del
# [1999/01/27] OSHIRO Naoki. Package name changed to tkduke
# [1999/02/11] OSHIRO Naoki.
# fix copyItem (mistake 'sy' to 'sx').
# unify switch commands in some procedures using regexp matching.
# [1999/02/17] OSHIRO Naoki. add toggleItem
# [1999/02/19] OSHIRO Naoki. add changeZoom, fit win size to A4 landscape.
# [1999/03/07] OSHIRO Naoki. add toggleTextAnchor
# [1999/03/07] OSHIRO Naoki. add loadFont. make font loading dynamically.
# exchange type names box and boxx.
# [1999/03/12] OSHIRO Naoki. add setItemAnchor, toggleItemAnchor
# [1999/03/14] OSHIRO Naoki. add abutItem
# [1999/03/15] OSHIRO Naoki. shift-key Selection
# add nodCut
# [1999/03/16] OSHIRO Naoki. add image item type, importImage proc
# [1999/03/19] OSHIRO Naoki. add setColor, darkenItem, blendItem
# [1999/03/25] OSHIRO Naoki. fix flip{H,V} for coords of {arrow,line} item.
# change copyItem: add itemcget {arrow,smooth}
# [1999/03/30] OSHIRO Naoki. add rotateItem
# [1999/04/06] OSHIRO Naoki. add colSpoit, zoom icon, setLineCap menu
# [1999/04/13] OSHIRO Naoki. fix related grid size (selection, copyItem).
# [1999/04/14] OSHIRO Naoki. add toolbox some icon image.
# [1999/04/18] OSHIRO Naoki. add (un)groupItem (cannot save this info.).
# [1999/04/24] OSHIRO Naoki. add mode icon on select and move.
# [1999/04/26] OSHIRO Naoki. use append command for string concatenate.
# [1999/05/17] OSHIRO Naoki. add fontface 'Mincho:Times-Roman'.
# [1999/05/26] OSHIRO Naoki. add layer architecture.
# [1999/06/03] OSHIRO Naoki. add '.mmp' file header and info editor.
# [1999/06/12] OSHIRO Naoki. add file browser.
# add {split,join}TextEachLine.
# [1999/06/18] OSHIRO Naoki. add Newfile.
# add edit text on drawing canvas.
# [1999/06/27] OSHIRO Naoki. fix color specification in toggleItem.
# [1999/06/28] OSHIRO Naoki. reduce array names search.
# [1999/08/05] OSHIRO Naoki. enabled float tool menu to tearoff.
# [1999/09/02] OSHIRO Naoki. separate toggle operation fontface and fontsize.
# [1999/09/05] OSHIRO Naoki. add procs for nod duplication.
# [1999/09/07] OSHIRO Naoki. add shearItem.
# [1999/10/03] OSHIRO Naoki. add Balloon Help.
# [1999/11/08] OSHIRO Naoki. add Reload button.
# [2000/01/10] OSHIRO Naoki. add nod delete proc in pline/poly draw mode.
# [2000/01/11] OSHIRO Naoki. fix width specification of rod item from file.
# [2000/01/18] OSHIRO Naoki. add makeGridLine, and fix zooming bugs.
# (Thanks SUEYOSHI Toshiyasu.)
# [2000/02/27] OSHIRO Naoki. change/fix changeZoom centering parameters.
# [2000/04/15] OSHIRO Naoki. fix font editting to keep current each fontsize.
# [2000/04/21] OSHIRO Naoki. fix font size changing by scale bar.
# [2000/05/02] OSHIRO Naoki. avoid duplicate grouping.
# [2000/05/06] OSHIRO Naoki. fix setItemAnchor: caluculate minx fail.
# [2001/08/09] OSHIRO Naoki. add OvalBox(obox) item type.
# [2003/10/14] OSHIRO Naoki. add process of duplicate nodes in saveItem.
#
package require Tk
set tkduke_version 0.1
set tkduke_copyright "Copyright (C) OSHIRO Naoki 1998-2001"
set canvas_grid 2
############################################################
# Icon generation
# cat foo-icon.xbm | xbmtopbm | ppmtogif -transparent white | base64
############################################################
# Lupe Icons
set lupe_plus_gif_old {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIqjI+pAe1r
nATrHXtbpEznvyHaRHkh2YlcGmach21rN8to8kxKDPF9DSkAADs=
}
set lupe_plus_gif {
R0lGODlhEAAQAMIAAL//3wB/HwC/P9//v////wAAAAAAAAAAACH5BAEAAAQA
LAAAAAAQABAAAAM9SLrcTiLKp8QIOD8bgAcaw3mRF1add31CIHbRVbYv0Gaw
u7RsauuoFO8HVGQ+REdGcnM0ccUg5RWl0KaLBAA7
}
set lupe_minus_gif_old {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAInjI+pAe1r
nATrHXubwoxWH1GTCHadZGaQlpWhy3HvuGlT7X75ByUFADs=
}
set lupe_minus_gif {
R0lGODlhEAAQAMIAAL//3wB/HwC/PwB/AN//v////wAAAAAAACH5BAEAAAUA
LAAAAAAQABAAAAM9WLrcXiLKpwQJOD87gAcaw31fWHXkJwRiJ0nA2sZDXcfs
IqApmJ88FaaRIa1+i8xr2DgWMszWgCKltqyLBAA7
}
############################################################
set arrow_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIYjI+py+0P
FYgBzGctzrzn+kUadVHmiT4FADs=
}
set arrow_icon_gif_tmp {
R0lGODlhEAAQAKEAAL8/AP+/v//f3////yH5BAEAAAMALAAAAAAQABAAAAIb
nI+py+0PVYgjABiCuM5uAIYiOIgUeVLqykYFADs=
}
set box_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIljI8ZwO3f
lgRz0luxy5z1HGmdSC7hd5XkqZqo5bXpm0J2pORGAQA7
}
set obox_icon_gif {
R0lGODlhEAAQAIAAAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIlTICpaAcH
n4yzRnetTLkznXFgNYafR6HkWbKqqKZts9RPg+d5AQA7
}
set orect_icon_gif {
R0lGODlhEAAQAIAAAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIhTICpaNcP
gYPUsEovfnpb6TWdN24ldlZpBoZOa4rL7FIFADs=
}
set box_icon_gif_tmp {
R0lGODlhEAAQAIAAAL8/AP///yH5BAEAAAEALAAAAAAQABAAAAIljI8ZwO3f
lgRz0luxy5z1HGmdSC7hd5XkqZqo5bXpm0J2pORGAQA7
}
set boxx_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIujI8ZwGuw
mJwQukrji3Q63V1bl1kY1zQXKX0p6aKwuXoqxlYP3uq1nBplFERDAQA7
}
set boxx_icon_gif_tmp {
R0lGODlhEAAQAMIAAL8AAL8/AP+/v/8AAP/f3////wAAAAAAACH5BAEAAAUA
LAAAAAAQABAAAAM0WLrcFQGMIYgYAGotqcXb1lVXFkLjZ55peaITCb7tzMbq
G+Euzduh2ir4G4qKOuHJwVwkAAA7
}
set circle_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjAOpcI1u
mJPwHVotzm9n5lUg14xkZJ2mipJY2JbityQnWQAAOw==
}
set fline_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAImjI+ZwKDX
kFNzvRpYvkZnbEEfuH0SGFHPma6Yp3YOzL4rd0v5WgAAOw==
}
set line_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAISjI+py+0P
o5wM2IszoLz7DwYFADs=
}
set oval_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjAOpcI3P
ooNUHolp3Th7z0FgF46jWG6pZZyMc07Iksj2VAAAOw==
}
set pixel_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIXjI+py43g
YoCSUXOrdvnt72GgOCrdVgAAOw==
}
set pline_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjGGpG+AM
UZOwrRcjTfvufnGVeIzlOVIgg6ysZZZuGJN1UgAAOw==
}
set pline_icon_gif_tmp {
R0lGODlhEAAQAKEAAL8/AP/f3////wAAACH5BAEAAAIALAAAAAAQABAAAAIp
lAKmywgQmETmRXnSslMzrlCY8IReZ4ijqGLsiWajSc407CZ4bKe7XQAAOw==
}
set poly_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIpjGGpG+AM
34MH2cls2zhJ3nTaGHogiVQnl66o96Ix69bOfZ9thnfUUgAAOw==
}
set poly_icon_gif_tmp {
R0lGODlhEAAQAKEAAL8AAP8AAP///wAAACH5BAEAAAIALAAAAAAQABAAAAIm
lGGpK+AMQQgPHiodilhrlnmiIpZbY45H6iVsu76P3NKfXUWlxRcAOw==
}
set rect_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIfjI8ZwO3P
lFxgqmgRzmZzn4GWOJGSeVVcp67Q66xIAQA7
}
set rect_icon_gif_tmp {
R0lGODlhEAAQAIAAAL8/AP///yH5BAEAAAEALAAAAAAQABAAAAIfjI8ZwO3P
lFxgqmgRzmZzn4GWOJGSeVVcp67Q66xIAQA7
}
set rod_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIYjI+py+0P
o2Qg1GsznrhrDYTiSE7miUoFADs=
}
set rod_icon_gif_tmp {
R0lGODlhEAAQAKEAAL8AAP+/v/8AAP///yH5BAEAAAMALAAAAAAQABAAAAIb
nI+py+0Po1yi2otF2Lz7kIUWQJbmCUzqykoFADs=
}
set select_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIkhIOpaQ27
nINMzngpsrqG1n2POGolaCooVG5HWLXhCtPzC4sFADs=
}
set select_icon_gif_tmp {
R0lGODlhEAAQAKEAAL8AAL8/AP8AAP///yH5BAEAAAMALAAAAAAQABAAAAIu
RDKpqxYCGTPuCalCPfCyA2ILGIrJMQiouaoIq7hwvEovfZuJrOO9/0sZgqlA
AQA7
}
set sphere_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIrjAOpcI0M
n5NQoZZuXSb3t2RRF1qiVkZqWoHs+orbS7LSkYITPblWD3QUAAA7
}
set sphere_icon_gif_tmp {
R0lGODlhEAAQAOMAAL8AAL8/AP+/v/8AAP/f3/////8Af/9/AL8APwAAAAAA
AAAAAAAAAAAAAAAAAAAAACH5BAEAAAUALAAAAAAQABAAAARFsMgCqgUz0xou
1hUheFVWFgR5VgKRqkBABcEIIzIHV/i2A4hD7gcQCH2wweH4GyhpkuRTNvEc
nAaohkZbcjUTrhhMLkcAADs=
}
set text_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIlDI6ZYerH
IGuTmmoniFhqrG3g6I1VaUZiGrLn6qKpTCLsA7tYAQA7
}
set text_icon_gif_tmp {
R0lGODlhEAAQAKEAAL8AAP+/v/8AAP///yH5BAEAAAMALAAAAAAQABAAAAIr
nI6ZYxEAowRMUGYuexVXzVyCl5Ej+aFquZpgy8KpPNMWvb2rA8HHpMMNCgA7
}
set colSpoit_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAImjI+gih3w
InRSTsegplXfllXYtmHGwpgnt7bc9akRO8dmypa0uxcAOw==
}
set colSpoit_icon_gif_tmp {
R0lGODlhEAAQAMIAAL8AAL8/AP/fv/+/v/8AAN//v////wAAACH5BAEAAAYA
LAAAAAAQABAAAAM0aLocHiyqQKqTi76Ljd6dR2xQR3IScHYCoD5s0QKhIciD
UN9FvuO6ncC3ywVDw2PNtlwkAAA7
}
############################################################
set hide_icon_gif {
R0lGODlhCAAIAPABAAAAAP///yH5BAEAAAEALAAAAAAIAAgAAAIPhH+ha4EO
nIotypramggVADs=
}
############################################################
set quit_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIkjI+py+0P
D5gQyGdNRjvsnlifp5ETVWZiapKte5YvqKoaGOUFADs=
}
set newfile_icon_gif {
R0lGODlhEAAQAIAAAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIljI+py+0P
DTjT1XAZqHnN/4AcR4mYdEojtqHfBVJni7JkF+VBAQA7
}
set load_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAImjI+ZwA1q
2ILvIXvjvG4frICBmJXU+EFctTqu+klkis2aGS7uixQAOw==
}
set reload_icon_gif {
R0lGODlhEAAQAIAAAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIpjI+pwIzw
moSB1nYmxYs7dTlcMl1d+YGkpWbpabzrJsev5I62Vu96UAAAOw==
}
set import_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIojAMJx5y2
mkNQnogtUtnG6Ulf8z0jCD2hc15iu3Gcq6VVnap4vMtGAQA7
}
set importtext_icon_gif {
R0lGODlhEAAQAIAAAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIpjAOZx7cG
GosRSttqRopeD37OKGmmyFXalD1b+3UyeUFqPSl4vsZ6UAAAOw==
}
set save_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAImjI+pwA16
HmIwyGjhNXLz5HjeBFYZOZ4gNYUuubAYqpWVaIquUwAAOw==
}
set saveas_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIrjI+pwA16
ngwM0ukgvjVV6TzIto0m6FGRKnodGMbGtLxX2pbrip7sP4o5CgA7
}
set imagel_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIohI8Xm20b
UowISkAVc5Ltjn3QqGXc8zWb5VDTCLPxvL70Gt6i3uljAQA7
}
set print_icon_gif {
R0lGODlhEAAQAPABAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIpjA2pCxft
DnQtoUuj1PX5n2ngJk4Pg1pex55nCotlRcuqTJn4C6O7VgAAOw==
}
set info_icon_gif {
R0lGODlhEAAQAIAAAAAAAP///yH5BAEAAAEALAAAAAAQABAAAAIojI+pAQ17
GpLqGcqSvTtHeH0RFnqjVp5TyqEs2VmOw5quFncVDfZGAQA7
}
set colplt_icon_gif {
R0lGODlhEAAQAOMAAAAAAL8AAP//fwC/AL+/AP8AAH///////39//wAAAAAA
AAAAAAAAAAAAAAAAAAAAACH5BAEAAAcALAAAAAAQABAAAARQ8EhAgbx4hhOC
zRewSR4Ydlz3ZWLnqhV1tG+tzrY9eHQeDEBKp1DIAQfCANEYxBGLLoKAcJst
AwhDYCqo0rJZqbSkCRjAr9VEpHXJTLG3JAIAOw==
}
set colsel_icon_gif {
R0lGODlhEAAQAIQAAAAAAH//f78AAAA/v///fwD/AAC/AL+//7+/AP//v/+/
v/8AAP/f3///AH9//7//vwAA/wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAEAAQAAAFZiAgjmQpMiiQrMDjAsdx
pmvSvvHMqKz7wDKTkKQoAghIQGAJcDhERcUxuQw0n4DolKBkOodgwGIMaJgB
hTQAAhGNF+VzurBui8nmBlrNDg8FgAAIgwAGhgADAyKAAoKEhgaIin4lIQA7
}
set colrnd_icon_gif {
R0lGODlhEAAQAOMAAAAAAL8AAP+/fz+/AL+/AAAAfwB//wB/AL8/AP8AAP//
////AH9/AP9/AAAAAAAAACH5BAEAAAoALAAAAAAQABAAAARhUEkgqwKNWhD0
bEJWcUlHYUIqkkl5nGBGnIE7vJe8EFNwDMAXA0BYGCVDwE+ILPIUDCQTCiBq
olEoElCoIr/ZS8HQtYQnYwPZY0EyxuVALVFhZLkaea09qugDfHwIeoFtEQA7
}
set none_icon_gif {
R0lGODlhEAAQAIAAAP///wAAACH5BAEAAAAALAAAAAAQABAAAAIOhI+py+0P
o5y02ouzPgUAOw==
}
############################################################
image create photo lupe_plus -format gif -data $lupe_plus_gif
image create photo lupe_minus -format gif -data $lupe_minus_gif
set lupe_minus_gif {}
set lupe_plus_gif {}
foreach i {arrow box obox boxx circle fline line oval pixel pline poly rect orect rod select sphere text colSpoit hide quit newfile load reload import importtext save saveas imagel print info colplt colsel colrnd none} {
eval image create photo ${i}_icon -format gif -data $${i}_icon_gif
unset ${i}_icon_gif
}
############################################################
# PI
set m_pi [expr atan2(1,1)*4]
############################################################
# Rand
set rand_next [clock seconds]
proc rand {} {
global rand_next;
set rand_next [expr $rand_next*1103515245 + 12345]
return [expr (($rand_next/65536)%32768)/32768.0];
}
############################################################
# sets: set apply to lists (like foreach).
proc sets {{vars} {vals}} {
foreach var $vars {
upvar $var x
set x [lindex $vals 0]
set vals [lreplace $vals 0 0]
}
}
############################################################
# lintersection
proc lintersection {a_lis b_lis} {
set c ""
foreach a $a_lis {
if {[lsearch $b_lis $a]!=-1} {
lappend c $a
}
}
return $c
}
############################################################
# lreverse
proc lreverse {{src}} {
set dest ""
foreach l $src {
set dest [linsert $dest 0 $l]
}
return $dest
}
############################################################
# basename
proc basename {{fname}} {
return [lindex [split $fname "/"] end]
}
proc get_smooth {c id} {
set smooth [$c itemcget $id -smooth]
if {$smooth!=0} {set smooth 1}
return $smooth
}
############################################################
# Canvas snapshot
# (popupCanvasSnapshot: from tkgnuplot)
proc getCanvasSnapshot {w} {
global fontsize cur_gridshow
set tmp_gridshow $cur_gridshow
if {$cur_gridshow} {set cur_gridshow 0; makeGridLine}
set bbox [$w bbox all]
if {$tmp_gridshow} {set cur_gridshow $tmp_gridshow; makeGridLine}
if {$bbox==""} {return}
set margin 0
set shrink 1
set snapwidth 80
set snapheight 60
set size $fontsize
sets {x0 y0 x1 y1} $bbox
set width [expr ($x1-$x0)]
set height [expr ($y1-$y0)]
if {$width>$height} {
if {$width>$snapwidth} {
set shrink [expr 1.0*$width/$snapwidth]
}
} else {
if {$height>$snapheight} {
set shrink [expr 1.0*$height/$snapheight]
}
}
set width [expr $width/$shrink+$margin*2]
set height [expr $height/$shrink+$margin*2]
set t .csn
toplevel $t
set c $t.c
canvas $c -width $width -height $height -background [$w cget -background]
wm overrideredirect $t 1
pack $c
bind $t <Control-q> "destroy $t"
bind $t <Control-w> "destroy $t"
update idletasks
set id_create ""
foreach id [$w find all] {
set opts ""
if {[lsearch [.c gettags $id] "grid"]!=-1} {continue}
foreach opt [$w itemconfigure $id] {
set o_name [lindex $opt 0]
set o_value [list [lindex $opt end]]
if {$o_name=="-font" && [regexp -- "-(\[0-9\]+)$" $o_value null size]} {
set size [expr int($size/$shrink)]
if {$size<=1} {set size 2}
loadFont $size
regsub -- "-(\[0-9\]+)$" $o_value "-$size" o_value
} elseif {$o_name=="-arrowshape"} {
set tmp ""
foreach v [lindex $o_value 0] {
lappend tmp [expr 1.0*$v/$shrink]
}
set o_value [list $tmp]
} elseif {$o_name=="-width"} {
set o_value [expr $o_value/$shrink]
}
append opts "$o_name $o_value "
}
lappend id_create "$c create [$w type $id] [$w coords $id] $opts"
}
foreach idc $id_create {eval $idc}
$c move all [expr -$x0+$margin] [expr -$y0+$margin]
$c scale all $margin $margin [expr 1.0/$shrink] [expr 1.0/$shrink]
update idletasks
set gif_base64 [exec xwd -id [winfo id $c] -nobdrs -silent | convert xwd:- gif:- | base64]
destroy $t
update idletasks
return $gif_base64
}
############################################################
# setIconbitmap
proc setIconbitmap {w} {
set bmp {
48 48
fc ff ff ff ff 3f 02 00 00 00 00 40 01 00 00 00 00 80
01 00 00 80 be 80 01 00 00 00 00 80 01 00 00 fe 07 80
01 00 00 01 00 80 01 00 00 01 00 80 01 00 80 00 00 80
01 00 ff ff 00 80 01 00 41 80 00 80 01 00 01 80 00 80
01 00 ff ff 00 96 01 80 00 00 01 80 01 40 00 00 f2 87
01 40 00 00 0e 80 01 40 00 80 03 80 01 40 00 60 02 80
5d 41 00 18 02 80 01 40 00 06 02 80 f1 4f 00 00 02 80
01 50 00 f0 03 80 01 60 00 00 02 80 01 c0 79 f0 03 80
01 40 86 00 02 80 01 40 9c f0 03 80 01 40 84 00 02 80
01 40 84 f0 03 80 01 40 78 00 02 80 01 40 00 f0 03 80
01 40 00 00 02 80 01 40 00 f0 03 80 01 40 00 00 02 80
01 80 00 00 01 80 01 80 00 00 01 80 01 00 0f f0 00 80
01 00 10 08 00 80 01 00 10 08 00 80 01 f8 8f f0 1f 80
01 08 00 01 10 80 01 f8 ff ff 1f 80 01 00 00 02 00 80
01 00 00 02 00 80 01 00 00 04 6c 9f 01 00 00 04 00 80
01 00 00 f8 3f 80 02 00 00 00 00 40 fc ff ff ff ff 3f
}
set tmpfile "tmp[pid].xbm"
set fd [open "$tmpfile" w]
puts $fd "#define -_width [lindex $bmp 0]"
puts $fd "#define -_height [lindex $bmp 1]"
puts $fd "static char -_bits\[\] = {"
foreach d [lrange $bmp 2 end] {
puts -nonewline $fd "0x$d, "
}
puts $fd "};"
close $fd
wm iconbitmap $w @$tmpfile
file delete $tmpfile
}
############################################################
# setColor
proc setColor {{col}} {
global cur_id cur_col itemType gradation_id
set m 65535.0
if {$col==""} {return}
sets {r g b} [winfo rgb . $col]
.op.col.cur_col configure -background $col
set cur_col [list 255 [expr $r/$m] [expr $g/$m] [expr $b/$m]]
if {$cur_id==""} {return}
foreach id $cur_id {
set type $itemType($id)
if {$type=="text" || $type=="arrow" || $type=="line" || $type=="pline" || $type=="poly" || $type=="orect"} {
.c itemconfigure $id -fill $col
} elseif {$type=="box" || $type=="obox"|| $type=="oval"} {
.c itemconfigure $id -fill $col -outline $col
} elseif {$type=="rect" || $type=="circle"} {
.c itemconfigure $id -outline $col
}
}
}
proc makeColorMenu {{m}} {
menu $m.m -borderwidth 0 -activeborderwidth 1
set clmn 5
set i 1
foreach c {
000000 1f1f1f 3f3f3f 5f5f5f 7f7f7f
ffffff efefef dfdfdf bfbfbf 9f9f9f
ffdfdf ffbfbf ff0000 bf0000 7f0000
ffdfbf ffbf7f ff7f00 bf3f00 7f1f00
ffffbf ffff7f ffff00 bfbf00 7f7f00
dfffbf bfff7f 7fff00 3fbf00 1f7f00
bfffbf 7fff7f 00ff00 00bf00 007f00
bfffdf 7fffbf 00ff7f 00bf3f 007f1f
bfffff 7fffff 00ffff 00bfbf 007f7f
bfdfff 7fbfff 007fff 003fbf 001f7f
bfbfff 7f7fff 0000ff 0000bf 00007f
dfbfff bf7fff 7f00ff 3f00bf 1f007f
ffbfff ff7fff ff00ff bf00bf 7f007f
ffbfdf ff7fbf ff007f bf003f 7f001f
} {
set col col$i
set size 16
image create photo $col -width $size -height $size
$col put #$c -to 0 0 $size $size
$m.m add checkbutton -image $col -hidemargin 1 \
-command "setColor #$c" \
-columnbreak [expr (fmod($i-1, $clmn)==0)]
incr i
}
return $m.m
}
proc makeColorString {{dst_col}} {
set col [lindex $dst_col 0]
set r [expr int($col*[lindex $dst_col 1])]
set g [expr int($col*[lindex $dst_col 2])]
set b [expr int($col*[lindex $dst_col 3])]
if {$r>255} {set r 255} elseif {$r<0} {set r 0}
if {$g>255} {set g 255} elseif {$g<0} {set g 0}
if {$b>255} {set b 255} elseif {$b<0} {set b 0}
set col [format "#%02x%02x%02x" $r $g $b]
return $col
}
proc randomColor {} {
sets {col_r col_g col_b} [list [rand] [rand] [rand]]
set col [expr int(([rand]*.6+.4)*255)]
if {($col_r+$col_g+$col_b)/3<.3} {
set col 255
sets {col_r col_g col_b} [list [expr $col_r*.6+.4] \
[expr $col_g*.6+.4] \
[expr $col_b*.6+.4]]
}
setColor [makeColorString [list $col $col_r $col_g $col_b]]
}
proc changeColorIntensity {{col} {ratio}} {
global cur_id cur_col itemType
sets {r g b} [winfo rgb . $col]
return [makeColorString [list [expr $ratio*255] [expr $r/65535.0] [expr $g/65535.0] [expr $b/65535.0]]]
}
proc darkenItem {{c_id}} {
global itemType
foreach id $c_id {
set col [changeColorIntensity [.c itemcget $id -fill] .95]
set type $itemType($id)
if {$type=="oval" || $type=="box" || $type=="obox"} {
.c itemconfigure $id -fill $col -outline $col
} else {
.c itemconfigure $id -fill $col
}
}
}
proc lightenItem {{c_id}} {
global itemType
foreach id $c_id {
if {[info exists itemType($id)]==0} {continue}
set col [changeColorIntensity [.c itemcget $id -fill] 1.1]
if {$col=="#000000"} {set col "#505050"}
set type $itemType($id)
if {$type=="oval" || $type=="box" || $type=="obox"} {
.c itemconfigure $id -fill $col -outline $col
} else {
.c itemconfigure $id -fill $col
}
}
}
############################################################
# setStipple
proc setStipple {p} {
global cur_stipple
set cur_stipple [list $p]
}
proc makeStippleMenu {m} {
menu $m.m -borderwidth 0 -activeborderwidth 1
set clmn 4
set i 1
foreach p {
gray12
gray25
gray50
gray75
error
hourglass
info
questhead
question
warning
{}
} {
$m.m add checkbutton -bitmap $p -hidemargin 1 \
-command "setStipple [list $p]; $m configure -bitmap $p" \
-columnbreak [expr (fmod($i-1, $clmn)==0)]
incr i
}
return $m.m
}
############################################################
#
# GetValue: ¡ÖTcl/Tk ÆþÌç¡×¥¦¥§¥ë¥Á, p.276-277.
proc getValue {{string} {init ""}} {
global prompt
set f [toplevel .prompt -borderwidth 10]
message $f.msg -text $string -width 300
entry $f.entry -textvariable prompt(result)
if {$init!=""} {$f.entry delete 0 end; $f.entry insert 0 $init}
set b [frame $f.buttons -bd 10]
pack $f.msg $f.entry $f.buttons -side top -fill x
button $b.ok -text OK \
-command {set prompt(ok) 1} -underline 0
button $b.cancel -text Cancel \
-command {set prompt(ok) 0} -underline 0
pack $b.ok -side left
pack $b.cancel -side right
# ¥Ð¥¤¥ó¥É¤òÀßÄꤹ¤ë
foreach w [list $f.entry $b.ok $b.cancel] {
bindtags $w [list .prompt [winfo class $w] $w all]
}
bind .prompt <Alt-o> "focus $b.ok; break"
bind .prompt <Alt-c> "focus $b.cancel; break"
bind .prompt <Alt-Key> break
bind .prompt <Return> {set prompt(ok) 1}
bind .prompt <Control-c> {set prompt(ok) 0}
focus $f.entry
grab $f
tkwait variable prompt(ok)
grab release $f
destroy $f
focus -force .
if {$prompt(ok)} {
return $prompt(result)
} else {
return {}
}
}
############################################################
#
# ItemSnap
proc distance_sort {a b} {
set a [lindex $a 0]
set b [lindex $b 0]
if {$a>$b} {
return 1
} elseif {$a<$b} {
return -1
} else {
return 0
}
}
proc itemSnap {{x} {y} {type edge}} {
global cur_id
set a 4
set id_list [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]]
set coord ""
foreach id $id_list {
if {[lsearch [.c gettags $id] "grid"]!=-1} {continue}
if {[info exists gradation($id)]} {set id $gradation($id)}
set coord [.c coord $id]
break
}
set dis_xy ""
foreach {xx yy} $coord {
lappend dis_xy [list \
[expr ($xx-$x)*($xx-$x)+($yy-$y)*($yy-$y)] $xx $yy]
}
return [lrange [lindex [lsort -command distance_sort $dis_xy] 0] 1 end]
}
############################################################
#
proc splitTextEachLine {t_id} {
global itemType
set new_id ""
unselectItem t_id
set tt_id ""
foreach id $t_id {
if {$itemType($id)!="text"} {continue}
sets {x0 y0 x1 y1} [.c bbox $id]
incr x0
set text [.c itemcget $id -text]
sets {x y} [list $x0 $y0]
regsub "\n$" $text "" text
foreach t [split $text "\n"] {
if {$t==""} {set t " "}
.text.e delete 0.0 end
.text.e insert 0.0 $t
set tmp_id [makeItem text -justify left -anchor nw [list $x $y]]
set y [lindex [.c bbox $tmp_id] 3]
lappend new_id $tmp_id
}
lappend tt_id $id
}
selectItem new_id
deleteItem $tt_id
return $new_id
}
proc itemcoordy_sort {a b} {
set ay [lindex [.c bbox $a] 1]
set by [lindex [.c bbox $b] 1]
if {$ay>$by} {
return 1
} elseif {$ay<$by} {
return -1
} else {
return 0
}
}
proc joinTextEachLine {t_id} {
global itemType
unselectItem t_id
set t_id [lsort -command itemcoordy_sort $t_id]
sets {x0 y0 x1 y1} [.c bbox [lindex $t_id 0]]
incr x0
set text ""
set tt_id ""
foreach id $t_id {
if {$itemType($id)!="text"} {continue}
append text "[.c itemcget $id -text]\n"
lappend tt_id $id
}
regsub "\n$" $text "" text
.text.e delete 0.0 end
.text.e insert 0.0 $text
set new_id [makeItem text -justify left -anchor nw [list $x0 $y0]]
selectItem new_id
deleteItem $tt_id
return $new_id
}
proc editText {{w} {x} {y} {id}} {
set e [winfo parent $w]
if {$e=="."} {
set e ".e"
} else {
append e ".e"
}
text $e -width 30 -height 3
pack slave $e
$e delete 0.0 end
$e insert 0.0 [$w itemcget $id -text]
set e_id [$w create window $x $y -window $e]
bind $e <Key-Return> "$w itemconfigure $id -text \[$e get 0.0 end-1chars\]; $w delete $e_id; destroy $e; break"
bind $e <Escape> "$w delete $e_id; destroy $e; set text \[$w itemcget $id -text\]; if {\$text==\"\"} {$w delete $e_id; $w delete $id}"
update idletasks
bind $e <Control-o> {
%W insert insert "\n"
%W mark set current [%W index insert]+2chars
%W see current
break
}
focus $e
grab $e
tkwait window $e
}
############################################################
proc getLineCoord {id} {
global itemType
global nod_dupinfo
set i 0
set coord ""
set skip 0
set type $itemType($id)
if {$type=="obox" || $type=="orect"} {
set cd [.c coord $id]
return "[lindex $cd 8] [lindex $cd 15] [lindex $cd 0] [lindex $cd 3]"
}
if {$nod_dupinfo($id)==""} {
return [.c coords $id]
}
foreach {x y} [.c coords $id] {
if {$skip==1} {
set skip 0
} else {
append coord "$x $y "
if {[lsearch $nod_dupinfo($id) $i]!=-1} {
set skip 1
}
incr i
}
}
return $coord
}
proc makeLineCoord {id coord} {
global itemType
global nod_dupinfo
global cur_zoom
set i 0
set coord_tmp ""
set type $itemType($id)
if {$type=="obox" || $type=="orect"} {
sets {x y x0 y0} $coord
set d [expr 20*$cur_zoom]
sets {xa ya x0a y0a} \
[list [expr $x-$d] [expr $y-$d] \
[expr $x0+$d] [expr $y0+$d]]
set coord_tmp [list \
$x0 $y0a $x0 $y0 $x0a $y0 \
$xa $y0 $x $y0 $x $y0a \
$x $ya $x $y $xa $y \
$x0a $y $x0 $y $x0 $ya \
$x0 $y0a ]
return $coord_tmp
}
foreach {x y} $coord {
append coord_tmp " $x $y"
if {[lsearch $nod_dupinfo($id) $i]!=-1} {
append coord_tmp " $x $y"
}
incr i
}
return $coord_tmp
}
proc toggleItemNodDup {id n} {
global selectnod_id selectnod nod_dupinfo
set coord [getLineCoord $id]
set i [lsearch $nod_dupinfo($id) $n]
if {$i==-1} {
lappend nod_dupinfo($id) $n
set col_f orange
} else {
set nod_dupinfo($id) [lreplace $nod_dupinfo($id) $i $i]
set col_f blue
}
.c itemconfigure [lindex $selectnod_id($id) $n] -fill $col_f
eval .c coords $id [makeLineCoord $id $coord]
}
############################################################
#
proc ButtonPress-1 {{x} {y}} {
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow cur_arrowshape cur_col
global cur_cursor
global cur_layer layer_id
#global cur_itemsnap
global itemType
global selectnod_id selectnod
global gradation_id gradation
global nod_dupinfo
global raiselower
global fontsize cur_linewidth linecap rodwidth
global fline_cnt fline_skipnum
global canvas_grid grid_unit cur_zoom
set fill "PeachPuff"
if {$cur_col!=""} { ;# ËÜÅö¤Ï ButtonPress Ëè¤Ë¹Ô¤¦¤Ù¤½èÍý¤¸¤ã¤Ê¤¤
sets {color col_r col_g col_b} $cur_col
set fill [format "#%02x%02x%02x" \
[expr int($color*$col_r)] \
[expr int($color*$col_g)] \
[expr int($color*$col_b)]]
}
#sets {sn_x sn_y} [itemSnap $x $y]
#if {![regexp $cur_mode "select|move"] && $cur_itemsnap} {
# if {$sn_x==""} {
# sets {x y} [list $sn_x $sn_y]
# }
#}
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
sets {xx yy} [list [.c canvasx $x] [.c canvasy $y]]
if {$grid>0} {
sets {x y} [list [.c canvasx $x $grid] [.c canvasy $y $grid]]
} else {
sets {x y} [list $xx $yy]
}
switch -regexp $cur_mode {
"^(select)$" {
set cur_bbox [list $x $y]
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
if {$id!="" && [lsearch [.c gettags $id] "grid"]==-1 && $cur_layer==$layer_id($id) } {
if {[info exists selectnod($id)]} {
set cur_nod $id
set id $selectnod($id)
set cur_mode resize
return
} elseif {[info exists gradation($id)]} {
set id $gradation($id)
}
if {$layer_id($id)!=$cur_layer} {return}
set cur_mode "move"
if {$cur_id=="" || [lsearch $cur_id $id]==-1} {
unselectItem cur_id
selectItem id
if {$cur_cursor!="fleur"} {
set cur_cursor "fleur"
.c configure -cursor $cur_cursor
update idletasks
}
} else {
unselectItem id
}
} else {
unselectItemAll
set cur_id [.c create rectangle $xx $yy $xx $yy]
set cur_bbox "$xx $yy"
}
}
"^(move)$" {
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
} elseif {$canvas_grid==0} {
set a 10
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
set cur_bbox [list $x $y]
if {$id=="" || [lsearch $cur_id $id]==-1} {
if {[info exists selectnod($id)]} {
set cur_nod $id
set id $selectnod($id)
set cur_mode resize
return
} elseif {[info exists gradation($id)]} {
set id $gradation($id)
}
if {[lsearch $cur_id $id]==-1} {
unselectItem cur_id
set cur_mode select
}
}
}
"^(resize)$" {
puts "Why resize!?"
}
"^(colSpoit)$" {
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
if {$id!=""} {
set col [.c itemcget $id -fill]
set t .op.col
$t.cur_col configure -background $col
$t.cole delete 0 end
$t.cole insert 0 $col
set m 65535.0
sets {r g b} [winfo rgb . $col]
set cur_col [list 255 [expr $r/$m] [expr $g/$m] [expr $b/$m]]
}
}
"^(nodDel)$" {
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
if {$id=="" || [lsearch $cur_id $id]==-1} {
if {[info exists selectnod($id)]} {
set cur_nod $id
set id $selectnod($cur_nod)
set n [lsearch $selectnod_id($id) $cur_nod]
set coord [getLineCoord $id]
set coord [lreplace $coord [expr $n*2] [expr $n*2+1]]
set i [lsearch $nod_dupinfo($id) $n]
if {$i!=-1} {
set nod_dupinfo($id) [lreplace $nod_dupinfo($id) $i $i]
}
set d ""
foreach dn $nod_dupinfo($id) {
if {$dn>=$n} {incr dn -1}
lappend d $dn
}
set nod_dupinfo($id) $d
if {[llength $coord]<4 || $itemType($id)=="poly" && [llength $coord]<6} {
unselectItem id
deleteItem $id
} else {
eval .c coord $id [makeLineCoord $id $coord]
.c delete $cur_nod
unset selectnod($cur_nod)
set selectnod_id($id) [lreplace $selectnod_id($id) $n $n]
}
}
}
}
"^(nodCut)$" {
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
if {$id=="" || [lsearch $cur_id $id]==-1} {
if {[info exists selectnod($id)]} {
set cur_nod $id
set id $selectnod($cur_nod)
set n [lsearch $selectnod_id($id) $cur_nod]
set coord [getLineCoord $id]
set coord_a [lrange $coord [expr $n*2] end]
set coord_b [lrange $coord 0 [expr $n*2+1]]
set coord [lreplace $coord [expr $n*2] [expr $n*2+1]]
unselectItem id
set d ""
foreach dn nod_dupinfo($id) {
if {$dn==$n} {
lappend d $dn
}
}
set nod_dupinfo($id) $d
eval .c coord $id [makeLineCoord $id $coord_a]
makeItem $itemType($id) \
-fill [.c itemcget $id -fill] \
-smooth [get_smooth .c $id] \
$coord_b
selectItem id
}
}
}
"^(nodAdd)$" {
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
if {$id=="" || [lsearch $cur_id $id]==-1} {
if {[info exists selectnod($id)]} {
set cur_nod $id
set id $selectnod($cur_nod)
set n [lsearch $selectnod_id($id) $cur_nod]
unselectItem id
set d ""
foreach dn $nod_dupinfo($id) {
if {$dn>=$n} {incr dn}
lappend d $dn
}
set coord [linsert [getLineCoord $id] [expr $n*2] $x $y]
set nod_dupinfo($id) $d
eval .c coord $id [makeLineCoord $id $coord]
selectItem id
set cur_nod [lindex $selectnod_id($id) $n]
}
}
}
"^(text)$" {
}
"^(rect|orect)$" {
unselectItem cur_id
set cur_id [.c create rectangle $x $y $x $y -width $cur_linewidth -outline $fill]
set cur_bbox [list $x $y]
}
"^(box|obox|boxx)$" {
unselectItem cur_id
set cur_id [.c create rectangle $x $y $x $y -fill $fill -outline $fill]
set cur_bbox [list $x $y]
}
"^(circle)$" {
unselectItem cur_id
set cur_id [.c create oval $x $y $x $y -outline $fill -width $cur_linewidth]
set cur_bbox [list $x $y]
}
"^(oval|sphere)$" {
unselectItem cur_id
set cur_id [.c create oval $x $y $x $y -fill $fill -outline $fill]
set cur_bbox [list $x $y]
}
"^(arrow)$" {
unselectItem cur_id
set cur_id [.c create line $x $y $x $y -arrow $cur_arrow -width $cur_linewidth -arrowshape $cur_arrowshape -capstyle $linecap -smooth $cur_smooth -fill $fill]
set cur_bbox [list $x $y]
}
"^(^line)$" {
unselectItem cur_id
set cur_id [.c create line $x $y $x $y -width $cur_linewidth -arrowshape $cur_arrowshape -capstyle $linecap -smooth $cur_smooth -fill $fill]
set cur_bbox [list $x $y]
}
"^(^fline)$" {
set fline_cnt 0
unselectItem cur_id
set cur_id [.c create line $x $y $x $y -width $cur_linewidth -arrowshape $cur_arrowshape -capstyle $linecap -smooth $cur_smooth -fill $fill]
set cur_bbox [list $x $y]
}
"^(pline|poly)$" {
unselectItem cur_id
if {$cur_id=="" || [llength $cur_bbox]<0} {
if {0} {
set cur_id [.c create line $x $y $x $y \
-width $cur_linewidth -arrowshape $cur_arrowshape \
-capstyle $linecap -smooth $cur_smooth -fill $fill]
set cur_bbox "$x $y"
}
} elseif {[llength $cur_bbox]>1} {
eval .c coord $cur_id $cur_bbox $x $y
append cur_bbox " $x $y"
} else {
eval .c coord $cur_id $cur_bbox $x $y
}
}
"^(rod)$" {
unselectItem cur_id
set cur_id [.c create line $x $y $x $y -width $rodwidth -smooth $cur_smooth -fill $fill]
set cur_bbox [list $x $y]
}
"^(pixel)$" {
unselectItem cur_id
set cur_id [.c create line $x $y [expr $x+1] $y -fill $fill]
set cur_bbox [list $x $y]
}
default {puts "Error: unknown mode specified.: $x $y $cur_mode"}
}
}
proc Shift-ButtonPress-1 {{x} {y}} {
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global cur_cursor
global itemType
global selectnod_id selectnod
global gradation_id gradation
global raiselower
global fontsize cur_linewidth linecap rodwidth
global canvas_grid grid_unit cur_zoom
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
if {$grid>0} {
set x [.c canvasx $x $grid]
set y [.c canvasy $y $grid]
} else {
sets {x y} [list [.c canvasx $x] [.c canvasy $y]]
}
switch -regexp $cur_mode {
"^(select|move)$" {
set cur_bbox "move"
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
if {$id != "" && [lsearch [.c gettags $id] "grid"]==-1} {
set cur_mode "move"
if {[info exists selectnod($id)]} {
set cur_nod $id
set id $selectnod($id)
if {1} {
toggleItemNodDup $id [lsearch $selectnod_id($id) $cur_nod]
} else {
set cur_mode resize
}
return
} elseif {[info exists gradation($id)]} {
set id $gradation($id)
}
if {$cur_id=="" || [lsearch $cur_id $id]==-1} {
selectItem id
if {$cur_cursor!="fleur"} {
set cur_cursor "fleur"
.c configure -cursor $cur_cursor
update idletasks
}
} else {
unselectItem id
}
}
}
"^(pline|poly)$" {
unselectItem cur_id
if {$cur_id=="" || [llength $cur_bbox]<0} {
if {0} {
set cur_id [.c create line $x $y $x $y \
-width $cur_linewidth -arrowshape $cur_arrowshape \
-capstyle $linecap -smooth $cur_smooth -fill $fill]
set cur_bbox "$x $y"
}
} elseif {[llength $cur_bbox]>1} { ;# nod duplicate
eval .c coord $cur_id $cur_bbox $x $y
append cur_bbox " $x $y $x $y"
} else {
eval .c coord $cur_id $cur_bbox $x $y $x $y
}
}
default {set cur_bbox ""; set cur_mode "select"}
}
}
proc Button1-Motion {{x} {y}} {
global cur_mode cur_id cur_bbox cur_nod
global itemType
global selectnod_id selectnod
global gradation_id gradation
global nod_dupinfo
global fline_cnt fline_skipnum
global canvas_grid grid_unit cur_zoom
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
sets {xx yy} [list [.c canvasx $x] [.c canvasy $y]]
if {$grid>0} {
sets {x y} [list [.c canvasx $x $grid] [.c canvasy $y $grid]]
} else {
sets {x y} [list $xx $yy]
}
set x0 [lindex $cur_bbox 0]
set y0 [lindex $cur_bbox 1]
switch -regexp $cur_mode {
"^(select)$" {
if {$cur_id!="" && $cur_bbox!=""} {
eval .c coord $cur_id [lrange $cur_bbox 0 1] $xx $yy
}
}
"^(move)$" {
moveItem [expr $x-$x0] [expr $y-$y0] cur_id
set cur_bbox [list $x $y]
}
"^(resize)$" {
foreach id $cur_id {
set n [lsearch $selectnod_id($id) $cur_nod]
if {$n==-1} {continue}
set coord [lreplace [getLineCoord $id] [expr $n*2] [expr $n*2+1] $x $y]
# box ¤Ê¤É¤Ç¤Î¥ê¥µ¥¤¥º¤òŬÅö¤Ë¤¹¤ë¤Ë¤Ï¤³¤³¤¤¤é¤ò¤¤¤¸¤ë
eval .c coord $id [makeLineCoord $id $coord]
eval .c coord $cur_nod [expr $x-3] [expr $y-3] [expr $x+3] [expr $y+3]
#unselectItem id
#selectItem id
#set cur_nod [lindex $selectnod_id($id) $n]
resizeItem id
break
}
}
"^(colSpoit)$" {
}
"^(nodDel|nodCut)$" {
}
"^(nodAdd)$" {
foreach id $cur_id {
set n [lsearch $selectnod_id($id) $cur_nod]
if {$n==-1} {
continue
}
set coord [lreplace [getLineCoord $id] [expr $n*2] [expr $n*2+1] $x $y]
eval .c coord $id [makeLineCoord $id $coord]
eval .c coord $cur_nod [expr $x-3] [expr $y-3] [expr $x+3] [expr $y+3]
resizeItem id
break
}
}
"^(text)$" {
}
"^(rect|orect|box|obox|boxx|circle|oval|sphere|line|rod)$" {
eval .c coord $cur_id $cur_bbox $x $y
}
"^(arrow)$" {
eval .c coord $cur_id $x $y $cur_bbox
}
"^(fline)$" {
incr fline_cnt
if {fmod($fline_cnt, $fline_skipnum)==0} {
append cur_bbox " $x $y"
eval .c coord $cur_id $cur_bbox
}
}
"^(pline|poly)$" {
if {0 && [llength $cur_bbox]==2} {
eval .c coord $cur_id $cur_bbox $x $y
} elseif {[llength $cur_bbox]>1} {
eval .c coord $cur_id $cur_bbox $x $y
}
}
"^(pixel)$" {
eval .c coord $cur_id $x $y [expr $x+1] $y
}
default {puts "Error: unknown mode specified.: $cur_mode $x $y"}
}
}
proc ButtonRelease-1 {{x} {y}} {
global itemType
global cur_mode cur_id cur_bbox cur_col cur_smooth cur_arrowshape
global fontsize cur_linewidth linecap rodwidth
global canvas_grid grid_unit cur_zoom
set fill "PeachPuff"
if {$cur_col!=""} { ;# ËÜÅö¤Ï ButtonPress Ëè¤Ë¹Ô¤¦¤Ù¤½èÍý¤¸¤ã¤Ê¤¤
sets {color col_r col_g col_b} $cur_col
set fill [format "#%02x%02x%02x" \
[expr int($color*$col_r)] \
[expr int($color*$col_g)] \
[expr int($color*$col_b)]]
}
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
sets {xx yy} [list [.c canvasx $x] [.c canvasy $y]]
if {$grid>0} {
sets {x y} [list [.c canvasx $x $grid] [.c canvasy $y $grid]]
} else {
sets {x y} [list $xx $yy]
}
switch -regexp $cur_mode {
"^(select)$" {
if {$cur_id!="" && $cur_bbox!=""} {
eval .c coord $cur_id $cur_bbox $xx $yy
set cur_bbox [.c bbox $cur_id]
.c delete $cur_id
set cur_id ""
} else {
set cur_bbox ""
}
if {$cur_bbox!=""} {
set enclose_id [eval .c find enclose $cur_bbox]
set id [canvasToItem enclose_id]
if {$id!=""} {
selectItem id
set cur_mode "move"
}
}
}
"^(move)$" {
if {[llength $cur_id]==1} {
set id [canvasToItem cur_id]
selectItem id
if {$itemType($id)=="text"} {
.text.e delete 0.0 end
.text.e insert 0.0 [.c itemcget $id -text]
set f [.c itemcget $id -font]
if {[llength f]>2} {
set fontsize [lindex $f 1]
}
} elseif {$itemType($id)=="line" || $itemType($id)=="arrow"} {
#set cur_linewidth [.c itemcget $id -width]
#set linecap [.c itemcget $id -capstyle]
} elseif {$itemType($id)=="rod"} {
#set rodwidth [.c itemcget $id -width]
#set cur_linewidth $rodwidth
}
}
#set cur_mode "select"
}
"^(resize)$" {
#set cur_mode "select"
set cur_mode "move"
}
"^(colSpoit)$" {
}
"^(nodDel|nodCut|nodAdd)$" {
}
"^(fline)$" {
makeItem $cur_mode $cur_bbox
}
"^(pline|poly)$" {
if {$cur_id=="" || [llength $cur_bbox]<0} {
set cur_id [.c create line $x $y $x $y \
-width $cur_linewidth -arrowshape $cur_arrowshape \
-capstyle $linecap -smooth $cur_smooth -fill $fill]
set cur_bbox "$x $y"
} elseif {0 && [llength $cur_bbox]==2
&& [lindex $cur_bbox 0]==$x && [lindex $cur_bbox 1]==$y} {
} else {
}
}
default {
makeItem $cur_mode -fill $fill "$x $y $cur_bbox"
}
}
}
proc ButtonPress-2 {{x} {y}} {
global itemType
global cur_mode cur_id cur_bbox cur_col cur_smooth
global fontsize cur_linewidth linecap rodwidth
global canvas_grid grid_unit cur_zoom
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
if {$grid>0} {
set x [.c canvasx $x $grid]
set y [.c canvasy $y $grid]
} else {
sets {x y} [list [.c canvasx $x] [.c canvasy $y]]
}
switch -regexp $cur_mode {
"^(select|text)$" {
set a 1
if {$canvas_grid>2} {
set a [expr $grid/2]
}
set id [lindex [.c find overlapping \
[expr $x-$a] [expr $y-$a] [expr $x+$a] [expr $y+$a]] end]
if {$id!="" && $itemType($id)=="text"} {
unselectItemAll
editText .c $x $y $id
set cur_mode "select"
}
}
}
}
proc ButtonPress-3 {{x} {y}} {
global itemType
global cur_mode cur_id cur_bbox cur_col
global fontsize cur_linewidth linecap rodwidth
global canvas_grid grid_unit cur_zoom
global poly_tgiftype
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
if {$grid>0} {
set x [.c canvasx $x $grid]
set y [.c canvasy $y $grid]
} else {
sets {x y} [list [.c canvasx $x] [.c canvasy $y]]
}
switch -regexp $cur_mode {
"^(pline|poly)$" {
.c delete $cur_id
set cur_id ""
if {$poly_tgiftype} {append cur_bbox " $x $y"}
if {[llength $cur_bbox]>2} {
makeItem $cur_mode $cur_bbox
}
if {$cur_bbox==""} {set cur_mode "select"}
set cur_bbox ""
}
default {
}
}
}
proc Shift-ButtonPress-3 {{x} {y}} {
global itemType
global cur_mode cur_id cur_bbox cur_col
global fontsize cur_linewidth linecap rodwidth
global canvas_grid grid_unit cur_zoom
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
if {$grid>0} {
set x [.c canvasx $x $grid]
set y [.c canvasy $y $grid]
} else {
sets {x y} [list [.c canvasx $x] [.c canvasy $y]]
}
switch -regexp $cur_mode {
"^(pline|poly)$" {
if {$cur_id!=""} {
set coord [.c coord $cur_id]
set n [llength $coord]
set nn 4
if {$n>4} {
sets {x1 y1 x2 y2} [lrange $coord [expr $n-6] [expr $n-2]]
if {$x1==$x2 && $y2==$y2} {
set nn 6
}
}
if {$n>$nn} {
set cur_bbox [lrange $coord 0 [expr $n-$nn-1]]
eval .c coord $cur_id $cur_bbox $x $y
} else {
.c delete $cur_id
set cur_id ""
set cur_bbox ""
}
}
}
default {
}
}
}
proc ButtonMotion {{x} {y}} {
global itemType
global cur_mode cur_id cur_bbox cur_col cur_cursor
global cur_layer layer_id
global fontsize cur_linewidth linecap rodwidth
global selectnod selectnod_id
global gradation gradation_id
global canvas_grid grid_unit cur_zoom
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
sets {xx yy} [list [.c canvasx $x] [.c canvasy $y]]
if {$grid>0} {
sets {x y} [list [.c canvasx $x $grid] [.c canvasy $y $grid]]
} else {
sets {x y} [list $xx $yy]
}
switch -regexp $cur_mode {
"^(pline|poly)$" {
if {[llength $cur_bbox]>0} {
eval .c coord $cur_id $cur_bbox $x $y
update idletasks
}
}
"^(move|select)" {
set a 1
if {0 && $canvas_grid>2} {
set a [expr $grid/2]
} else {
set a 2
}
set x0 [.c canvasx $xx]
set y0 [.c canvasy $yy]
set id [lindex [.c find overlapping \
[expr $x0-$a] [expr $y0-$a] [expr $x0+$a] [expr $y0+$a]] end]
if {[info exists gradation($id)]} {
set id $gradation($id)
}
if {$id!="" && ([info exists selectnod($id)] || ([info exists layer_id($id)] && $layer_id($id)==$cur_layer))} {
if {[lsearch $cur_id $id]==-1 || $cur_mode=="select"} {
set cursor "crosshair"
} else {
set cursor "fleur"
}
if {$cur_cursor!=$cursor} {
set cur_cursor $cursor
.c configure -cursor $cur_cursor
update idletasks
}
} elseif {$cur_cursor!="left_ptr"} {
set cur_cursor "left_ptr"
.c configure -cursor $cur_cursor
update idletasks
}
update idletasks
}
default {
}
}
}
############################################################
#
proc changeLayer {{n}} {
global cur_layer layer_id
if {0} {
foreach id [array names layer_id] {
if {$layer_id($id)!=$n} {
set stipple gray75
} else {
.c raise $id
set stipple {}
}
.c itemconfigure $id -stipple $stipple
}
}
set cur_layer $n
}
############################################################
#
proc canvasToItem {enclose_id} {
upvar $enclose_id e_id
global selectnod selectnod_id
global gradation gradation_id
set tmp_id ""
foreach id $e_id {
if {[info exists gradation_id($id)]} {
lappend tmp_id $id
}
}
return $tmp_id
}
proc raiselowerItem {{raiselower_id}} {
upvar $raiselower_id l_id
global gradation_id
global raiselower
foreach id $l_id {
if {$raiselower=="lower"} {
if {[.c find withtag grid]!={}} {
.c raise $id grid
} else {
.c lower $id
}
} else {
.c raise $id
}
set p $id
foreach g_id $gradation_id($id) {
.c raise $g_id $p
set p $g_id
}
}
if {$raiselower=="raise"} {
set raiselower lower
} else {
set raiselower raise
}
}
proc raiseItem {r_id} {
global gradation_id
global cur_editedp
if {$r_id!=""} {
set cur_editedp 1
}
unselectItem r_id
foreach id $r_id {
.c raise $id
foreach g_id $gradation_id($id) {
.c raise $g_id
}
}
selectItem r_id
}
proc lowerItem {l_id} {
global gradation_id
global cur_editedp
if {$l_id!=""} {
set cur_editedp 1
}
unselectItem l_id
foreach id [lreverse $l_id] {
if {[.c find withtag grid]!={}} {
.c raise $id grid
} else {
.c lower $id
}
set p_id $id
foreach g_id $gradation_id($id) {
.c raise $g_id $p_id
set p_id $g_id
}
}
selectItem l_id
}
proc selectItem {{select_id}} {
upvar $select_id s_id
global itemType
global cur_id
global selectnod selectnod_id
global gradation gradation_id
global nod_dupinfo
global raiselower
global group itemgroup
global cur_layer layer_id
foreach id $s_id {
if {[info exists itemgroup($id)]} {
foreach gname $itemgroup($id) {
foreach gid $group($gname) {
if {[lsearch $cur_id $gid]==-1 && [lsearch $s_id $gid]==-1} {
lappend s_id $gid
}
}
}
}
}
foreach id $s_id {
if {[lsearch $cur_id $id]!=-1} {
continue
}
if {$layer_id($id)!=$cur_layer} {
continue
}
#.c raise $id
set coord [getLineCoord $id]
foreach g_id $gradation_id($id) {
#.c raise $g_id
}
set i 0
foreach {x y} $coord {
set col_o blue
if {[lsearch $nod_dupinfo($id) $i]==-1} {
set col_f blue
} else {
set col_f orange
}
set n_id [.c create rectangle \
[expr $x-3] [expr $y-3] \
[expr $x+3] [expr $y+3] \
-outline $col_o -fill $col_f -width 2]
lappend selectnod_id($id) $n_id
set selectnod($n_id) $id
incr i
}
#set raiselower lower
lappend cur_id $id
}
}
proc selectItemAll {} {
global cur_mode cur_id cur_bbox
global selectnod selectnod_id
global gradation gradation_id
global width height
set cur_bbox "0 0"
foreach id [.c find all] {
if {[info exists gradation_id($id)]} {
selectItem id
}
}
set cur_mode "select"
}
proc unselectItem {{unselect_id}} {
upvar $unselect_id u_id
global cur_id
global selectnod selectnod_id
foreach id $u_id {
if {![info exists selectnod_id($id)]} {
continue
}
foreach n_id $selectnod_id($id) {
.c delete $n_id
unset selectnod($n_id)
}
unset selectnod_id($id)
set n [lsearch $cur_id $id]
if {$n>-1} {
set cur_id [lreplace $cur_id $n $n]
}
}
}
proc unselectItemAll {} {
global cur_id cur_bbox
global selectnod selectnod_id
set u_id [array names selectnod_id]
unselectItem u_id
set cur_id ""
set cur_bbox ""
}
proc moveItem {{sx} {sy} {move_id}} {
upvar $move_id m_id
global selectnod_id
global gradation_id
global cur_editedp
global canvas_grid cur_zoom
if {$m_id!=""} {
set cur_editedp 1
}
foreach id $m_id {
.c move $id $sx $sy
foreach g_id $gradation_id($id) {
.c move $g_id $sx $sy
#.c raise $g_id
}
foreach n_id $selectnod_id($id) {
.c move $n_id $sx $sy
#.c raise $n_id
}
}
}
proc deleteItem {{d_id}} {
global selectnod selectnod_id
global gradation gradation_id
global nod_dupinfo
global cur_id cur_bbox
global cur_editedp
global cur_layer layer_id
if {$d_id!=""} {
set cur_editedp 1
}
unselectItem d_id
foreach id $d_id {
foreach g_id $gradation_id($id) {
.c delete $g_id
unset gradation($g_id)
}
unset gradation_id($id)
unset layer_id($id)
unset nod_dupinfo($id)
.c delete $id
}
set cur_bbox ""
}
proc deleteItemAll {} {
global cur_id
selectItemAll; deleteItem $cur_id
}
proc deleteItemAll_old {} {
global cur_mode cur_id cur_bbox
global selectnod selectnod_id
global gradation gradation_id
global width height
foreach id [.c find all] {
if {[array names gradation $id]!="" ||
[array names selectnod $id]!=""} {
continue
}
deleteItem $id
}
}
proc makeOptString {{w} {id} {opt}} {
set val [$w itemcget $id $opt]
if {"$val"!=""} {
return "$opt $val"
} else {
return ""
}
}
proc setCurrentInfo {{fname} {title} {creator} {createdate}} {
global cur_filename cur_filetitle cur_creator cur_createdate
set cur_filename $fname
set cur_filetitle $title
set cur_creator $creator
set cur_createdate $createdate
}
proc editCurrentInfo {} {
global cur_filename cur_filetitle cur_creator cur_createdate
set t .eci
toplevel $t
wm title $t "tkduke: Current Info Editor"
label $t.lfn -text "File Name" -justify right
entry $t.fn
label $t.lft -text "Title" -justify right
entry $t.ft -width 40
label $t.lcr -text "Creator" -justify right
entry $t.cr
label $t.lcd -text "Create Date" -justify right
entry $t.cd
$t.fn insert 0 $cur_filename
$t.ft insert 0 $cur_filetitle
$t.cr insert 0 $cur_creator
$t.cd insert 0 $cur_createdate
frame $t.f
button $t.f.ok -text "OK" -command "setCurrentInfo \[$t.fn get\] \[$t.ft get\] \[$t.cr get\] \[$t.cd get\]
destroy $t
wm title . \"tkduke: \$cur_filename\"
"
button $t.f.cancel -text "Cancel" -command "destroy $t"
grid $t.lfn -column 0 -row 0 -sticky nes
grid $t.fn -column 1 -row 0 -sticky news
grid $t.lft -column 0 -row 1 -sticky nes
grid $t.ft -column 1 -row 1 -sticky news
grid $t.lcr -column 0 -row 2 -sticky nes
grid $t.cr -column 1 -row 2 -sticky news
grid $t.lcd -column 0 -row 3 -sticky nes
grid $t.cd -column 1 -row 3 -sticky news
grid $t.f.ok $t.f.cancel
grid $t.f -columnspan 2
bind $t <Key-Return> "setCurrentInfo \[$t.fn get\] \[$t.ft get\] \[$t.cr get\] \[$t.cd get\]
destroy $t
wm title . \"tkduke: \$cur_filename\"
"
bind $t <Control-s> "setCurrentInfo \[$t.fn get\] \[$t.ft get\] \[$t.cr get\] \[$t.cd get\]
destroy $t
wm title . \"tkduke: \$cur_filename\"
"
bind $t <Control-q> "destroy $t"
}
proc saveItem {fname} {
global itemType
global cur_mode cur_id cur_bbox
global cur_filename cur_printname
global cur_filetitle cur_creator cur_createdate
global cur_editedp cur_zoom
global cur_paporient
global cur_layer layer_id
global selectnod selectnod_id
global gradation gradation_id
global nod_dupinfo
global fontsizeId
global itemgroup
global width height
global cur_editedp cur_backupedp
global cur_saving
global cur_savepreview
global cur_gridshow
global imageFileMap
if {![regexp {\.mmp$} $fname]} {append fname ".mmp"}
. configure -cursor watch
update idletasks
if {$cur_saving==1} {return}
set cur_saving 1
set gif_preview ""
if {$cur_savepreview} {set gif_preview [getCanvasSnapshot .c]}
set cur_bbox "0 0"
set tmp_id ""
foreach id [.c find all] {
if {[lsearch [.c gettags $id] "grid"]!=-1} {
continue
} elseif {[info exists gradation_id($id)]} {
lappend tmp_id $id
}
}
if {!$cur_backupedp && $cur_filename!="" && [file exists $cur_filename]} {
set f [glob $cur_filename]
file rename -force $f $f.bak
set cur_backupedp 1
}
set fid [open $fname w]
set layer $cur_layer
puts $fid "#!/usr/local/bin/tkduke"
puts $fid ""
puts $fid "# "
puts $fid "# [basename $cur_filename]: $cur_filetitle"
puts $fid "# "
puts $fid "# \[$cur_createdate\] $cur_creator"
puts $fid "# "
if {$cur_savepreview} {
if {$gif_preview!=""} {
puts $fid ""
puts $fid "# preview: image/gif; base64"
foreach l $gif_preview {
puts $fid "# $l"
}
}
}
puts $fid ""
puts $fid "title $cur_filetitle"
puts $fid "creator $cur_creator"
puts $fid "createdate $cur_createdate"
puts $fid ""
puts $fid "orient $cur_paporient"
puts $fid "zoom $cur_zoom"
puts $fid "layer $layer"
foreach id $tmp_id {
if {$layer_id($id)!=$layer} {
set layer $layer_id($id)
puts $fid "layer $layer"
}
if {[info exists itemgroup($id)] && $itemgroup($id)!=""} {
puts $fid "#group $itemgroup($id)"
}
puts -nonewline $fid "$itemType($id) "
switch -regexp $itemType($id) {
"^(text)$" {
set str [.c itemcget $id -text]
regsub -all "\n" $str "\\\n" str
puts -nonewline $fid "\{$str\} "
}
"^(arrow)$" {
set arrow [.c itemcget $id -arrow]
puts -nonewline $fid "\{$arrow\} "
}
}
set opt ""
switch -regexp -- $itemType($id) {
"^(arrow|line|pline)$" {
set smooth [get_smooth .c $id]
if {$smooth} {append opt " -smooth 1"}
append opt " [makeOptString .c $id -width]"
append opt " [makeOptString .c $id -capstyle]"
}
"^rod$" {
set smooth [.c itemcget $id -smooth]
if {$smooth} {append opt " -smooth 1"}
append opt " [makeOptString .c [lindex $gradation_id($id) 0] -width]"
puts $opt
}
"^(poly)$" {
set smooth [get_smooth .c $id]
if {$smooth} {append opt " -smooth 1"}
append opt " [makeOptString .c $id -width]"
append opt " [makeOptString .c $id -outline]"
}
"^(rect|circle)$" {
append opt " [makeOptString .c $id -width]"
append opt " [makeOptString .c $id -outline]"
}
"^(oval|orect|obox|box)$" {
append opt " [makeOptString .c $id -width]"
append opt " [makeOptString .c $id -fill]"
}
"^(text)$" {
set tmp_font " [makeOptString .c $id -font]"
regsub -- "-\[0-9\]+\$" [makeOptString .c $id -font] "-$fontsizeId($id)" tmp_font
append opt " $tmp_font"
append opt " [makeOptString .c $id -anchor]"
append opt " [makeOptString .c $id -justify]"
}
}
if {$itemType($id)!="image"} {
append opt " [makeOptString .c $id -stipple]"
puts -nonewline $fid "\{[.c itemcget $id -fill]\}$opt "
} else {
puts -nonewline $fid "\{$imageFileMap([.c itemcget $id -image])\}$opt "
}
set coord ""
set coord_tmp [getLineCoord $id]
set i 0
foreach {x y} $coord_tmp {
set x [format "%.2f" [expr 1.0*$x/$cur_zoom]]
set y [format "%.2f" [expr 1.0*$y/$cur_zoom]]
regsub {\.00} $x "" x
regsub {\.00} $y "" y
if {[lsearch -exact $nod_dupinfo($id) $i]!=-1} {
lappend coord $x $y
}
lappend coord $x $y
incr i
}
puts $fid $coord
}
puts $fid "#"
puts $fid "# end of mmp file."
close $fid
set cur_filename $fname
regsub ".mmp$" [file tail $cur_filename] "" cur_printname
append cur_printname ".eps"
wm title . "tkduke: $cur_filename"
wm iconname . "$cur_filename"
set cur_editedp 0
set cur_saving 0
. configure -cursor left_ptr
update idletasks
}
############################################################
#
proc toggleOrient {} {
global width height cur_paporient cur_zoom
set tmp $width
set width $height
set height $tmp
if {$cur_paporient=="landscape" || $cur_paporient=="horizontal"} {
set cur_paporient "portrait"
} elseif {$cur_paporient=="portrait" || $cur_paporient=="vertical"} {
set cur_paporient "landscape"
} else {
set cur_paporient "landscape"
}
changeZoom $cur_zoom
}
proc toggleSmoothItem {{t_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
#puts toggleSmoothIterm
if {$t_id!=""} {
set cur_editedp 1
#puts toggleSmoothIterm:0
} elseif {0} {
switch $cur_smooth {
"0" {set cur_smooth "1"}
"1" {set cur_smooth "0"}
default {set cur_smooth "1"}
}
#puts toggleSmoothIterm:1
# return
}
foreach id $t_id {
switch -regexp -- $itemType($id) {
"^(arrow|line|pline|poly)$" {
set type [get_smooth .c $id]
switch $type {
"0" {set type "1"}
"1" {set type "0"}
default {set type "1"}
}
.c itemconfigure $id -smooth $type
}
default {}
}
}
}
proc toggleArrowItem {{t_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$t_id!=""} {
set cur_editedp 1
} else {
switch $cur_arrow {
"first" {set cur_arrow "last"}
"last" {set cur_arrow "both"}
"both" {set cur_arrow "first"}
default {set cur_arrow "first"}
}
return
}
foreach id $t_id {
set itype $itemType($id)
switch -regexp -- $itype {
"^(arrow|line|pline)$" {
set type [.c itemcget $id -arrow]
switch $type {
"first" {set itype "arrow"; set type "last"}
"last" {set itype "arrow"; set type "both"}
"both" {set itype "line"; set type "none"}
"none" {set itype "arrow"; set type "first"}
default {set itype "arrow"; set type "first"}
}
.c itemconfigure $id -arrow $type
}
default {}
}
set itemType($id) $itype
}
}
proc toggleTextJustify {{t_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global cur_textjustify
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$t_id==""} {
set type $cur_textjustify
switch $type {
"center" {set type "left"}
"left" {set type "right"}
"right" {set type "center"}
default {set type "center"}
}
set cur_textjustify $type
return
}
set cur_editedp 1
foreach id $t_id {
switch -regexp -- $itemType($id) {
"^(text)$" {
set type [.c itemcget $id -justify]
switch $type {
"center" {set type "left"}
"left" {set type "right"}
"right" {set type "center"}
default {set type "center"}
}
.c itemconfigure $id -justify $type
}
default {}
}
}
}
proc toggleTextAnchor {{t_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global cur_textanchor
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$t_id==""} {
set type $cur_textanchor
switch $type {
"se" {set type "s"}
"s" {set type "sw"}
"sw" {set type "e"}
"e" {set type "center"}
"center" {set type "w"}
"w" {set type "ne"}
"ne" {set type "n"}
"n" {set type "nw"}
"nw" {set type "se"}
default {set type "center"}
}
set cur_textanchor $type
return
}
set cur_editedp 1
foreach id $t_id {
switch -regexp -- $itemType($id) {
"^(text)$" {
set type [.c itemcget $id -anchor]
switch $type {
"se" {set type "s"}
"s" {set type "sw"}
"sw" {set type "e"}
"e" {set type "center"}
"center" {set type "w"}
"w" {set type "ne"}
"ne" {set type "n"}
"n" {set type "nw"}
"nw" {set type "se"}
default {set type "center"}
}
.c itemconfigure $id -anchor $type
}
default {}
}
}
}
proc makeFrame {{c_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$c_id==""} {return}
set cur_editedp 1
set tmp_id $c_id
unselectItem c_id
set padx 8
set pady 8
if {[llength $c_id]>1} {
sets {x0 y0 x1 y1} [eval .c bbox $c_id]
incr x0 -$padx
incr y0 -$pady
incr x1 $padx
incr y1 $pady
lappend tmp_id [makeItem "rect" [list $x0 $y0 $x1 $y1]]
} else {
set id $c_id
set type $itemType($id)
sets {x0 y0 x1 y1} [.c bbox $id]
if {$type=="box" || $type=="boxx" || $type=="obox"} {
} else {
incr x0 -$padx
incr y0 -$pady
incr x1 $padx
incr y1 $pady
}
lappend tmp_id [makeItem "rect" [list $x0 $y0 $x1 $y1]]
}
selectItem tmp_id
}
proc makeShadow {{c_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$c_id==""} {return}
set cur_editedp 1
set tmp_id $c_id
unselectItem c_id
set padx 8
set pady 8
set sx 8
set sy 8
if {[llength $c_id]>1} {
sets {x0 y0 x1 y1} [eval .c bbox $c_id]
incr x0 -$padx
incr y0 -$pady
incr x1 $padx
incr y1 $pady
lappend tmp_id [makeItem "box" [list $x1 [expr $y0+$sy] [expr $x1+$sx] [expr $y1+$sy]]]
lappend tmp_id [makeItem "box" [list [expr $x0+$sx] $y1 [expr $x1+$sx] [expr $y1+$sy]]]
lappend tmp_id [makeItem "rect" [list $x0 $y0 $x1 $y1]]
} else {
set id $c_id
set type $itemType($id)
sets {x0 y0 x1 y1} [.c bbox $id]
if {$type=="box" || $type=="boxx" || $type=="obox"} {
} else {
incr x0 -$padx
incr y0 -$pady
incr x1 $padx
incr y1 $pady
}
lappend tmp_id [makeItem "box" [list $x1 [expr $y0+$sy] [expr $x1+$sx] [expr $y1+$sy]]]
lappend tmp_id [makeItem "box" [list [expr $x0+$sx] $y1 [expr $x1+$sx] [expr $y1+$sy]]]
lappend tmp_id [makeItem "rect" [list $x0 $y0 $x1 $y1]]
}
selectItem tmp_id
}
proc makeBrace {{c_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$c_id==""} {return}
set cur_editedp 1
set tmp_id $c_id
unselectItem c_id
set padx 9
set pady 9
set w 10
if {[llength $c_id]>1} {
sets {x0 y0 x1 y1} [eval .c bbox $c_id]
incr x0 -$padx
incr y0 -$pady
incr x1 $padx
incr y1 $pady
} else {
set id $c_id
set type $itemType($id)
sets {x0 y0 x1 y1} [.c bbox $id]
if {$type=="box" || $type=="boxx" || $type=="obox"} {
} else {
incr x0 -$padx
incr y0 -$pady
incr x1 $padx
incr y1 $pady
}
}
lappend tmp_id [makeItem "pline" \
[list [expr $x0+$w] $y0 $x0 $y0 $x0 $y1 [expr $x0+$w] $y1]]
lappend tmp_id [makeItem "pline" \
[list [expr $x1-$w] $y0 $x1 $y0 $x1 $y1 [expr $x1-$w] $y1]]
selectItem tmp_id
}
proc copyItem {{c_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global selectnod_id selectnod
global gradation_id gradation
global font fontsizeId
global nod_dupinfo
global imageFileMap
global cur_editedp
global canvas_grid grid_unit cur_zoom
global group itemgroup cur_group_id
if {$c_id==""} {return}
set cur_editedp 1
set tmp_id {}
if {$canvas_grid==0} {
set grid $cur_zoom
} else {
set grid [expr ($canvas_grid*$grid_unit)*$cur_zoom]
}
if {$grid>0} {
set sx [expr int(15/$grid)*$grid]
set sy [expr int(10/$grid)*$grid]
if {$sx==0} {set sx $grid}
if {$sy==0} {set sy $grid}
} else {
set sx [expr int(15/$cur_zoom)*cur_zoom]
set sy [expr int(10/$cur_zoom)*cur_zoom]
}
unselectItem c_id
set copy_g() ""
set gmap() ""
foreach id $c_id {
set t_id ""
switch -regexp $itemType($id) {
"^(text)$" {
set tmp [.c itemcget $id -text]
.text.e delete 0.0 end
.text.e insert 0.0 $tmp
sets {x y} [.c coord $id]
set facesize [.c itemcget $id -font]
set face "gh"
if {[regexp "^Gothic:Helvetica-Bold-(\[0-9\]+)" \
$facesize null size]} {
set face "gh"
} elseif {[regexp "^Mincho:Times-Roman-(\[0-9\]+)" \
$facesize null size]} {
set face "mt"
}
set size $fontsizeId($id)
if {[info exists font($face:$size)]==0} {loadFont $size $face}
set t_id [makeItem $itemType($id) \
-anchor [.c itemcget $id -anchor] \
-justify [.c itemcget $id -justify] \
-fill [.c itemcget $id -fill] \
-font $font($face:$size) \
[list [expr $x+$sx] [expr $y+$sy]]]
}
"^(rect|box|obox|boxx|circle|oval|sphere|pixel)$" {
sets {x y x0 y0} [getLineCoord $id]
set x [expr $x+$sx]
set y [expr $y+$sy]
set x0 [expr $x0+$sx]
set y0 [expr $y0+$sy]
set t_id [makeItem $itemType($id) \
-fill [.c itemcget $id -fill] \
-outline [.c itemcget $id -outline] \
-width [.c itemcget $id -width] \
[list $x $y $x0 $y0]]
}
"^(orect)$" {
sets {x y x0 y0} [getLineCoord $id]
set x [expr $x+$sx]
set y [expr $y+$sy]
set x0 [expr $x0+$sx]
set y0 [expr $y0+$sy]
set t_id [makeItem $itemType($id) \
-fill [.c itemcget $id -fill] \
-width [.c itemcget $id -width] \
[list $x $y $x0 $y0]]
}
"^(arrow|line|rod)$" {
set coord [.c coord $id]
sets {x0 y0} $coord
set x0 [expr $x0+$sx]
set y0 [expr $y0+$sy]
set c_coord "$x0 $y0"
foreach {x y} [lrange $coord 2 end] {
set x [expr $x+$sx]
set y [expr $y+$sy]
append c_coord " $x $y"
}
set t_id [makeItem $itemType($id) \
-smooth [get_smooth .c $id] \
-arrow [.c itemcget $id -arrow] \
-fill [.c itemcget $id -fill] \
-width [.c itemcget $id -width] \
-capstyle [.c itemcget $id -capstyle] \
$c_coord]
}
"^(pline)$" {
set coord [.c coord $id]
set c_coord ""
foreach {x y} $coord {
set x [expr $x+$sx]
set y [expr $y+$sy]
append c_coord " $x $y"
}
set t_id [makeItem $itemType($id) \
-smooth [get_smooth .c $id] \
-arrow [.c itemcget $id -arrow] \
-fill [.c itemcget $id -fill] \
-width [.c itemcget $id -width] \
-capstyle [.c itemcget $id -capstyle] \
$c_coord]
}
"^(poly)$" {
set coord [.c coord $id]
set c_coord ""
foreach {x y} $coord {
set x [expr $x+$sx]
set y [expr $y+$sy]
append c_coord " $x $y"
}
set t_id [makeItem $itemType($id) \
-smooth [get_smooth .c $id] \
-fill [.c itemcget $id -fill] \
-width [.c itemcget $id -width] \
$c_coord]
}
"^(image)$" {
sets {x y} [.c coord $id]
set t_id [makeItem $itemType($id) -file $imageFileMap([.c itemcget $id -image]) [expr $x+$sx] [expr $y+$sy]]
}
default {}
}
if {$t_id!=""} {
if {[info exists itemgroup($id)]} {
foreach g $itemgroup($id) {
if {![info exists gmap($g)]} {
set gname "g$cur_group_id"
set gmap($g) $gname
set group($gname) ""
incr cur_group_id
} else {
set gname $gmap($g)
}
lappend group($gname) $t_id
lappend itemgroup($t_id) $gname
}
}
lappend tmp_id $t_id
}
}
selectItem tmp_id
}
proc propdist_sort {a b} {
set ax [lindex $a 1]
set ay [lindex $a 2]
set bx [lindex $b 1]
set by [lindex $b 2]
return [expr (sqrt($ax*$ax+$ay*$ay)>sqrt($bx*$bx+$by*$by))]
}
proc propdistItem {{prop_id}} {
upvar $prop_id p_id
global itemType
global cur_mode cur_id cur_bbox cur_nod
global selectnod_id selectnod
global gradation_id gradation
global imageFileMap
global cur_editedp
global canvas_grid cur_zoom
global group itemgroup cur_group_id
set p_list ""
set num [llength $p_id]
if {$num<=1} {return}
foreach id $p_id {
sets {xx yy n} {0 0 0}
foreach {x y} [.c coord $id] {
set xx [expr $xx+$x]
set yy [expr $yy+$y]
incr n
}
set xx [expr $xx/$n]
set yy [expr $yy/$n]
lappend p_list "$id $xx $yy"
}
set p_list [lsort -command propdist_sort $p_list]
set x0 [lindex [lindex $p_list 0] 1]
set y0 [lindex [lindex $p_list 0] 2]
set xn [lindex [lindex $p_list end] 1]
set yn [lindex [lindex $p_list end] 2]
set sx [expr 1.0*($xn-$x0)/($num-1)]
set sy [expr 1.0*($yn-$y0)/($num-1)]
for {set i 1} {$i<$num-1} {incr i} {
sets {id x y} [lindex $p_list $i]
moveItem [expr $x0+$sx*$i-$x] [expr $y0+$sy*$i-$y] id
}
}
proc flipHorizontalItem {{c_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$c_id==""} {return}
set cur_editedp 1
set tmp_id {}
unselectItem c_id
set bbox_all [eval .c bbox $c_id]
set xx [expr [lindex $bbox_all 0]+[lindex $bbox_all 2]]
foreach id $c_id {
switch -regexp $itemType($id) {
"^(text)$" {
sets {x y} [.c coord $id]
set x [expr $xx-$x]
.c coord $id $x $y
}
"^(rect|circle|pixel)$" {
sets {x y x0 y0} [.c coord $id]
set x [expr $xx-$x]
set x0 [expr $xx-$x0]
.c coord $id $x $y $x0 $y0
}
"^(box|boxx|oval|sphere|rod)$" {
sets {x y x0 y0} [.c coord $id]
set x [expr $xx-$x]
set x0 [expr $xx-$x0]
.c coord $id $x $y $x0 $y0
resizeItem id
}
"^(arrow|line|pline|poly|obox|orect)$" {
set coord [.c coord $id]
set f_coord ""
foreach {x y} $coord {
set x [expr $xx-$x]
append f_coord " $x $y"
}
eval .c coord $id $f_coord
}
default {}
}
}
selectItem c_id
}
proc flipVerticalItem {{c_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$c_id==""} {return}
set cur_editedp 1
set tmp_id {}
unselectItem c_id
set bbox_all [eval .c bbox $c_id]
set yy [expr [lindex $bbox_all 1]+[lindex $bbox_all 3]]
foreach id $c_id {
switch -regexp $itemType($id) {
"^(text)$" {
sets {x y} [.c coord $id]
set y [expr $yy-$y]
.c coord $id $x $y
}
"^(rect|circle|pixel)$" {
sets {x y x0 y0} [.c coord $id]
set y [expr $yy-$y]
set y0 [expr $yy-$y0]
.c coord $id $x $y $x0 $y0
}
"^(box|boxx|oval|sphere|rod)$" {
sets {x y x0 y0} [.c coord $id]
set y [expr $yy-$y]
set y0 [expr $yy-$y0]
.c coord $id $x $y $x0 $y0
resizeItem id
}
"^(arrow|line|pline|poly|obox|orect)$" {
set coord [.c coord $id]
set f_coord ""
foreach {x y} $coord {
set y [expr $yy-$y]
append f_coord " $x $y"
}
eval .c coord $id $f_coord
}
default {}
}
}
selectItem c_id
}
proc scaleSizeItem {{ratio} {s_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global cur_scaleratio
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$s_id==""} {return}
if {$ratio=={}} {
set ratio [getValue "Scale Ratio \[X:Y\] or Scale" $cur_scaleratio]
if {$ratio=={}} {return}
set cur_scaleratio $ratio
}
sets {ratio_x ratio_y} [split $ratio ":"]
if {$ratio_y==""} {set ratio_y $ratio_x}
set cur_editedp 1
set tmp_id {}
unselectItem s_id
set bbox_all [eval .c bbox $s_id]
set xc [expr ([lindex $bbox_all 0]+[lindex $bbox_all 2])/2.0]
set yc [expr ([lindex $bbox_all 1]+[lindex $bbox_all 3])/2.0]
set xcr [expr (1-$ratio_x)*$xc]
set ycr [expr (1-$ratio_y)*$yc]
foreach id $s_id {
switch -regexp $itemType($id) {
"^(text)$" {
sets {x y} [.c coord $id]
set x [expr $ratio_x*$x+$xcr]
set y [expr $ratio_y*$y+$ycr]
.c coord $id $x $y
}
"^(rect|circle|pixel|box|boxx|oval|sphere|rod)$" {
sets {x y x0 y0} [.c coord $id]
set x [expr $ratio_x*$x+$xcr]
set y [expr $ratio_y*$y+$ycr]
set x0 [expr $ratio_x*$x0+$xcr]
set y0 [expr $ratio_y*$y0+$ycr]
.c coord $id $x $y $x0 $y0
resizeItem id
}
"^(arrow|line|pline|poly|obox|orect)$" {
set coord [.c coord $id]
set f_coord ""
foreach {x y} $coord {
set x [expr $ratio_x*$x+$xcr]
set y [expr $ratio_y*$y+$ycr]
append f_coord " $x $y"
}
eval .c coord $id $f_coord
}
"^(image)$" {
set tmpfile "/tmp/tmp_tkduke[pid].ppm"
set tmpfile2 "/tmp/tmp_tkduke[pid]a.ppm"
set img_id [lindex [.c itemconfigure $id -image] end]
$img_id write $tmpfile -format ppm
catch [list exec pnmscale -xscale $ratio_x -yscale $ratio_y $tmpfile > $tmpfile2]
$img_id blank
$img_id configure -width 1 -height 1
$img_id configure -width 0 -height 0
$img_id read $tmpfile2 -format ppm
file delete $tmpfile $tmpfile2
}
default {}
}
}
selectItem s_id
}
proc rotateItem {{angle} {s_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global cur_rotateangle
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
global m_pi
if {$s_id==""} {return}
if {$angle=={}} {
set angle [getValue "Rotate Angle" $cur_rotateangle]
if {$angle=={}} {return}
set cur_rotateangle $angle
}
set cur_editedp 1
set tmp_id {}
unselectItem s_id
set bbox_all [eval .c bbox $s_id]
set xc [expr ([lindex $bbox_all 0]+[lindex $bbox_all 2])/2.0]
set yc [expr ([lindex $bbox_all 1]+[lindex $bbox_all 3])/2.0]
set angle [expr -$angle*$m_pi/180]
set ca [expr cos($angle)]
set sa [expr sin($angle)]
foreach id $s_id {
switch -regexp $itemType($id) {
"^(text)$" {
sets {x y} [.c coord $id]
set xx [expr $ca*($x-$xc)-$sa*($y-$yc)+$xc]
set yy [expr $sa*($x-$xc)+$ca*($y-$yc)+$yc]
.c coord $id $xx $yy
}
"^(rect|circle|pixel|box|boxx|oval|sphere|rod)$" {
sets {x y x0 y0} [.c coord $id]
set xx [expr $ca*($x-$xc)-$sa*($y-$yc)+$xc]
set yy [expr $sa*($x-$xc)+$ca*($y-$yc)+$yc]
set xx0 [expr $ca*($x0-$xc)-$sa*($y0-$yc)+$xc]
set yy0 [expr $sa*($x0-$xc)+$ca*($y0-$yc)+$yc]
.c coord $id $xx $yy $xx0 $yy0
resizeItem id
}
"^(arrow|line|pline|poly|obox|orect)$" {
set coord [.c coord $id]
set f_coord ""
foreach {x y} $coord {
set xx [expr $ca*($x-$xc)-$sa*($y-$yc)+$xc]
set yy [expr $sa*($x-$xc)+$ca*($y-$yc)+$yc]
append f_coord " $xx $yy"
}
eval .c coord $id $f_coord
}
default {}
}
}
selectItem s_id
}
proc shearItem {{xshift} {s_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod
global cur_shearxshift
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
global m_pi
if {$s_id==""} {return}
if {$xshift=={}} {
set xshift [getValue "Rotate Angle" $cur_shearxshift]
if {$xshift=={}} {return}
set cur_shearxshift $xshift
}
set cur_editedp 1
set tmp_id {}
unselectItem s_id
sets {x0 y0 x1 y1} [eval .c bbox $s_id]
set ratio [expr 1.0*$xshift/($y0-$y1)]
foreach id $s_id {
switch -regexp $itemType($id) {
"^(text)$" {
sets {x y} [.c coord $id]
set xx [expr $x+($y-$y1)*$ratio]
set yy $y
.c coord $id $xx $yy
}
"^(rect|circle|pixel|box|boxx|oval|sphere|rod)$" {
sets {x y xa ya} [.c coord $id]
set xx [expr $x+($y-$y1)*$ratio]
set yy $y
set xxa [expr $xa+($ya-$y1)*$ratio]
set yya $ya
.c coord $id $xx $yy $xxa $yya
resizeItem id
}
"^(arrow|line|pline|poly|obox|orect)$" {
set coord [.c coord $id]
set f_coord ""
foreach {x y} $coord {
set xx [expr $x+($y-$y1)*$ratio]
set yy $y
append f_coord " $xx $yy"
}
eval .c coord $id $f_coord
}
default {}
}
}
selectItem s_id
}
proc setGrid_getValue {string {init ""}} {
global prompt
set f [toplevel .prompt -borderwidth 10]
message $f.msg -text $string -width 300
entry $f.entry -textvariable prompt(result) -width 5
if {$init!=""} {$f.entry delete 0 end; $f.entry insert 0 $init}
menubutton $f.sel -text "Sel" -relief raised
menu $f.sel.m
foreach v {0 1 2 5 10 20} {
$f.sel.m add command -label $v -command "$f.entry delete 0 end; $f.entry insert 0 $v"
}
set b [frame $f.buttons -bd 10]
$f.sel configure -menu $f.sel.m
button $f.inc -text "+" \
-command "set tmp_v \[expr \[$f.entry get\]+1\]; $f.entry delete 0 end; $f.entry insert 0 \$tmp_v"
button $f.dec -text "-" \
-command "set tmp_v \[expr \[$f.entry get\]-1\]; $f.entry delete 0 end; $f.entry insert 0 \$tmp_v"
grid $f.msg -columnspan 4
grid $f.entry $f.inc $f.dec $f.sel
grid $f.buttons -sticky ew -columnspan 4
button $b.ok -text OK \
-command {set prompt(ok) 1} -underline 0
button $b.cancel -text Cancel \
-command {set prompt(ok) 0} -underline 0
grid $b.ok $b.cancel
# ¥Ð¥¤¥ó¥É¤òÀßÄꤹ¤ë
foreach w [list $f.entry $b.ok $b.cancel] {
bindtags $w [list .prompt [winfo class $w] $w all]
}
bind .prompt <Alt-o> "focus $b.ok; break"
bind .prompt <Alt-c> "focus $b.cancel; break"
bind .prompt <Alt-Key> break
bind .prompt <Return> {set prompt(ok) 1}
bind .prompt <Control-c> {set prompt(ok) 0}
bind .prompt <Control-q> {set prompt(ok) 0}
bind .prompt <Key-Escape> {set prompt(ok) 0}
focus $f.entry
grab $f
tkwait variable prompt(ok)
grab release $f
destroy $f
if {$prompt(ok)} {
return $prompt(result)
} else {
return {}
}
}
proc setGrid {{grid ""}} {
global canvas_grid cur_gridshow
if {$grid=={}} {
set grid [setGrid_getValue "Canvas Grid" $canvas_grid]
if {$grid<0 || $grid=={}} {return}
}
set canvas_grid $grid
if {$cur_gridshow} {makeGridLine}
}
proc makeGridLine {} {
global canvas_grid grid_unit cur_zoom cur_gridshow
global width height
.c delete grid
if {!$cur_gridshow} {return}
set grid $canvas_grid
sets {w h} [list [expr $width*$cur_zoom] [expr $height*$cur_zoom]]
switch $grid {
0 {set grid 5}
1 {set grid 5}
2 {set grid 8}
3 {set grid 6}
4 {set grid 8}
}
set grid [expr $grid*$grid_unit]
set i 0
for {set x 0} {$x<$width} {set x [expr $x+$grid]} {
if {[expr fmod($i, 5)]==0} {set col gray80} else {set col gray90}
.c lower [.c create line [expr $x*$cur_zoom] 0 [expr $x*$cur_zoom] $h \
-fill $col -tag grid]
incr i
}
set i 0
for {set y 0} {$y<$height} {set y [expr $y+$grid]} {
if {[expr fmod($i, 5)]==0} {set col gray80} else {set col gray90}
.c lower [.c create line 0 [expr $y*$cur_zoom] $w [expr $y*$cur_zoom] \
-fill $col -tag grid]
incr i
}
}
proc toggleClosePline {{p_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$p_id==""} {return}
set cur_editedp 1
foreach id $p_id {
switch -regexp -- $itemType($id) {
"^(arrow|line|pline)$" {
set coord [.c coord $id]
set n [llength $coord]
if {$n<3} {continue}
sets {x0 y0} $coord
set x1 [lindex $coord [expr $n-2]]
set y1 [lindex $coord [expr $n-1]]
if {$x0!=$x1 && $y0!=$y1} {
eval .c coord $id $coord $x0 $y0
} else {
eval .c coord $id [lrange $coord 0 [expr $n-3]]
}
}
default {}
}
}
}
proc toggleItem {{p_id}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow cur_col
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$p_id==""} {return}
set cur_editedp 1
set td_id ""
unselectItem p_id
set tmp_col $cur_col
foreach id $p_id {
set type ""
set smooth ""
switch -- $itemType($id) {
"rect" {set type "orect" }
"orect" {set type "box" }
"box" {set type "obox" }
"obox" {set type "boxx" }
"boxx" {set type "circle"}
"circle" {set type "oval" }
"oval" {set type "sphere"}
"sphere" {set type "rect" }
"arrow" {
set smooth [get_smooth .c $id]
set type "line"
}
"line" {
set smooth [get_smooth .c $id]
set type "arrow"
}
"pline" {
set smooth [get_smooth .c $id]
set type "poly"
}
"poly" {
set smooth [get_smooth .c $id]
set type "pline"
}
"rod" {set type "line" }
default {puts "unknown Type"}
}
if {$type!=""} {
set opt ""
set cur_type $itemType($id)
set coord [getLineCoord $id]
if {$type=="orect" || $type=="obox"} {
set coord "[lindex $coord 2] [lindex $coord 3] [lindex $coord 0] [lindex $coord 1]"
}
if {$cur_type=="rect" || $cur_type=="circle"} {
setColor [.c itemcget $id -outline]
} else {
setColor [.c itemcget $id -fill]
}
deleteItem $id
if {$smooth!=""} {
append opt " -smooth $smooth"
}
lappend td_id [eval makeItem $type $opt [list $coord]]
} else {
lappend td_id $id
}
}
setColor [makeColorString $tmp_col]
selectItem td_id
}
proc toggleItemAnchor {{t_id}} {
global cur_itemanchor
if {$t_id==""} {return}
set type $cur_itemanchor
set cur_editedp 1
switch $type {
"se" {set type "s"}
"s" {set type "sw"}
"sw" {set type "e"}
"e" {set type "c"}
"c" {set type "w"}
"w" {set type "ne"}
"ne" {set type "n"}
"n" {set type "nw"}
"nw" {set type "se"}
default {set type "c"}
}
setItemAnchor $t_id $type
set cur_itemanchor $type
}
proc setItemAnchor {{p_id} {type "w"}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$p_id==""} {return}
set cur_editedp 1
sets {max_xx max_yy} [lrange [.c coord [lindex $p_id 0]] 0 1]
sets {min_xx min_yy} [list $max_xx $max_yy]
foreach id $p_id {
foreach {x y} [.c coord $id] {
if {$max_xx<$x} {set max_xx $x}
if {$min_xx>$x} {set min_xx $x}
if {$max_yy<$y} {set max_yy $y}
if {$min_yy>$y} {set min_yy $y}
}
}
set tmp_id $cur_id
unselectItem tmp_id
foreach id $p_id {
set coord [eval .c coord $id]
sets {maxx maxy} [lrange $coord 0 1]
sets {minx miny} [list $maxx $maxy]
foreach {x y} $coord {
if {$maxx<$x} {set maxx $x}
if {$minx>$x} {set minx $x}
if {$maxy<$y} {set maxy $y}
if {$miny>$y} {set miny $y}
}
set new_coord ""
sets {sx sy} {0 0}
switch $type {
"t" {set sy [expr $min_yy-$miny]}
"b" {set sy [expr $max_yy-$maxy]}
"r" {set sx [expr $max_xx-$maxx]}
"l" {set sx [expr $min_xx-$minx]}
"ne" {set sy [expr $min_yy-$miny]; set sx [expr $max_xx-$maxx]}
"n" {set sy [expr $min_yy-$miny]; set sx [expr (($max_xx+$min_xx)-($maxx-$minx))/2.0-$minx]}
"nw" {set sy [expr $min_yy-$miny]; set sx [expr $min_xx-$minx]}
"se" {set sy [expr $max_yy-$maxy]; set sx [expr $max_xx-$maxx]}
"s" {set sy [expr $max_yy-$maxy]; set sx [expr (($max_xx+$min_xx)-($maxx-$minx))/2.0-$minx]}
"sw" {set sy [expr $max_yy-$maxy]; set sx [expr $min_xx-$minx]}
"e" {set sy [expr (($max_yy+$min_yy)-($maxy-$miny))/2.0-$miny]; set sx [expr $max_xx-$maxx]}
"w" {set sy [expr (($max_yy+$min_yy)-($maxy-$miny))/2.0-$miny]; set sx [expr $min_xx-$minx]}
"c" {set sx [expr (($max_xx+$min_xx)-($maxx-$minx))/2.0-$minx]}
"m" {set sy [expr (($max_yy+$min_yy)-($maxy-$miny))/2.0-$miny]}
}
foreach {x y} $coord {
sets {x y} [list [expr $x+$sx] [expr $y+$sy]]
append new_coord " $x $y"
}
eval .c coord $id $new_coord
}
selectItem tmp_id
}
proc setLineCap {{type "butt"} {t_id}} {
global itemType
if {$t_id==""} {return}
foreach id $t_id {
switch -regexp $itemType($id) {
"^(line|arrow|pline)$" {
.c itemconfigure $id -capstyle $type
}
}
}
}
proc cmpAbut {a b n} {
set aa [lindex $a $n]
set bb [lindex $b $n]
if {$aa>$bb} {return 1} \
elseif {$aa<$bb} {return -1} \
else {return 0}
}
proc abutItem {{p_id} {type "h"}} {
global itemType
global cur_mode cur_id cur_bbox cur_nod cur_smooth cur_arrow
global selectnod_id selectnod
global gradation_id gradation
global cur_editedp
if {$p_id==""} {return}
set cur_editedp 1
set tmp_id ""
foreach id $p_id {
sets {max_x max_y} [.c coord $id]
sets {min_x min_y} [list $max_x $max_y]
foreach {x y} [.c coord $id] {
if {$max_x<$x} {set max_x $x}
if {$min_x>$x} {set min_x $x}
if {$max_y<$y} {set max_y $y}
if {$min_y>$y} {set min_y $y}
}
lappend tmp_id "$id $max_x $min_x $max_y $min_y"
}
if {$type=="h"} {
set n 2
} else {
set n 4
}
set tmp_id "[lsort -increasing -real -index $n $tmp_id]"
sets {id0 x1 x0 y1 y0} [lindex $tmp_id 0]
unselectItem p_id
foreach tmp $tmp_id {
sets {id max_x min_x max_y min_y} $tmp
sets {sx sy} {0 0}
if {$type=="h"} {
set sx [expr $x0-$min_x]
} else {
set sy [expr $y0-$min_y]
}
set coord ""
foreach {x y} [.c coord $id] {
sets {x y} [list [expr $x+$sx] [expr $y+$sy]]
append coord " $x $y"
}
eval .c coord $id $coord
sets {x0 y0} [list [expr $max_x+$sx] [expr $max_y+$sy]]
}
selectItem p_id
}
proc blendItem {{c_id} {step ""}} {
global itemType
global cur_blendstep
if {$c_id==""} {return}
if {[llength $c_id]!=2} {
puts "Blend must apply to same two items."
return
}
set cur_editedp 1
if {$step=={}} {
set step [getValue "Blend Step" $cur_blendstep]
if {$step=={}} {return}
set cur_blendstep $step
}
sets {id_a id_b} $c_id
if {$itemType($id_a)!=$itemType($id_b)} {
puts "Blend must apply to same two items."
return
}
sets {coord_a coord_b} [list [getLineCoord $id_a] [getLineCoord $id_b]]
set colopt fill
set smtopt 0
switch -regexp $itemType($id_a) {
"circle|rect" {set colopt "outline"}
"line|pline|fline|poly|arrow" {
set smtopt [get_smooth .c $id_a]
}
}
sets {r_a g_a b_a} [winfo rgb . [.c itemcget $id_a -$colopt]]
sets {r_b g_b b_b} [winfo rgb . [.c itemcget $id_b -$colopt]]
set sr [expr 1.0*($r_b-$r_a)/255/($step+1)]
set sg [expr 1.0*($g_b-$g_a)/255/($step+1)]
set sb [expr 1.0*($b_b-$b_a)/255/($step+1)]
sets {r g b} [list [expr $r_a/255] [expr $g_a/255] [expr $b_a/255]]
set coord_num [llength $coord_a]
for {set i 1} {$i<=$step} {incr i} {
set new_coord ""
for {set j 0} {$j<$coord_num} {incr j 2} {
sets {x_a y_a} [lrange $coord_a [expr $j] [expr $j+1]]
sets {x_b y_b} [lrange $coord_b [expr $j] [expr $j+1]]
set sx [expr 1.0*($x_b-$x_a)/($step+1)*$i]
set sy [expr 1.0*($y_b-$y_a)/($step+1)*$i]
sets {x y} [list [expr $x_a+$sx] [expr $y_a+$sy]]
append new_coord " $x $y"
}
sets {r g b} [list [expr int($r+$sr)] [expr int($g+$sg)] [expr int($b+$sb)]]
if {$r>255} {set r 255}
if {$g>255} {set g 255}
if {$b>255} {set b 255}
set coord $new_coord
makeItem $itemType($id_a) \
-fill [format "#%02x%02x%02x" $r $g $b] \
-smooth $smtopt \
$coord
}
}
############################################################
#
proc makeItem {{type} args} {
global itemType
global cur_mode cur_id cur_col cur_smooth cur_arrow cur_arrowshape
global cur_stipple
global cur_textanchor cur_textjustify
global cur_zoom
global selectnod_id selectnod
global gradation_id gradation
global nod_dupinfo
global font fontface fontsize fontsizeId cur_linewidth linecap rodwidth
global cur_layer layer_id
global col_rand
global cur_editedp
global font
set anchor "center"
set smooth $cur_smooth
set justify $cur_textjustify
set linewidth $cur_linewidth
set arrowshape [list $cur_arrowshape]
set capstyle $linecap
set joinstyle "round"
if {$fontface=="gh"} {
set fontfacesize "Gothic:Helvetica-Bold-$fontsize"
} else {
set fontfacesize "Mincho:Times-Roman-$fontsize"
}
set file ""
switch $type {
"arrow" {set arrow $cur_arrow}
"text" {set anchor $cur_textanchor; set justify $cur_textjustify}
"default" {set arrow none}
}
set obj_col ""
#puts "makeItem type:$type args:$args"
while {1} {
switch -- [lindex $args 0] {
"-fill" {
set obj_col [lindex $args 1]
set args [lreplace $args 0 1]
}
"-outline" {
set obj_col [lindex $args 1]
set args [lreplace $args 0 1]
}
"-anchor" {
set anchor [lindex $args 1]
set args [lreplace $args 0 1]
}
"-justify" {
set justify [lindex $args 1]
set args [lreplace $args 0 1]
}
"-smooth" {
set smooth [lindex $args 1]
set args [lreplace $args 0 1]
}
"-splinesteps" {
set spliesteps [lindex $args 1]
set args [lreplace $args 0 1]
}
"-stipple" {
set stipple [lindex $args 1]
set args [lreplace $args 0 1]
}
"-tags" {
set stipple [lindex $args 1]
set args [lreplace $args 0 1]
}
"-arrow" {
set arrow [lindex $args 1]
set args [lreplace $args 0 1]
}
"-arrowshape" {
set arrowshape [list [lindex $args 1]]
set args [lreplace $args 0 1]
}
"-capstyle" {
set capstyle [lindex $args 1]
set args [lreplace $args 0 1]
}
"-joinstyle" {
set joinstyle [lindex $args 1]
set args [lreplace $args 0 1]
}
"-width" {
switch -regexp $type {
"rod" {set rodwidth [lindex $args 1]}
default {set linewidth [lindex $args 1]}
}
set args [lreplace $args 0 1]
}
"-font" {
set fontfacesize [lindex $args 1]
set args [lreplace $args 0 1]
}
"-file" {
set file [lindex $args 1]
set args [lreplace $args 0 1]
}
default {
break
}
}
}
if {$obj_col==""} {
sets {color col_r col_g col_b} $cur_col
set obj_col [format "#%02x%02x%02x" \
[expr int($color*$col_r)] \
[expr int($color*$col_g)] \
[expr int($color*$col_b)]]
}
set bbox [lindex $args end]
sets {x y x0 y0} $bbox
set cur_editedp 1
.c delete $cur_id
set cur_id ""
set m_id ""
if {$col_rand} {randomColor}
switch -regexp $type {
"^(text)$" {
set val [.text.e get 0.0 "end-1chars"]
regsub "\n+$" $val "" val
set size $fontsize
set face $fontface
if {[regexp "^Gothic:Helvetica-Bold-(\[0-9\]+)" \
$fontfacesize null size]} {
set face "gh"
} elseif {[regexp "^Mincho:Times-Roman-(\[0-9\]+)" \
$fontfacesize null size]} {
set face "mt"
}
if {0} {
set tmp_size $size
} else {
set tmp_size [expr int($size*$cur_zoom)]
}
if {[info exists font($face:$tmp_size)]==0} {
loadFont $tmp_size $face
}
set m_id [eval .c create text $x $y -text [list $val] \
-font $font($face:$tmp_size) \
-anchor $anchor -justify $justify \
-stipple $cur_stipple]
set fontsizeId($m_id) $size
if {$obj_col!=""} {.c itemconfigure $m_id -fill $obj_col}
set itemType($m_id) "text"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
if {$val==""} {
editText .c $x $y $m_id
}
}
"^(rect)$" {
if {$x0==$x || $y0==$y} {return}
set m_id [eval .c create rectangle $bbox \
-width $linewidth -outline $obj_col \
-stipple $cur_stipple]
set itemType($m_id) "rect"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(orect)$" {
if {$x0==$x || $y0==$y} {return}
set d [expr 20*$cur_zoom]
sets {x y x0 y0} $bbox
sets {xa ya x0a y0a} \
[list [expr $x-$d] [expr $y-$d] \
[expr $x0+$d] [expr $y0+$d]]
set m_id [.c create line \
$x0 $y0a $x0 $y0 $x0a $y0 \
$xa $y0 $x $y0 $x $y0a \
$x $ya $x $y $xa $y \
$x0a $y $x0 $y $x0 $ya \
$x0 $y0a \
-width $linewidth \
-fill $obj_col \
-smooth 1]
set itemType($m_id) "orect"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(box)$" {
if {$x0==$x || $y0==$y} {return}
set m_id [eval .c create rectangle $bbox \
-fill $obj_col -outline $obj_col \
-stipple $cur_stipple]
set itemType($m_id) "box"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(obox)$" {
if {$x0==$x || $y0==$y} {return}
set d [expr 20*$cur_zoom]
sets {x y x0 y0} $bbox
sets {xa ya x0a y0a} \
[list [expr $x-$d] [expr $y-$d] \
[expr $x0+$d] [expr $y0+$d]]
set m_id [.c create poly \
$x0 $y0a $x0 $y0 $x0a $y0 \
$xa $y0 $x $y0 $x $y0a \
$x $ya $x $y $xa $y \
$x0a $y $x0 $y $x0 $ya \
$x0 $y0a \
-fill $obj_col -outline $obj_col \
-smooth 1]
set itemType($m_id) "obox"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(boxx)$" {
if {$x0==$x || $y0==$y} {return}
if {$obj_col!=""} {
set color 255
sets {col_r col_g col_b} [winfo rgb . $obj_col]
sets {col_r col_g col_b} [list \
[expr 1.0*$col_r/0xffff] \
[expr 1.0*$col_g/0xffff] \
[expr 1.0*$col_b/0xffff]]
} else {
sets {color col_r col_g col_b} $cur_col
}
set m_id [eval .c create rectangle $bbox \
-fill [format "#%02x%02x%02x" \
[expr int($color*$col_r)] \
[expr int($color*$col_g)] \
[expr int($color*$col_b)]] \
-stipple $cur_stipple]
set itemType($m_id) "boxx"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
set im 30
for {set i 0} {$i<$im} {incr i} {
set color [expr int(log($i+1)/log($im)*155+100)]
set color [format "#%02x%02x%02x" [expr int($color*$col_r)] [expr int($color*$col_g)] [expr int($color*$col_b)]]
sets {w h} [list [expr $x-$x0] [expr $y-$y0]]
set id [eval .c create rectangle $x0 $y0 $x $y \
-fill $color -outline $color \
-stipple $cur_stipple]
lappend gradation_id($m_id) $id
set gradation($id) $m_id
sets {x0 x} [list [expr $x0+$w*.08] [expr $x-$w*.03]]
}
}
"^(circle)$" {
if {$x0==$x || $y0==$y} {return}
if {$obj_col!=""} {
set color $obj_col
} else {
set color "black"
}
set m_id [eval .c create oval $bbox \
-width $linewidth -outline $color \
-stipple $cur_stipple]
set itemType($m_id) "circle"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(oval)$" {
if {$x0==$x || $y0==$y} {return}
if {$obj_col!=""} {
set color $obj_col
} else {
sets {color col_r col_g col_b} $cur_col
set color [format "#%02x%02x%02x" [expr int($color*$col_r)] [expr int($color*$col_g)] [expr int($color*$col_b)]]
}
set m_id [eval .c create oval $bbox \
-fill $color -outline $color \
-stipple $cur_stipple]
set itemType($m_id) "oval"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(sphere)$" {
if {$x0==$x || $y0==$y} {return}
if {$obj_col!=""} {
set color 255
sets {col_r col_g col_b} [winfo rgb . $obj_col]
sets {col_r col_g col_b} [list \
[expr 1.0*$col_r/0xffff] \
[expr 1.0*$col_g/0xffff] \
[expr 1.0*$col_b/0xffff]]
} else {
sets {color col_r col_g col_b} $cur_col
}
set m_id [eval .c create oval $bbox -outline {{}} \
-fill [format "#%02x%02x%02x" \
[expr int($color*$col_r)] \
[expr int($color*$col_g)] \
[expr int($color*$col_b)]] \
-stipple $cur_stipple]
set itemType($m_id) "sphere"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
sets {x0 y0 x1 y1} [.c coord $m_id]
set im 50
for {set i 0} {$i<$im} {incr i} {
set color [expr int(log($i+1)/log($im)*(0xfff-100)+100)]
set color [format "#%03x%03x%03x" [expr int($color*$col_r)] [expr int($color*$col_g)] [expr int($color*$col_b)]]
set id [eval .c create oval $x0 $y0 $x1 $y1 \
-fill $color -outline {{}} \
-stipple $cur_stipple]
lappend gradation_id($m_id) $id
set gradation($id) $m_id
sets {w h} [list [expr $x1-$x0] [expr $y1-$y0]]
sets {x0 y0 x1 y1} \
[list [expr $x0+$w*1.45/$im] \
[expr $y0+$h*.725/$im] \
[expr $x1-$w*.725/$im] \
[expr $y1-$h*1.45/$im]]
}
}
"^(arrow)$" {
if {$x0==$x && $y0==$y} {return}
if {$obj_col!=""} {
set color $obj_col
} else {
set color "black"
}
set m_id [eval .c create line $bbox \
-arrow $arrow -width $linewidth -arrowshape $arrowshape \
-capstyle $capstyle -fill $color -smooth $smooth \
-stipple $cur_stipple]
set itemType($m_id) "arrow"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(line)$" {
if {$x0==$x && $y0==$y} {return}
if {$obj_col!=""} {
set color $obj_col
} else {
set color "black"
}
set m_id [eval .c create line $bbox \
-width $linewidth -arrowshape $arrowshape -arrow $arrow \
-capstyle $capstyle -fill $color -smooth $smooth \
-stipple $cur_stipple]
set itemType($m_id) "line"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(pline|fline)$" {
if {$obj_col!=""} {
set color $obj_col
} else {
sets {color col_r col_g col_b} $cur_col
set color [format "#%02x%02x%02x" [expr int($color*$col_r)] [expr int($color*$col_g)] [expr int($color*$col_b)]]
}
set m_id [eval .c create line $bbox \
-width $linewidth -arrow $arrow -arrowshape $arrowshape \
-capstyle $capstyle -fill $color -smooth $smooth \
-stipple $cur_stipple]
set itemType($m_id) "pline"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(poly)$" {
if {$obj_col!=""} {
set color $obj_col
} else {
sets {color col_r col_g col_b} $cur_col
set color [format "#%02x%02x%02x" [expr int($color*$col_r)] [expr int($color*$col_g)] [expr int($color*$col_b)]]
}
set m_id [eval .c create polygon $bbox \
-width $linewidth -fill $color -smooth $smooth \
-stipple $cur_stipple]
set itemType($m_id) "poly"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(rod)$" {
if {$x0==$x && $y0==$y} {return}
if {$obj_col!=""} {
set color 255
sets {col_r col_g col_b} [winfo rgb . $obj_col]
sets {col_r col_g col_b} [list \
[expr 1.0*$col_r/0xffff] \
[expr 1.0*$col_g/0xffff] \
[expr 1.0*$col_b/0xffff]]
} else {
sets {color col_r col_g col_b} $cur_col
}
if {$rodwidth<=2} {set rodwidth 4}
set m_id [eval .c create line $bbox -width $rodwidth \
-fill [format "#%02x%02x%02x" \
[expr int($color*$col_r)] \
[expr int($color*$col_g)] \
[expr int($color*$col_b)]] \
-stipple $cur_stipple]
set itemType($m_id) "rod"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
sets {x0 y0 x1 y1} [.c coord $m_id]
sets {w h} [list [expr $x1-$x0] [expr $y1-$y0]]
if {$w==0 || $h==0} {
set d 1
} else {
set d [expr $h/$w]
}
set im $rodwidth
for {set i 0} {$i<$im} {incr i} {
if {$d<0} {
set ii [expr $i]
} else {
set ii [expr $im-$i]
}
if {$ii<($im*.7)} {
set color [expr int(log($ii+1)/log(($im+1)*.7)*155+100)]
} else {
set color [expr int(log(($ii-($ii-($im*.7))*2)-1)/log($im*.7)*155+100)]
}
set color [format "#%02x%02x%02x" [expr int($color*$col_r)] [expr int($color*$col_g)] [expr int($color*$col_b)]]
set ww [expr $i-$im/2]
if {$d==1 && $w==0} {
set xx0 [expr $x0+$ww]
set yy0 $y0
set xx1 [expr $x1+$ww]
set yy1 $y1
} elseif {$d==1 && $h==0} {
set xx0 $x0
set yy0 [expr $y0+$ww]
set xx1 $x1
set yy1 [expr $y1+$ww]
} elseif {$d>1 || $d<-1} {
set xx0 [expr $x0+$ww]
set yy0 [expr -$ww/$d+$y0]
set xx1 [expr $x1+$ww]
set yy1 [expr -$ww/$d+$y1]
} else {
set yy0 [expr $y0+$ww]
set xx0 [expr -$ww*$d+$x0]
set yy1 [expr $y1+$ww]
set xx1 [expr -$ww*$d+$x1]
}
set id [.c create line $xx0 $yy0 $xx1 $yy1 \
-fill $color -width 2]
lappend gradation_id($m_id) $id
set gradation($id) $m_id
set nod_dupinfo($m_id) ""
}
}
"^(pixel)$" {
if {$obj_col!=""} {
set color $obj_col
} else {
set color "black"
}
set m_id [eval .c create line $x $y [expr $x+1] $y \
-fill $color -stipple $cur_stipple]
set itemType($m_id) "pixel"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
"^(image)$" {
set x [lindex $args 0]
set y [lindex $args 1]
if {![file exists $file]} {
} else {
set img_id [createImage $file]
set m_id [eval .c create image $x $y \
-image $img_id]
set itemType($m_id) "image"
set gradation_id($m_id) {}
set nod_dupinfo($m_id) ""
}
}
default {puts "Error: unknown mode specified.: $type $x $y"}
}
# ½ÅʣĺÅÀ¡Ê¥¹¥×¥é¥¤¥ó½ü³°ÅÀ¡Ë¤Î½èÍý
sets {x y} {{} {}}
set i 0
foreach {xx yy} $bbox {
if {$xx==$x && $yy==$y} {
lappend nod_dupinfo($m_id) [expr $i-1]
sets {x y} {{} {}}
} else {
sets {x y} "$xx $yy"
incr i
}
}
if {[llength $m_id]>0} {
set layer_id($m_id) $cur_layer
return $m_id
} else {
return ""
}
}
proc resizeItem {{resize_id}} {
# ¥Ù¡¼¥¹¥¢¥¤¥Æ¥à¤Î¥ê¥µ¥¤¥º¤Ë¹ç¤ï¤»¤Æ¥°¥é¥Ç¡¼¥·¥ç¥ó¤Ê¤É¤òÉÁ¤´¹¤¨¤ë
upvar $resize_id r_id
global itemType
global cur_mode cur_id cur_col cur_zoom
global selectnod_id selectnod
global gradation_id gradation
global rodwidth
set bbox [.c bbox $r_id]
set x0 [lindex $bbox 0]
set y0 [lindex $bbox 1]
set x [lindex $bbox 2]
set y [lindex $bbox 3]
switch -regexp $itemType($r_id) {
"^(text)$" {
}
"^(rect|orect|box|obox|oval|circle|arrow|line|pline|poly)$" {
}
"^(boxx)$" {
if {$x0==$x || $y0==$y} return
sets {x0 y0 x y} [.c coord $r_id]
set im 30
for {set i 0} {$i<$im} {incr i} {
.c coord [lindex $gradation_id($r_id) $i] \
$x0 $y0 $x $y
set w [expr $x-$x0]
set h [expr $y-$y0]
set x0 [expr $x0+$w*.08]
#set y0 [expr $y0+$h*.08]
set x [expr $x-$w*.03]
#set y [expr $y-$h*.03]
}
}
"^(sphere)$" {
if {$x0==$x || $y0==$y} return
set coord [.c coord $r_id]
set x0 [lindex $coord 0]
set y0 [lindex $coord 1]
set x1 [lindex $coord 2]
set y1 [lindex $coord 3]
set im 50
for {set i 0} {$i<$im} {incr i} {
.c coord [lindex $gradation_id($r_id) $i] $x0 $y0 $x1 $y1
set w [expr $x1-$x0]
set h [expr $y1-$y0]
set x0 [expr $x0+$w*1.45/$im]
set y0 [expr $y0+$h*.725/$im]
set x1 [expr $x1-$w*.725/$im]
set y1 [expr $y1-$h*1.45/$im]
}
}
"^(rod)$" {
if {$x0==$x && $y0==$y} return
set coord [.c coord $r_id]
set x0 [lindex $coord 0]
set y0 [lindex $coord 1]
set x1 [lindex $coord 2]
set y1 [lindex $coord 3]
set w [expr $x1-$x0]
set h [expr $y1-$y0]
if {$w==0 || $h==0} {
set d 1
} else {
set d [expr $h/$w]
}
set im $rodwidth
for {set i 0} {$i<$im} {incr i} {
set ww [expr $i-$im/2]
if {$d==1 && $w==0} {
set xx0 [expr $x0+$ww]
set yy0 $y0
set xx1 [expr $x1+$ww]
set yy1 $y1
} elseif {$d==1 && $h==0} {
set xx0 $x0
set yy0 [expr $y0+$ww]
set xx1 $x1
set yy1 [expr $y1+$ww]
} elseif {$d>1 || $d<-1} {
set xx0 [expr $x0+$ww]
set yy0 [expr -$ww/$d+$y0]
set xx1 [expr $x1+$ww]
set yy1 [expr -$ww/$d+$y1]
} else {
set yy0 [expr $y0+$ww]
set xx0 [expr -$ww*$d+$x0]
set yy1 [expr $y1+$ww]
set xx1 [expr -$ww*$d+$x1]
}
.c coord [lindex $gradation_id($r_id) $i] $xx0 $yy0 $xx1 $yy1
}
}
"^(pixel)$" return
"^(image)$" return
default {puts "Error: unknown mode specified.: $itemType($r_id) $x $y"}
}
if {[llength $r_id]} {
#puts "$r_id:$itemType($r_id)"
return $r_id
}
}
############################################################
#
proc printCanvas {{fname}} {
global cur_id cur_paporient cur_gridshow cur_zoom
global fmap
global width height
set retvalue 0
set tmp_id $cur_id
unselectItem tmp_id
sets {viewx viewy} [list [.c xview] [.c yview]]
set tmp_zoom $cur_zoom
if {$cur_zoom!=1} {changeZoom 1}
set tmp_gridshow $cur_gridshow
if {$cur_gridshow} {set cur_gridshow 0; makeGridLine}
set bbox [.c bbox all]
if {$bbox!=""} {
set x [lindex $bbox 0]
set y [lindex $bbox 1]
set w [expr [lindex $bbox 2]-$x]
set h [expr [lindex $bbox 3]-$y]
set pad 5
if {$w+$pad*2<$width && $h+$pad*2<$height} {
incr x -$pad
incr y -$pad
incr w [expr $pad*2]
incr h [expr $pad*2]
}
if {$cur_paporient=="landscape"} {
set rotate true
set pagex [expr $y*.96]
set pagey [expr $x*.96]
} else {
set rotate false
set pagex [expr $x*.96]
set pagey [expr ($height-$y)*.96]
}
.c postscript \
-file $fname -width $w -height $h -x $x -y $y \
-pagewidth [expr 0.9596*$w] -pageheight [expr 0.9596*$h] \
-colormode color -fontmap fmap \
-rotate $rotate \
-pageanchor nw -pagex $pagex -pagey $pagey
set retvalue 1
}
selectItem tmp_id
if {$tmp_gridshow} {set cur_gridshow $tmp_gridshow; makeGridLine}
if {$tmp_zoom!=1} {changeZoom $tmp_zoom}
.c xview moveto [lindex $viewx 0]
.c yview moveto [lindex $viewy 0]
makeGridLine
if {!$retvalue} {
tk_dialog .notice "Print Error" "No printing items." warning 0 ok
}
return $retvalue
}
proc fileDialog_old {} {
global cur_id
set t .fd
toplevel $t
wm title $t "tkduke"
wm iconname $t "tkduke"
label $t.l -text "Open File"
entry $t.e
bind $t.e <Key-Return> "\
selectItemAll; deleteItem $cur_id;\
loadFile \[$t.e get\];\
destroy $t"
bind $t.e <Control-c> "destroy $t"
bind $t.e <Control-q> "destroy $t"
button $t.ok -text "OK" -command "\
selectItemAll; deleteItem $cur_id;\
loadFile \[$t.e get\];\
destroy $t"
button $t.canc -text "Cancel" -command "destroy $t"
pack $t.l $t.e -side top
pack $t.ok $t.canc -side left
}
proc getPreviewImage {{fname}} {
set fd [open "$fname" "r"]
set preview 0
while {![eof $fd]} {
gets $fd str
if {[regexp "^#|^ *$" $str]==-1} {
break
} elseif {[regexp "# *preview:" $str]} {
set preview 1
break
}
}
set gif ""
set id -1
if {$preview} {
while {![eof $fd]} {
gets $fd str
if {[regexp "# .+" $str]==-1} {
break
}
regsub "^# " $str "" str
append gif $str
}
}
close $fd
if {$gif!=""} {set id [image create photo -format gif -data $gif]}
return $id
}
proc fileBrowser {} {
global cur_importdir cur_filename
set t .fdw
toplevel $t
$t configure -background white
wm title $t "Tkduke: File Browser"
set c $t.c
canvas $c -width 200 -height 400 -background white \
-xscrollcommand "$t.x set" -yscrollcommand "$t.y set"
scrollbar $t.y -command "$c yview"
scrollbar $t.x -command "$c xview" -orient horizontal
button $t.close -image hide_icon -command "destroy $t"
bind $t <Control-q> "destroy $t"
bind $t <Control-w> "destroy $t"
grid $t.close -columnspan 2 -sticky nes
grid $c $t.y -sticky news
grid $t.x -sticky news
grid rowconfigure $t 1 -weight 1
grid columnconfigure $t 0 -weight 1
sets {x y} {100 10}
set margin 3
set width 0
foreach f [lsort [glob -nocomplain $cur_importdir/*.mmp]] {
set img_id [getPreviewImage $f]
if {0} {
set img_id [image create photo -format gif]
$img_id copy $img_id_src -zoom 2 2
}
if {$img_id!=-1} {
set id [$c create image $x $y -image $img_id -anchor ne]
$c bind $id <Enter> "$c configure -cursor hand2"
$c bind $id <Leave> "$c configure -cursor left_ptr"
$c bind $id <Double-Button-1> "loadFile $f"
sets {x0 y0 x1 y1} [$c bbox $id]
set id [$c create text [expr $x+$margin] $y1 -text $f -anchor sw]
$c bind $id <Enter> "$c configure -cursor hand2"
$c bind $id <Leave> "$c configure -cursor left_ptr"
$c bind $id <Double-Button-1> "loadFile $f"
set y [expr $y1+$margin]
set x1 [lindex [$c bbox $id] 2]
if {$width<$x1} {set width $x1}
} else {
set y [expr $y+$margin]
$c create line [expr $x-20] $y $x $y -width 1 -fill gray
set id [$c create text [expr $x+$margin] $y -text $f -anchor w]
$c bind $id <Enter> "$c configure -cursor hand2"
$c bind $id <Leave> "$c configure -cursor left_ptr"
$c bind $id <Double-Button-1> "loadFile $f"
set x1 [lindex [$c bbox $id] 2]
set y1 [lindex [$c bbox $id] 3]
set y [expr $y1+$margin]
if {$width<$x1} {set width $x1}
}
$c configure -scrollregion "0 0 $width $y"
update idletasks
}
}
proc fileDialog {{proc} {mess} {type Open}} {
global cur_importdir
set tmp [tk_get${type}File \
-title "tkduke: $mess" \
-initialdir $cur_importdir \
-filetypes {{MMP {.mmp}} {ALL {*}}}]
if {$tmp != ""} {$proc $tmp}
}
proc textfileDialog {{proc} {mess} {type Open}} {
global cur_importdir
global cur_importtext
set tmp [tk_get${type}File \
-title "tkduke: $mess" \
-initialdir $cur_importdir \
-filetypes {{TXT {.txt .text}} {ALL {*}}}]
if {$tmp != ""} {$proc $tmp $cur_importtext}
}
proc imagefileDialog {{proc} {mess} {type Open}} {
global cur_importdir tmp_img
if {0} {
set tmp [tk_get${type}File \
-title "tkduke: $mess" \
-initialdir $cur_importdir \
-filetypes {{GIF/JPEG {.gif .jpeg .jpg .GIF .JPEG .JPG}} {PNM {.pbm .pnm .ppm}} {ALL {*}}}]
} else {
toplevel .tmp_img
listbox .tmp_img.l -yscrollcommand {.tmp_img.ly set}
scrollbar .tmp_img.ly -command {.tmp_img.l yview}
foreach f [lsort [glob *.gif *.jpeg *.jpg]] {
.tmp_img.l insert end $f
}
button .tmp_img.ok -text OK -command {set tmp_img [.tmp_img.l get [.tmp_img.l curselection]]; destroy .tmp_img}
button .tmp_img.cancel -text Cancel -command {set tmp_img ""; destroy .tmp_img}
pack .tmp_img.ly -side right -expand yes -fill y
pack .tmp_img.l -expand yes -fill both
pack .tmp_img.ok
pack .tmp_img.cancel
tkwait window .tmp_img
puts $tmp_img
set tmp $tmp_img
}
if {$tmp != ""} {$proc $tmp}
}
proc printfileDialog {{proc} {mess} {type Save}} {
global cur_importdir cur_printname
set tmp [tk_get${type}File \
-title "tkduke: $mess" \
-initialdir $cur_importdir \
-initialfile $cur_printname \
-filetypes {{PS {.ps .eps .epsi}} {ALL {*}}}]
if {$tmp != ""} {$proc $tmp}
}
proc newFile {} {
global cur_filename cur_printname cur_editedp
global cur_layer
set cur_filename "default.mmp"
wm title . "tkduke: $cur_filename"
wm iconname . "$cur_filename"
regsub ".mmp$" [file tail $cur_filename] ".eps" cur_printname
foreach layer {1 2 3 4} {
changeLayer $layer
deleteItemAll
}
changeLayer 1
}
proc loadFile {{fname}} {
global cur_filename cur_printname cur_editedp
global cur_layer
set cur_filename $fname
wm title . "tkduke: $cur_filename"
wm iconname . "$cur_filename"
regsub ".mmp$" [file tail $cur_filename] ".eps" cur_printname
set tmp_layer $cur_layer
foreach layer {1 2 3 4} {
changeLayer $layer
deleteItemAll
}
changeLayer $tmp_layer
if {![file exists $fname]} {
# New file
set cur_editedp 0
return
}
importFile $fname
}
proc importFile {{fname}} {
global cur_filename cur_printname cur_editedp cur_zoom
global cur_filetitle cur_creator cur_createdate
global cur_paporient cur_smooth cur_stipple
global cur_layer layer_id
global cur_zoom
global cur_saving
global cur_importdir
global rodwidth
global font fontface fontsize fontsizeId
if {$cur_saving} {return} ;# ÊݸÃæ¤Ï¾¤Î¥Õ¥¡¥¤¥ë¤òÆɤ߹þ¤Þ¤Ê¤¤
if {![file exists $fname]} return
set cur_importdir [file dirname $fname]
. config -cursor watch
#update ;# ¤³¤Î¹Ô¤ò͸ú¤Ë¤¹¤ë¤È¥³¥Þ¥ó¥É¥é¥¤¥ó¤«¤é¤Î¥Õ¥¡¥¤¥ë»ØÄê¤ÇÄä»ß¡©¡©
set fd [open $fname "r"]
set str_hang "" ;# \ Ï¢·ë¹Ô¤Î°ì»þÊݸÍÑ
set im_id ""
set tmp_smooth $cur_smooth
set cur_smooth 0
set tmp_stipple $cur_stipple
set tmp_rodwidth $rodwidth
set cur_stipple {{}}
set tmp_zoom ""
set tmp_grid ""
while {![eof $fd]} {
gets $fd str
append str_hang $str
if {[regsub {\\$} $str_hang "\n" str_hang]} {
continue
}
set str $str_hang
set str_hang ""
if {[regexp "^ *#" $str]} {
continue
}
if {[regexp "^(\[^ \]+) +((.| )+)" $str null type val]} {
if {$type=="orient"} {
if {$val!=$cur_paporient} {toggleOrient}
continue
} elseif {$type=="layer"} {
changeLayer $val
continue
} elseif {$type=="title"} {
set cur_filetitle $val
continue
} elseif {$type=="zoom"} {
set tmp_zoom $val
continue
} elseif {$type=="grid"} {
set tmp_grid $val
continue
} elseif {$type=="creator"} {
set cur_creator $val
continue
} elseif {$type=="createdate"} {
set cur_createdate $val
continue
} elseif {$type=="comment"} {
continue
}
set val [eval list $val]
switch $type {
"text" {
.text.e delete 0.0 end
.text.e insert 0.0 [lindex $val 0]
set val [lreplace $val 0 0]
}
"arrow" {
set arrow [lindex $val 0]
set val [lreplace $val 0 0]
}
}
if {$type!="image"} {
set color [lindex $val 0]
} else {
set image [lindex $val 0]
}
set val [lreplace $val 0 0]
set opt ""
while {[regexp "^-\[^0-9\]" [lindex $val 0]]} {
set tmp_opt "[lindex $val 0] [lindex $val 1]"
if {$type=="rod" && [regexp "^-width" $tmp_opt]} {
set rodwidth [lindex $tmp_opt 1]
}
if {[regexp "^-font" [lindex $val 0]]} {
set face $fontface
set size $fontsize
if {[regexp "^-font +Gothic:Helvetica-Bold-(\[0-9\]+)" \
$tmp_opt null size]} {
set face "gh"
} elseif {[regexp "^-font +Mincho:Times-Roman-(\[0-9\]+)" \
$tmp_opt null size]} {
set face "mt"
}
regsub -all -- "-font +\[^ \]+ *" $tmp_opt "" tmp_opt
if {[info exists font($face:$size)]==0} {loadFont $size $face}
set fontsize $size
set fontface $face
}
append opt " $tmp_opt"
set val [lreplace $val 0 1]
}
set tmp_val $val
set val ""
foreach x $tmp_val {
lappend val [expr $x*$cur_zoom]
}
if {$type!="image"} {
set id [makeItem $type -fill $color $val]
} else {
set id [makeItem $type -file $image $val]
}
if {$type=="arrow"} {
.c itemconfigure $id -arrow $arrow
}
if {$id!=""} {
eval .c itemconfigure $id $opt
}
lappend im_id $id
}
}
close $fd
set cur_stipple $tmp_stipple
set cur_smooth $tmp_smooth
set cur_editedp 0
set rodwidth $tmp_rodwidth
if {$tmp_zoom!=""} {changeZoom $tmp_zoom}
if {$tmp_grid!=""} {setGrid $tmp_grid}
. config -cursor left_ptr
return $im_id
}
proc importTextFile {fname {type "whole"} {x 0} {y 0}} {
global cur_saving
if {$cur_saving} {return} ;# ÊݸÃæ¤Ï¾¤Î¥Õ¥¡¥¤¥ë¤òÆɤ߹þ¤Þ¤Ê¤¤
if {![file exists $fname]} {return}
set fd [open "$fname" "r"]
set text ""
while {![eof $fd]} {
append text "[gets $fd]\n"
}
close $fd
if {$type=="whole"} {
.text.e delete 0.0 end
.text.e insert 0.0 $text
makeItem text [list $x $y]
} elseif {$type=="each"} {
foreach t [split $text "\n"] {
.text.e delete 0.0 end
.text.e insert 0.0 $t
makeItem text [list $x $y]
incr y 10
}
}
}
proc createImage {{file}} {
global imageFileMap
global env
set tmpfile "/tmp/tkduke[pid].ppm"
# Image format translation
set format "ppm"
if [regexp "\.jpe?g" $file] {
catch "exec djpeg $file > $tmpfile"
} elseif [regexp "\.JPE?G" $file] {
catch "exec djpeg $file > $tmpfile"
} elseif [regexp "\.jpe" $file] {
catch "exec djpeg $file > $tmpfile"
} elseif [regexp "\.gif" $file] {
set format "gif"
set tmpfile $file
} elseif [regexp "\.tiff?" $file] {
catch "exec tifftopnm $file > $tmpfile"
} elseif [regexp "\.pbm" $file] {
catch "exec cat $file | pgmtoppm #fff > $tmpfile"
} elseif [regexp "\.pgm" $file] {
catch "exec cat $file | pgmtoppm #fff > $tmpfile"
} elseif [regexp "\.ppm" $file] {
catch "exec cat $file > $tmpfile"
} elseif [regexp "\.bmp" $file] {
catch "exec bmptoppm $file > $tmpfile"
} elseif [regexp "\.xbm" $file] {
catch "exec xbmtopbm $file | pgmtoppm #fff > $tmpfile"
} elseif [regexp "\.xpm" $file] {
catch "exec xpmtoppm $file > $tmpfile"
} elseif [regexp "\.tga" $file] {
catch "exec tgatoppm $file > $tmpfile"
} elseif [regexp "\.e?psi?" $file] {
catch "exec pstopnm2 $file > $tmpfile"
} else {
return
}
if {[file size $tmpfile]<=0} return
set img_id [image create photo -file "$tmpfile" -format $format]
if {$tmpfile!=$file} {puts "$tmpfile!=$file"; file delete $tmpfile}
regsub [exec \pwd]/ $file "" file
set imageFileMap($img_id) $file
return $img_id
}
proc importImage {{fname}} {
global cur_filename cur_printname cur_editedp
global width height
set x [expr ([rand]*.6+.2)*$width ]
set y [expr ([rand]*.6+.2)*$height]
makeItem image -file $fname [list $x $y]
}
proc changeZoom {{zoom}} {
global cur_id cur_zoom
global canvas_grid grid_unit cur_gridshow
global canvas_column canvas_row
global fontface font fontsizeId
global itemType
global width height
if {$zoom<0.1} return
set z_w [expr $width*$zoom]
set z_h [expr $height*$zoom]
set bbox [grid bbox . $canvas_column $canvas_row]
set c_w [expr [lindex $bbox 2]]
set c_h [expr [lindex $bbox 3]]
set tmp_zoom [expr 1.0/$cur_zoom*$zoom]
set tmp_id $cur_id
unselectItem tmp_id
.file.zoom_v configure -text [format "%4.1f" $zoom]
set grid [expr ($canvas_grid*$grid_unit)*$zoom]
.c configure -width $z_w
.c configure -height $z_h
.c configure -scrollregion "0 0 $z_w $z_h";
if {$tmp_id!=""} {
set bbox [eval .c bbox $tmp_id]
} else {
set tmp_gridshow $cur_gridshow
if {$cur_gridshow} {set cur_gridshow 0; makeGridLine}
set bbox [.c bbox all]
if {$tmp_gridshow} {set cur_gridshow $tmp_gridshow; makeGridLine}
}
if {$bbox!=""} {
set x [expr ([lindex $bbox 2]+[lindex $bbox 0])/2.0]
set y [expr ([lindex $bbox 3]+[lindex $bbox 1])/2.0]
set x [expr $x*$tmp_zoom-$c_w/2.0]
set y [expr $y*$tmp_zoom-$c_h/2.0]
.c xview moveto [expr 1.0*$x/$z_w]
.c yview moveto [expr 1.0*$y/$z_h]
} else {
sets {x0 x1} [.c xview]
sets {y0 y1} [.c yview]
.c xview moveto [expr .5-($x1-$x0)/2]
.c yview moveto [expr .5-($y1-$y0)/2]
}
foreach id [.c find all] {
set coord ""
foreach {x y} [.c coord $id] {
set x [expr $x*$tmp_zoom]
set y [expr $y*$tmp_zoom]
lappend coord $x
lappend coord $y
}
eval .c coord $id $coord
if {1 && [array names itemType $id]!="" && $itemType($id)=="text"} {
set tmp_face [.c itemcget $id -font]
if {[regexp "Gothic" $tmp_face]} {
set tmp_face "gh"
} else {
set tmp_face "mt"
}
if {0} {
regexp ".+-(\[0-9\]+)$" [.c itemcget $id -font] null size
} else {
set size [expr int($fontsizeId($id)*$zoom)]
if {$size==0} {set size 1}
}
if {[info exists font($tmp_face:$size)]==0} {
loadFont $size $tmp_face
}
.c itemconfigure $id -font $font($tmp_face:$size)
}
}
selectItem tmp_id
set cur_zoom $zoom
if {$cur_gridshow} {makeGridLine}
}
proc loadFont {{size} {face ""}} {
global font fontface fmap
global tcl_platform
global kfont_mt kfont_gh
if {$face==""} {set face $fontface}
if {[info exists font($face:$size)]!=0} {return}
set win_fontscale .9
if {$face=="gh"} {
set font($face:$size) Gothic:Helvetica-Bold-$size
eval set kfont $kfont_gh
if {$tcl_platform(platform)=="windows"} {
font create $font($face:$size) \
-copy [list $kfont [expr int($size*$win_fontscale)]]
} else {
catch [font create $font($face:$size) \
-compound \
"-adobe-helvetica-bold-r-normal--$size-*-*-*-p-*-iso8859-1 \
$kfont"]
# "-*-*-*-*-*--$size-*-*-*-*-*-jisx02*-*"
}
set fmap($font($face:$size)) \
[list {Helvetica-Bold GothicBBB-Medium-EUC-H} $size]
} elseif {$face=="mt"} {
set font($face:$size) Mincho:Times-Roman-$size
eval set kfont $kfont_mt
if {$tcl_platform(platform)=="windows"} {
font create $font($face:$size) \
-copy [list $kfont [expr int($size*$win_fontscale)]]
} else {
catch [font create $font($face:$size) \
-compound \
"-adobe-times-medium-r-normal--$size-*-*-*-p-*-iso8859-1 \
$kfont"]
# "-*-*-*-*-*--$size-*-*-*-*-*-jisx02*-*"
}
set fmap($font($face:$size)) \
[list {Times-Roman Ryumin-Light-EUC-H} $size]
} else {
error "Unknown typeface specified '$fontface'"
}
}
proc toggleFontFace {} {
global font fontface fontsize cur_id itemType
if {$fontface=="gh"} {
set fontface "mt"
} else {
set fontface "gh"
}
.text.fs_lf configure -text $fontface
if {$cur_id!={}} {
foreach id $cur_id {
if {$itemType($id)=="text"} {
set tmp_fontsize $fontsize
regexp ".+-(\[0-9\]+)$" [.c itemcget $id -font] null fontsize
if {[info exists font($fontface:$fontsize)]==0} {
loadFont $fontsize
}
.c itemconfigure $id -font $font($fontface:$fontsize)
set fontsize $tmp_fontsize
}
}
}
}
proc groupItem {{group_id}} {
upvar $group_id g_id
global group itemgroup cur_group_id
set gname "g$cur_group_id"
set group($gname) $g_id
set g ""
set grouping_p 0
foreach id $g_id {
if {[info exists itemgroup($id)] && $itemgroup($id)!=""} {
if {$g!="" && [lintersection $itemgroup($id) $g]==""} {
set grouping_p 1
break
}
set g $itemgroup($id)
} else {
set grouping_p 1
break
}
}
if {$grouping_p==0} {return}
foreach id $g_id {
lappend itemgroup($id) $gname
}
incr cur_group_id
}
proc ungroupItem {{group_id}} {
upvar $group_id g_id
global group itemgroup
foreach id $g_id {
if {[info exists itemgroup($id)]} {
set itemgroup($id) [lreplace $itemgroup($id) end end]
}
}
}
############################################################
# Balloon Help
proc balloon_activate {w msg} {
global bhinfo balloon_show
if {$balloon_show} {
set bhinfo(w) [after 500 balloon_popup $w [list $msg]]
}
}
proc balloon_cancel {w} {
global bhinfo
if {[info exists bhinfo(w)]} {
after cancel $bhinfo(w)
unset bhinfo(w)
}
if {[winfo exists .bh]} {
destroy .bh
}
}
proc balloon_popup {w msg} {
global balloon_lang
if {$balloon_lang!="Japanese"} {
set msg [lindex $msg 0]
} else {
set msg [lindex $msg 1]
}
set t .bh
toplevel $t -background black -borderwidth 1 -relief flat
label $t.l -text $msg -background LemonChiffon \
-font {-*-lucida-medium-r-normal-sans-*-120-*}
pack $t.l
wm overrideredirect $t 1
set x [expr [winfo rootx $w]+[winfo reqwidth $w]/2]
set y [expr [winfo rooty $w]+[winfo reqheight $w]+5]
wm geometry $t [format "+%d+%d" $x $y]
update idletasks
}
proc balloon_for {w msg {msg_jp ""}} {
bind $w <Enter> [list balloon_activate $w [list $msg $msg_jp]]
bind $w <Leave> [list balloon_cancel $w]
bind $w <Button-1> [list balloon_cancel $w]
}
############################################################
proc exitProgram {} {
global cur_editedp
if {1 || $cur_editedp==0} {
exit
} else {
puts "Warning: Please save before quit."
}
}
############################################################
# Initialize
set cur_mode "select"
set cur_id {}
set cur_nod {}
set cur_bbox ""
if {0} {
set cur_col [list [expr int(([rand]*.4+.6)*255)] [rand] [rand] [rand]]
} else {
set cur_col {0 0 0 0}
}
set cur_filename "default.mmp"
set cur_filetitle ""
set cur_creator "unknown"
if {[array names env USER]!=""} {set cur_creator "$env(USER)"}
if {$cur_creator!="" && $cur_creator!="unknown"} {
set tmp [exec perl -e {print ((getpwnam("oshiro"))[6])}]
if {$tmp!=""} {
set cur_creator $tmp
}
}
set cur_createdate [clock format [clock seconds] -format "%Y/%m/%d"]
set cur_arrow "first"
set cur_arrowshape {10 10 2}
set cur_smooth "0"
set cur_editedp 0
set cur_backupedp 0
set cur_printname "tmp_tkduke.eps"
set cur_zoom 1
set cur_itemanchor "c"
set cur_scaleratio .7
set cur_rotateangle 90
set cur_shearxshift 50
set cur_blendstep 20
set cur_paporient "landscape"
set cur_cursor "left_ptr"
set cur_textjustify "center"
set cur_textanchor "center"
set cur_saving 0
set cur_savepreview 0
set cur_importdir .
set cur_importtext whole
set poly_tgiftype 1
#set cur_itemsnap 0
set tmp_cur_id ""
set group() ""
set itemgroup() ""
set cur_group_id 0
set cur_layer 1
set layer_id() ""
set fline_skipnum 1
set fline_cnt 0
set raiselower lower
sets {width height} {876 620} ;# A4 paper size
set floatmenubase_limit 7
set floatmenubase_x 0
set floatmenubase_y 0
set balloon_lang "English"
set balloon_show 1
set bhinfo(w) ""
set fontface "gh"
if {$tcl_platform(platform)=="windows"} {
set fontsize_list {2 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 24 25 26 30 33 34 40 50 60 70 80 90 100 120}
set kfont_gh {{£Í£Ó £Ð¥´¥·¥Ã¥¯}}
set kfont_mt {{£Í£Ó £ÐÌÀÄ«}}
} else {
if {0} {
set fontsize_list {2 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 24 25 26 30 33 34 40 50 60 70 80 90 100 120} ;# X-tt ¤Î¾ì¹ç¤Ë¿ä¾©
set kfont_gh "-wadalab-gothic-*-r-*--\$size-*-*-*-*-*-jisx02*-*"
set kfont_mt "-watanabe-mincho-*-r-*--\$size-*-*-*-*-*-jisx02*-*"
} else {
set fontsize_list {10 12 16 24} ;# Ä̾ï¤Î X ¤ËÍÑ°Õ¤µ¤ì¤Æ¤¤¤ëÆüËܸì¥Õ¥©¥ó¥È¤Ç¤Ï
;# ¤³¤Á¤é¤¬¸Â³¦
set kfont_gh "-jis-*-*-r-*--\$size-*-*-*-*-*-jisx02*-*"
set kfont_mt "-jis-*-*-r-*--\$size-*-*-*-*-*-jisx02*-*"
}
}
set fontsize 16
set font_no [expr [lsearch $fontsize_list $fontsize] +1]
set cur_linewidth 2
set cur_gridshow 1
set linecap butt
set rodwidth 15
#set tk_strictMotif 1
set no_toolbutton 0
############################################################
# ½é´üÀßÄê¥Õ¥¡¥¤¥ë¤ÎÆɤ߹þ¤ß
if {[info exists env(LANG)] && [regexp "^ja_JP" $env(LANG)]} {
set balloon_lang "Japanese"
}
if {[file exists [glob ~]/.tkdukerc]} {
source [glob ~]/.tkdukerc
}
while {1} {
set v [lindex $argv 0]
if {![regexp "^-" $v] || [regexp "^--$" $v]} break
switch -- $v {
"-notoolbutton" {
set no_toolbutton 1
set cur_gridshow 0
set argv [lrange $argv 1 end]
}
"--help" {
puts "Usage: tkduke \[-notoolbutton\] file"
exit
}
default {
puts "Unknown option specified $v."
puts "Usage: tkduke \[-notoolbutton\] file"
exit
}
}
}
############################################################
canvas .c \
-width [expr $width*$cur_zoom] \
-height [expr $height*$cur_zoom] \
-background white
#.c configure -background SteelBlue
if {0} {
set grid_unit 1
} else {
foreach {name u} {cm c mm m in i pt p} {
set tmp_id [.c create line 1$u 0 0 0]
set gridUnit($name) [lindex [.c coords $tmp_id] 0]
.c delete $tmp_id
}
set grid_unit $gridUnit(mm)
}
scrollbar .cscrolly -orient vertical -command ".c yview"
scrollbar .cscrollx -orient horizontal -command ".c xview"
grid .cscrolly -row 4 -column 5 -sticky ns
grid .cscrollx -row 5 -column 3 -columnspan 2 -sticky ew
sets {canvas_column canvas_row} {3 4}
grid .c -row $canvas_row -column $canvas_column -columnspan 2
grid rowconfigure . $canvas_row -weight 1
grid columnconfigure . $canvas_column -weight 1
.c configure -scrollregion \
"0 0 [expr $width*$cur_zoom] [expr $height*$cur_zoom]" \
-xscrollcommand ".cscrollx set" -yscrollcommand ".cscrolly set"
focus .c
if {$cur_gridshow} {makeGridLine}
##################################################
# Font map, fontmap
if {1} {
. config -cursor watch
set i 1
foreach size $fontsize_list {
set fontsize_array($i) $size
#loadFont $size ;#¢«»Ï¤á¤Ë¼Â¹Ô¤¹¤ë¤È¥Õ¥©¥ó¥È¿ô¤¬Â¿¤¤¤È¤¤Ë»þ´Ö¤¬¤«¤«¤ë
incr i
}
. config -cursor left_ptr
} else {
set font Ryumin:Helvetica-12
}
setIconbitmap .
##################################################
frame .file
frame .tool
frame .op
frame .op.col
frame .text
if {$no_toolbutton==0} {
grid .file -row 0 -column 2 -columnspan 2 -sticky w
grid .tool -row 3 -column 1 -rowspan 5 -sticky nw
grid .text -row 2 -column 3 -columnspan 2 -sticky w
grid .op -row 0 -column 0 -rowspan 5 -sticky n
}
##################################################
set t .file
foreach {i} {quit newfile load reload save saveas import importtext imagel info} {
button $t.$i -image ${i}_icon
}
foreach {i m} {print menu} {
menubutton $t.$i -image ${i}_icon -menu $t.$i.$m -relief raised
}
set m $t.print.menu
menu $m -tearoff false
$m add command -label "Send to Printer" -command {if {[printCanvas /tmp/tkduke[pid].eps]} {exec lpr -Plbp67 -r -s /tmp/tkduke[pid].eps}}
$m add command -label "Save to EPS" -command {printfileDialog printCanvas "Print Out to File" Save}
foreach {w msg msg_jp} {
quit "Quit" "½ªÎ»"
newfile "New" "¿·µ¬"
load "Load" "Æɤ߹þ¤ß"
reload "Reload" "ºÆÆɤ߹þ¤ß"
save "Save" "Êݸ"
saveas "Save as" "ÊÌ̾Êݸ"
import "Import" "¸½ÊÔ½¸Ê¬¤ØÆɤ߹þ¤ß"
importtext "Import Text File" "¥Æ¥¥¹¥È¥Õ¥¡¥¤¥ë¤òÆɤ߹þ¤ß"
imagel "Load Image File" "²èÁü¤òÆɤ߹þ¤ß"
print "Print" "°õºþ"
info "Document Info Editor" "¥Õ¥¡¥¤¥ë¾ðÊó¤òÊÔ½¸"
} {
balloon_for $t.$w $msg $msg_jp
}
set t .tool
foreach {i d} {\
bs select bt text brct rect borct orect bb box bob obox bx boxx \
bc circle bo oval bsp sphere
} {
radiobutton $t.$i -image ${d}_icon -value $d \
-variable cur_mode -indicatoron false
}
foreach {i d} {\
ba arrow bl line bfl fline bpl pline bpo poly br rod bp pixel \
spoit colSpoit
} {
radiobutton $t.$i -image ${d}_icon -value $d \
-variable cur_mode -indicatoron false
}
foreach {w msg msg_jp} {
bs "Select" "ÁªÂò"
bt "Text" "¥Æ¥¥¹¥È"
brct "Rectangle" "¶ë·Á"
borct "OvalRectangle" "´Ý¶ë·Á"
bb "Box" "ÃæµÍ¤á¶ë·Á"
bob "OvalBox" "ÃæµÍ¤á´Ý¶ë·Á"
bx "Boxx" "È¢"
bc "Circle" "±ß"
bo "Oval" "ÃæµÍ¤á±ß"
bsp "Sphere" "µå·Á"
ba "Arrow" "Ìð"
bl "Line" "Àþ"
bfl "Free" "¼«Í³Àþ"
bpl "Poly Line" "¿³ÑÀþ"
bpo "Poly Fill" "¿³Ñ·Á"
br "Rod" "ËÀ·Á"
bp "Pixel" "ÅÀ"
spoit "Spoit Color" "¿§¥¹¥Ý¥¤¥È"
} {
balloon_for $t.$w $msg $msg_jp
}
proc fontmapNumToSize {} {
global font_no fontsize fontsize_array
while {1} {
tkwait variable font_no
set fontsize $fontsize_array($font_no)
}
}
after 10000 fontmapNumToSize
##################################################
set t .text
label $t.e_l -text Text -relief ridge
text $t.e -width 30 -height 1
balloon_for $t.e_l "Text Input" "ʸ»úÎó¤ÎÆþÎÏ"
##################################################
set c .op.col
entry $c.cole -width 9
button $c.cur_col -background [makeColorString $cur_col] -relief raised
button $c.col_rand -image colrnd_icon -relief raised
menubutton $c.col_sel -image colsel_icon -relief raised
$c.col_sel configure -menu [makeColorMenu $c.col_sel]
checkbutton $c.col_randchk -variable col_rand
button $c.col_plt -image colplt_icon -command {setColor [tk_chooseColor -title "Color Chooser" -initialcolor [.op.col.cur_col cget -background]]}
set cur_stipple {{}}
menubutton $c.stipple_sel -text stp -relief raised -justify center
$c.stipple_sel configure -menu [makeStippleMenu $c.stipple_sel]
foreach {w msg msg_jp} {
cur_col "Set Current Color" "¸½ºß¿§¤òÀßÄê"
col_rand "Random Color" "¥é¥ó¥À¥à¥«¥é¡¼"
col_sel "Color Select" "¿§ÁªÂò"
col_plt "Color Pallette" "¿§ºîÀ®"
col_randchk "Set Random Color for Each Item" "¥¢¥¤¥Æ¥àËè¤Î¿§¤Î¥é¥ó¥À¥àÀßÄê"
stipple_sel "Set Item Stipple" "¥¢¥¤¥Æ¥àÌÏÍͤòÀßÄê"
} {
balloon_for $c.$w $msg $msg_jp
}
#checkbutton $c.itemsnap -variable cur_itemsnap -onvalue 1 -offvalue 0
##################################################
set t .op
button $t.delete -text "delete" -relief raised
button $t.copy -text "copy" -relief raised
button $t.group -text "group" -relief raised
button $t.ungroup -text "ungroup" -relief raised
button $t.propdist -text "propDist" -relief raised
button $t.frame -text "fram" -relief raised
button $t.shadow -text "shad" -relief raised
button $t.brace -text "brac" -relief raised
button $t.flipH -text "flipH" -relief raised
button $t.flipV -text "flipV" -relief raised
button $t.scaleI -text "scale" -relief raised
button $t.rotateI -text "rotate" -relief raised
button $t.shearI -text "shear" -relief raised
button $t.togGrid -text "togGrid" -relief raised
if {0} {
button $t.setGrid -text "setGrid" -relief raised
} else {
set m $t.setGrid
menubutton $m -menu $m.menu -text "setGrid" -relief raised
set m $m.menu
menu $m -tearoff false
foreach g {0 1 2 5 10 20} {
$m add command -label $g -command [list setGrid $g] \
-columnbreak [expr $g==5]
}
$m add command -label set -command {setGrid {}}
}
button $t.fileBrowser -text "fileBrowser" -relief raised
button $t.togor -text "togOrient" -relief raised
checkbutton $t.togsm -text "togSmooth" -relief raised -variable cur_smooth -onvalue 1 -offvalue 0
button $t.togar -text "togArrow" -relief raised
button $t.togjus -text "togTextJustify" -relief raised
button $t.toganc -text "togTextAnchor" -relief raised
button $t.splittext -text "splitText" -relief raised
button $t.jointext -text "joinText" -relief raised
button $t.togpcl -text "togClosePline" -relief raised
button $t.togitm -text "togItem" -relief raised
button $t.blend -text "blend" -relief raised
button $t.darken -text "dark" -relief raised
button $t.lighten -text "light" -relief raised
radiobutton $t.bna -text "nAdd" -value "nodAdd" -variable cur_mode -indicatoron false
radiobutton $t.bnd -text "nDel" -value "nodDel" -variable cur_mode -indicatoron false
radiobutton $t.bnc -text "nCut" -value "nodCut" -variable cur_mode -indicatoron false
set m $t.menulinc
menubutton $m -menu $m.menu -text "setLineCap" -relief raised
set m $m.menu
menu $m -tearoff false
$m add command -label "Butt"
$m add command -label "Projecting"
$m add command -label "Round"
foreach {w msg msg_jp} {
delete "Delete Select Item" "ºï½ü"
copy "Copy Select Item" "Ê£¼Ì"
group "Group Select Item" "¥°¥ë¡¼¥Ô¥ó¥°"
ungroup "Ungroup Select Item" "¥°¥ë¡¼¥Ô¥ó¥°¤ò²ò½ü"
propdist "Proportional Distribute" "¶ÑÅùÇÛÃÖ"
frame "Add Frame to Select Item" "ÏȤòÄɲÃ"
shadow "Add Shadow to Select Item" "±ÆÉÕ¤ÏȤòÄɲÃ"
brace "Add Brace to Select Item" "¥«¥®³ç¸ÌÏȤòÄɲÃ"
flipH "Item Flip Horizontal" "¿åÊ¿Êý¸þ¤Ëȿž"
flipV "Item Flip Vertical" "¿âľÊý¸þ¤Ëȿž"
scaleI "Scale Select Item" "¥µ¥¤¥º¤òÊѹ¹"
rotateI "Rotate Select Item" "²óž"
shearI "Shear Select Item" "¤»¤óÃÇÊÑ·Á"
togGrid "Set Grid Size" "¥°¥ê¥Ã¥Éɽ¼¨¤òÀÚÂؤ¨"
setGrid "Set Grid Size" "¥°¥ê¥Ã¥É¥µ¥¤¥º¤òÀßÄê"
fileBrowser "Invoke File Browser" "¥Õ¥¡¥¤¥ë¥Ö¥é¥¦¥¶¤òµ¯Æ°"
togor "Toggle Paper Orient" "»æÌÌÊý¸þ¤òÀÚÂؤ¨"
togsm "Toggle Poly/Line Smoothing" "Àþ¼ï¤Î¥¹¥à¡¼¥¸¥ó¥°¤òÀÚÂؤ¨"
togar "Toggle Line Arrow" "Àþ¤ÎÌð¤ÎÍ̵¤òÀÚÂؤ¨"
togjus "Toggle Text Justify" "ʸ»úÎó¤Î´ó¤»Êý¸þ¤òÀÚÂؤ¨"
toganc "Toggle Text Anchor" "ʸ»úÎó¤ÎÇÛÃÖ°ÌÃÖ¤òÀÚÂؤ¨"
splittext "Split Text Each Line" "ʸ»úÎó¤ò¹ÔËè¤Ëʬ²ò"
jointext "Join Text to One Item" "¹ÔËè¤Îʸ»úÎó¤òñ°ì²½"
togpcl "Toggle Poly Line Closing" "¿³ÑÀþ¤ÎüÅÀ¤ÎÊĤ¸¤òÀÚÂؤ¨"
togitm "Toggle Item Type" "¥¢¥¤¥Æ¥à¼ï¤òÀÚÂؤ¨"
blend "Blend Two Same Type Items" "£²¤Ä¤Î¥¢¥¤¥Æ¥à¤òÊ£¹ç"
darken "Change Color Dark" "¥¢¥¤¥Æ¥à¿§¤ò°Å¤¯"
lighten "Change Color Light" "¥¢¥¤¥Æ¥à¿§¤òÌÀ¤ë¤¯"
bna "Line Node Add" "Àþ¤ÎÀ©¸æÅÀ¤òÄɲÃ"
bnd "Line Node Delete" "Àþ¤ÎÀ©¸æÅÀ¤òºï½ü"
bnc "Line Node Cut" "Àþ¤ÎÀ©¸æÅÀ¤«¤éʬ³ä"
menulinc "Set Line Cap" "¥é¥¤¥ó¥¥ã¥Ã¥×¤òÀßÄê"
} {
balloon_for $t.$w $msg $msg_jp
}
set t .file
button $t.zoom_p -image lupe_plus -relief raised
button $t.zoom_m -image lupe_minus -relief raised
label $t.zoom_v -text [format "%4.1f" $cur_zoom]
bind $t.zoom_p <ButtonRelease-1> {changeZoom [expr $cur_zoom*sqrt(2)]}
bind $t.zoom_m <ButtonRelease-1> {changeZoom [expr $cur_zoom/sqrt(2)]}
balloon_for $t.zoom_p "Zoom +" "ɽ¼¨¤ò³ÈÂç +"
balloon_for $t.zoom_m "Zoom -" "ɽ¼¨¤ò½Ì¾® -"
balloon_for $t.zoom_v "Current Zoom Value" "¸½ºß¤Îɽ¼¨¥¹¥±¡¼¥ë"
label $t.llayer -text Layer -relief ridge
balloon_for $t.llayer "Change Layer" "ÊÔ½¸¥ì¥¤¥ä¤ÎÀÚÂؤ¨"
foreach n {1 2 3 4} {
radiobutton $t.layer$n -variable cur_layer -value $n -text $n \
-indicatoron false
balloon_for $t.layer$n "Change Layer $n" "ÊÔ½¸¥ì¥¤¥ä¤ÎÀÚÂؤ¨ $n"
}
label $t.limptype -text ImportText -relief ridge
balloon_for $t.limptype \
"Set Import Text Type" \
"¥Æ¥¥¹¥È¥Õ¥¡¥¤¥ë¤ÎÆɤ߹þ¤ß¥¿¥¤¥×¤òÀßÄê"
checkbutton $t.imptype -variable cur_importtext -indicatoron false \
-onvalue each -offvalue whole -text each
balloon_for $t.imptype \
"Set Import Text Type to 'Each'" \
"¥Æ¥¥¹¥È¥Õ¥¡¥¤¥ë¤ÎÆɤ߹þ¤ß¥¿¥¤¥×¤ò¡Ö¸ÄÊ̹ԡפËÀßÄê"
set sticky news
set t .file
if {$no_toolbutton==0} {
foreach {w r c} {
quit 0 0
newfile 0 1
load 0 2
reload 0 3
save 0 4
saveas 0 5
import 0 6
importtext 0 7
imagel 0 8
print 0 9
info 0 10
zoom_p 0 11
zoom_m 0 12
zoom_v 0 13
llayer 0 14
layer1 0 15
layer2 0 16
layer3 0 17
layer4 0 18
limptype 0 19
imptype 0 20
} {
grid $t.$w -row $r -column $c -sticky $sticky -padx 0 -pady 0 -ipadx 0 -ipady 0
}
}
update idletasks
wm geometry . [wm geometry .]
##################################################
set c .op.col
if {0} {
grid $c.cur_col $c.cole $c.col_plt -sticky news
grid $c.col_sel $c.col_rand $c.col_randchk -sticky news
grid $c.stipple_sel
} else {
grid $c.cur_col $c.col_sel $c.col_plt $c.col_rand $c.col_randchk $c.stipple_sel -sticky news
}
set t .tool
if {$no_toolbutton==0} {
set c 0
set r 0
foreach {w} {
bs
bt
brct
borct
bb
bob
bx
bc
bo
bsp
ba
bl
bfl
bpl
bpo
br
bp
spoit
} {
grid $t.$w -row $r -column $c -sticky $sticky
incr r
}
}
set t .op
if {$no_toolbutton==0} {
grid $t.fileBrowser -columnspan 6 -sticky news
grid $t.togor -columnspan 6 -sticky news
grid $t.togGrid $t.setGrid -columnspan 3 -sticky news
grid $t.delete $t.copy -columnspan 3 -sticky news
grid $t.group $t.ungroup -columnspan 3 -sticky news
grid $t.scaleI $t.shearI $t.rotateI -columnspan 2 -sticky news
grid $t.blend $t.darken $t.lighten -columnspan 2 -sticky news
grid $t.bnd $t.bnc $t.bna -columnspan 2 -sticky news
grid $t.frame $t.shadow $t.brace -columnspan 2 -sticky news
grid $t.flipH $t.flipV -columnspan 3 -sticky news
grid $t.propdist -columnspan 6 -sticky news
grid $t.togjus -columnspan 6 -sticky news
grid $t.toganc -columnspan 6 -sticky news
grid $t.splittext $t.jointext -columnspan 3 -sticky news
grid $t.togsm -columnspan 6 -sticky news
grid $t.togar -columnspan 6 -sticky news
grid $t.togpcl -columnspan 6 -sticky news
grid $t.menulinc -columnspan 6 -sticky news
grid $t.togitm -columnspan 6 -sticky news
grid $t.col -columnspan 6 -sticky news
}
set t .text
scale $t.fs -variable font_no -from 1 -to [llength $fontsize_list] -orient horizontal -showvalue 0
label $t.fs_l -text Font -relief ridge
label $t.fs_lv -text [$t.fs get]
label $t.fs_lf -text $fontface
scale $t.fw -variable cur_linewidth -from 0 -to 200 -orient horizontal -showvalue 0
label $t.fw_l -text Line -relief ridge
label $t.fw_lv -text [$t.fw get]
balloon_for $t.fs_l "Set Font" "»ú°À¤ÎÀßÄê"
balloon_for $t.fs_lf "Toggle Font Face" "»úÂΤòÀÚÂؤ¨"
balloon_for $t.fs "Set Font Size" "»ú¥µ¥¤¥º¤òÀßÄê"
balloon_for $t.fw_l "Set Line" "Àþ¤ÎÀßÄê"
balloon_for $t.fw "Set Line Width" "ÀþÉý¤ÎÀßÄê"
if {$no_toolbutton==0} {
set t .text
grid $t.e_l $t.e $t.fs_l $t.fs_lf $t.fs $t.fs_lv $t.fw_l $t.fw $t.fw_lv -sticky news
}
############################################################
#
proc makeFloatMenuBase {{x} {y}} {
global todo todo_c todo_open todo_num
global cur_editedp cur_filename cur_printname cur_mode
global tool_menu_teaoff
foreach i {arrow box obox boxx circle fline line oval pixel pline poly rect orect rod select sphere text colSpoit quit load import importtext save saveas imagel print info} {
global ${i}_icon
}
set m .tool_menu
if {[winfo exists $m]} {
tk_popup $m [expr $x-20] $y
return
}
menu $m -tearoff 1 -cursor hand2 -title "tkduke: Toolbox"
bind $m <Control-q> "destroy $m;break"
bind $m <Control-c> "destroy $m;break"
bind $m <Alt-w> "destroy $m;break"
set clmn 5
#set n 0
set n 1
foreach i {
select
text
rect
orect
box
obox
boxx
circle
oval
sphere
arrow
line
fline
pline
poly
rod
pixel
colSpoit} {
$m add radiobutton -variable cur_mode \
-indicatoron false \
-value $i \
-image ${i}_icon \
-hidemargin 1 \
-columnbreak [expr (fmod($n-1, $clmn)==0)]
incr n
}
set n 1
foreach f {
{load {fileDialog loadFile "Load File"}}
{reload {loadFile $cur_filename}}
{save {saveItem $cur_filename}}
{saveas {set cur_filename ""; fileDialog saveItem "Save As.." Save}}
{import {set imp_id [fileDialog importFile "Import File"]; selectItem imp_id}}
{imagel {imagefileDialog importImage "Import Image"}}
{print {printfileDialog printCanvas "Print Out to File" Save}}
{info {editCurrentInfo}}
{newfile {fileDialog newFile "New File"}}
{quit exitProgram}} {
set i [lindex $f 0]
set com [lindex $f 1]
$m add command -image ${i}_icon \
-command $com \
-hidemargin 1 \
-columnbreak [expr (fmod($n-1, $clmn)==0)]
incr n
}
tk_popup $m [expr $x-20] $y
}
bind .c <ButtonPress-1> {focus .c; ButtonPress-1 %x %y}
bind .c <ButtonPress-2> {focus .c; ButtonPress-2 %x %y}
bind .c <Enter> {focus .c}
bind .c <ButtonPress-3> {
if {$cur_mode=="poly" || $cur_mode=="pline"} {
ButtonPress-3 %x %y
} else {
set floatmenubase 0
set floatmenubase_x %x
set floatmenubase_y %y
if {0} {
unselectItem cur_id
set cur_id "";
set cur_bbox "";
set cur_mode "select";
}
}
}
bind .c <Button3-Motion> {
if {sqrt((%x-$floatmenubase_x)*(%x-$floatmenubase_x)+(%y-$floatmenubase_y)*(%y-$floatmenubase_y))>$floatmenubase_limit} {
makeFloatMenuBase %X %Y
set floatmenubase 1
}
}
bind .c <ButtonRelease-3> {
if {$floatmenubase==0} {
unselectItem cur_id
set cur_id "";
set cur_bbox "";
set cur_mode "select";
}
set floatmenubase 0
}
bind .c <Button1-Motion> {Button1-Motion %x %y}
bind .c <ButtonRelease-1> {ButtonRelease-1 %x %y}
bind .c <Shift-ButtonPress-1> {Shift-ButtonPress-1 %x %y; break}
bind .c <Shift-ButtonPress-3> {Shift-ButtonPress-3 %x %y; break}
bind .c <Shift-ButtonRelease-3> {break}
bind .c <Shift-Button1-Motion> {break}
bind .c <Motion> {ButtonMotion %x %y}
set floatmenubase 0
set t .text
bind $t.e <Alt-Return> {
%W insert insert "\n"
%W mark set current [%W index insert]+2chars
%W see current
break
}
bind $t.e <Control-o> {
%W insert insert "\n"
%W mark set current [%W index insert]+2chars
%W see current
break
}
bind $t.e <Control-Return> {
%W insert insert "\n"
%W mark set current [%W index insert]+2chars
%W see current
break
}
bind $t.e <Key-Return> {
set x [expr ([rand]*.6+.2)*$width ]
set y [expr ([rand]*.6+.2)*$height]
if {$cur_id!={}} {
foreach id $cur_id {
if {$itemType($id)=="text"} {
set font_opt [.c itemcget $id -font]
set tmp_fontface $fontface
set tmp_fontsize $fontsize
if {[regexp "Mincho:Times-Roman-(\[0-9\]+)" $font_opt null tmp_fontsize]} {
set tmp_fontface "mt"
} elseif {[regexp "Gothic:Helvetica-Bold-(\[0-9\]+)" $font_opt null tmp_fontsize]} {
set tmp_fontface "gh"
}
if {[info exists font($tmp_fontface:$tmp_fontsize)]==0} {loadFont $tmp_fontsize $tmp_fontface}
.c itemconfigure $id -text [%W get 0.0 "end-1chars"] -font $font($tmp_fontface:$tmp_fontsize)
}
}
} else {
makeItem "text" [list $x $y]
}
break
}
bind $t.e <Double-Button-3> {
%W delete 0.0 end
focus %W
break
}
set c .op.col
bind $c.cole <Key-Return> {setColor [%W get]}
bind $c.cole <Button-3> {setColor [%W get]}
bind $c.cole <Double-Button-1> {%W delete 0 end}
set t .text
$t.fs configure -command [list $t.fs_lv configure -text]
bind $t.fs <ButtonRelease-1> {
set x [expr ([rand]*.6+.2)*$width ]
set y [expr ([rand]*.6+.2)*$height]
if {$cur_id!={}} {
foreach id $cur_id {
if {$itemType($id)=="text"} {
regexp "(.+)-\[0-9\]+\$" [.c itemcget $id -font] null tmpface
if {$tmpface=="Mincho:Times-Roman"} {
set face "mt"
} elseif {$tmpface=="Gothic:Helvetica-Bold"} {
set face "gh"
}
if {0} {
set size $fontsize_array($font_no)
} else {
set fontsizeId($id) $fontsize_array($font_no)
set size [expr int($fontsizeId($id)*$cur_zoom)]
if {$size==0} {set size 1}
}
if {[info exists font($face:$size)]==0} {
loadFont $size $face
}
.c itemconfigure $id -font $font($face:$size)
}
}
}
}
$t.fw configure -command [list $t.fw_lv configure -text]
bind $t.fw <ButtonRelease-1> {
set rodwidth $cur_linewidth
if {$cur_id!={}} {
foreach id $cur_id {
set type $itemType($id)
if {$type=="line" || $type=="arrow" || $type=="pline"} {
.c itemconfigure $id -width $cur_linewidth
} elseif {$type=="rect" || $type=="orect"} {
.c itemconfigure $id -width $cur_linewidth
} elseif {$type=="circle"} {
.c itemconfigure $id -width $cur_linewidth
} elseif {$type=="rod"} {
.c itemconfigure $id -width $rodwidth
resizeItem id
}
}
}
}
bind .c <Control-q> exitProgram
bind .c <Key-Delete> {deleteItem $cur_id}
bind .c <Control-x> {deleteItem $cur_id; set cur_mode "select"}
bind .c <Control-a> {selectItemAll; set cur_mode "move"}
bind .c <Control-d> {copyItem $cur_id}
bind .c <Control-f> {raiseItem $cur_id}
bind .c <Control-b> {lowerItem $cur_id}
bind .c <Control-t> {toggleSmoothItem $cur_id}
bind .c <Control-r> {loadFile $cur_filename}
bind .c <Control-g> {groupItem cur_id}
bind .c <Control-u> {ungroupItem cur_id}
bind .c <Alt-p> {printfileDialog printCanvas "Print Out to File" Save}
bind .c <Alt-parenright> {scaleSizeItem {} $cur_id}
bind .c <Alt-a> {set cur_mode "nodAdd"}
bind .c <Alt-d> {set cur_mode "nodDel"}
bind .c <Control-s> {saveItem $cur_filename}
bind .c <Control-o> {fileDialog loadFile "Load File"}
bind .c <Alt-i> {set imp_id [fileDialog importFile "Import File"]; selectItem imp_id}
bind .c <Alt-less> {changeZoom [expr $cur_zoom/sqrt(2)]}
bind .c <Alt-greater> {changeZoom [expr $cur_zoom*sqrt(2)]}
# wheel mouse binding
bind .c <Button-4> {.c yview scroll -5 units}
bind .c <Button-5> {.c yview scroll 5 units}
bind .c <Control-Button-4> {changeZoom [expr $cur_zoom/sqrt(2)]}
bind .c <Control-Button-5> {changeZoom [expr $cur_zoom*sqrt(2)]}
bind .c <MouseWheel> {if {%D>0} {.c yview scroll -5 units} else {.c yview scroll 5 units}}
bind .c <Control-MouseWheel> {if {%D>0} {changeZoom [expr $cur_zoom/sqrt(2)]} else {changeZoom [expr $cur_zoom*sqrt(2)]}}
update idletasks
if {$argc>0} {
loadFile [lindex $argv 0]
}
##################################################
#
wm protocol . WM_DELETE_WINDOW exitProgram
set t .file
$t.quit configure -command exitProgram
$t.save configure -command {saveItem $cur_filename}
$t.saveas configure -command {fileDialog saveItem "Save As.." Save}
$t.load configure -command {fileDialog loadFile "Load File"}
$t.reload configure -command {loadFile $cur_filename}
$t.newfile configure -command {newFile}
$t.import configure -command {set imp_id [fileDialog importFile "Import File"]; selectItem imp_id}
$t.importtext configure -command {set imp_id [textfileDialog importTextFile "Import Text File"]; selectItem imp_id}
$t.imagel configure -command {imagefileDialog importImage "Import Image"}
#$t.print configure -command {printfileDialog printCanvas "Print Out to File" Save}
$t.info configure -command {editCurrentInfo}
set t .tool
$t.bfl configure -command unselectItemAll
$t.bpl configure -command unselectItemAll
$t.bpo configure -command unselectItemAll
set c .op.col
$c.col_rand configure -command randomColor
$c.cur_col configure -command {
set col [lindex $cur_col 0]
set col [format "#%02x%02x%02x" \
[expr int($col*[lindex $cur_col 1])] \
[expr int($col*[lindex $cur_col 2])] \
[expr int($col*[lindex $cur_col 3])]]
setColor $col}
set t .op
$t.delete configure -command {deleteItem $cur_id; set cur_mode "select"}
$t.copy configure -command {copyItem $cur_id}
$t.group configure -command {groupItem cur_id}
$t.ungroup configure -command {ungroupItem cur_id}
$t.propdist configure -command {propdistItem cur_id}
$t.frame configure -command {makeFrame $cur_id}
$t.shadow configure -command {makeShadow $cur_id}
$t.brace configure -command {makeBrace $cur_id}
$t.flipH configure -command {flipHorizontalItem $cur_id}
$t.flipV configure -command {flipVerticalItem $cur_id}
$t.scaleI configure -command {scaleSizeItem {} $cur_id}
$t.rotateI configure -command {rotateItem {} $cur_id}
$t.shearI configure -command {shearItem {} $cur_id}
$t.fileBrowser configure -command "$t.fileBrowser configure -state disabled; fileBrowser; tkwait window .fdw; $t.fileBrowser configure -state active"
$t.togGrid configure -command {set cur_gridshow [expr !$cur_gridshow]; makeGridLine}
#$t.setGrid configure -command {setGrid {}}
$t.togor configure -command {toggleOrient}
$t.togsm configure -command {toggleSmoothItem $cur_id}
$t.togar configure -command {toggleArrowItem $cur_id}
$t.togjus configure -command {toggleTextJustify $cur_id}
$t.toganc configure -command {toggleTextAnchor $cur_id}
$t.splittext configure -command {splitTextEachLine $cur_id}
$t.jointext configure -command {joinTextEachLine $cur_id}
$t.togpcl configure -command {toggleClosePline $cur_id}
$t.togitm configure -command {toggleItem $cur_id}
$t.blend configure -command {blendItem $cur_id}
$t.darken configure -command {darkenItem $cur_id}
$t.lighten configure -command {lightenItem $cur_id}
set m $t.menulinc.menu
$m entryconfigure Butt -command {setLineCap "butt" $cur_id}
$m entryconfigure Projecting -command {setLineCap "projecting" $cur_id}
$m entryconfigure Round -command {setLineCap "round" $cur_id}
bind .c <Alt-t> {setItemAnchor $cur_id "l"}
bind .c <Alt-equal> {setItemAnchor $cur_id "c"}
bind .c <Alt-plus> {setItemAnchor $cur_id "m"}
bind .c <Alt-bar> {abutItem $cur_id "v"}
bind .c <Alt-underscore> {abutItem $cur_id "h"}
bind .c <Control-Alt-d> {darkenItem $cur_id; break}
bind .c <Control-Alt-l> {lightenItem $cur_id; break}
bind .c <Control-Alt-b> {blendItem $cur_id; break}
bind .text.fs_lf <Button-1> toggleFontFace
bind .c <Control-Alt-f> toggleFontFace
bind .c <Control-Alt-Key-1> {changeLayer 1}
bind .c <Control-Alt-Key-2> {changeLayer 2}
bind .c <Control-Alt-Key-3> {changeLayer 3}
bind .c <Control-Alt-Key-4> {changeLayer 4}
bind .c <Key-Right> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem [expr $grid*$cur_zoom] 0 cur_id}
bind .c <Key-Left> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem [expr -$grid*$cur_zoom] 0 cur_id}
bind .c <Key-Up> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem 0 [expr -$grid*$cur_zoom] cur_id}
bind .c <Key-Down> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem 0 [expr $grid*$cur_zoom] cur_id}
bind .c <Shift-Key-Right> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem [expr 5*$grid*$cur_zoom] 0 cur_id}
bind .c <Shift-Key-Left> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem [expr -5*$grid*$cur_zoom] 0 cur_id}
bind .c <Shift-Key-Up> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem 0 [expr -5*$grid*$cur_zoom] cur_id}
bind .c <Shift-Key-Down> {set grid [expr $canvas_grid*$grid_unit]; if {$grid==0} {set grid 1}; moveItem 0 [expr 5*$grid*$cur_zoom] cur_id}
bind .c <Control-Alt-s> {getCanvasSnapshot .c}
bind .c <Alt-s> {splitTextEachLine $cur_id}
bind .c <Alt-j> {joinTextEachLine $cur_id}
bind .c <Alt-z> {fileBrowser}