draw.tcl

很不错的tcl编程实例

#!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" "$@"


# Copyright 1996

# Authors

# Lakshmi Sastry
# Computing and Information Systems Department
# Rutherford Appleton Laboratory, Chilton, Didcot. OX11 0QX
# [e-mail]

#                         and

# Venkat VSS Sastry
# Department of Applied Mathematics and Operational Research
# Cranfield University, RMCS Shrivenham, Swindon, SN6 8LA
# [e-mail]

# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies.
  
# The authors, RAL, RMCS Shrivenham, Cranfield University and AGOCG
# make no representations about the suitability of this
# software for any purpose.  It is provided "as is" without
# express or implied warranty. Likewise they accept no responsibility
# whatsoever for any public domain software modules used (which are
# hereby acknowledged) in this software 


set sb {}

frame .fr -width 24c -height 13.6c -bd 2 ;#main frame
pack .fr
wm title . "Canvas"
frame .fr.menubar -relief raised -bd 2
pack .fr.menubar -padx 1 -fill x

frame .fr.panl -width 3.6c -height 12.8c -bg black
frame .cfr -width 20.4c -height 12.4c -bd 1

pack .fr.panl .cfr -in .fr -side left -padx 2 -after .fr.menubar -fill x

canvas .can -width 20c -height 12.0c -bg grey -xscrollcommand ".xs set" \
	-yscrollcommand ".ys set"
scrollbar .ys -command ".can yview" 
pack .can .ys -in .cfr -side left -fill x -fill y
scrollbar .xs -orient horizontal -command ".can xview"
place .xs -in .fr -x 3.8c -y 13.3c -width 20.2c

bind .can <Button-1> {GetStarted %x %y}
bind .can <ButtonRelease-1> { LetGo %x %y}
bind .can <Button1-Motion> {KeepMoving %x %y}

button .rect  -image [image create bitmap \
-file  "./bitmaps/boxOp.xbm"]  -com {set sb "rectangle"}
button .circ  -image [image create bitmap -file  "./bitmaps/ovalOp.xbm"] \
	 -com {set sb "oval" }
button .lin  -image [image create bitmap -file  "./bitmaps/lineOp.xbm"] \
	 -com {set sb "line" }
button .txt  -image [image create bitmap -file  "./bitmaps/textOp.xbm"] \
	 -com {set sb "text"}
button .selob  -image [image create bitmap -file  "./bitmaps/selectOp.xbm"] \
	 -com {set sb "obj" }
label .txtlab -text "Text : "
entry .txtstr -textvariable str -relief sunken -width 10

place .rect -in .fr.panl -x 2 -y 1
place .circ -in .fr.panl -x 60 -y 1
place .lin -in .fr.panl -x 2 -y 60
place .txt -in .fr.panl -x 2 -y 120
place .selob -in .fr.panl -x 60 -y 60
place .txtlab -in .fr.panl -x 2 -y 180
place .txtstr -in .fr.panl -x 20 -y 220


#fill the  top menu
menubutton .fr.menubar.file -text File -underline 0 -menu .fr.menubar.file.menu
menubutton .fr.menubar.edit -text Edit -underline 0 -menu .fr.menubar.edit.menu
menubutton .fr.menubar.graphics -text Graphics -underline 0 -menu \
		.fr.menubar.graphics.menu
pack .fr.menubar.file .fr.menubar.edit .fr.menubar.graphics -side left
menubutton .fr.menubar.help -text Help -underline 0 
pack .fr.menubar.help -side right

menu .fr.menubar.file.menu
.fr.menubar.file.menu add command -label Print -command {printCanvas}
.fr.menubar.file.menu add command -label Quit -command exit

menu .fr.menubar.edit.menu
.fr.menubar.edit.menu add command -label Cut -com {CutSelection}
.fr.menubar.edit.menu add command -label Clear -com {clearCanvas}

#Graphics menu
menu .fr.menubar.graphics.menu
.fr.menubar.graphics.menu add cascade -label "Line Width" \
	-menu .fr.menubar.graphics.menu.fmenu
menu .fr.menubar.graphics.menu.fmenu
.fr.menubar.graphics.menu.fmenu add radiobutton -label "0.5" \
		-com {set lw 0.5}
.fr.menubar.graphics.menu.fmenu add radiobutton -label "2.0" \
	-com { set lw 2.0 }
set lw 1.0


proc CutSelection {} {
global so
.can delete $so
}

proc GetStarted {x y} {

	global x1 y1 sb so str eo lw


	set x1 $x
	set y1 $y

	if {[string compare $sb ""] == 0 } {
		return
	}
	if {[string compare $sb "text"] == 0 && ${str} != "" } {
		set so [.can create text $x $y -text $str  -anchor sw]
		.can addtag $sb$so closest $x $y
		return
	}

	if { [string compare $sb "obj"] == 0} {
		set so [.can create rectangle $x $y $x $y -fill {} -outline red]
		set eo $so
		return
	} 
	if {[string compare $sb "line"] == 0 } {
		set so [.can create $sb $x1 $y1 $x $y  ]
		.can addtag $sb$so enclosed $x1 $y1 $x $y
	} else {
		set so [.can create $sb $x1 $y1 $x $y -fill {} -outline black ]
		.can addtag $sb$so enclosed $x1 $y1 $x $y
	}
			
}


proc KeepMoving {x y} {

	global x1 y1 so sb
	
	if {[string compare $sb ""] == 0 } {
		return
	}
	if {[string compare $sb "text"] == 0 } {
		return
	}


	.can coords $so $x1 $y1 $x $y

}

proc LetGo {x y} {

	global x1 y1 so sb eo

	if {[string compare $sb ""] == 0 } {
		return
	}

	if { [string compare $sb "obj"] == 0} {
		set so [.can find enclosed $x1 $y1 $x $y]
		foreach s $so {
			if { [string compare -length 4 [.can gettags $s] "text"] == 0} {
				.can itemconfigure $s -fill green 
			} elseif { [string compare -length 4 [.can gettags $s] "line"] == 0} {
				.can itemconfigure $s -fill green
			} else {
				.can itemconfigure $s -fill {} -outline green
			}
		}
		.can delete $eo
	}
}

proc printCanvas {} {

.can postscript -file "canvas.ps"
}
proc clearCanvas {} {
	foreach id [.can  find all] { .can delete $id }
}