program Tastenbelegungen;

{ for use with .KEY files }


{$I stdio1}

type
       filename = string[14];

var
       ok,wait : boolean;
       ch      : char;
       name    : filename;
       fp      : text;


procedure CON;                    { Cursor on }

begin
       write(chr(27),'.2');
end;


procedure err(x,y : integer; msg : zeile; VAR flag : boolean);

{ prints errormessage at x,y and set flag false }

begin
       gotoxy(x,y);
       write(^G,msg);
       if wait then
          delay(2000);
       flag := false;
end;


procedure keyhit;

begin
   SNV(1);
   PUL('                 < Dr}cke beliebige Taste, um weiterzumachen >');
   repeat
   until keypressed;
   PUL('');
   SNV(10);
end;


procedure lfk(taste : char; belegung : zeile);

begin
       write(^[,'|',taste,'1',belegung,^Y);
end;


function getfilename(VAR name : filename) : boolean;

{ prompt for filename with extension .key and return FALSE on Error }

var
       flag   : boolean;
       ch     : char;
       p      : integer;

begin
       gotoxy(1,13); writeln('Tastenfile:'); LINE(80);
       name := '';
       CON;
       ch := getstr(name,13,13,14,[' '..'~'],FALSE,[^M]);
       CUROFF;
       p  := pos('.',name);
       flag := true;
       if p = 0 then
          if name = '' then
             flag := false
          else
             name := copy(name,1,8) + '.key'
       else
          if p = length(name) then begin
             delete(name,p,1);
             name := copy(name,1,8) + '.key';
          end
          else
             if copy(name,p+1,14) <> 'key' then
                flag := false;
       getfilename := flag;
end;


function fileexist(name : filename; VAR fp : text) : boolean;

{ initialize the fileptr fp, return TRUE if file exists, otherwise FALSE. }

begin
       assign(fp,name);
       {$I-} reset(fp); {$I+}
       fileexist := (ioresult = 0);
end;


function tastencode(x,y : integer; code : zeile; VAR taste : char) : boolean;

{ return FALSE, if code is invalid, otherwise taste contains the
  corresponding key code and TRUE is returned }

var
       flag          : boolean;
       nummer,result : integer;


begin
       flag := true;

       code[1] := upcase(code[1]);
       if (code[1] = 'C') or (code[1] = 'S') then
          val(copy(code,2,3),nummer,result)
       else
          val(code,nummer,result);

       if result <> 0 then
          err(x,y,'das ist keine Tastennummer',flag)
       else
          case code[1] of
             'C' : case nummer of
                       1..6   : taste := chr(nummer + 70);
                       7..17  : taste := chr(nummer + 42);
                      18..21  : taste := chr(nummer + 59);
                      38..39  : taste := chr(nummer + 43);
                      41      : taste := chr(nummer + 42);
                      55..57  : taste := chr(nummer + 29);
                      74..78  : taste := chr(nummer + 13);
                      92..95  : taste := chr(nummer - 1);
                      58      : taste := chr(nummer + 37);
                   else
                      err(x,y,'das ist keine programmierbare Taste',flag);
                   end;
             'S' : if (nummer < 1) or (nummer > 11) then
                      err(x,y,'das ist keine geschiftete Funktionstaste',flag)
                   else
                      taste := chr(59 + nummer);
            else
                   if (nummer < 1) or (nummer > 11) then
                      err(x,y,'das ist keine Funktionstaste',flag)
                   else
                      taste := chr(48 + nummer);
          end;
       tastencode := flag;
end;


function tastenbelegung(belegung : zeile) : zeile;

{ searches belegung for '^', interprets the following character as a
  control character and returns the scanned belegung }

var
       flag   : boolean;
       i,j    : integer;
       buffer : zeile;


procedure fill_buffer(ch : char);

{ fills buffer with ch and increments buffercounter }

begin
       buffer[j] := ch;
       j := j + 1;
       flag := false;
end;


begin
       flag := false;
       j := 1;
       for i := 1 to length(belegung) do
          if (belegung[i] <> '^') AND (flag = true) then begin
             if belegung[i] in ['Y','P'] then
                fill_buffer(^P);
             fill_buffer(chr(ord(belegung[i]) - 64));
          end
          else
             if (belegung[i] = '^') AND (flag = true) then
                fill_buffer('^')
             else
                if belegung[i] = '^' then
                   flag := true
                else
                   fill_buffer(belegung[i]);
       buffer[0] := chr(j-1);
       tastenbelegung := buffer;
end;


procedure help1;

{ help menue activated in the main menue }

begin
       clrscr;  SNV(1);
       writeln;
       writeln('Aktivieren eines Tastenfiles:'); writeln;
       writeln('':10,'Der Tastenfile muss vom Typ .KEY sein. Wird der File');
       writeln('':10,'nicht spezifiziert, so wird automatisch der Typ .KEY');
       writeln('':10,'angenommen.');
       writeln('':10,'Treten bei der Abarbeitung des Tatstaturfiles Fehler');
       writeln('':10,'auf, so werden sie mit entsprechender Meldung angezeigt');
       writeln('':10,'Nach der Tastaturbelegung befindet sich der Benutzer');
       writeln('':10,'wieder im Menue.'); writeln;
       writeln('Tastenbelegung:'); writeln;
       writeln('':10,'Wird ein Tastenfile angegeben, so werden alle Tasten-');
       writeln('':10,'Belegungen in diesem File gespeichert, und k|nnen');
       writeln('':10,'sp{ter wiederverwendet werden.');
       writeln;
       writeln('':10,'Tastenfiles koennen auch mit einem Editor erstellt bzw.');
       writeln('':10,'ge{ndert werden, wobei darauf zu achten ist, da~');
       writeln('':10,'der Tastencode von der Tastenbelegung durch ein '',''');
       writeln('':10,'getrennt ist.');
       keyhit;
end;


procedure help2;

{ help menue activated using key programming }

begin
       clrscr; SNV(1);
       writeln;
       writeln('':25,'Funktionstastenbelegung');
       write('':25); LINE(23); writeln; writeln;
       writeln('':10,'die Belegung erfolgt in folgender Form:'); writeln;
       writeln('':10,'<programmierbare Taste> <CR> <Tastenbelegung>');
       writeln('':10,'wobei: <programmierbare Taste>::= '); writeln;
       writeln('':10,'         <Nr. der ungeschifteten Funktionstaste [1-11]>');
       writeln('':10,'       S <Nr. der geschifteten Funktionstaste   [1-11]>');
       writeln('':10,'       C <Tastencode der programmierbaren Taste>');
       writeln;
       writeln('':10,'Soll die <Tastenbelegung> Steuerzeichen enthalten, so');
       writeln('':10,'wird diese Sequenz durch das Zeichen ^ eingeleitet, z.B.');
       writeln('':10,'wird das CR Zeichen durch die Folge ^M dargestellt.');
       writeln('':10,'Mittels ^^ erh{lt man das  Zeichen ^ selbst.'); LF(3);
       keyhit;
       clrscr;
       writeln('Taste   Tastenbelegung'); writeln;
end;


procedure tastatur_belegen;

{ promts for key and key message and loads key with message until
  only ',' is pressed. If a keyfile is selected, the information
  is saved in it. }

var
       exit,ok,
       save     : boolean;
       ch,taste : char;
       lines    : integer;
       name     : filename;
       tcode    : string[3];
       belegung : zeile;

begin
       ok   := true;
       save := true;
       if getfilename(name) then
          if fileexist(name,fp) then begin
             gotoxy(30,13);
             SNV(1); write('File existiert bereits. L|schen (J/N)');
             repeat
                read(kbd,ch);
                ch := upcase(ch);
             until ch in ['J','N'];
             if ch = 'J' then
                rewrite(fp)
             else
                ok := false;
             SNV(10);
          end
          else
             rewrite(fp)
       else
          if name = '' then
             save := false
          else
             err(30,13,'das ist kein Tastenfile',ok);

       if ok then begin
          clrscr;
          lines := 3;
          exit := false;
          writeln('Taste   Tastenbelegung');
          repeat
             repeat
                tcode := '';
                ok    := false;
                repeat
                   gotoxy(1,lines); write(^['Y*');
                   CON;
                   ch := getstr(tcode,3,lines,3,['C','c','S','s','0'..'9'],FALSE,
                           [^J,',',^M]);
                   CUROFF;
                   if ch = ^J then begin
                      help2;
                      lines := 3;
                   end;
                until ch <> ^J;
                if tcode = '' then
                   exit := true
                else
                   ok := tastencode(9,lines,tcode,taste);
             until exit or ok;
             if ok then begin
                belegung := '';
                CON;
                ch := getstr(belegung,9,lines,70,[' '..'~'],FALSE,[^M]);
                CUROFF;
                if belegung <> '' then begin
                   lfk(taste,tastenbelegung(belegung));
                   if save then
                      writeln(fp,tcode,',',belegung);
                   if lines = 24 then
                      writeln
                   else
                      lines := lines + 1;
                end
                else
                   err(9,lines,'Taste wird nicht belegt',ok);
             end;
          until exit;
          close(fp);
          writeln;
       end;
end;


procedure aktivieren;

{ loads keys with the information from the selected keyfile }

var
       ok : boolean;


procedure readfile(VAR fp : text);

{ reads the keyfile line by line }

var
       taste     : char;
       i,p,zei   : integer;
       buffer    : zeile;


procedure inc;

{ increments the error counter i }

begin
       if i = 24 then
          writeln
       else
          i := i + 1;
end;


begin
       zei := 1;
       i := 3;
       wait := false;
       while not eof(fp) do begin
          readln(fp,buffer);
          p := pos(',',buffer);
          if p = 0 then begin
             if i = 3 then begin
                clrscr;
                writeln('ERROR(s)'); writeln;
             end;
             gotoxy(1,i);  write(copy(buffer,1,7));
             gotoxy(9,i);  write('Trenner '','' fehlt');
             gotoxy(50,i); write('in Zeile ',zei);
             inc;
          end
          else
             if tastencode(9,i,copy(buffer,1,p-1),taste) then
                lfk(taste,tastenbelegung(copy(buffer,p+1,length(buffer))))
             else begin
                if i = 3 then begin
                   clreol;
                   gotoxy(1,1); write('ERROR(s):'); clreol;
                   gotoxy(1,2); clreol;
                   gotoxy(1,3); write('':8);
                   gotoxy(1,4); write(^[,'Y');
                end;
                if p > 8 then p := 8;
                gotoxy(1,i); write(copy(buffer,1,p-1));
                gotoxy(50,i); write('in Zeile ',zei);
                inc;
             end;
          zei := zei + 1;
       end;
       close(fp);
       if i <> 3 then
          keyhit;
       wait := true;
end;

begin
       if getfilename(name) then
          if fileexist(name,fp) then
             readfile(fp)
          else
             err(30,13,'file existiert nicht',ok)
       else
          if name <> '' then
             err(30,13,'das ist kein Tastenfile',ok);
end;


procedure menue;

{ writes the menue on the screen }

begin
       clrscr;
       LINE(80);
       writeln('':20,'Funktionstastenbelegung');
       LINE(80); writeln; writeln;
       write('A'); half('ktivieren eines Tastenfiles'); writeln;
       write('T'); half('astatur belegen');             writeln;
       write('H'); half('ilfsmenue aufrufen');          writeln;
       write('B'); half('eenden');                      writeln;
       LF(3);  LINE(80);
end;

begin
       wait := true;
       CUROFF;
       repeat
          menue;
          repeat
             read(kbd,ch);
             ch := upcase(ch);
          until ch in ['A','T','H','B',^J];
          case ch of
             'A'    : aktivieren;
             'T'    : tastatur_belegen;
             'H',^J : help1;
          end;
       until ch = 'B';
       writeln;
       CON;
end.
