#Copyright 2004 George Peter Staplin
#Smalltick - A Smalltalk-like object system in pure-Tcl.
#Version 1.3
set ::expand_arguments {
if {[llength $_priv_arg_list] != [llength $args]} {
return -code error "invalid number of arguments"
}
foreach _priv_var $_priv_arg_list _priv_val $args {
set $_priv_var $_priv_val
}
}
proc get.unique.command.name {} {
while 1 {
if {"" == [info commands [set n cmd[clock clicks]]]} {
return $n
}
}
}
proc instance.handler {obj args} {
if {":" == [lindex $args 0]} {
proc $obj->[lindex $args 1] \
[list args [list _priv_arg_list [lindex $args 2]]] \
"set self $obj
$::expand_arguments
[lindex $args 3]"
return
} else {
foreach {msg arg} $args {
set r [[set obj]->[set msg] $arg]
}
return $r
}
}
proc new.object {} {
set obj [get.unique.command.name]
interp alias {} $obj {} instance.handler $obj
$obj : destroy {} {
foreach cmd [info commands [set self]*] {
rename $cmd {}
}
array unset ::_priv_instances [set self],*
}
$obj : get var {
return [set ::_priv_instances($self,$var)]
}
$obj : set {var value} {
set ::_priv_instances($self,$var) $value
}
return $obj
}
############## Example Code ################
proc Ball self {
$self set [list pressure 0]
$self : -bounce n {
puts "Bouncing $n times."
$self do.a.bounce.until.0 $n
}
$self : -dance {} {
puts "$self says shake your groove thing!"
}
$self : -inflate p {
puts "Inflating from [$self get pressure] to $p lbs. of pressure."
$self set [list pressure $p]
$self do.inflate [list 0 $p]
}
$self : -roll d {
puts "Rolling $d degress."
}
$self : do.a.bounce.until.0 n {
if {$n <= 0} return
puts "Bouncy! $n"
after 100
$self do.a.bounce.until.0 [incr n -1]
}
$self : do.inflate {i n} {
if {$i > $n} return
puts "PSI $i"
after 50
$self do.inflate [list [incr i] $n]
}
return $self
}
proc Balloon self {
$self set [list color bland]
$self : -set.color col {
puts "Changing [set self]'s color from [$self get color] to $col"
$self set [list color $col]
}
$self : -set.location {x y z} {
puts "x:$x y:$y z:$z"
$self set [list x $x] set [list y $y] set [list z $z]
}
return $self
}
proc main {} {
set b [Ball [new.object]]
$b -roll 32 -inflate 20 -bounce 10 -dance
$b destroy
set bal [Balloon [new.object]]
$bal -set.color [list [list wild indigo]] -set.location [list 5 7 9]
$bal destroy
}
main
Category Object Orientation