PROGRAM Vector_Pad_Definition;
{ Written by Craig Brown  Sept. 1985 }

{ This program will re-define the vector pad (arrow keys) on the
  Kaypro 4'84.  It DOES NOT affect the definition on the disk, only
  that which is in memory.  It allows choices from three sets of
  pre-defined definitions or make your own. }

(* * * * *  VARIBLE DECLARATIONS  * * * * *)

type
    str4= string[4];

var
   up,            { arrow key value fields - prime definition }
   down,
   left,
   right: byte;

   up4,           { multiple value fields - secondary definition }
   down4,         { if an arrow key has more then a one byte definition }
   left4,         { the prime field is set to 00 and the (up to) four   }
   right4,        { bytes of definition are stored here.                }
   ans4: str4;

   ans: char;     { input field, with multiple type definition }
   ansb: byte absolute ans;

   x, y, z: integer;  { garbage fields }

(* * * * *  PROCEDURES  * * * * *)

PROCEDURE displayhex(invalue: byte);
{ This procedure displays a byte in hex.  It is a modification of a
  routine from Micro Cornucopia #24, written by Tom Geldner. }
var hexstr: string[3];
const hexltr: array[0..15] of char= '0123456789ABCDEF';
begin
     hexstr:='00h';
     hexstr[1]:=hexltr[((invalue) div 16)];
     hexstr[2]:=hexltr[((invalue) mod 16)];
     write(hexstr,' ');
end;

PROCEDURE Write1(inchar: char);
{ This procedure will display a byte value differentaly, depending on its
  ASCII value.  It either displays it as a control character (CTRL-A) or
  as its ASCII character or the hex equivilent (for those that don't have
  a character) }
var
   inbyte: byte absolute inchar;
begin
     case inchar of
        #0..#31: write('CTRL-',chr(inbyte+$40),' ');
        #32: write('SPACE ');
        #33..#125: write(inchar,' ');
        #127: write('DEL ');
        #126, #128..#255: displayhex(inbyte);
        end; {case}
end;

PROCEDURE Write4(invalue4: str4);
{ This procedure will display the 4 bytes of the secondary key definition. }
begin
     for x:=1 to 4 do write1(invalue4[x]);
     writeln;
end;

PROCEDURE EditEntry(var invalue: byte; var invalue4: str4; len: integer);
{ This procedure allows you to enter a new key definition up to 4 bytes long.
  It first displays the old definition and then enters the new. }
begin
  if invalue=0 then write4(invalue4) else write1(chr(invalue));
  write('  New definition: ');
  invalue4:=#0#0#0#0;           { set the 4 byte definition to 0's
                                  so a short (2 or 3 byte) definition
                                  doesn't include any part of the old }
  if len>1 then begin           { if definition is to be more then one byte }
     invalue:=0;                { input and display values                  }
     for x:=1 to len do begin
        read(kbd,ans);
        write1(ans);
        invalue4[x]:=ans;
        end; {for}
     end {if}
   else begin                   { if definition is 1 byte enter and display }
     read(kbd,ans);
     write1(ans);
     invalue:=ansb;
     end;
  writeln;
end;

(* * * * *  MAIN PROGRAM  * * * * *)
{ The memory locations used in this program are for the Kaypro 4'84 running
  CP/M 2.2F.  Other machines or versions of CP/M may vary, no guarentees
  extended, or liability assumed by the author.  }

label 0, 1, 2, 3, 4, 5;

BEGIN
     writeln;
     writeln('Current settings of the vector pad (arrow keys).');
     writeln;
0:   up:=mem[$F635];                 { the definition for the up arrow is at }
     if up=0 then begin              { F635h.  if it is 00h the definition is}
        ans4:='';                    { stored starting at F661h for up to 4  }
        for x:=1 to 4 do begin       { bytes                                 }
           ansb:=mem[$F660+x];
           ans4:=ans4+ans;
           end;
        up4:=ans4;
        end;
     write('   Up arrow = ');
     if up=0 then write4(up4)
       else if up<$20 then writeln('CTRL-',chr(up+$40))
              else writeln(chr(up));

     down:=mem[$F636];               { down arrow is at F636h. if 00h then   }
     if down=0 then begin            { starts at F665h for 4 bytes           }
        ans4:='';
        for x:=1 to 4 do begin
           ansb:=mem[$F664+x];
           ans4:=ans4+ans;
           end;
        down4:=ans4;
        end;
     write(' Down arrow = ');
     if down=0 then writeln(down4)
       else if down<$20 then writeln('CTRL-',chr(down+$40))
              else writeln(chr(down));

     left:=mem[$F637];               { left arrow is at F637h.  if 00h then  }
     if left=0 then begin            { start at F669h for 4 bytes            }
        ans4:='';
        for x:=1 to 4 do begin
           ansb:=mem[$F668+x];
           ans4:=ans4+ans;
           end;
        left4:=ans4;
        end;
     write(' Left arrow = ');
     if left=0 then writeln(left4)
       else if left<$20 then writeln('CTRL-',chr(left+$40))
              else writeln(chr(left));

     right:=mem[$F638];              { right arrow is at F638h.  if 00h then }
     if right=0 then begin           { start at F66Dh for 4 bytes            }
        ans4:='';
        for x:=1 to 4 do begin
           ansb:=mem[$F66C+x];
           ans4:=ans4+ans;
           end;
        right4:=ans4;
        end;
     write('Right arrow = ');
     if right=0 then writeln(right4)
       else if right<$20 then writeln('CTRL-',chr(right+$40))
              else writeln(chr(right));

     writeln;
     write('Change? (y/n) ');
     repeat
       read(kbd,ans);
     until upcase(ans) in ['Y','N'];
     writeln(ans);
     if upcase(ans)='N' then halt
       else begin
1:        writeln('Please select one of the following (? for help)-');
          writeln;
          writeln('  1. CP/M set');
          writeln('  2. WordStar set');
          writeln('  3. Perfect Writer set');
          writeln('  4. Design your own');
          writeln('  5. Abort - no changes');
          writeln;
          write('Your selection: ');
          repeat
            read(kbd,ans)
          until upcase(ans) in ['1','2','3','4','5','A','?'];
          writeln(ans);
          case upcase(ans) of
             '1': begin                { CP/M pre-defined set }
                    mem[$F635]:=$0B;   { up    = ^K           }
                    mem[$F636]:=$0A;   { down  = ^J           }
                    mem[$F637]:=$08;   { left  = ^H           }
                    mem[$F638]:=$0C;   { right = ^L           }
                    writeln('CP/M set installed:');
                  end;
             '2': begin                { WS pre-defined set   }
                    mem[$F635]:=$05;   { up    = ^E           }
                    mem[$F636]:=$18;   { down  = ^X           }
                    mem[$F637]:=$13;   { left  = ^S           }
                    mem[$F638]:=$04;   { right = ^D           }
                    writeln('WordStar set installed:');
                  end;
             '3': begin                { PW pre-defined set   }
                    mem[$F635]:=$10;   { up    = ^P           }
                    mem[$F636]:=$0E;   { down  = ^N           }
                    mem[$F637]:=$02;   { left  = ^B           }
                    mem[$F638]:=$06;   { right = ^F           }
                    writeln('Perfect Writer set installed:');
                  end;
            '4': begin                 { Self definition routine }
                   writeln;
                   writeln('Entering a ''0'' will leave that arrow definition the same.');
                   writeln;

                   write('Length of Up arrow definition? (1-4) ');
                   readln(y);
                   if y=0 then goto 2;
                   write('Current up arrow = ');
                   editentry(up,up4,y);
                   mem[$F635]:=up;
                   for x:=1 to 4 do mem[$F660+x]:=byte(up4[x]);

              2:   writeln;
                   write('Length of Down arrow definition? (1-4) ');
                   readln(y);
                   if y=0 then goto 3;
                   write('Current down arrow = ');
                   editentry(down,down4,y);
                   mem[$F636]:=down;
                   for x:=1 to 4 do mem[$F664+x]:=byte(down4[x]);

              3:   writeln;
                   write('Length of Left arrow definition? (1-4) ');
                   readln(y);
                   if y=0 then goto 4;
                   write('Current left arrow = ');
                   editentry(left,left4,y);
                   mem[$F637]:=left;
                   for x:=1 to 4 do mem[$F668+x]:=byte(left4[x]);

              4:   writeln;
                   write('Length of Right arrow definition? (1-4) ');
                   readln(y);
                   if y=0 then goto 5;
                   write('Current right arrow = ');
                   editentry(right,right4,y);
                   mem[$F638]:=right;
                   for x:=1 to 4 do mem[$F66C+x]:=byte(right4[x]);
              5:
                 end;

             '5','A': begin
                        writeln('Aborted - no changes');
                        halt;
                      end;
             '?': begin          { help information }
                    writeln;
                    writeln('Arrow   CP/M     WS     PW');
                    writeln('         set     set    set');
                    writeln;
                    writeln('Up       ^K      ^E     ^P');
                    writeln;
                    writeln('Down     ^J      ^X     ^N');
                    writeln;
                    writeln('Left     ^H      ^S     ^B');
                    writeln;
                    writeln('Right    ^L      ^D     ^F');
                    writeln;
                    writeln('Entering the number of the corresponding set, will install the definition');
                    writeln(' set above.  Entering ''4'' will allow you to enter your own definitions,');
                    writeln(' up to four characters per key.');
                    goto 1;
                  end;


             end; {case}
          end; {else}
     writeln;
     goto 0;
END.
