#!/usr/bin/tclsh

# We no longer predefine the methods of a class.
# You can just freely implement new methods even after the class has been declared.
# You only have to follow a simple naming convention so that
# the object command can find the method.

# 'delete' procedure independent of the class.
proc delete {args} {
   foreach name $args {
      upvar #0 $name arr
      unset arr        ; # Deletes the object's data
      rename $name {}  ; # Deletes the object command
   }
}

# No more 'methods' argument here; 'vars' is optional.
proc class {classname {vars ""}} {

   # Create the class command, which will allow new instances to be created.
   set template {
      proc @classname@ {obj_name args} {
         # The class command in turn creates an object command.
         # Fewer escape characters thanks to the '@' sign.
         proc $obj_name {command args} \
            "return \[eval dispatch_@classname@ $obj_name \$command \$args\]"

         # Set variable defaults, if any
         upvar #0 $obj_name arr
         @set_vars@

         # Then possibly override those defaults with user-supplied values
         if { [llength $args] > 0 } {
            eval $obj_name configure $args
         }
      }
   }

   set set_vars "array set arr {$vars}"
   regsub -all @classname@ $template $classname template
   if { $vars != "" } {
      regsub -all @set_vars@  $template $set_vars template
   } else {
      regsub -all @set_vars@  $template "" template
   }

   eval $template

   # Create the dispatcher, which does not check what it
   # dispatches to.  It just follows the naming convention.
   set template {
      proc dispatch_@classname@ {obj_name command args} {
         upvar #0 $obj_name arr
         if { $command == "configure" || $command == "config" } {
            array set arr $args

         } elseif { $command == "cget" } {
            return $arr([lindex $args 0])

         } else {
            # Here you see the naming convention explicitly: classname_command.
            uplevel 1 @classname@_${command} $obj_name $args
         }
      }
   }

   regsub -all @classname@ $template $classname template

   eval $template
}

class apple {-color green -size 5 -price 10}
proc apple_byte {self} {
   puts "Taking a byte from apple $self"
   $self configure -size [expr [$self cget -size] - 1]
   if { [$self cget -size] <= 0 } {
      puts "Apple $self now completely eaten!  Deleting it..."
      delete $self
   }
}

class fridge
proc fridge_open {self} {
   if { [$self cget -state] == "open" } {
      puts "Fridge $self already open."
   } else {
      $self configure -state "open"
      puts "Opening fridge $self..."
   }
}

proc fridge_close {self} {
   if { [$self cget -state] == "closed" } {
      puts "Fridge $self already closed."
   } else {
      $self configure -state "closed"
      puts "Closing fridge $self..."
   }
}

apple a1 -size 3
apple a2 -color yellow -size 3

foreach i {1 2 3} {
   a1 byte
   a2 byte
}


fridge f1 -state open
f1 close
f1 close
f1 open
f1 open
f1 close


# Even after 'f1' is created, we can add a new method to the 'fridge'
# class.  'f1' automatically gets the new method.
proc fridge_paint {self color} {
   puts "Painting fridge $self $color ..."
}

f1 paint green
f1 open
f1 paint blue