⟦64e67b953⟧

TextFile

{---------------------------------------------------------------}
{ Go Menu Manager                                               }
{ Copyright (c) 1982 by Three Rivers Computer Corp.             }
{                                                               }
{ Written: December 3, 1982 by Stoney Ballard                   }
{ Edit History:                                                 }
{                                                               }
{   Jan  5, 1983 - Fixed bug in menu select                     }
{   Jan 27, 1983 - added setPlayLevel                           }
{---------------------------------------------------------------}

module goMenu;

exports

imports fileDefs from fileDefs;
imports goTree from goTree;

procedure initMenu;
function getMenuCmd: integer;
procedure endCmd;
procedure putMString(cmd: integer; ms: string);
procedure activate(cmd: integer; act: boolean);
procedure restoreCursor;
function confirmed: boolean;
function menuGoFile(var fName: pathName): boolean;
procedure waitNoButton;
procedure waitButton;
procedure clearLine(ln: integer);
procedure prompt(s: string);
procedure showComment;
procedure showTag;
function getHCMenu: integer;
function getTagMenu: tagPtr;
procedure setMenuCursor;
procedure menuPlayLevel(var playLevel: integer; maxLevel: integer);

private

imports goCom from goCom;
imports goMgr from goMgr;
imports popUp from popUp;
imports raster from raster;
imports screen from screen;
imports IO_Others from IO_Others;
imports fileSystem from fileSystem;
imports fileUtils from fileUtils;
imports perq_String from perq_String;

const
  mWidth = 180;
  mHeight = 18;
  mLBorder = 12;
  mTBorder = 10;
  mVSpacing = mHeight + 4;
  mHSpacing = mWidth + 8;
  grHeight = mHeight - 2;
  grWidth = (((mWidth - 2 + 15) div 16 + 3) div 4) * 4;

type
  mStr = string[20];

  menuBox = record
              leftX, topY, rightX, botY: integer;
              isAct: boolean;
              str: mStr;
            end;

  greyPat = array[0..grHeight - 1] of array[0..grWidth - 1] of integer;
  pGreyPat = ^greyPat;

var
  mItems: array[1..mLast] of menuBox;
  curHiLi, curCmd: integer;
  mGreyP: pGreyPat;
  isMenuCursor: boolean;
  valDesc: pNameDesc;
  cnfDesc: pNameDesc;
  res: resRes;
  goFNames: array[1..1024] of string[25];
  tabXPos, tabYPos: integer;

procedure restoreCursor;
begin { restoreCursor }
  if isMenuCursor then
    IOLoadCursor(defaultCursor, 0, 0)
  else
    IOLoadCursor(selCursor, curC, curC);
end { restoreCursor };

procedure waitNoButton;
begin { waitNoButton }
  while tabYellow or tabWhite or tabGreen or tabBlue or tabSwitch do;
end { waitNoButton };

procedure waitButton;
begin { waitButton }
  while not tabSwitch do;
end { waitButton };

procedure menuPlayLevel(var playLevel: integer; maxLevel: integer);
var
  plMenu: pNameDesc;
  i: integer;
  res: resres;

  handler outside;
  begin { outside }
    destroyNameDesc(plMenu);
    write(''); {control-G}
    waitNoButton;
    exit(menuPlayLevel);
  end { outside };

begin { menuPlayLevel }
  allocNameDesc(maxLevel + 1, 0, plMenu);
  plMenu^.header := 'Play Level?';
  for i := 0 to maxLevel do
    begin
{$R-}
      plMenu^.commands[i + 1] := intToStr(i);
{$R=}
    end;
  menu(plMenu, false, 1, maxLevel + 1, -1, -1, -1, res);
  playLevel := res^.indices[1] - 1;
  destroyRes(res);
  destroyNameDesc(plMenu);
end { menuPlayLevel };

function getTagMenu: tagPtr;
var
  tp: tagPtr;
  nTags, tIdx, i: integer;
  tMenu: pNameDesc;
  res: resres;

  handler outside;
  begin { outside }
    destroyNameDesc(tMenu);
    write(''); {control-G}
    waitNoButton;
    exit(getTagMenu);
  end { outside };

begin { getTagMenu }
  getTagMenu := nil;
  tp := treeRoot^.lastTag;
  nTags := 0;
  while tp <> nil do
    begin
      nTags := nTags + 1;
      tp := tp^.nextTag;
    end;
  if nTags = 0 then
    write('') {control-G}
  else
    begin
      tp := treeRoot^.lastTag;
      allocNameDesc(nTags, 0, tMenu);
      tMenu^.header := 'Which Tag?';
      for i := nTags downTo 1 do
        begin
{$R-}
          tMenu^.commands[i] := tp^.sTag;
{$R=}
          tp := tp^.nextTag;
        end;
      menu(tMenu, false, 1, nTags, -1, -1, -1, res);
      restoreCursor;
      tIdx := nTags - res^.indices[1];
      destroyRes(res);
      destroyNameDesc(tMenu);
      tp := treeRoot^.lastTag;
      for i := 1 to tIdx do
        tp := tp^.nextTag;
      getTagMenu := tp;
    end;
end { getTagMenu };

procedure clearLine(ln: integer);
var
  lY: integer;
begin { clearLine }
  lY := winTable[statWin].winTY +
        (ln * (charHeight + lineDel)) + lineY - charHeight;
  rasterop(RAndNot, sWinW - promptX - 32, charHeight,
                    promptX, lY, SScreenW, SScreenP,
                    promptX, lY, SScreenW, SScreenP);
end { clearLine };

procedure posLine(ln: integer);
var
  lY: integer;
begin { posLine }
  clearLine(ln);
  lY := winTable[statWin].winTY + (ln * (charHeight + lineDel)) + lineY;
  SSetCursor(promptX, lY);
end { posLine };

procedure prompt(s: string);
begin { prompt }
  posLine(promptLine);
  write(s);
end { prompt };

procedure showTag;
var
  ts: string;
begin { showTag }
  posLine(tagLine);
  if getTag(curMove, ts) then
    write('Tag: ', ts);
end { showTag };

procedure showComment;
var
  cs: string;
begin { showComment }
  posLine(cmtLine);
  if getComment(curMove, cs) then
    write('Comment: ', cs);
end { showComment };

function getHCMenu: integer;
var
  res: resres;

  handler outside;
  begin { outside }
    restoreCursor;
    getHCMenu := none;
    write(''); {control-G}
    exit(getHCMenu);
  end { outside };

begin { getHCMenu }
  menu(valDesc, false, 1, 8, -1, -1, -1, res);
  restoreCursor;
  getHCMenu := res^.indices[1] + 1;
  destroyRes(res);
end { getHCMenu };

function menuGoFile(var fName: pathName): boolean;
var
  fi, i: integer;
  fid: fileID;
  fileMenu: pNameDesc;
  res: resres;
  scanP: ptrScanRecord;

  function isGoFName(var rName: string): boolean;
  var
    ts: string;
  begin { isGoFName }
    isGoFName := false;
    ts := rName;
    convUpper(ts);
    if length(ts) < 3 then
      exit(isGoFName);
    ts := subStr(ts, length(ts) - 2, 3);
    if ts = '.GO' then
      begin
        rName := subStr(rName, 1, length(rName) - 3);
        isGoFName := true;
      end;
  end { isGoFName };

  handler outside;
  begin { outside }
    destroyNameDesc(fileMenu);
    restoreCursor;
    menuGoFile := false;
    write(''); {control-G}
    exit(menuGoFile);
  end { outside };

begin { menuGoFile }
  new(scanP);
  scanP^.initialCall := true;
  scanP^.dirName := '';
  prompt('Scanning Directory...');
  fi := 0;
  while FSScan(scanP, fName, fid) do
    if isGoFName(fName) then
      begin
        fi := fi + 1;
        goFNames[fi] := fName;
      end;
  dispose(scanP);
  prompt('');
  if fi < 1 then
    begin
      prompt('No GO files found');
      menuGoFile := false;
      exit(menuGoFile);
    end;
  allocNameDesc(fi, 0, fileMenu);
  fileMenu^.header := 'Available Games';
  for i := 1 to fi do
    begin
{$R-}
      fileMenu^.commands[i] := goFNames[i];
{$R=}
    end;
  menu(fileMenu, false, 1, fi, -1, -1, -1, res);
  restoreCursor;
  destroyNameDesc(fileMenu);
  fName := goFNames[res^.indices[1]];
  destroyRes(res);
  menuGoFile := true;
end { menuGoFile };

function confirmed: boolean;

  handler outside;
  begin { outside }
    confirmed := false;
    restoreCursor;
    exit(confirmed);
  end { outside };

begin { confirmed }
  if treeDirty then
    begin
      menu(cnfDesc, false, 1, 2, -1, -1, -1, res);
      restoreCursor;
      confirmed := res^.indices[1] = 2;
      destroyRes(res);
    end
  else
    confirmed := true;
end { confirmed };

procedure activate(cmd: integer; act: boolean);
var
  dFun: lineStyle;
begin { activate }
  with mItems[cmd] do
    begin
      isAct := act;
      if isAct then
        dFun := drawLine
      else
        dFun := eraseLine;
      line(dFun, leftX, topY, rightX, topY, SScreenP);
      line(dFun, leftX, botY, rightX, botY, SScreenP);
      line(dFun, leftX, topY, leftX, botY, SScreenP);
      line(dFun, rightX, topY, rightX, botY, SScreenP);
    end;
end { activate };

function findItem(x, y: integer): integer;
var
  i: integer;
begin { findItem }
  for i := 1 to mLast do
    with mItems[i] do
      if isAct then
        if (x >= leftX) and (x <= rightX) and
           (y >= topY) and (y <= botY) then
          begin
            findItem := i;
            exit(findItem);
          end;
  findItem := none;
end { findItem };

procedure invertItem(cmd: integer);
begin { invertItem }
  with mItems[cmd] do
    rasterop(rNot, mWidth - 2, mHeight - 2,
                   leftX + 1, topY + 1, SScreenW, SScreenP,
                   leftX + 1, topY + 1, SScreenW, SScreenP);
end { invertItem };

procedure checkHighLight;
var
  cmd: integer;
begin { checkHighLight }
  cmd := findItem(tabXPos, tabYPos);
  if cmd <> curHiLi then
    begin
      if curHiLi <> none then
        invertItem(curHiLi);
      if cmd <> none then
        invertItem(cmd);
      curHiLi := cmd;
    end;
end { checkHighLight };

procedure writeMStr(cmd, cFunc: integer);
begin { writeMStr }
  SChrFunc(cFunc);
  with mItems[cmd] do
    begin
      SSetCursor(leftX + 9, botY - 2);
      write(str);
    end;
  SChrFunc(rRpl);
end { writeMStr };

procedure xorGrey(cmd: integer);
begin { xorGrey }
  if (cmd <> none) and (cmd <= mLast) then
    with mItems[cmd] do
      rasterop(rXor, mWidth - 2, mHeight - 2,
                     leftX + 1, topY + 1, SScreenW, SScreenP,
                     0, 0, grWidth, mGreyP);
end { xorGrey };

procedure selItem(cmd: integer);
begin { selItem }
  xorGrey(cmd);
  writeMStr(cmd, rOr);
end { selItem };

procedure deSelItem(cmd: integer);
begin { deSelItem }
  xorGrey(cmd);
  writeMStr(cmd, rAndNot);
end { deSelItem };

procedure setMenuCursor;
begin { setMenuCursor }
  if not isMenuCursor then
    begin
      IOLoadCursor(defaultCursor, 0, 0);
      isMenuCursor := true;
    end;
end { setMenuCursor };

function getMenuCmd: integer;
var
  cmd, nCmd: integer;
  gOn: boolean;
begin { getMenuCmd }
  tabXPos := tabRelX;
  tabYPos := tabRelY;
  with winTable[boardWin] do
    if (tabXPos >= winLX) and (tabXPos <= winRX) and
       (tabYPos >= winTY) and (tabYPos <= winBY) then
      begin
        if isMenuCursor then
          IOLoadCursor(selCursor, curC, curC);
        isMenuCursor := false;
      end
    else
      setMenuCursor;
  checkHighLight;
  if not tabSwitch then
    curCmd := none
  else if tabWhite then
    begin
      with mItems[mBackOne] do
        if isAct then
          begin
            cmd := mBackOne;
            if curHiLi <> cmd then
              begin
                if curHiLi <> none then
                  invertItem(curHiLi);
                invertItem(cmd);
              end;
            curHiLi := cmd;
            curCmd := cmd;
            selItem(cmd);
          end
        else
          write(''); {control-G}
      waitNoButton;
    end
  else if tabGreen then
    begin
      with mItems[mForOne] do
        if isAct then
          begin
            cmd := mForOne;
            if curHiLi <> cmd then
              begin
                if curHiLi <> none then
                  invertItem(curHiLi);
                invertItem(cmd);
              end;
            curHiLi := cmd;
            curCmd := cmd;
            selItem(cmd);
          end
        else
          write(''); {control-G}
      waitNoButton;
    end
  else { tabYellow or tabBlue }
    begin
      cmd := findItem(tabXPos, tabYPos);
      if cmd <> none then
        begin
          selItem(cmd);
          gOn := true;
          while tabSwitch do
            begin
              nCmd := findItem(tabRelX, tabRelY);
              if nCmd <> cmd then
                begin
                  if gOn then
                    deSelItem(cmd);
                  gOn := false;
                end
              else
                begin
                  if not gOn then
                    selItem(cmd);
                  gOn := true;
                end;  
            end;
          if gOn then
            begin
              curCmd := cmd;
            end
          else
            begin
              write(''); {control-G}
              curCmd := none;
            end;
          waitNoButton;
        end
      else
        with winTable[boardWin] do
          if (tabXPos >= winLX) and (tabXPos <= winRX) and
             (tabYPos >= winTY) and (tabYPos <= winBY) then
            curCmd := mPlaceStone
          else
            begin
              write(''); {control-G}
              curCmd := none;
              waitNoButton;
            end;
    end;
  getMenuCmd := curCmd;
end { getMenuCmd };

procedure endCmd;
begin { endCmd }
  if (curCmd <> none) and (curCmd <= mLast) then
    deSelItem(curCmd);
  curCmd := none;
end { endCmd };

procedure putMString(cmd: integer; ms: string);
begin { putMString }
  if (curCmd = cmd) and (cmd <= mLast) then
    begin
      deSelItem(cmd);
      curCmd := none;
    end;
  with mItems[cmd] do
    begin
      rasterOp(rAndNot, mWidth - 2, mHeight - 2,
               leftX + 1, topY + 1, SScreenW, SScreenP,
               leftX + 1, topY + 1, SScreenW, SScreenP);
      str := ms;
      writeMStr(cmd, rRpl);
      if curHiLi = cmd then
        invertItem(cmd);
    end;
end { putMString };

procedure initMenu;
var
  i, j: integer;

  procedure setItem(cmd, sx, sy: integer; cs: string);
  begin { setItem }
    with mItems[cmd] do
      begin
        leftX := (sx * mHSpacing) + mLBorder + mWinX;
        topY := (sy * mVSpacing) + mTBorder + mWinY;
        isAct := false;
        rightX := leftX + mWidth - 1;
        botY := topY + mHeight - 1;
        putMString(cmd, cs);
      end;
  end { setItem };

begin { initMenu }
  curHiLi := none;
  curCmd := none;
  setItem(mPass, 0, 0, 'Pass');
  setItem(mAutoPlay, 0, 1, 'Generate Move');
  setItem(mPlayMyself, 0, 2, 'Play Myself');
  setItem(mSetPlayLevel, 0, 3, 'Set Play Level');
  setItem(mSetHC, 0, 4, 'Set Handicap');
  setItem(mScore, 0, 5, 'Score');
  setItem(mQuit, 0, 6, 'Quit');
  setItem(mInit, 0, 7, 'Initialize');
  setItem(mBackOne, 1, 0, 'Backup One');
  setItem(mGotoRoot, 1, 1, 'Back to Start');
  setItem(mBackToBr, 1, 2, 'Back to Branch');
  setItem(mBackToStone, 1, 3, 'Back to Stone');
  setItem(mEraseMove, 1, 4, 'Erase Move');
  setItem(mPruneBranches, 1, 5, 'Prune Branches');
  setItem(mDebug, 1, 6, 'Turn Debug On');
  setItem(mWriteFile, 1, 7, 'Write File');
  setItem(mForOne, 2, 0, 'Forward One');
  setItem(mForToLeaf, 2, 1, 'Forward to Leaf');
  setItem(mForToBr, 2, 2, 'Forward to Branch');
  setItem(mStepToTag, 2, 3, 'Step Towards Tag');
  setItem(mGotoTag, 2, 5, 'Go To Tag');
  setItem(mRefBoard, 2, 6, 'Refresh Board');
  setItem(mReadFile, 2, 7, 'Read File');
  setItem(mPutTag, 3, 0, 'Put Tag');
  setItem(mPutCmt, 3, 1, 'Put Comment');
  setItem(mSetStepTag, 3, 2, 'Set Step Tag');
  setItem(mShoState, 3, 3, 'Show Player State');
  setItem(mTogNums, 3, 4, 'Show Stone Numbers');
  setItem(mBoardSize, 3, 5, 'Use Small Board');
  setItem(mPrintBoard, 3, 6, 'Print Board');
  setItem(mPrintDiag, 3, 7, 'Print Diagram');
  initPopUp;
  allocNameDesc(8, 0, valDesc);
  with valDesc^ do
    begin
{$R-}
      header := 'How Many?';
      commands[1] := '2';
      commands[2] := '3';
      commands[3] := '4';
      commands[4] := '5';
      commands[5] := '6';
      commands[6] := '7';
      commands[7] := '8';
      commands[8] := '9';
{$R=}
    end;
  allocNameDesc(2, 0, cnfDesc);
  with cnfDesc^ do
    begin
      header := 'Confirm';
{$R-}
      commands[1] := 'No';
      commands[2] := 'Yes';
{$R=}
    end;
  new(0, 4, mGreyP);
  i := 0;
  repeat
    for j := 0 to (grWidth - 1) do
      case (i mod 4) of
        0, 2:
          mGreyP^[i, j] := #177777;
        1:
          mGreyP^[i, j] := #125252;
        3:
          mGreyP^[i, j] := #052525;
      end;
    i := i + 1;
  until i > (grHeight - 1);
  isMenuCursor := true;
end. { initMenu }
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦64e67b953⟧ TextFile

Derivation

TextFile
