Socrates set sing badlyThis command does set a variable named sing for Socrates, but (a) it returns an error, and (b) the variable is not accessible through Socrates's ways ...In order to fix this, I eliminated the possibility of finding Socrates' number of legs by simply
Socrates legsThe usage of a way is now compulsory, you now DO have to
Socrates set legs2. an API extension: added the capability to chain commands - i.e., to call a same-named way at lower levels. For instance
Socrates wayto sing {
{- text} {
subst "$text-haha, but also [::thing::chain $text]"
}
}will substitute the human song for the expression in brackets ...3. slight API change: the names of currently existing things can be retrieved by either of namespace children ::thing
::thing::namesThe list ::thing::names does not exist any longer ...4. didactical changes: I thought it interesting to restructure the file so that the properties of thing are defined using a minimal infrastructure and defining new properties via thing wayto .... Added some comments.5. attempts at optimisation: some slight changes - no really noticeable effect though ...6. cosmetic changes: these are (of course) quite personal ...ON THING (object) AGGREGATION (comments here are particularly appreciated)Things as defined here (as modified today) are created at global scope; if a fully qualified name is given (and the corresponding namespace already exists), the thing will be created in that namespace. Same-named things in different namespaces will not collide if they were created using fully qualified names.In this sense thing aggregation is already present in this model:
namespace eval ::realEstate {}
thing new ::realEstate::house3
namespace eval ::realEstate::house3 {}
thing new ::realEstate::house3::kitchencreates the things::realEstate::house3 and ::realEstate::house3::kitchen;their vars and ways live under
::thing::realEstate::house3 and ::thing::realEstate::house3::kitchenrespectively.It is easy to extend this behaviour to allow for correct thing creation when given a relative name, in the manner of
namespace eval ::realEstate {
thing new house3
}
namespace eval ::realEstate::house3 {
thing new kitchen
}However, I do not quite like this behaviour, and am thinking about alternatives. What I dislike is:- the existence of TWO different namespaces for the same thing (one at ::, the other at ::thing)
- the extra parsing load for method calling
- the fact that the structure under ::thing lost its simplicity
- the fact that some namespaces under ::thing do not correspond to things - in the example, ::thing::realEstate (assuming ::realEstate is a bona-fide namespace, and not a thing)
%info body thing
::thing::dispatch 0 $way $argsinstead of the present %info body thing
::thing::dispatch thing $way $argsIn this model, the example above could be generated via an API like namespace eval ::realEstate {
thing new house3
house3 addChild thing new kitchen
}generating for instance the namespaces::thing::25 and ::thing::26and a proc
::thing::25::kitchenNow the sub-thing "kitchen" is a wayto of house3, so that you would call
::realEstate::house3 kitchen set heatSource electricityor
namespace eval ::realEstate {
house3 kitchen set heatSource electricity
}What I like about this one is:- all things live directly under ::thing - simple structure
- everything under ::thing IS a thing
- sub-things are simply waytos of the containing thing
- it is easy to move things from one container to the other - it rarely happens that kitchens are moved, but football players do switch teams ...
- it generates recursive calls to the dispatcher
- it is difficult to introspect - distinguish between 'real waytos' and sub-things?
- things require an additional variable (@name maybe) to store the name of the command
NOTES ON USAGE AND CAPABILITIESRemark that the is-a list controls the search path for ways and variables; you can actually do anything you want with it - at your own risk! Some creative uses might be
- prepend another thing to obtain a mixin behaviour (the ways and variables of the prepended thing will have priority over the own ones; these are reachable via ::thing::chain)
- insert other things to obtain the effect of multiple inheritance with a clearly defined priority path
THE CODE (revised 15-dec-2000)
#######################################################################
# 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 var ::thing::${name}::is-a u "::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 var ::thing::${name}::is-a u "::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