[GPS]: I like playing with new interfaces and object systems.  This package sort of evolved from several ideas I had.  It's simple, fast, and unique. 

Use this code however you like, but I would like to know how you use it, so leave a comment or email me[mailto:GeorgePS@XMission.com].

----
''UPDATED'' April 8, 2003 with an almost complete rewrite and now a demo widget.  I'm now using SDynObject successfully with several projects.  I updated a few comments above too. 

 package provide SDynObject 1.0
 
 #BEGIN OBJECT SYSTEM - SDynObject
 proc sd.get.unique.id {} {
   while 1 {
     set id [clock clicks]
     if {"" == [info commands $id]} {
       return $id
     }
   }
 }
 
 proc sd.new.object {} {
   set id [sd.get.unique.id]
   interp alias {} $id {} __sd.instance $id
   return $id
 }
 
 proc __sd.instance {id args} {
   upvar #0 _obj$id ar
   set al [llength $args]
   if {1 == $al} {
     set mem [lindex $args 0]
     if {![info exists ar($mem)]} {
       return -code error "no member named $meth in $id"
     }
     return [set ar($mem)]
   } elseif {2 == $al} {
     foreach {mem value} $args break
     set ar($mem) $value
   } else {
     return -code error "bad number of arguments sent to $id; $args"
   }
 }
 
 proc sd.call {meth _ id args} {
   upvar #0 _obj$id ar
 
   if {![info exists ar($meth)]} {
     return -code error "no method named $meth in $id"
   }
   namespace eval :: [set ar($meth)] $args
 }
 
 proc sd.new.method {name _ id _ takes body} {
   upvar #0 _obj$id ar
   set methodId [sd.get.unique.id]
   proc ::$methodId $takes "set self $id\n$body"
   set ar($name) $methodId
 
   if {![info exists ::_obj[set id](__methodList)]} {
     set ar(__methodList) [list]
   }
 
   lappend ar(__methodList) $methodId
   
   return $methodId
 }
 
 proc sd.dereference {id mem} {
   return "::_obj[set id]($mem)"
 }
 
 proc sd.dereference.cmd {id cmd} {
   return [set ::_obj[set id]($cmd)]
 }
 
 proc sd.destroy.object {id} {
   upvar #0 _obj$id ar
 
   foreach method $ar(__methodList) {
     catch {rename $method {}}
   }
   array unset ar
 }
 
----
''DEMO''

 source ./SDynObject.tcl
 
 proc box {win args} {
   set b [sd.new.object]
   $b size 200
   $b color royalblue
   $b delay 20 
   $b busy 0
 
   frame $win -class Box -bg [$b color] \
   -width [$b size] -height [$b size]  
   
   $b win $win
 
   sd.new.method fade.to.black for $b takes {win r g b} {
     if {$r < 1 || $g < 1 || $b < 1} {
       $win configure -bg [$self color]
       $self busy 0
       return
     }
     set col [format {#%2.2x%2.2x%2.2x} $r $g $b]
     $win config -bg $col
 
     incr r -1
     incr g -1
     incr b -1
 
     after [$self delay] [list sd.call fade.to.black in $self $win $r $g $b]
   }
 
   sd.new.method begin.fading for $b takes {win r g b} {
     if {[$self busy]} {
       #already running
     }
 
     $self busy 1
     sd.call fade.to.black in $self $win $r $g $b
   }
 
 
   set fadeCmd [list [sd.dereference.cmd $b begin.fading] $win 255 255 255]
 
   bind $win <Expose> $fadeCmd
   bind $win <ButtonPress-1> $fadeCmd 
   
   return $win
 }
 
 pack [box .b] -fill both -expand 1
----
[Category Object Orientation]