set auto_path [concat . $auto_path]

#########################################################################
#
# Implementation of the Tcl Core Object Oriented Language (TclCOOL)
# based on the Minimal Object System.
#
#########################################################################
#
# This script consists of three major parts:
#
#   1. Setup of XOTcl to be used as Tcl Minimal Object Sytem (TMOS)
#
#   2. The definition of TclCOOL (Tcl Core Object Oriented Languge)
#      based on TMOS. TclCOOL is simple but powerful object language
#      realized with TMOS
#
#   3. Sample TclCOOL program 
#
#

######################################################################
#
# 1. Configuration of XOTcl to act as the Tcl Minimal Object System
#
###################################################################### 
# For the time being, we use the XOTcl implementation for implementing
# TMOS and TclCOOL. The used part of the XOTcl implementation should 
# be part of tcl-core. 
#
# For now, we have XOTcl appearing in the first 12 lines of code,
# but then the script is free of direct references to XOTcl. XOTcl
# should use the same basic set of commands as every other oo language.
# 
# In this script we use a few commands from XOTcl, which will be in
# the final version part of the ::oo namespace in the core. This
# little demo program shows the flexibility and reuse capability
# between different OO-languages. These languages can provide their
# own commands/methods, or they can reuse commands/methods from
# TclCOOL or other OO-languages. This script can be executed with
#
# http://media.wu-wien.ac.at/download/xotcl-1.5.3-alpha.tar.gz

package require XOTcl
namespace eval ::xotcl {
  namespace export alias setrelation
  namespace eval cmd::Class {namespace export alloc instproc instforward info}
  namespace eval cmd::Object {namespace export instvar forward info}
}
namespace eval ::oo  {
  namespace import ::xotcl::alias ::xotcl::setrelation
  namespace import ::xotcl::my ::xotcl::self ::xotcl::next
  namespace eval ::oo::methodset::class  {namespace import ::xotcl::cmd::Class::*}
  namespace eval ::oo::methodset::object {namespace import ::xotcl::cmd::Object::*}
  namespace export my self next
}
# The remainder of this script is free of xotcl::*.


######################################################################
#
# Basic setup of the Tcl minimal object system (TMOS)
#
###################################################################### 

# Now we have the following commands and methods defined in the ::oo namespace:
#
# Two classes
#   ::oo::class
#   ::oo::object
#
# Two unexported commands for OO-language designer
#   ::oo::alias
#   ::oo::setrelation
#
# Three exported commands to be used by in the languages
#   ::oo::my
#   ::oo::self
#   ::oo::next 
#
# An unregistered (unattached) set of methods that can be used for classes
#   alloc, instproc, instforward, info
#
# An unregistered (unattached) set of methods that can be used to objects
#   instvar forward info


# The only method provided by ::oo::class is the the method "alloc"
# used to create objects or classes. This method is available in the
# methodset of oo. We will attach it to ::oo::class using the command
# alias:
#
# The alias command 
#
#    ::oo::alias class|obj methodName ?-objscope? ?-per-object? cmdName
#
# registers a command ("cmdName") under a certain name ("methodName")
# to an object or class (1st argument) to make the command available 
# as a method. The options "-objscope" makes instance variables of the
# object/class appear as local variables, therefore Tcl commands to which
# variable names are passed (e.g. set, append, lappend, ...) will access
# instance variables. "namespace origin" is required by the current 
# implementation, but won't be needed in the final version.

::oo::alias ::oo::class alloc [namespace origin ::oo::methodset::class::alloc]

#
# Ok. now our basic setup of the Tcl minimal object system is done. 
# Now we are ready to define the Tcl core object oriented language (TclCOOL)
# based on these functionalities.

######################################################################
#
# 2. TclCOOL language definition based on TMOS
#
###################################################################### 

namespace eval tcl-cool {

  # In a first step, we create two basic classes of TclCOOL, 
  # namely "object" and "class"  in the current namespace:
  
  oo::class alloc object
  oo::class alloc class

  # We have now two classes objects, which are instances of
  # ::oo::class.  This is not what we want to have. "tcl-cool::object"
  # should be the most general superclass of TclCOOL, and
  # "tcl-cool::class" should be the most general superclass of
  # TclCOOL. Since we are bootstrapping the language from a minimal
  # command-set, we will use the setrelation command to define the
  # basic relationships of the freshly defined classes.
  #
  # The setrelation command 
  #
  #   ::oo::setrelation class|obj <relation> <target>
  # 
  # allows to set relations between objects, classes and mixins.  This
  # is a primitive command designed for the language developer, not
  # for the user of TclCOOL. The following relation-types are used
  # for TclCOOL:
  #
  #     "superclass", "class", "filter" and "mixin"
  #
  # The first command defines that the superclass of the newly defined
  # class named "class" (fully qualified "::tcl-cool::class") should
  # be the general meta-class ::oo::class and as well
  # "::tcl-cool::object".  Therefore, ::tcl-cool::class will be a
  # meta-class (its instances are classes) and it will inherit all
  # properties of the most general TclCOOL class.

  ::oo::setrelation class superclass {::oo::class object} 

  # After creation, the classes ::tcl-cool::class and
  # ::tcl-cool::object are instances of ::oo::class. However, these
  # should be instances of ::tcl-cool::class, to inherit the methods
  # of this most general meta-class of the TclCOOL language.  Without
  # that, ::tcl-cool::class and ::tcl-cool::object would not have
  # methods.
  #
  # The next two commands define that ::tcl-cool::object and 
  # ::tcl-cool::class are instances of ::tcl-cool::class. In 
  # other words, the class of e.g. ::tcl-cool::object is 
  # ::tcl-cool::class. 
  
  ::oo::setrelation object class class 
  ::oo::setrelation class  class class 

  # So, the basic OO-relations for superclass and class are done. Now
  # we can define methods for these newly defined classes.
  #
  # We define 3 methods for "class" (actually "::tcl-cool::class) 
  # based on the methodset for classes
  #   - "method"  is a means to define the methods, which are provided 
  #               to the instances of the class ("instproc" in XOTcl)
  #   - "forward" us a forwarder for instances of the object 
  #               (instforward in XOTcl)
  #   - "info"    is an introspection method for classes

  ::oo::alias class method    [namespace origin ::oo::methodset::class::instproc]
  ::oo::alias class forward   [namespace origin ::oo::methodset::class::instforward]
  ::oo::alias class info      [namespace origin ::oo::methodset::class::info]

  # Next, we define 3 methods for "object" (actually "::tcl-cool::object) 
  # based on the methodset for objects
  #   - "variable" is a means to import instance variables into
  #                the current scope ("instvar" in XOTcl)
  #   - "forward" is a method for delegating calls to different objects
  #   - "info"   is an introspection method for objects

  ::oo::alias object variable [namespace origin ::oo::methodset::object::instvar]
  ::oo::alias object forward  [namespace origin ::oo::methodset::object::forward]
  ::oo::alias object info     [namespace origin ::oo::methodset::object::info]

  #
  # The method "create" defines, what happens, when a class or object 
  # is created. It is firstly allocated, then the constructor is called.
  #
  class method create {name args} {
    set obj [uplevel [self] alloc $name]
    eval $obj init $args
    return $obj
  }

  # provide primitive commands; we use these from oo
  namespace import ::oo::my ::oo::self ::oo::next

  # a small helper proc for processing the body of the constructor
  proc pop vn {upvar $vn v; set r [lindex $v 0]; set v [lreplace $v 0 0]; return $r}

  # When we create classes without specifying a superclass, we have to
  # choose a default class. This is achieved by setting an instance
  # variable in the meta-class "class" with the name
  # "__default_superclass" to the newly defined object. In XOTcl, this
  # is integrated with the slot objects that provide a uniform
  # interface. Slot objects would need more support from other
  # commands in TclCOOL, so they are left out for the time being....
  #
  # The following method is the constructor for classes.  It sets the
  # default superclass and provides easy means for specifying methods
  # and superclasses during initialization
  
  class method init {spec} {
    my variable __default_superclass
    set __default_superclass [namespace current]::object
    while {[llength $spec]} {
      set m [pop spec] 
      switch $m {
	method     {my method [pop spec] [pop spec] [pop spec]}
	superclass {my superclass [pop spec]}
	default    {error "unknown argument '$m'"}
      }
    }
  }

  # Call the constructor on "class" to set the default superclass as
  # well for this class, and define a convenience routine for defining
  # superclasses
  class init {
    method superclass sc {
      ::oo::setrelation [self] superclass $sc
    }
  }

  # Finally, we provide a few methods for all objects in TclCOOL: 
  #  - "unknown": provide an error message, when unknown methods are called
  #  - "filter": convenience routine to set filters though 
  object method unknown {m args} {error "[self]: unknown method '$m' called"}
  
  # Provide users a convenient way to register/deregister filters and
  # mixins

  object forward filter ::oo::setrelation %self filter 
  object forward mixin  ::oo::setrelation %self mixin

  # Alternatively, we could use these methods
  #   object method filter {filterList} {
  #     ::oo::setrelation [self] filter $filterList
  #   }
  #   # ... and mixins (per object mixins)
  #   object method mixin {mixinList} {
  #     ::oo::setrelation [self] mixin $mixinList
  #   }
  
  # finally, export a few commands
  namespace export object class my self next
}



######################################################################
#
# 3. Sample TclCOOL program
#
######################################################################
namespace import tcl-cool::*

class create dog {
  method init {} {
    tail create [self]::tail
    my forward wag [self]::tail wag
    my forward rise [self]::tail rise
  }
  method bark {} {
    puts "[self] Bark, bark, bark."
  }
}

# we can extend the class incrementally
dog method chase {thing} {
  puts "Chase $thing!"
}

class create tail {
  method init {} {
    my variable length
    set length 5
  }
  method wag {} {
    return Joy
  }
  method rise {} {
    return Attention
  }
}

dog create fido
puts "wag means [fido wag]"
fido chase tweedy!

# The output is:
# wag means Joy
# Chase tweedy!!



puts "\n============ filter ================"

#
# define a filter method....
#
object method tracer args {
  puts "* call [self] [self calledproc] [self args]"
  set r [next]
  puts "* exit [self] [self calledproc], returns '$r'"
  return $r
}

#
# ... and register the filter on the object:
#
fido filter tracer

# 
# invoke the methods again
#
puts "wag means [fido wag]"
fido chase tweedy!


# The output is:
# > ============ filter ================
# > * call ::fido wag 
# > * exit ::fido wag, returns 'Joy'
# > wag means Joy
# > * call ::fido chase tweedy!
# > Chase tweedy!!
# > * exit ::fido chase, returns ''
# > * call ::fido filter {}
# > * exit ::fido filter, returns ''

#
# remove the filter
#
fido filter ""

puts "\n============ mixin class ================"

#
# define a class, which should be mixed in into instances of dogs
#

class create lazydog {
  method wag {} {
    puts "... well, if i have to...."
    next
  }
  method chase thing {
    puts "... [self] does not like to chase $thing"
  }
}

#
# ... and register the filter on the object:
#
fido mixin lazydog

# 
# invoke the methods again
#
puts "wag means [fido wag]"
fido chase tweedy!


# The output is:
# > ============ mixin class ================
# > ... well, if i have to....
# > wag means Joy
# > ... ::fido does not like to chase tweedy!


#
# remove the mixin class again
#
fido mixin ""

puts "\n============ subclass ================"

class create terrier {
  superclass dog
  method chase thing {
    puts "Yippy, I'll get that wicked $thing!"
  }
}

terrier create frido
frido chase tweedy!

# The output is:
# > ============ subclass ================
# >Yippy, I'll get that wicked tweedy!!





puts "\nMethods of fido: [fido info methods]"
foreach cmd {{fido wag} {fido rise}} {  puts "$cmd [time {eval $cmd} 10000]" }