#!/usr/bin/env brick-tcl
# beworld - Prototype Brick Engine game
# License: Creative Commons (see license information section)
# Revision: 211113
#---------------------------------------------------------------------
# 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 or 3 for non-OpenGL mode.
# FullScreen specifies a full-screen mode flag (may be "on" or "off").
# The recommended setting is "off".
if { $UseOpenGL } {
set DisplayWidth $GAME_WIDTH
set DisplayHeight $GAME_HEIGHT
set DisplayScale 1
set FullScreen off
} 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 3
set FullScreen off
}
#---------------------------------------------------------------------
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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 \
# 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
}
}
br::graphics window-title "OldCoder BEWorld"
}
#---------------------------------------------------------------------
# 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
