#! /bin/sh
# \
exec tclsh "$0" "$@"
package require Tk
# TkBugs --
#
# An implementation of the BUGS program from
# the book "The Magic Machine", by A K Dewdney
# (ISBN 0-7167-2144-9). Substantial changes
# have been made to the code to adapt it to
# the Tk environment and an event-driven
# programming model.
#
# Copyright
# (c) 2001 Peter Lewerin. All rights reserved.
# This program is free software; you may
# redistribute it and/or modify it as you wish.
#
# RCS: $Revision: 1.5 $ $Date: 2003-12-01 07:00:03 $
### configuration variables ########################
#
# canvas width, height, background color
set width 150
set height 100
set canvasBgColor grey
# colors for drawing bugs and bacteria
set bugColor white
set bugInspColor yellow
set bactColor purple
# initial number of bugs/bacteria
set initialBugs 10
set initialBacteria 200
set delayBugAction 100
set delayReplBact 500
# parameters for bug behaviour
set energyToMove 10
set energyToSplit 1000
set ageToSplit 800
set energyMax 1500
set energyPerBact 40
#
### end of configuration variables #################
# repeat --
#
# Arguments:
# n an integer value
# script a script
#
# Results:
# The script is executed n times. The procedure
# returns an empty string.
#
proc repeat {n script} {
for {set i 0} {$i < $n} {incr i} {
uplevel $script
} ;# end for (i)
return
}
wm title . TkBugs
set timeElapsed 0
set xmove [list 0 2 2 0 -2 -2]
set ymove [list -2 -1 1 2 1 -1]
array set bugs [list]
# init --
# Sets up the program to run the bug simulation.
#
# Results:
# Creates the canvas if it didn't exist before;
# removes all canvas items and all timers if they
# exist; creates initial bug and bacterium items;
# sets up timers.
# Returns an empty string.
#
proc init {} {
global width height canvasBgColor
global initialBugs delayBugAction
global initialBacteria delayReplBact
# lifted from a postcard from Richard Suchenwirth
if {![winfo exists .c]} {
canvas .c -width $width -height $height \
-background $canvasBgColor \
-highlightcolor $canvasBgColor
pack .c
bind .c <1> [list source [info script]]
bind .c <3> [list tk_popup .m %X %Y]
}
.c delete all
destroy .m
foreach {i} [after info] {after cancel $i}
menu .m -tearoff no
.m add checkbutton -label {Show info} \
-command toggleInfo
.m add checkbutton -label {Debugging mode} \
-command toggleDebugMode
.m add checkbutton -label {Inspect} \
-command toggleInspectMode
.m add separator
.m add cascade -label {About...} \
-state disabled
generateInitialBugs $initialBugs
generateInitialBacteria $initialBacteria
after $delayBugAction bugAction
after $delayReplBact replenishBacteria
focus .c
return
}
# toggleInfo --
# Show or hide information about the program.
#
# Results:
# Creates an information frame if it didn't
# already exist.
# If the frame is visible, this procedure
# hides it; if it is hidden, this procedure
# shows it.
# Returns an empty string.
#
proc toggleInfo {} {
global numBugs numCycles
if {![winfo exists .info]} {
frame .info
label .info.numbugs -textvariable numBugs
label .info.time -textvariable numCycles
pack .info.numbugs .info.time -side left
}
if {[catch {llength [pack info .info]}]} {
pack .info
} else {
pack forget .info
} ;# end if
return
}
# toggleDebugMode --
# Toggles debugging mode.
#
# Results:
# Returns an empty string.
#
proc toggleDebugMode {} {
if {[.c cget -cursor] == "crosshair"} {
.c configure -cursor arrow
bind .c <1> [list source [info script]]
} else {
.c configure -cursor crosshair
bind .c <1> [list killBug %x %y]
} ;# end if
return
}
# toggleInspectMode --
# Toggles inspection mode.
#
# Results:
# Creates an inspection frame if it didn't
# already exist.
# If the frame is visible, this procedure
# 1) hides it, 2) unbinds the Tab key, and
# 3) calls nullInspId; if it is hidden,
# this procedure 1) shows it, 2) binds the
# Tab key to the procedure bumpInspId, and
# 3) calls bumpInspId.
# Returns an empty string.
#
proc toggleInspectMode {} {
global inspLabel inspAttrs
if {![winfo exists .inspect]} {
frame .inspect
label .inspect.id -font {Helvetica 9 bold} \
-textvariable inspLabel
label .inspect.attrs -textvariable inspAttrs
pack .inspect.id .inspect.attrs
}
if {![catch {llength [pack info .inspect]}]} {
pack forget .inspect
bind .c <Tab> {}
nullInspId
} else {
pack .inspect
bind .c <Tab> bumpInspId
bumpInspId
} ;# end if
return
}
# bugAction --
# This procedure is called by a timer
# to update the state of the bug items.
#
# Results:
# Each bug
# 1) eats bacteria
# 2) moves if it has enough energy left
# 3) loses a unit of energy and ages one cycle
# 4) splits into two new bugs if it has enough
# energy and is old enough
# 5) dies, if it has run out of energy.
# The timer is then reset to $delayBugAction.
# Returns an empty string.
#
proc bugAction {} {
global bugs
global numBugs numCycles timeElapsed
global delayBugAction
global inspLabel inspAttrs
global energyToMove energyToSplit ageToSplit
set bugids [.c find withtag {bug||inspected}]
set numBugs [format "Bugs: %d" [llength $bugids]]
set numCycles [format "Cycles: %d" \
[incr timeElapsed]]
if {[string length [set inspId [.c find withtag inspected]]]} {
set inspLabel "Bug # $inspId"
set inspAttrs "Energy: $bugs($inspId,energy)"
append inspAttrs " Age: $bugs($inspId,age)"
append inspAttrs " Dir: $bugs($inspId,dir)\n"
append inspAttrs " Lt: $bugs($inspId,lt)"
append inspAttrs " Fw: $bugs($inspId,fw)"
append inspAttrs " Rt: $bugs($inspId,rt)\n"
append inspAttrs " Hl: $bugs($inspId,hl)"
append inspAttrs " Rv: $bugs($inspId,rv)"
append inspAttrs " Hr: $bugs($inspId,hr)"
}
foreach {id} $bugids {
feedBug $id
if {$bugs($id,energy) >= $energyToMove} {
moveBug $id
}
incr bugs($id,energy) -1
incr bugs($id,age)
if {
$bugs($id,energy) >= $energyToSplit &&
$bugs($id,age) >= $ageToSplit
} {
set id' [cloneBug $id]
mutateBug $id
mutateBug ${id'}
}
if {$bugs($id,energy) <= 0} {
destroyBug $id
} ;# end if
} ;# end foreach
after $delayBugAction bugAction
return
}
# feedBug --
# Simulates a bug eating one or more bacteria,
# gaining energy.
#
# Arguments:
# id the canvas item number for the bug.
#
# Results:
# Increases bug's energy by 40 for each bacterium
# eaten (unless the bug already has 1500 or more
# units of energy).
# The canvas items representing the bacteria are
# removed.
# Returns total amount of energy gained.
#
proc feedBug {id} {
global bugs energyMax energyPerBact
set total 0
foreach {i} [eval .c find overlap [.c bbox $id]] {
if {[lsearch [.c gettags $i] bacterium] >= 0} {
if {$bugs($id,energy) < $energyMax} {
incr total $energyPerBact
}
.c delete $i
} ;# end if
}
incr bugs($id,energy) $total
}
# moveBug --
# Simulates a bug changing direction and moving.
#
# Arguments:
# id the canvas item number for the bug.
#
# Results:
# See comments inside procedure. Returns an
# empty string.
#
proc moveBug {id} {
global bugs xmove ymove
set sum 0
# choose which direction change to make by adding
# the `genetical' bias for the different turns
# and moves...
foreach {g} [list fw rt hr rv hl lt] {
set sum [expr {$sum + $bugs($id,$g)}]
}
# ...then take a random number in the range
# [0..$sum)...
set r [expr {rand()*$sum}]
# ...find the corresponding direction change and
# apply it.
foreach {g} [list fw rt hr rv hl lt] \
{i} {0 1 2 3 4 5} {
set r [expr {$r - $bugs($id,$g)}]
if {$r <= 0} {
set bugs($id,dir) \
[expr {($bugs($id,dir)+$i)%6}]
break
} ;# end if
}
# make the direction change, bouncing from walls...
set width [.c cget -width]
set height [.c cget -height]
foreach {x y} [.c coords $id] break
set dx [lindex $xmove $bugs($id,dir)]
if {$x+$dx < 0 || $x+$dx+2 > $width} {
set dx [expr {$dx*-1}]
}
set dy [lindex $ymove $bugs($id,dir)]
if {$y+$dy < 0 || $y+$dy+2 > $height} {
set dy [expr {$dy*-1}]
}
# ...do it!
.c move $id $dx $dy
return
}
# cloneBug --
# Simulate a bug splitting into two identical
# bugs.
#
# Arguments:
# id the canvas item number for the bug.
#
# Results:
# Creates a new bug canvas item, and copies all
# attributes from the old bug to the new (except
# for energy, which is halved, and age, which is
# set to 0).
# Returns the canvas item number of the new bug.
#
proc cloneBug {id} {
global bugs
set bugs($id,energy) [expr {$bugs($id,energy)/2}]
set bugs($id,age) 0
set id2 [eval drawBug [lrange [.c coords $id] 0 1]]
foreach {name} [array names bugs $id,*] {
regsub {^(.*?),(.*)} $name $id2,\\2 name2
set bugs($name2) $bugs($name)
} ;# end foreach
return $id2
}
# mutateBug --
# Change one of the six `genes' that control
# bug movement.
#
# Arguments:
# id the canvas item number for the bug.
#
# Results:
# One randomly chosen `gene' is doubled or
# halved.
# Returns an empty string.
#
proc mutateBug {id} {
global bugs
set g [lindex [list fw rt hr rv hl lt] \
[expr {int(rand()*6)}]]
if {int(rand()*2) > 0} {
set bugs($id,$g) [expr {$bugs($id,$g)*2}]
} else {
set bugs($id,$g) [expr {$bugs($id,$g)/2.0}]
} ;# end if
return
}
# drawBug --
# Draws the image of a bug on the canvas.
#
# Arguments:
# x, y The coordinates for the upper left
# corner of the bug canvas item.
#
# Results:
# Returns the canvas item number of the bug.
#
proc drawBug {x y} {
global bugColor
.c create rectangle $x $y [expr {$x+2}] \
[expr {$y+2}] -outline $bugColor \
-fill $bugColor -tags bug
}
# getRandCoords --
# Generates a coordinate within a given
# width and height.
#
# Arguments:
# width the x coordinate will be generated
# within [0..$width). If $width is 0, the
# canvas width will be used instead.
# height the y coordinate will be generated
# within [0..$height). If $height is 0, the
# canvas height will be used instead.
# xofs is added to the x coordinate
# yofs is added to the y coordinate
#
# Results:
# Returns a list consisting of the x and y
# coordinates.
#
proc getRandCoords {{width 0} {height 0} {xofs 0} \
{yofs 0}} {
if {$width<1} { set width [.c cget -width] }
if {$height<1} { set height [.c cget -height] }
set x [expr {int(rand()*$width+$xofs)}]
set y [expr {int(rand()*$height+$yofs)}]
return [list $x $y]
}
# createBug --
# Sets the initial attributes of a bug, and
# creates the canvas item for it.
#
# Results:
# Returns the canvas item number of the bug.
#
proc createBug {} {
global bugs energyPerBact
set width [.c cget -width]
set height [.c cget -height]
set id [eval drawBug [getRandCoords \
[incr width -2] [incr height -2] 1 1]]
set bugs($id,energy) $energyPerBact
set bugs($id,age) 0
set bugs($id,fw) [expr {pow(2,int(rand()*10-5))}]
set bugs($id,rt) [expr {pow(2,int(rand()*10-5))}]
set bugs($id,hr) [expr {pow(2,int(rand()*10-5))}]
set bugs($id,rv) [expr {pow(2,int(rand()*10-5))}]
set bugs($id,hl) [expr {pow(2,int(rand()*10-5))}]
set bugs($id,lt) [expr {pow(2,int(rand()*10-5))}]
set bugs($id,dir) [expr {int(rand()*6)}]
return $id
}
# generateInitialBugs --
# Creates a number of bugs.
#
# Arguments:
# n number of bugs to create.
#
# Results:
# Bugs! Returns an empty string.
#
proc generateInitialBugs {n} {
repeat $n createBug
return
}
# drawBacterium --
# Draws the image of a bacterium on the canvas.
#
# Arguments:
# x, y The coordinates for the upper left
# corner of the bacterium canvas item.
#
# Results:
# Returns the canvas item number of the bacterium.
#
proc drawBacterium {x y} {
global bactColor
.c create rectangle $x $y $x $y \
-outline $bactColor -tags bacterium
}
# generateInitialBacteria --
# Creates a number of bacteria.
#
# Arguments:
# n number of bacteria to create.
#
# Results:
# Bacteria! Returns an empty string.
#
proc generateInitialBacteria {n} {
repeat $n {
eval drawBacterium [getRandCoords]
}
return
}
# replenishBacteria --
# This procedure is called by a timer
# to add one more bacterium to the canvas.
#
# Results:
# One more bacterium; resets the timer.
# Returns an empty string.
#
proc replenishBacteria {} {
global delayReplBact
eval drawBacterium [getRandCoords]
after $delayReplBact replenishBacteria
return
}
# killBug --
# Handles an attempt to kill a bug with
# a mouseclick.
#
# Arguments:
# x, y the canvas coordinates for the
# killing mousepress.
#
# Results:
# If there is a canvas item such that it
# 1) overlaps the coordinates of the
# mouseclick, and 2) is a bug, then it is
# destroyed. In any case, a dark grey
# spot marks the place where the assault
# occurred.
# Returns an empty string.
#
proc killBug {x y} {
set items [.c find overlap $x $y $x $y]
set id {}
foreach {item} $items {
set tags [.c gettags $item]
if {[lsearch $tags bug] >= 0} {
set id $item
break
} ;# end if
} ;# end foreach
if {[llength $id] > 0} {
destroyBug $id
}
.c create rectangle $x $y $x $y \
-outline {dark grey}
return
} ;# end killBug
# bumpInspId --
# Set the identity of the inspected
# bug to the next bug on the canvas.
#
# Results:
# Sets the color of the inspected bug
# to $bugInspColor.
# Returns the id of the inspected bug.
#
proc bumpInspId {} {
global bugColor bugInspColor
# get a list of bugs
set bugids [.c find withtag {bug||inspected}]
# is any existing bug inspected?
set inspId [.c find withtag inspected]
if {![string length $inspId]} {
# nope, get one
set inspId [lindex $bugids 0]
} else {
# yep, revert it to uninspected...
.c itemconfigure $inspId \
-outline $bugColor \
-fill $bugColor
.c dtag inspected
# ...and set inspId to the next id in
# the bug list.
set idx [lsearch $bugids $inspId]
set inspId [lindex $bugids [incr idx]]
# did that work?
if {![llength $inspId]} {
# no, get another
set inspId [lindex $bugids 0]
} ;# end if
} ;# end if
# now, give the bug the inspected tag
# and color it appropriately
.c itemconfigure $inspId \
-tags {inspected bug} \
-outline $bugInspColor \
-fill $bugInspColor
return $inspId
} ;# end bumpInspId
# nullInspId --
#
# Results:
#
proc nullInspId {} {
global bugColor
set inspId [.c find withtag inspected]
if {[string length $inspId]} {
.c itemconfigure $inspId \
-outline $bugColor \
-fill $bugColor
.c dtag inspected
}
return
} ;# end nullInspId
# destroyBug --
# Handles the death of a bug.
#
# Arguments:
# id the canvas item number for the bug.
#
# Results:
# If the dying bug was under inspection,
# switch the inspection to the next bug.
# Then remove the attributes of the bug,
# and delete the canvas item.
# Returns an empty string.
#
proc destroyBug {id} {
if {$id == [.c find withtag inspected]} {
bumpInspId
} ;# end if
array unset bugs $id,*
.c delete $id
return
} ;# end destroyBug
initPlease don't put this in the Games category: you can't actually play, win or lose this application.
Category Application | Category Toys