@prog pente.muf
1 9999 d
1 i
(
If there is an _action: property on trigger @, its value is taken as a
command, unless its value is "prefix", which causes the command line up
to the first space to be taken as the command.  Otherwise, trigger @'s
name, up to the first ; [if any], is taken as the command.

Games are started by one player offering a game and the other accepting it.
The "other" player can also decline the offer, in which case it is discarded;
if the "other" player hasn't done either yet, the first player can retract
the offer, which also discards it.

Any particular pair of players can have at most one game in progress at any
one time.

Games can be for the record or just for fun.  This must be decided no later
than the time the offer is accepted.  A game for the record has its outcome
put into each player's win/loss record and affects ladder standings, whereas
a just-for-fun game has no effect on either.

Commands and their parameters are as given in the help messages below.

Which player gets first move is random the first time two players play;
after that, it switches, each game between them.

Everything is kept on a single dbref.  By default, this dbref is obtained
with "trigger @ location" and must be a thing [as opposed to a room or other
type of dbref], but if trigger @ has a _holder: property, its value is used
instead, regardless of type, as long as either [a] trigger @ has its wizbit
set, or [b] the holder dbref has the same owner as trigger @.

Players are identified internally by dbref, not name; names are converted
to dbrefs, and vice versa, as close to the user interface as possible.  In
particular, if a player is renamed, everything belonging to that player will
automatically carry over to the new name.

Offers are stored on the dbref in properties of the form
	*offer-A-B-: TYPES
where A is the offering person, B is the offered-to person, and TYPES is a
string containing f if the game could be just for fun or r if it could be
for the record.

Games-in-progress are stored on the dbref in properties of the form
	*game-A-B-: STRING
where A and B are the players involved [in dbref numbers, A <= B] and STRING
is an encoding of the game state.  The game state is stored as 21 hex strings,
such as are handled by atoq and qtoa, separated by single spaces.  The first
value gives some game state; the remaining 20 store the board.  The
game-state value has bitfields thus:
	<record> <turn> <A capture count> <B capture count>
The record and turn fields are one bit each.  record is 1 if the game is
for the record, 0 if it's just for fun; turn is 0 if it's A's turn, 1 if
B's turn.  The capture count fields are four bits each.  Thus, for example,
if that number is ca, or 1100010010 in binary, then the game is for the
record, it's B's turn, A has captured one pair, and B has captured two pairs.

Who-moves-first state between two players A and B is stored in a property
	*turn-A-B-: BIT
where BIT is 1 if A should move first and 2 if B should, next time those
two players start a game between them.  [Modifications to this property are
locked by the game lock.]  As for *game- props, A <= B.

A player's default-game setting [the "game" command] is kept in a
*def-<player>: property, whose value is the default game.  If there is no
default game, the property can be present with a zero-length value or absent.

The 20 strings that store the board are simply the board rows, represented
as numbers in base 3 and converted to hex.  An empty cell is represented as
0, a piece belonging to A as 1, and a piece belonging to B as 2.  For example,
if the board row looks like
	- - A - B A B B B A - - - - A - - - - B
then the base-3 number will be
	0 0 1 0 2 1 2 2 2 1 0 0 0 0 1 0 0 0 0 2
which is 167286062 decimal, or 9f8952e as it would appear in the property
[ie, in hex].  Rows higher on the board appear earlier in the property.

Settings [see the "set" command] are kept in a *set-<player>: property, which
contains one character per setting that differs from the default:
	"set" keyword	character
	move		m
	show		s
	watch		w
	autoshow	a
If all the defaults are in effect, the property may be absent or may be
present with a zero-length value.

There is a lock that prevents offers from being made, retracted, accepted, or
declined [except, of course, by the holder of the lock]; this lock takes the
form of a property
	*lock-offers: <holder> <timestamp>
[for example: *lock-offers: 1234 909524337].  A similar lock
	*lock-games: <holder> <timestamp>
prevents games from being started or finished while it is set.  Locks older
than
)
$def lock-timeout-time 60
(
seconds are considered stale and are ignored.  The code is careful to never
block while it holds a lock.  Individual games are not locked; only the player
whose turn it is may modify a game-in-progress, so no locking is necessary.
When waiting for a lock, the first
)
$def lock-yield-count 3
(
failures provoke simple "yield" calls; after that, one-second sleeps are done
instead [with timed-prompt, so that the player can break out].  After
)
$def lock-warn-count 6
(
failures, a warning is printed.  After that, nothing is done until either
the lock is obtained [possibly due to an existing lock going stale] or the
user aborts the wait.

Whenever a given piece of code needs to have both offers and games locked,
it must always lock offers first [but it may unlock in either order].
)
$def conf-size 3 (size of border printed for move confirmation)
: help-info-
"Commands are as follows.  Use \"help <command>\" for help on <command>,"
"as in \"help offer\" for help on the \"offer\" command."
" "
"rules      - print game rules"
"move       - make a move in a game"
"show       - show the current state of a game"
"check      - check if you have anything to do"
"offer      - offer to play a game with someone"
"retract    - retract an offer you made"
"accept     - accept an offer made to you"
"decline    - decline an offer made to you"
"ladder     - show the game ladder"
"help       - (also \"?\") show help info"
"games      - list all games you have in progress"
"offers     - list all outstanding offers involving you"
"record     - show someone's win/loss record"
"game       - pick a default opponent for move and show commands"
"resign     - give up a game"
"set        - set various options"
"toadsweep  - clean up after toaded players"
me @ prog owner dbcmp if
"cmdstats   - show command statistics"
then
;
: help-info-rules
"rules [<page>]"
"    Prints game rules.  With no argument, prints a table-of-contents list;"
"    with an argument, prints that page from the rules."
;
: help-info-help
"help [<command>]"
"    Prints help information.  If no command is given, prints a list of"
"    commands, with a short description of each one.  If a command is given,"
"    prints help info for that command."
;
: help-info-offer
"offer <player> [{fun|record}]"
"    Extend an offer to another player, whose name must be given.  The"
"    optional argument says whether the game is just for fun or is for the"
"    record; if it is not specified, the other player may choose when"
"    accepting the offer.  If you already have an offer extended to that"
"    player, it is replaced."
;
: help-info-retract
"retract <player>"
"    Retracts your offer of a game to the specified player.  If you have no"
"    offer currently extended to that player, a message saying so is printed"
"    and nothing is done."
;
: help-info-decline
"decline <player>"
"    Declines an offer the specified player has made to you.  If there is no"
"    such offer outstanding, a message saying so is printed and nothing is"
"    done."
;
: help-info-offers
"offers"
"    Lists all offers that have been made to you or that you have made, but"
"    which have been neither accepted, declined, nor retracted."
;
: help-info-set
"set <option> <value>"
"    Sets various options.  The value is option-specific.  The options"
"    currently recognized are as follows.  Use \"help set <option>\" to"
"    get help on \"set <option>\" (as in \"help set move\" for help on the"
"    \"move\" option)."
"        move     - controls confirmation prompting for making moves"
"        show     - controls whether empty areas of the board are shown"
"        watch    - controls seeing other people's game actions"
"        autoshow - controls whether \"show\" is automatic after moves"
;
: help-info-set-move
"set move {confirm|noconfirm}"
"    Sets move confirmation.  When set to confirm, when you make a move, a"
"    small area of the board around the new move is printed and you are"
"    prompted for confirmation that the move is the move you really intend"
"    to make; when set noconfirm, the game assumes that what you typed is"
"    really what you meant.  By default, confirmation is turned off."
;
: help-info-set-show
"set show {small|big}"
"    Sets whether the show command shows the whole board (\"big\") or just"
"    that part of the board which has pieces on it (\"small\").  By default,"
"    the whole board is shown."
;
: help-info-set-watch
"set watch {yes|no}"
"    Sets whether you hear about it when games not involving you are begun"
"    or have moves made in them.  By default such announcements are sent."
;
: help-info-set-autoshow
"set autoshow {yes|no}"
"    Sets whether an automatic \"show\" is done for you when your opponent"
"    makes a move (with you in the room).  By default, no automatic"
"    \"show\" is done."
;
: help-info-accept
"accept <player> [{fun|record}]"
"    Accept an offer from another player to you.  The optional argument syas"
"    whether the game is just for fun or is for the record; if the offer"
"    specifies one and the acceptance specifies the other, an error occurs"
"    and the offer is not accepted.  (If neither the offer nor acceptance"
"    specifies whether the game is fun or record, record is assumed.)"
;
: help-info-game
"game [<player>]"
"    Sets the default game for move, show, and resign commands to be your"
"    game with the specified player.  If no player name is given, sets no"
"    default game (which means you must specify a game for affected"
"    commands).  You do not need to have a game in progress with a player"
"    for your default game to be set to that player."
;
: help-info-show
"show [<player> [<otherplayer>]]"
"    Prints the state a game.  This includes the board and the pieces on it,"
"    captures made by either side, whose turn it is, and, if the two players"
"    involved have completed any for-the-record games, the win/loss record"
"    between them.  If no arguments are specified, you must have specified a"
"    default game with the \"game\" command, and that game is used.  If one"
"    player name is specified, your game with that player is shown.  If two"
"    player names are specified, the game between them is shown.  In any"
"    case, if no game is in progress between the two players in question,"
"    a message to that effect is printed, and nothing else is shown."
;
: help-info-resign
"resign [<player>]"
"    Resign in your game with the named player.  If no player name is"
"    specified, you must have specified a default game with the \"game\""
"    command, and that game is used.  It has to be your move in the game,"
"    and a confirmation is required."
;
: help-info-cmdstats
"cmdstats show"
"cmdstats clear"
"    [This command works only for the program's owner.]"
"    Shows, or clears, the statistics that are kept about how which commands"
"    are used and how often."
;
: help-info-games
"games"
"    List all games you have in progress."
;
: help-info-move
"move       - make a move in a game"
"move [<player>] <col> <row>"
"    Makes a move in a game.  Your piece is placed at column col, row row"
"    (columns are named by letters A-T, rows by numbers 1-20).  If move"
"    confirmation is set (see the \"set move\" command), the board as it"
"    would appear near the new move is printed and you are asked for"
"    confirmation; if not, the move is made without confirmation.  If the"
"    move does not win or tie the game, it becomes the other player's turn,"
"    and if that player is in the same room as you, a notification of this"
"    fact is sent.  The game is your game with player; if no player name is"
"    specified, you must have specified a default game with the \"game\""
"    command, and that game is used.  Whitespace between the column and row"
"    is accepted but optional."
;
(
        check
                List all offers currently extended to you, and any games you
                have in progress in which it is your move.
        record [player]
                Show your [or player's] wins/losses record against various
                opponents.
        ladder
                Show the competition ladder.
        toadsweep
                [This command works only for a wizard.]
                Does a sweep to find any players who were toaded with things
                in progress, and cleans up after them.  This happens
                automatically and incrementally to an extent, but if [for
                example] two players have a game in progress between them,
                and they are both toaded without the later-toaded one
                touching the game in between, the game will not be swept up
                until a toadsweep is done.
)
: help-info-check
"check      - check if you have anything to do"
"[no documentation written yet]"
;
: help-info-ladder
"ladder     - show the game ladder"
"[no documentation written yet]"
;
: help-info-record
"record     - show someone's win/loss record"
"[no documentation written yet]"
;
: help-info-toadsweep
"toadsweep  - clean up after toaded players"
"[no documentation written yet]"
;
: help-rules-
"This command prints the rules for the game.  The rules are broken up into"
"pages, to keep each page small enough to fit in a single screen on most"
"displays.  The available pages are:"
" "
"basic    - An overall summary of the basic rules"
"examples - Some examples"
;
: help-rules-basic
"The game is played on a 20x20 board with pieces of two contrasting colors."
"(Your pieces are displayed as O, your opponents' as *.)  A move consists of"
"placing one of your pieces on any empty cell.  If your move brackets two of"
"your opponents pieces - O * * O - with no empty cells in between, then you"
"capture both of those pieces and remove them from the board.  (This can"
"occur in any of the eight orientations, orthogonal or diagonal, and a single"
"move can capture more than one pair of your opponent's pieces.)  In order"
"to win, you need to either (a) make five-in-a-row with your pieces or (b)"
"capture at least five pairs of your opponent's pieces.  It is theoretically"
"possible for the board to be filled with pieces without either player's"
"winning; since this essentially never happens in practice, the game takes"
"no notice of this condition, and if it happens, the player whose move it is"
"will have to resign."
;
: help-rules-examples
"A sample capture:"
". O . * O O .                        . O . * O O ."
". . * * O . . -> if you play         . . . * O . ."
". . O * . . .    on the <.> space -> . . O . . . ."
". . * .<.>. .                        . . * . O . ."
" "
"A sample of two captures on the same move:"
". .<.>* * O .                        . . O . . O ."
". . * O O . . -> if you play         . . . O O . ."
". . * * . . .    on the <.> space -> . . . * . . ."
". . O . . . .                        . . O . . . ."
" "
"Note that you can play between your opponent's pieces without danger; it"
"is only the playing of one of the bracketing pieces that causes a capture:"
". O * O * . .                        . O * O * . ."
". . O O * . . -> if you play         . . O O * . ."
". .<.>* . . .    on the <.> space -> . . O * . . ."
". . * . . . .                        . . * . . . ."
;
$def wizflag "c"
$def 20-letters "ABCDEFGHJKLMNPQRSTUV"
$def 22-letters " ABCDEFGHJKLMNPQRSTUV "
: stripspace
	begin dup " " 1 strncmp not while 1 -1 substr loop
	begin dup -1 1 substr " " strcmp not while 0 -1 substr loop
;
: crackspace ( str -- rest cmd )
	( Cracks "str" at the first space, returning the part before the
	  space as "cmd" and the rest as "rest".  If there's no space,
	  cmd is str and rest is "".  rest will have had stripspace applied
	  to it. )
	" " explode1 if swap stripspace else "" then swap
;
$def prefix "| "
: pfxsayto prefix swap strcat notify ;
: pfxsay me @ swap pfxsayto ;
: pfxsayto-if-with-me ( to-player string-to-pfxsay )
	over location me @ location dbcmp if pfxsayto else pop pop then
;
: cmd-stats
	prog "_cmd-" rot strcat
	over over getpropstr atoi 1 + intostr addprop
;
: holder-dbref
	trigger @ "_holder" 0 getpropval dup if
		     dup string? if atoi dbref
		else dup dbref? not eif pop #-1
		then
	then
	dup if
		     trigger @ wizflag flag? if
		else dup owner trigger @ owner dbcmp eif
		else pop #-1
		then
	then
	dup not if pop trigger @ location then
;
: sort2 over over > if swap then ;
: game-prop-name ( player player -- propname )
	sort2 "-" -rot int intostr "-" rot int intostr "*game-" 5 "" implode
;
: turn-prop-name ( player player -- propname )
	sort2 "-" -rot int intostr "-" rot int intostr "*turn-" 5 "" implode
;
: offer-prop-name ( offering offered-to -- propname )
	"-" -rot int intostr "-" rot int intostr "*offer-" 5 "" implode
;
: set-prop-name ( player -- propname )
	int intostr "*set-" swap strcat
;
: def-prop-name ( player -- propname )
	int intostr "*def-" swap strcat
;
$def set-val-move     "m"
$def set-val-show     "s"
$def set-val-watch    "w"
$def set-val-autoshow "a"
: add-or-remove-prop dup if addprop else pop remove_prop then ;
: name-to-player ( s -- d 0  or  s -- 1 )
	"*" over strcat match dup player? not if
		pop "\"" swap "\" is not a valid player name!"
		3 "" rimplode pfxsay 1
	else
		swap pop 0
	then
;
: take-lock
	holder-dbref "*lock-" rot strcat 0 -rot
	begin
		( failcount dbref propname )
		over over me @ int intostr systime intostr 2 " " rimplode addprop-if
		dup int? if
			(We got the lock!)
			3 mpop
			lock-warn-count >= if "[Lock succeeded]" pfxsay then
			0 exit
		then
		( failcount dbref propname curvalue )
		dup " " rexplode1
		not if
			(prop exists, but wrong format?)
			pop 3 copy remprop-if pop pop continue
		then
		( failcount dbref propname curvalue holder timestamp )
		atoi systime swap - lock-timeout-time >= if
			(stale lock)
			pop 3 copy remprop-if pop pop continue
		then
		pop pop
		( failcount dbref propname )
		rot 1 +
		dup lock-yield-count <= if
			yield
		else
			dup lock-warn-count = if
				"[Waiting for lock, type x to abort]" pfxsay
			then
			"" 1 timed-prompt
			dup string? if "x" stringcmp not else pop 0 then
			if 3 mpop 1 exit then
		then
		-rot
	loop
;
: release-lock
	(This code assumes it cannot be called unless we hold the lock.)
	holder-dbref "*lock-" rot strcat remove_prop
;
: lock-games "games" take-lock ;
: unlock-games "games" release-lock ;
: lock-offers "offers" take-lock ;
: unlock-offers "offers" release-lock ;
: lock-games-noisy
	"games" take-lock if
		mpop "[Aborted.]" pfxsay 1
	else
		pop 0
	then
;
: lock-offers-noisy
	"offers" take-lock if
		mpop "[Aborted.]" pfxsay 1
	else
		pop 0
	then
;
: unify-game-type (s1 s2 -- s)
	over "r" instr over "r" instr and if pop pop "r" exit then
	over "f" instr over "f" instr and if pop pop "f" exit then
	pop pop ""
;
: verbose-game-type "r" strcmp if "fun" else "record" then ;
: pfxsay-watchers (otherplayer s -- )
	( says the string to everyone in me @ location, except that me @
	  and otherplayer are skipped. )
	holder-dbref me @ location contents
	begin dup while
		( otherplayer s dbr inroom )
		dup player? not if next continue then
		dup me @ dbcmp if next continue then
		dup 5 pick dbcmp if next continue then
		( otherplayer s dbr player )
		over over set-prop-name getpropstr set-val-watch instr
		if next continue then
		dup 4 pick pfxsayto
		next
	loop
	4 mpop
;
: announce-move (other mymove? -- )
	if
		"It is " me @ name me @ "'s move in %p game with " pronoun_sub
		4 pick name "." 5 "" rimplode
		"It is " me @ "'s move in %p game with you."
		pronoun_sub 2 me @ name rimplode
		"It is your move in your game with " "."
		2 6 pick name rimplode
	else
		"It is " over dup name swap "'s move in %p game with "
		pronoun_sub me @ name "." 5 "" rimplode
		"It is your move in your game with " "."
		2 me @ name rimplode
		"It is " 4 pick dup name swap "'s move in %p game with you."
		pronoun_sub 2 rot rimplode
	then
	( other 3rd 2nd 1st )
	pfxsay
	3 pick swap pfxsayto-if-with-me
	pfxsay-watchers
;
: start-a-game (other type -- )
	over me @ over over game-prop-name -rot turn-prop-name holder-dbref
	( other type tpn dbr )
	dup 3 pick getpropstr atoi
	dup not if pop random 1 & else 1 - then
	( other type gpn tpn dbr turnbit )
	over 4 rotate 2 4 pick - intostr addprop
	( other type gpn dbr turnbit )
	dup 5 rotate "f" strcmp if 2 + then 6 <<
	( other gpn dbr turnbit bits )
	itoq qtoa " 0 0 0 0 0 0 0 0 0 1806f 21a35 0 0 0 0 0 0 0 0 0" strcat
	rot 4 rotate rot addprop
	( other turnbit )
	over me @ sort2 rot if swap then pop me @ dbcmp
	announce-move
;
: int-to-base3 (10-tit-int -- base3string)
	1 9 1 for pop 3 /% intostr swap loop intostr 10 "" implode
;
: hex-to-base3 (hexstring -- base3string)
	atoq 59049 (3^10) /% swap int-to-base3 swap qtoi int-to-base3 strcat
;
: explode-game-prop (gst -- s1 ... s21 0  or  gst -- 1)
	" " rexplode
	dup 21 != if
		" " rimplode
		"Malformatted game property:" pfxsay
		pfxsay
		1
	else
		pop 0
	then
;
: implode-game-prop
	1 21 1 for pop
		21 rotate dup quad? if qtoa then
	loop
	21 " " rimplode
;
: rowstr
	dup 0 < if
		pop "  "
	else dup 19 > eif
		pop "  "
	else 1 + dup 10 < eif
		intostr " " swap strcat
	else
		intostr
	then
;
: show-game (holder name-1 name-2 1-on-top? game-state -- )
	over if 4 2 roll swap 4 2 roll then
	explode-game-prop if 4 mpop exit then
	0 19 1 for
		21 rotate hex-to-base3
		23 pick if " *" "1" " O" "2" else " *" "2" " O" "1" then
		" ." "0" 3 multisubst
		swap rowstr
		swap " " 3 pick 4 "" rimplode
	loop
	21 rotate atoq qtoi
	21 rotate "  *  " 24 rotate "  " 5 pick 26 pick if 3 else 0 then >> 7 &
	0 -1 for pop " OO" strcat loop 0 -3 substr 4 "" rimplode -21 rotate
	swap "  O  " 24 rotate "  " 5 pick 26 pick if 0 else 3 then >> 7 &
	0 -1 for pop " **" strcat loop 0 -3 substr 4 "" rimplode swap
	( holder 1-on-top? s1 ... s20 gamebits )
	dup 64 & 23 pick if not then if
		19 rotate "  [To move]" strcat -19 rotate
	else
		4 rotate "  [To move]" strcat -4 rotate
	then
	23 pick me @ set-prop-name getpropstr set-val-show instr if
		12 rotate "  [\"set show small\"" strcat -12 rotate
		11 rotate "   not yet implemented]" strcat -11 rotate
	then
	pop
	20-letters 1 explode 1 + "  " swap " " implode dup
	-22 rotate
	22 1 -1 for rotate pfxsay loop
	pop pop
;
: show-vs-me (holder other -- )
	dup me @ < if
		dup name "(you)" 1
	else
		"(you)" over name 0
	then
	4 rotate me @ game-prop-name 5 pick swap getpropstr
	dup if
		show-game
	else
		"You have no game in progress with " "!" 2 5 pick rimplode
		pfxsay 5 mpop
	then
;
: show-3rdparty (holder p1 p2 -- )
	over over < if
		over name -rot dup name 1 4 -2 roll
	else
		dup name -rot over name 0 4 -2 roll
	then
	( holder pAn pBn A-on-top? p1 p2 )
	game-prop-name 5 pick swap getpropstr
	dup if
		show-game
	else
		5 mpop "No such game in progress!" pfxsay
	then
;
: default-opponent
	(x1 ... xN holder N -- x1 ... xN holder player 0
	 x1 ... xN holder N -- 1)
	over me @ def-prop-name getpropstr
	dup not if
"You have no default game set, so you must specify an opponent."
		pfxsay pop mpop pop 1
	else
		atoi dbref swap pop 0
	then
;
: get-turn (statestr -- turnbit)
	" " explode1 if swap pop then
	atoq qtoi 6 >> 1 &
;
: get-for-record (statestr -- turnbit)
	" " explode1 if swap pop then
	atoq qtoi 7 >> 1 &
;
: lose-game-vs (opponent -- )
	pop (XXX)
;
: crack-position (s -- c r 0  or  s -- 1)
	1 strcut atoi
	dup 1 < over 20 > or if
		"Invalid column number, must be 1-20." pfxsay pop pop 1 exit
	then
	20-letters rot instring dup not if
		"Invalid row letter, must be one of " "."
		2 20-letters rimplode pfxsay pop pop 1 exit
	then
	1 - swap 1 - 0
;
: limit-offboard (n -- n)
	dup -1 < if pop -1 else dup 20 > eif pop 20 then
;
: pickqcol (rowquad colno -- val)
	19 swap - swap
	over 16 & if 43046721 (3^16) / then
	over 8 & if 6561 (3^8) / then
	over 4 & if 81 (3^4) / then
	over 2 & if 9 (3^2) / then
	swap 1 & if 3 (3^1) / then
	3 % qtoi
;
: print-sub-board (gst 1-on-top? cmark rmark rmin rmax cmin cmax -- )
	(rmin/cmin may be as small as -1; rmax/cmax may be as large as 20)
	8 rotate explode-game-prop if 7 mpop exit then 28 21 roll
	( gstv rv1 ... rv20 1-on-top? cmark rmark rmin rmax cmin cmax )
	4 copy "" "  " 4 2 roll 1 for
		( ... rmin rmax blankrow letrow c )
		rot " ~" strcat -rot 1 + 22-letters swap 1 substr " " swap
		3 "" rimplode
	loop
	( ... rmin rmax blankrow letrow )
	0 -rot 5 3 roll 1 for
		rowstr 3 pick " " 3 pick 4 "" rimplode 4 rotate 1 + 4 2 roll
	loop swap pop
	( gstv rv1 ... rv20 1top? cm rm rmin rmax cmin cmax t1 ... tN N tlet )
	over 30 + -28 roll
	( t1 ... tN N tlet gstv rv1 ... rv20 1top? cm rm rmin rmax cmin cmax )
	4 pick 4 pick 1 for
		( ... rmin rmax cmin cmax r )
		4 pick over - 32 + rotate
		( ... rmin rmax cmin cmax r tx )
		4 pick 4 pick 1 for
			( ... rmin rmax cmin cmax r tx c )
			swap "~" explode1 pop rot
			( ... rmin rmax cmin cmax r txpost txpre c )
			dup 0 < over 19 > or
			5 pick dup 0 < swap 19 > or
			( ... rmin rmax cmin cmax r txpost txpre c cout? rout? )
			if if "+" else "-" then else if "|" else
				31 5 pick - pick atoq over pickqcol
				12 pick if ".*O" else ".O*" then swap 1 substr
			then then
			( ... cm rm rmin rmax cmin cmax r txpost txpre c cc )
			over 12 pick = if 5 pick 11 pick = else 0 then
			if
				rot 0 -1 substr "<" rot ">"
				6 rotate 1 -1 substr 5 "" rimplode swap pop
			else
				swap pop 2 swap implode
			then
		loop
		over 6 pick - 32 - rotate
		pop
	loop
	( t1 ... tN N tlet gstv rv1 ... rv20 1top? cm rm rmin rmax cmin cmax )
	28 mpop
	( t1 ... tN tlet N )
	dup pfxsay swap
	begin dup 0 > while dup 2 + rotate pfxsay 1 - loop
	pop pfxsay
;
: confirm-move (hdp opp col row gstate -- hdp opp col row gstate 0
				or
		hdp opp col row gstate -- 1)
	3 copy -rot 7 pick me @ < -rot 2 copy
	dup conf-size - limit-offboard -rot conf-size + limit-offboard swap
	dup conf-size - limit-offboard swap conf-size + limit-offboard
	print-sub-board
	begin
		prefix "Is this the cell you wish to move on? " strcat prompt
		stripspace
		dup if break then pop
	loop
	0 1 substr "y" stringcmp if
		5 mpop 1
	else
		0
	then
;
: check-legal-move (col row gstate -- 0/1)
	explode-game-prop if pop pop 1 exit then
	20 23 rotate - rotate -21 rotate 20 mpop atoq swap pickqcol if
		"That cell is already occupied." pfxsay 1
	else
		0
	then
;
: 3^
	1
	over 16 & if 43046721 (3^16) * then
	over 8 & if 6561 (3^8) * then
	over 4 & if 81 (3^4) * then
	over 2 & if 9 (3^2) * then
	swap 1 & if 3 (3^1) * then
;
: set-cell (r0 ... r19 C R new-val -- r0 ... r19)
	23 3 roll 20 19 24 pick - roll
	( C R newval rR+1 ... r19 r0 ... rR-1 rR )
	( can't use /% for first op'n 'cause /% always uses an integer
	  for the quotient, which risks overflow if C is 19. )
	dup string? if atoq then 19 24 pick - 3^ swap over over over / -rot %
	( C R newval rR+1 ... r19 r0 ... rR-1 3^[19-C] rRh rRl )
	swap 3 / 3 * 23 rotate + rot * +
	( C R rR+1 ... r19 r0 ... rR-1 rRnew )
	20 23 -2 roll swap pop 19 - roll
	( r0 ... rR-1 rRnew rR+1 ... r19 )
;
: capture-combo? (n1 n2 n3 n4 -- 0/1)
	4 pick != if 3 mpop 0 exit then
	over = != if pop pop 0 exit then
	+ 3 =
;
: do-captures (r0 ... rR-1 rRnew rR+1 ... r19 C R stv -- [same])
	23 copy pop 0 0 0 0 0 0 28 4 roll 5 3 roll
	( [args] 0 0 0 r0 ... r19 0 0 0 C R )
	2 copy 23 over - 2 roll 20 swap - mpop
	( [args] 0 0 0 r0 ... rR rR+1 rR+2 rR+3 C R )
	dup -10 rotate dup 10 + 9 roll mpop pop -8 rotate
	( [args] C rR-3 rR-2 rR-1 rR rR+1 rR+2 rR+3 )
	1 7 1 for pop 7 rotate dup string? if atoq then 27 * loop
	19 9 rotate - 3^
	1 7 1 for pop
		8 rotate over / 2187 % dup quad? if qtoi then swap
	loop pop 0
	( [args] r'0 r'1 r'2 r'3 r'4 r'5 r'6 ncaptures )
	5 pick 81 % 27 /% 9 /% 3 /% capture-combo? if
		5 rotate 27 /% 3 % swap 27 * + -5 rotate
		1 +
	then
	5 pick 27 / 27 /% 9 /% 3 /% capture-combo? if
		5 rotate 27 /% swap 3 % 756 (27*28) * + -5 rotate
		1 +
	then
	{
		( r'a r'b r'c r'd ncaptures -- [same] )
	}
	( [args] r'0 r'1 r'2 r'3 r'4 r'5 r'6 ncaptures code )
	dup -7 rotate exec
	( [args] r'0 r'1 r'2 code r'3 r'4 r'5 r'6 ncaptures )
	5 rotate 7 rotate 8 rotate 9 rotate 5 rotate 9 rotate exec
	( [args] r'4 r'5 r'6 r'3 r'2 r'1 r'0 ncaptures )
	dup not if 8 mpop exit then
	( [args] r'4 r'5 r'6 r'3 r'2 r'1 r'0 ncaptures )
	XXX
;
: make-move (dbr opp col row gstate -- [same])
	explode-game-prop if 4 mpop exit then
	( dbr opp C R stvs r0 ... r19 )
	24 pick me @ < -21 rotate
	( dbr opp C R stvs 2's-move? r0 ... r19 )
	24 pick 24 pick 23 rotate if 2 else 1 then
	( dbr opp C R stvs r0 ... r19 C R new-cell )
	set-cell
	( dbr opp C R stvs r0 ... r19 )
	23 -3 roll atoq
	( dbr opp r0 ... r19 C R stv )
	do-captures
	( dbr opp r0 ... r19 C R stv )
	qtoa 23 3 roll implode-game-prop
	( dbr opp col row newgstate )
;
: do-help
	pop "help" cmd-stats
	0 swap
	     dup                       not  if help-info-
	else dup "move"      stringcmp not eif help-info-move
	else dup "show"      stringcmp not eif help-info-show
	else dup "check"     stringcmp not eif help-info-check
	else dup "offer"     stringcmp not eif help-info-offer
	else dup "retract"   stringcmp not eif help-info-retract
	else dup "accept"    stringcmp not eif help-info-accept
	else dup "decline"   stringcmp not eif help-info-decline
	else dup "ladder"    stringcmp not eif help-info-ladder
	else dup "help"      stringcmp not eif help-info-help
	else dup "rules"     stringcmp not eif help-info-rules
	else dup "games"     stringcmp not eif help-info-games
	else dup "offers"    stringcmp not eif help-info-offers
	else dup "record"    stringcmp not eif help-info-record
	else dup "game"      stringcmp not eif help-info-game
	else dup "resign"    stringcmp not eif help-info-resign
	else dup "set"       stringcmp not eif help-info-set
	else dup "set move"     stringcmp not eif help-info-set-move
	else dup "set show"     stringcmp not eif help-info-set-show
	else dup "set watch"    stringcmp not eif help-info-set-watch
	else dup "set autoshow" stringcmp not eif help-info-set-autoshow
	else dup "toadsweep" stringcmp not eif help-info-toadsweep
	else dup "cmdstats"  stringcmp not eif help-info-cmdstats
	else "Unrecognized help keyword `" over "'." 3 "" rimplode
	then
	-1 begin 1 + dup 3 + pick int? until
	begin
		1 - dup 2 + pick
	    dup string? while
		pfxsay
	loop
	pop pop begin int? until
;
: do-offer
	cmd-stats
	dup not if
		"Usage: offer <player-name> [{fun|record}]" pfxsay exit
	then
	crackspace
	name-to-player if pop exit then
	dup me @ dbcmp if
		pop pop "Playing games with yourself doesn't work." pfxsay exit
	then
	swap
	( other-player optarg )
	     dup "fun"    strcmp not  if pop "f"
	else dup "record" strcmp not eif pop "r"
	else dup                 not eif pop "rf"
	else
		pop pop
		"Optional argument must be `fun' or `record'"
		pfxsay exit
	then
	holder-dbref
	( other-player offer-types holder-dbref )
	3 lock-games-noisy if exit then
	dup me @ 5 pick game-prop-name getpropstr unlock-games
	if
		pop pop
		"You already have a game in progress with "
		swap name "!" 3 "" rimplode pfxsay exit
	then
	( other-player offer-types holder-dbref )
	3 lock-offers-noisy if exit then
	me @ 4 pick offer-prop-name rot addprop
	unlock-offers
	"You extend an offer of a game of pente to " over name "."
	3 "" rimplode pfxsay
	me @ name " offers to play a game of pente with you." strcat
	pfxsayto-if-with-me
;
: do-retract
	cmd-stats
	dup not if
		"Usage: retract <player-name>" pfxsay exit
	then
	name-to-player if exit then
	holder-dbref
	2 lock-offers-noisy if exit then
	me @ 3 pick offer-prop-name
	over over prop-exists? if
		remove_prop "You retract your offer to "
	else
		pop pop "You have no offer outstanding to "
	then
	unlock-offers
	swap name "." 3 "" rimplode pfxsay
;
: do-decline
	cmd-stats
	dup not if
		pop "Usage: decline <player-name>" pfxsay exit
	then
	name-to-player if exit then
	holder-dbref
	2 lock-offers-noisy if exit then
	over me @ offer-prop-name
	over over prop-exists? if
		remove_prop "You decline " "'s offer."
	else
		pop pop "" " has no offer outstanding to you."
	then
	unlock-offers
	3 pick name swap 3 "" rimplode pfxsay
	me @ name " declines your offer of a game of pente." strcat
	pfxsayto-if-with-me
;
: do-offers
	cmd-stats
	if "Usage: offers" pfxsay exit then
	0
	1 lock-offers-noisy if exit then
	holder-dbref "-" dup 2 me @ int intostr rimplode
	over propfirst
	begin while
		( sN ... s2 s1 N dbr -me- plt pn )
		dup "*offer-" 7 stringncmp if
			pop 0
		else dup 4 pick instr not eif
			pop 0
		else
			"-" explode dup 4 != if
				(malformatted *offer prop!)
				"-" implode "m" 1
			else
				pop pop rot pop
				dup atoi dbref me @ dbcmp if
					pop ">"
				else
					swap pop "<"
				then
				1
			then
		then
		if
			( sN ... s2 s1 N dbr -me- plt new-str new-tag )
			swap strcat 5 rotate 1 + 5 2 roll
			( sN ... s2 s1 new-s1 N+1 dbr -me- plt )
		then
		propnext
	loop
	( sN ... s2 s1 N dbr -me- )
	pop
	unlock-offers 1
	begin 3 pick 0 > while
		( sN ... s2 s1 N dbr none? )
		rot 1 - -rot 4 rotate 1 strcut swap
		( sN ... s2 N-1 dbr none? s1-str s1-tag )
		     dup "m" strcmp not if
			pop 3 pick swap remove_prop 0
		else dup ">" strcmp not eif
			pop "You have an offer outstanding to " "" 1
		else dup "<" strcmp not eif
			pop "" " has an offer outstanding to you" 1
		else
			"Internal error: bad tag " swap strcat pfxsay pop 0
		then
		if
			rot atoi dbref name swap "." 4 "" rimplode pfxsay
			pop 0
		then
	loop
	( 0 dbr none? )
	if "[None.]" pfxsay then pop pop
;
: do-set
	cmd-stats
	dup not if
		"Usage: set <setting> <value>" pfxsay exit
	then
	crackspace
	     dup "move"     strcmp not  if set-val-move "noconfirm" "confirm"
	else dup "show"     strcmp not eif set-val-show "big" "small"
	else dup "watch"    strcmp not eif set-val-watch "yes" "no"
	else dup "autoshow" strcmp not eif set-val-autoshow "no" "yes"
	else
		"Unrecognized setting `" swap "'!" 3 "" rimplode pfxsay exit
	then
	( value setting letter defval nondefval )
	dup 6 pick strcmp not if
		1 0
	else over 6 pick strcmp not eif
		0 0
	else 5 pick not eif
		"Missing value for `set " 5 pick "'!" 3 1
	else
		"Unrecognized `set " 5 pick "' value `" 8 pick "'!" 5 1
	then
	if "" rimplode pfxsay 5 mpop exit then
	( val set let defv ndefv nondef? )
	6 -2 roll 5 -2 roll 4 mpop
	holder-dbref
	me @ set-prop-name
	over over getpropstr 5 -2 roll
	( holder propname oldval letter nondef? )
	if over over instr if pop else strcat then else "" swap subst then
	( holder propname newval )
	add-or-remove-prop "Set." pfxsay
;
: do-accept
	cmd-stats
	dup not if
		pop "Usage: accept <player-name> [fun|record]" pfxsay exit
	then
	crackspace
	name-to-player if pop exit then
	swap
	( other-player optarg )
	     dup "fun"    strcmp not  if pop "f"
	else dup "record" strcmp not eif pop "r"
	else dup                 not eif pop "rf"
	else
		pop pop
		"Optional argument must be `fun' or `record'."
		pfxsay exit
	then
	holder-dbref
	( other-player offer-types holder-dbref )
	3 lock-offers-noisy if exit then
	3 pick me @ offer-prop-name
	over over prop-exists? if
		( other oft dbr pn )
		over over getpropstr 4 pick unify-game-type
		( other oft dbr pn gt )
		dup not if
			pop over over getpropstr verbose-game-type
			( other oft dbr pn vgt )
			5 pick name "'s offer specifies `"
			rot "' only." 4 "" rimplode pfxsay
			( other oft dbr pn )
		else
			3 copy pop remove_prop
			"You accept " "'s offer." 2 8 pick name rimplode
			pfxsay
			5 pick me @ name
			" accepts your offer of a game of pente." strcat
			pfxsayto-if-with-me
			5 pick me @ name " accepts " 3 pick name
			"'s offer of a game of pente." 4 "" rimplode
			pfxsay-watchers
			5 lock-games-noisy if unlock-offers exit then
			5 pick 3 pick start-a-game
			unlock-games
			pop
			( other oft dbr pn )
		then
	else
		4 pick name " has no offer outstanding to you." strcat pfxsay
	then
	unlock-offers
	4 mpop
;
: do-game
	cmd-stats
	dup if name-to-player if exit then int intostr then
	holder-dbref me @ def-prop-name 3 pick add-or-remove-prop
	if "Set." else "Unset." then pfxsay
;
: do-show
	cmd-stats
	holder-dbref swap
	dup not if
		pop 0 default-opponent if exit then
		show-vs-me
	else
		crackspace
		name-to-player if pop pop exit then
		swap dup if
			name-to-player if pop pop exit then show-3rdparty
		else
			pop show-vs-me
		then
	then
;
: do-resign
	cmd-stats
	holder-dbref swap
	dup if
		name-to-player if pop exit then
	else
		pop 0 default-opponent if exit then
	then
	( holder opponent )
	2 lock-games-noisy if exit then
	over over me @ game-prop-name getpropstr
	dup not if
		pop "You have no game in progress with " "!"
		2 4 rotate name rimplode pfxsay pop
	else over me @ < over get-turn if not then eif
		3 mpop "It's not your turn!" pfxsay
	else
		get-for-record if dup lose-game-vs then
		( holder opponent )
		"You resign against " "." 2 4 pick name rimplode pfxsay
		dup me @ name " resigns against you." strcat
		pfxsayto-if-with-me
		dup me @ name " resigns against " 3 pick name "."
		4 "" rimplode pfxsay-watchers
		over over me @ game-prop-name remove_prop
		pop pop
	then
	unlock-games
;
: do-cmdstats
	pop me @ prog owner dbcmp not if
		pop "Permission denied." pfxsay exit
	then
	dup "show" strcmp not if
		pop prog propfirst
		begin while
			dup "_cmd-" 5 stringncmp not if
				prog over getpropstr swap 5 -5 substr
				2 ": " implode pfxsay
			else
				pop
			then
			propnext
		loop
		exit
	then
	dup "clear" strcmp not if
		pop 0 prog propfirst
		begin while
			dup "_cmd-" 5 stringncmp not if
				rot 1 + rot
			else
				pop
			then
			propnext
		loop
		begin dup while 1 - prog rot remove_prop loop pop exit
	then
	"Bad cmdstats subcommand `" "'." 2 4 rotate rimplode pfxsay
;
: do-games
	cmd-stats
	if "Usage: games" pfxsay exit then
	0
	1 lock-games-noisy if exit then
	holder-dbref "-" dup 2 me @ int intostr rimplode
	over propfirst
	begin while
		( sN ... s2 s1 N dbr -me- plt pn )
		dup "*game-" 6 stringncmp if
			pop 0
		else dup 4 pick instr not eif
			pop 0
		else
			"-" explode dup 4 != if
				(malformatted *game prop!)
				"-" implode "m" 1
			else
				pop pop rot pop
				dup atoi dbref me @ dbcmp not if swap then
				pop "g" 1
			then
		then
		if
			( sN ... s2 s1 N dbr -me- plt new-str new-tag )
			swap strcat 5 rotate 1 + 5 2 roll
			( sN ... s2 s1 new-s1 N+1 dbr -me- plt )
		then
		propnext
	loop
	( sN ... s2 s1 N dbr -me- )
	pop
	unlock-games 1
	begin 3 pick 0 > while
		( sN ... s2 s1 N dbr none? )
		rot 1 - -rot 4 rotate 1 strcut swap
		( sN ... s2 N-1 dbr none? s1-str s1-tag )
		     dup "m" strcmp not if
			pop 3 pick swap remove_prop 0
		else dup "g" strcmp not eif
			pop 1
		else
			"Internal error: bad tag " swap strcat pfxsay pop 0
		then
		if
			"You have a game in progress with " "."
			2 4 rotate atoi dbref name rimplode pfxsay
			pop 0
		then
	loop
	( 0 dbr none? )
	if "[None.]" pfxsay then pop pop
;
: do-rules
	cmd-stats
	0 swap
	     dup                       not  if help-rules-
	else dup "basic"     stringcmp not eif help-rules-basic
	else dup "examples"  stringcmp not eif help-rules-examples
	else "Unrecognized rules page `" over "'." 3 "" rimplode
	then
	-1 begin 1 + dup 3 + pick int? until
	begin
		1 - dup 2 + pick
	    dup string? while
		pfxsay
	loop
	pop pop begin int? until
;
: do-move
	cmd-stats
	( Arg can be:
		- one arg: <row><col>
		- two args: <row> <col>
		- two args: <player> <row><col>
		- three args: <player> <row> <col>
	  Dealing with this is a bit messy.  One and three args are easy.
	  If we get two args, we say that if the first arg is exactly one
	  row letter, and the second begins with a digit, it's <row> <col>,
	  otherwise we treat it as <player> <row><col>. )
	crackspace swap crackspace
	( arg1 arg3 arg2 )
	over if
		( Three args.  Paste the second two back together. )
		swap strcat
	else dup eif
		( Two, but not three, args.  Hard case - see above. )
		swap pop
		begin (just a block, not really a loop)
			dup 0 1 substr "0123456789" swap instr while
			( Second arg begins with a digit )
			over strlen 1 = while
			( First arg one char long )
			over 20-letters swap instring while
			( <row> <col> form )
			strcat "" swap break
		loop
	else
		( One arg. )
		pop swap
	then
	( <player>-or-"" <row><col> )
	over if
		swap name-to-player if pop exit then
		holder-dbref swap
	else
		holder-dbref 2 default-opponent if exit then
		4 rotate pop
	then
	( rc dbr opp )
	rot crack-position if pop pop exit then
	( dbr opp col row )
	4 pick 4 pick me @ game-prop-name getpropstr
	( dbr opp col row gamestr )
	dup not if
		"You have no game in progress with " "!"
		2 7 rotate name rimplode pfxsay 4 mpop
	else 4 pick me @ < over get-turn if not then eif
		5 mpop "It's not your turn!" pfxsay
	else
depth "dbr opp col row gst" pstack
		3 copy check-legal-move if 5 mpop exit then
		5 pick me @ set-prop-name getpropstr set-val-move instr if
			confirm-move if exit then
		then
		make-move
depth "h o c r s" pstack
		5 pick 5 pick me @ game-prop-name rot addprop
		rowstr 20-letters rot 1 substr swap strcat "" " " subst
		( dbr opp cellstr )
depth "h o cs #1" pstack
		me @ name " moves at " 3 pick me @ " in %p game with "
		pronoun_sub 6 pick name "." 6 "" rimplode
		3 pick swap pfxsay-watchers
		( dbr opp cellstr )
depth "h o cs #2" pstack
		me @ name " moves at " 3 pick me @ " in %p game with you."
		pronoun_sub 4 "" rimplode 3 pick swap pfxsayto-if-with-me
		( dbr opp cellstr )
depth "h o cs #3" pstack
		over 0 announce-move
depth "h o cs #4" pstack
		over location me @ location dbcmp if
			3 copy pop set-prop-name getpropstr set-val-autoshow instr
		else 0 then if
			me @ 4 pick over 5 pick me ! show-vs-me me !
		then
depth "h o cs #5" pstack
		3 mpop
	then
;
: do-check
	cmd-stats
	pop "[Not yet implemented.]" pfxsay
;
: do-ladder
	cmd-stats
	pop "[Not yet implemented.]" pfxsay
;
: do-record
	cmd-stats
	pop "[Not yet implemented.]" pfxsay
;
: do-toadsweep
	cmd-stats
	pop "[Not yet implemented.]" pfxsay
;
: realmain
	stripspace
	trigger @ "_action" getpropstr
	dup "prefix" strcmp not if
		pop crackspace
		dup not if pop "?" then
	then
	dup not if
		pop trigger @ name
		";" explode1 if swap pop then
	then
	dup "move" strcmp not if do-move exit then
	dup "show" strcmp not if do-show exit then
	dup "check" strcmp not if do-check exit then
	dup "offer" strcmp not if do-offer exit then
	dup "retract" strcmp not if do-retract exit then
	dup "accept" strcmp not if do-accept exit then
	dup "decline" strcmp not if do-decline exit then
	dup "ladder" strcmp not if do-ladder exit then
	dup "rules" strcmp not if do-rules exit then
	dup "?" strcmp not if do-help exit then
	dup "help" strcmp not if do-help exit then
	dup "games" strcmp not if do-games exit then
	dup "offers" strcmp not if do-offers exit then
	dup "record" strcmp not if do-record exit then
	dup "game" strcmp not if do-game exit then
	dup "resign" strcmp not if do-resign exit then
	dup "set" strcmp not if do-set exit then
	dup "rules" strcmp not if do-rules exit then
	dup "toadsweep" strcmp not if do-toadsweep exit then
	dup "cmdstats" strcmp not if do-cmdstats exit then
	"Unrecognized command `" "'." 2 4 rotate rimplode pfxsay pop
;
: main
	depth 1 - dup 2 + neg rotate
	realmain
(prog "d" set)
	depth not if
		me @ "Internal error: stack underflow" notify
	else
		depth rotate dup depth 2 - != if
			me @ "Internal error: stack trash left" notify
			depth pstack
			begin
				swap pop
				dup depth 2 - != while
			loop
		then
	then
(prog "!d" set)
;
.
c
q