beworld



#!/usr/bin/env brick-tcl
# beworld - Prototype Brick Engine game
# License:  Creative Commons (see license information section)
# Revision: 110923

#---------------------------------------------------------------------
# License information.

# This software is distributed under the  following license:  Creative
# Commons Attribution-NonCommercial-ShareAlike 3.0.  For more informa-
# tion, visit:
#
#     http://creativecommons.org/

#---------------------------------------------------------------------
# Important note.

# This software is provided on an  as-is basis with  no warranty.  The
# entire risk as to the  quality and  performance of  the  software is
# with you.  Should the software prove defective,  you assume the cost
# of all necessary  servicing, repair or correction.  In no event will
# any of the developers,  or any other party, be  liable to anyone for
# damages arising out of use of the software, or  inability to use the
# software.

#---------------------------------------------------------------------
# Documentation: Changes in revision 110923.

# Brief change summary:

# Brick Engine 5.4 or above  is  now supported  (and  required, though
# older APIs may be used for testing purposes).

# Multi-frame sprites are now supported,  both for multi-shape classes
# and for animation purposes.  In the multi-shape case,  shapes may be
# selected either by name or randomly.

# Added drop shadows,  a "God" mode power-up,  and new objects:  cars,
# dogs, pigs, and tigers. Added an animated "fire" level.  The game no
# longer needs OpenGL.  There is now a  goal: Make it to the exit. Ei-
# ther Control or Space may be used to shoot. License has  changed  to
# Creative Commons.

# More object properties are supported.  For example,  objects may now
# have random sizes that fall into a pre-defined range. Attacks by the
# player may affect them differently,  attacks by them  may affect the
# player differently, and they may make different sounds under differ-
# ent circumstances.

# Details:

# (a) Ported the program to the Brick Engine 5.4 API.

# (b) The player may now use either Left-Control or Space to shoot.

# (c) For best results, the following "cmake" rule should be used when
# Brick is built:
#
#     -DCMAKE_BUILD_TYPE:STRING=RELEASE
#
# Note: This will help other Brick programs as well as BEWorld.

# (d)  A  "God mode" power-up feature is supported.  The player sprite
# used in "God mode" and  the amount of time that "God mode" lasts are
# both configurable.

# (e) Drop shadows are now  supported.  This feature may be enabled or
# disabled for objects on a per-class and/or per-world basis.

# (f) OpenGL is no longer  needed.  Non-OpenGL mode is now the default
# (though OpenGL is still supported).  However, the "cmake"  rule men-
# tioned  previously is  important.  Brick  should be built in RELEASE
# mode or BEWorld will be too slow.

# (g) Objects  may now be assigned random sizes taken from a specified
# range. The range may be set on a per-class and/or per-world basis.

# (h) Multi-frame  sprites  are  now  supported,  both for multi-shape
# classes and for animation purposes.  In the multi-shape case, shapes
# may be selected either by name or randomly.

# (i) Objects  may now make different sounds in  different circumstan-
# ces. For example, different sounds may be set for object hit by wea-
# pon and object destroyed by weapon.  The sounds  in question  may be
# set on a per-class and/or per-world basis.

# (j) Additional parameters  may now be set on a per-class and/or per-
# world basis, including:
#
# Initial health of an object
# Health effect on an  object per attack by the player
# Health effect on the player per attack by an object
# Score change if an object is destroyed by shooting
# Distance from player at which an object becomes cautious
# Whether or not an object can be attacked

# (k) Added tigers. They hide behind trees until the player happens to
# pass close by. Tigers are similar to the older enemy types but are a
# little tougher;  they can be destroyed by shooting, but more bullets
# are required.

# (l) Added dogs and pigs.  Pigs are  simply variations on cows.  Dogs
# follow the player and are friendly.  They'll fight tigers on his/her
# behalf (they're evenly matched).

# (m) Money now has different forms, is mobile, and is reluctant to be
# picked up.

# (n) The red-square enemies  are now known as  Karkinos.  They may be
# thought of as a type of crab; the crab constellation Cancer is based
# on the original Karkinos legend.

# (o) Added cars.  The player can drive a car;  while doing so, he/she
# is safe from  some attacks  but can't shoot  (attempts to shoot will
# simply beep the car's horn).

# (p) Added a global parameter  BRICKAPI that specifies the  Brick API
# to use  (5200 for  Brick 5.2, 5300 for Brick 5.3, and 5400 for Brick
# 5.4).

# For the time being, the program should run under any of the support-
# ed APIs if BRICKAPI is set correctly.  However,  there are some cav-
# eats:
#
# Older APIs  are only supported for testing  purposes.  When an older
# API is used, some features will be omitted  and others will be  only
# partly supported.
#
# If Brick 5.2 is used, a "wrap_sprite_position" patch (available sep-
# arately) must be applied  to the Brick sources and Brick must be re-
# built. The patch isn't needed for Brick 5.3 or above.

#---------------------------------------------------------------------
# Documentation: Changes in revision 101010.

# (a) Added a preliminary "help" screen;  it can be accessed using the
# "h" key.

# (b) Added the  start of a  player inventory (or backpack).  Added an
# associated "inventory" screen,  which can be accessed using  the "i"
# key.

# (c) Reorganized the information display. It has two columns now, and
# a message line has been added.

# (d) Added cows. Presently, cows are simply grazers who happen to eat
# red enemies.

# (e) Added trees. The player can hide behind trees, but only once per
# tree and shooting from there breaks cover.

# (f) Added money.  Money  simply goes  into  the  player's inventory;
# there's no way to spend it yet.

# (g) New subroutine keywords: "dmproc" and "xproc".  "dmproc" extends
# "proc" and adds some debugging features.  "xproc" extends "proc" and
# adds support for call-by-reference.

# (h) New sound effects: "moo" and "bonus"  (played  when  a health or
# financial bonus is received).

# (i) Added  support for a new  data compression format (bxdiv).  It's
# intended primarily for use with sound data.

# (j) For some  object classes  (including cows, medical kits, and red
# enemies), object are now given individual names.

# (k) Most object-related  parameters can now be set using either glo-
# bal defaults or per-world values.

# (l) The main sprite prototype setup routine (make_proto_sprite)  now
# supports up to 64 colors per sprite.

# (m) Added more documentation.

#---------------------------------------------------------------------
# Documentation: Changes in revision 101003.

# (a) Notable user-visible items added (summary):  Multiple worlds and
# inter-world portals.  Scrolls.  Variable-size enemies. Variable-size
# random maps.  Limbo  (a world that has no map, walls,  or floor  and
# that  wraps around).  Caspak  (a world that's  simple  but not  very
# friendly).

# (b) Notable  internal features added  (summary):  "base64" decoding.
# LZ77 decompression.  Background music is now built-in.  Sprites  can
# be drawn as simple text diagrams. It's easy to add new worlds and to
# connect them in different ways. A specified number of enemies may be
# preloaded.

# (c) "base64"  decoding:  Pure-Tcl support for  "base64" decoding has
# been added. No external programs or Tcl modules are required for de-
# coding.

# (d) LZ77 decompression:  Pure-Tcl support for LZ77 decompression has
# been added. No external programs or Tcl modules are required for de-
# compression.

# The LZ77 feature  may be  used in conjunction with the "base64" fea-
# ture to load  binary data from a compressed but ASCII-encoded repre-
# sentation.

# Note: If you'd like to add  new compressed objects to this  program,
# you'll  need  to use  a  separate LZ77 compression tool named "lzbe-
# tool".  "lzbetool" is a short pure-Tcl script that should be availa-
# ble from the same place as this program.

# (e) Music: Background music is now built into the program; it's rep-
# resented as  LZ77-compressed and base64-encoded inline data.  No ex-
# ternal music file  is required.  However,  external  music files are
# still supported. For more information,  see PlayMusic and MusicFile.
# Additional minor change: The MusicVolume setting is now optional.

# (f) Sound effects: Sound effects have switched from simple "hex" en-
# coding to LZ77-compressed and base64-encoded blocks; this makes them
# significantly smaller.

# (g) Multiple worlds:  The program now  supports multiple  rooms  (or
# worlds).

# Two types of inter-world portals have been added: "forward" and "re-
# verse".  These are similar to Netscape  "down" and "up" stairs,  but
# they can be used more generally. For more information, see the docu-
# mentation section named "Inter-world portals".

# The multiple-worlds feature works  both  in  random-map  mode  (with
# RandomMapEnable set to one) and in invariant-map mode (with the par-
# ameter in question set to zero). However, in invariant-map mode, the
# coder must  pre-define an invariant map for every world that's going
# to be used.

# (h) Scrolls:  The game now  includes  scrolls.  Presently, these are
# "demo" objects that simply display random quotes (or fortunes).  The
# number of scrolls may be specified on a  per-world basis.  It may be
# set to zero, a fixed number, or a range.

# (i) Intra-world portals:  The number of  intra-world portals may now
# be set on a per-world basis.  It may be set to zero, a fixed number,
# or a range.

# (j) Enemies: Three different red-enemy sizes are now supported.  The
# size used may be set on a per-world basis. Enemies may be preloaded;
# i.e., generated as part of world creation. The  number of enemies to
# preload may be set on a per-world basis.

# (k) Info display:  The info  display  has  been  moved  to  its  own
# (transparent) layer. The code tries to keep the  info-display  layer
# on top. The width of the info display is now parameterized. The info
# display now includes the name of the current world.

# (l) Sprite definitions:  It's easy to  define  sprites  images  now;
# they're drawn as inline text.  For the time being,  all sprites have
# switched  to the  inline-text approach.  Some sprites may use  other
# approaches in the future. For more information about the new conven-
# tions, see "make_proto_sprite".

# (m) Random maps: Random maps have variable dimensions now. Addition-
# ally, some bugs in the random-map generator have been fixed.

# (n) Message screens: The arrow keys may now be used to close message
# boxes  (such  as  those  created  for  the  startup  message  and/or
# scrolls). The Escape and Q keys still work, as well.

# (o) Miscellaneous: Most of the code has been moved into subroutines.
# A fair amount of  documentation  has  been added.  Additionally, the
# program now includes "debug" code. The "debug" code is controlled by
# a new parameter named DebugLevel.

# There's now a configurable upper limit on the maximum number of bul-
# lets that can exist  simultaneously in a  given level.  The limit is
# needed because of  the  way that Limbo  works;  without a limit, the
# number of bullets might increase indefinitely.

# The B.E. text-string engine seems to limit  strings  to a few lines'
# worth of text. The program's main message-display routine (presently
# named "show_msg") has been modified  to  work around the limitation.
# The new version breaks messages up into lines and displays the lines
# separately.

#---------------------------------------------------------------------
# Documentation: Changes in revision 100923.

# Random game maps are now supported
# Maps are no longer limited to a single size
# Added optional medical kits
# Medical kits are alive; the player needs to catch them
# Added optional teleportation portals
# Sprite creation frequency is now configurable
# Maximum number of sprites may now be capped
# Added chroma-key setup code
# Sprite colors are now configurable
# Sprites now move in 8 directions as opposed to 4
# Reformatted sprite creation code to make layout visible
# Reformatted default game map     to make layout visible
# Documented "hex" approach to raw-sound operations

#---------------------------------------------------------------------
# Documentation: Changes in revision 100922.

# (a) As of this  revision, if Brick 5.2 is  used,  the  "wrap_sprite_
# position" patch discussed elsewhere is required.  The  patch is  not
# needed for newer releases of Brick.

# (b) "Hunter" enemies have been implemented.

# (c) The default enemy speed is now configurable. Additionally,  dif-
# ferent enemies may have different speeds.

#---------------------------------------------------------------------
# Documentation: Changes in revision 100921.

# Optional background music is now supported
# Now supports systems without OpenGL
# Statistics are now displayed in a rectangular box

#---------------------------------------------------------------------
# Documentation: Changes in revision 100920a.

# Added a program parameters section
# Added a sound effect for enemies popping (when they're shot)
# Added a sound effect for getting hit by enemies
# Can now quit from the opening screen
# "Q" key now quits (as well as Escape key)
# Opening message is now displayed in a rectangular box
# Revised some of the program comments

#---------------------------------------------------------------------
# Changes in revision 100920.

# Ported program to Brick Engine 5.2 API

#---------------------------------------------------------------------
# Documentation: Terminology.

# This isn't an object-oriented program in the standard sense,  but it
# uses objects and classes in a manner of speaking.

# A object class is  something for which  two routines "new_NAME"  and
# "run_NAME" exist (NAME being the name of the class). "new_NAME" cre-
# ates an instance of  the class.  "run_NAME" is  called  subsequently
# (and repeatedly) for each instance to initiate and/or direct actions
# by the instance.

# An object-class parameter is any  program parameter that's tied to a
# particular object class.

#---------------------------------------------------------------------
# Documentation: Object-class parameters.

# 1. Most object-class parameters may be set either as global defaults
# or on a per-world basis.

# 2. Global defaults are defined as follows:
#
#     set gdata(Default_CLASS_PARAM)  ...
#
# where CLASS is an object-class  name  (ocbullet,  ocscroll,  octree,
# etc.) and PARAM is a parameter name (divmin, frequency, etc.).

# 3. To override a given parameter  for a given world, add a statement
# similar to the following at the appropriate location in  the world's
# definition section:
#
#     set gdata($World.CLASS_PARAM)   ...
#
# where, again, CLASS is an object-class name and PARAM is a parameter
# name.

# For example,  there are  no cows in  Caspak.  For cows,  the object-
# class name "occow" is used.  Therefore, to keep cows out of  Caspak,
# the following statement has been added to Caspak's world-definitions
# section:
#
#     set gdata($World.occow_maxnum)   0

# 4. Some of the most frequently used object-class parameters are dis-
# cussed in the following sections.

#---------------------------------------------------------------------
# Documentation: Object-creation modes.

# From  an  object-creation perspective, object classes are classified
# as "periodic", "upfront", or "unique".

# For "periodic" classes,  the  associated  "new_" routines are called
# directly  by the main loop in "main_routine".  The routines may also
# be called elsewhere.

# For "upfront"  classes,  the  associated  "new_" routines are called
# indirectly by "make_world"  when  a world is created;  specifically,
# through the loop in "make_world" that  invokes  "make_upfront".  The
# routines may also be called elsewhere.

# For "unique" objects,  the  associated  "new_" routines  are  called
# neither by the main loop in "main_routine" nor by the "make_upfront"
# loop in "make_world".

#---------------------------------------------------------------------
# Documentation: More about "periodic" classes.

# If an object class falls into the  "periodic" category,  the associ-
# ated "new_" routine adds new  instances  periodically  (on a  random
# basis).  Additionally,  when a world is  created,  "make_world"  may
# preload a specified number of instances.

# New instances of "periodic" classes may also be  created due to spe-
# cial-case operations.

# There's  a per-class  parameter  for  classes  of  this  type  named
# "preload".  This parameter may be set for a  given class on a global
# and/or per-world  basis. It specifies the number of instances of the
# class which should be added initially when a world is created.

# There's also a  per-class parameter named "frequency" which controls
# the rate at which  new instances are added by a given class's "new_"
# routine.  This parameter  should  be a  real number from  0.00000 to
# 0.10000.  Use  smaller  numbers  to decrease the  creation rate  and
# larger numbers to increase it.

# Additionally,  there's a  per-class parameter  named  "maxnum" which
# limits the  maximum number of  instances  per world.  Note: "maxnum"
# takes precedence over "preload".

# For some periodic-generation routines,  setting the following global
# flag to one will override "frequency" once  (after that, the flag is
# reset):
#
#     gdata(force_create)
#
# Note: This flag overrides "frequency", but not "maxnum".

# "periodic" class names should be added to the following list:
#
#     list_classes_periodic

# Examples of "periodic" classes include:
#
#     occow, ockarkinos, ocmedical

#---------------------------------------------------------------------
# Documentation: More about "upfront" classes.

# If an object class falls  into the "upfront" category,  "make_world"
# adds zero or more instances to  a  world  when the world is created.
# Subsequently, new instances are added  only as the result of special
# circumstances.

# For this category, the per-class parameters  "minnum"  and  "maxnum"
# specify the minimum and  maximum number of instances per world,  re-
# spectively.

# To disable a given "upfront" class for a  given world,  set "maxnum"
# to zero for the class in that world. To make the number of instances
# a fixed  value,  set  both  "minnum" and "maxnum"  to  the  value in
# question.

# To let the program choose the number of instances from a range,  set
# "minnum" to the  first  number in the range and set  "maxnum" to the
# last number.

# "upfront" class names should be added to the following list:
#
#     list_classes_upfront

# Examples of "upfront" classes include:
#
#     ocintra, ocscroll, octree

#---------------------------------------------------------------------
# Documentation: More about special-case creation.

# Object classes that fall into the special-case creation category in-
# clude:
#
#     ocbullet - bullets
#     ocinter  - inter-world portals
#     ocplayer - player
#
# These are neither "periodic" nor "upfront" classes.

#---------------------------------------------------------------------
# Documentation: Bullets.

# Class name: ocbullet
# Sprite prototype(s): ocbullet
# Creation mode: Special

# "maxnum"  shouldn't be  set  much  higher than 30 for the "ocbullet"
# class.  If it's set too high, problems may occur in Limbo or similar
# special-case levels.

#---------------------------------------------------------------------
# Documentation: Object speed.

# For  mobile objects,  "divmin" and "divmax"  usually  affect  object
# speed.  These two parameters set minimum and maximum  "speed  divis-
# ors", respectively.

# Smaller speed divisors result in faster sprites.  Larger speed divi-
# sors reduce sprite speed.  Values of  about  3 to 5  produce average
# speeds. Presently, the minimum value supported is 1. This value pro-
# duces the maximum speed.

#---------------------------------------------------------------------
# Documentation: Inter-world portals.

# Class name: ocinter
# Sprite prototype(s): forward, reverse
# Creation mode: Special

# 1. There's  two  types of  inter-world  portals:  "forward" and "re-
# verse".  These are similar  to Nethack-style "down" and "up" stairs,
# respectively,  and games derived from  this one may use them  in the
# same way.  However,  this interpretation  is an  oversimplification;
# "forward" and/or "reverse" portals  may lead to  either  "higher" or
# "lower" levels, or to different worlds located on the same level.

# Each  "forward" portal is associated with a  destination  world name
# and a "reverse" portal located in the specified world.

# Each  "reverse" portal is associated with a  destination  world name
# and a "forward" portal located in the specified world.

# When  a world is  created (by "make_world"),  a sprite is  added for
# each  "forward" portal  that  it contains.  No "reverse" portals are
# created, initially.

# When the player enters  a  "forward" portal, the associated destina-
# tion  world is created  (unless  it  already exists)  and  he/she is
# transported to the world  in question.  The transport process adds a
# "reverse" portal  to the  destination world that is connected to the
# "forward" portal  used,  unless this was done previously (as part of
# an earlier transport).

# When the player arrives at a destination portal, the portal is lock-
# ed until he/she steps  off of it.  This prevents  infinite transport
# loops.

# 2. Each  world-definition  section  includes a block  similar to the
# following. The block defines a "to_worlds" list:
#
#     set gdata($World.to_worlds) [list \
#         $gdata(WorldElysian) \
#         $gdata(WorldEternia) \
#     ]

# To define the "forward" portals associated  with a given world,  set
# the  contents of  "to_worlds" to the names of  the  worlds  that the
# world in question connects to. Use $gdata(World...) strings as shown
# here.

# If a  given world  doesn't have any  "forward" connections to  other
# worlds, use:
#
#     set gdata($World.to_worlds) [list]

# 3. There's  no need to define  "reverse" portals  (or  any way to do
# so explicitly).  The program creates "reverse" portals automatically
# as necessary.

#---------------------------------------------------------------------
# Documentation: Intra-world portals.

# Class name: ocintra
# Sprite prototype(s): ocintra
# Creation mode: upfront

# The number of intra-world portals in a given world  may be set using
# either global defaults or per-world values.  The relevant parameters
# are:
#
#     ocintra_minnum = Minimum number of intra-world portals
#     ocintra_maxnum = Maximum number of intra-world portals

# For an explanation of how parameters such as these are set (globally
# or per world), see the preceding sections.

#---------------------------------------------------------------------
# Documentation: Scrolls.

# Class name: ocscroll
# Sprite prototype(s): ocscroll
# Creation mode: upfront

# 1. The number of ocscrolls in a given world  may be set using either
# global defaults or per-world values. The relevant parameters are:
#
#     ocscroll_minnum = Minimum number of ocscrolls
#     ocscroll_maxnum = Maximum number of ocscrolls

# For an explanation of how parameters such as these are set (globally
# or per world), see the preceding sections.

# 2. To change the contents of the ocscrolls,  replace the contents of
# "wisdom_lz77_base64". The item  in question should contain a base64-
# encoded  text version  of an  LZ77-compressed  copy  of a "fortunes"
# file. The "fortunes" file should be structured as follows:
#
#     Text for a fortune (may be multi-line)
#     %%
#     Text for another fortune
#     %%
#
# etc.  In other words, the file should contain  one or more blocks of
# text, and each block should end with a line that contains just "%%".
# Lines should  be  no longer than  36 characters,  excluding  newline
# characters.

# Note: To LZ77-compress the file, use the "lzbetool" program mention-
# ed previously.

#---------------------------------------------------------------------
# Documentation: Trees.

# Class name: octree
# Sprite prototype(s): octree
# Creation mode: upfront

# 1. The number of octrees in a given world  may  be set  using either
# global defaults or per-world values. The relevant parameters are:
#
#     octree_minnum = Minimum number of octrees
#     octree_maxnum = Maximum number of octrees

# For an explanation of how parameters such as these are set (globally
# or per world), see the preceding sections.

# 2. A player can hide  behind an octree,  but only  once per  octree.
# Leaving the octree or firing a weapon breaks cover.

# Assume:
#
#     # $lv          = Current world name
#     # $octree_id   = Sprite ID for an octree   in world $lv
#     # $ocplayer_id = Sprite ID for an ocplayer in world $lv
#
# If the following variable exists,  it contains the  sprite ID for an
# octree that the given ocplayer is presently hiding behind:
#
#     gdata($lv,$ocplayer_id.octreehide_id)
#
# If the following variable exists, the given ocplayer has used (or is
# using) the given octree for hiding:
#
#     gdata($lv,$octree_id,$ocplayer_id.octreehide_flag)

#---------------------------------------------------------------------
# Documentation: General tips.

# Destroying an object:  If instances of a  given object class  can be
# destroyed by an ocbullet or other means,  make calls similar  to the
# following in the code where this occurs:
#
#     set objclass ..         ; # Set to object-class name
#     set id ...              ; # Set to sprite I.D.
#     destroy_sprite $objclass $id

# Collisions:  If a "run_" routine checks for collisions  between  ob-
# jects, and does something when a collision occurs, but  doesn't  de-
# stroy or move either of the objects involved in a collision,  a col-
# lision lock may be required.  The  collision lock will be a variable
# used to prevent repeated processing of the same collision. For exam-
# ples of possible approaches,  see  the source code for  "run_octree"
# and/or "run_occow".

#---------------------------------------------------------------------
# Documentation: bxdiv data format.

# This program  supports (and uses)  a simple  data compression format
# that we'll call "bxdiv".

# A "bxdiv"  data block consists  of a  sequence of  8-bit bytes.  The
# block  consists of a  header  followed  by a segment  that  contains
# compressed data.

# The header starts with "bxdiv" followed by six decimal digits, which
# specify the format revision.  Presently,  the only  supported format
# revision is "101009".

# For format "101009",  the header  includes  one additional byte. The
# byte contains an integer from zero to 255.  This is a "divisor".  If
# the  divisor is  zero or one,  the data represented is  equal to the
# data segment;  i.e.,  there is  no translation.  If  the  divisor is
# greater than one, the data represented  may be  decoded  as follows:
# Take each byte in the data segment  and replace it with  N copies of
# the same byte, where N is the divisor.

#---------------------------------------------------------------------
# Documentation: Raw-sound operations: Simple hex-data version.

# If you're got a  copy of Linux that has "sox",  you can  prepare and
# use raw-sound data as follows:
#
#     (a) Start with a WAV file.  We'll assume that the  WAV-file name
#         is "foo.wav".
#
#     (b) Execute a Linux command similar to this:
#
#         sox -V foo.wav -t ub -r 44100 -c 1 foo.ub
#
#         If the volume needs to be adjusted, add a switch  similar to
#         -v 0.5 (lower-case "v") after "-V". Use  lower  numbers  for
#         lower volume and higher numbers for higher volume.
#
#     (c) Produce a  hex dump of "foo.ub"  (with exactly two hex char-
#         acters per byte). To do so under Linux, use commands similar
#         to this:
#
#         hexdump -v -e '34/1 "%02x"' -e '"\n"' foo.ub > foo.hex
#
#     (d) To load the hex dump into a Tcl variable, use Tcl code simi-
#         lar to this:
#
#         set    foo_hex ""
#         append foo_hex \
#         67707f7a7677787f7a82887d7f7b787a77 \
#         86827a848a8c8b8d8a888381878a8b8083 \
#         67707f7a7677787f7
#
#     (e) To  prepare a  Brick Engine-level  version  of  the original
#         sound, use Tcl code similar to this:
#
#         set foo_bin   [binary format H*    $foo_hex]
#         set foo_sound [br::sound load-raw  $foo_bin]
#         unset foo_bin foo_hex
#
#     (f) To play the sound, use Tcl code similar to this:
#
#         br::sound play $foo_sound

# Note: Even if you run "sox" under Linux,  the output should work un-
# der both Windows and Linux.

#---------------------------------------------------------------------
# Documentation: Raw-sound operations: base64-data version.

# If you'd like to reduce the size of inline  sound data, you can sub-
# stitute the following procedure for the  simple procedure  described
# in the previous section:
#
#     (a) Start with a WAV file.  We'll assume that the  WAV-file name
#         is "foo.wav".
#
#     (b) Execute a Linux command similar to this:
#
#         sox -V foo.wav -t ub -r 44100 -c 1 foo.ub
#
#         If the volume needs to be adjusted, add a switch  similar to
#         -v 0.5 (lower-case "v") after "-V". Use  lower  numbers  for
#         lower volume and higher numbers for higher volume.
#
#     (c) Produce a "base64" dump of "foo.ub".  To do so  under Linux,
#         use a command similar to this:
#
#         base64 --wrap=68 < foo.ub > foo.base64
#
#     (d) To load the "base64" dump into a Tcl variable,  use Tcl code
#         similar to this:
#
#         set    foo_base64 ""
#         append foo_base64 \
#         gH2Bh3x/lpSEkoJ+k4aHhoqFdnd9jnlvfn \
#         t5fn1ycX6FdGdwf3p2d3h/eoKIfX97eHp3 \
#         hoJ6hIqMi42KiIOBh==
#
#     (e) To  prepare a  Brick Engine-level  version  of  the original
#         sound, use Tcl code similar to this:
#
#         set foo_bin [base64_decode $foo_base64]
#         set foo_sound [br::sound load-raw $foo_bin]
#         unset foo_bin foo_base64
#
#         The routine called here (base64_decode) is  included in this
#         program.
#
#     (f) To play the sound, use Tcl code similar to this:
#
#         br::sound play $foo_sound

# Note: Even if you run "sox" under Linux,  the output should work un-
# der both Windows and Linux.

#---------------------------------------------------------------------
# Documentation: Raw-sound operations: LZ77-base64 version.

# If you'd like to reduce the size of inline sound data further, start
# with the  "base64" procedure described  in the  previous section and
# modify it as follows:
#
# Before producing the "base64" dump discussed in step (c),  LZ77-com-
# press the data.  To do so, use the "lzbetool" program mentioned pre-
# viously.
#
# Additionally, in step (e), replace:
#
#     set foo_bin [base64_decode $foo_base64]
# with:
#     set foo_bin [lz77_decode [base64_decode $foo_base64]]
# or:
#     set foo_bin [lz77_base64_decode $foo_base64]

# The routines called here are included in this program.

#---------------------------------------------------------------------
# Documentation: Raw-sound operations: bxdiv-LZ77-base64 version.

# To reduce the size of inline sound data yet further,  start with the
# with the "LZ77-base64" procedure described  in the  previous section
# and modify it as follows.  Important:  This should  only be done for
# sound effects that can tolerate highly-lossy compression.

# Before LZ77-compressing the data,  bxdiv-compress it.  Use a divisor
# setting of  somewhere from 2 to 10.  Lower divisors  will  result in
# better quality. Higher divisors will result in better compression.

# To bxdiv-compress data,  use the 'C' program  "data2bxdiv.c",  which
# should be available from the same place as this program.

# Additionally, in step (e),  replace the  "set foo_bin ..." statement
# with:
#     set foo_bin [bxdiv_lz77_base64_decode $foo_base64]

# The routine called here is included in this program.

#---------------------------------------------------------------------
# Program parameters: Brick API level.

# For Brick 5.2, set BRICKAPI to 5200.  For Brick 5.3,  use 5300.  For
# Brick 5.4 or above, use 5400.  Important: Older APIs  are  supported
# only for  testing purposes.  If BRICKAPI is  set to  less than 5400,
# some features will be  omitted  and  others will be only partly sup-
# ported.

set BRICKAPI 5400

#---------------------------------------------------------------------
# Documentation: Global variables.

# This documentation section is under construction.

# Important global variables include:
#
# gdata  = Array:  General global data
# layers = Array:  To be documented
# sdata  = Array:  Sprite information related to the current world
# lv     = Scalar: Current world name

#---------------------------------------------------------------------
# Program parameters: Basic colors.

set BLUE        "0000FF"
set DARKGREEN   "00AA00"
set DARKORANGE  "8B4500"
set DARKWOOD    "855E42"
set GREEN       "00FF00"
set RED         "FF0000"
set TOPAZ       "0198E1"
set WHITE       "FFFFFF"
set YELLOW      "CCCC00"

#---------------------------------------------------------------------
# Program parameters: Dimensions and graphics.

# GAME_WIDTH and GAME_HEIGHT  specify the width and height of the game
# display in pixels.  These parameters should be  set to  320 and 240,
# respectively.

set GAME_WIDTH  320
set GAME_HEIGHT 240

# To use  OpenGL, set UseOpenGL to 1.  To disable  this mode,  set this
# parameter to 0. For Brick 5.4 or above, the recommended setting is 0.
# For older Bricks, the recommended setting is 1.

# If OpenGL is used, the game won't work well with  some graphics chip-
# sets. However, for Bricks before 5.4, the alternate mode (OpenGL dis-
# abled) may also exhibit problems.  Ideally, Brick 5.4 or above should
# be used and OpenGL should be disabled.  Note  that this mode requires
# that a particular  "cmake" option be  used when  Brick is built.  For
# more information, see this program's changelog.

if { $BRICKAPI < 5400 } {
    set UseOpenGL 1
} else {
    set UseOpenGL 0
}

# DisplayWidth and  DisplayHeight specify the display width and height
# parameters passed to "br::display open".  The  recommended  settings
# are $GAME_WIDTH and $GAME_HEIGHT,  respectively,  except  for Bricks
# older than 5.4  running without  OpenGL.  In the  latter case, these
# settings should be doubled.

# DisplayScale specifies a  scale factor  (ignored  for  Bricks  older
# than 5.4 running without  OpenGL).  This parameter should be a small
# positive integer.  The  recommended setting is 1 for OpenGL mode and
# 2 for non-OpenGL mode.

# FullScreen specifies a full-screen mode flag (may be "on" or "off").
# The recommended setting is "on".

if { $UseOpenGL } {
    set DisplayWidth    $GAME_WIDTH
    set DisplayHeight   $GAME_HEIGHT
    set DisplayScale     1
    set FullScreen      on
} else {
    if { $BRICKAPI < 5400 } {
        set DisplayWidth    [expr $GAME_WIDTH  * 2]
        set DisplayHeight   [expr $GAME_HEIGHT * 2]
    } else {
        set DisplayWidth    $GAME_WIDTH
        set DisplayHeight   $GAME_HEIGHT
    }

    set DisplayScale     2
    set FullScreen      on
}

#---------------------------------------------------------------------
# Program parameters: Music.

# If you'd like to play background music,  set PlayMusic to 1;  other-
# wise, 0. The factory setting is 1.

# Background music is built into the program;  there's no need  for an
# external music file.

# If you'd like  to use the built-in music,  set MusicFile to internal
# (and set PlayMusic to 1 as well).  If  you'd like to use an external
# music file instead,  set MusicFile to a name (or pathname)  for  the
# file (and, again, set PlayMusic to 1). Note: In the latter case, any
# music-file type supported by the Brick Engine may be used.

# If you'd like to set music volume, set MusicVolume to a positive in-
# teger from  one to 100. Otherwise, set this parameter to a negative
# integer, The factory setting is 70.

set PlayMusic            1
set MusicFile     internal
set MusicVolume         70

#---------------------------------------------------------------------
# Program parameters: Frame and color formats.

# FRAFMTRGB and  FRAFMTTRA specify  Brick Engine  frame-type  strings.
# FRAFMTRGB may be used to create frames that contain only opaque pix-
# els and FRAFMTTRA may be used to create frames that may (or may not)
# contain non-opaque pixels.

# For Brick 5.2 or 5.3, both of  the "FRAFMT..." parameters should  be
# set to "rgb".  For Brick 5.4,  FRAFMTRGB should be set to "rgb"  and
# FRAFMTTRA should be set to "rgba".

# For Brick 5.2 or 5.3, frame color values are  six  hex  digits.  For
# Brick 5.4, frames of type $FRAFMTRGB work the same way but frames of
# type $FRAFMTTRA use an eight-hex digit format:  a six-hex  digit RGB
# value followed by a two-hex digit opacity value.

# Large frames  should be created using  the  $FRAFMTRGB type (and the
# associated color format) if possible.  This produces faster programs
# in Brick 5.4.

# NRDIGITS specifies the  number of hex  digits  in a  FRAFMTRGB color
# value (always 6).

# NCDIGITS specifies the  number of hex  digits  in a  FRAFMTTRA color
# value (6 for Brick 5.2 or 5.3 and 8 for Brick 5.4).

if { $BRICKAPI < 5400 } {
    set FRAFMTRGB   rgb
    set FRAFMTTRA   rgb
    set NCDIGITS    6
    set NRDIGITS    6
} else {
    set FRAFMTRGB   rgb
    set FRAFMTTRA   rgba
    set NCDIGITS    8
    set NRDIGITS    6
}

#---------------------------------------------------------------------
# Program parameters: Transparency.

# TRANSPARRGB specifies a  six-hex digit RGB value that will be mapped
# to transparency  when six-hex digit RGB values  in general are  con-
# verted to Brick Engine frame color values. The color associated with
# TRANSPARRGB should chosen so that it's  unlikely  to  conflict  with
# commonly-used colors. The factory setting is FF00FF.

# TRANSPARFRA  specifies a frame color value that  will  be treated as
# transparent.  For Brick 5.2 or 5.3,  this should be equal to $TRANS-
# PARRGB. For Brick 5.4,  this should be equal to $TRANSPARRGB follow-
# ed by the hex digits 00.

# For Brick 5.2 or 5.3,  the following  three  "CHROMA_..." parameters
# should be set:
#
#   CHROMA_R     Red   component of $TRANSPARRGB in decimal (0 to 255)
#   CHROMA_G     Green component of $TRANSPARRGB in decimal (0 to 255)
#   CHROMA_B     Blue  component of $TRANSPARRGB in decimal (0 to 255)

set TRANSPARRGB  FF00FF
set TRANSPARFRA  ${TRANSPARRGB}00

if { $BRICKAPI < 5400 } {
    set CHROMA_R     255
    set CHROMA_G       0
    set CHROMA_B     255
    set TRANSPARFRA  $TRANSPARRGB
}

#---------------------------------------------------------------------
# Program parameters: Object background colors.

# Future change:  These parameters should  eventually be  moved to the
# class level.

# Name                  Specifies background color for
# -------------------   ------------------------------
#   BG_KARKINOS         Karkinos
#   BG_MEDICAL          Medical kit
#   BG_PLAYER           Player
#   BG_PORTAL_FORWARD   Inter-world portal forward
#   BG_PORTAL_INTRA     Intra-world portal
#   BG_PORTAL_REVERSE   Inter-world portal reverse
#   BG_SCROLL           Scroll

set BG_KARKINOS         $TRANSPARRGB
set BG_MEDICAL          $TRANSPARRGB
set BG_PLAYER           $TRANSPARRGB
set BG_PORTAL_FORWARD   $YELLOW
set BG_PORTAL_INTRA     $TRANSPARRGB
set BG_PORTAL_REVERSE   $YELLOW
set BG_SCROLL           $TRANSPARRGB

#---------------------------------------------------------------------
# Program parameters: Object foreground colors.

# Future change:  These parameters should  eventually be  moved to the
# class level.

# Name                  Specifies foreground color for
# -------------------   ------------------------------
#   FG_KARKINOS         Karkinos
#   FG_MEDICAL          Medical kit
#   FG_PLAYER           Player
#   FG_PORTAL_FORWARD   Inter-world portal forward
#   FG_PORTAL_INTRA     Intra-world portal
#   FG_PORTAL_REVERSE   Inter-world portal reverse
#   FG_SCROLL           Scroll

set FG_KARKINOS         $RED
set FG_MEDICAL          $DARKGREEN
set FG_PLAYER           $BLUE
set FG_PORTAL_FORWARD   $DARKORANGE
set FG_PORTAL_INTRA     $TOPAZ
set FG_PORTAL_REVERSE   $DARKORANGE
set FG_SCROLL           $DARKWOOD

#---------------------------------------------------------------------
# Program parameters: Background tiles and layer.

# BGTileWidth specifies the width of a  background and/or info-display
# tile, in pixels. BGTileHeight is similar, but specifies height.  The
# factory settings for  these two parameters are 8 and 8,  respective-
# ly.

# For the time being, BGTileWidth and BGTileHeight shouldn't be chang-
# ed.  One or more routines  (including  "setup_background") still as-
# sume that the factory settings for the BGTile* parameters  are used.
# If the settings  are changed,  the routines in question will need to
# be modified.

# BGWidth specifies  the width of the background  and/or  info-display
# layer, in tiles. BGHeight is similar, but specifies height. Ideally,
# BGTileWidth times  BGWidth should be  equal to or a  divisor  of the
# "DisplayWidth" settings.  Additionally,  BGTileHeight times BGHeight
# should be  equal to or a  divisor of the  "DisplayHeight"  settings.
# The factory settings for BGTileWidth and BGTileHeight are 40 and 30,
# respectively.

set BGTileWidth      8
set BGTileHeight     8
set BGWidth         40
set BGHeight        30

#---------------------------------------------------------------------
# Program parameters: Random-map mode.

# To enable  random maps,  set RandomMapEnable to 1.  To disable them,
# specify 0 instead. The factory setting is 1.

# Note:  For special-case worlds,  predefined maps may be used regard-
# less of the RandomMapEnable setting.

set RandomMapEnable  1

#---------------------------------------------------------------------
# Program parameters: Random-map dimensions.

# There are four random-map dimension parameters:
#
#   Name                 Factory   Specifies
#                        Setting
#   ------------------   -------   -----------------------------
#   RandomMapWidthMin    30        Minimum map width  (in cells)
#   RandomMapWidthMax    55        Maximum map width  (in cells)
#   RandomMapHeightMin   25        Minimum map height (in cells)
#   RandomMapHeightMax   40        Maximum map height (in cells)

set RandomMapWidthMin    30
set RandomMapWidthMax    55
set RandomMapHeightMin   25
set RandomMapHeightMax   40

#---------------------------------------------------------------------
# Program parameters: Random-map tuning values.

# The following four parameters are  tuning values used during random-
# map generation.

# RandomMapFollow should be an integer from 1 to 500. The factory set-
# ting is 150.

# RandomMapPoints should be an integer or  real number  from 0 to 150.
# The factory setting is 75.

# RandomMapMinSep1 and RandomMapMinSep2 should be  integers from  4 to
# 10. The factory settings are 5 and 4, respectively.

set RandomMapFollow     150
set RandomMapPoints      75
set RandomMapMinSep1      5
set RandomMapMinSep2      4

#---------------------------------------------------------------------
# Program parameters: World names.

# Every world needs a unique name. World names are used as array keys,
# so they need  to be spelled exactly  the same  way  everywhere  that
# they're used. Therefore,  they're  defined here as "gdata(World...)"
# entries. This approach makes it possible for Tcl to detect misspell-
# ings.

# World names  should  be short  (they need to fit on the  game's info
# display). They may use most printable characters and spaces,  though
# not spaces at the beginning or end or  multiple  consecutive spaces.
# Dollar signs and double quotes are prohibited.

set gdata(WorldMain)            "Qlaviql"
set gdata(WorldCaspak)          "Caspak"
set gdata(WorldElysian)         "Elysian Fields"
set gdata(WorldEndOfAllSongs)   "End of All Songs"
set gdata(WorldEternia)         "Eternia"
set gdata(WorldHeaven)          "Heaven"
set gdata(WorldLimbo)           "Limbo"
set gdata(WorldMilk)            "Milk and Honey"

#---------------------------------------------------------------------
# Program parameters: Keyboard definitions.

# Each "Key..._Input"  parameter  should specify a Brick input-channel
# number (0 through 7). These parameters don't need to be unique.

# Each "Key..._Button" parameter  should specify a Brick button number
# that's unique (and unused) for the associated input channel.

# Each "Key..._SDLCode" parameter should specify a standard "SDLK_..."
# keycode number.

# This program directs presses of a  given key to the associated Brick
# input-channel and button combination.

set KeyH_Input              1   ; # h     -key channel
set KeyH_Button            17   ; # h     -key button
set KeyH_SDLCode          104   ; # h     -key SDL code

set KeyI_Input              1   ; # i     -key channel
set KeyI_Button            18   ; # i     -key button
set KeyI_SDLCode          105   ; # i     -key SDL code

set KeyQ_Input              0   ; # q     -key channel
set KeyQ_Button            19   ; # q     -key button
set KeyQ_SDLCode          113   ; # q     -key SDL code

set KeySpace_Input          0   ; # space -key channel
set KeySpace_Button        18   ; # space -key button
set KeySpace_SDLCode       32   ; # space -key SDL code

#---------------------------------------------------------------------
# Program parameters: Misc.

# Normally, DebugLevel should be set to 0. If this parameter is set to
# a positive integer, the program will produce debugging output.  Lar-
# ger settings will generally result in more output.

# FPS specifies the frame rate that the program aims for. This parame-
# ter is expressed in frames per second.  The  factory  setting is 50.
# Note: If you change this, you may need to modify  "FPS divisor" set-
# tings elsewhere.

set DebugLevel    0
set FPS          50

# InfoDisplayFieldWidth  is a  field width  that's  used  to construct
# idsfmt, as shown here. The factory setting is 36. idsfmt is a format
# string that's used for lines in the program's info display.

set InfoDisplayFieldWidth  36
set idsfmt "s"
set idsfmt " %-$InfoDisplayFieldWidth$idsfmt"

# MaxGodTime specifies the  maximum  amount of time  (in seconds) that
# the player spends  in "God" mode  after receiving a  "God" power-up.
# The factory setting is 120.

# NameAndRevision specifies a short string that identifies the program
# name and revision.  This string  should be  less than  21 characters
# long. The factory settings is "BEWorld" plus a space and a six-digit
# revision number.

set MaxGodTime        120
set NameAndRevision   "BEWorld 110923"

# WorldKeyStart  is used to construct  "gdata" keys that include  data
# related to various worlds.  Any reasonably unique text string should
# work.  The factory setting  is "WORLD_PARAM".  For more information,
# see any world-definition section.

set WorldKeyStart     "WORLD_PARAM"

#---------------------------------------------------------------------

# Routine:    dmproc
# Purpose:    Extended version of "dmproc"
# Arguments:  (special case, see below)

#---------------------------------------------------------------------

# "dmproc" is an extended version of  "proc" that adds some  debugging
# features.

# "dmproc" takes  the same  arguments  as "proc",  with  one addition:
# There's a new first argument named "msglev",  which must be an inte-
# ger.

# "dmproc" assumes that a global variable named  DebugLevel is defined
# and contains an integer.

# If  $DebugLevel is  greater  than  or equal to  one at compile time,
# "dmproc" prints a single-line  message  of  the form  "define NAME",
# where NAME is the name of the routine that's being defined.

# "dmproc" also makes some changes to the routine in question:
#
#     (a) Define a local variable named rtn that contains  the name of
#         the routine.
#
#     (b) If $DebugLevel is greater than or equal to $msglev  when the
#         routine is called, print the name of the routine.
#
#     (c) Define a local variable named  IE that contains an internal-
#         error message prefix string. The string includes the name of
#         the routine.

#---------------------------------------------------------------------

proc dmproc { msglev pname arglist body } {
    global DebugLevel
    if  { $DebugLevel >= 1 } { puts "define $pname" }

    set    newcode ""
    append newcode "set rtn $pname\n";
    append newcode "global DebugLevel\n";
    append newcode {if { $DebugLevel >= MSGLEV } { puts $rtn }}
    append newcode "\n"
    append newcode {set IE "$rtn: panic"}
    append newcode "\n"

    regsub -all {MSGLEV}  $newcode $msglev newcode
    proc $pname $arglist "$newcode$body"
}

#---------------------------------------------------------------------

# Routine:    xproc
# Purpose:    Extended version of "proc"
# Arguments:  (special case, see below)

# "xproc" is an  extended version of "proc" that supports pass-by-ref-
# erence.  You can use it the  same way as "proc",  but  any  argument
# names that  are prefixed with "&" are automatically passed by refer-
# ence.

# This routine is apparently by  one or more of the  following:  Keith
# Vetter,  Donal Fellows, Andreas Leitgeb.  It's believed to be redis-
# tributable.

# Original web-page URL (valid as of 2010):
#
#     http://wiki.tcl.tk/4535

#---------------------------------------------------------------------

proc xproc { pname arglist body } {
    set newcode ""
    foreach arg $arglist {
        set arg [lindex $arg 0]
        if { [string match "&*" $arg] } {
            set bare [string range $arg 1 end]
            append newcode \
                "upvar 1 \[set [list $arg]\] [list $bare]\n"
        }}
    proc $pname $arglist "$newcode#original body follows:\n$body"
}

#---------------------------------------------------------------------

# Routine:    lrandom
# Purpose:    Returns a random element from a list
# Arguments:  xlist = A Tcl list

#---------------------------------------------------------------------

dmproc 3 lrandom { xlist } {
    return [lindex $xlist [expr { int (rand() * [llength $xlist]) }]]
}

#---------------------------------------------------------------------

# Routine:    set_class_defaults_barnyard
# Purpose:    Set class defaults based on barnyard prototype
# Arguments:  objclass = Object-class name

#---------------------------------------------------------------------

# This routine sets the  class defaults for the specified class to val-
# ues that may be suitable for something similar to an occow.  The cal-
# ler may change individual defaults subsequently to fine-tune the  re-
# sults.  Additionally,  defaults may be overridden on a per-world bas-
# is.

# Presently,  the  following defaults are  set  (using the values shown
# here):

# Parameter    Use                                        Factory value
# ----------   ---------------------------------------    -------------
# divmax       Maximum speed divisor                          5
# divmin       Minimum speed divisor                          4
# dropshadow   Flag: Add drop shadow                          1
# frequency    Creation frequency                             0.00500
# maxnum       Maximum no. that can exist in one world        1
# minnum       Minimum no. that can exist in one world        1
# preload      Number of instances to preload                 1
# scalemin     Minimum scale factor (may be a real)           1.00
# scalemax     Maximum scale factor (may be a real)           2.00
# shoot_can    Flag: Can shoot one of these                   1
# shoot_effect Effect on object's health per ocbullet        -1
# shoot_score  Score change if destroyed by shooting          0
# smartmax     Maximum percentage that are smart             95
# smartmin     Minimum percentage that are smart             95
# zhint        Render-order hint                              2

#---------------------------------------------------------------------

dmproc 3 set_class_defaults_barnyard { objclass } {
    global gdata

    set gdata(Default_${objclass}_divmax)            5
    set gdata(Default_${objclass}_divmin)            4
    set gdata(Default_${objclass}_dropshadow)        1
    set gdata(Default_${objclass}_frequency)         0.00500
    set gdata(Default_${objclass}_maxnum)            1
    set gdata(Default_${objclass}_minnum)            1
    set gdata(Default_${objclass}_preload)           1
    set gdata(Default_${objclass}_scalemin)          1.00
    set gdata(Default_${objclass}_scalemax)          2.00
    set gdata(Default_${objclass}_shoot_can)         1
    set gdata(Default_${objclass}_shoot_effect)     -1
    set gdata(Default_${objclass}_shoot_score)       0
    set gdata(Default_${objclass}_smartmax)         95
    set gdata(Default_${objclass}_smartmin)         95
    set gdata(Default_${objclass}_zhint)             2
}

#---------------------------------------------------------------------
# Class parameters: Defaults for ocbullet class.

# Defaults may be overridden on a per-world basis.

# Parameter    Purpose                                   Factory value
# ----------   ---------------------------------------   -------------
# divmax       Maximum speed divisor                        1
# divmin       Minimum speed divisor                        1
# maxnum       Maximum no. that can exist in one world     20
# minnum       Minimum no. that can exist in one world      0

set gdata(Default_ocbullet_divmax)    1
set gdata(Default_ocbullet_divmin)    1
set gdata(Default_ocbullet_maxnum)   20
set gdata(Default_ocbullet_minnum)    0

#---------------------------------------------------------------------
# Class parameters: Defaults for occar class.

# This class starts with the "barnyard" prototype  discussed previous-
# ly and makes some adjustments.  Defaults may be overridden on a per-
# world basis.

set_class_defaults_barnyard occar

set gdata(Default_occar_minnum)     0
set gdata(Default_occar_maxnum)     0
set gdata(Default_occar_preload)    0
set gdata(Default_occar_scalemin)   1.00
set gdata(Default_occar_scalemax)   1.00

                              ; # List of possible names
set gdata(Default_occar_name) [list \
    Chitty-Chitty  Herbie  KARR  KITT
]

#---------------------------------------------------------------------
# Class parameters: Defaults for occow class.

# This class starts with the "barnyard" prototype discussed previously
# and makes some adjustments.  Defaults  may be  overridden on  a per-
# world basis.

set_class_defaults_barnyard occow

set gdata(Default_occow_scalemin)   2.00
set gdata(Default_occow_scalemax)   2.00

                              ; # List of possible names
set gdata(Default_occow_name) [list \
    Bessie   Buttercup  Clarabelle  Daisy  Kalikau  Latavao \
    Palauni  Tangaloa \
]

#---------------------------------------------------------------------
# Class parameters: Defaults for occross class.

# This class starts with the "barnyard" prototype discussed previously
# and makes some adjustments.  Defaults may  be  overridden on  a per-
# world basis.

set_class_defaults_barnyard occross

set gdata(Default_occross_frequency)     0
set gdata(Default_occross_maxnum)        0
set gdata(Default_occross_minnum)        0
set gdata(Default_occross_preload)       0
set gdata(Default_occross_scalemin)      2
set gdata(Default_occross_scalemax)      2
set gdata(Default_occross_shoot_can)     0

#---------------------------------------------------------------------
# Class parameters: Defaults for ocdog class.

# This class starts with the "barnyard" prototype  discussed previous-
# ly and makes some adjustments.  Defaults may be overridden on a per-
# world basis.

set_class_defaults_barnyard ocdog
set gdata(Default_ocdog_scalemax)   1.00

                              ; # List of possible names
set gdata(Default_ocdog_name) [list \
    Cerebus Lassie Rin-Tin-Tin Rover Spot
]

#---------------------------------------------------------------------
# Class parameters: Defaults for ocflames class.

# "ocflames" is a special case.  This class is  only  instantiated for
# one world, only once there, it's placed at a fixed location,  and it
# behaves more like an environment than  an  object  (so, for example,
# "nobounce" needs to be non-zero).

# Defaults may be overridden on a per-world basis.

# Parameter    Use                                       Factory value
# ----------   ---------------------------------------   -------------
# dropshadow   Flag: Add drop shadow                         0
# forceposn    Flag: Place at a specified position           1
# frequency    Creation frequency                            0
# heffect      Effect on player's health per attack         -1
# maxnum       Maximum no. that can exist in one world       0
# minnum       Minimum no. that can exist in one world       0
# nobounce     Flag: Suppress positioning bounces            1
# preload      Number of instances to preload                0
# scalemin     Minimum scale factor (may be a real)          3.00
# scalemax     Maximum scale factor (may be a real)          3.00
# shoot_can    Flag: Can shoot one of these                  0
# xpos         X-position (in pixels)                        8
# ypos         Y-position (in pixels)                        8
# zhint        Render-order hint                             0

set gdata(Default_ocflames_dropshadow)   0
set gdata(Default_ocflames_forceposn)    1
set gdata(Default_ocflames_frequency)    0
set gdata(Default_ocflames_heffect)     -1
set gdata(Default_ocflames_maxnum)       0
set gdata(Default_ocflames_minnum)       0
set gdata(Default_ocflames_nobounce)     1
set gdata(Default_ocflames_preload)      0
set gdata(Default_ocflames_scalemin)     3.0
set gdata(Default_ocflames_scalemax)     3.0
set gdata(Default_ocflames_shoot_can)    0
set gdata(Default_ocflames_xpos)         8
set gdata(Default_ocflames_ypos)         8
set gdata(Default_ocflames_zhint)        0

#---------------------------------------------------------------------
# Class parameters: Defaults for ocinter class.

# Presently, there are none.

#---------------------------------------------------------------------
# Class parameters: Defaults for ocintra class.

# Presently, there are none.

#---------------------------------------------------------------------
# Class parameters: Defaults for ockarkinos class.

# Defaults may be overridden on a per-world basis.

# Parameter    Use                                       Factory value
# ----------   ---------------------------------------   -------------
# divmax       Maximum speed divisor                         5
# divmin       Minimum speed divisor                         2
# dropshadow   Flag: Add drop shadow                         1
# frequency    Creation frequency                            0.00400
# heffect      Effect on player's health per attack         -1
# maxnum       Maximum no. that can exist in one world      20
# minnum       Minimum no. that can exist in one world       0
# preload      Number of instances to preload                0
# shoot_can    Flag: Can shoot one of these                  1
# shoot_effect Effect on object's health per ocbullet       -1
# shoot_score  Score change if destroyed by shooting         1
# smartmax     Maximum percentage that are smart            95
# smartmin     Minimum percentage that are smart            95
# zhint        Render-order hint                             1
# name         List of possible names                    (various)

set gdata(Default_ockarkinos_divmax)             5
set gdata(Default_ockarkinos_divmin)             2
set gdata(Default_ockarkinos_dropshadow)         1
set gdata(Default_ockarkinos_frequency)          0.00400
set gdata(Default_ockarkinos_heffect)           -1
set gdata(Default_ockarkinos_maxnum)            20
set gdata(Default_ockarkinos_minnum)             0
set gdata(Default_ockarkinos_preload)            0
set gdata(Default_ockarkinos_shoot_can)          1
set gdata(Default_ockarkinos_shoot_effect)      -1
set gdata(Default_ockarkinos_shoot_score)        1
set gdata(Default_ockarkinos_smartmax)          95
set gdata(Default_ockarkinos_smartmin)          95
set gdata(Default_ockarkinos_zhint)              1

# Note: Names ending with  "*" are female.  The "*" isn't displayed at
# runtime.

                              ; # List of possible names
set gdata(Default_ockarkinos_name) [list \
    Adjur     Aghi      Akten     Ankhisk   Anog      Antaan     \
    Aperakei  Argan     Arizhel*  AsKade    Atro      Auloh      \
    Azetbor*  Badich    Ba'el*    Batahr    Batrell   Be'Elanna* \
    B'Etor*   B'iJik    Chang     ChaqI     D'cIq     Dezhe      \
    D'Ghor    Divok     Dracla    Drex      DuKath    Dula       \
    Durall    Duras     Edronh    Eragh     Gelly*    Gistad     \
    Godar     Goradh    Gorkon    Gowron    Graade    Grilka*    \
    Gudag     G'Vera*   Halaylah  hiJak     Hon'Tihl  Huraga     \
    Inagh     Janar     Ja'rod    J'Ddan    Kaden     Kadi       \
    Kadrya*   Kaftter   Kagga     Kahless   Kahlest*  KaiTan     \
    Kalan     Kalim     Kalin     Kandel    Kang      Kanjis     \
    Karden    Kargan    Katilla*  Kaybok    K'Ehleyr* Kelay      \
    Kell      Kellein*  Kellen    Kelly*    Keppa     Keroth     \
    Kessec    Kessum    Kethas    Kev       KezhKe    Khidri     \
    Kian      Kintata   Klaa      Klag      Kle'eg    Klimor     \
    K'mpek    K'mpok    K'mtar    K'nara    Kodan     Koll       \
    Koloth    Komakh    Konmel    Konora*   Koord     Koplo      \
    Kor       Koronin*  Koroth    Korrath   Korris    K'Orta     \
    Koth      KothKe    Koval     Kowla     Kozak     Kras       \
    K'Ratak   K'rau     Kreg      Krenn     K'Rodak   Kromm      \
    Kruge     Kruger    k'taH*    K'tal     K'Tar*    K'Tel      \
    K'Temok   K'Tesh    Kulan     Kulge     Kurak*    Kurn       \
    Kurrozh   K'Vada    Larg      Largh     Ler'at    L'Kor      \
    Lursa*    Mabli     Maglus    Maida     Majjas    Makai      \
    Maltz     Manda*    Mara*     Margon    Martok    Memeth     \
    Merzhan   Mogh      Mohtr     Molor     Morag     Morath     \
    M'Rel     Muuda     Najuk     Nedec     Noj       Nu'Daq     \
    olahg     olmai     Ondagh    Pok       Porus     Qua'lon    \
    Qugh      Ragga     Rajuc     Rannuf    Restagh   Rocta      \
    RoKis     Ruzhe     Seegath   Seeth     Segon     Shurin     \
    Starad    Surgh     SvaD      Tagre     Tellot*   Tel'Peh    \
    Tiehar    Tignor    T'lak     T'lanak   Tog       Toragh     \
    Torak     Toral     Torghn    Torin     T'Rok     Tumek      \
    T'Var*    Unagroth  U'Qam     Vagh      Valkris*  Vathraq    \
    VeKma*    Vixis*    Vok       Voloh     Vrenn     Yatron     \
    Zharn     ZhoKa  \
]

# Related notes:

# The program now supports both  hunters and grazers as enemies.  Gra-
# zers move at random. Hunters chase the player.

# For "ockarkinos",  "smartmin" and "smartmax" specify the minimum and
# maximum percentages  of  the  "ockarkinos"  population  (in  a given
# world) that are hunters.

# Hunters aren't intelligent.  In particular,  they don't know know to
# get around walls.  As a kludge, if a hunter hits a wall,  it changes
# into a grazer temporarily. This increases the chances that the hunt-
# er will be able to find a new route.

# If you're using Brick 5.2, the "hunters" feature requires the 100922
# "bricktcl" patch to "wrap_sprite_position". If the patch is missing,
# the program will  crash.  This isn't an issue  for newer releases of
# Brick.

#---------------------------------------------------------------------
# Class parameters: Defaults for ocmedical class.

# Defaults may be overridden on a per-world basis.

# Parameter    Purpose                                   Factory value
# ----------   ---------------------------------------   -------------
# cautious     Become cautious if player is this close      50
# dropshadow   Flag: Add drop shadow                         1
# frequency    Creation frequency                            0.00200
# health       See remarks below                            15
# maxnum       Maximum no. that can exist in one world       2
# minnum       Minimum no. that can exist in one world       4
# preload      Number of instances to preload                1
# shoot_can    Flag: Can shoot one of these                  1
# shoot_effect Effect on object's health per ocbullet       -1
# shoot_score  Score change if destroyed by shooting         0
# zhint        Render-order hint                             1
# name         List of possible names                    (various)

set gdata(Default_ocmedical_cautious)            50
set gdata(Default_ocmedical_dropshadow)           1
set gdata(Default_ocmedical_frequency)            0.00200
set gdata(Default_ocmedical_health)              15
set gdata(Default_ocmedical_maxnum)               2
set gdata(Default_ocmedical_minnum)               4
set gdata(Default_ocmedical_preload)              1
set gdata(Default_ocmedical_shoot_can)            1
set gdata(Default_ocmedical_shoot_effect)        -1
set gdata(Default_ocmedical_shoot_score)          0
set gdata(Default_ocmedical_zhint)                1

                              ; # List of possible names
set gdata(Default_ocmedical_name) [list \
    Chidori     Chiyo       Chizu       Kado        Kaemon    \
    Kagami      Kamenosuke  Katsutoshi  Kazuo       Keiji     \
    Keitaro     Machi       Makoto      Maro        Masahiro  \
    Nagisa      Naoko       Ogano       Ozuru       Raiden    \
    Renjiro     Sachi       Sakae       Samaru      Taizo     \
    Tani        Taro        Yasahiro    Yoshi       Yukiko    \
    Zinan
]

# Related notes:

# "health" specifies the number of health points that an  ocmedical is
# worth.  This should be a  positive integer from  1 to 100.  The fac-
# tory setting is 15.

#---------------------------------------------------------------------
# Class parameters: Defaults for ocmoney class.

# Defaults may be overridden on a per-world basis.

# Parameter    Use                                       Factory value
# ----------   ---------------------------------------   -------------
# cautious     Become cautious if player is this close      50
# divmax       Maximum speed divisor                         5
# divmin       Minimum speed divisor                         4
# dropshadow   Flag: Add drop shadow                         1
# maxnum       Maximum no. that can exist in one world       3
# minnum       Minimum no. that can exist in one world       1
# shoot_can    Flag: Can shoot one of these                  1
# shoot_effect Effect on object's health per ocbullet       -1
# shoot_score  Score change if destroyed by shooting         0
# smartmax     Maximum percentage that are smart            95
# smartmin     Minimum percentage that are smart            95
# valmax       Maximum value per instance                   25
# valmin       Minimum value per instance                    2
# name         List of possible names                    (various)

set gdata(Default_ocmoney_cautious)              50
set gdata(Default_ocmoney_divmax)                 5
set gdata(Default_ocmoney_divmin)                 4
set gdata(Default_ocmoney_dropshadow)             1
set gdata(Default_ocmoney_maxnum)                 3
set gdata(Default_ocmoney_minnum)                 1
set gdata(Default_ocmoney_shoot_can)              1
set gdata(Default_ocmoney_shoot_effect)          -1
set gdata(Default_ocmoney_shoot_score)            0
set gdata(Default_ocmoney_smartmax)              95
set gdata(Default_ocmoney_smartmin)              95
set gdata(Default_ocmoney_valmax)                25
set gdata(Default_ocmoney_valmin)                 2

                              ; # List of possible names
set gdata(Default_ocmoney_name) [list \
    Bill Happiness Joy Success Truth
]

#---------------------------------------------------------------------
# Class parameters: Defaults for ocpig class.

# This class starts with the "barnyard" prototype  discussed previous-
# ly and makes some adjustments.  Defaults may be overridden on a per-
# world basis.

set_class_defaults_barnyard ocpig
set gdata(Default_ocpig_scalemax)   1.00

                              ; # List of possible names
set gdata(Default_ocpig_name) [list \
    Babe        Bacon     Barnaby  Freddy  Hamm  Harold \
    Peppermint  Porkchop  Wilbur
]

#---------------------------------------------------------------------
# Class parameters: Defaults for ocplayer class.

# Parameter    Purpose                                   Factory value
# ----------   ---------------------------------------   -------------
# dropshadow   Flag: Add drop shadow                        1

set gdata(Default_ocplayer_dropshadow)  1

#---------------------------------------------------------------------
# Class parameters: Defaults for ocscroll class.

# Defaults may be overridden on a per-world basis.

# Parameter    Purpose                                   Factory value
# ----------   ---------------------------------------   -------------
# dropshadow   Flag: Add drop shadow                        1
# maxnum       Maximum no. that can exist in one world      2
# minnum       Minimum no. that can exist in one world      1
# zhint        Render-order hint                            1

set gdata(Default_ocscroll_dropshadow)   1
set gdata(Default_ocscroll_maxnum)       2
set gdata(Default_ocscroll_minnum)       1
set gdata(Default_ocscroll_zhint)        1

#---------------------------------------------------------------------
# Class parameters: Defaults for octiger class.

# Defaults may be overridden on a per-world basis.

# Parameter     Use                                      Factory value
# ----------    ---------------------------------------  -------------
# divmax        Maximum speed divisor                        5
# divmin        Minimum speed divisor                        2
# dropshadow    Flag: Add drop shadow                        1
# health        Initial health points                        7
# heffect       Effect on player's health per attack        -3
# maxnum        Maximum no. that can exist in one world      2
# minnum        Minimum no. that can exist in one world      2
# scalemin      Minimum scale factor (may be a real)         1.00
# scalemax      Maximum scale factor (may be a real)         1.00
# shoot_can     Flag: Can shoot one of these                 1
# shoot_effect  Effect on object's health per ocbullet      -1
# shoot_score   Score change if destroyed by shooting        5
# sound_destroy Sound when destroyed                        briefmeow
# sound_hit     Sound when hit                              briefmeow
# smartmax      Maximum percentage that are smart           95
# smartmin      Minimum percentage that are smart           95
# name          List of possible names                   (various)

set gdata(Default_octiger_divmax)          5
set gdata(Default_octiger_divmin)          2
set gdata(Default_octiger_dropshadow)      1
set gdata(Default_octiger_health)          7
set gdata(Default_octiger_heffect)        -3
set gdata(Default_octiger_maxnum)          2
set gdata(Default_octiger_minnum)          2
set gdata(Default_octiger_scalemin)        1.00
set gdata(Default_octiger_scalemax)        1.00
set gdata(Default_octiger_shoot_can)       1
set gdata(Default_octiger_shoot_effect)   -1
set gdata(Default_octiger_shoot_score)     5
set gdata(Default_octiger_sound_destroy)  briefmeow
set gdata(Default_octiger_sound_hit)      briefmeow
set gdata(Default_octiger_smartmax)       95
set gdata(Default_octiger_smartmin)       95

                              ; # List of possible names
set gdata(Default_octiger_name) [list \
    Catrina Catzandra Catzilla Fluffy Magnificat Mewsette \
    Raggles Ripley    Tabby \
]

#---------------------------------------------------------------------
# Class parameters: Defaults for octree class.

# Defaults may be overridden on a per-world basis.

# Parameter    Use                                       Factory value
# ----------   ---------------------------------------   -------------
# dropshadow   Flag: Add drop shadow                         1
# maxnum       Maximum no. that can exist in one world      10
# minnum       Minimum no. that can exist in one world       0
# smartmax     Maximum percentage that are smart            95
# smartmin     Minimum percentage that are smart            95
# octigerdelta See remarks below                            20
# zhint        Render-order hint                            10

set gdata(Default_octree_dropshadow)       1
set gdata(Default_octree_maxnum)          10
set gdata(Default_octree_minnum)           0
set gdata(Default_octree_smartmax)        95
set gdata(Default_octree_smartmin)        95
set gdata(Default_octree_octigerdelta)    20
set gdata(Default_octree_zhint)           10

# Related notes:

# If a given octree (or forest) has a hidden octiger,  and the X and Y
# distances from a given octree to an ocplayer  are both less than the
# associated  "octiger_delta" setting,  the hidden octiger will be in-
# stantiated.

#---------------------------------------------------------------------
# "Bounce" list for "random_position_sprite".

# If "random_position_sprite" shouldn't drop objects on instances of a
# given class,  or drop instances of that class on anything else,  add
# the name of the class to the following list (list_classes_bounce).

# The list should include  ocplayer,  non-mobile classes,  and classes
# whose instances are activated and/or destroyed when the player pass-
# es over them.

# For now, mobile classes other than ocplayer should be omitted except
# where it's  important to keep instances of these classes from inter-
# acting with instances of other  classes based on random positioning.
# Explanation:  If classes are  listed  here  unnecessarily,  this may
# cause problems for "random_position_sprite".

# Note:  If the  "nobounce" flag is set  elsewhere  for  a given class
# (call it foo for the  sake of discussion),  "random_position_sprite"
# may drop an object of any class (call it bar) on an instance of  foo
# whether or not bar is listed here.

# It's important to set  "nobounce"  for classes  whose  objects  have
# large dimensions.  If this isn't done,  this may also cause problems
# for "random_position_sprite".

set gdata(list_classes_bounce) \
    [list ocinter ocintra ocplayer ocscroll octree]

#---------------------------------------------------------------------
# Other class-category lists.

# As  explained  elsewhere,  some  object classes  are  classified  as
# "periodic".  The associated  class names should be added to the fol-
# lowing list:

set gdata(list_classes_periodic) \
    [list occow occross ocdog ockarkinos ocpig ocmedical]

# As  explained  elsewhere,  some  object classes  are  classified  as
# "upfront". The associated class names should be added to the follow-
# ing list:

set gdata(list_classes_upfront) \
    [list occar ocflames ocintra ocscroll ocmoney octree]

# Note: A given class shouldn't be both "periodic" and "upfront". How-
# ever, this won't cause significant problems presently.

#---------------------------------------------------------------------
# List of classes with sprite prototypes.

# The list  defined here  holds  the  names  of  the classes for which
# sprite prototypes exist.

# The list should be initialized to empty here;  names are  added at a
# later point.

set gdata(list_classes_proto) [list]

#---------------------------------------------------------------------
# List of sounds.

# The list  defined here  holds  the  names  of  the sounds  for which
# "_bxdiv_lz77_base64" data exists. "setup_sound_effects" converts the
# sounds in question to internal (playable) format.

# The list should be initialized to empty here;  names are  added at a
# later point.

# Note:  In some contexts,  this program  prepends  "sound_"  to sound
# names. However, the "sound_" prefix is omitted in this context.

set gdata(list_sounds) [list]

#---------------------------------------------------------------------
# Compressed music file.

# music_lz77_base64 contains a LZ77-compressed and base64-encoded ver-
# sion  of the  program's  internal music file;  i.e.,  the music file
# that's  played when  PlayMusic is set to 1 and  MusicFile is  set to
# internal.

# Presently, the following music file is used: "heatbeat.mod". The MOD
# file in question is licensed under Creative Commons and is therefore
# redistributable. The artist is Aleksi Eeben.

set    music_lz77_base64 ""
append music_lz77_base64 \
aW50cm9tdXotMS5oYgABBgFjb21wb3NlZCBieSABCQEAA94AHAEDHQEBaGVhdGIBAwQg \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
DjsBCh8CABwOIg==

#---------------------------------------------------------------------
# Compressed "ocscroll" data.

# wisdom_lz77_base64  contains a  LZ77-compressed  and  base64-encoded
# version of a "fortunes" file; i.e., a text file that contains quotes
# (or "fortunes"). The quotes are used by ocscrolls.

# For an explanation of the "fortunes"-file format,  and more informa-
# tion about ocscrolls, see the documentation section named "Scrolls".

set    wisdom_lz77_base64 ""
append wisdom_lz77_base64 \
VGhlIGJlc3Qgd2F5IHRvIHByZWRpY3QgdAEDGGZ1dHVyZQppcwEEGWludmVudCBpdC4K \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
AAsS2EV4Y2VwAgAGE4ggdG9sAgAHAlZQaGlsaXAgTW9lAgAIG6o=

#---------------------------------------------------------------------
# Compressed "bonus" sound.

lappend gdata(list_sounds) bonus

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    bonus_bxdiv_lz77_base64 ""
append bonus_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEf4SCgH6Bf3x+f3l9gH+BhoSAf4B7e39+fICBfoCEg4CDgXt7fnp9 \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
BFE=

#---------------------------------------------------------------------
# Compressed "briefmeow" sound.

lappend gdata(list_sounds) briefmeow

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    briefmeow_bxdiv_lz77_base64 ""
append briefmeow_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEgAEEAYEBBQYBBwEBDQ2AfwEREgEKJAEOGIEBDw8BETUBFQEBBDYB \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
AgAKBokBDIsCAAgEJQIACQJMAgAFAVF9AgAGG9UCAAYEPwIABQogAgAPAVIBB8d/

#---------------------------------------------------------------------
# Compressed "gunshot" sound.

lappend gdata(list_sounds) gunshot

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    gunshot_bxdiv_lz77_base64 ""
append gunshot_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkBAYB6go54fqyoiKSEfKaMjoyUimxuepxyXnx2cnx6ZGJ8imhOYH50 \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
eAIAEQIlAgAPAT0BDGcCAAcBIQEHAQ==

#---------------------------------------------------------------------
# Compressed "hit" sound.

lappend gdata(list_sounds) hit

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    hit_bxdiv_lz77_base64 ""
append hit_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEgIEBBgGCg4KDg4OEhIWLioWEgoSHXJ536rxWbqSOin6dhXKPb3p7 \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
CQL4ARcYAQsZAgANAygCAA0DZgEaPgEaYwIABQN3ASU4ASujARQYAQUGAQsLARE4

#---------------------------------------------------------------------
# Compressed "loser" sound.

lappend gdata(list_sounds) loser

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    loser_bxdiv_lz77_base64 ""
append loser_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEgAEGAYEBBwgBDQF/AQcWAQMHAREgAQkRAQsaAQ4LfwEVGQEJEgEV \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
EQLeAgAGA4I=

#---------------------------------------------------------------------
# Compressed "occar" sound.

lappend gdata(list_sounds) occar

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    occar_bxdiv_lz77_base64 ""
append occar_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEgYCAgQEEAYABBAkBBAsBBBABBAqAf4CAf39/AQMEgAEDCQEEAwED \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
GDQCADgBdgEUKgIACCCw

#---------------------------------------------------------------------
# Compressed "occow" sound.

lappend gdata(list_sounds) occow

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    occow_bxdiv_lz77_base64 ""
append occow_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkIgIGAf3+AAQMBAQYGfn8BAwEBAwx/fwEGCgEFGAEECAEFC4EBAwGC \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
BdwBFFuB

#---------------------------------------------------------------------
# Compressed "occross" sound.

lappend gdata(list_sounds) occross

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    occross_bxdiv_lz77_base64 ""
append occross_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkIgoGCfoB8fH5+gIKCgH58en2AgoOAgYJ/gYCCgIGAfX59hIKGgn98 \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
AgAFBuIBBZY=

#---------------------------------------------------------------------
# Compressed "ocdog" sound.

lappend gdata(list_sounds) ocdog

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    ocdog_bxdiv_lz77_base64 ""
append ocdog_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEf35+f3+AgIB/AQMBfn8BBQcBBhB+fn1+fn4BAwqBAQYdAQcbAQgf \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
AAYU1QIADwLiAgAJBCMBEEQBD54=

#---------------------------------------------------------------------
# Compressed "ocflames" sound.

lappend gdata(list_sounds) ocflames

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    ocflames_bxdiv_lz77_base64 ""
append ocflames_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkBAoODgYGBg4SFhoaFhAEDB4eGhIGAgYKDg4B+f4OHh4SAf4KDhIOC \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
BQGaAgAFG2MCAAcDBQEHCQEOAQIABQamAQVe

#---------------------------------------------------------------------
# Compressed "ocintra" sound.

lappend gdata(list_sounds) ocintra

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    ocintra_bxdiv_lz77_base64 ""
append ocintra_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEfn+ChIF+fHh3fH5/hIWFg316eHV5e3+CgoGAeXZ0cXZ5fICCgH57 \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
AQgJAQ0KAQXgAQUBAQRMAQTgAQbeAQ0BAQYcARsSAQkPAQQJgg==

#---------------------------------------------------------------------
# Compressed "ocpig" sound.

lappend gdata(list_sounds) ocpig

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    ocpig_bxdiv_lz77_base64 ""
append ocpig_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkKgAEJAX59f4Z/e3+JhXh/g4OBfHqDin53got/dHuHhXt5gYKAenqE \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
gYiQgn6Dgnd0end8iX9vfYuKg35/hYKDgoN/fICHhIGDhYGChgIAOwSKASw0

#---------------------------------------------------------------------
# Compressed "octiger" sound.

lappend gdata(list_sounds) octiger

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    octiger_bxdiv_lz77_base64 ""
append octiger_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkIf3+AgYCBgoGDgoOCgYGAAQMBf35/fX5+fn8BAwuBgoKDhISFhYaG \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
Gj+BgoKDAgAGI1wBBhsCAAUiZwIABRuBAgAFGoEBBGcBBRUBBzsCAAUcUgEHDg==

#---------------------------------------------------------------------
# Compressed "pop" sound.

lappend gdata(list_sounds) pop

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    pop_bxdiv_lz77_base64 ""
append pop_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkBAoABAwF/gIGBAQQGgICBAQMCAQYBAQUIAQgNAQoMAQwSAQkZAQkV \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
Bn0CAAoGCQEQFwIACQGgAgAIAVQBAwQ=

#---------------------------------------------------------------------
# Compressed "poweroff" sound.

lappend gdata(list_sounds) poweroff

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    poweroff_bxdiv_lz77_base64 ""
append poweroff_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkEgAEHAX9/AQoEgH8BBAcBCAkBBwsBDQEBBCkBEBABCCmBAQdQAQQO \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
AQ+/AgAIFGACAApPEgIAChyrAgALAosBBh0=

#---------------------------------------------------------------------
# Compressed "win" sound.

lappend gdata(list_sounds) win

# This variable contains a sound effect compressed (and encoded) using
# the "bxdiv-LZ77-base64" procedure discussed in the program document-
# ation.

set    win_bxdiv_lz77_base64 ""
append win_bxdiv_lz77_base64 \
YnhkaXYxMDEwMDkGgAEtAYEBLi8BNQEBOWQBBDkBCT0BJ0YBBicBCy0BCAt/f3+KlpN4 \
#
# Binary data removed to make browsing easier. For a complete version,
# see the actual source code.
#
ChoBC2YBBroBCQEBDAwCAA042AIAFTja

#---------------------------------------------------------------------
# Misc. data.

# Future change: Document this data.

set    fr1data ""
append fr1data \
AAAAAA AAAAAA AAAAAA AAAAAA CCCCCC CCCCCC CCCCCC CCCCCC \
AAAAAA AAAAAA AAAAAA CCCCCC CCCCCC CCCCCC CCCCCC AAAAAA \
AAAAAA AAAAAA CCCCCC CCCCCC CCCCCC CCCCCC AAAAAA AAAAAA \
AAAAAA CCCCCC CCCCCC CCCCCC CCCCCC AAAAAA AAAAAA AAAAAA \
CCCCCC CCCCCC CCCCCC CCCCCC AAAAAA AAAAAA AAAAAA AAAAAA \
CCCCCC CCCCCC CCCCCC AAAAAA AAAAAA AAAAAA AAAAAA CCCCCC \
CCCCCC CCCCCC AAAAAA AAAAAA AAAAAA AAAAAA CCCCCC CCCCCC \
CCCCCC AAAAAA AAAAAA AAAAAA AAAAAA CCCCCC CCCCCC CCCCCC

set    fr2data ""
append fr2data \
DDDDDD DDDDDD DDDDDD DDDDDD CCCCCC CCCCCC CCCCCC CCCCCC \
DDDDDD DDDDDD DDDDDD CCCCCC CCCCCC CCCCCC CCCCCC DDDDDD \
DDDDDD DDDDDD CCCCCC CCCCCC CCCCCC CCCCCC DDDDDD DDDDDD \
DDDDDD CCCCCC CCCCCC CCCCCC CCCCCC DDDDDD DDDDDD DDDDDD \
CCCCCC CCCCCC CCCCCC CCCCCC DDDDDD DDDDDD DDDDDD DDDDDD \
CCCCCC CCCCCC CCCCCC DDDDDD DDDDDD DDDDDD DDDDDD CCCCCC \
CCCCCC CCCCCC DDDDDD DDDDDD DDDDDD DDDDDD CCCCCC CCCCCC \
CCCCCC DDDDDD DDDDDD DDDDDD DDDDDD CCCCCC CCCCCC CCCCCC

set    fr3data ""
append fr3data \
CCCCCC CCCCCC CCCCCC AAAAAA CCCCCC CCCCCC CCCCCC AAAAAA \
CCCCCC 888888 888888 444444 CCCCCC 888888 888888 444444 \
CCCCCC 888888 888888 444444 CCCCCC 888888 888888 444444 \
AAAAAA 444444 444444 444444 AAAAAA 444444 444444 444444 \
CCCCCC CCCCCC CCCCCC AAAAAA CCCCCC CCCCCC CCCCCC AAAAAA \
CCCCCC 888888 888888 444444 CCCCCC 888888 888888 444444 \
CCCCCC 888888 888888 444444 CCCCCC 888888 888888 444444 \
AAAAAA 444444 444444 444444 AAAAAA 444444 444444 444444

#---------------------------------------------------------------------

# Routine:    setup_graphics
# Purpose:    Sets up graphics mode
# Arguments:  None

# For related information,  see the comments  in the  "program parame-
# ters" section named "Graphics".

#---------------------------------------------------------------------

dmproc 1 setup_graphics {} {
    global BRICKAPI UseOpenGL
    global DisplayWidth DisplayHeight DisplayScale FullScreen

    if { $UseOpenGL > 0 } {
        br::graphics open accel \
            $DisplayWidth $DisplayHeight $FullScreen $DisplayScale
    } else {
        if { $BRICKAPI < 5400 } {
            br::graphics open sdl \
                $DisplayWidth $DisplayHeight $FullScreen
        } else {
            set gra_opts [list sdl]
            if { $FullScreen } { lappend gra_opts fs }
            br::graphics open \
                $DisplayWidth $DisplayHeight $DisplayScale 0 $gra_opts
        }
    }
}

#---------------------------------------------------------------------

# Routine:    lz77_decode
# Purpose:    Decompresses LZ77-compressed data
# Arguments:  data = LZ77-compressed data

# This routine decompresses the input data and returns the result.

# Note: If you'd like to create compressed data that's compatible with
# this routine,  you'll need to use  a  separate LZ77 compression tool
# named "lzbetool". "lzbetool" is a short pure-Tcl script that  should
# be available from the same place as this program.

# This routine isn't original,  but it's  believed to be redistributa-
# ble. It's based on code by Miguel Sofer that was obtained from:
#
#     http://wiki.tcl.tk/12390

#---------------------------------------------------------------------

dmproc 1 lz77_decode { data } {
    set LZ_Escape1 "\x01"
    set LZ_Escape2 "\x02"

    set output ""

    for {set i 0} {$i < [string length $data]} {incr i} {
         set char [string index $data $i]
         if { $char eq $LZ_Escape1 } {
             set char [string index $data [incr i]]
             if { ($char eq $LZ_Escape1) || ($char eq $LZ_Escape2)} {
                 append output $char
             } else {
                 scan $char %c length
                 scan [string index $data [incr i]] %c offset
                 set index [expr {[string length $output] - $offset}]
                 for {set j 0} {$j < $length} {incr j} {
                     append output [string index $output $index]
                     incr index
                 }
             }
         } elseif { $char eq $LZ_Escape2 } {
             binary scan \
                [string range $data [incr i] [incr i]] S length
             binary scan \
                [string range $data [incr i] [incr i]] S offset
             set index [expr {[string length $output] - $offset}]
             for {set j 0} {$j < $length} {incr j} {
                 append output [string index $output $index]
                 incr index
             }
         } else {
             append output $char
         }
     }

     return $output
}

#---------------------------------------------------------------------

# Routine:    makebase64
# Purpose:    Sets up a global variable used by "base64_decode"
# Arguments:  None

# This routine  initializes a global variable (named "base64")  that's
# used by  "base64_decode".  Note:  "base64_decode" calls this routine
# automatically if necessary.

# This routine isn't original,  but  it's believed to be redistributa-
# ble. It's based on Tcl "base64" support code by Stephen Uhler, Brent
# Welch, and Chris Garrigues.

#---------------------------------------------------------------------

dmproc 1 makebase64 {} {
    global base64

    set i 0
    foreach char { \
        A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
        a b c d e f g h i j k l m n o p q r s t u v w x y z \
        0 1 2 3 4 5 6 7 8 9 + / \
    } {
        set base64_tmp($char) $i ; incr i
    }

    scan z %c len

    for { set i 0 } { $i <= $len } { incr i } {
        set char [format %c $i]
        set val {}
        if { [info exists base64_tmp($char)] } {
            set val $base64_tmp($char)
        } else { set val {} }
        lappend base64 $val
    }

    scan = %c i
    set base64 [lreplace $base64 $i $i -1]
    unset base64_tmp i char len val
}

#---------------------------------------------------------------------

# Routine:    base64_decode
# Purpose:    Converts "base64"-encoded data to binary data
# Arguments:  string = "base64"-encoded string

# This  routine  returns  the data  that  the  input string represents
# (which  may be  either binary or text data).  Note:  Embedded  white
# space in the input is ignored.

# This routine isn't original,  but it's  believed to be redistributa-
# ble. It's based on Tcl "base64" support code by Stephen Uhler, Brent
# Welch, and Chris Garrigues.

#---------------------------------------------------------------------

dmproc 1 base64_decode { string } {
    global base64

    if { [string length $string] == 0 } { return "" }
    if { ![info exists    base64] || \
         ![string length $base64] } { makebase64 }

    set output ""
    binary scan $string c* X

    foreach x $X {
        set bits [lindex $base64 $x]
        if { $bits >= 0 } {
            if { [llength [lappend nums $bits]] == 4 } {
                foreach { v w z y } $nums break
                set a [expr { ($v << 2) | ($w >> 4) }]
                set b [expr { (($w & 0xF) << 4) | ($z >> 2) }]
                set c [expr { (($z & 0x3) << 6) | $y }]
                append output [binary format ccc $a $b $c]
                set nums {}
            }
        } elseif { $bits == -1 } {

# End of data. Output whatever characters remain.  The encoding algor-
# ithm dictates that we can  only have 1 or 2  padding characters.  If
# x  is  {}, we have 12 bits of input (enough  for one 8-bit  output).
# Otherwise, we have 18 bits of input (enough  for two 8-bit outputs).

            foreach {v w z} $nums break
            set a [expr { ($v << 2) | (($w & 0x30) >> 4) }]

            if { $z == {} } {
                append output [binary format c $a ]
            } else {
                set b [expr \
                    { (($w & 0xF) << 4) | (($z & 0x3C) >> 2) }]
                append output [binary format cc $a $b]
            }
            break
        } else {

# Line break or another character that  isn't part of the encoded data
# stream.  Based on RFC 2045, we should ignore this and we can option-
# ally treat it as a warning or error condition.  Presently,  this im-
# plementation  ignores characters  of this type  but doesn't  produce
# warnings or errors in this case.

            continue
        }
    }

    return $output
}

#---------------------------------------------------------------------

# Routine:    lz77_base64_decode
# Purpose:    Decodes LZ77-compressed base64-encoded data
#
# Arguments:  data = Data that was  produced by  LZ77 compression fol-
#             lowed by base64-encoding

# This routine converts the input data from "base64" format to binary,
# decompresses it, and returns the result.

#---------------------------------------------------------------------

dmproc 1 lz77_base64_decode { data } {
    return [lz77_decode [base64_decode $data]]
}

#---------------------------------------------------------------------

# Routine:    bxdiv_lz77_base64_decode
# Purpose:    Decodes bxdiv-LZ77-base64 data (see below)
# Arguments:  data =  bxdiv-LZ77-base64 data (see below)

# This routine takes data produced by "bxdiv-LZ77-base64" compression-
# encoding as input and returns  decoded-decompressed data  as output.
# For  more  information,  see the  following  documentation  section:
# bxdiv data format.

#---------------------------------------------------------------------

dmproc 1 bxdiv_lz77_base64_decode { data } {
    set data [lz77_base64_decode $data]
    set n [binary scan $data a5a6a1a* magic revision divisor data]
    if { $n != 4 }           { puts "$IE-01: $n"     ; exit 1 }
    if { $magic ne "bxdiv" } { puts "$IE-02: $magic" ; exit 1 }
    scan $divisor %c divisor
    if { $divisor < 2 } { return $data }

    set str ""
    for { set ii 1 } { $ii <= $divisor } { incr ii } {
        append str "\\1"
    }

    regsub -all {(.)} $data "$str" data
    return $data
}

#---------------------------------------------------------------------

# Routine:    setup_sound_effects_sndname
# Purpose:    Sets up one sound effect
# Arguments:  sndname = Sound name (omitting "sound_" prefix)

#---------------------------------------------------------------------

dmproc 1 setup_sound_effects_sndname { sndname } {
    global gdata
    global          ${sndname}_bxdiv_lz77_base64
    eval  set hex  $${sndname}_bxdiv_lz77_base64
    set temp_bin [bxdiv_lz77_base64_decode $hex]

    set gdata(sound_${sndname}) [br::sound load-raw $temp_bin]
    unset           ${sndname}_bxdiv_lz77_base64
}

#---------------------------------------------------------------------

# Routine:    setup_sound_effects
# Purpose:    Sets up sound effects
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 setup_sound_effects {} {
    global gdata

    foreach sound $gdata(list_sounds) {
        setup_sound_effects_sndname $sound
    }

# Set the default "exit" sound  (may be changed as  the game progress-
# es).

    set gdata(sound_exit) $gdata(sound_poweroff)

# An  inter-world portal presently sounds  the same as an  intra-world
# portal.

    set gdata(sound_ocinter) $gdata(sound_ocintra)
}

#---------------------------------------------------------------------

# Routine:    setup_audio
# Purpose:    Sets up audio (including music and sound effects)
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 setup_audio {} {
    global music_lz77_base64
    global MusicFile MusicVolume PlayMusic
                                # Initialize audio
    br::audio open speaker
                                # If music is requested, start playing
                                # the specified  file at the specified
                                # volume
    if { $PlayMusic eq "1" } {
                                # Play built-in music?
        if {$MusicFile eq "internal"} {
                                # Yes
            set   MusicDataBinary \
                [lz77_base64_decode $music_lz77_base64]
            unset music_lz77_base64
            br::song play-buffer $MusicDataBinary
        } else {
                                # No  - Play an external file
            br::song play-file $MusicFile
        }
                                # Adjust volume
        if { [info exists MusicVolume] && \
             [expr $MusicVolume >= 0] } {
            br::song adj-vol $MusicVolume
        }
    }

    setup_sound_effects       ; # Set up sound effects
}

#---------------------------------------------------------------------

# Routine:    play_sound
# Purpose:    Plays a sound
# Arguments:  name  = Sound name (omitting "sound_" prefix)
#             delay = Number passed to "after" (or zero to omit delay)

#---------------------------------------------------------------------

dmproc 1 play_sound { name delay } {
    global gdata
    if { ![regexp {^sound_} $name] } { set name sound_$name }

    if { [info exists   gdata($name)] } {
        br::sound play $gdata($name)
        if { $delay > 0 } { after $delay }
    }
}

#---------------------------------------------------------------------

# Routine:    quit_program
# Purpose:    Quits the program
# Arguments:  None

# This routine quits the program.  By default,  an appropriate  "exit"
# sound is played first. To disable the "exit" sound, use:
#
#     global gdata
#     unset  gdata(sound_exit)

#---------------------------------------------------------------------

dmproc 1 quit_program {} {
    play_sound exit 2600
    exit 0
}

#---------------------------------------------------------------------
# World definitions: Main world.

                                     ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldMain)

set gdata($World.is_invariant)     0 ; # Flag: Random maps are O.K.
set gdata($World.width)           46 ; # Default map width  (in cells)
set gdata($World.height)          32 ; # Default map height (in cells)

set gdata($World.ocintra_minnum)   1 ; # Min. no. of ocintra portals
set gdata($World.ocintra_maxnum)   3 ; # Max. no. of ocintra portals
set gdata($World.ocscroll_minnum)  1 ; # Min. no. of ocscrolls
set gdata($World.ocscroll_maxnum)  2 ; # Max. no. of ocscrolls
set gdata($World.octree_minnum)    1 ; # Min. no. of octrees
set gdata($World.octree_maxnum)    3 ; # Max. no. of octrees

                                     ; # Worlds that this one connects
                                     ; # forward to
set gdata($World.to_worlds) [list \
   $gdata(WorldElysian) $gdata(WorldMilk) \
]

set    gdata($World.map_data) ""     ; # Default map data
append gdata($World.map_data) \
1111111111111111111111111111111111111111111111 \
1----------------------------111-------------1 \
1--111111111-----1-----------111-------------1 \
1--1------------1------------111-------------1 \
1--1-1111111-------------1---111-------------1 \
1--1-1-1------1----1---------111-------------1 \
1--1---1------1----1---------111-------------1 \
1--11111------1-------1------111-------------1 \
1----1----------------1111111111-------------1 \
1----1----111----------------111-------------1 \
1----1---11------------------111-------------1 \
1----1---11-----11-----------11--------------1 \
1----1-----------------------111-----11------1 \
1--------11----------------1111111111111-----1 \
1--------11111111111------1111---------------1 \
1--------------------------1111111111111-----1 \
1---11-----------------------111-------------1 \
1--------1------11---1-------11-------------11 \
1----1--------1-------1------1-----------1--11 \
1--1------------------1------------------1--11 \
1---1----111----------1----------1-------1--11 \
1--------1-----------1---1111------------1--11 \
1-------11------1--------1-------1--1----1--11 \
1---------------------1111---------------1--11 \
1-------------1-------1--1111------1-----1--11 \
1--1111----------1-------1-------1----1--1--11 \
1--1111----1----11-------1------------1--1--11 \
1--1111---------------1111111-------111--1--11 \
1--1111--------111----1--1-------1111----1--11 \
1---------------------1--1-------1-----111--11 \
1----------------1-------1111---------------11 \
1111111111111111111111111111111111111111111111

#---------------------------------------------------------------------
# World definitions: Elysian Fields.

                                     ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldElysian)

set gdata($World.is_invariant)     0 ; # Flag: Random maps are O.K.
set gdata($World.width)           25 ; # Default map width  (in cells)
set gdata($World.height)          20 ; # Default map height (in cells)

                                     ; # ockarkinos size class
set gdata($World.ockarkinos_size)  "medium"

set gdata($World.occar_minnum)     1 ; # Min. no. of occars
set gdata($World.occar_maxnum)     1 ; # Max. no. of occars
set gdata($World.ocintra_minnum)   1 ; # Min. no. of ocintra portals
set gdata($World.ocintra_maxnum)   3 ; # Max. no. of ocintra portals
set gdata($World.ocscroll_minnum)  1 ; # Min. no. of ocscrolls
set gdata($World.ocscroll_maxnum)  1 ; # Max. no. of ocscrolls
set gdata($World.octree_minnum)    1 ; # Min. no. of octrees
set gdata($World.octree_maxnum)    3 ; # Max. no. of octrees

                                     ; # Worlds that this one connects
                                     ; # forward to
set gdata($World.to_worlds) [list \
    $gdata(WorldMilk) $gdata(WorldCaspak) \
]

set    gdata($World.map_data) ""     ; # Default map data
append gdata($World.map_data) \
1111111111111111111111111 \
1-----------------------1 \
1-----1--------1111---1-1 \
1-----1------111--11111-1 \
1--1111------11---------1 \
1-------------1---------1 \
1--1--------111---------1 \
1-11-------11-----------1 \
1-----------------------1 \
1-11-----111------------1 \
1--11----------111------1 \
1---1-----------11------1 \
1-111----------11-----1-1 \
1------11111--------111-1 \
1------11-----------111-1 \
1-------1---------------1 \
1-------1111---111111---1 \
1--------111---11--11---1 \
1-----------------------1 \
1111111111111111111111111

#---------------------------------------------------------------------
# World definitions: Limbo.

                                     ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldLimbo)

set gdata($World.is_invariant)     1 ; # Flag: This map is invariant
set gdata($World.width)           25 ; # Default map width  (in cells)
set gdata($World.height)          25 ; # Default map height (in cells)

                                     ; # No. of karkinos to preload
set gdata($World.ockarkinos_preload)  2

set gdata($World.ocintra_minnum)   1 ; # Min. no. of ocintra portals
set gdata($World.ocintra_maxnum)   3 ; # Max. no. of ocintra portals

set gdata($World.occross_maxnum)   1 ; # This world has an occross
set gdata($World.occross_preload)  1

set gdata($World.ocscroll_minnum)  1 ; # Min. no. of ocscrolls
set gdata($World.ocscroll_maxnum)  1 ; # Max. no. of ocscrolls
set gdata($World.octree_minnum)    1 ; # Min. no. of octrees
set gdata($World.octree_maxnum)    3 ; # Max. no. of octrees

                                     ; # Worlds that this one connects
                                     ; # forward to (presently none)
set gdata($World.to_worlds) [list]

set    gdata($World.map_data) ""     ; # Map data
append gdata($World.map_data) ""     ; # This map is empty

#---------------------------------------------------------------------
# World definitions: Milk and Honey.

                                     ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldMilk)

set gdata($World.is_invariant)     0 ; # Flag: Random maps are O.K.
set gdata($World.width)           52 ; # Default map width  (in cells)
set gdata($World.height)          30 ; # Default map height (in cells)

set gdata($World.occar_minnum)     1 ; # Min. no. of occars
set gdata($World.occar_maxnum)     1 ; # Max. no. of occars
set gdata($World.ocintra_minnum)   1 ; # Min. no. of ocintra portals
set gdata($World.ocintra_maxnum)   3 ; # Max. no. of ocintra portals
set gdata($World.ocscroll_minnum)  1 ; # Min. no. of ocscrolls
set gdata($World.ocscroll_maxnum)  1 ; # Max. no. of ocscrolls
set gdata($World.octree_minnum)    1 ; # Min. no. of octrees
set gdata($World.octree_maxnum)    3 ; # Max. no. of octrees

                                     ; # Worlds that this one connects
                                     ; # forward to
set gdata($World.to_worlds) [list \
    $gdata(WorldLimbo) $gdata(WorldCaspak) \
]

set    gdata($World.map_data) ""     ; # Default map data
append gdata($World.map_data) \
1111111111111111111111111111111111111111111111111111 \
1--------------------------------------------------1 \
1--11111111----------1---------------------111-----1 \
1-----111111-------------------------------111-----1 \
1--1-------11-----------------------11-----111-----1 \
1---------111----------11---111-----11-------1-----1 \
1--------------------111------1-----11-111---1-----1 \
1------1111---------11------1------------1--11-----1 \
1------------------------11-1-------1---11--1111---1 \
1------1-111--------1---11----------111------1111--1 \
1----------1111-----1-----111---------111------11--1 \
1--------111--1-----1-------1--1----1--------------1 \
1-1--11-------1-----11--111---------111------------1 \
1-1111111--1111-----11----------------111----------1 \
1------11-----111-------11--------------1-----1111-1 \
1-1--------1--111---111--1--------------1111-----1-1 \
1-111-11---11111---1111--1-----------------1-11--1-1 \
1---1-1----11--1---11---11----111111-------1-------1 \
1--------------111-11--11-----1111-1----11-111-----1 \
1----------------------1-----------1---111-------1-1 \
1------------------111-------------1---------11111-1 \
1----------------------------------1-111111--------1 \
1----------------------------------1------1--11----1 \
1-------------------11-------------111----1---1111-1 \
1-----------111---111---------------------11-------1 \
1-------------1----------------------------1-------1 \
1----------1111---111-------------111------1-------1 \
1-------------------1----------------------1---111-1 \
1--------------------------------------------------1 \
1111111111111111111111111111111111111111111111111111

#---------------------------------------------------------------------
# World definitions: Eternia.

                                     ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldEternia)

set gdata($World.is_invariant)     0 ; # Flag: Random maps are O.K.
set gdata($World.width)           54 ; # Default map width  (in cells)
set gdata($World.height)          29 ; # Default map height (in cells)

set gdata($World.ocintra_minnum)   1 ; # Min. no. of ocintra portals
set gdata($World.ocintra_maxnum)   3 ; # Max. no. of ocintra portals
set gdata($World.ocscroll_minnum)  1 ; # Min. no. of ocscrolls
set gdata($World.ocscroll_maxnum)  1 ; # Max. no. of ocscrolls
set gdata($World.octree_minnum)    1 ; # Min. no. of octrees
set gdata($World.octree_maxnum)    3 ; # Max. no. of octrees

                                     ; # Worlds that this one connects
                                     ; # forward to
set gdata($World.to_worlds) [list \
    $gdata(WorldCaspak) \
]

set    gdata($World.map_data) ""     ; # Default map data
append gdata($World.map_data) \
111111111111111111111111111111111111111111111111111111 \
1----------------------------------------------------1 \
1------------1111--11-----------11------111----------1 \
1--------11111111---1-----------11-------------------1 \
1-1------111---11---11------------------1-1111-------1 \
1-1------111----1--111------------------1------------1 \
1-1--------1----1-----------------------1--1111-1111-1 \
1----------1----1-11--------------------11----1-1--1-1 \
1----------1----1-------1111----------1--1-----------1 \
1--------111---------1--1111-----1111---11-----------1 \
1-----111111---------1111--1111-----1---111111-------1 \
1--------111-----------11---111--1--1----11--1111----1 \
1-1---11111-------11-1--------1111-11---------111----1 \
1-1---11111-------11-11-------------------------1----1 \
1-----111------11111--11-----------1------------11---1 \
1----------------------111---------111---------111---1 \
1------------------------11----------1---------111---1 \
1-------------------------1-------1111-----------1---1 \
1------------------------11-------11111----1111111---1 \
1-------------------------------------1--------------1 \
1------1111--------------1--------111-1----1---------1 \
1---------1--------------11---------111----1111111---1 \
1---------111---------11--1---------------111--------1 \
1-11-------11------11111-11--------------11----------1 \
1-11-------11----111-------------------111-----------1 \
1-11--------1---11-------------------111-------------1 \
1-----------1--11------------------------------------1 \
1----------------------------------------------------1 \
111111111111111111111111111111111111111111111111111111

#---------------------------------------------------------------------
# World definitions: Caspak.

                                     ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldCaspak)

set gdata($World.is_invariant)     1 ; # Flag: This map is invariant
set gdata($World.width)           43 ; # Map width  (in cells)
set gdata($World.height)          27 ; # Map height (in cells)

                                     ; # No. of karkinos to preload
set gdata($World.ockarkinos_preload) 10
                                     ; # ockarkinos size class
set gdata($World.ockarkinos_size)  "large"

set gdata($World.ocintra_minnum)   1 ; # Min. no. of ocintra portals
set gdata($World.ocintra_maxnum)   3 ; # Max. no. of ocintra portals
set gdata($World.ocscroll_minnum)  1 ; # Min. no. of ocscrolls
set gdata($World.ocscroll_maxnum)  1 ; # Max. no. of ocscrolls
set gdata($World.octree_minnum)    1 ; # Min. no. of octrees
set gdata($World.octree_maxnum)    3 ; # Max. no. of octrees
set gdata($World.occow_maxnum)     0 ; # This world has no occows
set gdata($World.ocdog_maxnum)     0 ; # This world has no ocdogs

                                     ; # Worlds that this one connects
                                     ; # forward to
set gdata($World.to_worlds) [list \
    $gdata(WorldEternia) \
    $gdata(WorldHeaven) \
]

set    gdata($World.map_data) ""     ; # Map data
append gdata($World.map_data) \
1111111111111111111111111111111111111111111 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1-----------------------------------------1 \
1111111111111111111111111111111111111111111

#---------------------------------------------------------------------
# World definitions: Heaven.

                                      ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldHeaven)

set gdata($World.is_invariant)      1 ; # Flag: This map is invariant
set gdata($World.width)            19 ; # Map width  (in cells)
set gdata($World.height)           13 ; # Map height (in cells)

                                      ; # World has one ocflames
set gdata($World.ocflames_minnum)   1
set gdata($World.ocflames_maxnum)   1
set gdata($World.ocflames_preload)  1

set gdata($World.ocintra_maxnum)    0 ; # No ocintra portals
set gdata($World.occow_maxnum)      0 ; # No occows
set gdata($World.ockarkinos_maxnum) 0 ; # No ockarkinos
set gdata($World.ocscroll_maxnum)   0 ; # No ocscrolls
set gdata($World.octree_maxnum)     0 ; # No octrees

                                      ; # Worlds this connects forward
                                      ; # to
set gdata($World.to_worlds) [list \
    $gdata(WorldEndOfAllSongs) \
]

set    gdata($World.map_data) ""      ; # Map data
append gdata($World.map_data) \
1111111111111111111 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1-----------------1 \
1111111111111111111

#---------------------------------------------------------------------
# World definitions: End of All Songs.

                                     ; # "gdata" key prefix string
set World $WorldKeyStart.$gdata(WorldEndOfAllSongs)

set gdata($World.is_invariant)     1 ; # Flag: This map is invariant
set gdata($World.width)           20 ; # Map width  (in cells)
set gdata($World.height)          15 ; # Map height (in cells)

set gdata($World.occow_maxnum)     0 ; # Zero occows
set gdata($World.ocintra_maxnum)   0 ; # Zero ocintra portals
set gdata($World.ocscroll_maxnum)  0 ; # Zero ocscrolls
set gdata($World.octree_maxnum)    0 ; # Zero octrees

                                     ; # Worlds that this one connects
                                     ; # forward to (none)
set gdata($World.to_worlds) [list]

set    gdata($World.map_data) ""     ; # Map data
append gdata($World.map_data) ""     ; # This map is empty

#---------------------------------------------------------------------

# Routine:    random_direction
# Purpose:    Returns a random direction number
# Arguments:  None

# "random_direction"  returns a  random direction number. For the pur-
# poses  of this  routine,  directions  are  numbered from 0 to 7  and
# should be interpreted as follows:
#
#     0: NorthWest   3: North   5: NorthEast
#     1: West                   6: East
#     2: SouthWest   4: South   7: SouthEast

#---------------------------------------------------------------------

dmproc 10 random_direction {} { return [expr { int (rand() * 8) }] }

#---------------------------------------------------------------------

# Routine:    (xproc) get_dir_vx_vy
# Purpose:    Translates a direction number to X-Y deltas
# Arguments:  dir = Direction number (see below)
#             vx  = X-delta output (passed by reference)
#             vy  = Y-delta output (passed by reference)

# This is  an  "xproc" routine;  i.e.,  it supports  "&variable"-style
# pass-by-reference.

# "dir" should be a direction number of the type returned by  "random_
# direction".

# This routine translates "dir" to X-Y deltas that represent a step of
# one unit in the  specified direction.  It sets vx  (in  the caller's
# scope) to the resulting X-delta (-1, 0, or 1).  It sets vy  (in  the
# caller's scope) to the resulting Y-delta (-1, 0, or 1).

#---------------------------------------------------------------------

if { $DebugLevel > 1 } { puts "define get_dir_vx_vy" }

xproc get_dir_vx_vy { dir &vx &vy } {
    switch $dir {
        0 { set vx -1; set vy -1 }
        1 { set vx -1; set vy  0 }
        2 { set vx -1; set vy  1 }
        3 { set vx  0; set vy -1 }
        4 { set vx  0; set vy  1 }
        5 { set vx  1; set vy -1 }
        6 { set vx  1; set vy  0 }
        7 { set vx  1; set vy  1 }
    }
}

#---------------------------------------------------------------------

# Routine:    random_int
# Purpose:    Returns a random integer in a specified range
# Arguments:  min_int = First (lower ) integer in a range
#             max_int = Last  (higher) integer in a range

# "random_int" returns a random integer that  ranges from  $min_int to
# $max_int inclusive. Special case: If $max_int is less than $min_int,
# this routine returns $max_int.

#---------------------------------------------------------------------

dmproc 10 random_int { min_int max_int } {
    set min_int [expr { int ($min_int + 0.5) }]
    set max_int [expr { int ($max_int + 0.5) }]

    if { $max_int < $min_int } { return $max_int }
    set num_int [expr $max_int - $min_int + 1]
    return [expr { $min_int + int (rand() * $num_int) }]
}

#---------------------------------------------------------------------

# Routine:    random_real
# Purpose:    Returns a random real in a specified range
# Arguments:  min_real  = First (lower ) real in a range
#             max_real  = Last  (higher) real in a range

# "random_real" returns a random real that ranges from just over $min_
# real to just under $max_real.  Special case:  If $max_real  is  less
# than or equal to $min_real, this routine returns $max_real.

#---------------------------------------------------------------------

dmproc 10 random_real { min_real max_real } {
    if { $max_real <= $min_real } { return $max_real }
    set delta [expr $max_real - $min_real]
    return [expr { $min_real + (rand() * $delta) }]
}

#---------------------------------------------------------------------

# Routine:    get_sprite_class
# Purpose:    Returns a sprite's object-class name
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 10 get_sprite_class { id } {
    global sdata
    if { ![info exists sdata($id.)]  } { puts "$IE-01" ; exit 1 }
    set callback      $sdata($id.)
    if { ![regexp {^run_} $callback] } { puts "$IE-02" ; exit 1 }
    regsub        {^run_} $callback "" objclass
    return $objclass
}

#---------------------------------------------------------------------

# Routine:    get_world_param
# Purpose:    Retrieves a world-specific variable
# Arguments:  name = Variable name

# If the  given variable  has been  set in the  context of the current
# world,  this routine returns the stored world-specific value.  Note:
# This may be anything; an integer, a list, etc.

# Otherwise, this routine returns the integer 0.

#---------------------------------------------------------------------

dmproc 100 get_world_param { name } {
    if { $DebugLevel >= 2 } { puts "$rtn $name" }
    global gdata lv WorldKeyStart
    set world_key  $WorldKeyStart.$lv

    if [info exists gdata($world_key.$name)] {
            return $gdata($world_key.$name)
    }

    return 0
}

#---------------------------------------------------------------------

# Routine:    set_world_param
# Purpose:    Sets a world-specific variable
# Arguments:  name  = Variable name
#             value = Arbitrary value

# This routine sets the given variable  to the specified value for the
# current world.  Instances of the variable that were set in  the con-
# texts of other worlds aren't affected.

#---------------------------------------------------------------------

dmproc 100 set_world_param { name value } {
    if { $DebugLevel >= 2 } { puts "$rtn $name" }
    global gdata lv WorldKeyStart
    set world_key  $WorldKeyStart.$lv
    set gdata($world_key.$name) $value
}

#---------------------------------------------------------------------

# Routine:    get_class_param
# Purpose:    Retrieves a specified parameter based on context
# Arguments:  objclass = Object-class name
#             param    = Parameter    name

# "param" may be the name of any parameter that may be associated with
# objects in the specified class.  Examples include "maxnum", "zhint",
# etc.

# If the given parameter  has been set for the given  object class  in
# the context of the current world,  this routine  returns  the stored
# world-specific  value.  Note:  This may be  anything;  an integer, a
# list, etc.

# Otherwise, if a global default setting exists for the  given  object
# class, this routine returns the stored global default value.

# Otherwise, this routine returns the integer 0.

# For more information  about  global and  per-world  parameters,  see
# "Object-class parameters".

#---------------------------------------------------------------------

dmproc 100 get_class_param { objclass param } {
    if { $DebugLevel >= 2 } { puts "$rtn $objclass $param" }
    global gdata lv WorldKeyStart

    if { [info exists lv] } {
        set world_key $WorldKeyStart.$lv
        if [info exists gdata($world_key.${objclass}_${param})] {
                return $gdata($world_key.${objclass}_${param})
        }
    }

    if { [info exists gdata(Default_${objclass}_${param})] } {
              return $gdata(Default_${objclass}_${param})
    }

    return 0
}

#---------------------------------------------------------------------

# Routine:    get_class_counter
# Purpose:    Per-world sprite counter utility routine
# Arguments:  objclass = Object-class name

# This routine returns the value of a counter that tracks  the  number
# of instances of the specified object class that exist in the current
# world.

# The counter doesn't need  to be  initialized.  If it doesn't already
# exist, this routine creates it.

#---------------------------------------------------------------------

dmproc 10 get_class_counter { objclass } {
    global gdata lv
    if { ![info exists gdata($lv,num_$objclass)] } {
                   set gdata($lv,num_$objclass) 0
    }

    return $gdata($lv,num_$objclass)
}

#---------------------------------------------------------------------

# Routine:    get_class_counter
# Purpose:    Per-world sprite counter utility routine
# Arguments:  objclass = Object-class name

# This routine returns the value of a counter that tracks  the  number
# of instances of the specified object class that exist in the current
# world.

# The counter doesn't need  to be  initialized.  If it doesn't already
# exist, this routine creates it.

#---------------------------------------------------------------------

dmproc 10 get_class_counter { objclass } {
    global gdata lv
    if { ![info exists gdata($lv,num_$objclass)] } {
                   set gdata($lv,num_$objclass) 0
    }

    return $gdata($lv,num_$objclass)
}

#---------------------------------------------------------------------

# Routine:    incr_class_counter
# Purpose:    Per-world sprite counter utility routine
# Arguments:  objclass = Object-class name

# This routine  increments  a counter  that  tracks  the number of in-
# stances  of  the specified object class  that exist  in the  current
# world and returns the result.

#---------------------------------------------------------------------

dmproc 10 incr_class_counter { objclass } {
    global gdata lv
    set n [expr [get_class_counter $objclass] + 1]
    set gdata($lv,num_$objclass) $n
    return $n
}

#---------------------------------------------------------------------

# Routine:    decr_class_counter
# Purpose:    Per-world sprite counter utility routine
# Arguments:  objclass = Object-class name

# This routine  decrements  a counter  that  tracks  the number of in-
# stances  of  the specified  object class that exist  in the  current
# world and returns the result.

#---------------------------------------------------------------------

dmproc 10 decr_class_counter { objclass } {
    global gdata lv
    set n [expr [get_class_counter $objclass] - 1]
    if { $n < 0 } { set n 0 }
    set gdata($lv,num_$objclass) $n
    return $n
}

#---------------------------------------------------------------------

# Routine:    get_object_param
# Purpose:    Gets a specified variable for a specified object
# Arguments:  id   = Sprite ID
#             name = Flag name

# This routine returns  the  value of the specified variable  for  the
# object  associated  with the specified sprite.  The variable doesn't
# need to be initialized;  if it doesn't  already exist,  this routine
# initializes it to the integer 0.

#---------------------------------------------------------------------

dmproc 10 get_object_param { id name } {
    global sdata
    if { ![info exists sdata($id.$name)] } {
                   set sdata($id.$name) 0
    }
    return            $sdata($id.$name)
}

#---------------------------------------------------------------------

# Routine:    set_object_param
# Purpose:    Sets a specified variable for a specified object
# Arguments:  id    = Sprite ID
#             name  = Flag name
#             value = Arbitrary value

# This routine  sets the  specified variable for the object associated
# with the  specified  sprite to the specified value.  It  returns the
# value in question.

#---------------------------------------------------------------------

dmproc 10 set_object_param { id name value } {
    global sdata
    set sdata($id.$name) $value
    return $value
}

#---------------------------------------------------------------------

# Routine:    get_object_name_random
# Purpose:    Selects a random name
# Arguments:  objclass = Object-class name

# If a list of possible names has been specified for  the given object
# class,  this routine returns a random name from the list. Otherwise,
# this routine returns the string "none".

# Note: Name lists specified at the  world-definitions level take pre-
# cedence over name lists specified at the global level.

# For more information  about  global and  per-world  parameters,  see
# "Object-class parameters".

#---------------------------------------------------------------------

dmproc 10 get_object_name_random { objclass } {
    set name_list [get_class_param $objclass name]
    if { $name_list eq "0" } { return "none" }
    set name [lrandom $name_list]
    regsub -all {\*} $name "" name
    return $name
}

#---------------------------------------------------------------------

# Routine:    get_object_name_current
# Purpose:    Gets the game-level name of an individual sprite
# Arguments:  id = Sprite ID

# If the  specified sprite was assigned a  game-level name when it was
# created, this routine returns the name.  Otherwise, this routine re-
# returns the string "none".

#---------------------------------------------------------------------

dmproc 10 get_object_name_current { id } {
    global sdata
    if { ![info exists sdata($id.name)] } { return "none" }
    return            $sdata($id.name)
}

#---------------------------------------------------------------------

# Routine:    destroy_sprite
# Purpose:    Destroys a specified sprite
# Arguments:  objclass = Object-class name
#             id       = Sprite ID

# The specified sprite must exist in the current world.  Additionally,
# it must be of the specified class.  This routine destroys the sprite
# at all applicable code levels.

#---------------------------------------------------------------------

dmproc 10 destroy_sprite { objclass id } {
    global gdata layers lv sdata
    set callback $sdata($id.)
                                # Consistency check
    if { $callback ne "run_$objclass" } { puts "$IE-01" ; exit 1 }

    br::list remove $layers($lv.spr-list) $id
    br::sprite delete $id
    array unset sdata $id.*
    decr_class_counter $objclass
                                # Remove any associated collision lock
    set ocplayer_id $gdata($lv,ocplayer_id)
    set xlock_id $ocplayer_id.${objclass}_id
    if { [info exists gdata($lv,$xlock_id)] } {
                unset gdata($lv,$xlock_id)
    }
}

#---------------------------------------------------------------------

# Routine:    verify_sprite_exists
# Purpose:    Used for sanity checks
# Arguments:  msg = Base message string
#             id  = Sprite ID

# This routine  verifies that the specified  sprite exists in the cur-
# rent world. To do this, it checks for the existence of:
#
#     sdata($id.)

# If  the sprite doesn't exist,  this routine prints  an error message
# and terminates the caller.  The error message includes both $msg and
# $id.

#---------------------------------------------------------------------

dmproc 10 verify_sprite_exists { msg id } {
    global lv sdata
    if { ![info exists sdata($id.)] } {
        puts "$IE-01: $msg lv=$lv id=$id" ; exit 1
    }
}

#---------------------------------------------------------------------

# Routine:    collision_sprites
# Purpose:    Sprite collision utility routine
# Arguments:  id = Sprite ID

# This routine returns a list of zero or more  sprite IDs  for sprites
# that presently overlap the specified sprite.

#---------------------------------------------------------------------

dmproc 10 collision_sprites { id } {
    global layers lv
    return [br::collision sprites $id $layers($lv.spr-list)]
}

#---------------------------------------------------------------------

# Routine:    inventory_ocmoney_get
# Purpose:    Returns player's ocmoney counter
# Arguments:  None

#---------------------------------------------------------------------

dmproc 10 inventory_ocmoney_get {} {
    global gdata
    if { ![info exists gdata(ocmoney)] } { set gdata(ocmoney) 0 }
    return $gdata(ocmoney)
}

#---------------------------------------------------------------------

# Routine:    inventory_ocmoney_add
# Purpose:    Increments player's ocmoney counter
# Arguments:  num = Number to add to ocmoney counter (may be negative)

#---------------------------------------------------------------------

dmproc 10 inventory_ocmoney_add { num } {
    global gdata
    inventory_ocmoney_get
    incr gdata(ocmoney) $num
}

#---------------------------------------------------------------------

# Routine:    inventory_get
# Purpose:    Gets description of player's inventory
# Arguments:  None

# This routine returns a list that describes the player's  current in-
# ventory. The list contains one entry per item (treating groups simi-
# lar to "50 gold coins" as single items).  If the inventory is empty,
# the list returned contains the single string "Empty".

#---------------------------------------------------------------------

dmproc 10 inventory_get {} {
    set iv [list]
    set n  [inventory_ocmoney_get]
    if { $n > 0 } { lappend iv "$n gold coins" }
    if { [llength $iv] == 0 } { lappend iv Empty }
    return $iv
}

#---------------------------------------------------------------------

# Routine:    show_msg
# Purpose:    Displays a message and waits for a keypress
# Arguments:  text = Message text (may be multi-line)

#---------------------------------------------------------------------

dmproc 1 show_msg { text xpos ypos } {
    global layers lv
    global KeyH_Button KeyH_Input
    global KeyI_Button KeyI_Input
    global KeyQ_Button KeyQ_Input
    set stglist [list]

    foreach line [split $text "\n"] {
        regsub -all {\015*\012} $line "" line
        set stg [br::string create]
        set stglist [concat $stglist $stg]
        br::string position $stg $xpos $ypos
        br::string text $stg $line
        br::list add $layers($lv.str-list) $stg
        incr ypos 8
    }

    set done        0
    set arrow_state 1

    while { $done < 1 } {
        set io(1) [br::io fetch 1]
        set io(0) [br::io fetch 0]
        set hkey  [lindex $io($KeyH_Input) 2 $KeyH_Button]
        set ikey  [lindex $io($KeyI_Input) 2 $KeyI_Button]
        set qkey  [lindex $io($KeyQ_Input) 2 $KeyQ_Button]

        if { [lindex $io(0) 7] || $qkey || \
             [br::io has-quit] } { quit_program }
        if { [lindex $io(0) 5] } { set done 1 }

        set horiz [lindex $io(0) 0 0]
        set vert  [lindex $io(0) 0 1]
        set vx [expr { $horiz < 0 ? -1 : ($horiz > 0 ? 1 : 0) }]
        set vy [expr { $vert  < 0 ? -1 : ($vert  > 0 ? 1 : 0) }]

# Undocumented feature:  Some regular keys  will  close the  displayed
# message.

        if { $vx || $vy || $hkey || $ikey } {
            if { $arrow_state == 2 } { set done 1 }
        } else {
            set arrow_state 2
        }

        br::render display
        after 25
    }

    foreach stg $stglist {
        br::list remove $layers($lv.str-list) $stg
        br::string delete $stg
    }

    after 250                 ; # Allow a moment for key to be releas-
                              ; # ed
}

#---------------------------------------------------------------------

# Routine:    display_help
# Purpose:    Displays runtime-help message
# Arguments:  None

# This routine  displays the program's runtime-help message and  waits
# for a keypress.  Enter (or an arrow key)  causes a return  to normal
# operation. Escape or Q quits the program.

#---------------------------------------------------------------------

dmproc 1 display_help {} {
    set    msg ""
    append msg \
" Help:  H  Inventory: I         \r\n"  \
" Pause: H                       \r\n"  \
" Quit:  Escape or Q             \r\n"  \
"                                \r\n"  \
" Press Enter or arrow to resume "

    show_msg $msg 10 50
}

#---------------------------------------------------------------------

# Routine:    display_inventory
# Purpose:    Displays the player's inventory
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 display_inventory {} {
    set InventoryTextWidth 30
    set msg ""
    set inventory [inventory_get]
    lappend inventory ""
    lappend inventory "Press Enter or arrow to resume"

    foreach entry $inventory {
        append msg [format " %-${InventoryTextWidth}s \r\n" $entry]
    }

    show_msg $msg 10 50
}

#---------------------------------------------------------------------

# Routine:    display_msg_startup
# Purpose:    Displays startup-time message
# Arguments:  None

# This routine  displays the program's startup-time message and  waits
# for a keypress.  Enter (or an arrow key)  causes a return  to normal
# operation. Escape or Q quits the program.

#---------------------------------------------------------------------

dmproc 1 display_msg_startup {} {
    global NameAndRevision
    set FmtName [format " %-20s " $NameAndRevision]

    set    msg ""
    append msg \
"$FmtName\r\n"                \
"\r\n"                        \
" Welcome to Hell!     \r\n"  \
" Use  arrow  keys  to \r\n"  \
" move,  Ctrl or Space \r\n"  \
" to shoot, and Esc or \r\n"  \
" Q to quit.  Find the \r\n"  \
" exit to win.         \r\n"  \
"\r\n"                        \
" Press Enter to begin "

    show_msg $msg 75 70
}

#---------------------------------------------------------------------

# Routine:    display_wisdom
# Purpose:    Displays random wisdom
# Arguments:  None

# This routine displays a random quote (or "fortune") and  waits for a
# keypress.  Enter (or an arrow key) causes a return  to normal opera-
# tion. Escape or Q quits the program.

#---------------------------------------------------------------------

dmproc 1 display_wisdom {} {
    global wisdom_list wisdom_num wisdom_lz77_base64

    if { ![info exists wisdom_list] } {
        set wisdom_txt [lz77_base64_decode $wisdom_lz77_base64]
        regsub -all {\n%%\n}    $wisdom_txt "\001" wisdom_txt
        regsub -all {\015*\012} $wisdom_txt "\012" wisdom_txt
        regsub -all {[\001]+$}  $wisdom_txt ""     wisdom_txt
        set wisdom_list [split  $wisdom_txt "\001"]
        set wisdom_num  [llength $wisdom_list]
    }

    set wisdom_idx [expr  [random_int 1 $wisdom_num] - 1]
    set text       [lindex $wisdom_list $wisdom_idx]
    set lines      [split $text "\012"]

    set msg ""
    append msg [format " %-36s\r\n" "Contents of scroll:"     ]
    append msg [format " %-36s\r\n" ""                        ]

    foreach line $lines {
        append msg [format " %-36s" $line]
        append msg "\r\n"
    }

    append msg [format " %-36s\r\n" ""                        ]
    append msg [format " %-36s\r\n" "Press Enter to continue" ]

    show_msg $msg 10 60
}

#---------------------------------------------------------------------

# Routine:    (xproc) get_target_dx_dy
# Purpose:    Gets X-Y sprite deltas
# Arguments:  base_id   = Sprite ID for a base   object
#             target_id = Sprite ID for a target object
#             dx        = X output (passed by reference)
#             dy        = Y output (passed by reference)

# This is  an  "xproc" routine;  i.e.,  it supports  "&variable"-style
# pass-by-reference.

# This routine sets dx (in the caller's scope) equal to the target ob-
# ject's  X-coordinate minus the base object's  X-coordinate.  It also
# sets dy (in the  caller's scope)  equal  to the  target object's  Y-
# coordinate minus the base object's Y-coordinate.

#---------------------------------------------------------------------

if { $DebugLevel > 1 } { puts "define get_target_dx_dy" }

xproc get_target_dx_dy { base_id target_id &dx &dy } {
    global sdata
    set base_position [br::sprite pos $base_id]
    set base_x [lindex $base_position 0]
    set base_y [lindex $base_position 1]

    set target_x $sdata($target_id.px)
    set target_y $sdata($target_id.py)
    set dx [expr $target_x - $base_x]
    set dy [expr $target_y - $base_y]
}

#---------------------------------------------------------------------

# Routine:    random_position_sprite
# Purpose:    Randomly positions a sprite
# Arguments:  id = Sprite ID

# This routine randomly positions the specified sprite.  The new loca-
# tion is guaranteed not to intersect  any  walls.  Additionally,  the
# move is guaranteed not to produce a  collision  where  either sprite
# involved  belongs to any  of the  classes  listed in  "list_classes_
# bounce".

#---------------------------------------------------------------------

dmproc 5 random_position_sprite { id } {
    global gdata layers lv sdata
    verify_sprite_exists $rtn $id

    set isolate_this 0        ; # Flag: Must isolate this object
                              ; # Get sprite class
    set objclass [get_sprite_class $id]

                                # Future change: This loop could prob-
                                # ably be replaced with "lsearch" code
    foreach callbase $gdata(list_classes_bounce) {
        if { $objclass eq $callbase } { set isolate_this 1 }
    }
                                # Is position predetermined?
    set forceposn [get_object_param $id forceposn]

# The loop-count limit used here is arbitrary.  However,  it should be
# an integer, and it should probably lie somewhere in the range of 100
# to 1000.

    for { set ii 1 } { $ii <= 500 } { incr ii } {
        if { $forceposn > 0 } {
            set xpos [get_object_param $id xpos]
            set ypos [get_object_param $id ypos]
        } else {
            set xpos [expr { int(rand()*($layers($lv.width)  * 8)) }]
            set ypos [expr { int(rand()*($layers($lv.height) * 8)) }]
        }

        br::sprite pos $id $xpos $ypos

        if { [lindex [br::collision map \
            $id $layers($lv.map) 1] 0] } { continue }
        set okay 1
        set nobounce1 [get_object_param $id nobounce]

        foreach tgt [collision_sprites $id] {
            if { $nobounce1 } { break }
            set tgt_id [lindex $tgt 1]
            set otherclass [get_sprite_class $tgt_id]
            set nobounce2 [get_object_param $tgt_id nobounce]
            if { $nobounce2 } { continue }
            if { $isolate_this } { set okay 0 }
            if { !$okay } { break }

            foreach callbase $gdata(list_classes_bounce) {
                if { $otherclass eq $callbase } {
                    set okay 0 ; break
                }
            }
        }

        if { $okay } { return }
    }

    puts "$IE-01"             ; # Shouldn't reach this point
    exit 1
}

#---------------------------------------------------------------------

# Routine:    handle_limbo
# Purpose:    Handles a special case
# Arguments:  id = Sprite ID

# This is a support routine  for "move_sprite" and "run_ocplayer".  It
# handles special cases related to the Limbo world  and/or  situations
# where the player can travel through walls.

#---------------------------------------------------------------------

dmproc 10 handle_limbo { id } {
    global gdata layers lv sdata WorldKeyStart

    if { ![info exists gdata($lv.is_empty)] || \
                     !$gdata($lv.is_empty) } {
        set ocplayer_id $gdata($lv,ocplayer_id)
        if { $id ne $ocplayer_id    } { return }
        if { ![is_ocplayer_driving] } { return }
    }

    while { 1 } {
        set max_x [expr ($layers($lv.width)  * 8) - 1]
        set max_y [expr ($layers($lv.height) * 8) - 1]

        set MyPosition [br::sprite pos $id]
        set my_x [lindex $MyPosition 0]
        set my_y [lindex $MyPosition 1]

        if { ($my_x > 0) && ($my_x < $max_x) && \
             ($my_y > 0) && ($my_y < $max_y) } { return }
        random_position_sprite $id
    }
}

#---------------------------------------------------------------------

# Routine:    move_sprite
# Purpose:    Moves an autonomous sprite
# Arguments:  id = Sprite ID

# $id should specify a sprite ID for a mobile autonomous sprite; i.e.,
# a mobile non-player  sprite such as an ockarkinos, an ocmedical,  or
# an ocbullet.

# This routine  uses "br::motion single" to move the specified sprite.
# It also  handles some  special cases  (through a  call  to  "handle_
# limbo"; for more information, see that routine).

#---------------------------------------------------------------------

dmproc 100 move_sprite { id } {
    br::motion single $id
    handle_limbo $id
}

#---------------------------------------------------------------------

# Routine:    setup_map_fixup_table
# Purpose:    Support routine for "make_random_map"
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 setup_map_fixup_table {} {
    global MapFixupTable
    set    MapFixupTable(initialized)  1

    set MapFixupTable(1--1)             {   ; # Edits a 2x2 square
        set x0y0 "-" ; set newmap($x0:$y0) "-"
    }
    set MapFixupTable(-11-)             {   ; # Edits a 2x2 square
        set x0y1 "-" ; set newmap($x0:$y1) "-"
    }
    set MapFixupTable(-11-1-)           {   ; # Edits a 3x2 rectangle
        set x1y0 "-" ; set newmap($x1:$y0) "-"
    }
    set MapFixupTable(1111-1111)        {   ; # Edits a 3x3 square
        set x1y1 "1" ; set newmap($x1:$y1) "1"
    }
    set MapFixupTable(11-1-1111)        {   ; # Edits a 3x3 square
        set x1y1 "1" ; set newmap($x1:$y1) "1"
    }
    set MapFixupTable(1-1111---)        {   ; # Edits a 3x3 square
        set x1y1 "1" ; set newmap($x1:$y1) "1"
    }
    set MapFixupTable(1--1-1111)        {   ; # Edits a 3x3 square
        set x1y0 "-" ; set newmap($x1:$y0) "-"
    }
    set MapFixupTable(1-11-1111)        {   ; # Edits a 3x3 square
        set x0y1 "-" ; set newmap($x0:$y1) "-"
        set x2y1 "-" ; set newmap($x2:$y1) "-"
    }
    set MapFixupTable(11111--11111)     {   ; # Edits a 4x3 rectangle
        set x1y1 "1" ; set newmap($x1:$y1) "1"
        set x2y1 "1" ; set newmap($x2:$y1) "1"
    }
    set MapFixupTable(1-11111-----)     {   ; # Edits a 4x3 rectangle
        set x2y1 "-" ; set newmap($x2:$y1) "-"
    }
    set MapFixupTable(----111-1-11)     {   ; # Edits a 4x3 rectangle
        set x2y1 "-" ; set newmap($x2:$y1) "-"
    }
    set MapFixupTable(11--1111----)     {   ; # Edits a 4x3 rectangle
        set x1y1 "-" ; set newmap($x1:$y1) "-"
    }
    set MapFixupTable(----111---1---11) {   ; # Edits a 4x4 square
        set x1y1 "-" ; set newmap($x1:$y1) "-"
    }
    set MapFixupTable(111---1--11-11--) {   ; # Edits a 4x4 square
        set x1y2 "-" ; set newmap($x1:$y2) "-"
    }
    set MapFixupTable(111---1--11-1---) {   ; # Edits a 4x4 square
        set x1y2 "-" ; set newmap($x1:$y2) "-"
    }
    set MapFixupTable(-11---1-111-----) {   ; # Edits a 4x4 square
        set x2y1 "-" ; set newmap($x2:$y1) "-"
    }
    set MapFixupTable(-1---1---111----) {   ; # Edits a 4x4 square
        set x2y2 "-" ; set newmap($x2:$y2) "-"
    }
    set MapFixupTable(11111--11--11111) {   ; # Edits a 4x4 square
        set x1y1 "1" ; set newmap($x1:$y1) "1"
        set x1y2 "1" ; set newmap($x1:$y2) "1"
        set x2y1 "1" ; set newmap($x2:$y1) "1"
        set x2y2 "1" ; set newmap($x2:$y2) "1"
    }
}

#---------------------------------------------------------------------

# Routine:    make_random_map
# Purpose:    Creates a random map
# Arguments:  width  = Map width  (in cells)
#             height = Map height (in cells)

# "make_random_map" returns a random map as a text string.  The string
# contains $width * $height characters.  Each character  indicates the
# contents of one map cell.  "1" represents a wall cell and "-" repre-
# sents an empty cell.

# The string is organized as follows: row 1, col 1; row 1, col 2; etc.
# through row 1, col $width;  row 2, col 1; row 2, col 2; etc. through
# row $height, col $width.

#---------------------------------------------------------------------

dmproc 1 make_random_map { width height } {
    global RandomMapFollow  RandomMapPoints
    global RandomMapMinSep1 RandomMapMinSep2
    global MapFixupTable

    if { ![info exists MapFixupTable(initialized)] } {
        setup_map_fixup_table
    }

    set area [expr $width * $height]
    set np   [expr int (($area / 100) * $RandomMapPoints)]

    for { set y 1 } { $y <= $height } { incr y } {
        for { set x 1 } { $x <= $width } { incr x } {
            set newmap($x:$y) "-"
        }
    }

    for { set x 1 } { $x <= $width   } { incr x } \
        { set newmap($x:1)       "1" }
    for { set x 1 } { $x <= $width   } { incr x } \
        { set newmap($x:$height) "1" }
    for { set y 1 } { $y <= $height  } { incr y } \
        { set newmap(1:$y)       "1" }
    for { set y 1 } { $y <= $height  } { incr y } \
        { set newmap($width:$y)  "1" }

    for { set p 1 } { $p <= $np } { incr p } {
        set x  [expr 1 + int (rand() * $width  )]
        set y  [expr 1 + int (rand() * $height )]
        set nf [expr 1 + int (rand() * $RandomMapFollow )]
        set reject 0

        if { ($x == 1) || ($x == $width ) ||
             ($y == 1) || ($y == $height) } { continue }

        for { set dx -$RandomMapMinSep1 } \
            { $dx  <= $RandomMapMinSep1 } { incr dx } {
            for { set dy -$RandomMapMinSep1 } \
                { $dy  <= $RandomMapMinSep1 } { incr dy } {

                set nx [expr $x + $dx]
                set ny [expr $y + $dy]

                if { ($nx <= 1) || ($nx >= $width  ) ||
                     ($ny <= 1) || ($ny >= $height ) } {
                    continue
                }

                if { $newmap($nx:$ny) eq "1" } {
                    set reject 1; break
                }
            }
        }

        if {$reject} { continue }
        set newmap($x,$y) "1"

        for { set i 1 } { $i < $nf } { incr i } {
            set reject 0
            set dir [expr int (rand() * 4)]

            switch $dir {
                0 { set vx -1; set vy  0 }
                1 { set vx  1; set vy  0 }
                2 { set vx  0; set vy -1 }
                3 { set vx  0; set vy  1 }
            }

            if { $vx < 0 } {
                set xa [expr $x - 1]
                set xz [expr $x - $RandomMapMinSep2]
                if { $xa <= 1 } { set reject 1; break }

                for { set nx $xa } { $nx >= $xz } { incr nx -1 } {
                    if { $nx <= 1 } { break }
                    set ya [expr $y - 1]; set yz [expr $y + 1]

                    for { set ny $ya } { $ny < $yz } { incr ny } {
                        if { ($ny >= 1) && ($ny <= $height) &&
                             $newmap($nx:$ny) eq "1" } {
                            set reject 1; break
                        }
                    }
                }
            }

            if { $vx > 0 } {
                set xa [expr $x + 1]
                set xz [expr $x + $RandomMapMinSep2]
                if { $xa >= $width } { set reject 1; break }

                for { set nx $xa } { $nx < $xz } { incr nx } {
                    if { $nx >= $width } { break }
                    set ya [expr $y - 1]; set yz [expr $y + 1]

                    for { set ny $ya } { $ny < $yz } { incr ny } {
                        if { ($ny >= 1) && ($ny <= $height) &&
                             $newmap($nx:$ny) eq "1" } {
                            set reject 1; break
                        }
                    }
                }
            }

            if { $vy < 0 } {
                set ya [expr $y - 1]
                set yz [expr $y - $RandomMapMinSep2]
                if { $ya <= 1 } { set reject 1; break }

                for { set ny $ya } { $ny >= $yz } { incr ny -1 } {
                    if { $ny <= 1 } { break }
                    set xa [expr $x - 1]; set xz [expr $x + 1]

                    for { set nx $xa } { $nx < $xz } { incr nx } {
                        if { ($nx >= 1) && ($nx <= $width) &&
                             $newmap($nx:$ny) eq "1" } {
                            set reject 1; break
                        }
                    }
                }
            }

            if { $vy > 0 } {
                set ya [expr $y + 1]
                set yz [expr $y + $RandomMapMinSep2]
                if { $ya >= $width } { set reject 1; break }

                for { set ny $ya } { $ny < $yz } { incr ny } {
                    if { $ny >= $height } { break }
                    set xa [expr $x - 1]; set xz [expr $x + 1]

                    for { set nx $xa } { $nx < $xz } { incr nx } {
                        if { ($nx >= 1) && ($nx <= $width) &&
                             $newmap($nx:$ny) eq "1" } {
                            set reject 1; break
                        }
                    }
                }
            }

            if { $reject == 0 } {
                incr x $vx
                incr y $vy
                set newmap($x:$y) "1"
            }

            if { ($x <= 1) || ($x >= $width ) ||
                 ($y <= 1) || ($y >= $height) } { break }
        }
    }

    set hm1 [expr $height - 1]
    set wm1 [expr $width  - 1]

    for { set x 2 } { $x < $width  } { incr x } \
        { set newmap($x:2)    "-"  }
    for { set x 2 } { $x < $width  } { incr x } \
        { set newmap($x:$hm1) "-"  }
    for { set y 2 } { $y < $height } { incr y } \
        { set newmap(2:$y)    "-"  }
    for { set y 2 } { $y < $height } { incr y } \
        { set newmap($wm1:$y) "-"  }

    set pass  0
    set retry 1

    if { $DebugLevel > 1 } {
        set tmpx ""
        for { set y 1 } { $y <= $height } { incr y } {
            for { set x 1 } { $x <= $width } { incr x } {
                append tmpx $newmap($x:$y)
            }

            append tmpx "\n"
        }

        puts "$rtn: pre-cleanup map:"
        puts $tmpx
    }

    while 1 {
        incr pass
        if { ($retry == 0) || ($pass > 3) } { break }
        set retry 0

        for { set y 3 } { $y < $height } { incr y } {
            for { set x 3 } { $x < $width } { incr x } {

set x3y3 "?" ; set x2y3 "?" ; set x1y3 "?" ; set x0y3 "?"
set x3y2 "?" ; set x2y2 "?" ; set x1y2 "?" ; set x0y2 "?"
set x3y1 "?" ; set x2y1 "?" ; set x1y1 "?" ; set x0y1 "?"
set x3y0 "?" ; set x2y0 "?" ; set x1y0 "?" ; set x0y0 "?"

                set x0 $x
                set y0 $y
                set x1 [expr $x - 1]
                set y1 [expr $y - 1]
                set x2 [expr $x - 2]
                set y2 [expr $y - 2]

                set x1y1 $newmap($x1:$y1)
                set x0y1 $newmap($x0:$y1)
                set x1y0 $newmap($x1:$y0)
                set x0y0 $newmap($x0:$y0)

                set x2y2 $newmap($x2:$y2)
                set x2y1 $newmap($x2:$y1)
                set x2y0 $newmap($x2:$y0)
                set x1y2 $newmap($x1:$y2)
                set x0y2 $newmap($x0:$y2)

                if { $x > 3 } {
                    set x3 [expr $x - 3]
                    set x3y2 $newmap($x3:$y2)
                    set x3y1 $newmap($x3:$y1)
                    set x3y0 $newmap($x3:$y0)
                }

                if { $y > 3 } {
                    set y3 [expr $y - 3]
                    set x2y3 $newmap($x2:$y3)
                    set x1y3 $newmap($x1:$y3)
                    set x0y3 $newmap($x0:$y3)
                }

                if { ($x > 3) && ($y > 3) } {
                    set x3 [expr $x - 3]
                    set y3 [expr $y - 3]
                    set x3y3 $newmap($x3:$y3)
                }

# The cleanup algorithm used below is based on  squares and horizontal
# rectangles.  Presently, there's no provision for working with verti-
# cal rectangles here.

# BlockOf04 is a string that represents the 2x2 square of 4 characters
# whose lower-right corner is at $x,$y.

# BlockOf06H  is a string that represents the 3x2 horizontal rectangle
# of 6 characters whose lower-right corner is at $x,$y.

# BlockOf09 is a string that represents the 3x3 square of 9 characters
# whose lower-right corner is at $x,$y.

# BlockOf12H  is a string that represents the 4x3 horizontal rectangle
# of 12 characters whose lower-right corner is at $x,$y.

# BlockOf16  is a string that represents the  4x4 square of 16 charac-
# ters whose lower-right corner is at $x,$y.

# The loop-count limit used here is arbitrary.  However,  it should be
# an integer, and it should probably lie somewhere in the range of  25
# to 100.

                for { set ii 1 } { $ii <= 50 } { incr ii } {

                    set    BlockOf04    ""
                    append BlockOf04    $x1y1 $x0y1 \
                                        $x1y0 $x0y0

                    set    BlockOf06H   ""
                    append BlockOf06H   $x2y1 $x1y1 $x0y1 \
                                        $x2y0 $x1y0 $x0y0

                    set    BlockOf09    ""
                    append BlockOf09    $x2y2 $x1y2 $x0y2 \
                                        $x2y1 $x1y1 $x0y1 \
                                        $x2y0 $x1y0 $x0y0

                    set    BlockOf12H   ""
                    append BlockOf12H   $x3y2 $x2y2 $x1y2 $x0y2 \
                                        $x3y1 $x2y1 $x1y1 $x0y1 \
                                        $x3y0 $x2y0 $x1y0 $x0y0

                    set    Blockof16    ""
                    append BlockOf16    $x3y3 $x2y3 $x1y3 $x0y3 \
                                        $x3y2 $x2y1 $x1y2 $x0y1 \
                                        $x3y1 $x2y1 $x1y1 $x0y1 \
                                        $x3y0 $x2y0 $x1y0 $x0y0

                    set modified 0

                    foreach block {
                        $BlockOf16  $BlockOf12H $BlockOf09
                        $BlockOf06H $BlockOf04
                    } {
                        set block [expr $block]
                        if { [info exists MapFixupTable($block)] } {
                                   eval  $MapFixupTable($block)
                                   set modified 1
                                   break
                        }
                    }

                    if { !$modified } break
                }
            }
        }
    }

    if { $DebugLevel > 1 } {
        set tmpx ""
        for { set y 1 } { $y <= $height } { incr y } {
            for { set x 1 } { $x <= $width } { incr x } {
                append tmpx $newmap($x:$y)
            }

            append tmpx "\n"
        }

        puts "$rtn: final map:"
        puts $tmpx
    }

    set tmp ""
    for { set y 1 } { $y <= $height } { incr y } {
        for { set x 1 } { $x <= $width } { incr x } {
            append tmp $newmap($x:$y)
        }
    }

    return $tmp
}

#---------------------------------------------------------------------

# Routine:    setup_background
# Purpose:    Sets up the program's "background" layer
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 setup_background {} {
    global fr1data
    global BGTileWidth BGTileHeight BGWidth BGHeight
    global BRICKAPI FRAFMTRGB NRDIGITS

    set n1  [string length $fr1data]
    set n2  [expr $BGTileWidth * $BGTileHeight * $NRDIGITS]
    if { $n1 != $n2 } {
        puts "$IE-01" ; exit 1
    }

    set t1  [br::tile create]
    set fr1 [br::frame create $FRAFMTRGB \
                $BGTileWidth $BGTileHeight \
                [binary format H$n1 $fr1data]]
    br::tile add-frame $t1 $fr1

    set layer_id   [br::layer add]
    set layers(bg) $layer_id

    if { $BRICKAPI < 5300 } {
        set info_list           [br::layer info $layer_id]
        set layers(bg.spr-list) [lindex $info_list 0]
        set layers(bg.map)      [lindex $info_list 1]
        set layers(bg.str-list) [lindex $info_list 2]
    } else {
        set layers(bg.spr-list) [br::layer sprite-list $layer_id]
        set layers(bg.map)      [br::layer map         $layer_id]
        set layers(bg.str-list) [br::layer string-list $layer_id]
    }

    br::map tile-size $layers(bg.map) $BGTileWidth $BGTileHeight
    br::map tile      $layers(bg.map) 1 $t1
    br::map size      $layers(bg.map) $BGWidth $BGHeight

    br::map set-data $layers(bg.map) \
        [binary format H[expr {4 * $BGWidth * $BGHeight}] \
        [string repeat 0100 [expr {$BGWidth * $BGHeight}]]]
}

#---------------------------------------------------------------------

# Routine:    setup_keyboard
# Purpose:    Sets up keyboard operations
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 setup_keyboard {} {
                                # Watch for the "h" key
    global         KeyH_Input         KeyH_Button  KeyH_SDLCode
    br::io assign $KeyH_Input button $KeyH_Button $KeyH_SDLCode

                                # Watch for the "i" key
    global         KeyI_Input         KeyI_Button  KeyI_SDLCode
    br::io assign $KeyI_Input button $KeyI_Button $KeyI_SDLCode

                                # Watch for the "q" key
    global         KeyQ_Input         KeyQ_Button  KeyQ_SDLCode
    br::io assign $KeyQ_Input button $KeyQ_Button $KeyQ_SDLCode
                                # Watch for the space key
    global         KeySpace_Input        \
                   KeySpace_Button KeySpace_SDLCode
    br::io assign $KeySpace_Input button \
                  $KeySpace_Button $KeySpace_SDLCode
}

#---------------------------------------------------------------------

# Routine:    make_proto_sprite
# Purpose:    Creates a sprite prototype
# Arguments:  Explained below

#---------------------------------------------------------------------

# 1. Usage is straightforward. Use calls similar to the following:
#
# make_proto_sprite square 4 4 1 1 \
#     [list $TRANSPARRGB $RED] move {
# ****
# *..*
# ****
# }

# 2. Arguments are:
#
# Sprite-type name.  Presently,  this should be an  object-class name,
# though special cases may arise in the future.
#
# Width in pixels and height in pixels
# Initial X-scale factor
# Initial Y-scale factor
# A list of color values    as explained below
# A motion-related argument as explained below
# A sprite drawn as inline text as shown above

# 3. Use "*" to represent a foreground pixel, "." to represent a back-
# ground pixel, and/or digits "0" through "9", lower-case letters  "a"
# through  "z", and upper-case letters  "A" through "Z"  to  represent
# pixels of up to 62 additional types, for a total of 64 possible col-
# ors.

# The terms  "foreground" and "background" are simply  convenient lab-
# els. In this context, they have no fixed meaning.

# Restrictions:  A digit can't be used in the inline-text  drawing un-
# less all preceding digits are also used.  A lower-case  letter can't
# be used unless all digits and all preceding lower-case  letters  are
# also used. An upper-case letter can't be used unless all digits, all
# lower-case letters,  and all preceding  upper-case letters  are also
# used.

# The color list  should contain a set of  six-digit  hex color codes.
# The list may be from 2 to 38 elements long. The first element speci-
# fies  the background color and the  second one specifies  the  fore-
# ground color. If subsequent elements are present,  they  specify the
# colors associated   with digits  "0",  "1", "2", etc.  through  "9",
# "a", "b", "c", etc. through  "z", and  "A", "B",  "C", etc.  through
# "Z".

# 4. For a normal mobile sprite, the motion argument should be "move".
# This installs the following Brick Engine motion program:
#
#     { add xpos, xvel
#       add ypos, yvel }

# For a  stationary sprite, the argument should be either  "nomove" or
# "stationary", though "move" presently works as well.

# For special cases,  pass any  desired  motion program instead of one
# of these keywords.  The  motion program should  consist of  a curly-
# brace block  that contains  appropriate  commands  (see the  example
# shown above).  For more information,  see the Brick Engine API docu-
# mentation.

# 5. Two or more  "make_proto_sprite" calls  may be made  for the same
# sprite type.  If this is done, the result is a sprite prototype that
# contains multiple frames (one frame per call).

# 6. On exit from a  "make_proto_sprite" call,  the  following  global
# variables are set ($name stands for the sprite-type name):
#
#     proto($name)              # Sprite prototype
#
#     gdata($name.num_frames)   # Number of frames in sprite (1+)
#
#                               # Frame index for the first frame that
#                               # was added to the current sprite pro-
#                               # totype  (subsequent calls don't cha-
#                               # nge this)
#     gdata($name.frame_index.default)
#
#                               # Frame index  for the  frame that was
#                               # just added
#     gdata($name.frame_index.newest)
#
#     gdata($name.frame_index)  # Current frame index (same as default
#                               # index until higher-level code chang-
#                               # es it)

#---------------------------------------------------------------------

dmproc 1 make_proto_sprite { \
    name width height x_scale y_scale colors move drawing } {
    global proto BRICKAPI FRAFMTTRA NRDIGITS TRANSPARRGB
    global gdata
                                # Remove white space  and quotes  from
                                # the sprite drawing
    regsub -all {[ "'\n\r\t]+}  $drawing  "" drawing

# This block is a  safety measure. It verifies that the dimensions and
# drawing provided are consistent.

    set area [expr $width * $height  ]
    set xlen [string length $drawing ]

    if { $area != $xlen } {
        puts "$IE-01: $rtn:\nDimensions and drawing\
specified for"
        puts "$name are inconsistent:"
        puts "Width: $width Height: $height Text: $drawing"
        exit 1
    }

# This block  is a  safety measure.  It verifies that  all elements in
# $colors are integers and converts  them to the appropriate number of
# hex digits.

    set clen [llength $colors]

    for { set ii 0 } { $ii < $clen } { incr ii } {
        set color [lindex $colors $ii]
        regsub {^0x} $color "" color
        set decimal_value [expr 0x$color]

        set OPACITY FF
        if { $color eq $TRANSPARRGB } { set OPACITY 00 }
        if { $BRICKAPI < 5400 } { set OPACITY "" }

        set color [format "%0${NRDIGITS}x${OPACITY}" $decimal_value]
        set colors [lreplace $colors $ii $ii $color]
    }
                                # Build a character-to-color map
    set CharMap [list "." [lindex $colors 0] "*" [lindex $colors 1]]

    set lcaval [scan a %c]    ; # ASCII value of letter "a"
    set ucaval [scan A %c]    ; # ASCII value of letter "A"
    set NumDigits    10       ; # No. of decimal digits     (10)
    set NumLCLetters 26       ; # No. of lower-case letters (26)
    set NumUCLetters 26       ; # No. of upper-case letters (26)
                              ; # No. of  possible  color chars  below
                              ; # the upper-case letters
    set NumCharsBelowUpper [expr $NumDigits + $NumLCLetters]
                              ; # No. of possible color chars (64)
    set NumColorChars \
        [expr $NumDigits + $NumLCLetters + $NumUCLetters]

    for { set ii 1 } { $ii <= $NumColorChars } { incr ii } {
        set jj [expr $ii + 1]
        set ColorHex [lindex $colors $jj]
        if { $ColorHex eq "" } { break }
        set ColorChar [expr $ii - 1]

        if { $ii > $NumDigits } {
            set ColorChar [format %c \
                [expr $lcaval + $ii - ($NumDigits + 1)]]
        }

        if { $ii > $NumCharsBelowUpper } {
            set ColorChar [format %c \
                [expr $ucaval + $ii - ($NumCharsBelowUpper + 1)]]
        }

        set CharMap [concat $CharMap $ColorChar $ColorHex]
    }
                                # Create hex version of sprite shape
    set drawing_hex [string map $CharMap $drawing]
                                # Create a frame for the sprite
    if { $BRICKAPI < 5400 } {
        global CHROMA_R CHROMA_G CHROMA_B
        set frame [br::frame create $FRAFMTTRA $width $height  \
            [binary format H* $drawing_hex] \
            $CHROMA_R $CHROMA_G $CHROMA_B]
    } else {
        set frame [br::frame create $FRAFMTTRA $width $height  \
            [binary format H* $drawing_hex]]
    }
                                # Flag: New sprite
    set is_new [expr [info exists proto($name)] ? 0 : 1]

                                # Set up the requested prototype
    if { $is_new } {
        set proto($name) [br::sprite create]
        if { $DebugLevel } { puts "proto($name)=$proto($name)" }
        if { $BRICKAPI >= 5400 } {
            br::sprite scale $proto($name) $x_scale $y_scale
        }

        br::sprite collides $proto($name) box
        set  gdata($name.num_frames) 1
    } else {
        incr gdata($name.num_frames)
    }

    set frame_index [br::sprite add-frame $proto($name) $frame]
    set gdata($name.frame_index.newest) $frame_index

    if { ![info exists gdata($name.frame_index)] } {
                   set gdata($name.frame_index)         $frame_index
                   set gdata($name.frame_index.default) $frame_index
    }

    set LocalShadows [get_class_param $name dropshadow]

    if { ($BRICKAPI >= 5400) && $LocalShadows } {
        br::sprite add-subframe $proto($name) \
        $frame_index \
        [br::frame effect $frame dropshadow 2 2 4 40 40 40]
    }

    br::sprite bound $proto($name) $frame_index 0 0 $width $height

    if { $is_new } {

        if { $move eq "move" } {
            br::sprite load-program $proto($name) \
                { add xpos, xvel
                  add ypos, yvel }
        } elseif { $move eq "nomove"     } {
        } elseif { $move eq "stationary" } {
        } else {
            br::sprite load-program $proto($name) $move"
        }
    }

    return $frame_index
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocbullet
# Purpose:    Creates a sprite prototype: ocbullet class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocbullet

dmproc 1 make_proto_ocbullet {} {
    global BG_BULLET FG_BULLET
    make_proto_sprite ocbullet \
        1 1 1 1 [list 0 0] move {
*
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_occar
# Purpose:    Creates a sprite prototype: occar class
# Arguments:  None

# Note: The associated sprite should be a small car driving left.  See
# "make_proto_ocplayer".

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) occar

dmproc 1 make_proto_occar {} {
    global TRANSPARRGB
    make_proto_sprite occar \
        22 9 1 1 [list $TRANSPARRGB \
        3A6D89  A2A2A3  4F778E  4A7C98  8E9EA9  161514 \
        035D88  094B71  9F9FA0  445058  233845  87959F \
        476472  718693  9AA6AE  3D7594  2E7295  0B4A6D \
        1D313D  4F5A62  34617E  01628B  1F6182  34444C \
        1F5874  2F4B59  0C3244  628CA0  648699  145C81 \
        365063] \
    move {
........r*******q.....
........*..**...b*r...
.....3a*c..**...12*r..
..dr1e11222**e222efsq.
.2t9n5555k55555k*9hjl0
cp44n*5555kk5555p44nlj
84ma4msg6666g6gb4m34lo
.4i84m70707000704i84..
..44.............44...
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_occow
# Purpose:    Creates a sprite prototype: occow class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) occow

dmproc 1 make_proto_occow {} {
    global TRANSPARRGB
    make_proto_sprite occow \
        12 7 1 1 [list $TRANSPARRGB 000000 FFFFFF 808080] \
    move {
*1..........
.*..........
*0********1.
****00***.*1
..*0**00*..*
..*******...
..*.....*...
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_occross
# Purpose:    Creates a sprite prototype: occross class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) occross

dmproc 1 make_proto_occross {} {
    global TRANSPARRGB
    make_proto_sprite occross \
        8 13 1 1 [list $TRANSPARRGB CCCC00] move {
...**...
...**...
...**...
********
********
...**...
...**...
...**...
...**...
...**...
...**...
...**...
...**...
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocdog
# Purpose:    Creates a sprite prototype: ocdog class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocdog

dmproc 1 make_proto_ocdog {} {
    global TRANSPARRGB
    make_proto_sprite ocdog \
        17 13 1 1 [list $TRANSPARRGB \
        FFFFFF  D2A394  C68A79  AA0000  E8CAC1  FFEFE8 \
        FFEBE4  F1CFC4  EDCFC6  CB9C8D  C39B8E  BB9488 \
        AD796A  D3AEA3  FFFAF8  2B0300  C09183  A43C1D \
        8A4A36  FAE0D9  B88879  AF877A  D8B4AA  E0BCB2 \
        C79F94  8E4E3A  000000] \
    move {
.....pppp........
.....pppp........
pp.....ppooo.....
ppooooo189nbo....
ppkalf3pp**5joppp
oi5**d*po***4oppp
o*********pp*oepp
o*********po*o.pp
o************o.pp
ocm0*********o...
.22h********7o...
.22hooo****6oo...
.22h..oooogoo....
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocflames
# Purpose:    Creates a sprite prototype: ocflames class
# Arguments:  None

#---------------------------------------------------------------------

# This is a multi-frame sprite. The sprite's frames are used for anim-
# ation, in this case, as opposed to multiple shapes.

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocflames

dmproc 1 make_proto_ocflames {} {
    global TRANSPARRGB

    # Frame #1, index 0
    make_proto_sprite ocflames \
        45 27 1 1 [list $TRANSPARRGB \
        FF0000  800000  808000  FFFF00  CCCCCC  FFFFFF \
        000000] \
    move {
.............................................
.............................................
.......000...................................
......0000..........0..................0.....
.000000000....0...0000............000.000....
0000000*00...00000000..........00000000000.00
000000*000..000000000..........00000000000000
000000000000000000000.........000000000000000
0000**000000000000000...0000.0000000000000000
000***00000*000000000000000000000000000*00000
00****000****0000**000000000000*0000000*00000
00****000******0***00**0000000**0000000**0000
******************000**0000000**000000***000*
******************00***00***00***0**00**0000*
******************00*********0******00*00000*
***********************************000000*00*
*****************0*************1*****0****00*
*****221*********0*********1***********22*00*
*****222****************1*22***2******222****
*0****22*22***12**21**22222***2221***2221****
*0***122*22*2222*121*222222**2222***22221*212
1*****2222222222*222222122**12222***2222*1*22
******2222222222*222222*22*212222*222221***22
2122222222**122*222322212**222221222222***2**
2222224222***222322222222*1*2*22**2222221*222
22*2224*22***22232222*22*20*024***222223*1222
2214*24*42*004114222*0*25350*34*22312***02222
    }

    # Frame #2, index 1
    make_proto_sprite ocflames \
        45 27 1 1 [list $TRANSPARRGB \
        FF0000  800000  808000  FFFF00  CCCCCC  FFFFFF \
        000000] \
    move {
.............................................
.............................................
.............................................
..............................0..............
...0000...000.....00.........000.............
..000000.00000...0000........000000..000.....
.0000000.0**00..00000.00....000000000000.....
0000000000**00.00*0000000...00000000000000000
0*0000000***000**00000000.00000**00000*000000
**0000000***000**0000000000000***00000*000***
**0000000**0000*0000000000000****00000*0*****
*00000000**000**0000000*00*******00000*******
*000*0000*000**0000000***********0050********
000***000*00***000000**0*********0000********
00****00*********000***0**********00******000
00****0**********000***0*****************000*
***************2*00****0*********1**2****00**
**************22*0*******2*******2**2***00***
**************22*0*******2******22221****0***
*******1******22***2*****1***12*2222****0**0*
*******21***2122**12*****12*222**22***2*0****
2******22**2222***22222**222222**22***2***2**
***11*222*22222*222222222122221**222*22**12**
22*222222*232*1222222222222222*222222222*222*
222222*222321*222332232*222222*222222222*3222
*1222*2*224***22242234*0222*222212*12*322232*
**22222*213*2***24*32300223*2*2201*22*4442420
    }

    # Frame #3, index 2
    make_proto_sprite ocflames \
        45 27 1 1 [list $TRANSPARRGB \
        FF0000  800000  808000  FFFF00  CCCCCC  FFFFFF \
        000000] \
    move {
.............................................
.........0.....0.............................
.......000.....00..................0.........
.......000.....00............................
..0000000.....000......00........0...........
.00000000....0000....0000...000000...........
000005000.00.0000..000000..0000000.......0...
000005500.0000000.0000**0000000000..0..000000
0**05500000000**0000****0000000**000000000000
0*005500000000***000***0000*00***000000000000
0000550000000****00****0000*********000000000
0005500000000****00***0000**********000000000
000000000000**********0000**********000000000
***0000000************0*******0*****000*00000
****000000********************00****00***000*
*1**00000****************0000*0000***0****0**
******000****************000****00***********
******00*2******0***************0************
******00*2**22**************22***********1***
*****0*0***222*221*2*12**2222*******1***12***
222**0*0***222222*12*22*2222***221**22*122**1
222*0**000*232232*21*2222222**1222**22*221122
222**1*00*0*32222*212222222**22222*222222*222
222*2210**0*222222*12222121*22222*2122222221*
*21*212****22*2*2202222**2*232221*22*2*22*211
*2*23222*2222*3*22*2222****22*12*2232**12*222
2*2222232232212*22222*222*2222*2*04235*212242
    }

    # Frame #4, index 3
    make_proto_sprite ocflames \
        45 27 1 1 [list $TRANSPARRGB \
        FF0000  800000  808000  FFFF00  CCCCCC  FFFFFF \
        000000] \
    move {
.............................................
.............................................
.............................................
.............................................
..00.....000............000..............0...
.000...0000000.........00000.......00000000..
0000000000000000......000*00.....000000000000
000000000*0000000....0000*00...00000000000000
0000000***000*0000..000000050000*00**00000000
0000000***00**0000000000000000*******00**0000
0000000***00**0000000*0000000********00**0000
0***000***0***000**00*000000*************0000
****00********000**00000000**************000*
****00*************00**000****************0**
****00*************00*********************0**
******************00**********************0**
*00**************00**************************
*00******************************************
*0*1****0****1*******************************
**22***00***22***1******11********22*****2***
122222*0****22*221**********0****222****22***
222222**2***21*221**********0**2*22*****22**2
***22******122222221*1***1*1***2122***2*22*22
**12*2****222232*222*2222*22***2222**22*222**
*222*2***232222*222*2222222**1224*222220*3221
2*34*21*124222*222222122222**2*22*332220*2222
*242*22*32222**22*322*21****02**124222**2222*
    }

    # Frame #5, index 4
    make_proto_sprite ocflames \
        45 27 1 1 [list $TRANSPARRGB \
        FF0000  800000  808000  FFFF00  CCCCCC  FFFFFF \
        000000] \
    move {
.............................................
.............................................
.............................................
.................0000.........0..............
.......0000......00000.......00000...........
00000..00000....000000......0000000..000.0000
000000000000...0000000....000000000.000000000
0000000000000..00000000..00000000000000000000
0000000000000.000000000.000000000000000000000
0000**0000*0000*000*0000000000000000**0000550
00*****00**000**00**000000000000000****000000
00*****00*******00**000000000000000****000000
******00********0*****00000**00000****000000*
******0*********0*****0000***00*******00*000*
******0***************000****0*******000*00**
0************************************00******
**********12************1********************
******221*11*****211***221***11********22****
******2*******1*12221**111**122********22****
121**22*******222222222222**222*************1
*2**122***0***221222222222*222****1*1********
*2*222*******12222*2222*22*222**222*2*****2**
*22222*12**122222**2222*2*2222*221**22***22**
222222**22***12220**22222*222222****22*1**222
222*22*222***122**21222212222222*22222222*222
2***22*22*22*2***22*2*2222223****2222421222**
222222*222222****2**00224*224222323*4323*22**
    }

    # Frame #6, index 5
    make_proto_sprite ocflames \
        45 27 1 1 [list $TRANSPARRGB \
        FF0000  808000  800000  FFFFFF  CCCCCC  FFFF00] \
    move {
.............................................
.............................................
.............................................
.............................................
.11.............111111...1111................
11...111.......11111111.11111..111.1.........
11..11111....1111111111111111.1111111......11
11..11111..11111111111111111111111111.....111
111111111.1111111111111***1111**111111...1111
111111111.1111111111111***1111**11111111.1111
111111111111111*1111111**11111*111*11111.1111
11111111111111*11111111**11111*1****111111111
11*****11111***11111111**111*11*****11111*111
11*******111***11*1111***11**11******1*1**111
1*********1****1***111***11**11***********111
*******************111***1**111***********111
***************1****1*******11*****0******11*
******40***************************4**0******
******44****************4*********0444444****
0*****44*4*****4***440**4*********04444444**0
4**0**4044*0*1*44*444**44***********444444**4
4*44*0444004*1*404444**44*4***44****0444***44
40444444**4***0**4*4***4**4***440****440**444
443444**04****4*44*4*****44**04444****04*44**
*4244***4**4444*4**4*4*0*4*40**444*****0*****
*44404444*4444*43**4440*440*4***43*1*04*41*4*
44444040444244**24*0314*4*4*444144*41*424134*
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocinter
# Purpose:    Creates a sprite prototype: ocinter class
# Arguments:  None

#---------------------------------------------------------------------

# This is a  multi-frame sprite.  The frames are used as shapes as op-
# posed to animation. When the class is instantiated, individual shap-
# es may be selected explicitly as follows:
#
#     set frame_index $gdata(CLASSNAME.frame_index.SHAPENAME)
#
# where CLASSNAME is the object-class name (ocinter) and SHAPENAME is
# a shape keyword (forward or reverse).

# Alternatively, a shape may be selected randomly:
#
#     set frame_index \
#         [random_int 0 [expr $gdata(CLASSNAME.num_frames) - 1]]

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocinter

dmproc 1 make_proto_ocinter {} {
    global gdata
    global BG_PORTAL_FORWARD FG_PORTAL_FORWARD
    global BG_PORTAL_REVERSE FG_PORTAL_REVERSE

                                # Inter-world "forward" portal
    make_proto_sprite ocinter \
        5 5 1 1 [list $BG_PORTAL_FORWARD $FG_PORTAL_FORWARD] \
    nomove {
.*...
..*..
...*.
..*..
.*...
    }
                                # Make "forward" shape addressable
    set gdata(ocinter.frame_index.forward) \
       $gdata(ocinter.frame_index.newest)

                                # Inter-world "reverse" portal
    make_proto_sprite ocinter \
        5 5 1 1 [list $BG_PORTAL_REVERSE $FG_PORTAL_REVERSE] \
    nomove {
...*.
..*..
.*...
..*..
...*.
    }
                                # Make "reverse" shape addressable
    set gdata(ocinter.frame_index.reverse) \
       $gdata(ocinter.frame_index.newest)
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocintra
# Purpose:    Creates a sprite prototype: ocintra class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocintra

dmproc 1 make_proto_ocintra {} {
    global BG_PORTAL_INTRA FG_PORTAL_INTRA
    make_proto_sprite ocintra \
        4 4 1 1 [list $BG_PORTAL_INTRA $FG_PORTAL_INTRA] nomove {
****
*..*
*..*
****
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_ockarkinos
# Purpose:    Creates a sprite prototype: ockarkinos class
# Arguments:  None

#---------------------------------------------------------------------

# This is a  multi-frame sprite.  The frames are used as shapes as op-
# posed to animation. When the class is instantiated, individual shap-
# es may be selected explicitly as follows:
#
#     set frame_index $gdata(CLASSNAME.frame_index.SHAPENAME)
#
# where CLASSNAME is the object-class name (ockarkinos) and  SHAPENAME
# is a shape keyword (small, medium, large).

# Alternatively, a shape may be selected randomly:
#
#     set frame_index \
#         [random_int 0 [expr $gdata(CLASSNAME.num_frames) - 1]]

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ockarkinos

dmproc 1 make_proto_ockarkinos {} {
    global BG_KARKINOS FG_KARKINOS TRANSPARRGB gdata

                                # Start with a small version
    make_proto_sprite ockarkinos \
        3 3 1 1 [list $BG_KARKINOS $FG_KARKINOS] move {
*.*
...
***
    }
                                # Make "small" shape addressable
    set gdata(ockarkinos.frame_index.small) \
       $gdata(ockarkinos.frame_index.newest)

                                # Add a medium-size version
    make_proto_sprite ockarkinos \
        8 8 1 1 [list $BG_KARKINOS $FG_KARKINOS] move {
**....**
**....**
........
........
........
........
........
********
    }
                                # Make "medium" shape addressable
    set gdata(ockarkinos.frame_index.medium) \
       $gdata(ockarkinos.frame_index.newest)

                                # Add a large version
    make_proto_sprite ockarkinos \
        20 20 1 1 [list $BG_KARKINOS $FG_KARKINOS] move {
***..............***
***..............***
***..............***
....................
....................
....................
....................
....................
....................
....................
....................
....................
....................
....................
....................
....................
....................
....................
********************
********************
    }
                                # Make "large" shape addressable
    set gdata(ockarkinos.frame_index.large) \
       $gdata(ockarkinos.frame_index.newest)
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocmedical
# Purpose:    Creates a sprite prototype: ocmedical class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocmedical

dmproc 1 make_proto_ocmedical {} {
    global BG_MEDICAL FG_MEDICAL
    make_proto_sprite ocmedical \
        2 2 1 1 [list $BG_MEDICAL $FG_MEDICAL] move {
**
**
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocmoney
# Purpose:    Creates a sprite prototype: ocmoney class
# Arguments:  None

#---------------------------------------------------------------------

# This is a  multi-frame sprite.  The frames are used as shapes as op-
# posed to animation. When the class is instantiated, individual shap-
# es may be selected explicitly as follows:
#
#     set frame_index $gdata(CLASSNAME.frame_index.SHAPENAME)
#
# where CLASSNAME is the object-class name (ocmoney) and  SHAPENAME is
# a shape keyword (dollar, cent, pound, yen).

# Alternatively, a shape may be selected randomly:
#
#     set frame_index \
#         [random_int 0 [expr $gdata(CLASSNAME.num_frames) - 1]]

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocmoney

dmproc 1 make_proto_ocmoney {} {
    global gdata TRANSPARRGB
                                # Start with the U.S. dollar
    make_proto_sprite ocmoney \
        5 7 1 1 [list $TRANSPARRGB 008800] \
    move {
..*..
*****
*.*..
*****
..*.*
*****
..*..
    }
                                # Make "dollar" shape addressable
    set gdata(ocmoney.frame_index.dollar) \
       $gdata(ocmoney.frame_index.newest)

                                # Alternate: U.S. cent
    make_proto_sprite ocmoney \
        5 7 1 1 [list $TRANSPARRGB 008800] \
    move {
..*..
*****
*.*..
*.*..
*.*..
*****
..*..
    }
                                # Make "cent" shape addressable
    set gdata(ocmoney.frame_index.cent) \
       $gdata(ocmoney.frame_index.newest)

                                # Alternate: British pound
    make_proto_sprite ocmoney \
        5 7 1 1 [list $TRANSPARRGB 008800] \
    move {
.****
.*..*
.*...
****.
.*...
.*..*
*****
    }
                                # Make "pound" shape addressable
    set gdata(ocmoney.frame_index.pound) \
       $gdata(ocmoney.frame_index.newest)

                                # Alternate: Japanese yen
    make_proto_sprite ocmoney \
        5 7 1 1 [list $TRANSPARRGB 008800] \
    move {
*...*
.*.*.
..*..
*****
..*..
*****
..*..
    }
                                # Make "yen" shape addressable
    set gdata(ocmoney.frame_index.yen) \
       $gdata(ocmoney.frame_index.newest)
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocpig
# Purpose:    Creates a sprite prototype: ocpig class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocpig

dmproc 1 make_proto_ocpig {} {
    global TRANSPARRGB
    make_proto_sprite ocpig \
        12 13 1 1 [list $TRANSPARRGB \
        F0BEBE  B18A89  A0878A  918486  775D5F  E4A6B2 \
        BE8F92  CC9E96  D6A9B4  715F5E  B79A9A  C89C9F \
        FFCACD  999192  442622  AC9699  372023  F9BEBD \
        D09E9E  DCB5B2  FFFFFF  DB6C6D] \
    move {
...ffff.ffff
...f2c..f2c.
...fdce1cfc.
888776g6b3..
******ff*ff.
******9fi9f.
*********kkk
***5****4fkf
***0*****fkf
***ah*8ii8..
******8jj8..
***2223888..
***2........
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocplayer
# Purpose:    Creates a sprite prototype: ocplayer class
# Arguments:  None

#---------------------------------------------------------------------

# This is a  multi-frame sprite.  The frames are used as shapes as op-
# posed to animation. When the class is instantiated, individual shap-
# es may be selected explicitly as follows:
#
#     set frame_index $gdata(CLASSNAME.frame_index.SHAPENAME)
#
# where CLASSNAME is the object-class name (ocplayer) and SHAPENAME is
# a shape keyword (normal, godmode, driving_left, or driving_right).

# Alternatively, a shape may be selected randomly:
#
#     set frame_index \
#         [random_int 0 [expr $gdata(CLASSNAME.num_frames) - 1]]

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocplayer

dmproc 1 make_proto_ocplayer {} {
    global BG_PLAYER FG_PLAYER TRANSPARRGB gdata
                                # Normal player shape
    make_proto_sprite ocplayer \
        6 6 1 1 [list $BG_PLAYER $FG_PLAYER] move {
**..**
**..**
......
......
******
******
    }
                                # Make "normal" shape addressable
    set gdata(ocplayer.frame_index.normal) \
       $gdata(ocplayer.frame_index.newest)

                                # Player in "God" mode
    make_proto_sprite ocplayer \
        6 6 1 1 [list FFFF00 8800FF] move {
**..**
**..**
......
......
******
******
    }
                                # Make "God mode" shape addressable
    set gdata(ocplayer.frame_index.godmode) \
       $gdata(ocplayer.frame_index.newest)

                                # Player driving a  car  left  (sprite
                                # should be the  same  here as  for an
                                # occar)
    make_proto_sprite ocplayer \
        22 9 1 1 [list $TRANSPARRGB \
        3A6D89  A2A2A3  4F778E  4A7C98  8E9EA9  161514 \
        035D88  094B71  9F9FA0  445058  233845  87959F \
        476472  718693  9AA6AE  3D7594  2E7295  0B4A6D \
        1D313D  4F5A62  34617E  01628B  1F6182  34444C \
        1F5874  2F4B59  0C3244  628CA0  648699  145C81 \
        365063] \
    move {
........r*******q.....
........*..**...b*r...
.....3a*c..**...12*r..
..dr1e11222**e222efsq.
.2t9n5555k55555k*9hjl0
cp44n*5555kk5555p44nlj
84ma4msg6666g6gb4m34lo
.4i84m70707000704i84..
..44.............44...
    }
                                # Make "driving left"  shape  address-
                                # able
    set gdata(ocplayer.frame_index.driving_left) \
       $gdata(ocplayer.frame_index.newest)

                                # Player driving a  car  facing  right
                                # (should be the  previous  shape  re-
                                # versed)
    make_proto_sprite ocplayer \
        22 9 1 1 [list $TRANSPARRGB \
        3A6D89  A2A2A3  4F778E  4A7C98  8E9EA9  161514 \
        035D88  094B71  9F9FA0  445058  233845  87959F \
        476472  718693  9AA6AE  3D7594  2E7295  0B4A6D \
        1D313D  4F5A62  34617E  01628B  1F6182  34444C \
        1F5874  2F4B59  0C3244  628CA0  648699  145C81 \
        365063] \
    move {
.....q*******r........
...r*b...**..*........
..r*21...**..c*a3.....
.qsfe222e**22211e1rd..
0ljh9*k55555k5555n9t2.
jln44p5555kk5555*n44pc
ol43m4bg6g6666gsm4am48
..48i40700070707m48i4.
...44.............44..
    }
                                # Make  "driving right" shape address-
                                # able
    set gdata(ocplayer.frame_index.driving_right) \
       $gdata(ocplayer.frame_index.newest)
}

#---------------------------------------------------------------------

# Routine:    make_proto_ocscroll
# Purpose:    Creates a sprite prototype: ocscroll class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) ocscroll

dmproc 1 make_proto_ocscroll {} {
    global BG_SCROLL FG_SCROLL
    make_proto_sprite ocscroll \
        5 5 1 1 [list $BG_SCROLL $FG_SCROLL FFFFFF] \
    nomove {
*****
.*0*.
.*0*.
.*0*.
*****
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_octiger
# Purpose:    Creates a sprite prototype: octiger class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) octiger

dmproc 1 make_proto_octiger {} {
    global TRANSPARRGB
    make_proto_sprite octiger \
        12 12 1 1 [list $TRANSPARRGB \
        F6FBDB  A34F07  8E7354  DA7117  5E4F3F  794718 \
        FF8919  8F531C  6B4D2F  A98C65  DF9F58  824813 \
        E6710C  A09782  151615  332F24  EFF4D4  E7E9CD \
        2E1A0A  240C00  DF6E0E  603E1B  EEEED6  904E11 \
        FFDDA1  4B4643  909285  AF580D  84867B  C8CCB3 \
        543212] \
    move {
22........22
261666666162
.43t0kak0o34
.b9f*qaq**9b
.bne*j5j*enb
.b9**m5m**9b
.bcs*ith*scb
.bs*fpdp**gb
.1b***rlf*b1
..bg81718gb.
...g5bbb5g..
...g.111.g..
    }
}

#---------------------------------------------------------------------

# Routine:    make_proto_octree
# Purpose:    Creates a sprite prototype: octree class
# Arguments:  None

#---------------------------------------------------------------------

lappend gdata(list_classes_proto) octree

dmproc 1 make_proto_octree {} {
    global TRANSPARRGB
    make_proto_sprite octree \
        12 12 1 1 [list $TRANSPARRGB \
        00AA35  606000  00B83A  00842B  7F7F00  007826 \
        00C43E  00952F  00CD42  656500  898A00  18AB2F \
        2CA626  009E32  006C2B] \
    move {
...22**777..
...***1777..
...*111*157.
..5*11642*7.
..5**1*6*57.
..**11*6c**.
...2*ba2d25.
....999d2...
....999.....
....999.....
...99399....
...999880...
    }
}

#---------------------------------------------------------------------

# Routine:    setup_sprite_prototypes
# Purpose:    Sets up sprite prototypes
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 setup_sprite_prototypes {} {
    global gdata
    foreach objclass $gdata(list_classes_proto) {
        set   cmd make_proto_$objclass
        eval $cmd
    }
}

#---------------------------------------------------------------------

# Routine:    set_world_name
# Purpose:    Set current world name
# Arguments:  name = World name

# When a new world is activated,  this routine is called to record the
# change.

#---------------------------------------------------------------------

dmproc 1 set_world_name { name } {
    global gdata lv

# Note: We'd like to  get rid of gdata(lv) and use lv exclusively, but
# this would require changes to the game's "trace" code.

    set lv        $name
    set gdata(lv) $name
}

#---------------------------------------------------------------------

# Routine:    track_sprite
# Purpose:    Camera-related utility routine
# Arguments:  xpos = X-position (in sprite coordinate system)
#             ypos = Y-position (in sprite coordinate system)

# This routine  centers the program's  virtual camera on the specified
# position.

#---------------------------------------------------------------------

dmproc 5 track_sprite { xpos ypos } {
    global GAME_WIDTH GAME_HEIGHT
    global layers lv
    set WX [expr int ($GAME_WIDTH  / 2) ]
    set HX [expr int ($GAME_HEIGHT / 2) ]

    br::layer camera $layers($lv) \
        [expr { $xpos - $WX }] [expr { $ypos - $HX }]
}

#---------------------------------------------------------------------

# Routine:    account_ocplayer_position
# Purpose:    Player-related utility routine
# Arguments:  None

# This routine  updates various records based on the ocplayer sprite's
# current position.  It also repositions the  program's virtual camera
# based on the position in question.

#---------------------------------------------------------------------

dmproc 5 account_ocplayer_position {} {
    global gdata layers lv sdata

    set id $gdata($lv,ocplayer_id)
    set PlayerPosition [br::sprite pos $id]
    set ocplayer_x [lindex $PlayerPosition 0]
    set ocplayer_y [lindex $PlayerPosition 1]

                                # Update  ocplayer's internal coordin-
                                # ates
    set sdata($id.px) $ocplayer_x
    set sdata($id.py) $ocplayer_y
                                # Track ocplayer with camera
    track_sprite $ocplayer_x $ocplayer_y
}

#---------------------------------------------------------------------

# Routine:    (xproc) check_force_create
# Purpose:    Checks a global flag
# Arguments:  FlagCreate = Output flag (passed by reference)

# This is  an  "xproc" routine;  i.e.,  it supports  "&variable"-style
# pass-by-reference.

# If the following flag exists and is true, this routine sets the spe-
# cified output variable to true (in the caller's scope):
#
#     gdata(force_create)
#
# Otherwise, the output flag isn't modified.  This routine doesn't re-
# turn anything (except through the output flag).

#---------------------------------------------------------------------

xproc check_force_create { &FlagCreate } {
    global gdata
    if { [info exists gdata(force_create)] && \
                     $gdata(force_create) } { set FlagCreate 1 }
    set gdata(force_create) 0
}

#---------------------------------------------------------------------

# Routine:    group_generic_new
# Purpose:    Object creation support routine
# Arguments:  objclass = Object class (for example, occow)

# This is a generic object  creation routine suitable for  "barnyard"-
# group classes and, if class parameters are set appropriate, for some
# of the other classes.

#---------------------------------------------------------------------

dmproc 2 group_generic_new { objclass } {
    global layers lv proto sdata ParamBlock WorldKeyStart
    global  BRICKAPI
                                # Get class parameters
    foreach param [list \
            divmax        divmin        forceposn     frequency \
            heffect       maxnum        nobounce      scalemin \
            scalemax      shoot_can     shoot_effect  shoot_score \
            xpos          ypos] {
        set $param [get_class_param $objclass $param]
    }
                                # Select a scale factor
    set   scale_factor  [random_real $scalemin $scalemax]
    if { $scale_factor  < 0.75 } { set scale_factor  1.00 }

                                # Select a speed divisor
    set   speed_divisor [random_int $divmin $divmax]
    if { $speed_divisor < 1    } { set speed_divisor 1    }

                                # Determine whether or not to create a
                                # new instance
    set FlagCreate 0
    if { rand() >= (1 - $frequency) } { set FlagCreate 1 }
    check_force_create FlagCreate
    if { [get_class_counter $objclass] >= $maxnum } \
        { set FlagCreate 0 }
                                # Create a new instance?
    if { $FlagCreate } {      ; # Yes
        set id [br::sprite copy $proto($objclass)]
        incr_class_counter $objclass
        if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
        set zhint [get_class_param $objclass zhint]
        br::sprite z-hint $id $zhint
                                # Scale the sprite if appropriate
        if { ($BRICKAPI >= 5400) && ($scale_factor != 1) } {
            br::sprite scale $id $scale_factor $scale_factor
        }
                                # Select object name
        set name [get_object_name_random $objclass]

        array set sdata [list \
            $id.               run_$objclass        \
            $id.ct             0                    \
            $id.dir            [random_direction]   \
            $id.forceposn      $forceposn           \
            $id.heffect        $heffect             \
            $id.name           $name                \
            $id.nobounce       $nobounce            \
            $id.shoot_can      $shoot_can           \
            $id.shoot_effect   $shoot_effect        \
            $id.shoot_score    $shoot_score         \
            $id.smart          1                    \
            $id.speed_divisor  $speed_divisor       \
            $id.xpos           $xpos                \
            $id.ypos           $ypos                \
        ]
        verify_sprite_exists $rtn $id
        br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
        random_position_sprite $id
        return $id
    }

    return 0
}

#---------------------------------------------------------------------

# Routine:    new_occar
# Purpose:    Objection creation: occar class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_occar {} {
    return [group_generic_new occar]
}

#---------------------------------------------------------------------

# Routine:    new_occow
# Purpose:    Objection creation: occow class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_occow {} {
    return [group_generic_new occow]
}

#---------------------------------------------------------------------

# Routine:    new_occross
# Purpose:    Objection creation: occross class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_occross {} {
    return [group_generic_new occross]
}

#---------------------------------------------------------------------

# Routine:    new_ocdog
# Purpose:    Objection creation: ocdog class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocdog {} {
    return [group_generic_new ocdog]
}

#---------------------------------------------------------------------

# Routine:    new_ocflames
# Purpose:    Object creation: ocflames class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocflames {} {
    return [group_generic_new ocflames]
}

#---------------------------------------------------------------------

# Routine:    new_ocinter
# Purpose:    Objection creation: ocinter class
#
# Arguments:  PortalType  = "forward" or "reverse".
#
#             ToWorldName = Name of the destination world.
#
#             ToPortalID  = If $PortalType is  "reverse",  $ToPortalID
#             specifies  the  sprite ID  of  the  destination  portal.
#             Otherwise, this argument should be "none".

# For  an explanation of  inter-world portals,  see  the documentation
# section named "Inter-world portals".

# This routine creates  one inter-world  portal of the specified type.
# It returns the associated sprite ID.  Note: This routine should only
# be used by "make_world" and "run_ocinter".

#---------------------------------------------------------------------

dmproc 2 new_ocinter { PortalType ToWorldName ToPortalID } {
    global lv gdata proto sdata layers

    set id [br::sprite copy $proto(ocinter)]
    set frame_index $gdata(ocinter.frame_index.$PortalType)
    br::sprite frame $id $frame_index

    if { $DebugLevel >= 2 } {
        puts "$rtn: $lv,$id $ToWorldName,$ToPortalID"
    }

    array set sdata [list $id. run_ocinter \
        $id.to_world  $ToWorldName \
        $id.to_portal $ToPortalID  \
    ]

    verify_sprite_exists new_ocinter $id
    br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
    random_position_sprite $id
    return $id
}

#---------------------------------------------------------------------

# Routine:    new_ocintra
# Purpose:    Objection creation: ocintra class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocintra {} {
    global lv proto sdata layers
    set id [br::sprite copy $proto(ocintra)]
    if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
    set zhint [get_class_param ocintra zhint]
    br::sprite z-hint $id $zhint

    array set sdata [list $id. run_ocintra]
    br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
    random_position_sprite $id
    return $id
}

#---------------------------------------------------------------------

# Routine:    new_ockarkinos
# Purpose:    Objection creation: ockarkinos class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ockarkinos {} {
    global gdata layers lv proto sdata
                                # Get class parameters
    foreach param [list \
            divmax  divmin     frequency     heffect \
            maxnum  shoot_can  shoot_effect  shoot_score \
            size    smartmax   smartmin      zhint] {
        set $param [get_class_param ockarkinos $param]
    }
                                # Select smart percentage
    set smart_percent [random_int $smartmin $smartmax ]
    if { $smart_percent > 100 } { set smart_percent 100 }

                                # Select speed divisor
    set speed_divisor [random_int $divmin   $divmax   ]
    if { $speed_divisor < 1 } { set speed_divisor 1 }

                                # Determine whether or not to create a
                                # new instance
    set FlagCreate 0
    if { rand() >= (1 - $frequency) } { set FlagCreate 1 }
    check_force_create FlagCreate
    if { [get_class_counter ockarkinos] >= $maxnum } \
        { set FlagCreate 0 }
                                # Create a new instance?
    if { $FlagCreate } {      ; # Yes
        set id [br::sprite copy $proto(ockarkinos)]
        if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
        br::sprite z-hint $id $zhint
                                # Select appropriate frame
        if { ($size ne "medium") && ($size ne "large") } \
            { set size small }
        set frame_index $gdata(ockarkinos.frame_index.$size)
        br::sprite frame $id $frame_index

        incr_class_counter ockarkinos
                                # $smart:  1 for a hunter and  0 for a
                                # grazer
        set smart \
            [ expr (int (rand() * 101) < $smart_percent) ? 1 : 0 ]
                                # Select name
        set name [get_object_name_random ockarkinos]

        array set sdata [list \
            $id.               run_ockarkinos       \
            $id.ct             0                    \
            $id.dir            [random_direction]   \
            $id.heffect        $heffect             \
            $id.name           $name                \
            $id.shoot_can      $shoot_can           \
            $id.shoot_effect   $shoot_effect        \
            $id.shoot_score    $shoot_score         \
            $id.smart          $smart               \
            $id.speed_divisor  $speed_divisor       \
        ]
        br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
        random_position_sprite $id
    }

    return 0
}

#---------------------------------------------------------------------

# Routine:    new_ocmedical
# Purpose:    Objection creation: ocmedical class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocmedical {} {
    global gdata layers lv proto sdata

    set objclass ocmedical      ; # Object class
                                # Get class parameters
    foreach param [list \
            cautious  divmax     divmin        frequency \
            maxnum    shoot_can  shoot_effect  shoot_score \
            zhint] {
        set $param [get_class_param $objclass $param]
    }
                                # Select a speed divisor
    set   speed_divisor [random_int $divmin $divmax]
    if { $speed_divisor < 1 } { set speed_divisor 1 }

                                # Determine whether or not to create a
                                # new instance
    set FlagCreate 0
    if { rand() >= (1 - $frequency) } { set FlagCreate 1 }
    check_force_create FlagCreate
    if { [get_class_counter $objclass] >= $maxnum } { set FlagCreate 0 }

                                # Create a new instance?
    if { $FlagCreate } {      ; # Yes
        set id [br::sprite copy $proto($objclass)]
        if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
        incr_class_counter $objclass
        br::sprite z-hint $id $zhint
                                # Select object name
        set name [get_object_name_random $objclass]

        array set sdata [list \
            $id.               run_$objclass        \
            $id.cautious       $cautious            \
            $id.ct             0                    \
            $id.dir            [random_direction]   \
            $id.name           $name                \
            $id.shoot_can      $shoot_can           \
            $id.shoot_effect   $shoot_effect        \
            $id.shoot_score    $shoot_score         \
            $id.smart          1                    \
            $id.speed_divisor  $speed_divisor       \
        ]
        verify_sprite_exists $rtn $id
        br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
        random_position_sprite $id
        return $id
    }

    return 0
}

#---------------------------------------------------------------------

# Routine:    new_ocmoney
# Purpose:    Object creation: ocmoney class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocmoney {} {
    global gdata lv proto sdata layers
    set objclass ocmoney      ; # Object class
                              ; # Get class parameters
    foreach param [list \
            cautious      divmax       divmin    shoot_can  \
            shoot_effect  shoot_score  smartmax  smartmin   \
            valmax        valmin       zhint] {
        set $param [get_class_param $objclass $param]
    }
                                # Select a value
    set value [random_int $valmin $valmax]
                                # This  simplifies  text output  else-
                                # where
    if { $value < 2 } { set value 2 }

    set id [br::sprite copy $proto($objclass)]

                                # Set money shape  displayed to a ran-
                                # dom shape selected  from  all  money
                                # frames
    set n [random_int 0 [expr $gdata(ocmoney.num_frames) - 1]]
    br::sprite frame $id $n

    if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
    incr_class_counter $objclass
    br::sprite z-hint $id $zhint
                                # Is this object smart?
    set smart_percent [random_int $smartmin $smartmax ]
    if { $smart_percent > 100 } { set smart_percent 100 }
    set smart \
        [ expr (int (rand() * 101) < $smart_percent) ? 1 : 0 ]

                                # Select speed divisor
    set   speed_divisor [random_int $divmin $divmax]
    if { $speed_divisor < 1 } { set speed_divisor 1 }

                                # Select object name
    set name [get_object_name_random $objclass]

    array set sdata [list \
        $id.               run_$objclass        \
        $id.cautious       $cautious            \
        $id.ct             0                    \
        $id.dir            [random_direction]   \
        $id.name           $name                \
        $id.shoot_can      $shoot_can           \
        $id.shoot_effect   $shoot_effect        \
        $id.shoot_score    $shoot_score         \
        $id.smart          $smart               \
        $id.speed_divisor  $speed_divisor       \
        $id.value          $value               \
    ]
    verify_sprite_exists $rtn $id
    br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
    random_position_sprite $id
    return $id
}

#---------------------------------------------------------------------

# Routine:    new_ocpig
# Purpose:    Objection creation: ocpig class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocpig {} {
    return [group_generic_new ocpig]
}

#---------------------------------------------------------------------

# Routine:    new_ocplayer
# Purpose:    Objection creation: ocplayer class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocplayer {} {
    global gdata layers lv proto sdata

    set ocplayer [br::sprite copy $proto(ocplayer)]
    if { $DebugLevel >= 2 } { puts "$rtn: $lv,$ocplayer" }
    set gdata($lv,ocplayer_id) $ocplayer

    array set sdata [list $ocplayer. run_ocplayer \
        $ocplayer.px  10  $ocplayer.py 10 \
        $ocplayer.gx   0  $ocplayer.gy  0 \
        $ocplayer.shot 0 \
    ]

    br::list add $layers($lv.spr-list) $ocplayer
    random_position_sprite             $ocplayer
    account_ocplayer_position
    return $ocplayer
}

#---------------------------------------------------------------------

# Routine:    new_ocscroll
# Purpose:    Object creation: ocscroll class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_ocscroll {} {
    global layers lv proto sdata
    set id [br::sprite copy $proto(ocscroll)]
    if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
    set zhint [get_class_param ocscroll zhint]
    br::sprite z-hint $id $zhint

    array set sdata [list $id. run_ocscroll]
    verify_sprite_exists $rtn $id
    br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
    random_position_sprite $id
    return $id
}

#---------------------------------------------------------------------

# Routine:    new_octiger
# Purpose:    Creates an object: octiger class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_octiger {} {
    if  { $DebugLevel > 1 } { puts "$rtn" }
    global layers lv proto sdata ParamBlock WorldKeyStart

    set objclass octiger      ; # Object class
                                # Get class parameters
    foreach param [list \
            divmax     divmin health  heffect      maxnum \
            shoot_can  shoot_effect   shoot_score  sound_destroy \
            sound_hit  zhint] {
        set $param [get_class_param $objclass $param]
    }
                                # Select a speed divisor
    set   speed_divisor [random_int $divmin $divmax]
    if { $speed_divisor < 1 } { set speed_divisor 1 }

    set FlagCreate 0          ; # Determine whether or not to create a
                              ; # new instance
    if { [get_class_counter $objclass] < $maxnum } {
        set FlagCreate 1
    }

    check_force_create FlagCreate
                                # Create a new instance?
    if { $FlagCreate } {      ; # Yes
        set id [br::sprite copy $proto($objclass)]
        incr_class_counter $objclass
        if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
        br::sprite z-hint $id $zhint
                                # Select object name
        set name [get_object_name_random $objclass]

        array set sdata [list \
            $id.               run_$objclass        \
            $id.ct             0                    \
            $id.dir            [random_direction]   \
            $id.health         $health              \
            $id.heffect        $heffect             \
            $id.name           $name                \
            $id.shoot_can      $shoot_can           \
            $id.shoot_effect   $shoot_effect        \
            $id.shoot_score    $shoot_score         \
            $id.smart          1                    \
            $id.sound_destroy  $sound_destroy       \
            $id.sound_hit      $sound_hit           \
            $id.speed_divisor  $speed_divisor       \
        ]

        verify_sprite_exists $rtn $id
        br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
        random_position_sprite $id
        return $id
    }

    return 0
}

#---------------------------------------------------------------------

# Routine:    new_octree
# Purpose:    Object creation: octree class
# Arguments:  None

#---------------------------------------------------------------------

dmproc 2 new_octree {} {
    global layers lv proto sdata ParamBlock WorldKeyStart

    set id [br::sprite copy $proto(octree)]
    if { $DebugLevel >= 2 } { puts "$rtn: $lv,$id" }
    set zhint [get_class_param octree zhint]
    br::sprite z-hint $id $zhint

    set add_octiger 0
    if { ![get_world_param has_octiger] } {
        set add_octiger 1
        set_world_param has_octiger 1
    }

    array set sdata [list \
        $id. run_octree \
        $id.add_octiger $add_octiger \
    ]
    verify_sprite_exists $rtn $id
    br::list add $layers($lv.spr-list) $id
                                # Randomly position the sprite
    random_position_sprite $id
    return $id
}

#---------------------------------------------------------------------

# Routine:    make_upfront
# Purpose:    Support routine for "make_world"
# Arguments:  objclass = Object-class name

# "objclass" may be any "upfront" class name. Examples include:
#
#     ocintra  ocscroll  octree

# "make_world"  calls this routine  during the world-generation proce-
# dure to add zero or more instances of an "upfront" class.

#---------------------------------------------------------------------

dmproc 2 make_upfront { objclass } {
    global gdata
    set minnum [get_class_param $objclass minnum]
    set maxnum [get_class_param $objclass maxnum]
    set num    [random_int $minnum $maxnum]

    for { set ii 1 } { $ii <= $num } { incr ii } {
        set gdata(force_create) 1
        set   cmd new_$objclass
        eval $cmd
    }
}

#---------------------------------------------------------------------

# Routine:    make_world
# Purpose:    Creates a new world
#
# Arguments:  NewWorldName = Name of  new world.  For  the  first  (or
#             main) world,  this should be equal to the following par-
#             ameter: $gdata(WorldMain)
#
#             FromPortalID = Sprite ID of the inter-world portal  that
#             led "forward" to the new world.  If the  main  world  is
#             being created, this parameter should be equal to "none".

# "make_world" creates the specified world and calls  "set_world_name"
# to assert that the active world name has changed.

# This  routine creates  "forward" portals,  intra-world portals,  and
# ocscrolls as  requested by the  world-definitions section associated
# with the specified world.

# "Reverse" portals are handled specially:

# If the new world is the  main world,  no  "reverse" portals are cre-
# ated. "make_world" returns an empty string, in this case.

# If the new world is a deeper world,  this routine assumes that world
# creation was  triggered by the use of a  "forward" portal located in
# the previous world, and that $FromPortalID specifies  the sprite  ID
# for the "forward" portal.  In this case,  this routine  adds exactly
# one "reverse" portal to the new world and  connects it to  the "for-
# ward" portal specified by $FromPortalID.  It then returns the sprite
# ID of the new "reverse" portal.

#---------------------------------------------------------------------

dmproc 100 make_world { NewWorldName FromPortalID } {
    if  { $DebugLevel >= 1 } {
        puts "$rtn $NewWorldName $FromPortalID"
    }

    global gdata layers lv BRICKAPI FRAFMTRGB NRDIGITS
    global fr2data fr3data MaxNumPortal WorldKeyStart

    global RandomMapEnable
    global RandomMapWidthMin RandomMapHeightMin
    global RandomMapWidthMax RandomMapHeightMax
    global BaseMapWidth      BaseMapHeight

# Note: This code is biased towards the creation of horizontal worlds,
# but vertical worlds may be created as well.

    for { set ii 1 } { $ii <= 3 } { incr ii } {
        set RandomMapWidth  [random_int \
           $RandomMapWidthMin  $RandomMapWidthMax  ]

        set RandomMapHeight [random_int \
           $RandomMapHeightMin $RandomMapHeightMax ]

        if { $RandomMapWidth >= $RandomMapHeight } { break }
    }

    if { $NewWorldName eq $gdata(WorldMain) } {
        set FromWorldName none
    } else {
        set FromWorldName $lv
    }

    set_world_name      $NewWorldName
    set world_key       $WorldKeyStart.$NewWorldName
    set is_invariant    0

    if { [info exists  gdata($world_key.is_invariant)] && \
                      $gdata($world_key.is_invariant) } {
        set is_invariant 1
    }

    if { $is_invariant } {      # Special case - Predefined map is re-
                                # quired
        if { [info exists  gdata($world_key.map_data)] } {
            set width     $gdata($world_key.width)
            set height    $gdata($world_key.height)
            set MapString $gdata($world_key.map_data)

            if { ![string length $MapString] } {
                set gdata($NewWorldName.is_empty) 1
            }
        } else {
            puts "$IE-01: World $lv is flagged as invariant,\
but no map is provided"
            puts "Either provide a map for the level or disable\
is is_invariant flag"
            exit 1
        }
    } elseif { $RandomMapEnable } {
                                # Use a random map
        set width     $RandomMapWidth
        set height    $RandomMapHeight
        set MapString [make_random_map $width $height]
    } else {
                                # Use a predefined map
        if { [info exists  gdata($world_key.map_data) ] } {
            set width     $gdata($world_key.width)
            set height    $gdata($world_key.height)
            set MapString $gdata($world_key.map_data)
        } else {
            puts "$IE-02: Random maps are disabled, but no\
default map is"
            puts "provided for the following level: $lv"
            puts "Either enable random maps or add a default map\
for the level in question"
            exit 1
        }
    }

    set layer_id             [br::layer add]
    set layers($lv)          $layer_id
    set layers($lv.width)    $width
    set layers($lv.height)   $height

    if { $BRICKAPI < 5300 } {
        set info_list            [br::layer info $layer_id]
        set layers($lv.spr-list) [lindex $info_list 0]
        set layers($lv.map)      [lindex $info_list 1]
        set layers($lv.str-list) [lindex $info_list 2]
    } else {
        set layers($lv.spr-list) [br::layer sprite-list $layer_id]
        set layers($lv.map)      [br::layer map         $layer_id]
        set layers($lv.str-list) [br::layer string-list $layer_id]
    }

    br::layer sorted $layer_id 1

# This code is an attempt to keep the  "info" layer  (i.e., the trans-
# parent layer that contains the game's information display) on top.

    if [info exists layers(info)] {
        set old_info     $layers(info)
        set old_lv       $layers($lv)
        br::layer swap   $old_info $old_lv
        set layers(info) $old_lv
        set layers($lv)  $old_info
    }

    set t2 [br::tile create]
    set t3 [br::tile create]

    set n1  [expr 8 * 8 * $NRDIGITS]
    set n2  [string length $fr2data]
    set n3  [string length $fr3data]
    if { ($n1 != $n2) || ($n1 != $n3) } {
        puts "$IE-03" ; exit 1
    }

    set fr2 [br::frame create $FRAFMTRGB 8 8 \
        [binary format H$n2 $fr2data]]
    set fr3 [br::frame create $FRAFMTRGB 8 8 \
        [binary format H$n3 $fr3data]]

    br::tile add-frame $t2 $fr2
    br::tile add-frame $t3 $fr3
    br::tile collides  $t3 box

    br::map tile-size $layers($lv.map) 8 8
    br::map tile      $layers($lv.map) 1 $t2
    br::map tile      $layers($lv.map) 2 $t3
    br::map size      $layers($lv.map) $width $height

    set ExpectedSize [expr $width * $height * 4]
    br::map set-data $layers($lv.map) \
        [binary format H$ExpectedSize \
            [string map {"-" 0100 "1" 0200} $MapString]]

                                # Create  "upfront" objects  as appro-
                                # priate
    foreach objclass $gdata(list_classes_upfront) {
        make_upfront $objclass
    }
                                # Preload "periodic" objects as appro-
                                # priate
    foreach objclass $gdata(list_classes_periodic) {
        set prenum [get_class_param $objclass preload ]
        set maxnum [get_class_param $objclass maxnum  ]
        if { $prenum > $maxnum } { set $prenum $maxnum }

        for { set ii 1 } { $ii <= $prenum } { incr ii } {
            set gdata(force_create) 1
            set cmd new_$objclass
            eval $cmd
        }
    }
                                # Create inter-world "forward" portals
    set to_worlds $gdata($world_key.to_worlds)

    foreach world $to_worlds {
        new_ocinter "forward" $world none
    }
                              ; # Creating the main level?
    if { $lv eq $gdata(WorldMain) } {
                              ; # Yes - Presently,  there's no reverse
                              ; # portal in the main level
        set PortalUpID ""
    } else {                  ; # No  - Add  a reverse portal that re-
                              ; # turns to the  "forward" portal which
                              ; # led here
        set PortalUpID \
            [new_ocinter "reverse" $FromWorldName $FromPortalID]
    }

    return $PortalUpID
}

#---------------------------------------------------------------------

# Routine:    is_ocplayer_driving
# Purpose:    Determines whether or not ocplayer is driving
# Arguments:  None

# This routine returns  nonzero  if the ocplayer is driving  and  zero
# otherwise.

#---------------------------------------------------------------------

dmproc 5 is_ocplayer_driving {} {
    global gdata
    set frame_index   $gdata(ocplayer.frame_index)
    set driving_left  $gdata(ocplayer.frame_index.driving_left)
    set driving_right $gdata(ocplayer.frame_index.driving_right)
    if { ($frame_index == $driving_left) || \
         ($frame_index == $driving_right) } { return 1 }
    return 0
}

#---------------------------------------------------------------------

# Routine:    cycle_smart
# Purpose:    Motion-related support routine
# Arguments:  id = Sprite ID

# This is a support routine  that may be used by  "run_" routines that
# switch occasionally between  intelligent and  unintelligent  motion.
# For usage examples, see "run_ockarkinos" and "group_avoid_run".

#---------------------------------------------------------------------

dmproc 5 cycle_smart { id } {
    global sdata
    if { [info exists sdata($id.smart)] } {
            if     { $sdata($id.smart) <  0 } {
                incr  sdata($id.smart) 1
                if { $sdata($id.smart) == 0 } {
                incr  sdata($id.smart) 1
            }
        }
    }
}

#---------------------------------------------------------------------

# Routine:    group_avoid_run
# Purpose:    "run_..." support routine
# Arguments:  id       = Sprite ID
#             objclass = Object-class name

# This  routine may be used  to  handle  "run_..." actions for classes
# similar to "ocmedical" or "ocmoney" at "run_..." time.  Changes  may
# be needed as new classes are added.

# Common characteristics of the supported classes:  Avoidance of play-
# er. Collision with player destroys object and  produces  a bonus for
# player.

#---------------------------------------------------------------------

dmproc 100 group_avoid_run { id objclass } {
    if { $DebugLevel >= 2 } { puts "$rtn $id $objclass" }
    global gdata layers lv sdata
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]          } { return }
    set   callback    $sdata($id.)
    if { $callback ne "run_$objclass"        } { return }
    if { $objclass ne [get_sprite_class $id] } { return }

                                # Identify sprite class
    set iddot "$sdata($id.)"
    regsub -all {^run_} $iddot "" sprite_class

    set is_ocmedical  \
        [if { $sprite_class eq "ocmedical" } {expr 1} {expr 0}]
    set is_ocmoney    \
        [if { $sprite_class eq "ocmoney"   } {expr 1} {expr 0}]

    incr sdata($id.ct)        ; # Increment timeline counter
    set vx 0                  ; # Reset velocity components
    set vy 0
                                # Move the sprite periodically
    if { !($sdata($id.ct) % $sdata($id.speed_divisor)) } {

        set ocplayer_id $gdata($lv,ocplayer_id)
        get_target_dx_dy $id $ocplayer_id dx dy
        if {$dx < 0} { set dx [expr -$dx] }
        if {$dy < 0} { set dy [expr -$dy] }
        set cautious [get_object_param $id cautious]

        if { ($dx > $cautious) || ($dy > $cautious) } {
                                # Object  isn't cautious at  this dis-
                                # tance
            get_dir_vx_vy $sdata($id.dir) vx vy

        } elseif { $sdata($id.smart) > 0 } {
                                # Moving intelligently - Avoid ocplayer
            set ocplayer_id $gdata($lv,ocplayer_id)
            get_target_dx_dy $id $ocplayer_id dx dy
            if {$dx < 0} { set vx  1 }
            if {$dx > 0} { set vx -1 }
            if {$dy < 0} { set vy  1 }
            if {$dy > 0} { set vy -1 }
        } else {
                                # No: Random-motion mode
            get_dir_vx_vy $sdata($id.dir) vx vy

            cycle_smart $id   ; # Return to intelligent mode eventual-
                                # ly
        }
                                # Set sprite velocity
        br::sprite vel $id $vx $vy
                                # Check to  see  if  we've  hit a wall
                                # Note:  This  sprite  doesn't  change
                                # direction  randomly  except  when  a
                                # collision occurs
        if { [lindex [br::collision map $id \
                 $layers($lv.map) 1] 0] == 1 } {

                                # Hit a wall:  Pick a new direction at
                                # random
            set sdata($id.dir) [random_direction]

                                # Override  intelligent behavior temp-
                                # orarily
            if { $sdata($id.smart) > 0 } { set sdata($id.smart) -10 }
        } else {
            move_sprite $id   ; # Move the sprite
        }
    }
                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]
                                # Collided with ocplayer?
        if { $other_class eq "ocplayer" } {
                                # Yes
            if { $is_ocmedical } {
                set name [get_object_name_current $id]
                if { ($name ne "none") } {
                                # Update the status line
                    set gdata(infomsg) "You ate $name"
                }
                                # Adjust health level
                set ocmedical_health \
                    [get_class_param ocmedical health]
                set n [expr $gdata(health) + $ocmedical_health]
                                # Limit  health to 100
                if { $n > 100 } { set n 100 }
                set gdata(health) $n
            }

            if { $is_ocmoney } {
                                # Value of ocmoney
                set value $sdata($id.value)
                                # Update the status line
                set gdata(infomsg) "Picked up $value coins"
                                # Adjust ocplayer's inventory
                inventory_ocmoney_add $value
            }
                                # Play the appropriate sound
            play_sound bonus 0
                                # Destroy the affected sprite
            destroy_sprite $sprite_class $id
        }
    }
}

#---------------------------------------------------------------------

# Routine:    group_barnyard_run
# Purpose:    Runs an object: classes in "barnyard" category
# Arguments:  id       = Sprite ID
#             objclass = Object-class name

#---------------------------------------------------------------------

dmproc 100 group_barnyard_run { id objclass } {
    if { $DebugLevel >= 2 } { puts "$rtn $id $objclass" }
    global BRICKAPI
    global gdata layers lv sdata level_list LevelToSData
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]          } { return }
    set   callback    $sdata($id.)
    if { $callback ne "run_$objclass"        } { return }
    if { $objclass ne [get_sprite_class $id] } { return }

                              ; # Player ID
    set ocplayer_id $gdata($lv,ocplayer_id)
    set ocplayer_collide 0    ; # Flag: Player is at same position

    incr sdata($id.ct)        ; # Increment timeline counter
    set vx 0                  ; # Reset velocity components
    set vy 0
                                # Move the sprite periodically
    if { !($sdata($id.ct) % $sdata($id.speed_divisor)) } {
        get_dir_vx_vy $sdata($id.dir) vx vy
        br::sprite vel $id $vx $vy
                                # Check to see if we've  hit a wall or
                                # if we're changing  direction at ran-
                                # dom
        set rthreshold 0.99

        if { [lindex [br::collision map $id \
             $layers($lv.map) 1] 0] == 1 || rand() > $rthreshold } {

                                # Yes: Pick a new direction at random
            set sdata($id.dir) [random_direction]
        } else {
            move_sprite $id   ; # Move the sprite
        }
    }
                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]

        if { $other_class eq "ocplayer" } {
                                # Assert collision with ocplayer
            set ocplayer_collide 1
                                # Set  a collision lock to  limit  re-
                                # peated processing of the same colli-
                                # sion
            if { ![info exists \
                    gdata($lv,$ocplayer_id.${objclass}_id) ] } {
                set gdata($lv,$ocplayer_id.${objclass}_id) $id
                                # This code is  executed once per col-
                                # lision
                                # Name of  sound  to play  (may change
                                # before it's actually played)
                set sound $objclass
                                # Check collision type
                if { $objclass eq "occar" } {
                                # occar-ocplayer collision
                                # Change ocplayer  sprite  into  occar
                                # sprite (as player is now driving)
                    set gdata(ocplayer.frame_index)  \
                       $gdata(ocplayer.frame_index.driving_left)
                    br::sprite frame $ocplayer_id \
                       $gdata(ocplayer.frame_index.driving_left)

                                # Update the status line
                    set name [get_object_name_current $id]
                    if { $name eq "none" } { set name "the car" }
                    set gdata(infomsg) "You drive $name"

                                # Destroy the occar sprite
                    destroy_sprite $objclass $id
                                # Reset  collision flag as  the sprite
                                # is now gone
                    set ocplayer_collide 0

                                # Prevent the creation of more cars in
                                # this world
                    set gdata(WORLD_PARAM.$lv.occar_minnum) 0
                    set gdata(WORLD_PARAM.$lv.occar_maxnum) 0

                } elseif { $objclass eq "occross" } {
                                # occross -ocplayer collision
                                # Destroy the affected sprite
                    destroy_sprite $objclass $id
                                # Reset  collision flag as  the sprite
                                # is now gone
                    set ocplayer_collide 0
                                # Embracing God is healthy
                    set gdata(health) 100
                                # Switch to "God" mode
                    if { $BRICKAPI >= 5400 } {
                        set godtime [expr int ([br::clock ms] / 1000)]
                        set gdata(godtime) $godtime
                        set gdata(ocplayer.frame_index)  \
                           $gdata(ocplayer.frame_index.godmode)
                        br::sprite frame $ocplayer_id \
                           $gdata(ocplayer.frame_index.godmode)
                    }
                }
                                # Play the appropriate sound
                play_sound $sound 0
            }

        } elseif { $other_class eq "ockarkinos" } {
                                # Object eats an ockarkinos
                                # Update the status line
            set name1 [get_object_name_current $id     ]
            set name2 [get_object_name_current $tgt_id ]
            if { ($name1 ne "none") && ($name2 ne "none") } {
                set gdata(infomsg) "$name1 ate $name2"
            }
                                # Play the appropriate sound
            play_sound pop 0
                                # Destroy the affected sprite
            destroy_sprite $other_class $tgt_id
        }
    }

# If an  ocplayer  collided with an object  supported by  this routine
# previously, a collision  lock was set to  limit  repeated processing
# of the (same) collision.  The following code releases the lock after
# the ocplayer leaves the object's position.

    set xlock_id $ocplayer_id.${objclass}_id

    if { !$ocplayer_collide } {
        if { [info exists  gdata($lv,$xlock_id) ] } {
             set glock_id $gdata($lv,$xlock_id)
             if { $id eq $glock_id } {
                    unset  gdata($lv,$xlock_id)
             }
        }
    }
}

#---------------------------------------------------------------------

# Routine:    group_hunter_run
# Purpose:    Runs an object (multiple hunter classes)
# Arguments:  id       = Sprite ID
#             objclass = Object-class name

# This routine handles object actions for hunter-group objects such as
# the following:
#
#     ocdog ockarkinos octiger
#
# The common characteristic is that these  objects  seek  the ocplayer
# (either to attack him/her or simply to follow).

#---------------------------------------------------------------------

dmproc 100 group_hunter_run { id objclass } {
    if  { $DebugLevel >= 2 } { puts "$rtn $id $objclass" }
    global gdata layers lv sdata
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]          } { return }
    set   callback    $sdata($id.)
    if { $callback ne "run_$objclass"        } { return }
    if { $objclass ne [get_sprite_class $id] } { return }

                                # Set object-class flags
    set is_ocdog      0 ; set is_ockarkinos 0 ; set is_octiger    0
    if { $objclass eq "ocdog"      } { set is_ocdog      1 }
    if { $objclass eq "ockarkinos" } { set is_ockarkinos 1 }
    if { $objclass eq "octiger"    } { set is_octiger    1 }
    if { !$is_ocdog && !$is_ockarkinos && !$is_octiger } { return }

    incr sdata($id.ct)        ; # Increment timeline counter
    set is_hunter 0           ; # Reset "hunter" flag
    set vx 0                  ; # Reset velocity components
    set vy 0

    set ocplayer_collide 0    ; # Flag: Collided with ocplayer
                              ; # ocplayer sprite id
    set ocplayer_id $gdata($lv,ocplayer_id)
                              ; # Check to see  if ocplayer is  hiding
                              ; # behind a tree
    if { [info exists gdata($lv,$ocplayer_id.octreehide_id) ] } {
        set ocplayer_hidden 1
    } else {
        set ocplayer_hidden 0
    }
                                # Move the sprite periodically
    if { !($sdata($id.ct) % $sdata($id.speed_divisor)) } {
                                # Is this a hunter?
        if { ($sdata($id.smart) > 0) && !$ocplayer_hidden } {
                                # Yes - Hunt the ocplayer!
            set is_hunter 1
            get_target_dx_dy $id $ocplayer_id dx dy
            if {$dx < 0} { set vx -1 }
            if {$dx > 0} { set vx  1 }
            if {$dy < 0} { set vy -1 }
            if {$dy > 0} { set vy  1 }

# An "ocdog" seeks the "ocplayer" until the two are  reasonably close.
# Then the  "ocdog" reverts to  random motion  until  the distance in-
# creases  again.  The net effect is that the  "ocdog" tends to follow
# the "ocplayer".

            if { $is_ocdog } {
                if {$dx < 0} { set dx [expr -$dx] }
                if {$dy < 0} { set dy [expr -$dy] }
                if { ($dx < 25) && ($dy < 25) } {
                    set sdata($id.smart) -8
                }
            }

        } else {
                                # No: It's a grazer
            get_dir_vx_vy $sdata($id.dir) vx vy
            cycle_smart $id   ; # Or maybe a hunter in explorer mode
        }

        br::sprite vel $id $vx $vy
        set rthreshold 0.99
        if { $is_hunter } { set rthreshold 1.00 }

                                # Check to see if we've  hit a wall or
                                # if we're changing  direction at ran-
                                # dom
        if { [lindex [br::collision map $id \
             $layers($lv.map) 1] 0] == 1 || rand() > $rthreshold } {

                                # Yes: Pick a new direction at random
            set sdata($id.dir) [random_direction]
                                # Override  intelligent behavior temp-
                                # orarily
            if { $sdata($id.smart) > 0 } { set sdata($id.smart) -8 }
        } else {
            move_sprite $id   ; # Move the sprite
        }
    }
                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]

        set a_eats_b 0        ; # Flag: Active object eats struck one
        set b_eats_a 0        ; # Flag: Struck object eats active one
                                # octigers eat occows
        if { $is_octiger && ($other_class eq "occow") } {
            set a_eats_b 1
        }
                                # octiger and ocdog are evenly matched
        if { ($is_octiger && ($other_class eq "ocdog"  )) || \
             ($is_ocdog   && ($other_class eq "octiger")) } {
            set n [random_int 1 2]
            if { $n == 1 } { set a_eats_b 1 }
            if { $n == 2 } { set b_eats_a 1 }
        }

        if { $other_class eq "ocplayer" } {
                                # Collided with an ocplayer
                                # Effect on ocplayer's health
            set heffect [get_object_param $id heffect]

                                # Assert collision with ocplayer
            set ocplayer_collide 1
                                # Set a collision lock to limit object
                                # class sounds to once per collision
            if { ![info exists \
                    gdata($lv,$ocplayer_id.${objclass}_id) ] } {
                set gdata($lv,$ocplayer_id.${objclass}_id) $id
                                # Play  object-class  sound  once  per
                                # collision
                play_sound $objclass 0
            } elseif { $heffect != 0 } {
                                # "Hit" sound may be played repeatedly
                                # while a collision continues
                play_sound hit 5
            }
                                # Determine effect on ocplayer health
            set heffect [get_object_param  $id heffect]
            if { [is_ocplayer_driving] } { set heffect 0 }

                                # Update the status line
            set name [get_object_name_current $id]
            if { $is_ockarkinos } {
                set gdata(infomsg) "$name attacks"
            } elseif { $is_octiger } {
                set gdata(infomsg) "$name is hungry"
            }
                                # Adjust ocplayer health
            incr gdata(health) $heffect

                                # "God" mode prevents damage
            if { [info exists gdata(godtime)] } {
                set gdata(health) 100
            }

        } elseif { $a_eats_b } {
                                # Active object eats other one
                                # Update the status line
            set name1 [get_object_name_current $id     ]
            set name2 [get_object_name_current $tgt_id ]
            if { ($name1 ne "none") && ($name2 ne "none") } {
                set gdata(infomsg) "$name1 ate $name2"
            }
                                # Play the appropriate sound
            play_sound $other_class 0
                                # Destroy the affected sprite
            destroy_sprite $other_class $tgt_id

        } elseif { $b_eats_a } {
                                # Other object eats active one
                                # Update the status line
            set name1 [get_object_name_current $id     ]
            set name2 [get_object_name_current $tgt_id ]
            if { ($name1 ne "none") && ($name2 ne "none") } {
                set gdata(infomsg) "$name2 ate $name1"
            }
                                # Play the appropriate sound
            play_sound $objclass 0
                                # Destroy the affected sprite
            destroy_sprite $objclass $id
        }
    }

# If an  ocplayer  collided with an object  supported by  this routine
# previously, a collision lock  was set to  limit  repeated processing
# of the (same) collision.  The following code releases the lock after
# the ocplayer leaves the object's position.

    set xlock_id $ocplayer_id.${objclass}_id

    if { !$ocplayer_collide } {
        if { [info exists  gdata($lv,$xlock_id) ] } {
             set glock_id $gdata($lv,$xlock_id)

             if { $id eq $glock_id } {
                    unset  gdata($lv,$xlock_id)
             }
        }
    }
}

#---------------------------------------------------------------------

# Routine:    run_ocbullet
# Purpose:    Runs an object: ocbullet class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocbullet { id } {
    if { $DebugLevel >= 2 } { puts "$rtn $id" }
    global gdata layers lv sdata
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]           } { return }
    set   callback    $sdata($id.)
    if { $callback  ne "run_ocbullet"         } { return }
    if { "ocbullet" ne [get_sprite_class $id] } { return }

    move_sprite $id           ; # Move the sprite
                                # Check for collisions with  shootable
                                # sprites
    foreach tgt [collision_sprites $id] {

        set tgt_id [lindex $tgt 1]
        set tgt_type "$sdata($tgt_id.)"
        regsub -all {^run_} $tgt_type "" objclass

                                # Was a shootable sprite hit?
        if { [get_object_param $tgt_id shoot_can] } {
                                # Yes
                                # Display a status message
            set name [get_object_name_current $tgt_id]
            if { $name ne "none" } {
                                # Update the status line
                set gdata(infomsg) "You shot $name"
            }
                                # Get object parameters
            foreach param [list \
                    health         shoot_score  shoot_effect \
                    sound_destroy  sound_hit] {
                set $param [get_object_param $tgt_id $param]
            }
                                # Update object health
            set new_health [expr $health + $shoot_effect]
            set_object_param $tgt_id health $new_health

# Some  sound-related conventions:  If an object is  hit or  destroyed
# here, an associated sound  may be  played.  The  "destroy" sound de-
# faults to the object's main class  sound  (if any).  The "hit" sound
# has no default.

                                # Has object been destroyed?
            if { $new_health < 0 } {
                                # Yes - Play appropriate sounds
                if { $sound_destroy eq "0" } {
                     set sound_destroy $objclass
                }

                play_sound $sound_destroy 100
                play_sound pop 0
                                # Update score appropriately
                incr gdata(score) $shoot_score
                                # Destroy the affected sprite
                destroy_sprite $objclass $tgt_id

            } elseif { $sound_hit ne "0" } {
                                # Play appropriate sound if it exists
                play_sound $sound_hit 100
            }
                                # Flag this ocbullet for removal
            set remove_ocbullet YES
        }
    }
                                # Remove this ocbullet?
    if { [info exists remove_ocbullet] || \
         [lindex [br::collision map $id $layers($lv.map) 1] 0] } {
                                # Yes
        destroy_sprite ocbullet $id
    }
}

#---------------------------------------------------------------------

# Routine:    run_occar
# Purpose:    Runs an object: occar class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_occar { id } {
    group_barnyard_run $id occar
}

#---------------------------------------------------------------------

# Routine:    run_occow
# Purpose:    Runs an object: occow class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_occow { id } {
    group_barnyard_run $id occow
}

#---------------------------------------------------------------------

# Routine:    run_occross
# Purpose:    Runs an object: occross class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_occross { id } {
    group_barnyard_run $id occross
}

#---------------------------------------------------------------------

# Routine:    run_ocdog
# Purpose:    Runs an object: ocdog class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocdog { id } {
    group_hunter_run $id ocdog
}

#---------------------------------------------------------------------

# Routine:    run_ocflames
# Purpose:    Runs an object: ocflames class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocflames { id } {
    if { $DebugLevel >= 2 } { puts "$rtn $id" }
    global gdata layers lv sdata level_list LevelToSData
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]           } { return }
    set   callback    $sdata($id.)
    if { $callback  ne "run_ocflames"         } { return }
    if { "ocflames" ne [get_sprite_class $id] } { return }

    if { ![info exists sdata($id.frametick)] } {
                   set sdata($id.frametick) 0
    }

    set FPSDIV 10             ; # This should be changed into  a class
                              ; # parameter

    if { [incr sdata($id.frametick)] == $FPSDIV } {
        set    sdata($id.frametick) 0
        set n [expr $gdata(ocflames.frame_index) + 1]
        if { $n >=  $gdata(ocflames.num_frames) } { set n 0 }
        set gdata(ocflames.frame_index) $n
        br::sprite frame $id $n
    }
                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]

        if { $other_class eq "ocplayer" } {
                                # Player hit! Adjust health
            incr gdata(health) [get_object_param $id heffect]

                                # "God" mode prevents damage
            if { [info exists gdata(godtime)] } {
                set gdata(health) 100
            }
                                # Play appropriate sound
            if { $sdata($id.frametick) == 0 } {
                play_sound ocflames 0
            }
        }
    }
}

#---------------------------------------------------------------------

# Routine:    run_ocinter
# Purpose:    Runs an object: ocinter class
# Arguments:  id = Sprite ID

# This  routine  runs two different  (but related)  types  of objects:
# inter-world forward and reverse portals.

#---------------------------------------------------------------------

dmproc 100 run_ocinter { id } {
    if { $DebugLevel >= 2 } { puts "$rtn $id" }

    global gdata layers lv sdata level_list
    global LevelToSData WorldKeyStart
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]          } { return }
    set   callback    $sdata($id.)
    if { $callback ne "run_ocinter"          } { return }
    if { "ocinter" ne [get_sprite_class $id] } { return }

    set FromWorldName $lv
    set FromPortalID  $id
    set ocplayer_id $gdata($lv,ocplayer_id)
                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]

                                # Player-portal collision?
        if { $other_class eq "ocplayer" } {
                                # Yes
                                # Consistency check
            if { $ocplayer_id ne $tgt_id } {
                puts "$IE-01: $rtn: Inconsistent ocplayer IDs"
                exit 1
            }
                                # Did player  get  here  by using  the
                                # portal (or its other side) ?
            if { [info exists gdata($lv.$tgt_id.$id.portal_lock)] } {
                                # Yes - So the portal shouldn't  acti-
                                # vate again immediately
                return
            } else {
                                # No  - Lock the portal to prevent in-
                                # finite loops
                set gdata($lv.$tgt_id.$id.portal_lock) 1
            }

            if { $DebugLevel } {
                puts "$rtn: ocplayer $lv,$tgt_id collided with\
portal $lv,$id"
            }
                                # Update the status line
            set gdata(infomsg) "Used a world portal"
                                # Play the appropriate sound
            play_sound ocinter 0

            set to_world  $sdata($id.to_world)
            set to_portal $sdata($id.to_portal)

            if {[info exists LevelToSData($to_world)]} {
                if { $DebugLevel > 2 } {
                    puts "$rtn: to_world $to_world exists"
                }

                array set xdata [array get sdata]
                unset sdata
                array set sdata $LevelToSData($to_world)
                set_world_name $to_world

                if { $to_portal eq "none" } {
                    set to_portal [new_ocinter \
                        "reverse" $FromWorldName $FromPortalID]
                    verify_sprite_exists "$rtn-1000"   $to_portal
                    set xdata($FromPortalID.to_portal) $to_portal
                }

                set LevelToSData($FromWorldName) [array get xdata]
                set PortalIdExit $to_portal
                verify_sprite_exists "$rtn-1001" $PortalIdExit
            } else {
                                # Consistency check
                if { $to_world eq $gdata(WorldMain) } {
                    puts "$IE-02" ; exit 1
                }

                array set xdata [array get sdata]
                unset sdata
                                # Note: "make_world" sets $lv equal to
                                # $to_world
                set PortalIdExit [make_world $to_world $id]
                verify_sprite_exists $rtn $PortalIdExit
                new_ocplayer

                set xdata($FromPortalID.to_portal) $PortalIdExit
                set LevelToSData($FromWorldName)   [array get xdata]
                set LevelToSData($to_world)        [array get sdata]
            }
                                # Consistency check
            if { $lv ne $to_world } { puts "$IE-03" ; exit 1 }

            set MyPosition [br::sprite pos $PortalIdExit]
            set my_x [lindex $MyPosition 0]
            set my_y [lindex $MyPosition 1]
            set ocplayer_id $gdata($lv,ocplayer_id)

            set frame_index   $gdata(ocplayer.frame_index)
            set frame_godmode $gdata(ocplayer.frame_index.godmode)
            set frame_normal  $gdata(ocplayer.frame_index.normal)
            if { ($frame_index != $frame_godmode) &&
                 ($frame_index != $frame_normal) } {
                set gdata(ocplayer.frame_index) $frame_normal
                br::sprite frame $ocplayer_id   $frame_normal
            }

            set gdata($lv.$ocplayer_id.$PortalIdExit.portal_lock) 1

            if { ![info exists gdata(ocplayer.frame_index)] } {
                puts "$IE-03"
                exit 1
            }

            br::sprite frame $ocplayer_id $gdata(ocplayer.frame_index)
            br::sprite pos   $ocplayer_id $my_x $my_y
            br::sprite vel   $ocplayer_id 0 0

# The following block is an attempt  to prevent a problem.  Under some
# conditions, the player may overlap a wall as soon as he/she  emerges
# from a portal. If this happens, and isn't corrected here, collision-
# detection code in "run_ocplayer"  may  be confused  and  prevent the
# player from moving. To address the issue, if the player intersects a
# wall  after arrival through a portal, this code bounces him/her to a
# random (but collision-free) location.

                                # Colliding on arrival?
            set colls [br::collision map $ocplayer_id \
                      $layers($lv.map) 1]
            if { [lindex $colls 0] } {
                                # Yes - Bounce to a better location
                random_position_sprite $ocplayer_id
            }
                                # Account for player's position
            account_ocplayer_position

            foreach name [array names LevelToSData] {
                if { $name ne $to_world } {
                    br::layer visible $layers($name) 0
                }
            }
                                # Make world layer visible
            br::layer visible $layers($to_world) 1

                                # Made it to the exit?
            if { $to_world eq $gdata(WorldEndOfAllSongs) } {
                                # Yes - Play appropriate sound
                play_sound win 2600
                                # Disable normal "exit" sound
                unset gdata(sound_exit)
                                # Update the status line
                set gdata(infomsg) "Winner!"
                                # Display a farewell message
                show_msg " Made it to the exit " 70 80

                quit_program  ; # Quit the program
            }

            return
        }
    }

# If we make it to this point,  the ocplayer sprite ($ocplayer_id)  in
# the current world ($lv) isn't  standing on the current portal ($id),
# so the portal should be  unlocked.  The following code addresses the
# issue.

    if { [info exists gdata($lv.$ocplayer_id.$id.portal_lock)] } {
                unset gdata($lv.$ocplayer_id.$id.portal_lock)
    }
}

#---------------------------------------------------------------------

# Routine:    run_ocintra
# Purpose:    Runs an object: ocintra class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocintra { id } {
    if { $DebugLevel >= 2 } { puts "$rtn $id" }
    global gdata layers lv sdata
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]          } { return }
    set   callback    $sdata($id.)
    if { $callback ne "run_ocintra"          } { return }
    if { "ocintra" ne [get_sprite_class $id] } { return }

                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]
                                # Collided with ocplayer?
        if { $other_class eq "ocplayer" } {
                                # Yes
                                # Update the status line
            set gdata(infomsg) "Used a local portal"
                                # Play the appropriate sound
            play_sound ocintra 0
                                # Set new position
            random_position_sprite $tgt_id
                                # Account for new ocplayer position
            account_ocplayer_position
        }
    }
}

#---------------------------------------------------------------------

# Routine:    run_ockarkinos
# Purpose:    Runs an object: ockarkinos class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ockarkinos { id } {
    group_hunter_run $id ockarkinos
}

#---------------------------------------------------------------------

# Routine:    run_ocmedical
# Purpose:    Runs an object: ocmedical class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocmedical { id } {
    group_avoid_run $id ocmedical
}

#---------------------------------------------------------------------

# Routine:    run_ocmoney
# Purpose:    Runs an object: ocmoney class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocmoney { id } {
    group_avoid_run $id ocmoney
}

#---------------------------------------------------------------------

# Routine:    run_ocpig
# Purpose:    Runs an object: ocpig class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocpig { id } {
    group_barnyard_run $id ocpig
}

#---------------------------------------------------------------------

# Routine:    run_ocplayer
# Purpose:    Runs an object: ocplayer class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocplayer { id } {
    if { $DebugLevel >= 2 } { puts "$rtn $id" }

    global gdata layers lv proto sdata
    global KeyH_Button      KeyH_Input
    global KeyI_Button      KeyI_Input
    global KeyQ_Button      KeyQ_Input
    global KeySpace_Button  KeySpace_Input
    global BRICKAPI MaxGodTime

    set ocbullet_maxnum [get_class_param ocbullet maxnum]
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]           } { return }
    set   callback    $sdata($id.)
    if { $callback  ne "run_ocplayer"         } { return }
    if { "ocplayer" ne [get_sprite_class $id] } { return }

                                # Fetch input
    set io(1) [br::io fetch 1]
    set io(0) [br::io fetch 0]
    set hkey  [lindex $io($KeyH_Input) 2 $KeyH_Button]
    set ikey  [lindex $io($KeyI_Input) 2 $KeyI_Button]
    set qkey  [lindex $io($KeyQ_Input) 2 $KeyQ_Button]
    set spkey [lindex $io($KeySpace_Input) 2 $KeySpace_Button ]

    set horiz [lindex $io(0) 0 0]
    set vert  [lindex $io(0) 0 1]

    if { [lindex $io(0) 7] || $qkey || [br::io has-quit] } {
        quit_program
    }
    if { $hkey } { display_help      ; return }
    if { $ikey } { display_inventory ; return }

                                # Get ocplayer movement
    set vx [expr { $horiz < 0 ? -1 : ($horiz > 0 ? 1 : 0) }]
    set vy [expr { $vert  < 0 ? -1 : ($vert  > 0 ? 1 : 0) }]
    br::sprite vel $id $vx $vy

# Note: If the ocplayer  is driving, he/she  can  pass through  walls.
# This is a kludge;  it's necessary (or may be necessary) to  keep the
# ocplayer  (in driving mode) from getting stuck  behind passages that
# are too narrow for an occar to use.

                                # Check for collision with walls
    if { ![is_ocplayer_driving] } {
        set colls [br::collision map $id $layers($lv.map) 1]
        set vx [expr {[lindex $colls 1] + [lindex $colls 3]}]
        set vy [expr {[lindex $colls 2] + [lindex $colls 4]}]
    }
                                # Set new position
    incr sdata($id.px) $vx
    incr sdata($id.py) $vy
    br::sprite pos $id $sdata($id.px) $sdata($id.py)

    handle_limbo $id
    account_ocplayer_position ; # Needed  because  "handle_limbo"  may
                                # have moved the ocplayer

                                # If  there's  any movement,  save the
                                # direction  for  use   in  subsequent
                                # shooting operations
    if { $horiz || $vert } {
        set sdata($id.gx) $vx
        set sdata($id.gy) $vy
    }
                                # "God mode" code
    if { $BRICKAPI >= 5400 } {
        if { [info exists gdata(godtime)] } {
            set gdata(health) 100
                                # Has time in "God mode" ended?
            set godtime  $gdata(godtime)
            set curtime  [expr int ([br::clock ms] / 1000)]

            if { ($curtime - $godtime) > $MaxGodTime } {
                                # Yes
                unset gdata(godtime)
                set   gdata(ocplayer.frame_index) \
                     $gdata(ocplayer.frame_index.default)
                br::sprite frame $id \
                     $gdata(ocplayer.frame_index.default)
            }
        }
    }

    set frame_index   $gdata(ocplayer.frame_index)
    set driving_left  $gdata(ocplayer.frame_index.driving_left)
    set driving_right $gdata(ocplayer.frame_index.driving_right)

    if { ($frame_index == $driving_left) && ($vx > 0) } {
        set gdata(ocplayer.frame_index) $driving_right
        br::sprite frame $id            $driving_right
    } elseif { ($frame_index == $driving_right) && ($vx < 0) } {
        set gdata(ocplayer.frame_index) $driving_left
        br::sprite frame $id            $driving_left
    }
                                # Handle a shot (if any)
    if { [lindex $io(0) 2 0] || $spkey } {
                                # If  the ocplayer  is  driving,  just
                                # beep the horn
        if { [is_ocplayer_driving] } {
            play_sound occar 250
        } elseif { ([get_class_counter ocbullet] \
                       < $ocbullet_maxnum) && \
             !$sdata($id.shot) && \
             ($sdata($id.gx) || $sdata($id.gy)) } {

                                # Create an ocbullet
            incr_class_counter ocbullet
            set ocbullet [br::sprite copy $proto(ocbullet)]
            if { $DebugLevel } { puts "new ocbullet: $lv,$id" }

            br::sprite pos $ocbullet [expr {$sdata($id.px) + 1}] \
                                     [expr {$sdata($id.py) + 1}]

            br::sprite vel $ocbullet [expr {$sdata($id.gx) * 2}] \
                                     [expr {$sdata($id.gy) * 2}]

                                # Add it to the lists
            br::list add $layers($lv.spr-list) $ocbullet
            set sdata($ocbullet.) run_ocbullet
            set sdata($id.shot) 1
                                # Play the appropriate sound
            play_sound gunshot 0
                                # Shooting   while  hiding  behind  an
                                # octree breaks cover
            if { [info exists gdata($lv,$id.octreehide_id) ] } {
                        unset gdata($lv,$id.octreehide_id)
            }
        }
    } else {
        set sdata($id.shot) 0 ; # Reset trigger for next shot
    }
                                # Track ocplayer with camera
    track_sprite $sdata($id.px) $sdata($id.py)
}

#---------------------------------------------------------------------

# Routine:    run_ocscroll
# Purpose:    Runs an object: ocscroll class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_ocscroll { id } {
    if { $DebugLevel >= 2 } { puts "$rtn $id" }
    global gdata layers lv sdata level_list LevelToSData
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]           } { return }
    set   callback    $sdata($id.)
    if { $callback  ne "run_ocscroll"         } { return }
    if { "ocscroll" ne [get_sprite_class $id] } { return }

                                # Player sprite ID
    set ocplayer_id $gdata($lv,ocplayer_id)
                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]
                                # Player-portal collision?
        if { $other_class eq "ocplayer" } {
                                # Yes
                                # Consistency check
            if { $ocplayer_id ne $tgt_id } {
                puts "$IE-01: $rtn: Inconsistent ocplayer IDs"
                exit 1
            }

            if { $DebugLevel } {
                puts "$rtn: ocplayer $lv,$tgt_id collided with\
ocscroll $lv,$id"
            }
                                # Destroy the affected sprite
            destroy_sprite ocscroll $id
                                # Update the status line
            set gdata(infomsg) "You read a scroll"
            display_wisdom    ; # Display contents of ocscroll
        }
    }
}

#---------------------------------------------------------------------

# Routine:    run_octiger
# Purpose:    Runs an object: octiger class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_octiger { id } {
    group_hunter_run $id octiger
}

#---------------------------------------------------------------------

# Routine:    run_octree
# Purpose:    Runs an object: octree class
# Arguments:  id = Sprite ID

#---------------------------------------------------------------------

dmproc 100 run_octree { id } {
    if { $DebugLevel >= 2 } { puts "$rtn $id" }
    global gdata layers lv sdata level_list LevelToSData
                                # Safety measure; see comments in main
                                # routine
    if { ![info exists sdata($id.)]          } { return }
    set   callback    $sdata($id.)
    if { $callback ne "run_octree"           } { return }
    if { "octree"  ne [get_sprite_class $id] } { return }

                                # Player sprite ID
    set ocplayer_id $gdata($lv,ocplayer_id)
    set ocplayer_collide 0
                                # Instantiate a tiger if appropriate
    if { [get_object_param $id add_octiger] } {
        get_target_dx_dy $id $ocplayer_id dx dy
        if {$dx < 0} { set dx [expr -$dx] }
        if {$dy < 0} { set dy [expr -$dy] }
        set octigerdelta [get_class_param octree octigerdelta]

        if { ($dx < $octigerdelta) && ($dy < $octigerdelta) } {
            set octiger_id [new_octiger]

            if { $octiger_id ne "0" } {
                set MyPosition [br::sprite pos $id]
                set my_x [lindex $MyPosition 0]
                set my_y [lindex $MyPosition 1]
                br::sprite pos $octiger_id $my_x $my_y
                set_object_param $id add_octiger 0
                play_sound octiger 0
            }
        }
    }
                                # Check for collisions
    foreach tgt [collision_sprites $id] {
                                # Process next collided object
        set tgt_id [lindex $tgt 1]
                                # Class of other object involved
        set other_class [get_sprite_class $tgt_id]
                                # Player-octree collision?
        if { $other_class eq "ocplayer" } {
                                # Yes
                                # Consistency check
            if { $ocplayer_id ne $tgt_id } {
                puts "$IE-01: Inconsistent ocplayer IDs"
                exit 1
            }
                                # Player  can  hide here,  subject  to
                                # limitations  (this only  works  once
                                # per octree, and shooting breaks con-
                                # cealment)
            if { ![info exists \
                    gdata($lv,$id,$ocplayer_id.octreehide_flag) ] } {
                set gdata($lv,$id,$ocplayer_id.octreehide_flag) 1
                set gdata($lv,$ocplayer_id.octreehide_id) $id
            }
                                # Assert collision with ocplayer
            set ocplayer_collide 1
        }
    }

# If an  ocplayer collided with an octree previously, a collision lock
# was set to limit repeated  processing of the  (same) collision.  The
# following  code  releases  the lock  after  the  ocplayer leaves the
# octree's position.

    if { !$ocplayer_collide } {
        if { [info exists gdata($lv,$ocplayer_id.octreehide_id) ] } {
         set octreehide_id $gdata($lv,$ocplayer_id.octreehide_id)
            if { $id eq $octreehide_id } {
                    unset gdata($lv,$ocplayer_id.octreehide_id)
            }
        }
    }
}

#---------------------------------------------------------------------

# Routine:    setup_info_display
# Purpose:    Sets up program's information display
# Arguments:  None

#---------------------------------------------------------------------

dmproc 1 setup_info_display {} {
    global gdata layers
    global BGHeight BGWidth
    global BGTileWidth BGTileHeight
    global BRICKAPI FRAFMTTRA NCDIGITS TRANSPARFRA

    set foo ""
    set nn [expr $BGTileWidth * $BGTileHeight]
    for { set ii 1 } { $ii <= $nn } { incr ii } \
        { append foo $TRANSPARFRA }
                                # Total number of hex digits
    set NumHexDigits [expr $nn * $NCDIGITS]
                                # Consistency check
    if { $NumHexDigits != [string length $foo] } {
        puts "$IE-01" ; exit 1
    }

    set t1 [br::tile create]

    if { $BRICKAPI < 5400 } {
        global CHROMA_R CHROMA_G CHROMA_B
        set fr1 [br::frame create $FRAFMTTRA \
                $BGTileWidth $BGTileHeight \
                [binary format H$NumHexDigits $foo] \
                $CHROMA_R $CHROMA_G $CHROMA_B]
    } else {
        set fr1 [br::frame create $FRAFMTTRA \
                $BGTileWidth $BGTileHeight \
                [binary format H$NumHexDigits $foo]]
    }

    br::tile add-frame $t1 $fr1
    set layer_id              [br::layer add]
    set layers(info)          $layer_id

    if { $BRICKAPI < 5300 } {
        set info_list             [br::layer info $layer_id]
        set layers(info.spr-list) [lindex $info_list 0]
        set layers(info.map)      [lindex $info_list 1]
        set layers(info.str-list) [lindex $info_list 2]
    } else {
        set layers(info.spr-list) [br::layer sprite-list $layer_id]
        set layers(info.map)      [br::layer map         $layer_id]
        set layers(info.str-list) [br::layer string-list $layer_id]
    }

    br::map tile-size $layers(info.map) $BGTileWidth $BGTileHeight
    br::map tile      $layers(info.map) 1 $t1
    br::map size      $layers(info.map) \
        $BGWidth $BGHeight
    br::map set-data $layers(info.map) \
        [binary format H[expr {4 * $BGWidth * $BGHeight}] \
        [string repeat 0100 [expr {$BGWidth * $BGHeight}]]]

    set stg_x 10
    set stg_y 10

    set mxpos(time)      10 ; set mypos(time)      10
    set mxpos(health)   120 ; set mypos(health)    10
    set mxpos(score)     10 ; set mypos(score)     18
    set mxpos(lv)       120 ; set mypos(lv)        18
    set mxpos(infomsg)   10 ; set mypos(infomsg)   26

    foreach stg { time health score lv infomsg } {
        set gdata(stg.$stg) [br::string create]
        set stg_x $mxpos($stg)
        set stg_y $mypos($stg)
        br::string position $gdata(stg.$stg) $stg_x $stg_y
        br::list add $layers(info.str-list) $gdata(stg.$stg)
    }

    global col2fmt
    set    col2fmt "%-16s"

    trace add variable gdata(time)   write {apply {{a1 a2 op} { \
        global idsfmt  ; upvar 1 $a1 a ; \
        br::string text $a(stg.time)    [format $idsfmt \
        "Time  |[clock format $a(time) -format %M:%S]"] }}}

    trace add variable gdata(health) write {apply {{a1 a2 op} { \
        global col2fmt ; upvar 1 $a1 a ; \
        br::string text $a(stg.health)  [format $col2fmt \
        "Health|$a(health)"] }}}

    trace add variable gdata(score)   write {apply {{a1 a2 op} { \
        global idsfmt  ; upvar 1 $a1 a ; \
        br::string text $a(stg.score)   [format $idsfmt \
        "Score |$a(score)"] }}}

    trace add variable gdata(lv)      write {apply {{a1 a2 op} { \
        global col2fmt ; upvar 1 $a1 a ; \
        br::string text $a(stg.lv)      [format $col2fmt \
        "World |$a(lv)"] }}}

    trace add variable gdata(infomsg) write {apply {{a1 a2 op} { \
        global idsfmt  ; upvar 1 $a1 a ; \
        br::string text $a(stg.infomsg) [format $idsfmt \
        "Info  |$a(infomsg)"] }}}
}

#---------------------------------------------------------------------

# Routine:    start_traces
# Purpose:    Starts traces associated with info display
# Arguments:  None

# This routine initializes some  global variables  associated with the
# program's  information display.  As a side effect,  this  starts the
# Tcl-level traces that run the display.

#---------------------------------------------------------------------

dmproc 1 start_traces {} {
    global gdata lv
                                # Global data connected to traces
    set gdata(health)     100
    set gdata(score)        0
    set gdata(start_time) [clock seconds]
    set gdata(lv)         $lv
    set gdata(infomsg)    "Press h for help"
}

#---------------------------------------------------------------------

# Routine:    setup_program
# Purpose:    Sets up the program
# Arguments:  None

# This routine should be called once, immediately before the program's
# main loop is started.  It handles all program-setup operations  that
# aren't addressed by "non-proc" code.

#---------------------------------------------------------------------

dmproc 1 setup_program {} {
    global gdata
    setup_graphics            ; # Set up graphics
    setup_audio               ; # Set up audio
    setup_keyboard            ; # Set up keyboard
    setup_background          ; # Set up background
    setup_sprite_prototypes   ; # Set up sprite prototypes
                              ; # Make main world
    make_world $gdata(WorldMain) none

    new_ocplayer              ; # Create an ocplayer
    setup_info_display        ; # Set up info display
    display_msg_startup       ; # Display a startup message
    start_traces              ; # Make info display active
}

#---------------------------------------------------------------------

# Routine:    main_routine
# Purpose:    Program's main routine
# Arguments:  None

# This routine handles almost everything:
#
#     (a) Most program-setup operations (*)
#     (b) Main loop
#     (c) Farewell message

# (*) Presently,  some  program-setup operations are handled by  "non-
# proc" code.

#---------------------------------------------------------------------

dmproc 1 main_routine {} {
    global BRICKAPI FPS lv gdata sdata
    setup_program             ; # Set up the program

    while { $gdata(health) > 0 } {
                                # Run callbacks for sprites
        foreach { id callback } [array get sdata *.] {

# The "info exists" test below is  an attempt to prevent callbacks re-
# lated to sprites  that are  removed from  play mid-loop.  It appears
# that the test may not be completely reliable. A sprite that's remov-
# ed may apparently be replaced with a  different sprite which has the
# same sprite ID. If the removal and replacement occur during the same
# iteration, erroneous callbacks may be made. To reduce the chances of
# problems,  the callback routines  have  been  modified  so that they
# simply return if an inconsistency of this type is detected.

            if { [info exists sdata($id)] } {
                set oldlv $lv
                $callback [string trim $id .]
                                # If we've changed worlds,  we need to
                                # exit the inner loop immediately
                if { $oldlv ne $lv } { break }
            }
        }
                                # Take care of necessary business
        foreach objclass $gdata(list_classes_periodic) {
            set cmd new_$objclass
            eval $cmd
        }

        set gdata(time) [expr {[clock seconds] - $gdata(start_time)}]
        br::render display

        if { $BRICKAPI < 5400 } {
            br::delay $FPS
        } else {
            br::clock wait $FPS
        }
    }

    play_sound loser 2600     ; # Play an appropriate sound
    play_sound loser 2600     ; # Twice
    unset gdata(sound_exit)   ; # Disable the normal "exit" sound
                                # Update the status line
    set gdata(infomsg) "Loser!"
                              ; # Display a farewell message
    show_msg " You have perished " 80 80
    quit_program              ; # Quit the program
}

#---------------------------------------------------------------------
# Main program.

# This is the main program.  It simply calls the  main routine,  which
# doesn't return.

main_routine



To continue, press the browser's Back button.