games-request@tekred.TEK.COM (03/10/88)
Submitted by: Fred Hansen <wjh+@andrew.cmu.edu>
Comp.sources.games: Volume 3, Issue 100
Archive-name: go/Part04
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 4 (of 5)."
# Contents: go.pas goMgr.pas
# Wrapped by billr@saab on Wed Mar 9 09:14:46 1988
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f go.pas -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"go.pas\"
else
echo shar: Extracting \"go.pas\" \(26299 characters\)
sed "s/^X//" >go.pas <<'END_OF_go.pas'
X{---------------------------------------------------------------}
X{ Go Game Manager }
X{ Copyright (c) 1982 by Three Rivers Computer Corp. }
X{ }
X{ Written: June 3, 1982 by Stoney Ballard }
X{ Edit History: }
X{ June 3, 1982 Started }
X{ June 4, 1982 Add dead group removal }
X{ June 10, 1982 Use new go file manager }
X{ Nov 10, 1982 Extensively Hacked Up }
X{ Dec 29, 1982 Changed "Erase Branch" to "Prune Branches" }
X{ Jan 6, 1983 Added ^C escape from all readlns }
X{---------------------------------------------------------------}
X
Xprogram Go;
X
Xexports
X
Ximports stream from stream;
X
Xprocedure resetInput;
X
Xprivate
X
Ximports system from System;
Ximports raster from raster;
Ximports screen from screen;
Ximports popUp from popUp;
Ximports IO_Others from IO_Others;
Ximports goCom from goCom;
Ximports goMgr from goMgr;
Ximports goTree from goTree;
Ximports goBoard from goBoard;
Ximports goMenu from goMenu;
Ximports memory from memory;
Ximports perq_string from perq_string;
Ximports goPlayer from goPlayer;
X
Xlabel
X 99; (* the fatal error point *)
X
Xvar
X oCurPosX, oCurPosY: integer;
X oScreenPtr: rasterPtr;
X
X procedure resetInput;
X begin { resetInput }
X streamKeyboardReset(input);
X end { resetInput };
X
X procedure newTitle;
X var
X ts: string[128];
X fn: string;
X fl, fPos, tPos, i: integer;
X begin { newTitle }
X ts := 'Go Version ';
X ts := concat(ts, version);
X getFNameString(fn);
X fl := length(fn);
X if fl > 0 then
X begin
X fPos := 81 - fl;
X tPos := length(ts) + 1;
X adjust(ts, 80);
X for i := tPos to 80 do
X ts[i] := ' ';
X for i := fPos to fPos + fl - 1 do
X ts[i] := fn[i - fPos + 1];
X end;
X changeTitle(ts);
X end { newTitle };
X
X procedure initialize;
X var
X sseg: integer;
X
X procedure setupWindows;
X var
X ts: string;
X begin { setupWindows }
X createWindow(boardWin, bWinX, bWinY, bWinW, bWinH, ' ');
X createWindow(menuWin, mWinX, mWinY, mWinW, mWinH, '');
X createWindow(statWin, sWinX, sWinY, sWinW, sWinH, '');
X changeWindow(0);
X gameFName := '';
X newTitle;
X end { setupWindows };
X
X begin { initialize }
X createSegment(sseg, 192, 1, 192);
X oScreenPtr := makePtr(sseg, 0, rasterPtr);
X SReadCursor(oCurPosX, oCurPosY);
X rasterop(rRpl, 768, 1024, 0, 0, SScreenW, oScreenPtr,
X 0, 0, SScreenW, SScreenP);
X IOSetFunction(CTCursCompl);
X rasterop(RAndNot, 768, 1024, 0, 0, SScreenW, SScreenP,
X 0, 0, SScreenW, SScreenP);
X setupWindows;
X initMenu;
X captures[black] := 0;
X captures[white] := 0;
X initGoTree;
X initGoBoard;
X makeGoTree;
X initGoMgr;
X gameFName := '';
X numbEnabled := false;
X treeDirty := false;
X playLevel := 0;
X debug := false;
X printLarge := true;
X initGoPlayer;
X end { initialize };
X
X procedure doit;
X var
X done, foundIt, endLoop, gbg: boolean;
X CtlCseen, playMyself, lastWasPass: boolean;
X whoseTurn, whoWasLast: sType;
X i, xi, yi, xs, ys: integer;
X numDead, numHC, cmd: integer;
X lastBuM: integer;
X thisTag: tagPtr;
X lastMove: pMRec;
X
X function getLine(var l: string): boolean;
X label
X 1;
X var
X i, j, cx, cy: integer;
X
X handler ctlC;
X begin { ctlC }
X IOKeyClear;
X streamKeyboardReset(input);
X beep(error);
X prompt('');
X l := '';
X getLine := false;
X exit(getLine);
X end { ctlC };
X
X handler pastEOF(fn: pathName);
X begin { pastEOF }
X reset(input, fn);
X sSetCursor(cx, cy);
X write(' ');
X sSetCursor(cx, cy);
X goto 1;
X end { pastEOF };
X
X begin { getLine }
X sReadCursor(cx, cy);
X 1:
X readln(l);
X getLine := true;
X j := 0;
X for i := 1 to length(l) do
X if ord(l[i]) >= 32 then
X begin
X j := j + 1;
X l[j] := l[i];
X end;
X adjust(l, j);
X end { getLine };
X
X procedure resetGame;
X begin { resetGame }
X clearBoard;
X koX := -1;
X koY := -1;
X moveNum := 0;
X curMove := treeRoot;
X captures[black] := 0;
X captures[white] := 0;
X showCaptures;
X whoseTurn := black;
X turnIs(black);
X gameFname := '';
X newTitle;
X gameOver := false;
X initGoMgr;
X end { resetGame };
X
X procedure switchWho;
X begin { switchWho }
X if curMove = treeRoot then
X whoseTurn := black
X else if curMove^.id = remove then
X whoseTurn := curMove^.who
X else if curMove^.id = hcPlay then
X whoseTurn := white
X else if curMove^.who = black then
X whoseTurn := white
X else
X whoseTurn := black;
X turnIs(whoseTurn);
X end { switchWho };
X
X procedure updateStatus;
X begin { updateStatus }
X dotLast;
X showCaptures;
X showComment;
X showTag;
X switchWho;
X end { updateStatus };
X
X procedure doReadGame;
X var
X fName: pathName;
X
X handler badFileVersion;
X begin { badFileVersion }
X beep(error);
X prompt('');
X write(gameFName, ' is not compatable with this version of GO');
X resetGame;
X exit(doReadGame);
X end { badFileVersion };
X
X begin { doReadGame }
X if menuGoFile(fName) then
X begin
X prompt('Reading ');
X write(fName, '.Go ...');
X readTree(concat(fName, '.GO'));
X resetGame;
X gameFName := fName;
X if treeRoot^.lastMove <> nil then
X switchBranch(treeRoot^.lastMove);
X treeDirty := false;
X prompt('');
X newTitle;
X end;
X end { doReadGame };
X
X procedure doWriteGame;
X var
X fs: string;
X procedure addExt(var nam: string);
X var
X es: string;
X begin { addExt }
X if length(nam) > 3 then
X begin
X es := substr(nam, length(nam) - 2, 3);
X convUpper(es);
X if es <> '.GO' then
X nam := concat(nam, '.Go');
X end
X else
X nam := concat(nam, '.Go');
X end { addExt };
X
X handler badGoWrite;
X begin { badGoWrite };
X beep(error);
X prompt('Unable to write file ');
X write(fs);
X exit(doWriteGame);
X end { badGoWrite };
X
X begin { doWriteGame }
X IOKeyClear;
X streamKeyboardReset(input);
X if gameFName <> '' then
X begin
X prompt('Game File Name [');
X write(gameFName, ']? ');
X end
X else
X prompt('Game File Name? ');
X if not getLine(fs) then
X exit(doWriteGame);
X if fs = '' then
X if gameFName = '' then
X begin
X beep(error);
X prompt('');
X exit(doWriteGame);
X end
X else
X fs := gameFName;
X gameFName := fs;
X addExt(fs);
X prompt('Writing ');
X write(fs, ' ...');
X writeTree(fs, curMove);
X treeDirty := false;
X prompt('');
X newTitle;
X end { doWriteGame };
X
X function chooseAlt: boolean;
X label
X 10;
X var
X bx, by, xs, ys: integer;
X tm: pMRec;
X hc0There: boolean;
X hcMenu: pNameDesc;
X res: resres;
X numHC, i, j, numNHC: integer;
X
X handler outside;
X begin { outside }
X destroyNameDesc(hcMenu);
X chooseAlt := false;
X beep(error);
X restoreCursor;
X exit(chooseAlt);
X end { outside };
X
X begin { chooseAlt }
X chooseAlt := false;
X switchWho;
X waitNoButton;
X tm := curMove^.flink;
X numHC := 0;
X numNHC := 0;
X hc0There := false;
X while tm <> nil do
X begin
X if tm^.id = hcPlay then
X numHC := numHC + 1
X else
X begin
X hc0There := true;
X numNHC := numNHC + 1;
X end;
X tm := tm^.slink;
X end;
X if numHC > 0 then
X begin
X if hc0There then
X numHC := numHC + 1;
X allocNameDesc(numHC, 0, hcMenu);
X hcMenu^.header := 'Handicap Alternates';
X j := 1;
X if hc0There then
X begin
X hcMenu^.commands[1] := '0';
X j := 2;
X end;
X tm := curMove^.flink;
X for i := j to numHC do
X begin
X while tm^.id <> hcPlay do
X tm := tm^.slink;
X {$R-}
X hcMenu^.commands[i] := ' ';
X hcMenu^.commands[i][1] := chr(tm^.hcNum + ord('0'));
X {$R=}
X tm := tm^.slink;
X end;
X menu(hcMenu, false, 1, numHC, -1, -1, -1, res);
X restoreCursor;
X destroyNameDesc(hcMenu);
X i := res^.indices[1];
X destroyRes(res);
X if hc0There then
X if i = 1 then
X begin
X if numNHC > 1 then
X goto 10;
X tm := curMove^.flink;
X while tm^.id <> move do
X tm := tm^.slink;
X forwardTo(tm);
X chooseAlt := true;
X exit(chooseAlt);
X end
X else
X i := i - 1;
X tm := curMove^.flink;
X j := 0;
X repeat
X while tm^.id <> hcPlay do
X tm := tm^.slink;
X j := j + 1;
X if j <> i then
X tm := tm^.slink;
X until j = i;
X forwardTo(tm);
X chooseAlt := true;
X end
X else
X begin
X 10:
X showAlts;
X waitButton;
X if passLocCur(tabRelX, tabRelY) then
X begin
X if passIsAlt then
X begin
X selPass;
X chooseAlt := true;
X waitNoButton;
X exit(chooseAlt);
X end;
X end
X else if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
X if board[bx][by].val = alternate then
X begin
X selAlt(bx, by);
X chooseAlt := true;
X waitNoButton;
X exit(chooseAlt);
X end;
X remAlts;
X beep(error);
X end;
X waitNoButton;
X end { chooseAlt };
X
X procedure mForward;
X var
X gbg: boolean;
X begin { mForward }
X if gameOver then
X restoreDead;
X if atLeaf(curMove) then
X beep(error)
X else if atBranch(curMove) then
X gbg := chooseAlt
X else
X forwardTo(curMove^.flink);
X end { mForward };
X
X procedure doBkToS;
X var
X bx, by, sx, sy: integer;
X begin { doBkToS }
X prompt('Point at stone to backup to');
X waitButton;
X if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
X if board[bx][by].val <> empty then
X begin
X while not lastPlayAt(bx, by) do
X backup1;
X exit(doBkToS);
X end;
X beep(error);
X waitNoButton;
X end { doBkToS };
X
X procedure doPutTag;
X var
X ts: tagStr;
X cm: pMRec;
X begin { doPutTag }
X if curMove = treeRoot then
X beep(error)
X else
X begin
X IOKeyClear;
X streamKeyboardReset(input);
X prompt('Tag String: ');
X if not getLine(ts) then
X exit(doPutTag);
X if length(ts) > maxTagLen then
X begin
X beep(error);
X prompt('Tags may be no longer than ');
X write(maxTagLen:0, ' characters');
X end
X else if length(ts) = 0 then
X begin
X if curMove^.tag = nil then
X begin
X beep(error);
X prompt('');
X end
X else
X begin
X delTag(curMove^.tag);
X prompt('Tag Deleted');
X end;
X end
X else if tagExists(ts) then
X begin
X beep(error);
X prompt('That tag already exists');
X end
X else
X begin
X tagMove(curMove, ts);
X end;
X end;
X end { doPutTag };
X
X procedure doGoToTag;
X var
X thisTag: tagPtr;
X begin { doGoToTag }
X thisTag := getTagMenu;
X if thisTag <> nil then
X switchBranch(thisTag^.mPtr);
X end { doGoToTag };
X
X procedure doPutCmt;
X var
X cs, curCmt: string;
X begin { doPutCmt }
X IOKeyClear;
X streamKeyboardReset(input);
X prompt('Comment: ');
X if not getLine(cs) then
X exit(doPutCmt);
X if length(cs) = 0 then
X if getComment(curMove, curCmt) then
X prompt('Comment Deleted')
X else
X begin
X beep(error);
X prompt('');
X end;
X commentMove(curMove, cs);
X end { doPutCmt };
X
X procedure doScore;
X var
X wScore, bScore, wr, br: integer;
X done: boolean;
X bx, by, xs, ys: integer;
X begin { doScore }
X putEnd;
X done := false;
X prompt('Point at dead groups, Press outside of board to stop');
X repeat
X waitButton;
X if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
X begin
X if board[bx, by].val <> empty then
X delGroup(bx, by);
X end
X else
X done := true;
X showCaptures;
X waitNoButton;
X until done;
X prompt('Counting Score ...');
X scoreGame(wScore, bScore);
X wScore := wScore - captures[black];
X bScore := bScore - captures[white];
X if wScore < 0 then
X begin
X wr := -wScore;
X wScore := 0;
X end
X else
X wr := 0;
X if bScore < 0 then
X begin
X br := -bScore;
X bScore := 0;
X end
X else
X br := 0;
X bScore := bScore + wr;
X wScore := wScore + br;
X prompt('Score is: ');
X write('White = ', wScore:0, ', Black = ', bScore:0);
X if wScore = bScore then
X write(' - A Tie!')
X else if wScore > bScore then
X write(' - White Wins by ', (wScore - bScore):0)
X else
X write(' - Black Wins by ', (bScore - wScore):0)
X end { doScore };
X
X procedure doEraseMove;
X var
X lm: pMRec;
X begin { doEraseMove }
X if gameOver then
X restoreDead;
X if curMove = treeRoot then
X beep(error)
X else
X begin
X lm := curMove;
X backup1;
X lm := delBranch(lm);
X treeDirty := true;
X end;
X end { doEraseMove };
X
X procedure doPruneBranches;
X var
X lm, sm, tm: pMRec;
X tp: tagPtr;
X didPrune: boolean;
X begin { doPruneBranches }
X if gameOver then
X restoreDead;
X if not isBranch(curMove) then
X beep(error)
X else if not confirmed then
X beep(error)
X else
X begin
X didPrune := false;
X wipeTreeMarks;
X lm := curMove;
X while lm <> treeRoot do
X begin
X lm^.mark := true;
X lm := lm^.blink;
X end;
X tp := treeRoot^.lastTag;
X while tp <> nil do
X begin
X lm := tp^.mPtr;
X while lm <> treeRoot do
X begin
X lm^.mark := true;
X lm := lm^.blink;
X end;
X tp := tp^.nextTag;
X end;
X lm := curMove;
X while lm <> treeRoot do
X begin
X if lm^.blink^.flink^.slink <> nil then
X begin
X sm := lm^.blink^.flink;
X while sm <> nil do
X if not sm^.mark then
X begin
X tm := sm;
X sm := sm^.slink;
X tm := delBranch(tm);
X didPrune := true;
X treeDirty := true;
X end
X else
X sm := sm^.slink;
X end;
X lm := lm^.blink;
X end;
X if not didPrune then
X prompt('All Branches Were Tagged');
X end;
X end { doPruneBranches };
X
X handler ctlC;
X begin { ctlC }
X IOKeyClear;
X CtlCseen := true;
X end { ctlC };
X
X begin { doit }
X resetGame;
X done := false;
X lastMove := nil;
X CtlCseen := false;
X playMyself := false;
X lastWasPass := false;
X IOSetModeTablet(relTablet);
X IOCursorMode(trackCursor);
X activate(mReadFile, true);
X activate(mTogNums, true);
X activate(mQuit, true);
X activate(mPutCmt, true);
X activate(mAutoPlay, true);
X activate(mPlayMyself, true);
X activate(mSetPlayLevel, true);
X activate(mDebug, true);
X activate(mRefBoard, true);
X activate(mShoState, true);
X activate(mBoardSize, true);
X repeat
X if curMove <> lastMove then
X checkAtari(curMove);
X updateStatus;
X lastMove := curMove;
X if not playMyself then
X begin
X activate(mPrintBoard, curMove <> treeRoot);
X activate(mPrintDiag, curMove <> treeRoot);
X activate(mStepToTag, stepTagPossible);
X activate(mSetStepTag, treeRoot^.lastTag <> nil);
X activate(mGotoTag, treeRoot^.lastTag <> nil);
X activate(mInit, treeRoot^.flink <> nil);
X activate(mWriteFile, treeRoot^.flink <> nil);
X activate(mSetHc, curMove = treeRoot);
X activate(mPass, curMove <> treeRoot);
X activate(mScore, curMove <> treeRoot);
X activate(mForToBr, hasBranch(curMove));
X activate(mBackToBr, isBranch(curMove));
X activate(mBackToStone, curMove <> treeRoot);
X activate(mForToLeaf, curMove^.flink <> nil);
X activate(mPutTag, curMove <> treeRoot);
X activate(mGotoRoot, curMove <> treeRoot);
X activate(mEraseMove, curMove <> treeRoot);
X activate(mPruneBranches, isBranch(curMove));
X activate(mBackOne, curMove <> treeRoot);
X activate(mForOne, curMove^.flink <> nil);
X end;
X if CtlCseen then
X cmd := mCtlC
X else if playMyself then
X cmd := mAutoPlay
X else
X repeat
X cmd := getMenuCmd;
X until cmd <> none;
X prompt('');
X case cmd of
X mCtlC:
X begin
X playMyself := false;
X CtlCseen := false;
X end;
X mPlaceStone:
X begin
X if gameOver then
X restoreDead;
X if bLocCur(tabRelX, tabRelY, xi, yi, xs, ys) then
X begin
X if board[xi, yi].val <> empty then
X beep(error)
X else if (xi = koX) and (yi = koY) then
X beep(koV)
X else
X doMove(whoseTurn, xi, yi, xs, ys);
X end
X else
X beep(error);
X waitNoButton;
X end;
X mAutoPlay:
X begin
X if gameOver then
X restoreDead;
X prompt('Thinking...');
X if curMove = treeRoot then
X lastWasPass := false
X else
X lastWasPass := curMove^.id = pass;
X if playMove(whoseTurn, xi, yi) then
X begin
X if board[xi, yi].val <> empty then
X begin
X beep(error);
X prompt('Bad move at ');
X write((xi + 1):0, ', ', (yi + 1):0);
X playMyself := false;
X write(' - Generated by ', playreason);
X end
X else if (xi = koX) and (yi = koY) then
X begin
X beep(koV);
X prompt('ko violation at ');
X write((xi + 1):0, ', ', (yi + 1):0);
X write(' - Generated by ', playreason);
X playMyself := false;
X end
X else
X begin
X doMove(whoseTurn, xi, yi, 0, 0);
X if board[xi, yi].val = empty then
X begin
X prompt('self kill at ');
X write((xi + 1):0, ', ', (yi + 1):0);
X write(' - Generated by ', playreason);
X playMyself := false;
X end
X else
X commentMove(curMove, playReason);
X end;
X end
X else
X begin
X doPass(whoseTurn);
X if lastWasPass then
X playMyself := false;
X end;
X waitNoButton;
X prompt('');
X end;
X mPlayMyself:
X playMyself := true;
X mSetPlayLevel:
X menuPlayLevel(playLevel, maxPlayLevel);
X mShoState:
X showPlayState(whoseTurn);
X mInit:
X if confirmed then
X begin
X makeGoTree;
X resetGame;
X treeDirty := false;
X end
X else
X beep(error);
X mSetHc:
X if moveNum = 0 then
X begin
X if gameOver then
X restoreDead;
X numHC := getHCMenu;
X if numHC > 0 then
X doHCPlay(numHC)
X else
X beep(error);
X end
X else
X beep(error);
X mPass:
X begin
X if gameOver then
X restoreDead;
X doPass(whoseTurn);
X end;
X mScore:
X doScore;
X mForToBr:
X begin
X if gameOver then
X restoreDead;
X if atLeaf(curMove) then
X beep(error)
X else if not atBranch(curMove) then
X forwToBr;
X if not atLeaf(curMove) then
X gbg := chooseAlt;
X end;
X mBackToBr:
X begin
X if gameOver then
X restoreDead;
X if curMove = treeRoot then
X beep(error)
X else
X backToBr;
X if atBranch(curMove) then
X gbg := chooseAlt;
X end;
X mBackToStone:
X begin
X if gameOver then
X restoreDead;
X if curMove = treeRoot then
X beep(error)
X else
X doBkToS;
X end;
X mForToLeaf:
X begin
X if gameOver then
X restoreDead;
X if atLeaf(curMove) then
X beep(error)
X else
X begin
X endLoop := false;
X repeat
X if atLeaf(curMove) then
X endLoop := true
X else if atBranch(curMove) then
X begin
X if not chooseAlt then
X begin
X endLoop := true;
X beep(error);
X end;
X end
X else
X forwToBr;
X until endLoop;
X end;
X end;
X mPutTag:
X doPutTag;
X mGotoTag:
X doGoToTag;
X mGotoRoot:
X switchBranch(treeRoot);
X mPutCmt:
X doPutCmt;
X mReadFile:
X if confirmed then
X doReadGame;
X mWriteFile:
X doWriteGame;
X mEraseMove:
X doEraseMove;
X mPruneBranches:
X doPruneBranches;
X mTogNums:
X if not numbEnabled then
X begin
X numbEnabled := true;
X showAllStones;
X dotSX := -1;
X putMString(mTogNums, 'Erase Numbers');
X end
X else
X begin
X numbEnabled := false;
X showAllStones;
X dotSX := -1;
X dotLast;
X putMString(mTogNums, 'Show Stone Numbers');
X end;
X mDebug:
X if debug then
X begin
X debug := false;
X putMString(mDebug, 'Turn Debug On');
X end
X else
X begin
X debug := true;
X putMString(mDebug, 'Turn Debug Off');
X end;
X mBoardSize:
X begin
X printLarge := not printLarge;
X if printLarge then
X begin
X prompt('Will Print on Large Board Now');
X putMString(mBoardSize, 'Use Small Board');
X end
X else
X begin
X prompt('Will Print on Small Board Now');
X putMString(mBoardSize, 'Use Large Board');
X end;
X end;
X mPrintBoard:
X printBoard(false);
X mPrintDiag:
X printBoard(true);
X mStepToTag:
X begin
X if gameOver then
X restoreDead;
X if stepTag = nil then
X stepTag := getTagMenu;
X if stepTag <> nil then
X doStepTag
X else
X beep(error);
X end;
X mSetStepTag:
X begin
X thisTag := getTagMenu;
X if thisTag <> nil then
X stepTag := thisTag;
X end;
X mQuit:
X if confirmed then
X done := true;
X mBackOne:
X begin
X if gameOver then
X restoreDead
X else if curMove = treeRoot then
X beep(error)
X else
X backUp1;
X end;
X mForOne:
X begin
X if gameOver then
X restoreDead;
X mForward;
X end;
X mRefBoard:
X refreshBoard;
X end { case };
X if not playMyself then
X endCmd;
X until done;
X end { doit };
X
X procedure cleanup;
X begin { cleanup }
X screenReset;
X rasterOp(rRpl, 768, 1024, 0, 0, SScreenW, SScreenP,
X 0, 0, SScreenW, oScreenPtr);
X SSetCursor(oCurPosX, oCurPosY);
X end { cleanup };
X
X handler ctlC;
X begin { ctlC }
X IOKeyClear;
X end { ctlC };
X
Xbegin { Go }
X initialize;
X doit;
X99:
X cleanUp;
Xend { Go }.
END_OF_go.pas
if test 26299 -ne `wc -c <go.pas`; then
echo shar: \"go.pas\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f goMgr.pas -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"goMgr.pas\"
else
echo shar: Extracting \"goMgr.pas\" \(20985 characters\)
sed "s/^X//" >goMgr.pas <<'END_OF_goMgr.pas'
X{---------------------------------------------------------------}
X{ GoMgr.Pas }
X{ }
X{ Go Game Manager }
X{ Copyright (c) 1982 by Three Rivers Computer Corp. }
X{ }
X{ Written: June 3, 1982 by Stoney Ballard }
X{ Edit History: }
X{ June 3, 1982 Started }
X{ June 4, 1982 Add dead group removal }
X{ June 10, 1982 Use new go file manager }
X{ Nov 9, 1982 Extracted from GO.PAS }
X{---------------------------------------------------------------}
X
Xmodule goMgr;
X
Xexports
X
Ximports goCom from goCom;
Ximports goTree from goTree;
X
Xvar
X curMove: pMRec;
X gameOver: boolean;
X passIsAlt: boolean;
X
Xprocedure initGoMgr;
Xprocedure backUp1;
Xprocedure doMove(which: sType; ix, iy, pox, poy: integer);
Xprocedure doPass(which: sType);
Xprocedure doHCPlay(num: integer);
Xprocedure forwardTo(m: pMRec);
Xprocedure forwToBr;
Xprocedure backToBr;
Xprocedure showAlts;
Xprocedure remAlts;
Xprocedure selAlt(lx, ly: integer);
Xprocedure selPass;
Xfunction atBranch(cm: pMRec): boolean;
Xfunction atLeaf(cm: pMRec): boolean;
Xprocedure checkAtari(cm: pMRec);
Xprocedure switchBranch(bm: pMRec);
Xprocedure scoreGame(var ws, bs: integer);
Xprocedure putEnd;
Xprocedure delGroup(bx, by: integer);
Xprocedure restoreDead;
Xprocedure dotLast;
Xfunction lastPlayAt(bx, by: integer): boolean;
Xprocedure doStepTag;
Xfunction stepTagPossible: boolean;
Xprocedure wipeTreeMarks;
X
Xprivate
X
Ximports goBoard from goBoard;
Ximports goMenu from goMenu;
Ximports screen from screen;
X
Xtype
X deadRec = record
X dx, dy, dox, doy, mn: integer;
X whoDead: sType;
X end;
X
Xvar
X killX, killY: integer;
X endDead: array[1..361] of deadRec;
X numEndDead: integer;
X
Xprocedure wipeMarks;
Xvar
X i, j: integer;
Xbegin { wipeMarks }
X for i := 0 to maxPoint do
X for j := 0 to maxPoint do
X board[i, j].marked := false;
Xend { wipeMarks };
X
Xprocedure wipeTreeMarks;
X
X procedure recWipe(m: pMRec);
X begin { recWipe }
X while m <> nil do
X begin
X recWipe(m^.slink);
X m^.mark := false;
X m := m^.flink;
X end;
X end { recWipe };
X
Xbegin { wipeTreeMarks }
X treeRoot^.mark := false;
X if treeRoot^.flink <> nil then
X recWipe(treeRoot^.flink);
Xend { wipeTreeMarks };
X
Xprocedure spanGroup(s: sType; xi, yi: integer; var libs, size: integer);
Xbegin { spanGroup }
X if (xi >= 0) and (xi <= maxPoint) and
X (yi >= 0) and (yi <= maxPoint) then
X with board[xi, yi] do
X if not marked then
X if val = empty then
X begin
X libs := libs + 1;
X marked := true;
X end
X else if val = s then
X begin
X marked := true;
X size := size + 1;
X spanGroup(s, xi - 1, yi, libs, size);
X spanGroup(s, xi + 1, yi, libs, size);
X spanGroup(s, xi, yi - 1, libs, size);
X spanGroup(s, xi, yi + 1, libs, size);
X end;
Xend { spanGroup };
X
Xfunction libertyCount(xi, yi: integer): integer;
Xvar
X libs, size: integer;
Xbegin { libertyCount }
X wipeMarks;
X libs := 0;
X size := 0;
X spanGroup(board[xi, yi].val, xi, yi, libs, size);
X libertyCount := libs;
Xend { libertyCount };
X
Xfunction groupSize(xi, yi: integer): integer;
Xvar
X gbg, size: integer;
Xbegin { groupSize }
X wipeMarks;
X size := 0;
X gbg := 0;
X spanGroup(board[xi, yi].val, xi, yi, gbg, size);
X groupSize := size;
Xend { groupSize };
X
Xprocedure killGroup(s: sType; xi, yi: integer);
Xbegin { killGroup }
X if (xi >= 0) and (xi <= maxPoint) and
X (yi >= 0) and (yi <= maxPoint) then
X with board[xi, yi] do
X if val = s then
X begin
X remStone(xi, yi);
X curMove := newMove(curMove);
X with curMove^ do
X begin
X mx := xi;
X my := yi;
X ox := board[xi, yi].xOfs;
X oy := board[xi, yi].yOfs;
X moveN := board[xi, yi].mNum;
X who := s;
X id := remove;
X end;
X curMove := mergeMove(curMove);
X killGroup(s, xi - 1, yi);
X killGroup(s, xi + 1, yi);
X killGroup(s, xi, yi - 1);
X killGroup(s, xi, yi + 1);
X end;
Xend { killGroup };
X
Xprocedure remDead(xi, yi: integer; var numDead: integer);
Xvar
X i, j, libs, size: integer;
X s, other: bVal;
X
Xbegin { remDead }
X numDead := 0;
X s := board[xi, yi].val;
X if s = white then
X other := black
X else
X other := white;
X if xi > 0 then
X if (board[xi - 1, yi].val = other) then
X begin
X wipeMarks;
X libs := 0;
X size := 0;
X spanGroup(other, xi - 1, yi, libs, size);
X if libs = 0 then
X begin
X killGroup(other, xi - 1, yi);
X numDead := numDead + size;
X killX := xi - 1;
X killY := yi;
X end;
X end;
X if xi < maxPoint then
X if (board[xi + 1, yi].val = other) then
X begin
X wipeMarks;
X libs := 0;
X size := 0;
X spanGroup(other, xi + 1, yi, libs, size);
X if libs = 0 then
X begin
X killGroup(other, xi + 1, yi);
X numDead := numDead + size;
X killX := xi + 1;
X killY := yi;
X end;
X end;
X if yi > 0 then
X if (board[xi, yi - 1].val = other) then
X begin
X wipeMarks;
X libs := 0;
X size := 0;
X spanGroup(other, xi, yi - 1, libs, size);
X if libs = 0 then
X begin
X killGroup(other, xi, yi - 1);
X numDead := numDead + size;
X killX := xi;
X killY := yi - 1;
X end;
X end;
X if yi < maxPoint then
X if (board[xi, yi + 1].val = other) then
X begin
X wipeMarks;
X libs := 0;
X size := 0;
X spanGroup(other, xi, yi + 1, libs, size);
X if libs = 0 then
X begin
X killGroup(other, xi, yi + 1);
X numDead := numDead + size;
X killX := xi;
X killY := yi + 1;
X end;
X end;
X if numDead > 0 then
X beep(die);
Xend { remDead };
X
Xfunction lastPlayAt(bx, by: integer): boolean;
Xvar
X tm: pMRec;
Xbegin { lastPlayAt }
X lastPlayAt := false;
X tm := curMove;
X while tm <> treeRoot do
X with tm^ do
X if id = move then
X begin
X lastPlayAt := (mx = bx) and (my = by);
X exit(lastPlayAt);
X end
X else if id = pass then
X exit(lastPlayAt)
X else if id = hcPlay then
X exit(lastPlayAt)
X else
X tm := tm^.blink;
Xend { lastPlayAt };
X
Xprocedure findAtari(xi, yi: integer);
Xvar
X i, j, libs, num, size: integer;
X s, other: bVal;
Xbegin { findAtari }
X size := 0;
X s := board[xi, yi].val;
X if s = white then
X other := black
X else
X other := white;
X wipeMarks;
X libs := 0;
X spanGroup(s, xi, yi, libs, size);
X if libs = 1 then
X begin
X beep(atari);
X exit(findAtari);
X end;
X if xi > 0 then
X if (board[xi - 1, yi].val = other) and
X (not board[xi - 1, yi].marked) then
X begin
X wipeMarks;
X libs := 0;
X spanGroup(other, xi - 1, yi, libs, size);
X if libs = 1 then
X begin
X beep(atari);
X exit(findAtari);
X end;
X end;
X if xi < maxPoint then
X if (board[xi + 1, yi].val = other) and
X (not board[xi + 1, yi].marked) then
X begin
X wipeMarks;
X libs := 0;
X spanGroup(other, xi + 1, yi, libs, size);
X if libs = 1 then
X begin
X beep(atari);
X exit(findAtari);
X end;
X end;
X if yi > 0 then
X if (board[xi, yi - 1].val = other) and
X (not board[xi, yi - 1].marked) then
X begin
X wipeMarks;
X libs := 0;
X spanGroup(other, xi, yi - 1, libs, size);
X if libs = 1 then
X begin
X beep(atari);
X exit(findAtari);
X end;
X end;
X if yi < maxPoint then
X if (board[xi, yi + 1].val = other) and
X (not board[xi, yi + 1].marked) then
X begin
X wipeMarks;
X libs := 0;
X spanGroup(other, xi, yi + 1, libs, size);
X if libs = 1 then
X beep(atari);
X end;
Xend { findAtari };
X
Xprocedure checkAtari(cm: pMRec);
Xbegin { checkAtari }
X if cm <> treeRoot then
X if cm^.id <> hcPlay then
X if cm^.id <> pass then
X begin
X while cm^.id = remove do
X cm := cm^.blink;
X with cm^ do
X findAtari(mx, my);
X end;
Xend { checkAtari };
X
Xprocedure restoreDead;
Xvar
X i: integer;
X other: sType;
Xbegin { restoreDead }
X for i := 1 to numEndDead do
X with endDead[i] do
X begin
X placeStone(whoDead, dx, dy, dox, doy, mn);
X if whoDead = white then
X other := black
X else
X other := white;
X captures[other] := captures[other] - 1;
X end;
X numEndDead := 0;
X gameOver := false;
Xend { restoreDead };
X
Xprocedure backUp1;
Xvar
X moveT: mType;
X prevMove, tm: pMRec;
Xbegin { backUp1 }
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X if gameOver then
X restoreDead;
X if curMove <> treeRoot then
X repeat
X with curMove^ do
X begin
X prevMove := blink;
X moveT := id;
X if id = move then
X remStone(mx, my)
X else if id = remove then
X begin
X placeStone(who, mx, my, ox, oy, moveN);
X if who = black then
X captures[white] := captures[white] - 1
X else
X captures[black] := captures[black] - 1;
X end
X else if id = pass then
X remPass
X else { hcPlay }
X clearBoard;
X end;
X curMove := prevMove;
X until (curMove = treeRoot) or (moveT = move) or (moveT = pass);
X if curMove = treeRoot then
X begin
X koX := -1;
X koY := -1;
X moveNum := 0;
X end
X else if curMove^.id = move then
X with curMove^ do
X begin
X koX := kx;
X koY := ky;
X moveNum := moveN;
X end
X else if curMove^.id = pass then
X with curMove^ do
X begin
X koX := -1;
X koY := -1;
X moveNum := moveN;
X showPass(who);
X end
X else if curMove^.id = hcPlay then
X begin
X koX := -1;
X koY := -1;
X moveNum := 1;
X end
X else
X begin
X tm := curMove^.blink;
X while tm^.id <> move do
X tm := tm^.blink;
X with tm^ do
X begin
X koX := kx;
X koY := ky;
X moveNum := moveN;
X end;
X end;
Xend { backUp1 };
X
Xprocedure doMove(which: sType; ix, iy, pox, poy: integer);
Xvar
X numDead: integer;
X cm: pMRec;
Xbegin { doMove }
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X if gameOver then
X restoreDead;
X curMove := newMove(curMove);
X moveNum := moveNum + 1;
X with curMove^ do
X begin
X mx := ix;
X my := iy;
X ox := pox;
X oy := poy;
X kx := koX;
X ky := koY;
X who := which;
X id := move;
X moveN := moveNum;
X end;
X curMove := mergeMove(curMove);
X cm := curMove;
X placeStone(which, ix, iy, pox, poy, moveNum);
X remDead(ix, iy, numDead);
X if libertyCount(ix, iy) < 1 then
X begin
X curMove := delBranch(curMove);
X moveNum := moveNum + 1;
X remStone(ix, iy);
X beep(error);
X end
X else
X begin
X captures[which] := captures[which] + numDead;
X if (numDead = 1) and (groupSize(ix, iy) = 1) then
X begin
X koX := killX;
X koY := killY;
X end
X else
X begin
X koX := -1;
X koY := -1;
X end;
X with cm^ do
X begin
X kx := koX;
X ky := koY;
X end;
X end;
Xend { doMove };
X
Xprocedure doPass(which: sType);
Xbegin { doPass }
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X if gameOver then
X restoreDead;
X curMove := newMove(curMove);
X moveNum := moveNum + 1;
X with curMove^ do
X begin
X who := which;
X id := pass;
X moveN := moveNum;
X end;
X curMove := mergeMove(curMove);
X showPass(which);
Xend { doPass };
X
Xprocedure doHCPlay(num: integer);
Xbegin { doHCPlay }
X moveNum := 1;
X curMove := newMove(treeRoot);
X with curMove^ do
X begin
X who := black;
X id := hcPlay;
X hcNum := num;
X end;
X addHCStones(num);
Xend { doHCPlay };
X
Xprocedure forwardTo(m: pMRec);
Xbegin { forwardTo }
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X curMove := m;
X if passShowing then
X remPass;
X with curMove^ do
X if id = hcPlay then
X begin
X addHCStones(hcNum);
X moveNum := 1;
X end
X else if id = pass then
X begin
X moveNum := moveN;
X koX := -1;
X koY := -1;
X showPass(who);
X end
X else
X begin
X moveNum := moveN;
X placeStone(who, mx, my, ox, oy, moveNum);
X koX := kx;
X koY := ky;
X while curMove^.flink <> nil do
X if curMove^.flink^.id = remove then
X begin
X curMove := curMove^.flink;
X with curMove^ do
X remStone(mx, my);
X if curMove^.who = white then
X captures[black] := captures[black] + 1
X else
X captures[white] := captures[white] + 1
X end
X else
X exit(forwardTo);
X end;
Xend { forwardTo };
X
Xprocedure forwToBr;
Xvar
X atBr: boolean;
Xbegin { forwToBr }
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X atBr := false;
X repeat
X if curMove^.flink = nil then
X atBr := true
X else if curMove^.flink^.slink <> nil then
X atBr := true
X else
X forwardTo(curMove^.flink);
X until atBr;
Xend { forwToBr };
X
Xprocedure backToBr;
Xvar
X na: integer;
X tm: pMRec;
X endLoop: boolean;
Xbegin { backToBr }
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X if curMove <> treeRoot then
X begin
X if not hasAlts(curMove) then
X repeat
X backUp1;
X if curMove = treeRoot then
X endLoop := true
X else
X endLoop := hasAlts(curMove);
X until endLoop;
X if curMove <> treeRoot then
X backUp1;
X end
X else
X beep(error);
Xend { backToBr };
X
Xfunction atBranch(cm: pMRec): boolean;
Xbegin { atBranch }
X if cm^.flink <> nil then
X atBranch := cm^.flink^.slink <> nil
X else
X atBranch := false;
Xend { atBranch };
X
Xfunction atLeaf(cm: pMRec): boolean;
Xbegin { atLeaf }
X atLeaf := cm^.flink = nil;
Xend { atLeaf };
X
Xprocedure showAlts;
Xvar
X tm: pMRec;
Xbegin { showAlts }
X setMenuCursor;
X tm := curMove^.flink;
X passIsAlt := false;
X while tm <> nil do
X begin
X with tm^ do
X begin
X if id = move then
X placeAlt(who, mx, my, ox, oy)
X else if id = pass then
X begin
X SChrFunc(ord(rNot));
X showPass(who);
X SChrFunc(ord(rRpl));
X passIsAlt := true;
X end;
X tm := tm^.slink;
X end;
X end;
Xend { showAlts };
X
Xprocedure remAlts;
Xvar
X tm: pMRec;
Xbegin { remAlts }
X tm := curMove^.flink;
X while tm <> nil do
X begin
X with tm^ do
X begin
X if id = move then
X remStone(mx, my)
X else if id = pass then
X remPass;
X tm := tm^.slink;
X end;
X end;
Xend { remAlts };
X
Xprocedure selAlt(lx, ly: integer);
Xbegin { selAlt }
X remAlts;
X curMove := curMove^.flink;
X repeat
X while curMove^.id <> move do
X curMove := curMove^.slink;
X if (curMove^.mx = lx) and (curMove^.my = ly) then
X begin
X forwardTo(curMove);
X exit(selAlt);
X end
X else
X curMove := curMove^.slink;
X until false;
Xend { selAlt };
X
Xprocedure selPass;
Xbegin { selPass }
X remAlts;
X curMove := curMove^.flink;
X while curMove^.id <> pass do
X curMove := curMove^.slink;
X forwardTo(curMove);
Xend { selPass };
X
Xprocedure switchBranch(bm: pMRec);
Xvar
X tm: pMRec;
Xbegin { switchBranch }
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X if gameOver then
X restoreDead;
X wipeTreeMarks;
X tm := bm;
X while tm <> treeRoot do
X begin
X tm^.mark := true;
X tm := tm^.blink;
X end;
X treeRoot^.mark := true;
X while not curMove^.mark do
X backup1;
X while curMove <> bm do
X begin
X tm := curMove^.flink;
X while not tm^.mark do
X tm := tm^.slink;
X forwardTo(tm);
X end;
Xend { switchBranch };
X
Xfunction stepTagPossible: boolean;
Xbegin { stepTagPossible }
X if treeRoot^.lastTag = nil then
X stepTagPossible := false
X else if stepTag = nil then
X stepTagPossible := true
X else if curMove = treeRoot then
X stepTagPossible := true
X else if curMove^.tag = stepTag then
X stepTagPossible := false
X else
X stepTagPossible := true;
Xend { stepTagPossible };
X
Xprocedure doStepTag;
Xvar
X tm: pMRec;
Xbegin { doStepTag }
X if stepTag = nil then
X exit(doStepTag);
X if dotSX >= 0 then
X begin
X dotStone(dotSX, dotSY);
X dotSX := -1;
X end;
X if gameOver then
X restoreDead;
X tm := stepTag^.mPtr;
X if curMove = tm then
X exit(doStepTag);
X wipeTreeMarks;
X while tm <> treeRoot do
X begin
X tm^.mark := true;
X tm := tm^.blink;
X end;
X treeRoot^.mark := true;
X if not curMove^.mark then
X begin
X prompt('Backed up to proper branch');
X repeat
X backup1;
X until curMove^.mark;
X end
X else
X begin
X tm := curMove^.flink;
X while not tm^.mark do
X tm := tm^.slink;
X forwardTo(tm);
X end;
Xend { doStepTag };
X
Xprocedure scoreGame(var ws, bs: integer);
Xvar
X i, j, size: integer;
X bSeen, wSeen: boolean;
X
X procedure spanEmpties(bx, by: integer);
X begin { spanEmpties }
X if (bx >= 0) and (bx <= maxPoint) and
X (by >= 0) and (by <= maxPoint) then
X begin
X if board[bx, by].val = white then
X wSeen := true
X else if board[bx, by].val = black then
X bSeen := true
X else if not board[bx, by].marked then
X begin
X board[bx, by].marked := true;
X size := size + 1;
X spanEmpties(bx - 1, by);
X spanEmpties(bx + 1, by);
X spanEmpties(bx, by - 1);
X spanEmpties(bx, by + 1);
X end;
X end;
X end { spanEmpties };
X
Xbegin { scoreGame }
X ws := 0;
X bs := 0;
X wipeMarks;
X for j := 0 to maxPoint do
X for i := 0 to maxPoint do
X if (not board[i, j].marked) and
X (board[i, j].val = empty) then
X begin
X bSeen := false;
X wSeen := false;
X size := 0;
X spanEmpties(i, j);
X if bSeen and not wSeen then
X bs := bs + size
X else if wSeen and not bSeen then
X ws := ws + size;
X end;
Xend { scoreGame };
X
Xprocedure putEnd;
Xbegin { putEnd }
X if not gameOver then
X begin
X gameOver := true;
X numEndDead := 0;
X end;
Xend { putEnd };
X
Xprocedure delGroup(bx, by: integer);
Xvar
X sto, other: sType;
X size: integer;
X
X procedure dumpDead(bx, by: integer);
X begin { dumpDead }
X if (bx >= 0) and (bx <= maxPoint) and
X (by >= 0) and (by <= maxPoint) then
X if board[bx, by].val = sto then
X begin
X remStone(bx, by);
X numEndDead := numEndDead + 1;
X with endDead[numEndDead] do
X begin
X dx := bx;
X dy := by;
X with board[bx, by] do
X begin
X dox := xOfs;
X doy := yOfs;
X mn := mNum;
X end;
X whoDead := sto;
X end;
X size := size + 1;
X dumpDead(bx - 1, by);
X dumpDead(bx + 1, by);
X dumpDead(bx, by - 1);
X dumpDead(bx, by + 1);
X end;
X end { dumpDead };
X
Xbegin { delGroup }
X sto := board[bx, by].val;
X size := 0;
X dumpDead(bx, by);
X if sto = white then
X other := black
X else
X other := white;
X captures[other] := captures[other] + size;
Xend { delGroup };
X
Xprocedure dotLast;
Xvar
X tm: pMRec;
Xbegin { dotLast }
X if numbEnabled then
X exit(dotLast);
X if dotSX >= 0 then
X dotStone(dotSX, dotSY);
X dotSX := -1;
X tm := curMove;
X while tm <> treeRoot do
X if tm^.id = pass then
X exit(dotLast)
X else if tm^.id = move then
X with tm^ do
X begin
X dotSX := mx;
X dotSY := my;
X dotStone(mx, my);
X exit(dotLast);
X end
X else
X tm := tm^.blink;
Xend { dotLast };
X
Xprocedure initGoMgr;
Xbegin { initGoMgr }
X moveNum := 0;
X curMove := treeRoot;
X gameOver := false;
X numEndDead := 0;
X dotSX := -1;
X dotSY := -1;
X passShowing := false;
Xend. { initGoMgr }
END_OF_goMgr.pas
if test 20985 -ne `wc -c <goMgr.pas`; then
echo shar: \"goMgr.pas\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 4 \(of 5\).
cp /dev/null ark4isdone
MISSING=""
for I in 1 2 3 4 5 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 5 archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0