DataMuseum.dk

top - metrics - download

    Length: 20985 (0x51f9)
    Types: TextFile
    Names: »goMgr.pas«

└─⟦b20c6495f⟧ Bits:30007238 EUUGD18: Wien-båndet, efterår 1987
    └─⟦this⟧ »EUUGD18/General/GoBoard/goMgr.pas« 

TextFile

{---------------------------------------------------------------}
{ GoMgr.Pas                                                     }
{                                                               }
{ Go Game Manager                                               }
{ Copyright (c) 1982 by Three Rivers Computer Corp.             }
{                                                               }
{ Written: June 3, 1982 by Stoney Ballard                       }
{ Edit History:                                                 }
{    June  3, 1982  Started                                     }
{    June  4, 1982  Add dead group removal                      }
{    June 10, 1982  Use new go file manager                     }
{    Nov   9, 1982  Extracted from GO.PAS                       }
{---------------------------------------------------------------}

module goMgr;

exports

imports goCom from goCom;
imports goTree from goTree;

var
  curMove: pMRec;
  gameOver: boolean;
  passIsAlt: boolean;

procedure initGoMgr;
procedure backUp1;
procedure doMove(which: sType; ix, iy, pox, poy: integer);
procedure doPass(which: sType);
procedure doHCPlay(num: integer);
procedure forwardTo(m: pMRec);
procedure forwToBr;
procedure backToBr;
procedure showAlts;
procedure remAlts;
procedure selAlt(lx, ly: integer);
procedure selPass;
function atBranch(cm: pMRec): boolean;
function atLeaf(cm: pMRec): boolean;
procedure checkAtari(cm: pMRec);
procedure switchBranch(bm: pMRec);
procedure scoreGame(var ws, bs: integer);
procedure putEnd;
procedure delGroup(bx, by: integer);
procedure restoreDead;
procedure dotLast;
function lastPlayAt(bx, by: integer): boolean;
procedure doStepTag;
function stepTagPossible: boolean;
procedure wipeTreeMarks;

private

imports goBoard from goBoard;
imports goMenu from goMenu;
imports screen from screen;

type
  deadRec = record
              dx, dy, dox, doy, mn: integer;
              whoDead: sType;
            end;

var
  killX, killY: integer;
  endDead: array[1..361] of deadRec;
  numEndDead: integer;

procedure wipeMarks;
var
  i, j: integer;
begin { wipeMarks }
  for i := 0 to maxPoint do
    for j := 0 to maxPoint do
      board[i, j].marked := false;
end { wipeMarks };

procedure wipeTreeMarks;

  procedure recWipe(m: pMRec);
  begin { recWipe }
    while m <> nil do
      begin
        recWipe(m^.slink);
        m^.mark := false;
        m := m^.flink;
      end;
  end { recWipe };

begin { wipeTreeMarks }
  treeRoot^.mark := false;
  if treeRoot^.flink <> nil then
    recWipe(treeRoot^.flink);
end { wipeTreeMarks };

procedure spanGroup(s: sType; xi, yi: integer; var libs, size: integer);
begin { spanGroup }
  if (xi >= 0) and (xi <= maxPoint) and
     (yi >= 0) and (yi <= maxPoint) then
    with board[xi, yi] do
      if not marked then
        if val = empty then
          begin
            libs := libs + 1;
            marked := true;
          end
        else if val = s then
          begin
            marked := true;
            size := size + 1;
            spanGroup(s, xi - 1, yi, libs, size);
            spanGroup(s, xi + 1, yi, libs, size);
            spanGroup(s, xi, yi - 1, libs, size);
            spanGroup(s, xi, yi + 1, libs, size);
          end;
end { spanGroup };

function libertyCount(xi, yi: integer): integer;
var
  libs, size: integer;
begin { libertyCount }
  wipeMarks;
  libs := 0; 
  size := 0;
  spanGroup(board[xi, yi].val, xi, yi, libs, size);
  libertyCount := libs;
end { libertyCount };

function groupSize(xi, yi: integer): integer;
var
  gbg, size: integer;
begin { groupSize }
  wipeMarks;
  size := 0;
  gbg := 0;
  spanGroup(board[xi, yi].val, xi, yi, gbg, size); 
  groupSize := size;
end { groupSize };

procedure killGroup(s: sType; xi, yi: integer);
begin { killGroup }
  if (xi >= 0) and (xi <= maxPoint) and
     (yi >= 0) and (yi <= maxPoint) then
    with board[xi, yi] do
      if val = s then
        begin
          remStone(xi, yi);
          curMove := newMove(curMove);
          with curMove^ do
            begin
              mx := xi;
              my := yi;
              ox := board[xi, yi].xOfs;
              oy := board[xi, yi].yOfs;
              moveN := board[xi, yi].mNum;
              who := s;
              id := remove;
            end;
          curMove := mergeMove(curMove);
          killGroup(s, xi - 1, yi);
          killGroup(s, xi + 1, yi);
          killGroup(s, xi, yi - 1);
          killGroup(s, xi, yi + 1);
        end;
end { killGroup };

procedure remDead(xi, yi: integer; var numDead: integer);
var
  i, j, libs, size: integer;
  s, other: bVal;

begin { remDead }
  numDead := 0;
  s := board[xi, yi].val;
  if s = white then
    other := black
  else
    other := white;
  if xi > 0 then
    if (board[xi - 1, yi].val = other) then
      begin
        wipeMarks;
        libs := 0;
        size := 0;
        spanGroup(other, xi - 1, yi, libs, size);
        if libs = 0 then
          begin
            killGroup(other, xi - 1, yi);
            numDead := numDead + size;
            killX := xi - 1;
            killY := yi;
          end;
      end;
  if xi < maxPoint then
    if (board[xi + 1, yi].val = other) then
      begin
        wipeMarks;
        libs := 0;
        size := 0;
        spanGroup(other, xi + 1, yi, libs, size);
        if libs = 0 then
          begin
            killGroup(other, xi + 1, yi);
            numDead := numDead + size;
            killX := xi + 1;
            killY := yi;
          end;
      end;
  if yi > 0 then 
    if (board[xi, yi - 1].val = other) then
      begin
        wipeMarks;
        libs := 0;
        size := 0;
        spanGroup(other, xi, yi - 1, libs, size);
        if libs = 0 then
          begin
            killGroup(other, xi, yi - 1);
            numDead := numDead + size;
            killX := xi;
            killY := yi - 1;
          end;
      end;
  if yi < maxPoint then
    if (board[xi, yi + 1].val = other) then
      begin
        wipeMarks;
        libs := 0;
        size := 0;
        spanGroup(other, xi, yi + 1, libs, size);
        if libs = 0 then
          begin
            killGroup(other, xi, yi + 1);
            numDead := numDead + size;
            killX := xi;
            killY := yi + 1;
          end;
      end;
  if numDead > 0 then
    beep(die);
end { remDead };

function lastPlayAt(bx, by: integer): boolean;
var
  tm: pMRec;
begin { lastPlayAt }
  lastPlayAt := false;
  tm := curMove;
  while tm <> treeRoot do
    with tm^ do
      if id = move then
        begin
          lastPlayAt := (mx = bx) and (my = by);
          exit(lastPlayAt);
        end
      else if id = pass then
        exit(lastPlayAt)
      else if id = hcPlay then
        exit(lastPlayAt)
      else
        tm := tm^.blink;
end { lastPlayAt };

procedure findAtari(xi, yi: integer);
var
  i, j, libs, num, size: integer;
  s, other: bVal;
begin { findAtari }
  size := 0;
  s := board[xi, yi].val;
  if s = white then
    other := black
  else
    other := white;
  wipeMarks;
  libs := 0;
  spanGroup(s, xi, yi, libs, size);
  if libs = 1 then
    begin
      beep(atari);
      exit(findAtari);
    end;
  if xi > 0 then
    if (board[xi - 1, yi].val = other) and
       (not board[xi - 1, yi].marked) then
      begin
        wipeMarks;
        libs := 0;
        spanGroup(other, xi - 1, yi, libs, size);
        if libs = 1 then
          begin
            beep(atari);
            exit(findAtari);
          end;
      end;
  if xi < maxPoint then
    if (board[xi + 1, yi].val = other) and
       (not board[xi + 1, yi].marked) then
      begin
        wipeMarks;
        libs := 0;
        spanGroup(other, xi + 1, yi, libs, size);
        if libs = 1 then
          begin
            beep(atari);
            exit(findAtari);
          end;
      end;
  if yi > 0 then 
    if (board[xi, yi - 1].val = other) and
       (not board[xi, yi - 1].marked) then
      begin
        wipeMarks;
        libs := 0;
        spanGroup(other, xi, yi - 1, libs, size);
        if libs = 1 then
          begin
            beep(atari);
            exit(findAtari);
          end;
      end;
  if yi < maxPoint then
    if (board[xi, yi + 1].val = other) and
       (not board[xi, yi + 1].marked) then
      begin
        wipeMarks;
        libs := 0;
        spanGroup(other, xi, yi + 1, libs, size);
        if libs = 1 then
          beep(atari);
      end;
end { findAtari };

procedure checkAtari(cm: pMRec);
begin { checkAtari }
  if cm <> treeRoot then
    if cm^.id <> hcPlay then
      if cm^.id <> pass then
        begin
          while cm^.id = remove do
            cm := cm^.blink;
          with cm^ do
            findAtari(mx, my);
      end;
end { checkAtari };

procedure restoreDead;
var
  i: integer;
  other: sType;
begin { restoreDead }
  for i := 1 to numEndDead do
    with endDead[i] do
      begin
        placeStone(whoDead, dx, dy, dox, doy, mn);
        if whoDead = white then
          other := black
        else
          other := white;
        captures[other] := captures[other] - 1;
      end;
  numEndDead := 0;
  gameOver := false;
end { restoreDead };

procedure backUp1;
var
  moveT: mType;
  prevMove, tm: pMRec;
begin { backUp1 }
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  if gameOver then
    restoreDead;
  if curMove <> treeRoot then
    repeat
      with curMove^ do
        begin
          prevMove := blink;
          moveT := id;
          if id = move then
            remStone(mx, my)
          else if id = remove then
            begin 
              placeStone(who, mx, my, ox, oy, moveN);
              if who = black then
                captures[white] := captures[white] - 1
              else
                captures[black] := captures[black] - 1;
            end
          else if id = pass then
            remPass
          else { hcPlay }
            clearBoard;
        end;
      curMove := prevMove;
   until (curMove = treeRoot) or (moveT = move) or (moveT = pass); 
   if curMove = treeRoot then
     begin
       koX := -1;
       koY := -1;
       moveNum := 0;
     end
   else if curMove^.id = move then
     with curMove^ do
       begin
         koX := kx;
         koY := ky;
         moveNum := moveN;
       end
   else if curMove^.id = pass then
     with curMove^ do
       begin
         koX := -1;
         koY := -1;
         moveNum := moveN;
         showPass(who);
       end
   else if curMove^.id = hcPlay then
     begin
       koX := -1;
       koY := -1;
       moveNum := 1;
     end
   else
     begin
       tm := curMove^.blink;
       while tm^.id <> move do
         tm := tm^.blink;
       with tm^ do
         begin
           koX := kx;
           koY := ky;
           moveNum := moveN;
         end;
     end;
end { backUp1 };

procedure doMove(which: sType; ix, iy, pox, poy: integer);
var
  numDead: integer;
  cm: pMRec;
begin { doMove }
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  if gameOver then
    restoreDead;
  curMove := newMove(curMove);
  moveNum := moveNum + 1;
  with curMove^ do
    begin
      mx := ix;
      my := iy;
      ox := pox;
      oy := poy;
      kx := koX;
      ky := koY;
      who := which;
      id := move;
      moveN := moveNum;
    end;
  curMove := mergeMove(curMove);
  cm := curMove;
  placeStone(which, ix, iy, pox, poy, moveNum);
  remDead(ix, iy, numDead);
  if libertyCount(ix, iy) < 1 then
    begin
      curMove := delBranch(curMove);
      moveNum := moveNum + 1;
      remStone(ix, iy);
      beep(error);
    end
  else
    begin
      captures[which] := captures[which] + numDead;
      if (numDead = 1) and (groupSize(ix, iy) = 1) then
        begin
          koX := killX;
          koY := killY;
        end
      else
        begin
          koX := -1;
          koY := -1;
        end;  
      with cm^ do
        begin
          kx := koX;
          ky := koY;
        end;
    end;
end { doMove };

procedure doPass(which: sType);
begin { doPass }
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  if gameOver then
    restoreDead;
  curMove := newMove(curMove);
  moveNum := moveNum + 1;
  with curMove^ do
    begin
      who := which;
      id := pass;
      moveN := moveNum;
    end;
  curMove := mergeMove(curMove);
  showPass(which);
end { doPass };

procedure doHCPlay(num: integer);
begin { doHCPlay }
  moveNum := 1;
  curMove := newMove(treeRoot);
  with curMove^ do
    begin
      who := black;
      id := hcPlay;
      hcNum := num;
    end;
  addHCStones(num);
end { doHCPlay };

procedure forwardTo(m: pMRec);
begin { forwardTo }
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  curMove := m;
  if passShowing then
    remPass;
  with curMove^ do
    if id = hcPlay then
      begin
        addHCStones(hcNum);
        moveNum := 1;
      end
    else if id = pass then
      begin
        moveNum := moveN;
        koX := -1;
        koY := -1;
        showPass(who);
      end
    else
      begin
        moveNum := moveN;
        placeStone(who, mx, my, ox, oy, moveNum);
        koX := kx;
        koY := ky;
        while curMove^.flink <> nil do
          if curMove^.flink^.id = remove then
            begin
              curMove := curMove^.flink;
              with curMove^ do
                remStone(mx, my);
              if curMove^.who = white then
                captures[black] := captures[black] + 1
              else
                captures[white] := captures[white] + 1
            end
          else
            exit(forwardTo);
      end;
end { forwardTo };

procedure forwToBr;
var
  atBr: boolean;
begin { forwToBr }
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  atBr := false;
  repeat
    if curMove^.flink = nil then
      atBr := true
    else if curMove^.flink^.slink <> nil then
      atBr := true
    else
      forwardTo(curMove^.flink);
  until atBr;
end { forwToBr };

procedure backToBr;
var
  na: integer;
  tm: pMRec;
  endLoop: boolean;
begin { backToBr }
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  if curMove <> treeRoot then
    begin
      if not hasAlts(curMove) then
        repeat
          backUp1;
          if curMove = treeRoot then
            endLoop := true
          else
            endLoop := hasAlts(curMove);
        until endLoop;
      if curMove <> treeRoot then
        backUp1;
    end
  else
    beep(error);
end { backToBr };

function atBranch(cm: pMRec): boolean;
begin { atBranch }
  if cm^.flink <> nil then
    atBranch := cm^.flink^.slink <> nil
  else
    atBranch := false;
end { atBranch };

function atLeaf(cm: pMRec): boolean;
begin { atLeaf }
  atLeaf := cm^.flink = nil;
end { atLeaf };

procedure showAlts;
var
  tm: pMRec;
begin { showAlts }
  setMenuCursor;
  tm := curMove^.flink;
  passIsAlt := false;
  while tm <> nil do
    begin
      with tm^ do
        begin
          if id = move then
            placeAlt(who, mx, my, ox, oy)
          else if id = pass then
            begin
              SChrFunc(ord(rNot));
              showPass(who);
              SChrFunc(ord(rRpl));
              passIsAlt := true;
            end;
          tm := tm^.slink;
        end;
    end;
end { showAlts };

procedure remAlts;
var
  tm: pMRec;
begin { remAlts }
  tm := curMove^.flink;
  while tm <> nil do
    begin
      with tm^ do
        begin
          if id = move then
            remStone(mx, my)
          else if id = pass then
            remPass;
          tm := tm^.slink;
        end;
    end;
end { remAlts };

procedure selAlt(lx, ly: integer);
begin { selAlt }
  remAlts;
  curMove := curMove^.flink;
  repeat
    while curMove^.id <> move do
      curMove := curMove^.slink;
    if (curMove^.mx = lx) and (curMove^.my = ly) then
      begin
        forwardTo(curMove);
        exit(selAlt);
      end
    else
      curMove := curMove^.slink;
  until false;
end { selAlt };

procedure selPass;
begin { selPass }
  remAlts;
  curMove := curMove^.flink;
  while curMove^.id <> pass do
    curMove := curMove^.slink;
  forwardTo(curMove);
end { selPass };

procedure switchBranch(bm: pMRec);
var
  tm: pMRec;
begin { switchBranch }
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  if gameOver then
    restoreDead;
  wipeTreeMarks;
  tm := bm;
  while tm <> treeRoot do
    begin
      tm^.mark := true;
      tm := tm^.blink;
    end;
  treeRoot^.mark := true;
  while not curMove^.mark do
    backup1;
  while curMove <> bm do
    begin
      tm := curMove^.flink;
      while not tm^.mark do
        tm := tm^.slink;
      forwardTo(tm);
    end;
end { switchBranch };

function stepTagPossible: boolean;
begin { stepTagPossible }
  if treeRoot^.lastTag = nil then
    stepTagPossible := false
  else if stepTag = nil then
    stepTagPossible := true
  else if curMove = treeRoot then
    stepTagPossible := true
  else if curMove^.tag = stepTag then
    stepTagPossible := false
  else
    stepTagPossible := true;
end { stepTagPossible };

procedure doStepTag;
var
  tm: pMRec;
begin { doStepTag }
  if stepTag = nil then
    exit(doStepTag);
  if dotSX >= 0 then
    begin
      dotStone(dotSX, dotSY);
      dotSX := -1;
    end;
  if gameOver then
    restoreDead;
  tm := stepTag^.mPtr;
  if curMove = tm then
    exit(doStepTag);
  wipeTreeMarks;
  while tm <> treeRoot do
    begin
      tm^.mark := true;
      tm := tm^.blink;
    end;
  treeRoot^.mark := true;
  if not curMove^.mark then
    begin
      prompt('Backed up to proper branch');
      repeat
        backup1;
      until curMove^.mark;
    end
  else 
    begin
      tm := curMove^.flink;
      while not tm^.mark do
        tm := tm^.slink;
      forwardTo(tm);
    end;
end { doStepTag };

procedure scoreGame(var ws, bs: integer);
var
  i, j, size: integer;
  bSeen, wSeen: boolean;

  procedure spanEmpties(bx, by: integer);
  begin { spanEmpties }
    if (bx >= 0) and (bx <= maxPoint) and
       (by >= 0) and (by <= maxPoint) then
      begin
        if board[bx, by].val = white then
          wSeen := true
        else if board[bx, by].val = black then
          bSeen := true
        else if not board[bx, by].marked then
          begin
            board[bx, by].marked := true;
            size := size + 1;
            spanEmpties(bx - 1, by);
            spanEmpties(bx + 1, by);
            spanEmpties(bx, by - 1);
            spanEmpties(bx, by + 1);
          end;
      end;
  end { spanEmpties };

begin { scoreGame }
  ws := 0;
  bs := 0;
  wipeMarks;
  for j := 0 to maxPoint do
    for i := 0 to maxPoint do
      if (not board[i, j].marked) and
         (board[i, j].val = empty) then
        begin
          bSeen := false;
          wSeen := false;
          size := 0;
          spanEmpties(i, j);
          if bSeen and not wSeen then
            bs := bs + size
          else if wSeen and not bSeen then
            ws := ws + size;
        end;
end { scoreGame };

procedure putEnd;
begin { putEnd }
  if not gameOver then
    begin
      gameOver := true;
      numEndDead := 0;
    end;
end { putEnd };

procedure delGroup(bx, by: integer);
var
  sto, other: sType;
  size: integer;

  procedure dumpDead(bx, by: integer);
  begin { dumpDead }
    if (bx >= 0) and (bx <= maxPoint) and
       (by >= 0) and (by <= maxPoint) then
      if board[bx, by].val = sto then
        begin
          remStone(bx, by);
          numEndDead := numEndDead + 1;
          with endDead[numEndDead] do
            begin
              dx := bx;
              dy := by;
              with board[bx, by] do
                begin
                  dox := xOfs;
                  doy := yOfs;
                  mn := mNum;
                end;
              whoDead := sto;
            end;
          size := size + 1;
          dumpDead(bx - 1, by);
          dumpDead(bx + 1, by);
          dumpDead(bx, by - 1);
          dumpDead(bx, by + 1);
        end;
  end { dumpDead };

begin { delGroup }
  sto := board[bx, by].val;
  size := 0;
  dumpDead(bx, by);
  if sto = white then
    other := black
  else
    other := white;
  captures[other] := captures[other] + size;
end { delGroup };

procedure dotLast;
var
  tm: pMRec;
begin { dotLast }
  if numbEnabled then
    exit(dotLast);
  if dotSX >= 0 then
    dotStone(dotSX, dotSY);
  dotSX := -1;
  tm := curMove;
  while tm <> treeRoot do
    if tm^.id = pass then
      exit(dotLast)
    else if tm^.id = move then
      with tm^ do
        begin
          dotSX := mx;
          dotSY := my;
          dotStone(mx, my);
          exit(dotLast);
        end
    else
      tm := tm^.blink;
end { dotLast };

procedure initGoMgr;
begin { initGoMgr }
  moveNum := 0;
  curMove := treeRoot;
  gameOver := false;
  numEndDead := 0;
  dotSX := -1;
  dotSY := -1;
  passShowing := false;
end. { initGoMgr }