
procedure color(cf:char);

var   screencolor:  byte absolute $f24e;
      f,b: integer;

begin
  f:=ord(cf)-ord('0');
  b:=0;
  f:=f mod 8;
  b:=b mod 8;
  b:=7-b;
  screencolor:=(screencolor and 3)+f*4+b*32;
end;

procedure defkey(tastnr:integer;belegstrg:str80);
begin
  write(#27,'F',chr($DF+tastnr),belegstrg,chr($DF+tastnr));
end;

procedure keys;
begin
  defkey(1,f1);
  defkey(2,f2);
  defkey(3,f3);
  defkey(4,f4);
  defkey(5,f5);
  defkey(6,f6);
  defkey(7,f7);
  defkey(8,f8);
  defkey(9,f9);
  defkey(10,f10);
  defkey(11,f11);
  defkey(12,f12);
  defkey(13,f13);
  defkey(14,f14);
  defkey(15,f15);
  defkey(16,f16);
  defkey(17,f17);
  defkey(18,f18);
  defkey(19,f19);
  defkey(20,f20);
end;


procedure openfiles;
begin
  assign(cassrecf,'cf.dat');
  reset(cassrecf);
  openfile(datf,'t.dat',TitelrecSize);
  initindex;
  openindex(indexf,'ti.dat',MaxKeyLen,0);
end;

procedure closefiles;
begin
  close(cassrecf);
  closeindex(indexf);
  closefile(datf);
end;

procedure holecassrec(cassnr:integer;var cassr:cassrec);
begin
  seek(cassrecf,cassnr);
  read(cassrecf,cassr);
end;

procedure schreibecassrec(cassnr:integer;var cassr:cassrec);
begin
  seek(cassrecf,cassnr);
  write(cassrecf,cassr);
end;


(*  UpcaseStr converts a string to upper case *)

function UpcaseStr(S : Str80) : Str80;
var
  P : Integer;
begin
  for P := 1 to Length(S) do
    S[P] := Upcase(S[P]);
  UpcaseStr := S;
end;

(*  ConstStr returns a string with N characters of value C *)

function ConstStr(C : Char; N : Integer) : Str80;
var
  S : string[80];
begin
  if N < 0 then
    N := 0;
  S[0] := Chr(N);
  FillChar(S[1],N,C);
  ConstStr := S;
end;

(*  Beep sounds the terminal bell or beeper *)

procedure Beep;
begin
  Write(^G);
end;


procedure InputStr(var S     : AnyStr;
                       L,X,Y : Integer;
                       Term  : CharSet;
                   var TC    : Char;
                       CC    : Char);
const
  UnderScore  =  '_';
var
  P : Integer;
  Ch : Char;
begin
  color(weiss);
  GotoXY(X + 1,Y + 1); Write(S,ConstStr(UnderScore,L - Length(S)));
  P := 0;
  repeat
    GotoXY(X + P + 1,Y + 1); Read(Kbd,Ch);
    case Ch of
      #32..#126 : if P < L then
                  begin
                    if Length(S) = L then
                      Delete(S,L,1);
                    P := P + 1;
                    Insert(Ch,S,P);
                    Write(Copy(S,P,L));
                  end
                  else Beep;
      ^S        : if P > 0 then
                    P := P - 1
                  else Beep;
      ^D        : if P < Length(S) then
                    P := P + 1
                  else Beep;
      ^A        : P := 0;
      ^F        : P := Length(S);
      ^G        : if P < Length(S) then
                  begin
                    Delete(S,P + 1,1);
                    Write(Copy(S,P + 1,L),UnderScore);
                  end;
      ^H,#127   : if P > 0 then
                  begin
                    Delete(S,P,1);
                    Write(^H,Copy(S,P,L),UnderScore);
                    P := P - 1;
                  end
                  else Beep;
      ^Y        : begin
                    Write(ConstStr(UnderScore,Length(S) - P));
                    Delete(S,P + 1,L);
                  end;
    else
      if not (Ch in Term) then Beep;
    end;  {of case}
  until Ch in Term;
  color(hellblau);
  P := Length(S);
  GotoXY(X + 1,Y + 1);
  Write(S);
  color(gruen);
  Write(ConstStr(CC,L - P));
  TC := Ch;
end;



procedure errormess(s:str80);
begin
  gotoxy(4,24);
  color(violett);
  write(s);
  color(gruen);
end;

procedure clrerrormess;
begin
  gotoxy(4,24);
  write('                                        ');
end;



procedure maske;
begin
  clrscr;
  writeln;
  writeln('                VIDEO-CASSETTE  Nummer  ... , ....................');
  write('--------------------------------------------------------------------------------');
  write('        Titel der Aufzeichnung                ! Datum  ! Min ! LP !Anfang- Ende ');
  write('--------------------------------------------------------------------------------');
  writeln(' 1.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 2.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 3.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 4.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 5.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 6.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 7.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 8.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln(' 9.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln('10.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln('11.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  writeln('12.: ........................................ ! ...... ! ... ! .. ! .... - ....');
  write('--------------------------------------------------------------------------------');
  color(gelb);
  writeln('  F1-F12 = Eintragen   F15 = -1 Cassette    F18 = Suchen       ');
  writeln('  L F1-F12 = L|schen   F16 = +1 Cassette    F19 = Ausdruck     ');
  writeln('  F13 = Art eingeben   F17 = Neue Cassette  F20 = End          ');
  color(gruen);
  writeln;
  writeln('-------------------------------------------------------------------------------');
end;


function spacefill(s:Str40;l:integer):Str40;
var i:integer;
begin
  for i:=length(s)+1 to l do
    s:=concat(s,' ');
  spacefill:=s;
end;

procedure Ausdruck;
var  i1,i2: integer;
     err:   integer;
     k,l,j: integer;
     s1,s2: Str20;
     tref:  integer;
     aktcass:    cassrec;
     datbuffer:  VidRec;

procedure lz;
begin
  writeln(lst,'!                                                                                               !');
end;

begin
  repeat
    gotoxy(2,22);
    color(weiss);
    write(' Anfang Ausdruck: ');
    readln(s1);
    val(s1,i1,err);
    if err<>0 then i1:=0;
      (* Zahl fehlerhaft *)
    gotoxy(2,22);
    write('                                              ');
  until (i1>=1) and (i1<=maxanzcass);
  repeat
    gotoxy(2,22);
    write(' Ende Ausdruck: ');
    readln(s2);
    val(s2,i2,err);
    if err<>0 then i2:=0;
      (* Zahl fehlerhaft *)
    gotoxy(2,22);
    write('                                              ');
  until (i2>=i1) and (i2<=maxanzcass);
  color(gruen);

  k:=0;
  for j:=i1 to i2 do
    begin
      k:=k+1;
      holecassrec(j,aktcass);
      write(lst,#27,'M',#27,'1');
      writeln(lst);
      writeln(lst,'+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +');
      writeln(lst);
      lz;
      writeln(lst);
      lz;
      writeln(lst);
      lz;
      writeln(lst);
      lz;
      writeln(lst);
      lz;
      writeln(lst,'                  VIDEO-CASSETTE  Nummer ',#14,j:3,#20,' , ',spacefill(aktcass.cassart,20));
      lz;
      writeln(lst,'      --------------------------------------------------------------------------------');
      lz;
      writeln(lst,'              Titel der Aufzeichnung                ! Datum  ! Min ! LP !Anfang- Ende ');
      lz;
      writeln(lst,'      --------------------------------------------------------------------------------');
      for l:=1 to 12 do
        begin
          lz;
          write(lst,'      ',l:2,'.: ');
          tref:=aktcass.titelref[l];
          if tref<>Leer then
            begin
              GetRec(DatF,tref,datbuffer);
              with datbuffer do
                begin
                  write(lst,spacefill(titel,40),' ! ');
                  write(lst,datum:6,' ! ');
                  write(lst,min:3,' ! ');
                  write(lst,lp:2,' ! ');
                  write(lst,zwanf:4,' - ');
                  write(lst,zwend:4);
                end; (* with *)
            end
          else
            begin
              write(lst,'                                         !        !     !    !      -        ');
            end; (* if *)
          writeln(lst);
        end; (* for l *)
      lz;
      writeln(lst,'      -------------------------------------------------------------------------------- ');
      lz;
      writeln(lst);
      lz;
      writeln(lst);
      writeln(lst,'+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +');
      if k=2 then
        begin
          k:=0;
          write(lst,chr(12));
        end;
    end; (* for j *)
end; (* procedure Ausdruck *)

