Richard Suchenwirth - Things (something like objects, or classes) change. In On things, a dirt simple OO API was described, and an initial implementation in Doing things. It worked, but didn't satisfy me. So I decided to do it more orthogonally - which involved slight (and not bad) changes in the API, e.g.
thing new human ;# instead of: thing human human new Socrates ;# instead of: thing Socrates is-a human (*) thing names ;# instead of: thing -names Socrates legs ;# equivalent to: Socrates set legs Socrates which legs ;# new: tells where a property/way came from Socrates ;# new: returns a pairlist of all properties Socrates clone Diogenes ;# makes an identical thing, except for name
and with namespaces (after all, those were introduced for OO). Now ::thing holds the whole system. For a thing foo, a sub-namespace ::thing::foo is created (and has to be explicitly deleted). Basic ways (methods) are introduced for an initial thing ::thing::thing and inherited by all other things if not overridden. Ways are implemented as namespace procs (so I need not treat default arguments, args myself.. - and they are compiled), but can still be thrown around like real lambdas:
[philosopher new Plato] wayto sing [Socrates wayto sing]
Each way receives the thing's name as first argument (might be called "self", or "-" if ignored).
(*) Note on the is-a list: This is every thing's backbone, take care not to break it! A usable is-a list starts with the thing's name, then possibly has the superthings, and finally the thing 'thing'':
T2 set is-a {T2 SmartToaster Toaster thing}Thanks to Miguel Sofer for pointing out!
So here's the current (and still pretty minimal) framework for Things:
catch {namespace delete ::thing} ;# good for repeated sourcing in tests
namespace eval thing {
variable names [list] ;# initially, no things around
proc dispatch {name {way ""} args} {
# This is the core of the "things" engine
foreach i [set ${name}::is-a] {
if [llength [info command ${i}::$way]] {
return [eval ${i}::$way $name $args]
}
if [info exists ${i}::$way] {return [set ${i}::$way]}
}
error "$way? Use one of: [join [Info $name command] {, }]"
}
#----------------------------- some helpers for introspection
proc Info {name what} {
# retrieve all own and inherited procs/properties of 'name'
set res [list]
foreach i [set ${name}::is-a] {
foreach j [info $what ::thing::${i}::*] {
regsub ::thing::${i}:: $j "" j2
ladd res $j2
}
}
lsort $res
}
proc lambda {name way} {
# retrieve [list argl body] for way of thing name
foreach i [set ${name}::is-a] {
if [llength [set proc [info command ${i}::$way]]] {
set res "{"; set space ""
foreach i [info args $proc] {
if [info default $proc $i value] {
append res "$space{$i [list $value]}"
} else {append res "$space$i"}
set space " "
}
return [append res "} {[info body $proc]}"]
}
}
error "$way? No way for $name"
}
}Now we create and instrument the initial thing, but before that we have to create a way how to create (constructor, some call it):
namespace eval thing::thing {
proc 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"
}
if [llength $self] {
set t [concat $name [set ::thing::${self}::is-a]]
} else {
set t $name
}
namespace eval ::thing::$name variable is-a [list $t]
regsub @name {uplevel 1 thing::dispatch @name $args} $name body
proc ::$name args $body ;#--------- so it can be called by name
regsub @name {rename @name "" ;#} $name trace
trace var ::thing::${name}::is-a u $trace
lappend ::thing::names $name
foreach {key value} $args {$name set $key $value}
::set name
}
new {} thing ;#----------------- first "thing" to do
proc clone {self name args} {
$self new $name
foreach {key value} [concat [$self] $args] {
if {$key!="is-a"} {$name set $key $value}
}
namespace eval ::thing::${name} {
::set is-a [lreplace ${is-a} 1 1]
}
::set name
}
proc {} {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
}
proc set {self {name ""} args} {
#way to set, retrieve, or list properties
if {$name==""} {return [::thing::Info $self vars]}
switch [llength $args] {
0 {}
1 {::set ::thing::${self}::$name [lindex $args 0]}
default {error "Usage: $self set ?name ?value??"}
}
if [catch {::thing::dispatch $self $name} res] {
error "$name? No such property for $self"
}
::set res
}
proc unset {self args} {
foreach i $args {::unset ::thing::${self}::$i}
}
proc delete {self} {
lremove ::thing::names $self
namespace delete ::thing::$self
}
proc wayto {self {way _None_} args} {
# way to define a, retrieve a, or list every way available
if {$way=="_None_"} {return [::thing::Info $self command]}
switch [llength $args] {
0 {return [::thing::lambda $self $way]}
1 {eval proc ::thing::${self}::$way [lindex $args 0]}
default {error "Usage: $self wayto ?name ?lambda??"}
}
::set args
}
proc which {self name} {
# way to know where a property or way came from
#::set path [concat $self [::set ::thing::${self}::is-a]]
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"
}
}
proc lremove {_list what} {
upvar $_list list
set where [lsearch -exact $list $what]
set list [lreplace $list $where $where] ;# no harm when where=-1
}
#----------------------------------------------- now testing...
proc test {} {
set test {
thing new human legs 2 mortal 1
human new philosopher
philosopher new Socrates hair white
Socrates mortal
Socrates legs
Socrates set legs
Socrates set legs 3
Socrates legs
Socrates unset legs
Socrates 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
}
set n 0
foreach i [split $test \n] {
puts -nonewline [incr n]$i=>
puts [uplevel $i]
}
puts OK
}
time test # On my P200/W95 box at home, the test suite took 490..600 msec.
Richard - pretty nifty -K6-2/475,W98 - 110msec so 11/27/2000 -went back and unloaded the system - time dropped to 50-60msec
For a comparison with Itcl, see Toasters and things
Arts and crafts of Tcl-Tk programming
See Chaining things for a modified version that allows method chaining (among other slight changes).