games-request@tekred.TEK.COM (03/10/88)
Submitted by: Fred Hansen <wjh+@andrew.cmu.edu>
Comp.sources.games: Volume 3, Issue 99
Archive-name: go/Part03
#! /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 3 (of 5)."
# Contents: goBoard.pas goTree.pas
# Wrapped by billr@saab on Wed Mar 9 09:14:45 1988
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f goBoard.pas -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"goBoard.pas\"
else
echo shar: Extracting \"goBoard.pas\" \(38053 characters\)
sed "s/^X//" >goBoard.pas <<'END_OF_goBoard.pas'
X{---------------------------------------------------------------}
X{ goBoard.Pas }
X{ }
X{ Board Image Handler for Go }
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 8, 1982 Split From Go.Pas }
X{---------------------------------------------------------------}
X
X
Xmodule goBoard;
X
Xexports
X
Ximports goCom from goCom;
Ximports screen from screen;
X
Xtype
X SoundType = (atari, koV, s3, s4, die, die2, die3, error);
X
Xexception gbFatal;
X
Xprocedure initGoBoard;
Xprocedure clearBoard;
Xprocedure addHCStones(num: integer);
Xprocedure placeStone(which: sType; lx, ly, ofx, ofy, moveNum: integer);
Xprocedure placeAlt(which: sType; lx, ly, ofx, ofy: integer);
Xprocedure remStone(lx, ly: integer);
Xprocedure showPass(which: sType);
Xprocedure remPass;
Xfunction passLocCur(cx, cy: integer): boolean;
Xfunction bLocCur(cx, cy: integer; var lx, ly, sx, sy: integer): boolean;
Xprocedure beep(sound: SoundType);
Xprocedure dotStone(lx, ly: integer);
Xprocedure showAllStones;
Xprocedure printBoard(isDiagram: boolean);
Xprocedure showCaptures;
Xprocedure turnIs(who: sType);
Xprocedure refreshBoard;
Xprocedure putBString(x, y: integer; s: string);
X
Xprivate
X
Ximports raster from raster;
Ximports io_unit from io_unit;
Ximports io_others from io_others;
Ximports memory from memory;
Ximports fileSystem from fileSystem;
Ximports perq_string from perq_string;
Ximports csdx from csdx;
Ximports goMgr from goMgr;
Ximports goTree from goTree;
Ximports goMenu from goMenu;
Ximports system from system;
Ximports go from go;
X
Xconst
X sPicC = 15;
X sPicS = 32;
X hpPicS = 10;
X hpPicC = 4;
X patchS = 40;
X patchC = 19;
X picWW = 4;
X htHeight = 4;
X htWidth = 48;
X gridWidth = 32;
X pGridWidth = 34; { for printing }
X xMargin = boardX + gridWidth;
X yMargin = boardY + gridWidth;
X pxMargin = pBoardX + pGridWidth;
X pyMargin = pBoardY + pGridWidth;
X gridBorder = gridWidth div 2;
X pGridBorder = pGridWidth div 2;
X gridXMargin = xMargin - gridBorder;
X gridYMargin = yMargin - gridBorder;
X pGridXMargin = pxMargin - pGridBorder;
X pGridYMargin = pyMargin - pGridBorder;
X htXMargin = xMargin - gridWidth;
X htYMargin = yMargin - gridWidth;
X phtXMargin = pxMargin - pGridWidth;
X phtYMargin = pyMargin - pGridWidth;
X boardHeight = 20 * gridWidth;
X pBoardHeight = 20 * pGridWidth;
X slopSize = 2;
X lineWidth = 2;
X extraXO = pxMargin; { 96 }
X extraYO = 768;
X pedgeBX = pxMargin; { 96 }
X pedgeBY = pyMargin + (19 * pGridWidth); { 672 }
X pedgeLX = pBoardX; { 64 }
X pedgeLY = pBoardY + (19 * pGridWidth); { 640 }
X edgeBX = xMargin; { 96 }
X edgeBY = yMargin + (19 * GridWidth); { 672 }
X edgeLX = BoardX; { 64 }
X edgeLY = BoardY + (19 * GridWidth); { 640 }
X rCmtY = pBoardX + pBoardHeight + 32;
X lCmtY = rCmtY + 8 + charHeight;
X tFntWidth = 6;
X tFntHeight = 9;
X maxSMark = 2;
X
Xtype
X htArray = array[0..3] of array[0..47] of integer;
X pHtArray = ^htArray;
X
X beepbuf = array[0..63] of integer;
X pBeepBuf = ^BeepBuf;
X
Xvar
X hcDot: pPicBuf;
X htBuf: pHtArray;
X patch: array[1..9] of pPicBuf;
X StatPtr: IOStatPtr;
X statRec: IOStatus;
X sounds: array[atari..die3] of pBeepBuf;
X stones: array[sType] of pPicBuf;
X stoneCir: pPicBuf;
X stoneMarks: array[0..maxSMark] of pPicBuf;
X sysFont: fontPtr;
X goBNumFont: fontPtr;
X goSNumFont: fontPtr;
X goTNumFont: fontPtr;
X goSLetFont: fontPtr;
X printing: boolean;
X scrSavPtr: rasterPtr;
X sNumBase, sNumStart: integer;
X bigNums: boolean;
X
X{ merely beeps the given sound }
Xprocedure beep(sound: SoundType);
Xvar
X zilch: Double;
X rep, i: integer;
X savY, savB, savG, savW, savS: boolean;
Xbegin { beep }
X if sound = error then
X IOBeep
X else
X begin
X savY := tabYellow;
X savW := tabWhite;
X savG := tabGreen;
X savB := tabBlue;
X savS := tabSwitch;
X IOSetModeTablet(offTablet);
X if sound = die then
X rep := 128 * 3
X else
X rep := 128;
X UnitIO(Speech, RECAST(sounds[sound],IOBufPtr), IOWriteHiVol, rep,
X zilch, nil, StatPtr);
X IOSetModeTablet(relTablet);
X tabYellow := savY;
X tabWhite := savW;
X tabGreen := savG;
X tabBlue := savB;
X tabSwitch := savS;
X end;
Xend { beep };
X
Xprocedure showCaptures;
Xvar
X s: string;
X
X procedure dectos(val: integer);
X var
X numC, i: integer;
X ts: string;
X c: char;
X begin { dectos }
X if val = 0 then
X s := '0'
X else
X begin
X numC := 0;
X adjust(ts, 20);
X while val <> 0 do
X begin
X numC := numC + 1;
X ts[numC] := chr(val mod 10 + ord('0'));
X val := val div 10;
X end;
X adjust(s, numC);
X for i := 1 to numC do
X s[i] := ts[numC - i + 1];
X end;
X end { dectos };
X
Xbegin { showCaptures }
X dectos(captures[black]);
X SSetCursor(captNBX, captNY);
X write(s:3);
X dectos(captures[white]);
X SSetCursor(captNWX, captNY);
X write(s:3);
Xend { showCaptures };
X
Xprocedure turnIs(who: sType);
Xbegin { turnIs }
X SSetCursor(turnX, turnY);
X if who = white then
X write('White to Play')
X else
X write('Black to Play');
Xend { turnIs };
X
Xprocedure putBString(x, y: integer; s: string);
Xvar
X xp, yp, sw, i: integer;
X fnt: fontPtr;
Xbegin { putBString }
X setFont(goSNumFont);
X fnt := goSNumFont;
X for i := 1 to length(s) do
X if (s[i] >= '0') and
X (s[i] <= '9') then
X s[i] := chr(ord(s[i]) - #46 + #200);
X xp := x * gridWidth + xMargin;
X yp := y * gridWidth + yMargin;
X sw := 0;
X for i := 1 to length(s) do
X sw := sw + fnt^.index[lAnd(ord(s[i]), #177)].width;
X xp := xp - (sw div 2);
X yp := yp + (fnt^.height div 2) + 1;
X SChrFunc(0);
X SSetCursor(xp, yp);
X write(s:0);
Xend { putBString };
X
Xprocedure putStone(cx, cy, mNum: integer; val: bVal);
Xconst
X widthPad = 2;
X shPad = 3;
X bhPad = 1;
Xvar
X x, y, org: integer;
X ns: string;
X sl, d, sw, n: integer;
X cv: integer;
X fnt: fontPtr;
X heightPad: integer;
Xbegin { putStone }
X x := cx - sPicC;
X y := cy - sPicC;
X rasterop(RAndNot, sPicS, sPicS, x, y, SScreenW, SScreenP,
X 0, 0, picWW, stones[black]);
X rasterop(ROr, sPicS, sPicS, x, y, SScreenW, SScreenP,
X 0, 0, picWW, stones[val]);
X if numbEnabled and (mNum > 0) then
X begin
X n := mNum - sNumBase;
X if n < 0 then
X exit(putStone);
X n := n + sNumStart;
X if bigNums then
X begin
X fnt := goBNumFont;
X heightPad := bhPad;
X end
X else
X begin
X fnt := goSNumFont;
X heightPad := shPad;
X end;
X if val = black then
X if bigNums then
X begin
X if n > 9 then
X org := ord('`')
X else
X org := ord('j');
X end
X else
X begin
X if n > 99 then
X org := #24
X else
X org := #0;
X end
X else if bigNums then
X begin
X if n > 9 then
X org := ord('@')
X else
X org := ord('J');
X end
X else
X begin
X if n > 99 then
X org := #12
X else
X org := #60;
X end;
X ns := ' ';
X sl := 0;
X sw := 0;
X if n >= 100 then
X d := 100
X else if n >= 10 then
X d := 10
X else
X d := 1;
X while d > 0 do
X begin
X sl := sl + 1;
X cv := (n div d) + org;
X ns[sl] := chr(cv + #200);
X sw := sw + fnt^.index[cv].width;
X n := n mod d;
X d := d div 10;
X end;
X adjust(ns, sl);
X x := cx - (sw div 2) + widthPad;
X y := cy + (fnt^.height div 2) + heightPad;
X setFont(fnt);
X SSetCursor(x, y);
X SChrFunc(6);
X write(ns);
X setFont(sysFont);
X SChrFunc(0);
X end;
Xend { putStone };
X
Xprocedure showStone(lx, ly: integer);
Xvar
X x, y: integer;
Xbegin { showStone }
X with board[lx, ly] do
X begin
X if printing then
X if printLarge then
X begin
X x := lx * pGridWidth + pxMargin;
X y := ly * pGridWidth + pyMargin;
X end
X else { small board }
X begin
X x := lx * gridWidth + xMargin;
X y := ly * gridWidth + yMargin;
X end
X else { not printing }
X begin
X x := lx * gridWidth + xMargin + xOfs;
X y := ly * gridWidth + yMargin + yOfs;
X end;
X putStone(x, y, mNum, val);
X end;
Xend { showStone };
X
Xprocedure showAllStones;
Xvar
X i, j: integer;
Xbegin { showAllStones }
X for j := 0 to maxPoint do
X for i := 0 to maxPoint do
X if board[i, j].val <> empty then
X showStone(i, j);
Xend { showAllStones };
X
Xprocedure dotStone(lx, ly: integer);
Xvar
X x, y: integer;
Xbegin { dotStone }
X with board[lx, ly] do
X if val <> empty then
X begin
X x := lx * gridWidth + xMargin + xOfs;
X y := ly * gridWidth + yMargin + yOfs;
X rasterop(rNot, 2, 2, x, y, SScreenW, SScreenP,
X x, y, SScreenW, SScreenP);
X end;
Xend { dotStone };
X
Xfunction bLocCur(cx, cy: integer; var lx, ly, sx, sy: integer): boolean;
Xvar
X xic, yic: integer;
Xbegin { bLocCur }
X bLocCur := false;
X if printing and printLarge then
X begin
X cx := cx - pGridXMargin;
X cy := cy - pGridYMargin;
X end
X else
X begin
X cx := cx - gridXMargin;
X cy := cy - gridYMargin;
X end;
X if (cx >= 0) and (cy >= 0) then
X begin
X if printing and printLarge then
X begin
X lx := cx div pGridWidth;
X ly := cy div pGridWidth;
X xic := lx * pGridWidth + pGridBorder;
X yic := ly * pGridWidth + pGridBorder;
X end
X else
X begin
X lx := cx div gridWidth;
X ly := cy div gridWidth;
X xic := lx * gridWidth + gridBorder;
X yic := ly * gridWidth + gridBorder;
X end;
X if (lx <= maxPoint) and (ly <= maxPoint) then
X begin
X if cx < xic - slopSize then
X cx := xic - slopSize
X else if cx > xic + slopSize then
X cx := xic + slopSize;
X if cy < yic - slopSize then
X cy := yic - slopSize
X else if cy > yic + slopSize then
X cy := yic + slopSize;
X sx := cx - xic;
X sy := cy - yic;
X bLocCur := true;
X end;
X end;
Xend { bLocCur };
X
Xprocedure showPass(which: sType);
Xbegin { showPass }
X SSetCursor(passX, passY);
X if which = black then
X write(' Black Passes ')
X else
X write(' White Passes ');
X passShowing := true;
Xend { showPass };
X
Xprocedure remPass;
Xbegin { remPass }
X SSetCursor(passX, passY);
X write(' ');
X passShowing := false;
Xend { remPass };
X
Xfunction passLocCur(cx, cy: integer): boolean;
Xbegin { passLocCur }
X passLocCur := (cx >= passX) and (cx < (passX + passW)) and
X (cy <= passY) and (cy > (passY - passH));
Xend { passLocCur };
X
Xprocedure showAlt(lx, ly: integer; sv: sType);
Xbegin { showAlt }
X with board[lx, ly] do
X begin
X lx := lx * gridWidth + xMargin - sPicC;
X ly := ly * gridWidth + yMargin - sPicC;
X rasterop(ROr, sPicS, sPicS, lx, ly, SScreenW, SScreenP,
X 0, 0, picWW, stoneCir);
X end;
Xend { showAlt };
X
Xprocedure placeStone(which: sType; lx, ly, ofx, ofy, moveNum: integer);
Xbegin { placeStone }
X if passShowing then
X remPass;
X with board[lx, ly] do
X begin
X val := which;
X xOfs := ofx;
X yOfs := ofy;
X mNum := moveNum;
X showStone(lx, ly);
X end;
Xend { placeStone };
X
Xprocedure placeAlt(which: sType; lx, ly, ofx, ofy: integer);
Xbegin { placeAlt }
X with board[lx, ly] do
X begin
X val := alternate;
X xOfs := 0;
X yOfs := 0;
X mNum := -1;
X showAlt(lx, ly, which);
X end;
Xend { placeAlt };
X
Xprocedure remStone(lx, ly: integer);
Xvar
X x, y, i, j: integer;
Xbegin { remStone }
X with board[lx, ly] do
X if val <> empty then
X begin
X val := empty;
X if ly = 0 then
X i := 1
X else if ly = maxPoint then
X i := 7
X else i := 4;
X if lx = maxPoint then
X i := i + 2
X else if lx > 0 then
X i := i + 1;
X if printing and printLarge then
X begin
X x := (lx * pGridWidth) - patchC + pxMargin;
X y := (ly * pGridWidth) - patchC + pyMargin;
X end
X else
X begin
X x := (lx * gridWidth) - patchC + xMargin;
X y := (ly * gridWidth) - patchC + yMargin;
X end;
X rasterop(RRpl, patchS, patchS, x, y, SScreenW, SScreenP,
X 0, 0, picWW, patch[i]);
X if ((lx = 3) and (ly = 3)) or
X ((lx = 9) and (ly = 3)) or
X ((lx = 15) and (ly = 3)) or
X ((lx = 3) and (ly = 9)) or
X ((lx = 9) and (ly = 9)) or
X ((lx = 15) and (ly = 9)) or
X ((lx = 3) and (ly = 15)) or
X ((lx = 9) and (ly = 15)) or
X ((lx = 15) and (ly = 15)) then
X if printing and printLarge then
X rasterop(ROr, hpPicS, hpPicS,
X pxMargin + (pGridWidth * lx) - hpPicC,
X pyMargin + (pGridWidth * ly) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot)
X else
X rasterop(ROr, hpPicS, hpPicS,
X xMargin + (gridWidth * lx) - hpPicC,
X yMargin + (gridWidth * ly) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X for i := lx - 1 to lx + 1 do
X for j := ly - 1 to ly + 1 do
X if (i >= 0) and (i <= maxPoint) and
X (j >= 0) and (j <= maxPoint) then
X if (board[i, j].val = black) or
X (board[i, j].val = white) then
X begin
X showStone(i, j);
X if (i = dotSX) and (j = dotSY) then
X dotStone(i, j);
X end;
X end;
Xend { remStone };
X
Xprocedure addHCStones(num: integer);
Xbegin { addHCStones }
X case num of
X 2:
X begin
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X end;
X 3:
X begin
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X placeStone(black, 15, 15, 0, 0, 0);
X end;
X 4:
X begin
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X placeStone(black, 3, 3, 0, 0, 0);
X placeStone(black, 15, 15, 0, 0, 0);
X end;
X 5:
X begin
X placeStone(black, 3, 3, 0, 0, 0);
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 9, 9, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X placeStone(black, 15, 15, 0, 0, 0);
X end;
X 6:
X begin
X placeStone(black, 3, 3, 0, 0, 0);
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 3, 9, 0, 0, 0);
X placeStone(black, 15, 9, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X placeStone(black, 15, 15, 0, 0, 0);
X end;
X 7:
X begin
X placeStone(black, 3, 3, 0, 0, 0);
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 3, 9, 0, 0, 0);
X placeStone(black, 9, 9, 0, 0, 0);
X placeStone(black, 15, 9, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X placeStone(black, 15, 15, 0, 0, 0);
X end;
X 8:
X begin
X placeStone(black, 3, 3, 0, 0, 0);
X placeStone(black, 3, 9, 0, 0, 0);
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 9, 3, 0, 0, 0);
X placeStone(black, 9, 15, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X placeStone(black, 15, 9, 0, 0, 0);
X placeStone(black, 15, 15, 0, 0, 0);
X end;
X 9:
X begin
X placeStone(black, 3, 3, 0, 0, 0);
X placeStone(black, 3, 9, 0, 0, 0);
X placeStone(black, 3, 15, 0, 0, 0);
X placeStone(black, 9, 3, 0, 0, 0);
X placeStone(black, 9, 9, 0, 0, 0);
X placeStone(black, 9, 15, 0, 0, 0);
X placeStone(black, 15, 3, 0, 0, 0);
X placeStone(black, 15, 9, 0, 0, 0);
X placeStone(black, 15, 15, 0, 0, 0);
X end;
X end;
Xend { addHCStones };
X
Xprocedure drawBoard;
Xvar
X i, j, c, lWidth, x, y, w: integer;
X xMarg, yMarg, gWid, eBX, eBY, eLX, eLY: integer;
Xbegin { drawBoard }
X if printing then
X begin
X lWidth := 1;
X if printLarge then
X begin
X xMarg := pxMargin;
X yMarg := pyMargin;
X gWid := pGridWidth;
X eBX := pedgeBX;
X eBY := pedgeBY;
X eLX := pedgeLX;
X eLY := pedgeLY;
X end
X else
X begin
X xMarg := xMargin;
X yMarg := yMargin;
X gWid := gridWidth;
X eBX := edgeBX;
X eBY := edgeBY;
X eLX := edgeLX;
X eLY := edgeLY;
X end
X end
X else
X begin
X lWidth := lineWidth;
X xMarg := xMargin;
X yMarg := yMargin;
X gWid := gridWidth;
X end;
X if not printing then
X for i := (htYMargin div htHeight) to
X ((htYMargin + boardHeight) div htHeight) - 1 do
X rasterop(RRpl, bWinW - (htXMargin * 2), htHeight,
X htXMargin, i * htHeight, SScreenW, SScreenP,
X htXMargin, 0, htWidth, htBuf)
X else
X rasterop(rAndNot, bWinW - (phtXMargin * 2), (bWinY + bWinH) - phtYMargin,
X phtXMargin, phtYMargin, SScreenW, SScreenP,
X phtXMargin, phtYMargin, SScreenW, SScreenP);
X for i := 1 to maxPoint - 1 do
X rasterop(ROrNot, (maxPoint * gWid) + lWidth, lWidth,
X xMarg, yMarg + (i * gWid), SScreenW, SScreenP,
X xMarg, yMarg + (i * gWid), SScreenW, SScreenP);
X for i := 1 to maxPoint - 1 do
X rasterop(ROrNot, lWidth, (maxPoint * gWid) + lWidth,
X xMarg + (i * gWid), yMarg, SScreenW, SScreenP,
X xMarg + (i * gWid), yMarg, SScreenW, SScreenP);
X rasterop(ROrNot, (maxPoint * gWid) + lineWidth, lineWidth,
X xMarg, yMarg, SScreenW, SScreenP,
X xMarg, yMarg, SScreenW, SScreenP);
X rasterop(ROrNot, (maxPoint * gWid) + lineWidth, lineWidth,
X xMarg, yMarg + (maxPoint * gWid), SScreenW, SScreenP,
X xMarg, yMarg + (maxPoint * gWid), SScreenW, SScreenP);
X rasterop(ROrNot, lineWidth, (maxPoint * gWid) + lineWidth,
X xMarg, yMarg, SScreenW, SScreenP,
X xMarg, yMarg, SScreenW, SScreenP);
X rasterop(ROrNot, lineWidth, (maxPoint * gWid) + lineWidth,
X xMarg + (maxPoint * gWid), yMarg, SScreenW, SScreenP,
X xMarg + (maxPoint * gWid), yMarg, SScreenW, SScreenP);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 3) - hpPicC,
X yMarg + (gWid * 3) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 9) - hpPicC,
X yMarg + (gWid * 3) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 15) - hpPicC,
X yMarg + (gWid * 3) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 3) - hpPicC,
X yMarg + (gWid * 9) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 9) - hpPicC,
X yMarg + (gWid * 9) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 15) - hpPicC,
X yMarg + (gWid * 9) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 3) - hpPicC,
X yMarg + (gWid * 15) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 9) - hpPicC,
X yMarg + (gWid * 15) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X rasterop(ROr, hpPicS, hpPicS,
X xMarg + (gWid * 15) - hpPicC,
X yMarg + (gWid * 15) - hpPicC,
X SScreenW, SScreenP,
X 0, 0, picWW, hcDot);
X if not printing then
X begin
X SSetCursor(captBX, captY);
X write('Black Captures');
X SSetCursor(captWX, captY);
X write('White Captures');
X end
X else
X begin
X for i := 1 to maxPoint + 1 do
X begin
X if i > 9 then
X w := charWidth * 2
X else
X w := charWidth;
X x := ((i - 1) * gWid) + eBX - (w div 2);
X y := eBY + charHeight;
X SSetCursor(x, y);
X write(i:0);
X end;
X for i := 0 to maxPoint do
X begin
X x := eLX - charWidth;
X y := eLY - ((maxPoint - i) * gWid) + (charHeight div 2);
X c := i + ord('A');
X if c >= ord('I') then
X c := c + 1;
X SSetCursor(x, y);
X SPutChr(chr(c));
X end;
X end;
Xend { drawBoard };
X
Xprocedure clearBoard;
Xvar
X i, j, xMarg, yMarg, gWid: integer;
Xbegin { clearBoard }
X drawBoard;
X if printing and printLarge then
X begin
X xMarg := pxMargin;
X yMarg := pyMargin;
X gWid := pGridWidth;
X end
X else
X begin
X xMarg := xMargin;
X yMarg := yMargin;
X gWid := gridWidth;
X end;
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[1],
X xMarg + (0 * gWid) - patchC,
X yMarg + (0 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[2],
X xMarg + (6 * gWid) - patchC,
X yMarg + (0 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[3],
X xMarg + (18 * gWid) - patchC,
X yMarg + (0 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[4],
X xMarg + (0 * gWid) - patchC,
X yMarg + (6 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[5],
X xMarg + (6 * gWid) - patchC,
X yMarg + (6 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[6],
X xMarg + (18 * gWid) - patchC,
X yMarg + (6 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[7],
X xMarg + (0 * gWid) - patchC,
X yMarg + (18 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[8],
X xMarg + (6 * gWid) - patchC,
X yMarg + (18 * gWid) - patchC,
X SScreenW, SScreenP);
X rasterop(RRpl, patchS, patchS, 0, 0, picWW, patch[9],
X xMarg + (18 * gWid) - patchC,
X yMarg + (18 * gWid) - patchC,
X SScreenW, SScreenP);
X for i := 0 to maxPoint do
X for j := 0 to maxPoint do
X board[i][j].val := empty;
X if not printing then
X remPass;
Xend { clearBoard };
X
Xprocedure showPlayHistory(isDiagram: boolean);
Xvar
X curRow, curCol, bx, by, bLim, curNum: integer;
X cm, scm, tm: pMRec;
X c: char;
X needWipe, lastCapt: boolean;
X
X procedure getMarks;
X var
X bx, by, lbx, lby, gx, gy, sMark, x, y, w: integer;
X curC: char;
X done: boolean;
X begin { getMarks }
X lbx := -1;
X lby := -1;
X curC := 'a';
X sMark := 0;
X prompt('Point at locations to place marks - press off board to stop');
X while tabSwitch do;
X done := false;
X setFont(goSLetFont);
X sChrFunc(rOr);
X repeat
X while not tabSwitch do;
X if bLocCur(tabRelX, tabRelY, bx, by, gx, gy) then
X begin
X if printLarge then
X begin
X x := bx * pGridWidth + pxMargin;
X y := by * pGridWidth + pyMargin;
X end
X else
X begin
X x := bx * GridWidth + xMargin;
X y := by * GridWidth + yMargin;
X end;
X if board[bx, by].val = empty then
X begin
X rasterop(rXor, 20, 30, x - 10, y - 15, SScreenW, SScreenP,
X x - 10, y - 15, SScreenW, SScreenP);
X w := goSLetFont^.index[ord(curC)].width - 2;
X SSetCursor(x - (w div 2), y + 7);
X write(curC);
X curC := chr(ord(curC) + 1);
X end
X else
X begin
X x := x - sPicC;
X y := y - sPicC;
X if (bx = lbx) and (by = lby) then
X begin
X if sMark <= maxSMark then
X begin
X rasterop(RXor, sPicS, sPicS, x, y, SScreenW, SScreenP,
X 0, 0, picWW, stoneMarks[sMark]);
X sMark := sMark + 1;
X end
X else
X sMark := 0;
X end
X else
X sMark := 0;
X if sMark <= maxSMark then
X rasterop(RXor, sPicS, sPicS, x, y, SScreenW, SScreenP,
X 0, 0, picWW, stoneMarks[sMark]);
X end;
X lbx := bx;
X lby := by;
X end
X else
X done := true;
X while tabSwitch do;
X until done;
X sChrFunc(rRpl);
X setFont(sysFont);
X prompt('');
X end { getMarks };
X
Xbegin { showPlayHistory }
X if not isDiagram then
X begin
X bLim := 99;
X sNumBase := 0;
X sNumStart := 0;
X end
X else
X bLim := 1000;
X curNum := 0;
X needWipe := true;
X wipeTreeMarks;
X cm := curMove;
X while cm <> treeRoot do
X begin
X cm^.mark := true;
X cm := cm^.blink;
X end;
X repeat
X if needWipe then
X begin
X rasterop(rAndNot, 768, 1024 - extraYO,
X 0, extraYO, SScreenW, SScreenP,
X 0, extraYO, SScreenW, SScreenP);
X curRow := 0;
X curCol := 0;
X showAllStones;
X needWipe := false;
X end;
X cm := cm^.flink;
X while not cm^.mark do
X cm := cm^.slink;
X with cm^ do
X case id of
X hcPlay:
X begin
X addHCStones(hcNum);
X curNum := 1;
X end;
X move:
X begin
X if board[mx, my].val <> empty then
X begin
X bx := curCol * (20 * charWidth) + extraXO;
X by := curRow * charHeight * 2 + extraYO + charHeight;
X SSetCursor(bx, by);
X if who = black then
X write('Black ')
X else
X write('White ');
X write((moveN - sNumBase):0, ' at ');
X c := chr(my + ord('A'));
X if c >= 'I' then
X c := chr(ord(c) + 1);
X write(c, '-', (mx + 1):0);
X curRow := curRow + 1;
X if (curRow * charHeight * 2 + extraYO + charHeight) > 1000 then
X begin
X curRow := 0;
X curCol := curCol + 1;
X end;
X end
X else
X placeStone(who, mx, my, 0, 0, moveN);
X curNum := moveN;
X lastCapt := false;
X repeat
X if cm^.flink = nil then
X lastCapt := true
X else if cm^.flink^.id = remove then
X begin
X cm := cm^.flink;
X if curNum < sNumBase then
X remStone(cm^.mx, cm^.my);
X end
X else
X lastCapt := true;
X until lastCapt;
X end;
X pass:
X begin
X if not isDiagram then
X begin
X bx := curCol * (20 * charWidth) + extraXO;
X by := curRow * charHeight * 2 + extraYO + charHeight;
X SSetCursor(bx, by);
X if who = black then
X write('Black ')
X else
X write('White ');
X write((moveN - sNumBase):0, ' - Pass');
X curRow := curRow + 1;
X if (curRow * charHeight * 2 + extraYO + charHeight) > 1000 then
X begin
X curRow := 0;
X curCol := curCol + 1;
X end;
X end;
X curNum := moveN;
X end;
X end { case };
X if (curNum = bLim) or
X (cm = curMove) then
X begin
X if isDiagram then
X getMarks;
X csdx;
X if cm <> curMove then
X begin
X sNumBase := bLim + 1;
X bLim := bLim + 100;
X needWipe := true;
X clearBoard;
X scm := curMove;
X curMove := treeRoot;
X switchBranch(cm);
X curMove := scm;
X wipeTreeMarks;
X tm := curMove;
X while tm <> treeRoot do
X begin
X tm^.mark := true;
X tm := tm^.blink;
X end;
X end;
X end;
X until cm = curMove;
X sNumBase := 0;
X sNumStart := 0;
Xend { showPlayHistory };
X
Xprocedure printBoard(isDiagram: boolean);
Xlabel
X 1;
Xvar
X sseg: integer;
X neWas: boolean;
X cmSave: pMRec;
X
X procedure showFName;
X var
X fnX, fnY: integer;
X fs: string;
X begin { showFName }
X getFNameString(fs);
X if fs <> '' then
X begin
X fnY := charHeight + 8;
X fnX := 384 - (charWidth * length(fs) div 2);
X SSetCursor(fnX, fnY);
X write(fs);
X end;
X end { showFName };
X
X procedure showComments(isDiagram: boolean);
X var
X cx: integer;
X cs: string;
X begin { showComments }
X if not isDiagram then
X if getComment(treeRoot, cs) then
X begin
X cx := 384 - (charWidth * length(cs) div 2);
X SSetCursor(cx, rCmtY);
X write(cs);
X end;
X if getComment(curMove, cs) then
X begin
X cx := 384 - (charWidth * length(cs) div 2);
X if isDiagram then
X SSetCursor(cx, charHeight + 8)
X else
X SSetCursor(cx, lCmtY);
X write(cs);
X end;
X end { showComments };
X
X handler ctlC;
X begin { ctlC }
X IOKeyClear;
X resetInput;
X write(''); {control-G}
X prompt('');
X goto 1;
X end { ctlC };
X
X function readNum(pmpt: string): integer;
X label
X 2;
X var
X n: integer;
X
X handler notNumber(fn: pathName);
X begin { notNumber }
X write(''); {control-G}
X prompt('Bad Number - try again: ');
X goto 2;
X end { notNumber };
X
X handler pastEOF(fn: pathName);
X begin { pastEOF }
X write(''); {control-G}
X goto 1;
X end { pastEOF };
X
X begin { readNum }
X prompt('');
X 2:
X resetInput;
X write(pmpt);
X readln(n);
X readNum := n;
X end { readNum };
X
Xbegin { printBoard }
X if curMove = treeRoot then
X begin
X write(''); {control-G}
X exit(printBoard);
X end;
X cmSave := curMove;
X if scrSavPtr = nil then
X begin
X createSegment(sseg, 192, 1, 192);
X scrSavPtr := makePtr(sseg, 0, rasterPtr);
X end;
X rasterop(rRpl, 768, 1024, 0, 0, SScreenW, scrSavPtr,
X 0, 0, SScreenW, SScreenP);
X rasterop(rAndNot, 768, 1024, 0, 0, SScreenW, SScreenP,
X 0, 0, SScreenW, SScreenP);
X printing := true;
X neWas := numbEnabled;
X numbEnabled := true;
X sNumBase := 0;
X sNumStart := 0;
X drawBoard;
X bigNums := false;
X showAllStones;
X if not isDiagram then
X begin
X showComments(false);
X showFName;
X csdx;
X end
X else
X begin
X sNumBase := readNum('Start Numbering at which stone? ');
X sNumStart := readNum('First Number is? ');
X prompt('');
X end;
X clearBoard;
X bigNums := true;
X if isDiagram then
X showComments(true);
X showPlayHistory(isDiagram);
X1:
X rasterop(rRpl, 768, 1024, 0, 0, SScreenW, SScreenP,
X 0, 0, SScreenW, scrSavPtr);
X printing := false;
X numbEnabled := neWas;
X bigNums := false;
X sNumBase := 0;
X sNumStart := 0;
X clearBoard;
X curMove := treeRoot;
X captures[black] := 0;
X captures[white] := 0;
X switchBranch(cmSave);
X curMove := cmSave;
Xend { printBoard };
X
Xprocedure refreshBoard;
Xbegin { refreshBoard }
X drawBoard;
X showAllStones;
X dotSX := -1;
X dotLast;
Xend { refreshBoard };
X
X{ initializes this module }
Xprocedure initGoBoard;
X
X procedure beepInit;
X const
X size = (WordSize(beepBuf) * 7 + 255) div 256;
X var
X d: SoundType;
X i,j: integer;
X beepSeg: integer;
X begin { beepInit }
X createSegment(beepSeg, size, 1, size);
X new(0,4,StatPtr);
X for d := atari to die3 do
X new(beepSeg, 4, sounds[d]);
X for i := 0 to 63 do
X begin
X sounds[atari]^[i] := 511;
X case i mod 3 of
X 0: sounds[koV]^[i] := -5;
X 1: sounds[koV]^[i] := 34;
X 2: sounds[koV]^[i] := 0;
X end;
X case i mod 4 of
X 0: sounds[s3]^[i] := 1023;
X 1: sounds[s3]^[i] := 0;
X 2: sounds[s3]^[i] := -1;
X 3: sounds[s3]^[i] := -1023;
X end;
X case i mod 5 of
X 0: sounds[s4]^[i] := 43;
X 1: sounds[s4]^[i] := 765;
X 2: sounds[s4]^[i] := -432;
X 3: sounds[s4]^[i] := -6;
X 4: sounds[s4]^[i] := 345;
X end;
X end;
X for i := 0 to 1 do
X for j := 0 to 15 do
X begin
X sounds[die]^[i*32+j] := -1;
X sounds[die]^[i*32+16+j] := 0;
X end;
X for i := 0 to 63 do
X begin
X sounds[die2]^[i] := sounds[die]^[i];
X sounds[die3]^[i] := sounds[die]^[i];
X end;
X end { beepInit };
X
X procedure definePats;
X var
X i, j, blks, gbg: integer;
X fid: fileID;
X begin { definePats }
X fid := FSLookup('go.animate', blks, gbg);
X if fid = 0 then
X begin
X writeln('GO.ANIMATE not found');
X raise gbFatal;
X end
X else if blks < 8 then
X begin
X writeln('GO.ANIMATE too short');
X raise gbFatal;
X end;
X new(0, 4, stones[black]);
X FSBlkRead(fid, 0, recast(stones[black], pDirBlk));
X new(0, 4, stones[white]);
X FSBlkRead(fid, 1, recast(stones[white], pDirBlk));
X new(0, 4, hcDot);
X FSBlkRead(fid, 2, recast(hcDot, pDirBlk));
X new(0, 4, selCursor);
X FSBlkRead(fid, 3, recast(selCursor, pDirBlk));
X new(0, 4, stoneCir);
X FSBlkRead(fid, 4, recast(stoneCir, pDirBlk));
X new(0, 4, stoneMarks[0]);
X FSBlkRead(fid, 5, recast(stoneMarks[0], pDirBlk));
X new(0, 4, stoneMarks[1]);
X FSBlkRead(fid, 6, recast(stoneMarks[1], pDirBlk));
X new(0, 4, stoneMarks[2]);
X FSBlkRead(fid, 7, recast(stoneMarks[2], pDirBlk));
X new(0, 4, htBuf);
X for i := 0 to 47 do
X htBuf^[0, i] := #125252;
X for i := 0 to 47 do
X htBuf^[1, i] := 0;
X for i := 0 to 47 do
X htBuf^[2, i] := #125252; { #52525 }
X for i := 0 to 47 do
X htBuf^[3, i] := 0;
X for i := 1 to 9 do
X new(0, 4, patch[i]);
X end { definePats };
X
X procedure setupFont;
X var
X bblks, sblks, tBlks, lBlks, bits, fontseg, i: integer;
X bFID, sFID, tFID, lFID: fileID;
X bp: pDirBlk;
X begin { setupFont }
X sysFont := getFont;
X bFID := FSLookup('goBNum.kst', bblks, bits);
X if bFID = 0 then
X begin
X writeln('goBNum.KST not found');
X raise gbFatal;
X end;
X sFID := FSLookup('goSNum.kst', sblks, bits);
X if sFID = 0 then
X begin
X writeln('goSNum.KST not found');
X raise gbFatal;
X end;
X tFID := FSLookup('goTNum.kst', tblks, bits);
X if sFID = 0 then
X begin
X writeln('goTNum.KST not found');
X raise gbFatal;
X end;
X lFID := FSLookup('goSLets.kst', lBlks, bits);
X if lFID = 0 then
X begin
X writeln('goSLets.KST not found');
X raise gbFatal;
X end;
X createSegment(fontseg, bblks + sblks + tBlks + lBlks, 1,
X bblks + sblks + tBlks + lBlks);
X for i := 0 to bblks - 1 do
X begin
X bp := makePtr(fontSeg, i * 256, pDirBlk);
X FSBlkRead(bFID, i, bp);
X end;
X goBNumFont := makePtr(fontseg, 0, fontPtr);
X for i := 0 to sblks - 1 do
X begin
X bp := makePtr(fontSeg, (i + bblks) * 256, pDirBlk);
X FSBlkRead(sFID, i, bp);
X end;
X goSNumFont := makePtr(fontseg, bblks * 256, fontPtr);
X for i := 0 to tblks - 1 do
X begin
X bp := makePtr(fontSeg, (i + bblks + sBlks) * 256, pDirBlk);
X FSBlkRead(tFID, i, bp);
X end;
X goTNumFont := makePtr(fontseg, (bblks + sBlks) * 256, fontPtr);
X for i := 0 to lBlks - 1 do
X begin
X bp := makePtr(fontSeg, (i + bblks + sBlks + tBlks) * 256, pDirBlk);
X FSBlkRead(lFID, i, bp);
X end;
X goSLetFont := makePtr(fontseg, (bblks + sBlks + tBlks) * 256, fontPtr);
X end { setupFont };
X
Xbegin { initGoBoard }
X printing := false;
X beepInit;
X definePats;
X setupFont;
X scrSavPtr := nil;
X sNumBase := 0;
X sNumStart := 0;
X bigNums := false;
Xend. { initGoBoard }
X
END_OF_goBoard.pas
echo shar: 4 control characters may be missing from \"goBoard.pas\"
if test 38053 -ne `wc -c <goBoard.pas`; then
echo shar: \"goBoard.pas\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f goTree.pas -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"goTree.pas\"
else
echo shar: Extracting \"goTree.pas\" \(19784 characters\)
sed "s/^X//" >goTree.pas <<'END_OF_goTree.pas'
X{---------------------------------------------------------------}
X{ GoTree.Pas }
X{ }
X{ Go Game Tree 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{ Nov 15, 1982 Added tag and comment deletion }
X{ Jan 5, 1983 Increased segment max sizes }
X{ Jan 7, 1983 Changed File Format to have global comment }
X{---------------------------------------------------------------}
X
Xmodule goTree;
X
Xexports
X
Ximports goCom from goCom;
Ximports getTimeStamp from getTimeStamp;
X
Xtype
X pMRec = ^moveRec;
X
X tagStr = string[maxTagLen];
X tagPtr = ^tagRec;
X tagRec = record
X mPtr: pMRec;
X nextTag: tagPtr;
X sTag: tagStr;
X end;
X
X mType = (header, move, remove, hcPlay, pass);
X moveRec = packed record
X mark: boolean;
X flink: pMRec;
X case id: mType of
X header:
X (lastMove: pMRec;
X freePool: pMRec;
X lastTag: tagPtr;
X nextMRec: integer;
X nextMBlock: integer;
X nextTRec: integer;
X nextTBlock: integer;
X nextCIdx: integer;
X nextCBlock: integer;
X freeTags: tagPtr);
X hcPlay, move, remove, pass:
X (blink: pMRec;
X slink: pMRec;
X tag: tagPtr;
X who: sType;
X moveN: integer;
X cmtBase: integer;
X cmtLen: integer;
X case {id:} mType of
X hcPlay:
X (hcNum: integer);
X move, remove:
X (mx: integer;
X my: integer;
X ox: integer;
X oy: integer;
X kx: integer;
X ky: integer) )
X end;
X
X baseBlock = packed record
X case boolean of
X false:
X (padding: array[1..512] of char);
X true:
X (randBool: boolean;
X oldTest: pointer;
X fileVersion: integer;
X created: timeStamp;
X rootComment: string[127])
X end;
X
X pBaseBlock = ^baseBlock;
X
Xvar
X treeRoot: pMRec;
X stepTag: tagPtr;
X hdrBlock: pBaseBlock;
X
Xexception goFNF;
Xexception badGoWrite;
Xexception badFileVersion;
X
Xprocedure initGoTree;
Xprocedure makeGoTree;
Xprocedure readTree(nam: string);
Xprocedure writeTree(nam: string; lm: pMRec);
Xfunction newMove(cm: pMRec): pMRec;
Xfunction delBranch(pm: pMRec): pMRec;
Xfunction hasAlts(pm: pMRec): boolean;
Xfunction isBranch(pm: pMRec): boolean;
Xfunction hasBranch(pm: pMRec): boolean;
Xfunction mergeMove(cm: pMRec): pMRec;
Xprocedure tagMove(cm: pMRec; ts: tagStr);
Xfunction tagExists(ts: tagStr): boolean;
Xprocedure commentMove(cm: pMRec; cs: string);
Xfunction getComment(cm: pMRec; var cs: string): boolean;
Xfunction getTag(cm: pMRec; var ts: string): boolean;
Xprocedure delTag(tp: tagPtr);
Xprocedure getFNameString(var fs: string);
X
Xprivate
X
Ximports fileSystem from fileSystem;
Ximports memory from memory;
Ximports perq_string from perq_string;
Ximports clock from clock;
X
Xconst
X curFileVersion = 1;
X minTreeSize = 20;
X minTagSize = 4;
X minCmtSize = 4;
X maxTreeSize = 255;
X maxTagSize = 64;
X maxCmtSize = 128;
X treeSegInc = 8;
X tagSegInc = 4;
X cmtSegInc = 4;
X
Xtype
X caType = packed array[0..1] of char;
X pCmtArray = ^caType;
X
Xvar
X mFID: FileID;
X treeSeg, tagSeg, cmtSeg: integer;
X trSegSize, tagSegSize, cmtSegSize: integer;
X cmtArray: pCmtArray;
X cmtCmpArray: array[1..1024] of pMRec;
X
Xprocedure getFNameString(var fs: string);
Xvar
X ts: string;
Xbegin { getFNameString }
X fs := gameFName;
X if fs <> '' then
X begin
X stampToString(hdrBlock^.created, ts);
X fs := concat(fs, ' ');
X fs := concat(fs, ts);
X end;
Xend { getFNameString };
X
Xfunction isBranch(pm: pMRec): boolean;
Xbegin { isBranch }
X repeat
X if pm = treeRoot then
X begin
X isBranch := false;
X exit(isBranch);
X end;
X pm := pm^.blink;
X until pm^.flink^.slink <> nil;
X isBranch := true;
Xend { isBranch };
X
Xfunction hasBranch(pm: pMRec): boolean;
Xbegin { hasBranch }
X while pm^.flink <> nil do
X if pm^.flink^.slink <> nil then
X begin
X hasBranch := true;
X exit(hasBranch);
X end
X else
X pm := pm^.flink;
X hasBranch := false;
Xend { hasBranch };
X
Xprocedure initSegs(trSize, tagSize, cmtSize: integer);
Xbegin { initSegs }
X if treeSeg <> -1 then
X begin
X changeSize(treeSeg, trSize);
X changeSize(tagSeg, tagSize);
X changeSize(cmtSeg, cmtSize);
X end
X else
X begin
X createSegment(treeSeg, trSize, treeSegInc, maxTreeSize);
X createSegment(tagSeg, tagSize, tagSegInc, maxTagSize);
X createSegment(cmtSeg, cmtSize, cmtSegInc, maxCmtSize);
X end;
X trSegSize := trSize;
X tagSegSize := tagSize;
X cmtSegSize := cmtSize;
Xend { initSegs };
X
Xprocedure initHdrBlock;
Xbegin { initHdrBlock }
X with hdrBlock^ do
X begin
X oldTest := nil;
X fileVersion := curFileVersion;
X getTStamp(created);
X rootComment := '';
X end;
Xend { initHdrBlock };
X
Xprocedure makeGoTree;
Xbegin { makeGoTree }
X initSegs(minTreeSize, minTagSize, minCmtSize);
X initHdrBlock;
X treeRoot := makePtr(treeSeg, 0, pMRec);
X with treeRoot^ do
X begin
X id := header;
X freePool := nil;
X flink := nil;
X lastTag := nil;
X nextMRec := wordSize(moveRec);
X nextMBlock := minTreeSize * 256;
X nextTRec := 0;
X nextTBlock := minTagSize * 256;
X nextCIdx := 0;
X nextCBlock := minCmtSize * 512;
X freeTags := nil;
X end;
X cmtArray := makePtr(cmtSeg, 0, pCmtArray);
X stepTag := nil;
Xend { makeGoTree };
X
Xprocedure readTree(nam: string);
Xtype
X ptrHack = record
X case integer of
X 0: (p: pMRec);
X 1: (pt: tagPtr);
X 2: (po: integer;
X ps: integer);
X end;
Xvar
X size, gbg, i, b: integer;
X pd: pDirBlk;
X ph: ptrHack;
X pm: pMRec;
X tm: tagPtr;
X mBlks, tBlks, cBlks: integer;
Xbegin { readTree }
X initSegs(minTreeSize, minTagSize, minCmtSize);
X mFID := FSLookup(nam, size, gbg);
X if mFID = 0 then
X raise goFNF;
X FSBlkRead(mFID, 0, recast(hdrBlock, pDirBlk));
X if hdrBlock^.oldTest <> nil then
X begin
X initHdrBlock;
X b := 0;
X end
X else if hdrBlock^.fileVersion <> curFileVersion then
X begin
X makeGoTree;
X raise badFileVersion;
X end
X else
X b := 1;
X pd := makePtr(treeSeg, 0, pDirBlk);
X FSBlkRead(mFID, b, pd);
X b := b + 1;
X treeRoot := makePtr(treeSeg, 0, pMRec);
X with treeRoot^ do
X begin
X mBlks := nextMBlock div 256;
X tBlks := nextTBlock div 256;
X cBlks := nextCBlock div 512;
X end;
X initSegs(mBlks, tBlks, cBlks);
X for i := 1 to mBlks - 1 do
X begin
X pd := makePtr(treeSeg, i * 256, pDirBlk);
X FSBlkRead(mFID, b, pd);
X b := b + 1;
X end;
X for i := 0 to tBlks - 1 do
X begin
X pd := makePtr(tagSeg, i * 256, pDirBlk);
X FSBlkRead(mFID, b, pd);
X b := b + 1;
X end;
X for i := 0 to cBlks - 1 do
X begin
X pd := makePtr(cmtSeg, i * 256, pDirBlk);
X FSBlkRead(mFID, b, pd);
X b := b + 1;
X end;
X with treeRoot^ do
X begin
X if freePool <> nil then
X begin
X ph.p := freePool;
X ph.ps := treeSeg;
X freePool := ph.p;
X end;
X if flink <> nil then
X begin
X ph.p := flink;
X ph.ps := treeSeg;
X flink := ph.p;
X end;
X if lastMove <> nil then
X begin
X ph.p := lastMove;
X ph.ps := treeSeg;
X lastMove := ph.p;
X end;
X if lastTag <> nil then
X begin
X ph.pt := lastTag;
X ph.ps := tagSeg;
X lastTag := ph.pt;
X end;
X if freeTags <> nil then
X begin
X ph.pt := freeTags;
X ph.ps := tagSeg;
X freeTags := ph.pt;
X end;
X end;
X i := wordSize(moveRec);
X while i < treeRoot^.nextMRec do
X begin
X pm := makePtr(treeSeg, i, pMRec);
X with pm^ do
X begin
X if flink <> nil then
X begin
X ph.p := flink;
X ph.ps := treeSeg;
X flink := ph.p;
X end;
X if blink <> nil then
X begin
X ph.p := blink;
X ph.ps := treeSeg;
X blink := ph.p;
X end;
X if slink <> nil then
X begin
X ph.p := slink;
X ph.ps := treeSeg;
X slink := ph.p;
X end;
X if tag <> nil then
X begin
X ph.pt := tag;
X ph.ps := tagSeg;
X tag := ph.pt;
X end;
X end;
X i := i + wordSize(moveRec);
X end;
X i := 0;
X while i < treeRoot^.nextTRec do
X begin
X tm := makePtr(tagSeg, i, tagPtr);
X with tm^ do
X begin
X if mPtr <> nil then
X begin
X ph.p := mPtr;
X ph.ps := treeSeg;
X mPtr := ph.p;
X end;
X if nextTag <> nil then
X begin
X ph.pt := nextTag;
X ph.ps := tagSeg;
X nextTag := ph.pt;
X end;
X end;
X i := i + wordSize(tagRec);
X end;
X stepTag := nil;
Xend { readTree };
X
Xprocedure writeTree(nam: string; lm: pMRec);
Xvar
X pd: pDirBlk;
X treeBlks, tagBlks, cmtBlks: integer;
X b, i: integer;
X
X procedure compressCmts;
X var
X numCmts: integer;
X cp: pMRec;
X
X procedure spanComments(m: pMRec);
X begin { spanComments }
X while m <> nil do
X begin
X if m^.cmtLen > 0 then
X begin
X numCmts := numCmts + 1;
X cmtCmpArray[numCmts] := m;
X end;
X spanComments(m^.slink);
X m := m^.flink;
X end;
X end { spanComments };
X
X procedure sortComments;
X var
X i, j: integer;
X t: pMRec;
X begin { sortComments }
X for i := 1 to numCmts - 1 do
X for j := i + 1 to numCmts do
X if cmtCmpArray[i]^.cmtBase > cmtCmpArray[j]^.cmtBase then
X begin
X t := cmtCmpArray[i];
X cmtCmpArray[i] := cmtCmpArray[j];
X cmtCmpArray[j] := t;
X end;
X end { sortComments };
X
X procedure squeezeComments;
X var
X i, j, cgi, lastCB: integer;
X mp: pMRec;
X begin { squeezeComments }
X lastCB := 0;
X for i := 1 to numCmts do
X begin
X if cmtCmpArray[i]^.cmtBase > lastCB then
X begin
X cgi := cmtCmpArray[i]^.cmtBase;
X for j := 0 to cmtCmpArray[i]^.cmtLen - 1 do
X begin
X {$R-}
X cmtArray^[lastCB + j] := cmtArray^[cgi + j];
X {$R=}
X end;
X cmtCmpArray[i]^.cmtBase := lastCB;
X end;
X lastCB := cmtCmpArray[i]^.cmtBase + cmtCmpArray[i]^.cmtLen;
X end;
X treeRoot^.nextCIdx := lastCB;
X end { squeezeComments };
X
X begin { compressCmts }
X numCmts := 0;
X cp := treeRoot^.flink;
X if cp <> nil then
X begin
X spanComments(cp);
X sortComments;
X squeezeComments;
X end;
X end { compressCmts };
X
Xbegin { writeTree }
X mFID := FSEnter(nam);
X if mFID = 0 then
X raise badGoWrite
X else
X begin
X compressCmts;
X with treeRoot^ do
X begin
X lastMove := lm;
X treeBlks := nextMBlock div 256;
X tagBlks := nextTBlock div 256;
X cmtBlks := nextCBlock div 512;
X end;
X FSBlkWrite(mFID, 0, recast(hdrBlock, pDirBlk));
X b := 1;
X for i := 0 to treeBlks - 1 do
X begin
X pd := makePtr(treeSeg, i * 256, pDirBlk);
X FSBlkWrite(mFID, b, pd);
X b := b + 1;
X end;
X for i := 0 to tagBlks - 1 do
X begin
X pd := makePtr(tagSeg, i * 256, pDirBlk);
X FSBlkWrite(mFID, b, pd);
X b := b + 1;
X end;
X for i := 0 to cmtBlks - 1 do
X begin
X pd := makePtr(cmtSeg, i * 256, pDirBlk);
X FSBlkWrite(mFID, b, pd);
X b := b + 1;
X end;
X FSClose(mFID, treeBlks + tagBlks + cmtBlks, 4096);
X end;
Xend { writeTree };
X
Xfunction newMove(cm: pMRec): pMRec;
Xvar
X pm: pMRec;
Xbegin { newMove }
X with treeRoot^ do
X if freePool <> nil then
X begin
X pm := freePool;
X freePool := pm^.flink;
X end
X else
X begin
X if nextMRec + wordSize(moveRec) > nextMBlock then
X begin
X trSegSize := trSegSize + treeSegInc;
X changeSize(treeSeg, trSegSize);
X nextMBlock := nextMBlock + (treeSegInc * 256);
X end;
X pm := makePtr(treeSeg, nextMRec, pMRec);
X nextMRec := nextMRec + wordSize(moveRec);
X end;
X with pm^ do
X begin
X flink := nil;
X blink := cm;
X slink := nil;
X tag := nil;
X cmtLen := 0;
X end;
X if cm^.flink <> nil then
X pm^.slink := cm^.flink;
X cm^.flink := pm;
X newMove := pm;
Xend { newMove };
X
Xprocedure tagMove(cm: pMRec; ts: tagStr);
Xvar
X tp: tagPtr;
Xbegin { tagMove }
X if cm^.tag <> nil then
X cm^.tag^.sTag := ts
X else
X with treeRoot^ do
X begin
X if freeTags <> nil then
X begin
X tp := freeTags;
X freeTags := tp^.nextTag;
X end
X else
X begin
X if nextTRec + wordSize(tagRec) > nextTBlock then
X begin
X tagSegSize := tagSegSize + tagSegInc;
X changeSize(tagSeg, tagSegSize);
X nextTBlock := nextTBlock + (tagSegInc * 256);
X end;
X tp := makePtr(tagSeg, nextTRec, tagPtr);
X nextTRec := nextTRec + wordSize(tagRec);
X end;
X cm^.tag := tp;
X with tp^ do
X begin
X mPtr := cm;
X nextTag := lastTag;
X sTag := ts;
X end;
X lastTag := tp;
X end;
X treeDirty := true;
Xend { tagMove };
X
Xfunction tagExists(ts: tagStr): boolean;
Xvar
X tp: tagPtr;
X
X function upCmp(s1, s2: pString): boolean;
X begin { upCmp }
X convUpper(s1);
X convUpper(s2);
X upCmp := s1 = s2;
X end { upCmp };
X
Xbegin { tagExists }
X tp := treeRoot^.lastTag;
X while tp <> nil do
X if upCmp(tp^.sTag, ts) then
X begin
X tagExists := true;
X exit(tagExists);
X end
X else
X tp := tp^.nextTag;
X tagExists := false;
Xend { tagExists };
X
Xprocedure commentMove(cm: pMRec; cs: string);
Xvar
X sl, i: integer;
Xbegin { commentMove }
X if cm = treeRoot then
X hdrBlock^.rootComment := cs
X else
X begin
X sl := length(cs);
X with cm^ do
X begin
X cmtLen := sl;
X if sl > 0 then
X begin
X cmtBase := treeRoot^.nextCIdx;
X treeRoot^.nextCIdx := cmtBase + sl;
X if cmtBase + cmtLen > treeRoot^.nextCBlock then
X with treeRoot^ do
X begin
X cmtSegSize := cmtSegSize + cmtSegInc;
X changeSize(cmtSeg, cmtSegSize);
X nextCBlock := nextCBlock + (cmtSegInc * 512);
X end;
X for i := 0 to sl - 1 do
X begin
X{$R-}
X cmtArray^[cmtBase + i] := cs[i + 1];
X{$R=}
X end;
X end;
X end;
X end;
X treeDirty := true;
Xend { commentMove };
X
Xfunction getComment(cm: pMRec; var cs: string): boolean;
Xvar
X i: integer;
Xbegin { getComment }
X if cm = treeRoot then
X begin
X cs := hdrBlock^.rootComment;
X getComment := cs <> '';
X end
X else if cm^.cmtLen = 0 then
X getComment := false
X else
X with cm^ do
X begin
X getComment := true;
X adjust(cs, cmtLen);
X for i := 1 to cmtLen do
X begin
X{$R-}
X cs[i] := cmtArray^[cmtBase + i - 1];
X{$R=}
X end;
X end;
Xend { getComment };
X
Xfunction getTag(cm: pMRec; var ts: string): boolean;
Xbegin { getTag }
X if cm = treeRoot then
X getTag := false
X else if cm^.tag = nil then
X getTag := false
X else
X begin
X ts := cm^.tag^.sTag;
X getTag := true;
X end;
Xend { getTag };
X
Xprocedure delTag(tp: tagPtr);
Xvar
X ttp: tagPtr;
Xbegin { delTag }
X tp^.mPtr^.tag := nil;
X tp^.mPtr := nil;
X if stepTag = tp then
X stepTag := nil;
X ttp := treeRoot^.lastTag;
X if ttp = tp then
X treeRoot^.lastTag := tp^.nextTag
X else
X begin
X while ttp^.nextTag <> tp do
X ttp := ttp^.nextTag;
X ttp^.nextTag := tp^.nextTag;
X end;
X tp^.nextTag := treeRoot^.freeTags;
X treeRoot^.freeTags := tp;
Xend { delTag };
X
Xfunction delBranch(pm: pMRec): pMRec;
Xvar
X sm: pMRec;
X
X procedure recDel(m: pMRec);
X var
X tp: tagPtr;
X begin { recDel }
X if m <> nil then
X begin
X recDel(m^.slink);
X recDel(m^.flink);
X m^.blink := nil;
X m^.slink := nil;
X m^.flink := treeRoot^.freePool;
X treeRoot^.freePool := m;
X if m^.tag <> nil then
X delTag(m^.tag);
X end;
X end { recDel };
X
Xbegin { delBranch }
X if pm = treeRoot then
X exit(delBranch);
X while pm^.id = remove do
X pm := pm^.blink;
X if pm^.blink^.flink = pm then
X pm^.blink^.flink := pm^.slink
X else
X begin
X sm := pm^.blink^.flink;
X while sm^.slink <> pm do
X sm := sm^.slink;
X sm^.slink := pm^.slink;
X end;
X pm^.slink := nil;
X delBranch := pm^.blink;
X pm^.blink := nil;
X recDel(pm);
Xend { delBranch };
X
Xprocedure delNode(pm: pMRec);
Xvar
X sm: pMRec;
Xbegin { delNode }
X if pm = treeRoot then
X exit(delNode);
X if pm^.blink^.flink = pm then
X pm^.blink^.flink := pm^.slink
X else
X begin
X sm := pm^.blink^.flink;
X while sm^.slink <> pm do
X sm := sm^.slink;
X sm^.slink := pm^.slink;
X end;
X pm^.blink := nil;
X pm^.slink := nil;
X pm^.flink := treeRoot^.freePool;
X treeRoot^.freePool := pm;
Xend { delNode };
X
Xfunction mergeMove(cm: pMRec): pMRec;
Xvar
X tm: pMRec;
Xbegin { mergeMove }
X tm := cm^.blink^.flink;
X mergeMove := cm;
X while tm <> nil do
X begin
X if tm <> cm then
X with tm^ do
X if id = cm^.id then
X if id = hcPlay then
X begin
X mergeMove := tm;
X delNode(cm);
X exit(mergeMove);
X end
X else if id = pass then
X begin
X if who = cm^.who then
X begin
X mergeMove := tm;
X delNode(cm);
X exit(mergeMove);
X end;
X end
X else if (mx = cm^.mx) and
X (my = cm^.my) and
X (who = cm^.who) then
X begin
X mergeMove := tm;
X delNode(cm);
X exit(mergeMove);
X end;
X tm := tm^.slink;
X end;
X treeDirty := true;
Xend { mergeMove };
X
Xfunction hasAlts(pm: pMRec): boolean;
Xbegin { hasAlts }
X while pm^.id = remove do
X pm := pm^.blink;
X hasAlts := pm^.blink^.flink^.slink <> nil;
Xend { hasAlts };
X
Xprocedure initGoTree;
Xbegin { initGoTree }
X treeSeg := -1;
X new(0, 256, hdrBlock);
Xend. { initGoTree }
END_OF_goTree.pas
if test 19784 -ne `wc -c <goTree.pas`; then
echo shar: \"goTree.pas\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 3 \(of 5\).
cp /dev/null ark3isdone
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