From mipos3!omepd!intelisc!littlei!uunet!husc6!mit-eddie!uw-beaver!tektronix!tekgen!tekred!games-request Fri Mar 11 07:30:06 PST 1988 Article 193 of comp.sources.games: Path: td2cad!mipos3!omepd!intelisc!littlei!uunet!husc6!mit-eddie!uw-beaver!tektronix!tekgen!tekred!games-request From: games-request@tekred.TEK.COM Newsgroups: comp.sources.games Subject: v03i099: go - go board manager sources, Part03/05 Message-ID: <2270@tekred.TEK.COM> Date: 9 Mar 88 17:57:05 GMT Sender: billr@tekred.TEK.COM Lines: 2210 Approved: billr@tekred.TEK.COM Submitted by: Fred Hansen 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 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 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