Open Mash Cross Reference
mash/tcl/psvp/parameter.tcl

   # parameter.tcl --
   #
   #       This file defines the Parameter class and many subclasses.
   #
   # Copyright (c) 1998-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.
  
  # Each subclass of Parameter must provide implementations for
  # the following methods:
  #
  # get
  # set
  # type
  # domain
  
  Class Parameter;
  
  Parameter instproc init args {
      eval $self next $args;
  }
  
  Class ColorParameter -superclass Parameter
  
  ColorParameter instproc init args {
      $self instvar from_l_ to_l_ from_cr_ to_cr_ from_cb_ to_cb_
      $self instvar current_l_ current_cr_ current_cb_
  
      set from_l_ 0
      set to_l_ 255
      set from_cr_ 0
      set to_cr_ 255
      set from_cb_ 0
      set to_cb_ 255
      set current_l_ 0
      set current_cr_ 128
      set current_cb_ 128
  
      eval $self next $args
  }
  
  ColorParameter instproc from args {
      $self instvar from_l_ from_cr_ from_cb_
  
      if {[llength $args] == 1} {
          set from_l_ [lindex [lindex $args 0] 0]
          set from_cr_ [lindex [lindex $args 0] 1]
          set from_cb_ [lindex [lindex $args 0] 2]
      }
      return [list $from_l_ $from_cr_ $from_cb_];
  }
  
  ColorParameter instproc to args {
      $self instvar to_l_ to_cr_ to_cb_
  
      if {[llength $args] == 1} {
          set to_l_ [lindex [lindex $args 0] 0]
          set to_cr_ [lindex [lindex $args 0] 1]
          set to_cb_ [lindex [lindex $args 0] 2]
      }
      return [list $to_l_ $to_cr_ $to_cb_];
  }
  
  ColorParameter instproc get {} {
      $self instvar current_l_ current_cr_ current_cb_
  
      return [list $current_l_ $current_cr_ $current_cb_]
  }
  
  ColorParameter instproc set {color} {
      $self instvar from_l_ from_cr_ from_cb_
      $self instvar current_l_ current_cr_ current_cb_
      $self instvar to_l_ to_cr_ to_cb_
  
      set new_l [lindex $color 0]
      set new_cr [lindex $color 1]
      set new_cb [lindex $color 2]
 
 
     if {$new_l < $from_l_} {
         set current_l_ $from_l_;
     } elseif {$new_l > $to_l_} {
         set current_l_ $to_l_
     } else {
         set current_l_ $new_l
     }
 
     if {$new_cr < $from_cr_} {
         set current_cr_ $from_cr_;
     } elseif {$new_cr > $to_cr_} {
         set current_cr_ $to_cr_
     } else {
         set current_cr_ $new_cr
     }
 
     if {$new_cb < $from_cb_} {
         set current_cb_ $from_cb_;
     } elseif {$new_cb > $to_cb_} {
         set current_cb_ $to_cb_
     } else {
         set current_cb_ $new_cb
     }
 
     return [$self get];
 }
 
 ColorParameter instproc type {} {
     return "color"
 }
 
 ColorParameter instproc domain {} {
     $self instvar from_l_ to_l_
     $self instvar from_cr_ to_cr_
     $self instvar from_cb_ to_cb_
 
     return "{{$from_l_ $from_cr_ $from_cb_} {$to_l_ $to_cr_ $to_cb_}}"
 }
 
 Class RealParameter -superclass Parameter
 
 RealParameter instproc init args {
     $self instvar from_ to_ current_;
     set from_ 0.0;
     set to_ 1.0;
     set current_ 0.0;
     eval $self next $args;
 }
 
 RealParameter instproc from args {
     $self instvar from_;
 
     if {[llength $args] == 1} {
         set from_ $args;
     }
     return $from_;
 }
 
 RealParameter instproc to args {
     $self instvar to_;
 
     if {[llength $args] == 1} {
         set to_ $args;
     }
     return $to_;
 }
 
 RealParameter instproc get {} {
     $self instvar current_;
 
     return $current_;
 }
 
 RealParameter instproc set value {
     $self instvar current_ from_ to_;
 
     if {$value < $from_} {
         set current_ $from_;
     } elseif {$value > $to_} {
         set current_ $to_;
     } else {
         set current_ $value;
     }
     return $current_;
 }
 
 RealParameter instproc type {} {
     return "real";
 }
 
 RealParameter instproc domain {} {
     $self instvar from_ to_;
 
     return "($from_,$to_)"
 }
 
 Class IntParameter -superclass Parameter
 
 IntParameter instproc init args {
     $self instvar from_ to_ current_;
 
     set from_ 0;
     set to_ 1;
     set current_ 0;
     eval $self next $args;
 }
 
 IntParameter instproc from args {
     $self instvar from_;
 
     if {[llength $args] == 1} {
         set from_ [expr int($args)];
     }
     return $from_;
 }
 
 IntParameter instproc to args {
     $self instvar to_;
 
     if {[llength $args] == 1} {
         set to_ [expr int($args)];
     }
     return $to_;
 }
 
 IntParameter instproc get {} {
     $self instvar current_;
 
     return $current_;
 }
 
 IntParameter instproc set value {
     $self instvar current_ from_ to_;
 
     if {$value < $from_} {
         set current_ $from_;
     } elseif {$value > $to_} {
         set current_ $to_;
     } else {
         set current_ [expr int($value)];
     }
     return $current_;
 }
 
 IntParameter instproc type {} {
     return "int";
 }
 
 IntParameter instproc domain {} {
     $self instvar from_ to_;
 
     return "($from_,$to_)"
 }
 
 Class TextParameter -superclass Parameter
 
 TextParameter instproc init args {
     $self instvar current_;
     set current_ "";
     eval $self next $args;
 }
 
 TextParameter instproc get {} {
     $self instvar current_;
 
     return $current_;
 }
 
 TextParameter instproc set value {
     $self instvar current_;
 
     set current_ $value;
     return $current_;
 }
 
 TextParameter instproc type {} {
     return "text";
 }
 
 TextParameter instproc domain {} {
     return "all"
 }
 
 Class ExclusiveChoiceParameter -superclass Parameter
 
 ExclusiveChoiceParameter instproc init args {
     $self instvar current_;
     $self instvar choices_;
     set current_ "";
     set choices_ "";
     eval $self next $args;
 }
 
 ExclusiveChoiceParameter instproc get {} {
     $self instvar current_;
 
     return $current_;
 }
 
 ExclusiveChoiceParameter instproc set value {
     $self instvar current_ choices_
 
     if {[lsearch $choices_ $value] != -1} {
         set current_ $value;
         return $current_;
     }
 }
 
 ExclusiveChoiceParameter instproc type {} {
     return "exclusive_choice";
 }
 
 ExclusiveChoiceParameter instproc domain {} {
     $self instvar choices_;
     return $choices_;
 }
 
 ExclusiveChoiceParameter instproc add {new_choice} {
     $self instvar choices_;
 
     lappend choices_ $new_choice;
 }
 
 Class RectSubregionParameter -superclass Parameter
 
 RectSubregionParameter instproc init args {
     $self instvar current_
 
     set current_ "0.25 0.25 0.75 0.75";
     eval $self next $args;
 }
 
 RectSubregionParameter instproc get {} {
     $self instvar current_;
 
     return $current_;
 }
 
 RectSubregionParameter instproc set value {
     $self instvar current_;
 
     set current_ $value;
     return $current_;
 }
 
 RectSubregionParameter instproc type {} {
     return "rect_subregion";
 }
 
 RectSubregionParameter instproc domain {} {
     return "all"
 }