#######################################################################
 # The very basic infrastructure
 #######################################################################
 catch {namespace delete ::thing} ;# good for repeated sourcing in tests
 namespace eval thing {
     proc dispatch {name way lst} {
         # This is the core of the "things" engine
         set level 0
         foreach i [set ::thing::${name}::is-a] {
             if [llength [info command [set cmd ${i}::$way]]] {
                 return [eval $cmd $name $lst]
             }
             incr level; #-# we now count the levels
         }
         error "$way? Use one of: [join [Info $name command] {, }]"
     }
     proc chain {args} {
         #-# new proc, almost the same as dispatch!
         upvar 2 name name  level level0  way way
         set level [expr {$level0 + 1}]
         foreach i [lrange [::set ::thing::${name}::is-a] $level end] {
             if [llength [info command [set cmd ${i}::$way]]] {
                 return [eval $cmd $name $args]
             }
             incr level
         }
     }
     proc get {name var} {
         #-# new proc, avoids the shadowing effect
         foreach i [set ::thing::${name}::is-a] {             
             if [llength [info vars [set nvar ${i}::$var]]] {
                 return [set $nvar]
             }
         }
         error "$var? No such property for $name"
     }
     #-- create "basic things": they can ONLY get new ways ...
     proc wayto {self way lambda} {
         # way to define a new way. 
         eval proc ::thing::${self}::$way $lambda
     }  
     namespace export wayto
     proc new {name} {
         namespace eval ::thing::$name {
             namespace import ::thing::wayto
         }
         ::set ::thing::${name}::is-a $name
         trace add variable ::thing::${name}::is-a unset "::rename ::$name {};#"
         proc ::$name {{way ""} args} "::thing::dispatch $name \$way \$args"
     }
     #----------------------------- some helpers for introspection
     proc names {} {
         foreach i [namespace children ::thing] {
             regsub ::thing:: $i "" name
             lappend names $name
         }
         lsort $names
     }
     proc Info {name what} {
         # retrieve all own and inherited procs/properties of 'name'
         foreach i [set ::thing::${name}::is-a] {
             foreach j [info $what ::thing::${i}::*] {
                 regsub ::thing::${i}:: $j "" j2
                 set res($j2) {}
             }
         }
         lsort [array names res]
     }
     proc lambda {name way} {
         # retrieve [list argl body] for way of thing name
         #-# it builds a list, not a string
         foreach i [set ${name}::is-a] {
             if [llength [set proc [info command ${i}::$way]]] {
                 foreach i [info args $proc] {
                     if [info default $proc $i value] {
                         lappend args [list $i $value]
                     } else {
                         lappend args $i
                     }
                 }
                 return [list $args [info body $proc]]
             }
         }
         error "$way? No way for $name"
     }
 }

 #######################################################################
 # Create the minimal thing: it can ONLY get new ways ...
 #######################################################################
 ::thing::new thing
 
 #######################################################################
 # giving thing some capabilities ...
 # -------------------------------------------
 # 1: deal with itself: reproduce, suicide
 #
 thing wayto new {
     {self name args} {
         #way to create a new thing 'name' that is-a 'self'
         if [llength [::info command ::$name]] {
             error "can't create thing $name: command exists"
         }
         ::set t [concat $name [::set ::thing::${self}::is-a]]
         namespace eval ::thing::$name variable is-a [list $t]
         trace add variable ::thing::${name}::is-a unset "::rename $name {};#"
         #--------- so it can be called by name
         proc ::$name {{way ""} args} "::thing::dispatch $name \$way \$args"
         foreach {key value} $args {$name set $key $value}
         ::set name
     }
 }

 thing wayto clone {
     {self name args} {
         eval $self new $name [$self] $args
         namespace eval ::thing::$name "::set is-a \[lreplace \${is-a} 0 0 $name\]"
         ::set pre ::thing::${self}
         foreach i [::info proc ${pre}::*] {
             regsub ${pre}:: $i "" i2
             ::thing::wayto $name $i2 [$self wayto $i2]
         }
         if {[llength [::info proc ${pre}::wayto]]} {
             if {[::set orig [namespace origin ${pre}::wayto]] != $pre} {
                 ::rename ::thing::${name}::wayto ::""
                 namespace eval ::thing::${name} namespace import ${orig}
             }
         }
         ::set name
     }
 }

 thing wayto delete {
     {self} {
         namespace delete ::thing::$self
     }
 }

 # -------------------------------------------
 # 2: deal with internal variables: set, unset
 #
 thing wayto set {
     {self args} {
         #way to set, retrieve, or list properties
         switch [llength $args] {
             1 {return [::thing::get $self [lindex $args 0]]}
             2 {
                 foreach {name value} $args {
                     return [::set ::thing::${self}::$name $value]
                 }
             }
             0 {return [::thing::Info $self vars]}
             default {error "Usage: $name set ?name ?value??"}
         }
     }
 }
 
 thing wayto unset {
     {self args} {
         foreach i $args {::unset ::thing::${self}::$i}
     }
 }
 #----------------------------------------------------------
 # 3: rename ways, remove unneeded ones
 #
 thing wayto rename {
     {self way newWay} {
         if {$newWay == ""} {
             namespace inscope :: rename ::thing::${self}::$way {}
         } else {
             set ns ::thing::$self
             ::rename ${ns}::$way ${ns}::$newWay
         }
     }
 }
 #----------------------------------------------------------
 # 4: introspection, and an introspecting wayto
 #
 thing wayto wayto {
     {self args} {
         # way to define a, retrieve a, or list every way available
         foreach {way lambda} $args break
         switch [llength $args] {
             1 {return [::thing::lambda $self $way]}
             2 { 
                 eval proc ::thing::${self}::$way $lambda
                 return $lambda
             }
             0 {return [::thing::Info $self command]}
             default {error "Usage: $self wayto ?name ?lambda??"}
         }
     }
 }

 thing wayto is-a {
     {self} {
         ::set ::thing::${self}::is-a
     }
 }

 thing wayto {} {
     {self} {
         # empty way: pairlist of all property names and values
         ::set res [list]
         foreach i [lsort [::info var ::thing::${self}::*]] {
             regsub ::thing::${self}:: $i "" i2
             lappend res $i2 [::set $i]
         }
         ::set res
     }
 }

 thing wayto which {
     {self name} {
         # way to know where a property or way came from
         foreach i [::set ::thing::${self}::is-a] {
             if [llength [::info command ::thing::${i}::$name]] {
                 return $i
             }
             if [::info exists ::thing::${i}::$name] {
                 return $i
             }
         }
         error "no $name for $self known"
     }
 }
 thing wayto info {{self what} {::thing::Info $self $what}}


 #----------------------------------------------- now testing...
 proc test {} {
     set test {
         thing new human legs 2 mortal 1
         human new philosopher
         philosopher new Socrates hair white
         Socrates set mortal
         Socrates set legs
         Socrates set legs
         Socrates set legs 3
         Socrates set legs
         Socrates unset legs
         Socrates set legs
         Socrates set beard long
         Socrates set
         human wayto sing {{- text} {subst $text,$text,lala.}}
         Socrates sing Kalimera
         Socrates wayto sing {{- text} {subst $text-haha}}
         Socrates sing Kalimera
         [thing new Plato] wayto sing [Socrates wayto sing]
         Plato sing Kalispera
         [human new Joe] sing hey
         Socrates
         Socrates wayto sing {{- text} {subst "[::thing::chain $text-haha], $text-haha"}}
         Socrates sing Kalimera
      }
     set n 0
     foreach i [split $test \n] {
         puts -nonewline [incr n]$i=>
         puts [uplevel $i]
     }
     puts OK
 }

 time test