- Make the eyes follow the purple dog by combining the two examples
- Make a polka dot that follows the cursor and changes colour from time to time
- Make the rabbits hunt the dog
- Emulate the classic game of "pong"
- Emulate the classic game of "pacman"
- Emulate turtle graphics (including drawing trees)
- A simple drawing program
Zarutian 14. april 2005: Hmm... NetLogo[2] is probably similar what you are thinking about.
# arena.tcl --
# Run a small arena with various agents (animals if you like) that
# hunt or hinder each other
# Use:
# wish arena.tcl agents.def
# (agents.def defines what agents)
#
# Problems:
# - Errors in the user-defined script can make the application
# enter an endless loop of error messages. (catch these in
# the "act" procedure?)
# - No checking of unique names yet - may lead to error messages
# - If you write to the (Windows) console in an action callback, the
# application may get stuck.
#
package require Tk
package require BWidget
#
# Create the main window
#
proc MainWindow {_width _height} {
global canvas
global ctree
global width
global height
set width $_width
set height $_height
set canvas [canvas .cnv -width $width -height $height -background white]
set ctree [Tree .ctree]
grid $ctree $canvas -sticky news
}
#
# Basic shapes
#
proc oval {color xmin ymin xmax ymax} {
global canvas
$canvas create oval $xmin $ymin $xmax $ymax -fill $color
}
proc rectangle {color xmin ymin xmax ymax} {
global canvas
$canvas create rectangle $xmin $ymin $xmax $ymax -fill $color
}
#
# Agents
#
proc type-agent {type data} {
global ctree
global agent_type
set agent_type($type) $data
$ctree insert end root type_$type -text $type
}
proc agent {type name data} {
global agent_type
global agent
global ctree
set agent($name,type) $type
$ctree insert end type_$type agent_$name -text $name
ConstructAgent $name initial color black
ConstructAgent $name initial form dot
ConstructAgent $name initial size 10
set agent($name,oldattr,position) {0 0}
ConstructAgent $name initial position {0 0}
set cmd {}
foreach line [split $agent_type($type) \n] {
if { [string trim $line] == "" } {
continue
}
append cmd $line
if { [info complete $cmd] } {
eval ConstructAgent [list $name] $cmd
set cmd {}
} else {
append cmd \n
}
}
foreach {key value} $data {
ConstructAgent $name change $key $value
}
DrawAgent $name 1
}
proc ConstructAgent {name command args} {
global ctree
global agent
switch -- $command {
"initial" {
foreach {key value} $args break
set agent($name,attr,$key) $value
if { ! [$ctree exists agent_${name}_$key] } {
$ctree insert end agent_$name \
agent_${name}_$key -text "$key = $value"
} else {
$ctree itemconfigure \
agent_${name}_$key -text "$key = $value"
}
}
"change" {
foreach {key value} $args break
set agent($name,attr,$key) $value
$ctree itemconfigure agent_${name}_$key -text "$key = $value"
}
"action" {
foreach {key cmds} $args break
set agent($name,cmds,$key) $cmds
}
"start" {
act $name $args
}
}
}
proc DrawAgent {name create} {
global canvas
global agent
#
# For now: simply a dot
#
if { $create } {
set agent($name,id) \
[$canvas create oval 0 0 \
$agent($name,attr,size) $agent($name,attr,size) \
-fill $agent($name,attr,color)]
}
$canvas coords $agent($name,id) 0 0 \
$agent($name,attr,size) $agent($name,attr,size)
foreach {dx dy} $agent($name,attr,position) {
set dx [expr {$dx-0.5*$agent($name,attr,size)}]
set dy [expr {$dy-0.5*$agent($name,attr,size)}]
break
}
$canvas move $agent($name,id) $dx $dy
$canvas itemconfigure $agent($name,id) -fill $agent($name,attr,color)
}
proc act {name action} {
global self
if { $name == "Self" } {
set name $self
}
after 50 [list ActAgent $name $action]
}
proc ActAgent {name action} {
global self
global agent
set self $name
eval $agent($name,cmds,$action)
DrawAgent $name 0
}
#
# Things an agent can do
#
proc add {op1 op2} {
expr {$op1+$op2}
}
proc mult {op1 op2} {
expr {$op1*$op2}
}
proc random {op1} {
expr {rand()*$op1}
}
proc direction {from to} {
global self
global agent
#
# For the moment: only positions
#
foreach {x1 y1} $from {break}
foreach {x2 y2} $to {break}
expr {atan2(($y2-$y1),($x2-$x1))*180.0/3.1415926}
}
proc distance {from to} {
global self
global agent
#
# For the moment: only positions
#
foreach {x1 y1} $from {break}
foreach {x2 y2} $to {break}
expr {hypot(($y2-$y1),($x2-$x1))}
}
proc delay {delay} {
set ::continue 0
after [expr {int(1000*$delay)}] {set ::continue 1}
vwait ::continue
}
proc newpos {start dist dir} {
global self
global agent
global width
global height
#
# For the moment: only positions
#
foreach {xold yold} $start {break}
set xnew [expr {$xold+$dist*cos($dir/180.0*3.1415926)}]
set ynew [expr {$yold+$dist*sin($dir/180.0*3.1415926)}]
if { $xnew < 0.0 } {
set xnew [expr {$xnew+$width}]
}
if { $ynew < 0.0 } {
set ynew [expr {$ynew+$height}]
}
if { $xnew > $width } {
set xnew [expr {$xnew-$width}]
}
if { $ynew > $height } {
set ynew [expr {$ynew-$height}]
}
list $xnew $ynew
}
proc change-attr {name attr value} {
global self
global agent
if { $name == "Self" } {
set name $self
}
if { $attr == "position" } {
set agent($name,oldattr,$attr) $agent($name,attr,$attr)
}
ConstructAgent $name change $attr $value
DrawAgent $name 0
}
proc get-attr {name attr} {
global agent
global self
if { $name == "Self" } {
set name $self
}
return $agent($name,attr,$attr)
}
#
# Bring up the main window
#
MainWindow 300 300
#
# Define the mouse agent
#
type-agent Mouse {}
agent Mouse Mouse {position {-100 -100}}
bind $canvas <Motion> {ConstructAgent Mouse initial position {%x %y}}
#
# Test: xeyes-like agents
#
if { 0 } {
oval black 100 100 160 180
oval white 105 105 155 175
oval black 200 100 260 180
oval white 205 105 255 175
type-agent Eye {
initial color green
initial position {0 0}
initial centre {0 0}
action where {
set centre [get-attr Self centre]
set dir [direction $centre [get-attr Mouse position]]
set pos [newpos $centre 20 $dir]
change-attr Self position $pos
#
# Change color and size if the mouse is very close
# to the left (!) eye
# Note:
# You get somewhat unexpected effects if you do not
# restrict this to one eye!
#
if { $name == "left" } {
set dist [distance $pos [get-attr Mouse position]]
if { $dist < 40 } {
change-attr left color blue
change-attr right size 30
} else {
change-attr left color green
change-attr right size 10
}
}
act Self where
}
start where ;# We need to kick the agent into action
}
set count 0
agent Eye left {position {145 140} centre {130 140}}
agent Eye right {position {245 140} centre {230 140}}
}
if { 1 } {
#
# Test: dog hunting rabbits
# Note:
# Getting the distances right takes some experimenting.
# With the settings that are given, the movements of the dog
# are rather smooth. The rabbits "jitter" a bit.
#
type-agent Rabbit {
initial color brown
initial position {0 0}
action fleedog {
set selfpos [get-attr Self position]
set dogpos [get-attr dog position]
if { [distance $selfpos $dogpos] < 50 } {
set dir [direction $selfpos $dogpos]
set rnd [random 360]
set pos [newpos $selfpos 20 [add $dir $rnd]]
change-attr Self position $pos
change-attr Self color yellow
} else {
change-attr Self color brown
}
act Self fleedog
}
start fleedog ;# We need to kick the agent into action
}
type-agent Dog {
initial color magenta
initial size 30
initial position {0 0}
action chaserabbit {
set mindist 1000000000.0
set dir ""
foreach r {rabbit1 rabbit2 rabbit3} {
set selfpos [get-attr Self position]
set rabbitpos [get-attr $r position]
if { [distance $selfpos $rabbitpos] < $mindist } {
set mindist [distance $selfpos $rabbitpos]
set dir [direction $selfpos $rabbitpos]
}
}
if { $dir != "" } {
set pos [newpos $selfpos [mult $mindist 0.1] $dir]
change-attr Self position $pos
}
act Self chaserabbit
}
start chaserabbit ;# We need to kick the agent into action
}
agent Rabbit rabbit1 {position {40 290}}
agent Rabbit rabbit2 {position {140 90}}
agent Rabbit rabbit3 {position {290 90}}
agent Dog dog {position {245 140}}
}
#
# Traffic lights
#
if { 0 } {
rectangle black 70 70 130 250
type-agent TrafficLight {
initial color darkgrey
initial on-color purple
initial position {0 0}
initial size 40
initial next ?
initial delay 1
action changecolor {
change-attr Self color [get-attr Self on-color]
delay [get-attr Self delay]
change-attr Self color darkgrey
act [get-attr Self next] changecolor
}
}
agent TrafficLight green { position {100 220} on-color green next orange}
agent TrafficLight orange { position {100 160} on-color orange next red}
agent TrafficLight red { position {100 100} on-color red next green}
act green changecolor
}
