Updated 2016-09-06 14:25:37 by pooryorick

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

pep - There might be an error in the ::thing::thing:new proc, 'set' should be '::set'
if [llength $self] {
    ::set t [concat $name [::set ::thing::${self}::is-a]]
} else {
    ::set t $name
}

Otherwise it would be refering to the ::thing::thing::set proc. I hope I didn't misunderstood something... By the way, thank you for this wonderful prototype based OO system!

For a comparison with Itcl, see Toasters and things

See Chaining things for a modified version that allows method chaining (among other slight changes).