ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/UTILITY/FILE/XLAT11.ZIP/CONFXLAT.PAS

Pascal/Delphi Source File | 1990-08-12 | 36.1 KB | 1,112 lines

Program confxlat;
{ Customize a XLAT(R).COM programme                                          }
{ FreeWare by TapirSoft Gisbert W.Selke, Oct 1989/Aug 1990                   }

{$UNDEF  DEBUG }        { DEFINE while debugging }

{$A+,B-,D+,E+,F-,I+,L+,N-,O-,V- }
{$M 16384,0,16384 }
{$IFDEF DEBUG }
  {$R+,S+ }
{$ELSE }
  {$R-,S- }
{$ENDIF }

  Uses Dos, Crt;

  Const progname  = 'ConfXlat';
        version   = '1.1';
        copyright = 'FreeWare by TapirSoft Gisbert W.Selke, Oct 1989/Aug 1990';
        idstring10= 'XLAT10';
        idstring11= 'XLAT11';
        idlength  = Length(idstring10);
        hexnibble : string[16] = '0123456789ABCDEF';
        digits    : string[10] = '0123456789';

  Const fbufsize = 4096;
        width    = 18;
        videoint = $10;
        blockcur = $010C;          { normcur  defined dynamically! }
        nocur    = $2B0C;
        F1       = #59;              F2       = #60;
        F3       = #61;              F4       = #62;
        F5       = #63;              F6       = #64;
        F7       = #65;              F8       = #66;
        F9       = #67;              F10      = #68;
        CtrlC    = #3;               Esc      = #27;
        Return   = #13;
        Home     = #71;              UpAr     = #72;
        PgUp     = #73;              LfAr     = #75;
        RtAr     = #77;              EndK     = #79;
        DnAr     = #80;              PgDn     = #81;
        Ins      = #82;              Del      = #83;
        CHome    = #119;             CEndK    = #117;

  Type tabletype = Array [byte] Of byte;

  Var fname : string;
      xlat  : File;
      tabf  : text;
      fbuf  : Array [1..fbufsize] Of byte;
      fsize : word;
      descript, intername : string;
      tstart, tabstart, interstart : word;
      desclen : byte;
      xlatid : byte;
      table : tabletype;
      changed, floaded : boolean;
      ch : char;
      maxlin, maxcol : byte;
      row : byte;
      col, leftcol : integer;
      normcur : word;
      exitsave : Pointer;

  Function hexbyte(b : byte) : string;
  { convert a byte to a string                                               }
  Begin                                                            { hexbyte }
    hexbyte := hexnibble[Succ(b ShR 4)] + hexnibble[Succ(b And $0F)];
  End;                                                             { hexbtye }

  Procedure beep;
  { error noise                                                              }
  Begin                                                               { beep }
    Sound(440);
    Delay(100);
    NoSound;
  End;                                                                { beep }

  Procedure putchar(b : byte);
  { show a character on the screen, without interpreting control chars       }
  Inline($B4/$0F/                {Mov ah, $0F       ; get current video mode }
         $CD/$10/                {Int $10           ; in bh                  }
         $58/                    {Pop ax            ; get char in al         }
         $B4/$0A/                {Mov ah, $0A       ; output char            }
         $B3/$70/                {Mov bl, $70       ; white on black         }
         $B9/$01/$00/            {Mov cx, $01       ; just one copy          }
         $CD/$10);               {Int $10                                    }

  Procedure setcursor(curtype : word);
  { set cursor start and end line and blink bits                             }
    Var regs : Registers;
  Begin                                                          { setcursor }
    With regs Do
    Begin
      ah := $0F;
      Intr(videoint,regs);
      cx := curtype;
      ah := $01;
      Intr(videoint,regs);
    End;
  End;                                                           { setcursor }

  Procedure getcursor;
  { get cursor start and end line and blink bits, put them into normcur      }
    Var regs : Registers;
  Begin                                                          { setcursor }
    With regs Do
    Begin
      ah := $0F;
      Intr(videoint,regs);
      ah := $03;
      Intr(videoint,regs);
      normcur := cx;
    End;
  End;                                                           { setcursor }

  Procedure moreprompt;
  { wait for key press at bottom of 'list' window                            }
    Var ch : char;
  Begin                                                         { moreprompt }
    GoToXY(maxcol-25,8);
    write('Hit space bar...');
    ch := ReadKey;
    While KeyPressed Do ch := ReadKey;
    GoToXY(1,8);
    ClrEoL;
  End;                                                          { moreprompt }

  Procedure openlistwindow;
  { open a window in central part of screen                                  }
    Var i : byte;
  Begin                                                     { openlistwindow }
    Window(1,11,maxcol,20);
    ClrScr;
    GoToXY(2,1);
    write(#218);
    For i := 3 To 78 Do write(#196);
    write(#191);
    For i := 2 To 9 Do
    Begin
      GoToXY(2,i);
      write(#179);
      GoToXY(79,i);
      write(#179);
    End;
    GoToXY(2,10);
    write(#192);
    For i := 3 To 78 Do write(#196);
    write(#217);
    Window(4,12,maxcol-4,19);
  End;                                                      { openlistwindow }

  Procedure errmsg(s : string);
  { display an error message                                                 }
    Var i : byte;
        ch : char;
  Begin                                                             { errmsg }
    SetCursor(nocur);
    Window(1,11,maxcol,13);
    ClrScr;
    GoToXY(1,1);
    write(#218);
    For i := 1 To Length(s)+2 Do write(#196);
    write(#191);
    GoToXY(1,2);
    write(#179,' ',s,' ',#179);
    GoToXY(1,3);
    write(#192);
    For i := 1 To Length(s)+2 Do write(#196);
    write(#217);
    While KeyPressed Do ch := ReadKey;
    ch := ReadKey;
    While KeyPressed Do ch := ReadKey;
    ClrScr;
    Window(1,1,maxcol,maxlin);
    SetCursor(normcur);
  End;                                                              { errmsg }

  Function showfiles(mask : string) : boolean;
  { if mask contains wildcards, show all files that match, then return True  }
    Var wild : boolean;
        i, linct, colct : byte;
        sr : SearchRec;
  Begin                                                          { showfiles }
    wild := False;
    For i := 1 To Length(mask) Do wild := wild Or (mask[i] = '?') Or
                                                  (mask[i] = '*');
    showfiles := wild;
    If Not wild Then Exit;
    openlistwindow;
    FindFirst(mask,Archive+ReadOnly+Hidden,sr);
    linct := 0;
    colct := 0;
    wild := False;
    While DosError = 0 Do
    Begin
      wild := True;
      i := Pos('.',sr.name);
      write(' ':(10-i),sr.name,' ':(4-Length(sr.name)+i));
      Inc(colct);
      If colct >= 5 Then
      Begin
        writeln;
        Inc(linct);
        If linct >= 7 Then
        Begin
          moreprompt;
          linct := 0;
        End;
        colct := 0;
      End;
      FindNext(sr);
    End;
    If Not wild Then
    Begin
      writeln('No files matching "',mask,'"');
      linct := 1;
    End;
    If (linct > 0) Or (colct > 0) Then
    Begin
      writeln;
      moreprompt;
    End;
    Window(1,11,maxcol,20);
    ClrScr;
    Window(1,1,maxcol,maxlin);
  End;                                                           { showfiles }

  Procedure initdisplay;
  { initialize display                                                       }
    Var i : byte;
  Begin                                                        { initdisplay }
    Window(1,1,maxcol,maxlin);
    ClrScr;
    GoToXY(3,1);
    write('Internal name: ',intername);
    Case xlatid Of
      10 : write('  (filter)');
      11 : write('  (resident)');
      Else ;
    End;
    While (descript <> '') And (descript[Length(descript)] = ' ') Do
                                         Delete(descript,Length(descript),1);
    GoToXY(79 - Length(descript),1);
    write(descript);
    GoToXY(1,2);
    write(#214);
    For i := 2 To 79 Do write(#196);
    write(#183);
    For i := 1 To 3 Do
    Begin
      GoToXY( 1,i+2); write(#186);
      GoToXY(80,i+2); write(#186);
      GoToXY( 1,i+6); write(#186);
      GoToXY(80,i+6); write(#186);
    End;
    GoToXY(2,4);
    write('From:');
    GoToXY(2,8);
    write('To:');
    GoToXY(1,6);
    write(#199);
    For i := 2 To 79 Do write(#196);
    write(#182);
    GoToXY(1,10);
    write(#211);
    For i := 2 To 79 Do write(#196);
    write(#189);
    GoToXY(1,21);
    write(#201);
    For i := 2 To 79 Do write(#205);
    write(#187);
    GoToXY(1,22);
    write(#186,' F1 clear to 0    F3 quit      F5 load com   ',
          'F7 load table   F9  check invert ',#186);
    GoToXY(1,23);
    write(#186,' F2 clear to id                F6 save com   ',
          'F8 save table   F10 invert table ',#186);
    GoToXY(1,24);
    write(#200);
    For i := 2 To 79 Do write(#205);
    write(#188);
    GoToXY(40-(Length(progname)+Length(version)+Length(copyright)+7) Div 2,25);
    write(progname,' ',version,'  --  ',copyright);
    leftcol := 1;
    col := 3;
    row := 1;
  End;                                                         { initdisplay }

  Procedure showone(b, col : byte; upper : boolean);
  { show one byte in its three incarnations; upper or lower row              }
    Var row : byte;
        incr : shortint;
  Begin                                                            { showone }
    col := col + 8;
    If upper Then
    Begin
      row := 3;
      incr := 1;
    End
    Else
    Begin
      row := 9;
      incr := -1;
    End;
    GoToXY(col,row);
    write(b:3);
    GoToXY(col,row+incr);
    write('x',hexbyte(b):2);
    GoToXY(col+2,row+incr+incr);
    putchar(b);
  End;                                                             { showone }

  Procedure adjustdisplay;
  { show proper segment of table                                             }
    Var i, k, start, ende : byte;
  Begin                                                      { adjustdisplay }
    setcursor(nocur);
    If col < leftcol Then leftcol := Succ(4*(col Div 4));
    If col > leftcol+4*width Then leftcol := Succ(4*(((col+3) Div 4) - width));
    start := Pred(leftcol) Div 4;
    ende  := start + width - 1;
    GoToXY(8,3);
    k := 4*integer(start)-leftcol+1;
    For i := start To ende Do
    Begin
      showone(i,k,True);
      showone(table[i],k,False);
      k := k + 4;
    End;
    setcursor(normcur);
  End;                                                       { adjustdisplay }

  Function dialog(prompt : string; len : byte; proto : string) : string;
  { show prompt, read answer, with default answer                            }
    Var s : string;
        ch : char;
        i, k, w : byte;
        insmode : boolean;
  Begin                                                             { dialog }
    If Length(prompt) + len > 74 Then len := 74 - Length(prompt);
    proto := Copy(proto,1,len);
    s := proto;
    While Length(s) < len Do s := s + ' ';
    w := Length(prompt) + len + 5;
    Window(1,14,maxcol,16);
    ClrScr;
    GoToXY(1,1);
    write(#218);
    For i := 2 To Pred(w) Do write(#196);
    write(#191);
    GoToXY(1,2);
    write(#179,' ',prompt,' ',s);
    GoToXY(w,2);
    write(#179);
    GoToXY(1,3);
    write(#192);
    For i := 2 To Pred(w) Do write(#196);
    write(#217);
    w := Length(prompt) + 3;
    i := 1;
    insmode := False;
    SetCursor(normcur);
    Repeat
      GoToXY(w+i,2);
      ch := ReadKey;
      Case ch Of
        ' '..#254 : Begin { ordinary char }
               If insmode Then
               Begin
                 For k := Pred(len) DownTo i Do s[Succ(k)] := s[k];
                 s[i] := ch;
                 For k := i To len Do write(s[k]);
                 Inc(i);
               End
               Else
               Begin
                 s[i] := ch;
                 write(ch);
                 Inc(i);
               End;
             End;
        #8 : Begin { backspace }
               If i > 1 Then
               Begin
                 GoToXY(w+Pred(i),2);
                 For k := i To len Do
                 Begin
                   s[Pred(k)] := s[k];
                   write(s[k]);
                 End;
                 s[len] := ' ';
                 write(' ');
                 Dec(i);
               End;
             End;
        #0 : Begin { extended key }
               ch := ReadKey;
               Case ch Of
                 LfAr : If i > 1 Then Dec(i);   { leftarrow }
                 RtAr : If i < len Then Inc(i); { rightarrow }
                 Home : i := 1;                 { home }
                 EndK : Begin                   { end }
                          i := len;
                          While (i > 1) And (s[Pred(i)] = ' ') Do Dec(i);
                        End;
                 Ins  : Begin                   { insert }
                          insmode := Not insmode;
                          If insmode Then SetCursor(blockcur)
                                     Else SetCursor(normcur);
                        End;
                 Del  : Begin                   { delete }
                          For k := i To Pred(len) Do
                          Begin
                            s[k] := s[Succ(k)];
                            write(s[k]);
                          End;
                          s[len] := ' ';
                          write(' ');
                        End;
                 CHome: Begin                   { Control-Home }
                          GoToXY(w+1,2);
                          For k := Succ(i) To len Do
                          Begin
                            s[k-i] := s[k];
                            write(s[k]);
                          End;
                          For k := len-i+1 To len Do
                          Begin
                            s[k] := ' ';
                            write(' ');
                          End;
                          i := 1;
                        End;
                 CEndK: Begin                   { Control-End }
                          For k := i To len Do
                          Begin
                            s[k] := ' ';
                            write(s[k]);
                          End;
                        End;
                 F3   : ch := Esc;              { general QUIT key }
                 Else   ch := #0;
               End;
             End;
        Else ;
      End;
    Until (i >= len) Or (ch In [CtrlC,Esc,Return]);
    If ch In [CtrlC,Esc] Then s := '';
    While (s <> '') And (s[Length(s)] = ' ') Do Delete(s,Length(s),1);
    dialog := s;
    ClrScr;
    Window(1,1,maxcol,maxlin);
    SetCursor(normcur);
  End;                                                              { dialog }

  Procedure edittable;
  { edit a translation table                                                 }

    Var cn, dig : byte;
        d : Array [1..3] Of byte;
        ok : boolean;

  Begin                                                          { edittable }
    If leftcol >= 1024 Then initdisplay;
    adjustdisplay;
    Repeat
      Case row Of
        1 : While col Mod 4 < 3 Do Inc(col);
        2 : If col Mod 4 = 1 Then Inc(col);
        3 : ;
      End;
      If (col < leftcol) Or (col > leftcol+4*width) Then adjustdisplay;
      GoToXY(col-leftcol+8,row+6);
      ch := ReadKey;
      ok := True;
      If ch <> #0 Then
      Begin
        cn := col Div 4;
        Case row Of
          1 : table[cn] := Ord(ch);
          2 : Begin
                ch := UpCase(ch);
                dig := Pos(ch,hexnibble);
                If dig > 0 Then
                Begin
                  d[2] := Ord(table[cn]) ShR 4;
                  d[3] := Ord(table[cn]) And $0F;
                  d[col Mod 4] := Pred(dig);
                  table[cn] := (d[2] ShL 4) Or d[3];
                End
                Else ok := False;
              End;
          3 : Begin
                ch := UpCase(ch);
                If ch In ['0'..'9'] Then
                Begin
                  dig := Ord(ch) - 48;
                  d[1] := Ord(table[cn]) Div 100;
                  d[2] := (Ord(table[cn]) Div 10) Mod 10;
                  d[3] := table[cn] Mod 10;
                  d[col Mod 4] := dig;
                  table[cn] := (d[1]*10+d[2])*10+d[3];
                End
                Else ok := False;
              End;
        End;
        If ok Then
        Begin
          changed := True;
          showone(table[cn],4*((col-leftcol) Div 4),False);
          ch := RtAr;
        End
        Else
        Begin
          beep;
          ch := #0;
        End;
      End
        Else ch := ReadKey;
      Case ch Of
        #0, F1..F10 : ;
        Home : col := 0;
        UpAr : If row > 1 Then Dec(row);
        PgUp : If col >= 4*width Then col := col - 4*width Else col := 0;
        LfAr : Begin
                 Case row Of
                   1 : Dec(col,4);
                   2 : If col Mod 4 = 2 Then Dec(col,3) Else Dec(col);
                   3 : If col Mod 4 = 1 Then Dec(col,2) Else Dec(col);
                 End;
                 If col < 1 Then col := 1;
               End;
        RtAr : Begin
                 Case row Of
                   1 : Inc(col,4);
                   2 : If col Mod 4 = 3 Then Inc(col,3) Else Inc(col);
                   3 : If col Mod 4 = 3 Then Inc(col,2) Else Inc(col);
                 End;
                 If col > 1023 Then col := 1023;
               End;
        EndK : col := 1023;
        DnAr : If row < 3 Then Inc(row);
        PgDn : If col+4*width <= 1023 Then col := col + 4*width
                                      Else col := 1023;
        Else   beep;
      End;
    Until ch In [F1..F10];
  End;                                                           { edittable }

  Procedure checkinvert;
  { check table for invertibility                                            }

    Var i, k, found, firstval, outct : byte;
        noprob1, noprob2 : boolean;
        nofound : Array [0..255] Of boolean;

  Begin                                                        { checkinvert }
    openlistwindow;
    noprob1 := True;
    noprob2 := True;
    outct := 0;
    For i := 0 To 255 Do
    Begin
      nofound[i] := True;
      found := 0;
      For k := 0 To 255 Do
      Begin
        If table[k] = i Then
        Begin
          nofound[i] := False;
          If found = 0 Then firstval := k
          Else
          Begin
            If found = 1 Then write('Multi image: x',hexbyte(i),': x',
                                    hexbyte(firstval));
            If WhereX > 66 Then
            Begin
              writeln;
              Inc(outct);
              If outct >= 7 Then
              Begin
                moreprompt;
                outct := 0;
              End;
              write(' ':17);
            End;
            write(' x',hexbyte(k));
          End;
          Inc(found);
        End;
      End;
      If found > 1 Then
      Begin
        noprob1 := False;
        writeln;
        Inc(outct);
        If outct >= 7 Then
        Begin
          moreprompt;
          outct := 0;
        End;
      End;
    End;
    writeln;
    Inc(outct);
    If outct >= 7 Then
    Begin
      moreprompt;
      outct := 0;
    End;
    write('No images: ');
    For i := 0 To 255 Do
    Begin
      If nofound[i] Then
      Begin
        noprob2 := False;
        If WhereX > 66 Then
        Begin
          writeln;
          Inc(outct);
          If outct >= 7 Then
          Begin
            moreprompt;
            outct := 0;
          End;
          write(' ':11);
        End;
        write(' x',hexbyte(i));
      End;
    End;
    If noprob2 Then writeln('none')
               Else writeln;
    If noprob1 And noprob2 Then writeln('Table is invertible.');
    moreprompt;
    Window(1,11,maxcol,20);
    ClrScr;
    Window(1,1,maxcol,maxlin);
  End;                                                         { checkinvert }

  Procedure invert;
  { invert a translation table                                               }
    Var temp : tabletype;
        i : byte;
  Begin                                                             { invert }
    For i :=   0     To   255 Do temp[i] := 0;
    For i := 255 DownTo     0 Do temp[table[i]] := i;
    table := temp;
    changed := True;
  End;                                                              { invert }

  Procedure checksave; Forward;

  Procedure cleartable(tonull : boolean);
  { clear table to 0 or to id                                                }
    Var i : byte;
  Begin                                                         { cleartable }
    checksave;
    If tonull Then
    Begin
      For i := 0 To 255 Do table[i] := 0;
      fname := 'NULL';
      descript := 'Maps all to 0';
    End
    Else
    Begin
      For i := 0 To 255 Do table[i] := i;
      fname := 'IDENT';
      descript := 'Identity mapping';
    End;
    intername := fname;
    leftcol := 9999;
  End;                                                          { cleartable }

  Procedure loadcom;
  { load a translation table from a COM file                                 }

    Const proginfoptr = 4;

    Var i, xinterstart : word;
        temp, fname1 : string;
        dodialog : boolean;

  Begin                                                            { loadcom }
    checksave;
    dodialog := floaded;
    Repeat
      fname1 := fname;
      If dodialog Or (fname1 = '') Then
                             fname1 := dialog('Name of COM file:',80,fname1);
      If fname  = '' Then fname := fname1;
      If fname1 = '' Then
      Begin
        errmsg('Load COM operation cancelled');
        Exit;
      End;
      If Pos('.',fname1) = 0 Then fname1 := fname1 + '.COM';
      dodialog := True;
    Until Not showfiles(fname1);
    i := FileMode;
    FileMode := 0;
    Assign(xlat,fname1);
    {$I- }
    Reset(xlat,1);
    FileMode := i;
    If IOResult <> 0 Then
    Begin
      errmsg('File ' + fname1 + ' not found');
      Exit;
    End;
    BlockRead(xlat,fbuf,fbufsize,fsize);
    Close(xlat);
    {$I+ }
    If IOResult <> 0 Then
    Begin
      errmsg('Error reading file ' + fname1);
      Exit;
    End;
    i := fbuf[proginfoptr] + 1;
    temp[0] := Chr(idlength);
    Move(fbuf[i],temp[1],idlength);
    xlatid := 0;
    If temp = idstring10 Then xlatid := 10;
    If temp = idstring11 Then xlatid := 11;
    If xlatid = 0 Then
    Begin
      errmsg('Unknown programme version ' + temp);
      Exit;
    End;
    Move(fbuf[i+8],xinterstart,2);
    If xinterstart >= fsize Then
    Begin
      errmsg('File ' + fname1 + ' has invalid format');
      Exit;
    End;
    interstart := Succ(xinterstart);
    tstart := Succ(fbuf[i+6]);
    desclen := fbuf[i+7];
    Move(fbuf[i+10],tabstart,2);
    Inc(tabstart);
    Move(fbuf[tstart],descript[1],desclen);
    descript[0] := Chr(desclen);
    Move(fbuf[tabstart],table,256);
    Move(fbuf[interstart],intername[1],8);
    intername[0] := #8;
    col := 1;
    row := 3;
    leftcol := 9999;
    changed := False;
    floaded := True;
    fname := fname1;
  End;                                                             { loadcom }

  Procedure savecom;
  { save a translation table as a COM file                                   }
    Const cancelcomsave = 'Save COM operation cancelled';
    Var c : char;
        s : string;
        iwrite : word;
  Begin                                                            { savecom }
    {$I- }
    s := dialog('Enter short description:',desclen,descript);
    If s = '' Then
    Begin
      errmsg(cancelcomsave);
      Exit;
    End;
    descript := s;
    While Length(descript) < desclen Do descript := descript + ' ';
    s := dialog('Enter name of com file:',60,fname);
    If s = '' Then
    Begin
      errmsg(cancelcomsave);
      Exit;
    End;
    fname := s;
    If Pos('.',fname) = 0 Then fname := fname + '.COM';
    intername := fname;
    While (intername <> '') And (Pos(':',intername) > 0) Do
                                  Delete(intername,1,Pos(':',intername));
    While (intername <> '') And (Pos('\',intername) > 0) Do
                                  Delete(intername,1,Pos('\',intername));
    While (intername <> '') And (Pos('.',intername) > 0) Do
                                  Delete(intername,Pos('.',intername),255);
    While Length(intername) < 8 Do intername := intername + ' ';
    Assign(xlat,fname);
    Reset(xlat,1);
    If IOResult = 0 Then
    Begin
      Close(xlat);
      Repeat
        s := dialog('File '+fname+' already exists. Continue? (y/n)',1,'N');
        If s = '' Then c := Esc Else c := UpCase(s[1]);
      Until c In ['Y','J','1','N','0',CtrlC,Esc];
      If c In ['N','0',CtrlC,Esc] Then
      Begin
        errmsg(cancelcomsave);
        Exit;
      End;
    End;
    Rewrite(xlat,1);
    If IOResult <> 0 Then
    Begin
      errmsg('Cannot open '+fname+' for output.');
      Exit;
    End;
    Move(descript[1],fbuf[tstart],desclen);
    Move(table,fbuf[tabstart],256);
    Move(intername[1],fbuf[interstart],8);
    BlockWrite(xlat,fbuf,fsize,iwrite);
    If iwrite <> fsize Then errmsg('Error writing file '+fname);
    Close(xlat);
    fname := '';
    changed := False;
    leftcol := 9999;
    {$I+ }
  End;                                                             { savecom }

  Procedure loadtable;
  { load a translation table from an ASCII table file                        }

    Var i : byte;
        tab1 : tabletype;
        descript1, lin, cmd, froms, tos, tname : string;
        fromval, toval : byte;
        ok : boolean;

    Function gettok(s : string; Var ptr : byte) : string;
    { returns next token from s, or ''                                       }
      Var beg : byte;
    Begin                                                           { gettok }
      While (ptr <= Length(s)) And ((s[ptr] = ' ') Or (s[ptr] = #9)) Do
                                                                     Inc(ptr);
      beg := ptr;
      While (ptr <= Length(s)) And (s[ptr] <> ' ') And (s[ptr] <> #9) Do
      Begin
        s[ptr] := UpCase(s[ptr]);
        Inc(ptr);
      End;
      gettok := Copy(s,beg,ptr-beg);
    End;                                                            { gettok }

    Function decoval(s : string; Var ok : boolean) : byte;
    { decodes a decimal or hexadecimal (prefixed by 'x') value               }
      Var i1, i2, num : byte;
    Begin                                                          { decoval }
      num := 0;
      ok := False;
      If s <> '' Then
      Begin
        If (s[1] = 'X') And (Length(s) >= 1) And (Length(s) <= 3) Then
        Begin
          If Length(s) = 2 Then
          Begin
            s[1] := '0';
            i2 := 1;
          End
            Else i2 := 2;
          i1 := Pos(s[i2],hexnibble);
          i2 := Pos(s[Succ(i2)],hexnibble);
          ok := (i1 > 0) And (i2 > 0);
          If ok Then num := Pred(i1) ShL 4 + Pred(i2);
        End
        Else
        Begin
          For i2 := 1 To Length(s) Do
          Begin
            i1 := Pos(s[i2],digits);
            ok := ok And (i1 > 0);
            If ok Then
            Begin
              If 10*word(num)+ i1 <= 256 Then num := 10*num + Pred(i1);
            End;
          End;
        End;
      End;
      decoval := num;
    End;                                                           { decoval }

  Begin                                                          { loadtable }
    checksave;
    Repeat
      tname := dialog('Enter name of table file:',60,
                      Copy(fname,1,Pred(Pos('.',fname))));
      If tname = '' Then
      Begin
        errmsg('Load TABLE operation cancelled');
        Exit;
      End;
      If Pos('.',tname) = 0 Then tname := tname + '.TBL';
      If (tname <> '') And (Pos('.',tname) = 0) Then tname := tname + '.TBL';
    Until Not showfiles(tname);
    i := FileMode;
    FileMode := 0;
    Assign(tabf,tname);
    {$I- }
    Reset(tabf);
    FileMode := i;
    If IOResult <> 0 Then
    Begin
      errmsg('File ' + tname + ' not found');
      Exit;
    End;
    descript1 := '';
    For i := 0 To 255 Do tab1[i] := i;
    While Not EoF(tabf) Do
    Begin
      readln(tabf,lin);
      If Pos(';',lin) > 0 Then Delete(lin,Pos(';',lin),255);
      While (lin <> '') And ((lin[1] = ' ') Or (lin[1] = #9)) Do
                                                           Delete(lin,1,1);
      i := 1;
      cmd := gettok(lin,i);
      If cmd = '' Then cmd := ' ';
      If Length(cmd) > 1 Then cmd := '?';
      Case UpCase(cmd[1]) Of
        'V' : Begin { version string }
                If (gettok(lin,i) <> idstring10) And
                   (gettok(lin,i) <> idstring11) Then
                Begin
                  errmsg('Version must be ' + idstring10 + ' or ' + idstring11);
                  Close(tabf);
                  Exit;
                End;
              End;
        'D' : Begin { description }
                If descript1 <> '' Then
                  errmsg('Warning: multiple descriptions not supported');
                descript1 := Copy(lin,i,255);
                While (descript1 <> '') And ((descript1[1] = ' ') Or
                       (descript1[1] = #9)) Do Delete(descript1,1,1);
                While (descript1 <> '') And
                      ((descript1[Length(descript1)] = ' ')
                        Or (descript1[Length(descript1)] = #9))
                      Do Delete(descript1,Length(descript1),1);
                If Length(descript1) > desclen Then
                  Delete(descript1,Succ(desclen),255);
              End;
        'T' : Begin { translation pair }
                froms := gettok(lin,i);
                tos   := gettok(lin,i);
                ok := (Length(froms) >= 1) And (Length(froms) <= 3) And
                      (Length(tos) >= 1)   And (Length(tos) <= 3);
                If ok Then
                Begin
                  fromval := decoval(froms,ok);
                  If ok Then toval := decoval(tos,ok);
                  If ok then tab1[fromval] := toval;
                End;
                If Not ok Then errmsg('Illegal translation directive ' +
                                      Copy(lin,1,20));
              End;
        ' ' : ; { ignore empty lines }
        Else errmsg('Illegal directive ' + Copy(lin,1,20));
      End;
    End;
    Close(tabf);
    fname := Copy(tname,1,Pred(Pos('.',tname)));
    intername := fname;
    descript := descript1;
    table := tab1;
    col := 1;
    row := 3;
    leftcol := 9999;
    changed := False;
  End;                                                           { loadtable }

  Procedure savetable;
  { save a translation table to an ASCII table file                          }
    Const canceltablesave = 'Save TABLE operation cancelled';
    Var i : byte;
        c : char;
        s, tname : string;
  Begin                                                          { savetable }
    {$I- }
    s := dialog('Enter short description:',desclen,descript);
    If s = '' Then
    Begin
      errmsg(canceltablesave);
      Exit;
    End;
    descript := s;
    While Length(descript) < desclen Do descript := descript + ' ';
    s := dialog('Enter name of table file:',60,
                    Copy(fname,1,Pred(Pos('.',fname))));
    If s = '' Then
    Begin
      errmsg(canceltablesave);
      Exit;
    End;
    tname := s;
    If Pos('.',tname) = 0 Then tname := tname + '.TBL';
    intername := tname;
    While (intername <> '') And (Pos(':',intername) > 0) Do
                                  Delete(intername,1,Pos(':',intername));
    While (intername <> '') And (Pos('\',intername) > 0) Do
                                  Delete(intername,1,Pos('\',intername));
    While (intername <> '') And (Pos('.',intername) > 0) Do
                                  Delete(intername,Pos('.',intername),255);
    While Length(intername) < 8 Do intername := intername + ' ';
    Assign(tabf,tname);
    Reset(tabf);
    If IOResult = 0 Then
    Begin
      Close(tabf);
      Repeat
        s := dialog('File '+tname+' already exists. Continue? (y/n)',1,'N');
        If s = '' Then c := Esc Else c := UpCase(s[1]);
      Until c In ['Y','J','1','N','0',CtrlC,Esc];
      If c In ['N','0',CtrlC,Esc] Then
      Begin
        errmsg(canceltablesave);
        Exit;
      End;
    End;
    Rewrite(tabf);
    If IOResult <> 0 Then
    Begin
      errmsg('Cannot open '+tname+' for output.');
      Exit;
    End;
    writeln(tabf,'; Translation table for use with ConfXLat');
    writeln(tabf,'; Everything after a '';'' is a comment.');
    writeln(tabf,'; Values are decimal by default, and hexadecimal if ',
                 'preceded by ''x''.');
    writeln(tabf,'V ',idstring10,' ':20,'; version');
    writeln(tabf,'D ',descript,'   ; description (max length: ',desclen,
                 ')');
    writeln(tabf,'; Translation table follows.');
    writeln(tabf,'; Start each row with a ''T''; first value is mapped to ',
                 'second value.');
    writeln(tabf,'; Missing values will be mapped to themselves.');
    For i := 0 To 255 Do writeln(tabf,'T  x',hexbyte(i):2,
                                      ' x',hexbyte(table[i]):2);
    writeln(tabf,'; End of translation table');
    If IOResult <> 0 Then errmsg('Error writing file '+tname);
    Close(tabf);
    fname := intername;
    changed := False;
    leftcol := 9999;
    {$I+ }
  End;                                                           { savetable }

  Procedure checksave;
  { check if we should save the changed table                                }
    Var ch : char;
        s : string;
  Begin                                                          { checksave }
    If changed Then
    Begin
      Repeat
        s := Dialog('Table has been changed. Save to COM or table file? (C/T/N)'
                    ,1,' ');
        If s = '' Then ch := Esc Else ch := UpCase(s[1]);
      Until ch In ['C', 'T', 'N',CtrlC,Esc];
      If ch = 'C' Then savecom;
      If ch = 'T' Then savetable;
    End;
  End;                                                           { checksave }

  {$F+ } Procedure myexit; {$F- }
  { exit procedure - clear screen etc.                                       }
  Begin                                                             { myexit }
    ExitProc := exitsave;
    SetCursor(normcur);
    Window(1,1,maxcol,maxlin);
    ClrScr;
    writeln(progname,' ',version,' - translation filter/driver configurator');
    writeln;
    writeln(copyright);
    writeln;
    writeln('This programme, and the filters, resident drivers, and tables,');
    writeln('may be used and copied freely.');
    writeln('However, it comes without any guarantees;');
    writeln('the whole risk of its use lies with the user.');
    writeln;
  End;                                                              { myexit }

Begin                                                                 { main }
  exitsave := ExitProc;
  ExitProc := @myexit;
  maxcol := Succ(Lo(WindMax));
  maxlin := Succ(Hi(WindMax));
  getcursor;
  ClrScr;
  If ParamCount = 0 Then fname := ''
                    Else fname := ParamStr(1);
  floaded := False;
  changed := False;
  Repeat
    loadcom;
    If fname = '' Then Halt(1);
    If Not floaded Then fname := '';
  Until floaded;
  Repeat
    edittable;
    Case ch Of
      F1 : cleartable(True);
      F2 : cleartable(False);
      F3 : ;
      F5 : loadcom;
      F6 : savecom;
      F7 : loadtable;
      F8 : savetable;
      F9 : checkinvert;
      F10: invert;
      Else beep;
    End;
  Until ch = F3;
  checksave;
End.