Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/games/volume3/go/part04/go.pas

Pascal/Delphi Source File | 1988-03-09 | 26KB | 1,001 lines

{---------------------------------------------------------------}
{ Go Game Manager                                               }
{ Copyright (c) 1982 by Three Rivers Computer Corp.             }
{                                                               }
{ Written: June 3, 1982 by Stoney Ballard                       }
{ Edit History:                                                 }
{    June  3, 1982 Started                                      }
{    June  4, 1982 Add dead group removal                       }
{    June 10, 1982 Use new go file manager                      }
{    Nov  10, 1982 Extensively Hacked Up                        }
{    Dec  29, 1982 Changed "Erase Branch" to "Prune Branches"   }
{    Jan   6, 1983 Added ^C escape from all readlns             }
{---------------------------------------------------------------}

program Go;

exports

imports stream from stream;

procedure resetInput;

private

imports system from System;
imports raster from raster;
imports screen from screen;
imports popUp from popUp;
imports IO_Others from IO_Others;
imports goCom from goCom;
imports goMgr from goMgr;
imports goTree from goTree;
imports goBoard from goBoard;
imports goMenu from goMenu;
imports memory from memory;
imports perq_string from perq_string;
imports goPlayer from goPlayer;

label
  99;       (* the fatal error point *)

var
  oCurPosX, oCurPosY: integer;
  oScreenPtr: rasterPtr;

  procedure resetInput;
  begin { resetInput }
    streamKeyboardReset(input);
  end { resetInput };

  procedure newTitle;
  var
    ts: string[128];
    fn: string;
    fl, fPos, tPos, i: integer;
  begin { newTitle }
    ts := 'Go  Version ';
    ts := concat(ts, version);
    getFNameString(fn);
    fl := length(fn);
    if fl > 0 then
      begin
        fPos := 81 - fl;
        tPos := length(ts) + 1;
        adjust(ts, 80);
        for i := tPos to 80 do
          ts[i] := ' ';
        for i := fPos to fPos + fl - 1 do
          ts[i] := fn[i - fPos + 1];
      end;
    changeTitle(ts);
  end { newTitle };

  procedure initialize;
  var
    sseg: integer;

    procedure setupWindows;
    var
      ts: string;
    begin { setupWindows }
      createWindow(boardWin, bWinX, bWinY, bWinW, bWinH, ' ');
      createWindow(menuWin, mWinX, mWinY, mWinW, mWinH, '');
      createWindow(statWin, sWinX, sWinY, sWinW, sWinH, '');
      changeWindow(0);
      gameFName := '';
      newTitle;
    end { setupWindows };

  begin { initialize }
    createSegment(sseg, 192, 1, 192);
    oScreenPtr := makePtr(sseg, 0, rasterPtr);
    SReadCursor(oCurPosX, oCurPosY);
    rasterop(rRpl, 768, 1024, 0, 0, SScreenW, oScreenPtr,
                              0, 0, SScreenW, SScreenP);
    IOSetFunction(CTCursCompl);
    rasterop(RAndNot, 768, 1024, 0, 0, SScreenW, SScreenP,
                                 0, 0, SScreenW, SScreenP);
    setupWindows;
    initMenu;
    captures[black] := 0;
    captures[white] := 0;
    initGoTree;
    initGoBoard;
    makeGoTree;
    initGoMgr;
    gameFName := '';
    numbEnabled := false;
    treeDirty := false;
    playLevel := 0;
    debug := false;
    printLarge := true;
    initGoPlayer;
  end { initialize };

  procedure doit;
  var
    done, foundIt, endLoop, gbg: boolean;
    CtlCseen, playMyself, lastWasPass: boolean;
    whoseTurn, whoWasLast: sType;
    i, xi, yi, xs, ys: integer;
    numDead, numHC, cmd: integer;
    lastBuM: integer;
    thisTag: tagPtr;
    lastMove: pMRec;

    function getLine(var l: string): boolean;
    label
      1;
    var
      i, j, cx, cy: integer;

      handler ctlC;
      begin { ctlC }
        IOKeyClear;
        streamKeyboardReset(input);
        beep(error);
        prompt('');
        l := '';
        getLine := false;
        exit(getLine);
      end { ctlC };

      handler pastEOF(fn: pathName);
      begin { pastEOF }
        reset(input, fn);
        sSetCursor(cx, cy);
        write('    ');
        sSetCursor(cx, cy);
        goto 1;
      end { pastEOF };

    begin { getLine }
      sReadCursor(cx, cy);
    1:
      readln(l);
      getLine := true;
      j := 0;
      for i := 1 to length(l) do
        if ord(l[i]) >= 32 then
          begin
            j := j + 1;
            l[j] := l[i];
          end;
      adjust(l, j);
    end { getLine };

    procedure resetGame;
    begin { resetGame }
      clearBoard;
      koX := -1;
      koY := -1;
      moveNum := 0;
      curMove := treeRoot;
      captures[black] := 0;
      captures[white] := 0;
      showCaptures;
      whoseTurn := black;
      turnIs(black);
      gameFname := '';
      newTitle;
      gameOver := false;
      initGoMgr;
    end { resetGame };

    procedure switchWho;
    begin { switchWho }
      if curMove = treeRoot then
        whoseTurn := black
      else if curMove^.id = remove then
        whoseTurn := curMove^.who
      else if curMove^.id = hcPlay then
        whoseTurn := white
      else if curMove^.who = black then
        whoseTurn := white
      else
        whoseTurn := black;
      turnIs(whoseTurn);
    end { switchWho };

    procedure updateStatus;
    begin { updateStatus }
      dotLast;
      showCaptures;
      showComment;
      showTag;
      switchWho;
    end { updateStatus };

    procedure doReadGame;
    var
      fName: pathName;

      handler badFileVersion;
      begin { badFileVersion }
        beep(error);
        prompt('');
        write(gameFName, ' is not compatable with this version of GO');
        resetGame;
        exit(doReadGame);
      end { badFileVersion };

    begin { doReadGame }
      if menuGoFile(fName) then
        begin
          prompt('Reading ');
          write(fName, '.Go ...');
          readTree(concat(fName, '.GO'));
          resetGame;
          gameFName := fName;
          if treeRoot^.lastMove <> nil then
            switchBranch(treeRoot^.lastMove);
          treeDirty := false;
          prompt('');
          newTitle;
        end;
    end { doReadGame };

    procedure doWriteGame;
    var
      fs: string;
      procedure addExt(var nam: string);
      var
        es: string;
      begin { addExt }
        if length(nam) > 3 then
          begin
            es := substr(nam, length(nam) - 2, 3);
            convUpper(es);
            if es <> '.GO' then
              nam := concat(nam, '.Go');
          end
        else
          nam := concat(nam, '.Go');
      end { addExt };

      handler badGoWrite;
      begin { badGoWrite };
        beep(error);
        prompt('Unable to write file ');
        write(fs);
        exit(doWriteGame);
      end { badGoWrite };

    begin { doWriteGame }
      IOKeyClear;
      streamKeyboardReset(input);
      if gameFName <> '' then
        begin
          prompt('Game File Name [');
          write(gameFName, ']? ');
        end
      else
        prompt('Game File Name? ');
      if not getLine(fs) then
        exit(doWriteGame);
      if fs = '' then
        if gameFName = '' then
          begin
            beep(error);
            prompt('');
            exit(doWriteGame);
          end
        else
          fs := gameFName;
      gameFName := fs;
      addExt(fs);
      prompt('Writing ');
      write(fs, ' ...');
      writeTree(fs, curMove);
      treeDirty := false;
      prompt('');
      newTitle;
    end { doWriteGame };

    function chooseAlt: boolean;
    label
      10;
    var
      bx, by, xs, ys: integer;
      tm: pMRec;
      hc0There: boolean;
      hcMenu: pNameDesc;
      res: resres;
      numHC, i, j, numNHC: integer;

      handler outside;
      begin { outside }
        destroyNameDesc(hcMenu);
        chooseAlt := false;
        beep(error);
        restoreCursor;
        exit(chooseAlt);
      end { outside };

    begin { chooseAlt }
      chooseAlt := false;
      switchWho;
      waitNoButton;
      tm := curMove^.flink;
      numHC := 0;
      numNHC := 0;
      hc0There := false;
      while tm <> nil do
        begin
          if tm^.id = hcPlay then
            numHC := numHC + 1
          else
            begin
              hc0There := true;
              numNHC := numNHC + 1;
            end;
          tm := tm^.slink;
        end;
      if numHC > 0 then
        begin
          if hc0There then
            numHC := numHC + 1;
          allocNameDesc(numHC, 0, hcMenu);
          hcMenu^.header := 'Handicap Alternates';
          j := 1;
          if hc0There then
            begin
              hcMenu^.commands[1] := '0';
              j := 2;
            end;
          tm := curMove^.flink;
          for i := j to numHC do
            begin
              while tm^.id <> hcPlay do
                tm := tm^.slink;
    {$R-}
              hcMenu^.commands[i] := ' ';
              hcMenu^.commands[i][1] := chr(tm^.hcNum + ord('0'));
    {$R=}
              tm := tm^.slink;
            end;
          menu(hcMenu, false, 1, numHC, -1, -1, -1, res);
          restoreCursor;
          destroyNameDesc(hcMenu);
          i := res^.indices[1];
          destroyRes(res);
          if hc0There then
            if i = 1 then
              begin
                if numNHC > 1 then
                  goto 10;
                tm := curMove^.flink;
                while tm^.id <> move do
                  tm := tm^.slink;
                forwardTo(tm);
                chooseAlt := true;
                exit(chooseAlt);
              end
            else
              i := i - 1;
          tm := curMove^.flink;
          j := 0;
          repeat
            while tm^.id <> hcPlay do
              tm := tm^.slink;
            j := j + 1;
            if j <> i then
              tm := tm^.slink;
          until j = i;
          forwardTo(tm);
          chooseAlt := true;
        end
      else
        begin
  10:
          showAlts;
          waitButton;
          if passLocCur(tabRelX, tabRelY) then
            begin
              if passIsAlt then
                begin
                  selPass;
                  chooseAlt := true;
                  waitNoButton;
                  exit(chooseAlt);
                end;
            end
          else if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
            if board[bx][by].val = alternate then
              begin
                selAlt(bx, by);
                chooseAlt := true;
                waitNoButton;
                exit(chooseAlt);
              end;
          remAlts;
          beep(error);
        end;
      waitNoButton;
    end { chooseAlt };

    procedure mForward;
    var
      gbg: boolean;
    begin { mForward }
      if gameOver then
        restoreDead;
      if atLeaf(curMove) then
        beep(error)
      else if atBranch(curMove) then
        gbg := chooseAlt
      else
        forwardTo(curMove^.flink);
    end { mForward };

    procedure doBkToS;
    var
      bx, by, sx, sy: integer;
    begin { doBkToS }
      prompt('Point at stone to backup to');
      waitButton;
      if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
        if board[bx][by].val <> empty then
          begin
            while not lastPlayAt(bx, by) do
              backup1;
            exit(doBkToS);
          end;
      beep(error);
      waitNoButton;
    end { doBkToS };

    procedure doPutTag;
    var
      ts: tagStr;
      cm: pMRec;
    begin { doPutTag }
      if curMove = treeRoot then
        beep(error)
      else
        begin
          IOKeyClear;
          streamKeyboardReset(input);
          prompt('Tag String: ');
          if not getLine(ts) then
            exit(doPutTag);
          if length(ts) > maxTagLen then
            begin
              beep(error);
              prompt('Tags may be no longer than ');
              write(maxTagLen:0, ' characters');
            end
          else if length(ts) = 0 then
            begin
              if curMove^.tag = nil then
                begin
                  beep(error);
                  prompt('');
                end
              else
                begin
                  delTag(curMove^.tag);
                  prompt('Tag Deleted');
                end;
            end
          else if tagExists(ts) then
            begin
              beep(error);
              prompt('That tag already exists');
            end
          else
            begin
              tagMove(curMove, ts);
            end;
        end;
    end { doPutTag };

    procedure doGoToTag;
    var
      thisTag: tagPtr;
    begin { doGoToTag }
      thisTag := getTagMenu;
      if thisTag <> nil then
        switchBranch(thisTag^.mPtr);
    end { doGoToTag };

    procedure doPutCmt;
    var
      cs, curCmt: string;
    begin { doPutCmt }
      IOKeyClear;
      streamKeyboardReset(input);
      prompt('Comment: ');
      if not getLine(cs) then
        exit(doPutCmt);
      if length(cs) = 0 then
        if getComment(curMove, curCmt) then
          prompt('Comment Deleted')
        else
          begin
            beep(error);
            prompt('');
          end;
      commentMove(curMove, cs);
    end { doPutCmt };

    procedure doScore;
    var
      wScore, bScore, wr, br: integer;
      done: boolean;
      bx, by, xs, ys: integer;
    begin { doScore }
      putEnd;
      done := false;
      prompt('Point at dead groups, Press outside of board to stop');
      repeat
        waitButton;
        if bLocCur(tabRelX, tabRelY, bx, by, xs, ys) then
          begin
            if board[bx, by].val <> empty then
              delGroup(bx, by);
          end
        else
          done := true;
        showCaptures;
        waitNoButton;
      until done;
      prompt('Counting Score ...');
      scoreGame(wScore, bScore);
      wScore := wScore - captures[black];
      bScore := bScore - captures[white];
      if wScore < 0 then
        begin
          wr := -wScore;
          wScore := 0;
        end
      else
        wr := 0;
      if bScore < 0 then
        begin
          br := -bScore;
          bScore := 0;
        end
      else
        br := 0;
      bScore := bScore + wr;
      wScore := wScore + br;
      prompt('Score is: ');
      write('White = ', wScore:0, ', Black = ', bScore:0);
      if wScore = bScore then
        write(' - A Tie!')
      else if wScore > bScore then
        write(' - White Wins by ', (wScore - bScore):0)
      else
        write(' - Black Wins by ', (bScore - wScore):0)
    end { doScore };

    procedure doEraseMove;
    var
      lm: pMRec;
    begin { doEraseMove }
      if gameOver then
        restoreDead;
      if curMove = treeRoot then
        beep(error)
      else
        begin
          lm := curMove;
          backup1;
          lm := delBranch(lm);
          treeDirty := true;
        end;
    end { doEraseMove };

    procedure doPruneBranches;
    var
      lm, sm, tm: pMRec;
      tp: tagPtr;
      didPrune: boolean;
    begin { doPruneBranches }
      if gameOver then
        restoreDead;
      if not isBranch(curMove) then
        beep(error)
      else if not confirmed then
        beep(error)
      else
        begin
          didPrune := false;
          wipeTreeMarks;
          lm := curMove;
          while lm <> treeRoot do
            begin
              lm^.mark := true;
              lm := lm^.blink;
            end;
          tp := treeRoot^.lastTag;
          while tp <> nil do
            begin
              lm := tp^.mPtr;
              while lm <> treeRoot do
                begin
                  lm^.mark := true;
                  lm := lm^.blink;
                end;
              tp := tp^.nextTag;
            end;
          lm := curMove;
          while lm <> treeRoot do
            begin
              if lm^.blink^.flink^.slink <> nil then
                begin
                  sm := lm^.blink^.flink;
                  while sm <> nil do
                    if not sm^.mark then
                      begin
                        tm := sm;
                        sm := sm^.slink;
                        tm := delBranch(tm);
                        didPrune := true;
                        treeDirty := true;
                      end
                    else
                      sm := sm^.slink;
                end;
              lm := lm^.blink;
            end;
          if not didPrune then
            prompt('All Branches Were Tagged');
        end;
    end { doPruneBranches };

    handler ctlC;
    begin { ctlC }
      IOKeyClear;
      CtlCseen := true;
    end { ctlC };

  begin { doit }
    resetGame;
    done := false;
    lastMove := nil;
    CtlCseen := false;
    playMyself := false;
    lastWasPass := false;
    IOSetModeTablet(relTablet);
    IOCursorMode(trackCursor);
    activate(mReadFile, true);
    activate(mTogNums, true);
    activate(mQuit, true);
    activate(mPutCmt, true);
    activate(mAutoPlay, true);
    activate(mPlayMyself, true);
    activate(mSetPlayLevel, true);
    activate(mDebug, true);
    activate(mRefBoard, true);
    activate(mShoState, true);
    activate(mBoardSize, true);
    repeat
      if curMove <> lastMove then
        checkAtari(curMove);
      updateStatus;
      lastMove := curMove;
      if not playMyself then
        begin
          activate(mPrintBoard, curMove <> treeRoot);
          activate(mPrintDiag, curMove <> treeRoot);
          activate(mStepToTag, stepTagPossible);
          activate(mSetStepTag, treeRoot^.lastTag <> nil);
          activate(mGotoTag, treeRoot^.lastTag <> nil);
          activate(mInit, treeRoot^.flink <> nil);
          activate(mWriteFile, treeRoot^.flink <> nil);
          activate(mSetHc, curMove = treeRoot);
          activate(mPass, curMove <> treeRoot);
          activate(mScore, curMove <> treeRoot);
          activate(mForToBr, hasBranch(curMove));
          activate(mBackToBr, isBranch(curMove));
          activate(mBackToStone, curMove <> treeRoot);
          activate(mForToLeaf, curMove^.flink <> nil);
          activate(mPutTag, curMove <> treeRoot);
          activate(mGotoRoot, curMove <> treeRoot);
          activate(mEraseMove, curMove <> treeRoot);
          activate(mPruneBranches, isBranch(curMove));
          activate(mBackOne, curMove <> treeRoot);
          activate(mForOne, curMove^.flink <> nil);
        end;
      if CtlCseen then
        cmd := mCtlC
      else if playMyself then
        cmd := mAutoPlay
      else
        repeat
          cmd := getMenuCmd;
        until cmd <> none;
      prompt('');
      case cmd of
        mCtlC:
          begin
            playMyself := false;
            CtlCseen := false;
          end;
        mPlaceStone:
          begin
            if gameOver then
              restoreDead;
            if bLocCur(tabRelX, tabRelY, xi, yi, xs, ys) then
              begin
                if board[xi, yi].val <> empty then
                  beep(error)
                else if (xi = koX) and (yi = koY) then
                  beep(koV)
                else
                  doMove(whoseTurn, xi, yi, xs, ys);
              end
            else
              beep(error);
            waitNoButton;
          end;
        mAutoPlay:
          begin
            if gameOver then
              restoreDead;
            prompt('Thinking...');
            if curMove = treeRoot then
              lastWasPass := false
            else
              lastWasPass := curMove^.id = pass;
            if playMove(whoseTurn, xi, yi) then
              begin
                if board[xi, yi].val <> empty then
                  begin
                    beep(error);
                    prompt('Bad move at ');
                    write((xi + 1):0, ', ', (yi + 1):0);
                    playMyself := false;
                    write(' - Generated by ', playreason);
                  end
                else if (xi = koX) and (yi = koY) then
                  begin
                    beep(koV);
                    prompt('ko violation at ');
                    write((xi + 1):0, ', ', (yi + 1):0);
                    write(' - Generated by ', playreason);
                    playMyself := false;
                  end
                else
                  begin
                    doMove(whoseTurn, xi, yi, 0, 0);
                    if board[xi, yi].val = empty then
                      begin
                        prompt('self kill at ');
                        write((xi + 1):0, ', ', (yi + 1):0);
                        write(' - Generated by ', playreason);
                        playMyself := false;
                      end
                    else
                      commentMove(curMove, playReason);
                  end;
              end
            else
              begin
                doPass(whoseTurn);
                if lastWasPass then
                  playMyself := false;
              end;
            waitNoButton;
            prompt('');
          end;
        mPlayMyself:
          playMyself := true;
        mSetPlayLevel:
          menuPlayLevel(playLevel, maxPlayLevel);
        mShoState:
          showPlayState(whoseTurn);
        mInit:
          if confirmed then
            begin
              makeGoTree;
              resetGame;
              treeDirty := false;
            end
          else
            beep(error);
        mSetHc:
          if moveNum = 0 then
            begin
              if gameOver then
                restoreDead;
              numHC := getHCMenu;
              if numHC > 0 then
                doHCPlay(numHC)
              else
                beep(error);
            end
          else
            beep(error);
        mPass:
          begin
            if gameOver then
              restoreDead;
            doPass(whoseTurn);
          end;
        mScore:
          doScore;
        mForToBr:
          begin
            if gameOver then
              restoreDead;
            if atLeaf(curMove) then
              beep(error)
            else if not atBranch(curMove) then
               forwToBr;
            if not atLeaf(curMove) then
              gbg := chooseAlt;
          end;
        mBackToBr:
          begin
            if gameOver then
              restoreDead;
            if curMove = treeRoot then
              beep(error)
            else
              backToBr;
            if atBranch(curMove) then
              gbg := chooseAlt;
          end;
        mBackToStone:
          begin
            if gameOver then
              restoreDead;
            if curMove = treeRoot then
              beep(error)
            else
              doBkToS;
          end;
        mForToLeaf:
          begin
            if gameOver then
              restoreDead;
            if atLeaf(curMove) then
              beep(error)
            else
              begin
                endLoop := false;
                repeat
                  if atLeaf(curMove) then
                    endLoop := true
                  else if atBranch(curMove) then
                    begin
                      if not chooseAlt then
                        begin
                          endLoop := true;
                          beep(error);
                        end;
                    end
                  else
                    forwToBr;
                until endLoop;
              end;
          end;
        mPutTag:
          doPutTag;
        mGotoTag:
          doGoToTag;
        mGotoRoot:
          switchBranch(treeRoot);
        mPutCmt:
          doPutCmt;
        mReadFile:
          if confirmed then
            doReadGame;
        mWriteFile:
          doWriteGame;
        mEraseMove:
          doEraseMove;
        mPruneBranches:
          doPruneBranches;
        mTogNums:
          if not numbEnabled then
            begin
              numbEnabled := true;
              showAllStones;
              dotSX := -1;
              putMString(mTogNums, 'Erase Numbers');
            end
          else
            begin
              numbEnabled := false;
              showAllStones;
              dotSX := -1;
              dotLast;
              putMString(mTogNums, 'Show Stone Numbers');
            end;
        mDebug:
          if debug then
            begin
              debug := false;
              putMString(mDebug, 'Turn Debug On');
            end
          else
            begin
              debug := true;
              putMString(mDebug, 'Turn Debug Off');
            end;
        mBoardSize:
          begin
            printLarge := not printLarge;
            if printLarge then
              begin
                prompt('Will Print on Large Board Now');
                putMString(mBoardSize, 'Use Small Board');
              end
            else
              begin
                prompt('Will Print on Small Board Now');
                putMString(mBoardSize, 'Use Large Board');
              end;
          end;
        mPrintBoard:
          printBoard(false);
        mPrintDiag:
          printBoard(true);
        mStepToTag:
          begin
            if gameOver then
              restoreDead;
            if stepTag = nil then
              stepTag := getTagMenu;
            if stepTag <> nil then
              doStepTag
            else
              beep(error);
          end;
        mSetStepTag:
          begin
            thisTag := getTagMenu;
            if thisTag <> nil then
              stepTag := thisTag;
          end;
        mQuit:
          if confirmed then
            done := true;
        mBackOne:
          begin
            if gameOver then
              restoreDead
            else if curMove = treeRoot then
              beep(error)
            else
              backUp1;
          end;
        mForOne:
          begin
            if gameOver then
              restoreDead;
            mForward;
          end;
        mRefBoard:
          refreshBoard;
      end { case };
      if not playMyself then
        endCmd;
    until done;
  end { doit };

  procedure cleanup;
  begin { cleanup }
    screenReset;
    rasterOp(rRpl, 768, 1024, 0, 0, SScreenW, SScreenP,
                              0, 0, SScreenW, oScreenPtr);
    SSetCursor(oCurPosX, oCurPosY);
  end { cleanup };

  handler ctlC;
  begin { ctlC }
    IOKeyClear;
  end { ctlC };

begin { Go }
  initialize;
  doit;
99:
  cleanUp;
end { Go }.