
toplevel .b
label .b.lfx -text "fx" 
entry .b.fx -textvariable fx -width 18
pack .b.lfx
pack .b.fx
label .b.lfz -text "fz" 
entry .b.fz -textvariable fz -width 18
pack .b.lfz
pack .b.fz
label .b.lsx -text "sx" 
entry .b.sx -textvariable sx -width 18
pack .b.lsx
pack .b.sx
label .b.lsz -text "sz" 
entry .b.sz -textvariable sz -width 18
pack .b.lsz
pack .b.sz



label .b.lt -text "titolo"
entry .b.ti -textvariable titolo -width 40
pack .b.lt
pack .b.ti

label .b.lt1 -text "titolo1"
entry .b.ti1 -textvariable titolo1 -width 40
pack .b.lt1
pack .b.ti1




button .b.bu -text "dessin" -command {

#destroy .c
# canvas .c -width $WC -height $HC
#  pack  .c
.c delete -tag all

.c create line  0 0 1 0  -tag AA   -fill magenta  -width 2
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA

 source tcldisegnoxz
 disegnaquadri

}
pack .b.bu
button .b.q -text "QUIT" -command {
exit
}
pack .b.q
button .b.s -text "imprimer" -command {
  set pippo " "
  if { $orient == 0 } {

     set pippo " -pagey 154m      -pagex 105m "
	   set pippo " -pageheight 200m $pippo  -rotate 1 "
  } else {
    set pippo "  -pagey 152m -pagex 105m "
	  set pippo " -pageheight 280m  $pippo  -rotate 0 "
  }

  eval  " .c postscript $pippo   -file del.ps "

  exec    "/usr/bin/lpr" "del.ps"
}
pack .b.s
set WC 1000
set HC  712

checkbutton .b.ori -variable orient -command {
	global WC HC
	
	if { $orient == 0  } {
		set WC  1000
		set HC  712
	}	else {
		set WC  506
		set HC  712  		
	}	
	
	.c configure -width  $WC -height $HC
#destroy .c
# canvas .c -width $WC -height $HC
#  pack  .c
.c delete -tag all

.c create line  0 0 1 0  -tag AA   -fill magenta  -width 2
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA

 source tcldisegnoxz
 disegnaquadri

}

pack .b.ori




font create  solemio  -family courier  -size 20  -weight normal -slant roman -underline 1 -overstrike 0
font create  lure  -family courier  -size 18  -weight normal -slant italic  -underline 0 -overstrike 0
font create  title  -family helvetica  -size 20  -weight normal -slant roman -underline 0 -overstrike 0


proc disegnaquadri { } {
	global WC HC orient titolo  titolo1
	if  {  $orient == 1 } {
	 .c  create rectangle 0  0  $WC  50 -fill white -outline black
	
	 .c  create rectangle 0  [ expr " $HC - 10 " ]  [ expr " $WC + 10" ]  [ expr "$HC + 10" ]  -fill white -outline black
	 .c  create rectangle 0  [ expr " $HC - 10 " ]  $WC  $HC -fill white -outline black

	 .c  create rectangle 0  0  10  $HC -fill white -outline black
	
	 .c  create rectangle [ expr " $WC -10 " ]   0   [ expr " $WC + 10" ]  [ expr "$HC + 10" ]  -fill white -outline black
	 .c  create rectangle [ expr " $WC -10 " ]   0   $WC  $HC -fill white -outline black

	  .c create text  400 40  -text "LURE-Jobin Yvon " -justify left  -font lure
	  .c create text  400 10  -text "SOLEMIO " -justify left  -font solemio

	} else {
	 .c  create rectangle 0  0  $WC  50 -fill white -outline black

	 .c  create rectangle 0  [ expr " $HC - 10 " ]   [ expr " $WC + 10" ]  [ expr "$HC + 10" ]   -fill white -outline white
	 .c  create rectangle 0  [ expr " $HC - 10 " ]  $WC  $HC -fill white -outline black

	 .c  create rectangle -10  0  10  $HC -fill white  -outline white	
	 .c  create rectangle 0  0  10  $HC -fill white -outline black
	 .c  create rectangle [ expr " $WC -10 " ]   0   $WC  $HC -fill white -outline black
	  .c create text  800 40  -text "LURE-Jobin Yvon " -justify left  -font lure
	  .c create text  800 10  -text "SOLEMIO " -justify left  -font solemio
	}

	  .c create text  20 10  -text $titolo    -font title -anchor w
	  .c create text  20 40  -text $titolo1    -font title -anchor w

}











 canvas .c -width $WC -height $HC 
  pack  .c 
set fx 8.000000e+02 
set fz 8.000000e+02 
set sx 1.000000e+02 
set sz 1.000000e+02 
source tcldisegnoxz
disegnaquadri

bind  .c <Button-1> {
	global ax ay
	set ax %x
   set ay %y
}
bind  .c <Button-2> {

	global ax ay
	global bx by
	set Minx  [ expr   "  ( $ax    - $sx) / $fx         "]
	set Maxx  [ expr   "  ( $bx    - $sx) / $fz         "]

	set Miny  [ expr   "  ( $ay   - $sz) / $fx         "]
	set Maxy  [ expr   "  ( $by   - $sz) / $fz         "]

	set fx  [ expr "  $WC / ( $Maxx - $Minx      ) "]
	set fz  [ expr "  $HC / ( $Maxy - $Miny      ) "]


	set sx  [ expr " $WC /2  -  $fx * ( $Maxx + $Minx ) * 0.5  "]
	set sz  [ expr " $HC /2  -  $fz * ( $Maxy + $Miny ) * 0.5  "]



}

.c create line  0 0 1 0  -tag AA   -fill magenta  -width 2
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA
.c create line 0 0 1 0    -fill magenta  -width 2 -tag AA

bind  .c  <Button-3> {

	set ax 0
	set ay 0

	set bx $WC
	set by $HC

	set Minx  [ expr   "  ( $ax    - $sx) / $fx         "]
	set Maxx  [ expr   "  ( $bx    - $sx) / $fz         "]

	set Miny  [ expr   "  ( $ay   - $sz) / $fx         "]
	set Maxy  [ expr   "  ( $by   - $sz) / $fz         "]



	set fx  [ expr "   0.75 * $fx   "]
	set fz  [ expr "   0.75 * $fz   "]

	
	set sx  [ expr " $WC /2  -  $fx * ( $Maxx + $Minx ) * 0.5  "]
	set sz  [ expr " $HC /2  -  $fz * ( $Maxy + $Miny ) * 0.5  "]

}

bind  .c <B1-Motion> {
	global ax ay
	global bx by
	set bx %x
	set by %y
	
	set dx [ expr " ($bx - $ax) *1.0 / $WC  " ]
	set dy [ expr " ($by - $ay) *1.0 / $HC " ]
	
	if { $dx < $dy } {
		set bx [ expr " $ax + $dy * $WC " ]
	} else {
		set by [ expr " $ay + $dx * $HC" ]
	}	
	
	.c delete AA
	.c create line $ax $ay   $bx  $ay   -fill magenta  -width 2 -tag AA
	.c  create line  $ax $ay $ax  $by   -fill magenta  -width 2  -tag AA
	.c  create line   $bx $by $bx  $ay   -fill magenta  -width 2  -tag AA
	.c  create line   $bx $by $ax  $by   -fill magenta  -width 2  -tag AA
}	
