#!/usr/bin/tclsh

# We now introduce the very powerful 'class' procedure,
# which automates the creation of class commands,
# which in turn create the instance commands.

# '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
   }
}

proc class {classname vars methods} {

   # Create the class command, which will allow new instances to be created.
   proc $classname {obj_name args} "
      # The class command in turn creates an object command.  Careful
      # with those escape characters!
      proc \$obj_name {command args} \
         \"return \\\[eval dispatch_$classname \$obj_name \\\$command \\\$args\\\]\"

      # Set variable defaults
      upvar #0 \$obj_name arr
      array set arr {$vars}

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

   # Create the dispatcher, which dispatches to one of the class methods
   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 {
         if { \[lsearch {$methods} \$command\] != -1 } {
            uplevel 1 ${classname}_\${command} \$obj_name \$args
         } else {
            puts \"Error: Unknown command \$command\"
         }
      }
   "
}

class apple {-color green -size 5 -price 10} {byte}
proc apple_byte {self} {
   upvar #0 $self arr
   puts "Taking a byte from apple $self"
   incr arr(-size) -1
   if { $arr(-size) <= 0 } {
      puts "Apple $self now completely eaten!  Deleting it..."
      delete $self
   }
}

class fridge {-state closed -label A} {open close}
proc fridge_open {self} {
   upvar #0 $self arr
   if { $arr(-state) == "open" } {
      puts "Fridge $self already open."
   } else {
      set arr(-state) "open"
      puts "Opening fridge $self..."
   }
}

proc fridge_close {self} {
   upvar #0 $self arr
   if { $arr(-state) == "closed" } {
      puts "Fridge $self already closed."
   } else {
      set arr(-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