[EKB] This is a simple implementation of Steve Yegge's Prototype Pattern [http://steve-yegge.blogspot.com/2008/10/universal-design-pattern.html] (or modeling approach, since he argues that it is actually a way to model programs and not just a pattern).

From his article:

''At a high level, every implementation of the Properties Pattern has the same core API. It's the core API for any collection that maps names to values:

    * get(name)
    * put(name, value)
    * has(name)
    * remove(name)

There are typically also ways to iterate over the properties, optionally with a filter of some sort.

So the simplest implementation of the Properties Pattern is a Map of some sort. The objects in your system are Maps, and their elements are Properties.

The next step in expressive power is to reserve a special property name to represent the (optional) parent link. You can call it "parent", or "class", or "prototype", or "mommy", or anything you like. If present, it points to another Map.

Now that you have a parent link, you can enhance the semantics of get, put, has and remove to follow the parent pointer if the specified property isn't in the object's list. This is largely straightforward, with a few catches that we'll discuss below. But you should be able to envision how you'd do it without too much thought.

At this point you have a full-fledged Prototype Pattern implementation. All it took was a parent link!

From here the pattern can expand in many directions, and we'll cover a few of the interesting ones in the remainder of this article.''

Here is the code:

======
# Basic data object is a "property list"

# Needed API is:
#  obj get name
#  obj put name value
#  obj has name
#  obj remove name

# Also need a creation command (here called "new")

# To follow the "properties pattern", there also needs to be
# a "parent" property. Here are the rules:
#  - Recurse up the list of parents when looking for a property
#  - If you set a value, set in the child, not the parent, even if
#    the parent has the property
#  - When you clear a property, clear only in the child

namespace eval pp {
    variable prototypes
    dict set prototypes root parent NULL
}

proc pp::new {obj <- parent} {
    variable prototypes
    
    dict set prototypes $obj parent $parent
    proc $obj {cmd args} {
        variable prototypes
        
        # Peel off just the proc name
        regexp {::(.*)$} [lindex [dict get [info frame 1] cmd] 0] -> self
        lassign $args name value
        switch -- $cmd {
            get {
                set obj $self
                while 1 {
                    if [dict exists $prototypes $obj $name] {
                        return [dict get $prototypes $obj $name]
                    }
                    set obj [dict get $prototypes $obj parent]
                    if {$obj eq "NULL"} {
                        break
                    }
                }
                error "$self: $name not found"
            }
            put {
                dict set prototypes $self $name $value
                return $value
            }
            has {
                set obj $self
                while 1 {
                    lassign $args name 
                    if [dict exists $prototypes $obj $name] {
                        return 1
                    }
                    set obj [dict get $prototypes $obj parent]
                    if {$obj eq "NULL"} {
                        break
                    }
                }
                return 0
            }
            remove {
                dict unset prototypes $self $name
                return {}
            }
            default {
                error "Available commands: get, put, has, remove"
            }
        }
    }
}
======

An example of use:

======
% pp::new test <- root
% pp::test put a foo
foo
% pp::test get a
foo
% pp::new test2 <- test
% pp::test2 get a
foo
% pp::test2 put b bar
% pp::test2 get b
bar
% pp::test2 remove b
% pp::test2 get b
test2: b not found
% pp::test2 remove a    <----- This does nothing, since it is defined in the parent
% pp::test2 get a
foo
======

----
!!!!!!
%| [Arts and crafts of Tcl-Tk programming] | [Category Design] |%
!!!!!!