Open Mash Cross Reference
mash/tcl/psvp/rect_subregion-ui.tcl

   # rect_subregion-ui.tcl --
   #
   #       FIXME: This file needs a description here.
   #
   # Copyright (c) 1999-2002 The Regents of the University of California.
   # All rights reserved.
   #
   # Redistribution and use in source and binary forms, with or without
   # modification, are permitted provided that the following conditions are met:
  #
  # A. Redistributions of source code must retain the above copyright notice,
  #    this list of conditions and the following disclaimer.
  # B. Redistributions in binary form must reproduce the above copyright notice,
  #    this list of conditions and the following disclaimer in the documentation
  #    and/or other materials provided with the distribution.
  # C. Neither the names of the copyright holders nor the names of its
  #    contributors may be used to endorse or promote products derived from this
  #    software without specific prior written permission.
  #
  # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
  # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
  # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  Class RectSubregionUI;
  
  RectSubregionUI instproc init {pframe} {
      $self instvar can_;
  
      set can_ [canvas $pframe.$self -width 120 -height 120];
      pack $can_ -side top;
  
      $self instvar outter_ inner_ ul_ ur_ ll_ lr_;
  
      set outter_ [$can_ create rect 10 10 110 110];
      set inner_ [$can_ create rect 20 20 100 100];
      set ul_ [$can_ create rect 15 15 25 25 -fill green];
      set ur_ [$can_ create rect 95 15 105 25 -fill green];
      set ll_ [$can_ create rect 15 95 25 105 -fill green];
      set lr_ [$can_ create rect 95 95 105 105 -fill green];
  
      $can_ bind $ul_ <B1-Motion> "$self move_handle ul %x %y";
      $can_ bind $ur_ <B1-Motion> "$self move_handle ur %x %y";
      $can_ bind $ll_ <B1-Motion> "$self move_handle ll %x %y";
      $can_ bind $lr_ <B1-Motion> "$self move_handle lr %x %y";
      $can_ bind $ul_ <B2-Motion> "$self move_box ul %x %y";
      $can_ bind $ur_ <B2-Motion> "$self move_box ur %x %y";
      $can_ bind $ll_ <B2-Motion> "$self move_box ll %x %y";
      $can_ bind $lr_ <B2-Motion> "$self move_box lr %x %y";
  
  }
  
  RectSubregionUI instproc move_box {hndl x y} {
      $self instvar inner_ ul_ ur_ ll_ lr_ can_;
  
      set ic [$can_ coords $inner_];
  
      set x1 [lindex $ic 0];
      set x2 [lindex $ic 2];
      set y1 [lindex $ic 1];
      set y2 [lindex $ic 3];
  
      if {$x1 > $x2} {
          set t $x2;
          set x2 $x1;
          set x1 $t;
      }
      if {$y1 > $y2} {
          set t $y2;
          set y2 $y1;
          set y1 $t;
      }
  
      set width [expr $x2 - $x1];
      set height [expr $y2 - $y1];
  
      if {$hndl == "ul"} {
          set x1 $x;
          set y1 $y;
          set x2 [expr $x1+$width];
          set y2 [expr $y1+$height];
      } elseif {$hndl == "ur"} {
          set x2 $x;
          set y1 $y;
          set x1 [expr $x2-$width];
          set y2 [expr $y1+$height];
      } elseif {$hndl == "ll"} {
          set x1 $x;
          set y2 $y;
          set x2 [expr $x1+$width];
          set y1 [expr $y2-$height];
      } else {
          set x2 $x;
         set y2 $y;
         set x1 [expr $x2-$width];
         set y1 [expr $y2-$height];
     }
 
     if {$x1 < 10} {
         set x1 10;
         set x2 [expr 10+$width];
     }
     if {$x2 > 110} {
         set x2 110;
         set x1 [expr 110-$width];
     }
     if {$y1 < 10} {
         set y1 10;
         set y2 [expr 10+$height];
     }
     if {$y2 > 110} {
         set y2 110;
         set y1 [expr 110-$height];
     }
 
     $can_ coords $inner_ $x1 $y1 $x2 $y2;
     $can_ coords $ul_ [expr $x1 - 5] [expr $y1 - 5] [expr $x1 + 5] [expr $y1 + 5]
     $can_ coords $ur_ [expr $x2 - 5] [expr $y1 - 5] [expr $x2 + 5] [expr $y1 + 5]
     $can_ coords $ll_ [expr $x1 - 5] [expr $y2 - 5] [expr $x1 + 5] [expr $y2 + 5]
     $can_ coords $lr_ [expr $x2 - 5] [expr $y2 - 5] [expr $x2 + 5] [expr $y2 + 5]
 
     $self do_command;
 }
 
 RectSubregionUI instproc move_handle {hndl x y} {
     $self instvar ul_ ur_ ll_ lr_ can_;
 
     if {$x < 10} {
         set x 10;
     }
     if {$y < 10} {
         set y 10;
     }
     if {$x > 110} {
         set x 110;
     }
     if {$y > 110} {
         set y 110;
     }
 
     if {$hndl == "ul"} {
         set h1 $ul_;
         set h2 $ll_;
         set h3 $ur_;
     }
     if {$hndl == "ll"} {
         set h1 $ll_;
         set h2 $ul_;
         set h3 $lr_;
     }
     if {$hndl == "ur"} {
         set h1 $ur_;
         set h2 $lr_;
         set h3 $ul_;
     }
     if {$hndl == "lr"} {
         set h1 $lr_;
         set h2 $ur_;
         set h3 $ll_;
     }
 
     $can_ coords $h1 [expr $x - 5] [expr $y - 5] [expr $x + 5] [expr $y + 5];
 
     set h2c [$can_ coords $h2];
     $can_ coords $h2 [expr $x - 5] [lindex $h2c 1] [expr $x+5] [lindex $h2c 3];
 
     set h3c [$can_ coords $h3];
     $can_ coords $h3 [lindex $h3c 0] [expr $y - 5] [lindex $h3c 2] [expr $y+5];
 
     $self instvar inner_
 
     set x1 [expr int(([lindex [$can_ coords $ul_] 0] + [lindex [$can_ coords $ul_] 2]) / 2)];
     set x2 [expr int(([lindex [$can_ coords $lr_] 0] + [lindex [$can_ coords $lr_] 2]) / 2)];
     set y1 [expr int(([lindex [$can_ coords $ul_] 1] + [lindex [$can_ coords $ul_] 3]) / 2)];
     set y2 [expr int(([lindex [$can_ coords $lr_] 1] + [lindex [$can_ coords $lr_] 3]) / 2)];
 
     $can_ coords $inner_ $x1 $y1 $x2 $y2;
 
     $self do_command;
 }
 
 RectSubregionUI instproc get {} {
     $self instvar inner_ can_;
 
     set c [$can_ coords $inner_];
 
     set x1 [expr ([lindex $c 0] - 10.0) / 100.0];
     set x2 [expr ([lindex $c 2] - 10.0) / 100.0];
     set y1 [expr ([lindex $c 1] - 10.0) / 100.0];
     set y2 [expr ([lindex $c 3] - 10.0) / 100.0];
 
     if {$x1 > $x2} {
         set t $x2;
         set x2 $x1;
         set x1 $t;
     }
 
     if {$y1 > $y2} {
         set t $y2;
         set y2 $y1;
         set y1 $t;
     }
 
     return [list $x1 $y1 $x2 $y2];
 }
 
 RectSubregionUI instproc set {c} {
 
     set x1 [expr int(([lindex $c 0] * 100.0) + 10.0)];
     set x2 [expr int(([lindex $c 2] * 100.0) + 10.0)];
     set y1 [expr int(([lindex $c 1] * 100.0) + 10.0)];
     set y2 [expr int(([lindex $c 3] * 100.0) + 10.0)];
 
     $self move_handle ul $x1 $y1;
     $self move_handle lr $x2 $y2;
 }
 
 RectSubregionUI instproc set_command {cmd} {
     $self instvar cmd_;
 
     set cmd_ $cmd;
 }
 
 RectSubregionUI instproc do_command {} {
     $self instvar cmd_;
 
     if {[info exists cmd_]} {
         eval $cmd_ [list [$self get]];
     }
 }