⟦d429481c9⟧

TextFile

{---------------------------------------------------------------}
{ GoTree.Pas                                                    }
{                                                               }
{ Go Game Tree 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                       }
{    Nov  15, 1982  Added tag and comment deletion              }
{    Jan   5, 1983  Increased segment max sizes                 }
{    Jan   7, 1983  Changed File Format to have global comment  }
{---------------------------------------------------------------}

module goTree;

exports

imports goCom from goCom;
imports getTimeStamp from getTimeStamp;

type
  pMRec = ^moveRec;

  tagStr = string[maxTagLen];
  tagPtr = ^tagRec;
  tagRec = record
             mPtr: pMRec;
             nextTag: tagPtr;
             sTag: tagStr;
           end;

  mType = (header, move, remove, hcPlay, pass);
  moveRec = packed record
              mark: boolean;
              flink: pMRec;
              case id: mType of
                header:
                  (lastMove: pMRec;
                   freePool: pMRec;
                   lastTag: tagPtr;
                   nextMRec: integer;
                   nextMBlock: integer;
                   nextTRec: integer;
                   nextTBlock: integer;
                   nextCIdx: integer;
                   nextCBlock: integer;
                   freeTags: tagPtr);
                hcPlay, move, remove, pass:
                  (blink: pMRec;
                   slink: pMRec;
                   tag: tagPtr;
                   who: sType;
                   moveN: integer;
                   cmtBase: integer;
                   cmtLen: integer;
                   case {id:} mType of
                     hcPlay:
                       (hcNum: integer);
                     move, remove:
                       (mx: integer;
                        my: integer;
                        ox: integer;
                        oy: integer;
                        kx: integer;
                        ky: integer) )
            end;

  baseBlock = packed record
                case boolean of
                  false:
                    (padding: array[1..512] of char);
                  true:
                    (randBool: boolean;
                     oldTest: pointer;
                     fileVersion: integer;
                     created: timeStamp;
                     rootComment: string[127])
              end;

  pBaseBlock = ^baseBlock;

var
  treeRoot: pMRec;
  stepTag: tagPtr;
  hdrBlock: pBaseBlock;

exception goFNF;
exception badGoWrite;
exception badFileVersion;

procedure initGoTree;
procedure makeGoTree;
procedure readTree(nam: string);
procedure writeTree(nam: string; lm: pMRec);
function newMove(cm: pMRec): pMRec;
function delBranch(pm: pMRec): pMRec;
function hasAlts(pm: pMRec): boolean;
function isBranch(pm: pMRec): boolean;
function hasBranch(pm: pMRec): boolean;
function mergeMove(cm: pMRec): pMRec;
procedure tagMove(cm: pMRec; ts: tagStr);
function tagExists(ts: tagStr): boolean;
procedure commentMove(cm: pMRec; cs: string);
function getComment(cm: pMRec; var cs: string): boolean;
function getTag(cm: pMRec; var ts: string): boolean;
procedure delTag(tp: tagPtr);
procedure getFNameString(var fs: string);

private

imports fileSystem from fileSystem;
imports memory from memory;
imports perq_string from perq_string;
imports clock from clock;

const
  curFileVersion = 1;
  minTreeSize = 20;
  minTagSize = 4;
  minCmtSize = 4;
  maxTreeSize = 255;
  maxTagSize = 64;
  maxCmtSize = 128;
  treeSegInc = 8;
  tagSegInc = 4;
  cmtSegInc = 4;

type
  caType = packed array[0..1] of char;
  pCmtArray = ^caType;

var
  mFID: FileID;
  treeSeg, tagSeg, cmtSeg: integer;
  trSegSize, tagSegSize, cmtSegSize: integer;
  cmtArray: pCmtArray;
  cmtCmpArray: array[1..1024] of pMRec;

procedure getFNameString(var fs: string);
var
  ts: string;
begin  { getFNameString }
  fs := gameFName;
  if fs <> '' then
    begin
      stampToString(hdrBlock^.created, ts);
      fs := concat(fs, '  ');
      fs := concat(fs, ts);
    end;
end { getFNameString };

function isBranch(pm: pMRec): boolean;
begin { isBranch }
  repeat
    if pm = treeRoot then
      begin
        isBranch := false;
        exit(isBranch);
      end;
    pm := pm^.blink;
  until pm^.flink^.slink <> nil;
  isBranch := true;
end { isBranch };

function hasBranch(pm: pMRec): boolean;
begin { hasBranch }
  while pm^.flink <> nil do
    if pm^.flink^.slink <> nil then
      begin
        hasBranch := true;
        exit(hasBranch);
      end
    else
      pm := pm^.flink;
  hasBranch := false;
end { hasBranch };

procedure initSegs(trSize, tagSize, cmtSize: integer);
begin { initSegs }
  if treeSeg <> -1 then
    begin
      changeSize(treeSeg, trSize);
      changeSize(tagSeg, tagSize);
      changeSize(cmtSeg, cmtSize);
    end
  else
    begin
      createSegment(treeSeg, trSize, treeSegInc, maxTreeSize);
      createSegment(tagSeg, tagSize, tagSegInc, maxTagSize);
      createSegment(cmtSeg, cmtSize, cmtSegInc, maxCmtSize);
    end;
  trSegSize := trSize;
  tagSegSize := tagSize;
  cmtSegSize := cmtSize;
end { initSegs };

procedure initHdrBlock;
begin { initHdrBlock }
  with hdrBlock^ do
    begin
      oldTest := nil;
      fileVersion := curFileVersion;
      getTStamp(created);
      rootComment := '';
    end;
end { initHdrBlock };

procedure makeGoTree;
begin { makeGoTree }
  initSegs(minTreeSize, minTagSize, minCmtSize);
  initHdrBlock;
  treeRoot := makePtr(treeSeg, 0, pMRec);
  with treeRoot^ do
    begin
      id := header;
      freePool := nil;
      flink := nil;
      lastTag := nil;
      nextMRec := wordSize(moveRec);
      nextMBlock := minTreeSize * 256;
      nextTRec := 0;
      nextTBlock := minTagSize * 256;
      nextCIdx := 0;
      nextCBlock := minCmtSize * 512;
      freeTags := nil;
    end;
  cmtArray := makePtr(cmtSeg, 0, pCmtArray);
  stepTag := nil;
end { makeGoTree };

procedure readTree(nam: string);
type
   ptrHack = record
               case integer of
                 0: (p: pMRec);
                 1: (pt: tagPtr);
                 2: (po: integer;
                     ps: integer);
             end;
var
  size, gbg, i, b: integer;
  pd: pDirBlk;
  ph: ptrHack;
  pm: pMRec;
  tm: tagPtr;
  mBlks, tBlks, cBlks: integer;
begin { readTree }
  initSegs(minTreeSize, minTagSize, minCmtSize);
  mFID := FSLookup(nam, size, gbg);
  if mFID = 0 then
    raise goFNF;
  FSBlkRead(mFID, 0, recast(hdrBlock, pDirBlk));
  if hdrBlock^.oldTest <> nil then
    begin
      initHdrBlock;
      b := 0;
    end
  else if hdrBlock^.fileVersion <> curFileVersion then
    begin
      makeGoTree;
      raise badFileVersion;
    end
  else
    b := 1;
  pd := makePtr(treeSeg, 0, pDirBlk);
  FSBlkRead(mFID, b, pd);
  b := b + 1;
  treeRoot := makePtr(treeSeg, 0, pMRec);
  with treeRoot^ do
    begin
      mBlks := nextMBlock div 256;
      tBlks := nextTBlock div 256;
      cBlks := nextCBlock div 512;
    end;
  initSegs(mBlks, tBlks, cBlks);
  for i := 1 to mBlks - 1 do
    begin
      pd := makePtr(treeSeg, i * 256, pDirBlk);
      FSBlkRead(mFID, b, pd);
      b := b + 1;
    end;
  for i := 0 to tBlks - 1 do
    begin
      pd := makePtr(tagSeg, i * 256, pDirBlk);
      FSBlkRead(mFID, b, pd);
      b := b + 1;
    end;
  for i := 0 to cBlks - 1 do
    begin
      pd := makePtr(cmtSeg, i * 256, pDirBlk);
      FSBlkRead(mFID, b, pd);
      b := b + 1;
    end;
  with treeRoot^ do
    begin
      if freePool <> nil then
        begin
          ph.p := freePool;
          ph.ps := treeSeg;
          freePool := ph.p;
        end;
      if flink <> nil then
        begin
          ph.p := flink;
          ph.ps := treeSeg;
          flink := ph.p;
        end;
      if lastMove <> nil then
        begin
          ph.p := lastMove;
          ph.ps := treeSeg;
          lastMove := ph.p;
        end;
      if lastTag <> nil then
        begin
          ph.pt := lastTag;
          ph.ps := tagSeg;
          lastTag := ph.pt;
        end;
      if freeTags <> nil then
        begin
          ph.pt := freeTags;
          ph.ps := tagSeg;
          freeTags := ph.pt;
        end;
    end;
  i := wordSize(moveRec);
  while i < treeRoot^.nextMRec do
    begin
      pm := makePtr(treeSeg, i, pMRec);
      with pm^ do
        begin
          if flink <> nil then
            begin
              ph.p := flink;
              ph.ps := treeSeg;
              flink := ph.p;
            end;
          if blink <> nil then
            begin
              ph.p := blink;
              ph.ps := treeSeg;
              blink := ph.p;
            end;
          if slink <> nil then
            begin
              ph.p := slink;
              ph.ps := treeSeg;
              slink := ph.p;
            end;
          if tag <> nil then
            begin
              ph.pt := tag;
              ph.ps := tagSeg;
              tag := ph.pt;
            end;
        end;
      i := i + wordSize(moveRec);
    end;
  i := 0;
  while i < treeRoot^.nextTRec do
    begin
      tm := makePtr(tagSeg, i, tagPtr);
      with tm^ do
        begin
          if mPtr <> nil then
            begin
              ph.p := mPtr;
              ph.ps := treeSeg;
              mPtr := ph.p;
            end;
          if nextTag <> nil then
            begin
              ph.pt := nextTag;
              ph.ps := tagSeg;
              nextTag := ph.pt;
            end;
        end;
      i := i + wordSize(tagRec);
    end;
  stepTag := nil;
end { readTree };

procedure writeTree(nam: string; lm: pMRec);
var
  pd: pDirBlk;
  treeBlks, tagBlks, cmtBlks: integer;
  b, i: integer;

  procedure compressCmts;
  var
    numCmts: integer;
    cp: pMRec;

    procedure spanComments(m: pMRec);
    begin { spanComments }
      while m <> nil do
        begin
          if m^.cmtLen > 0 then
            begin
              numCmts := numCmts + 1;
              cmtCmpArray[numCmts] := m;
            end;
          spanComments(m^.slink);
          m := m^.flink;
        end;
    end { spanComments };

    procedure sortComments;
    var
      i, j: integer;
      t: pMRec;
    begin { sortComments }
      for i := 1 to numCmts - 1 do
        for j := i + 1 to numCmts do
          if cmtCmpArray[i]^.cmtBase > cmtCmpArray[j]^.cmtBase then
            begin
              t := cmtCmpArray[i];
              cmtCmpArray[i] := cmtCmpArray[j];
              cmtCmpArray[j] := t;
            end;
    end { sortComments };

    procedure squeezeComments;
    var
      i, j, cgi, lastCB: integer;
      mp: pMRec;
    begin { squeezeComments }
      lastCB := 0;
      for i := 1 to numCmts do
        begin
          if cmtCmpArray[i]^.cmtBase > lastCB then
            begin
              cgi := cmtCmpArray[i]^.cmtBase;
              for j := 0 to cmtCmpArray[i]^.cmtLen - 1 do
                begin
    {$R-}
                  cmtArray^[lastCB + j] := cmtArray^[cgi + j];
    {$R=}
                end;
              cmtCmpArray[i]^.cmtBase := lastCB;
            end;
          lastCB := cmtCmpArray[i]^.cmtBase + cmtCmpArray[i]^.cmtLen;
        end;
      treeRoot^.nextCIdx := lastCB;
    end { squeezeComments };

  begin { compressCmts }
    numCmts := 0;
    cp := treeRoot^.flink;
    if cp <> nil then
      begin
        spanComments(cp);
        sortComments;
        squeezeComments;
      end;
  end { compressCmts };

begin { writeTree }
  mFID := FSEnter(nam);
  if mFID = 0 then
    raise badGoWrite
  else
    begin
      compressCmts;
      with treeRoot^ do
        begin
          lastMove := lm;
          treeBlks := nextMBlock div 256;
          tagBlks := nextTBlock div 256;
          cmtBlks := nextCBlock div 512;
        end;
      FSBlkWrite(mFID, 0, recast(hdrBlock, pDirBlk));
      b := 1;
      for i := 0 to treeBlks - 1 do
        begin
          pd := makePtr(treeSeg, i * 256, pDirBlk);
          FSBlkWrite(mFID, b, pd);
          b := b + 1;
        end;
      for i := 0 to tagBlks - 1 do
        begin
          pd := makePtr(tagSeg, i * 256, pDirBlk);
          FSBlkWrite(mFID, b, pd);
          b := b + 1;
        end;
      for i := 0 to cmtBlks - 1 do
        begin
          pd := makePtr(cmtSeg, i * 256, pDirBlk);
          FSBlkWrite(mFID, b, pd);
          b := b + 1;
        end;
      FSClose(mFID, treeBlks + tagBlks + cmtBlks, 4096);
    end;
end { writeTree };

function newMove(cm: pMRec): pMRec;
var
  pm: pMRec;
begin { newMove }
  with treeRoot^ do
    if freePool <> nil then
      begin
        pm := freePool;
        freePool := pm^.flink;
      end
    else
      begin
        if nextMRec + wordSize(moveRec) > nextMBlock then
          begin
            trSegSize := trSegSize + treeSegInc;
            changeSize(treeSeg, trSegSize);
            nextMBlock := nextMBlock + (treeSegInc * 256);
          end;
        pm := makePtr(treeSeg, nextMRec, pMRec);
        nextMRec := nextMRec + wordSize(moveRec);
      end;
  with pm^ do
    begin
      flink := nil;
      blink := cm;
      slink := nil;
      tag := nil;
      cmtLen := 0;
    end;
  if cm^.flink <> nil then
    pm^.slink := cm^.flink;
  cm^.flink := pm;
  newMove := pm;
end { newMove };

procedure tagMove(cm: pMRec; ts: tagStr);
var
  tp: tagPtr;
begin { tagMove }
  if cm^.tag <> nil then
    cm^.tag^.sTag := ts
  else
    with treeRoot^ do
      begin
        if freeTags <> nil then
          begin
            tp := freeTags;
            freeTags := tp^.nextTag;
          end
        else
          begin
            if nextTRec + wordSize(tagRec) > nextTBlock then
              begin
                tagSegSize := tagSegSize + tagSegInc;
                changeSize(tagSeg, tagSegSize);
                nextTBlock := nextTBlock + (tagSegInc * 256);
              end;
            tp := makePtr(tagSeg, nextTRec, tagPtr);
            nextTRec := nextTRec + wordSize(tagRec);
          end;
        cm^.tag := tp;
        with tp^ do
          begin
            mPtr := cm;
            nextTag := lastTag;
            sTag := ts;
          end;
        lastTag := tp;
      end;
  treeDirty := true;
end { tagMove };

function tagExists(ts: tagStr): boolean;
var
  tp: tagPtr;

  function upCmp(s1, s2: pString): boolean;
  begin { upCmp }
    convUpper(s1);
    convUpper(s2);
    upCmp := s1 = s2;
  end { upCmp };

begin { tagExists }
  tp := treeRoot^.lastTag;
  while tp <> nil do
    if upCmp(tp^.sTag, ts) then
      begin
        tagExists := true;
        exit(tagExists);
      end
    else
      tp := tp^.nextTag;
  tagExists := false;
end { tagExists };

procedure commentMove(cm: pMRec; cs: string);
var
  sl, i: integer;
begin { commentMove }
  if cm = treeRoot then
    hdrBlock^.rootComment := cs
  else
    begin
      sl := length(cs);
      with cm^ do
        begin
          cmtLen := sl;
          if sl > 0 then
            begin
              cmtBase := treeRoot^.nextCIdx;
              treeRoot^.nextCIdx := cmtBase + sl;
              if cmtBase + cmtLen > treeRoot^.nextCBlock then
                with treeRoot^ do
                  begin
                    cmtSegSize := cmtSegSize + cmtSegInc;
                    changeSize(cmtSeg, cmtSegSize);
                    nextCBlock := nextCBlock + (cmtSegInc * 512);
                  end;
              for i := 0 to sl - 1 do
                begin
{$R-}
                  cmtArray^[cmtBase + i] := cs[i + 1];
{$R=}
                end;
            end;
        end;
    end;
  treeDirty := true;
end { commentMove };

function getComment(cm: pMRec; var cs: string): boolean;
var
  i: integer;
begin { getComment }
  if cm = treeRoot then
    begin
      cs := hdrBlock^.rootComment;
      getComment := cs <> '';
    end
  else if cm^.cmtLen = 0 then
    getComment := false
  else
    with cm^ do
      begin
        getComment := true;
        adjust(cs, cmtLen);
        for i := 1 to cmtLen do
          begin
{$R-}
            cs[i] := cmtArray^[cmtBase + i - 1];
{$R=}
          end;
      end;
end { getComment };

function getTag(cm: pMRec; var ts: string): boolean;
begin { getTag }
  if cm = treeRoot then
    getTag := false
  else if cm^.tag = nil then
    getTag := false
  else
    begin
      ts := cm^.tag^.sTag;
      getTag := true;
    end;
end { getTag };

procedure delTag(tp: tagPtr);
var
  ttp: tagPtr;
begin { delTag }
  tp^.mPtr^.tag := nil;
  tp^.mPtr := nil;
  if stepTag = tp then
    stepTag := nil;
  ttp := treeRoot^.lastTag;
  if ttp = tp then
    treeRoot^.lastTag := tp^.nextTag
  else
    begin
      while ttp^.nextTag <> tp do
        ttp := ttp^.nextTag;
      ttp^.nextTag := tp^.nextTag;
    end;
  tp^.nextTag := treeRoot^.freeTags;
  treeRoot^.freeTags := tp;
end { delTag };

function delBranch(pm: pMRec): pMRec;
var
  sm: pMRec;

  procedure recDel(m: pMRec);
  var
    tp: tagPtr;
  begin { recDel }
    if m <> nil then
      begin
        recDel(m^.slink);
        recDel(m^.flink);
        m^.blink := nil;
        m^.slink := nil;
        m^.flink := treeRoot^.freePool;
        treeRoot^.freePool := m;
        if m^.tag <> nil then
          delTag(m^.tag);
      end;
  end { recDel };

begin { delBranch }
  if pm = treeRoot then
    exit(delBranch);
  while pm^.id = remove do
    pm := pm^.blink;
  if pm^.blink^.flink = pm then
    pm^.blink^.flink := pm^.slink
  else
    begin
      sm := pm^.blink^.flink;
      while sm^.slink <> pm do
        sm := sm^.slink;
      sm^.slink := pm^.slink;
    end;
  pm^.slink := nil;
  delBranch := pm^.blink;
  pm^.blink := nil;
  recDel(pm);
end { delBranch };

procedure delNode(pm: pMRec);
var
  sm: pMRec;
begin { delNode }
  if pm = treeRoot then
    exit(delNode);
  if pm^.blink^.flink = pm then
    pm^.blink^.flink := pm^.slink
  else
    begin
      sm := pm^.blink^.flink;
      while sm^.slink <> pm do
        sm := sm^.slink;
      sm^.slink := pm^.slink;
    end;
  pm^.blink := nil;
  pm^.slink := nil;
  pm^.flink := treeRoot^.freePool;
  treeRoot^.freePool := pm;
end { delNode };

function mergeMove(cm: pMRec): pMRec;
var
  tm: pMRec;
begin { mergeMove }
  tm := cm^.blink^.flink;
  mergeMove := cm;
  while tm <> nil do
    begin
      if tm <> cm then
        with tm^ do
          if id = cm^.id then
            if id = hcPlay then
              begin
                mergeMove := tm;
                delNode(cm);
                exit(mergeMove);
              end            
            else if id = pass then
              begin
                if who = cm^.who then
                  begin
                    mergeMove := tm;
                    delNode(cm);
                    exit(mergeMove);
                  end;
              end
            else if (mx = cm^.mx) and
               (my = cm^.my) and
               (who = cm^.who) then
              begin
                mergeMove := tm;
                delNode(cm);
                exit(mergeMove);
              end;
      tm := tm^.slink;
    end;
  treeDirty := true;
end { mergeMove };

function hasAlts(pm: pMRec): boolean;
begin { hasAlts }
  while pm^.id = remove do
    pm := pm^.blink;
  hasAlts := pm^.blink^.flink^.slink <> nil;
end { hasAlts };

procedure initGoTree;
begin { initGoTree }
  treeSeg := -1;
  new(0, 256, hdrBlock);
end. { initGoTree }
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦d429481c9⟧ TextFile

Derivation

TextFile
