|
DataMuseum.dkPresents historical artifacts from the history of: DKUUG/EUUG Conference tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DKUUG/EUUG Conference tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: T g
Length: 26299 (0x66bb)
Types: TextFile
Names: »go.pas«
└─⟦b20c6495f⟧ Bits:30007238 EUUGD18: Wien-båndet, efterår 1987
└─⟦this⟧ »EUUGD18/General/GoBoard/go.pas«
{---------------------------------------------------------------}
{ Go Game Manager }
{ Copyright (c) 1982 by Three Rivers Computer Corp. }
{ }
{ Written: June 3, 1982 by Stoney Ballard }
{ Edit History: }
{ June 3, 1982 Started }
{ June 4, 1982 Add dead group removal }
{ June 10, 1982 Use new go file manager }
{ Nov 10, 1982 Extensively Hacked Up }
{ Dec 29, 1982 Changed "Erase Branch" to "Prune Branches" }
{ Jan 6, 1983 Added ^C escape from all readlns }
{---------------------------------------------------------------}
program Go;
exports
imports stream from stream;
procedure resetInput;
private
imports system from System;
imports raster from raster;
imports screen from screen;
imports popUp from popUp;
imports IO_Others from IO_Others;
imports goCom from goCom;
imports goMgr from goMgr;
imports goTree from goTree;
imports goBoard from goBoard;
imports goMenu from goMenu;
imports memory from memory;
imports perq_string from perq_string;
imports goPlayer from goPlayer;
label
99; (* the fatal error point *)
var
oCurPosX, oCurPosY: integer;
oScreenPtr: rasterPtr;
procedure resetInput;
begin { resetInput }
streamKeyboardReset(input);
end { resetInput };
procedure newTitle;
var
ts: string[128];
fn: string;
fl, fPos, tPos, i: integer;
begin { newTitle }
ts := 'Go Version ';
ts := concat(ts, version);
getFNameString(fn);
fl := length(fn);
if fl > 0 then
begin
fPos := 81 - fl;
tPos := length(ts) + 1;
adjust(ts, 80);
for i := tPos to 80 do
ts[i] := ' ';
for i := fPos to fPos + fl - 1 do
ts[i] := fn[i - fPos + 1];
end;
changeTitle(ts);
end { newTitle };
procedure initialize;
var
sseg: integer;
procedure setupWindows;
var
ts: string;
begin { setupWindows }
createWindow(boardWin, bWinX, bWinY, bWinW, bWinH, ' ');
createWindow(menuWin, mWinX, mWinY, mWinW, mWinH, '');
createWindow(statWin, sWinX, sWinY, sWinW, sWinH, '');
changeWindow(0);
gameFName := '';
newTitle;
end { setupWindows };
begin { initialize }
createSegment(sseg, 192, 1, 192);
oScreenPtr := makePtr(sseg, 0, rasterPtr);
SReadCursor(oCurPosX, oCurPosY);
rasterop(rRpl, 768, 1024, 0, 0, SScreenW, oScreenPtr,
0, 0, SScreenW, SScreenP);
IOSetFunction(CTCursCompl);
rasterop(RAndNot, 768, 1024, 0, 0, SScreenW, SScreenP,
0, 0, SScreenW, SScreenP);
setupWindows;
initMenu;
captures[black] := 0;
captures[white] := 0;
initGoTree;
initGoBoard;
makeGoTree;
initGoMgr;
gameFName := '';
numbEnabled := false;
treeDirty := false;
playLevel := 0;
debug := false;
printLarge := true;
initGoPlayer;
end { initialize };
procedure doit;
var
done, foundIt, endLoop, gbg: boolean;
CtlCseen, playMyself, lastWasPass: boolean;
whoseTurn, whoWasLast: sType;
i, xi, yi, xs, ys: integer;
numDead, numHC, cmd: integer;
lastBuM: integer;
thisTag: tagPtr;
lastMove: pMRec;
function getLine(var l: string): boolean;
label
1;
var
i, j, cx, cy: integer;
handler ctlC;
begin { ctlC }
IOKeyClear;
streamKeyboardReset(input);
beep(error);
prompt('');
l := '';
getLine := false;
exit(getLine);
end { ctlC };
handler pastEOF(fn: pathName);
begin { pastEOF }
reset(input, fn);
sSetCursor(cx, cy);
write(' ');
sSetCursor(cx, cy);
goto 1;
end { pastEOF };
begin { getLine }
sReadCursor(cx, cy);
1:
readln(l);
getLine := true;
j := 0;
for i := 1 to length(l) do
if ord(l[i]) >= 32 then
begin
j := j + 1;
l[j] := l[i];
end;
adjust(l, j);
end { getLine };
procedure resetGame;
begin { resetGame }
clearBoard;
koX := -1;
koY := -1;
moveNum := 0;
curMove := treeRoot;
captures[black] := 0;
captures[white] := 0;
showCaptures;
whoseTurn := black;
turnIs(black);
gameFname := '';
newTitle;
gameOver := false;
initGoMgr;
end { resetGame };
procedure switchWho;
begin { switchWho }
if curMove = treeRoot then
whoseTurn := black
else if curMove^.id = remove then
whoseTurn := curMove^.who
else if curMove^.id = hcPlay then
whoseTurn := white
else if curMove^.who = black then
whoseTurn := white
else
whoseTurn := black;
turnIs(whoseTurn);
end { switchWho };
procedure updateStatus;
begin { updateStatus }
dotLast;
showCaptures;
showComment;
showTag;
switchWho;
end { updateStatus };
procedure doReadGame;
var
fName: pathName;
handler badFileVersion;
begin { badFileVersion }
beep(error);
prompt('');
write(gameFName, ' is not compatable with this version of GO');
resetGame;
exit(doReadGame);
end { badFileVersion };
begin { doReadGame }
if menuGoFile(fName) then
begin
prompt('Reading ');
write(fName, '.Go ...');
readTree(concat(fName, '.GO'));
resetGame;
gameFName := fName;
if treeRoot^.lastMove <> nil then
switchBranch(treeRoot^.lastMove);
treeDirty := false;
prompt('');
newTitle;
end;
end { doReadGame };
procedure doWriteGame;
var
fs: string;
procedure addExt(var nam: string);
var
es: string;
begin { addExt }
if length(nam) > 3 then
begin
es := substr(nam, length(nam) - 2, 3);
convUpper(es);
if es <> '.GO' then
nam := concat(nam, '.Go');
end
else
nam := concat(nam, '.Go');
end { addExt };
handler badGoWrite;
begin { badGoWrite };
beep(error);
prompt('Unable to write file ');
write(fs);
exit(doWriteGame);
end { badGoWrite };
begin { doWriteGame }
IOKeyClear;
streamKeyboardReset(input);
if gameFName <> '' then
begin
prompt('Game File Name [');
write(gameFName, ']? ');
end
else
prompt('Game File Name? ');
if not getLine(fs) then
exit(doWriteGame);
if fs = '' then
if gameFName = '' then
begin
beep(error);
prompt('');
exit(doWriteGame);
end
else
fs := gameFName;
gameFName := fs;
addExt(fs);
prompt('Writing ');
write(fs, ' ...');
writeTree(fs, curMove);
treeDirty := false;
prompt('');
newTitle;
end { doWriteGame };
function chooseAlt: boolean;
label
10;
var
bx, by, xs, ys: integer;
tm: pMRec;
hc0There: boolean;
hcMenu: pNameDesc;
res: resres;
numHC, i, j, numNHC: integer;
handler outside;
begin { outside }
destroyNameDesc(hcMenu);
chooseAlt := false;
beep(error);
restoreCursor;
exit(chooseAlt);
end { outside };
begin { chooseAlt }
chooseAlt := false;
switchWho;
waitNoButton;
tm := curMove^.flink;
numHC := 0;
numNHC := 0;
hc0There := false;
while tm <> nil do
begin
if tm^.id = hcPlay then
numHC := numHC + 1
else
begin
hc0There := true;
numNHC := numNHC + 1;
end;
tm := tm^.slink;
end;
if numHC > 0 then
begin
if hc0There then
numHC := numHC + 1;
allocNameDesc(numHC, 0, hcMenu);
hcMenu^.header := 'Handicap Alternates';
j := 1;
if hc0There then
begin
hcMenu^.commands[1] := '0';
j := 2;
end;
tm := curMove^.flink;
for i := j to numHC do
begin
while tm^.id <> hcPlay do
tm := tm^.slink;
{$R-}
hcMenu^.commands[i] := ' ';
hcMenu^.commands[i][1] := chr(tm^.hcNum + ord('0'));
{$R=}
tm := tm^.slink;
end;
menu(hcMenu, false, 1, numHC, -1, -1, -1, res);
restoreCursor;
destroyNameDesc(hcMenu);
i := res^.indices[1];
destroyRes(res);
if hc0There then
if i = 1 then
begin
if numNHC > 1 then
goto 10;
tm := curMove^.flink;
while tm^.id <> move do
tm := tm^.slink;
forwardTo(tm);
chooseAlt := true;
exit(chooseAlt);
end
else
i := i - 1;
tm := curMove^.flink;
j := 0;
repeat
while tm^.id <> hcPlay do
tm := tm^.slink;
j := j + 1;
if j <> i then
tm := tm^.slink;
until j = i;
forwardTo(tm);
chooseAlt := true;
end
else
begin
10:
showAlts;
waitButton;
if passLocCur(tabRelX, tabRelY) then
begin
if passIsAlt then
begin
selPass;
chooseAlt := true;
waitNoButton;
exit(chooseAlt);
end;
end
else if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
if board[bx][by].val = alternate then
begin
selAlt(bx, by);
chooseAlt := true;
waitNoButton;
exit(chooseAlt);
end;
remAlts;
beep(error);
end;
waitNoButton;
end { chooseAlt };
procedure mForward;
var
gbg: boolean;
begin { mForward }
if gameOver then
restoreDead;
if atLeaf(curMove) then
beep(error)
else if atBranch(curMove) then
gbg := chooseAlt
else
forwardTo(curMove^.flink);
end { mForward };
procedure doBkToS;
var
bx, by, sx, sy: integer;
begin { doBkToS }
prompt('Point at stone to backup to');
waitButton;
if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
if board[bx][by].val <> empty then
begin
while not lastPlayAt(bx, by) do
backup1;
exit(doBkToS);
end;
beep(error);
waitNoButton;
end { doBkToS };
procedure doPutTag;
var
ts: tagStr;
cm: pMRec;
begin { doPutTag }
if curMove = treeRoot then
beep(error)
else
begin
IOKeyClear;
streamKeyboardReset(input);
prompt('Tag String: ');
if not getLine(ts) then
exit(doPutTag);
if length(ts) > maxTagLen then
begin
beep(error);
prompt('Tags may be no longer than ');
write(maxTagLen:0, ' characters');
end
else if length(ts) = 0 then
begin
if curMove^.tag = nil then
begin
beep(error);
prompt('');
end
else
begin
delTag(curMove^.tag);
prompt('Tag Deleted');
end;
end
else if tagExists(ts) then
begin
beep(error);
prompt('That tag already exists');
end
else
begin
tagMove(curMove, ts);
end;
end;
end { doPutTag };
procedure doGoToTag;
var
thisTag: tagPtr;
begin { doGoToTag }
thisTag := getTagMenu;
if thisTag <> nil then
switchBranch(thisTag^.mPtr);
end { doGoToTag };
procedure doPutCmt;
var
cs, curCmt: string;
begin { doPutCmt }
IOKeyClear;
streamKeyboardReset(input);
prompt('Comment: ');
if not getLine(cs) then
exit(doPutCmt);
if length(cs) = 0 then
if getComment(curMove, curCmt) then
prompt('Comment Deleted')
else
begin
beep(error);
prompt('');
end;
commentMove(curMove, cs);
end { doPutCmt };
procedure doScore;
var
wScore, bScore, wr, br: integer;
done: boolean;
bx, by, xs, ys: integer;
begin { doScore }
putEnd;
done := false;
prompt('Point at dead groups, Press outside of board to stop');
repeat
waitButton;
if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
begin
if board[bx, by].val <> empty then
delGroup(bx, by);
end
else
done := true;
showCaptures;
waitNoButton;
until done;
prompt('Counting Score ...');
scoreGame(wScore, bScore);
wScore := wScore - captures[black];
bScore := bScore - captures[white];
if wScore < 0 then
begin
wr := -wScore;
wScore := 0;
end
else
wr := 0;
if bScore < 0 then
begin
br := -bScore;
bScore := 0;
end
else
br := 0;
bScore := bScore + wr;
wScore := wScore + br;
prompt('Score is: ');
write('White = ', wScore:0, ', Black = ', bScore:0);
if wScore = bScore then
write(' - A Tie!')
else if wScore > bScore then
write(' - White Wins by ', (wScore - bScore):0)
else
write(' - Black Wins by ', (bScore - wScore):0)
end { doScore };
procedure doEraseMove;
var
lm: pMRec;
begin { doEraseMove }
if gameOver then
restoreDead;
if curMove = treeRoot then
beep(error)
else
begin
lm := curMove;
backup1;
lm := delBranch(lm);
treeDirty := true;
end;
end { doEraseMove };
procedure doPruneBranches;
var
lm, sm, tm: pMRec;
tp: tagPtr;
didPrune: boolean;
begin { doPruneBranches }
if gameOver then
restoreDead;
if not isBranch(curMove) then
beep(error)
else if not confirmed then
beep(error)
else
begin
didPrune := false;
wipeTreeMarks;
lm := curMove;
while lm <> treeRoot do
begin
lm^.mark := true;
lm := lm^.blink;
end;
tp := treeRoot^.lastTag;
while tp <> nil do
begin
lm := tp^.mPtr;
while lm <> treeRoot do
begin
lm^.mark := true;
lm := lm^.blink;
end;
tp := tp^.nextTag;
end;
lm := curMove;
while lm <> treeRoot do
begin
if lm^.blink^.flink^.slink <> nil then
begin
sm := lm^.blink^.flink;
while sm <> nil do
if not sm^.mark then
begin
tm := sm;
sm := sm^.slink;
tm := delBranch(tm);
didPrune := true;
treeDirty := true;
end
else
sm := sm^.slink;
end;
lm := lm^.blink;
end;
if not didPrune then
prompt('All Branches Were Tagged');
end;
end { doPruneBranches };
handler ctlC;
begin { ctlC }
IOKeyClear;
CtlCseen := true;
end { ctlC };
begin { doit }
resetGame;
done := false;
lastMove := nil;
CtlCseen := false;
playMyself := false;
lastWasPass := false;
IOSetModeTablet(relTablet);
IOCursorMode(trackCursor);
activate(mReadFile, true);
activate(mTogNums, true);
activate(mQuit, true);
activate(mPutCmt, true);
activate(mAutoPlay, true);
activate(mPlayMyself, true);
activate(mSetPlayLevel, true);
activate(mDebug, true);
activate(mRefBoard, true);
activate(mShoState, true);
activate(mBoardSize, true);
repeat
if curMove <> lastMove then
checkAtari(curMove);
updateStatus;
lastMove := curMove;
if not playMyself then
begin
activate(mPrintBoard, curMove <> treeRoot);
activate(mPrintDiag, curMove <> treeRoot);
activate(mStepToTag, stepTagPossible);
activate(mSetStepTag, treeRoot^.lastTag <> nil);
activate(mGotoTag, treeRoot^.lastTag <> nil);
activate(mInit, treeRoot^.flink <> nil);
activate(mWriteFile, treeRoot^.flink <> nil);
activate(mSetHc, curMove = treeRoot);
activate(mPass, curMove <> treeRoot);
activate(mScore, curMove <> treeRoot);
activate(mForToBr, hasBranch(curMove));
activate(mBackToBr, isBranch(curMove));
activate(mBackToStone, curMove <> treeRoot);
activate(mForToLeaf, curMove^.flink <> nil);
activate(mPutTag, curMove <> treeRoot);
activate(mGotoRoot, curMove <> treeRoot);
activate(mEraseMove, curMove <> treeRoot);
activate(mPruneBranches, isBranch(curMove));
activate(mBackOne, curMove <> treeRoot);
activate(mForOne, curMove^.flink <> nil);
end;
if CtlCseen then
cmd := mCtlC
else if playMyself then
cmd := mAutoPlay
else
repeat
cmd := getMenuCmd;
until cmd <> none;
prompt('');
case cmd of
mCtlC:
begin
playMyself := false;
CtlCseen := false;
end;
mPlaceStone:
begin
if gameOver then
restoreDead;
if bLocCur(tabRelX, tabRelY, xi, yi, xs, ys) then
begin
if board[xi, yi].val <> empty then
beep(error)
else if (xi = koX) and (yi = koY) then
beep(koV)
else
doMove(whoseTurn, xi, yi, xs, ys);
end
else
beep(error);
waitNoButton;
end;
mAutoPlay:
begin
if gameOver then
restoreDead;
prompt('Thinking...');
if curMove = treeRoot then
lastWasPass := false
else
lastWasPass := curMove^.id = pass;
if playMove(whoseTurn, xi, yi) then
begin
if board[xi, yi].val <> empty then
begin
beep(error);
prompt('Bad move at ');
write((xi + 1):0, ', ', (yi + 1):0);
playMyself := false;
write(' - Generated by ', playreason);
end
else if (xi = koX) and (yi = koY) then
begin
beep(koV);
prompt('ko violation at ');
write((xi + 1):0, ', ', (yi + 1):0);
write(' - Generated by ', playreason);
playMyself := false;
end
else
begin
doMove(whoseTurn, xi, yi, 0, 0);
if board[xi, yi].val = empty then
begin
prompt('self kill at ');
write((xi + 1):0, ', ', (yi + 1):0);
write(' - Generated by ', playreason);
playMyself := false;
end
else
commentMove(curMove, playReason);
end;
end
else
begin
doPass(whoseTurn);
if lastWasPass then
playMyself := false;
end;
waitNoButton;
prompt('');
end;
mPlayMyself:
playMyself := true;
mSetPlayLevel:
menuPlayLevel(playLevel, maxPlayLevel);
mShoState:
showPlayState(whoseTurn);
mInit:
if confirmed then
begin
makeGoTree;
resetGame;
treeDirty := false;
end
else
beep(error);
mSetHc:
if moveNum = 0 then
begin
if gameOver then
restoreDead;
numHC := getHCMenu;
if numHC > 0 then
doHCPlay(numHC)
else
beep(error);
end
else
beep(error);
mPass:
begin
if gameOver then
restoreDead;
doPass(whoseTurn);
end;
mScore:
doScore;
mForToBr:
begin
if gameOver then
restoreDead;
if atLeaf(curMove) then
beep(error)
else if not atBranch(curMove) then
forwToBr;
if not atLeaf(curMove) then
gbg := chooseAlt;
end;
mBackToBr:
begin
if gameOver then
restoreDead;
if curMove = treeRoot then
beep(error)
else
backToBr;
if atBranch(curMove) then
gbg := chooseAlt;
end;
mBackToStone:
begin
if gameOver then
restoreDead;
if curMove = treeRoot then
beep(error)
else
doBkToS;
end;
mForToLeaf:
begin
if gameOver then
restoreDead;
if atLeaf(curMove) then
beep(error)
else
begin
endLoop := false;
repeat
if atLeaf(curMove) then
endLoop := true
else if atBranch(curMove) then
begin
if not chooseAlt then
begin
endLoop := true;
beep(error);
end;
end
else
forwToBr;
until endLoop;
end;
end;
mPutTag:
doPutTag;
mGotoTag:
doGoToTag;
mGotoRoot:
switchBranch(treeRoot);
mPutCmt:
doPutCmt;
mReadFile:
if confirmed then
doReadGame;
mWriteFile:
doWriteGame;
mEraseMove:
doEraseMove;
mPruneBranches:
doPruneBranches;
mTogNums:
if not numbEnabled then
begin
numbEnabled := true;
showAllStones;
dotSX := -1;
putMString(mTogNums, 'Erase Numbers');
end
else
begin
numbEnabled := false;
showAllStones;
dotSX := -1;
dotLast;
putMString(mTogNums, 'Show Stone Numbers');
end;
mDebug:
if debug then
begin
debug := false;
putMString(mDebug, 'Turn Debug On');
end
else
begin
debug := true;
putMString(mDebug, 'Turn Debug Off');
end;
mBoardSize:
begin
printLarge := not printLarge;
if printLarge then
begin
prompt('Will Print on Large Board Now');
putMString(mBoardSize, 'Use Small Board');
end
else
begin
prompt('Will Print on Small Board Now');
putMString(mBoardSize, 'Use Large Board');
end;
end;
mPrintBoard:
printBoard(false);
mPrintDiag:
printBoard(true);
mStepToTag:
begin
if gameOver then
restoreDead;
if stepTag = nil then
stepTag := getTagMenu;
if stepTag <> nil then
doStepTag
else
beep(error);
end;
mSetStepTag:
begin
thisTag := getTagMenu;
if thisTag <> nil then
stepTag := thisTag;
end;
mQuit:
if confirmed then
done := true;
mBackOne:
begin
if gameOver then
restoreDead
else if curMove = treeRoot then
beep(error)
else
backUp1;
end;
mForOne:
begin
if gameOver then
restoreDead;
mForward;
end;
mRefBoard:
refreshBoard;
end { case };
if not playMyself then
endCmd;
until done;
end { doit };
procedure cleanup;
begin { cleanup }
screenReset;
rasterOp(rRpl, 768, 1024, 0, 0, SScreenW, SScreenP,
0, 0, SScreenW, oScreenPtr);
SSetCursor(oCurPosX, oCurPosY);
end { cleanup };
handler ctlC;
begin { ctlC }
IOKeyClear;
end { ctlC };
begin { Go }
initialize;
doit;
99:
cleanUp;
end { Go }.