Fifty: Elektronik/FIFTY Elektronik (PS_Computer_Vertrieb).iso/ps8/fty1017/gepackt.exe/DISK2/PLOTSRC.EXE/INPUT.IMP

Text File | 1993-11-10 | 16.4 KB | 641 lines

type  Buttons = Record
                   Knopf1,Knopf2,Knopf3 :Boolean;
                 End;
Const Uses_Maus :Boolean=false;
      MausDx    :Integer=0;
      MausDy    :Integer=0;

Var   Knoepfealt,Knoepfeneu :Buttons;

CONST  HlpWinCol   :Byte =Crt.White+16*Crt.Lightgray;
       HlpNorCol   :Byte =Crt.blue+16*Crt.Lightgray;
       HlpHeadCol  :Byte =Crt.White+16*Crt.green;
       HelpActive  :Boolean=false;
       DiaWinCol   :Byte =blue+16*green;
       DiaHeadCol  :Byte =White+16*green;

Const  Helptable   :Array['A'..'Z'] of Byte =
                    (1,2,4,10,15,16,19,24,31,38,42,45,52,57,
                    59,64,69,70,71,74,81,86,96,104,106,111);


VAR    Help_Wok      : INTEGER;
       Help_Win      : WindowType;
       Helpfile      : HelpF;



PROCEDURE SetCursor (C:Word);       { Cursorform setzen }
VAR Regs  : Registers;
BEGIN
     WITH Regs DO BEGIN
          AX := $0100;        { Set Cursor }
          cx := C;
          intr ($10,Regs);  { Video Interrupt }
       END;
END;  { Cursor }

PROCEDURE GetCursor (VAR C:Word);   { Cursorform lesen }
VAR Regs  : Registers;
BEGIN
     WITH Regs DO BEGIN
          AX := $0300;        { Read Cursor }
          intr ($10,Regs);  { Video interrupt }
          C := cx;          { CX enhält Cursorzeilen }
       END;
END;


Procedure Beep;
begin
  Sound(2000);Delay(30);Nosound;
end;

procedure Maus(var M1,M2,M3,M4 : Integer);
var Regs : Registers;
begin
  with Regs do begin
    AX := M1;  BX := M2;
    CX := M3;  DX := M4
  end;
  Intr(51,Regs);             (* Interrupt 51 aufrufen *)
  with Regs do begin
    M1 := AX;  M2 := BX;
    M3 := CX;  M4 := DX
  end;
end;

Procedure ResetMouseDelta;
Var M1,M2 :Integer;
begin
  MausDx:=0;
  MausDy:=0;
  If Uses_Maus then
    begin
      M1:=11; Maus(M1,M2,M2,M2);
    end;
end;

Procedure MausInit;
Var M1,M2,M3,M4 :Integer;
    P           :Pointer;
Begin
  GetIntVec(51,P);
  Uses_Maus:=P<>nil;
  If Uses_Maus then
  begin
    M1:=0;M2:=0;M3:=0;M4:=0;
    Maus(M1,M2,M3,M4);
    Uses_Maus:=M1=-1;
    If Uses_Maus then
    begin
      M1:=15;M2:=0;M3:=2;
      Maus(M1,M2,M3,M3);
    end;
  end;
  ResetMouseDelta;
  With Knoepfealt Do
    begin
      Knopf1:=false;
      Knopf2:=false;
      Knopf3:=false;
    end;
    KnoepfeNeu:=Knoepfealt;
End;

Procedure GetMaus(Var Knoepfe : Buttons);
Var M1,M2,M3,M4 :Integer;
Const OldMausRatio:Word=0;
Begin
 If Uses_Maus then
  begin
    If OldMausRatio<>Maus_Ratio then
    begin
      Maus_Ratio:=Maus_Ratio and $0F;
      M1:=15;M2:=0;M3:=16-Maus_Ratio;M4:=M3;
      Maus(M1,M2,M3,M4);
      OldMausRatio:=Maus_Ratio;
    end;
    M1:=3;M2:=0;M3:=0;M4:=0;
    Maus(M1,M2,M3,M4);
    Delay(10);
    With KnoepfeNeu Do
    Begin
      M2:=M2 and 7;
      Knopf1:=M2=1;
      Knopf2:=M2=2;
      Knopf3:=(M2 = 4) or (M2=3);
     End;
    With Knoepfe Do
    Begin
      Knopf1:=Not(Knoepfealt.Knopf1) and Knoepfeneu.Knopf1;
      Knopf2:=Not(Knoepfealt.Knopf2) and Knoepfeneu.Knopf2;
      Knopf3:=Not(Knoepfealt.Knopf3) and Knoepfeneu.Knopf3;
     End;
     KnoepfeAlt:=Knoepfeneu;
   end;
End;

PROCEDURE FlushKbd;                    { Löscht den Tastaturpuffer }
VAR CH  : Char;
BEGIN
  While Crt.Keypressed do Ch:=crt.ReadKey;
END;


Procedure MausKey(Var Ch :Char;Var Valid :Boolean);
Var Knob        :Buttons;
    Dx,Dy,M1,M2 :Integer;
Begin
 If Uses_Maus then
 begin
   GetMaus(Knob);
   With Knob Do
    If Knopf1 or Knopf2 or Knopf3 Then
     Begin
       Delay(50);
       Valid:=true;
       If Knopf1 Then Ch:=Mouse_Left
         else If Knopf2 Then Ch:=Mouse_Right
           else If Knopf3 Then CH:=Mouse_Mid;
     End;
   M1:=11; Maus(M1,M2,Dx,Dy);
   Inc(MausDx,Dx );
   Dec(MausDy,Dy );
   If Abs(MausDx)>32*(16-Maus_ratio) then
     begin
       Valid:=True;
       If MausDx>0  then CH:=^D else CH:=^S;
       MausDx:=0;
      end;
   If Abs(MausDy)>16*(16-Maus_Ratio) then
     begin
       Valid:=True;
       If MausDy>0  then CH:=^E else CH:=^X;
       MausDy:=0;
      end;
 end;
End;

Function Keypressed:Boolean;
CONST ALT          = 8;
      AltLeftShift =10;
VAR   KbFlag       : INTEGER ABSOLUTE $40:$17;
      { Status (ALT,CTRL,CAPS,SHIFT) }
      Ch           : Char;
      IsHelp,
      Taste,
      AltLeft      : Boolean;
      REG          :Registers;
BEGIN  { Keypressed}
  Taste:=Crt.Keypressed;
  AltLeft:=(AltLeftShift and KBFlag) =10;
  If Taste or AltLeft then
  begin
    With REG Do
    begin
      AH:=1;
      Intr($16,REG);
      IsHelp:=((Flags and Fzero) = 0) and (AH=35) and (AL =0);
    end;
    { Hilfe-System auf ALT-H}
    If Ishelp or AltLeft Then
      If HelpActive Then Beep else
        begin
          FlushKbd;
          Dohelp;
          Taste:=false;
        end;
  end;
  Keypressed:=Taste;
END; { Keypressed }

Procedure LeseTastatur(Var Ch :Char;Var F:Integer;Var Valid :Boolean);
Var Zweiter  :Char;
begin
 Ch:=ReadKey;
 F:=-1;
 Valid:=true;
 If (Ch=Nul) and keypressed then
   begin
     Zweiter:=ReadKey;
     Case Zweiter of
       #75 :Ch:=^S;  { Pfeil links  }
       #77 :Ch:=^D;  { Pfeil rechts }
       #72 :Ch:=^E;  { Pfeil rauf   }
       #80 :Ch:=^X;  { Pfeil runter }
       #71 :Ch:=^A;  { Anfang       }
       #79 :Ch:=^F;  { ende         }
       #83 :Ch:=^G;  { Löschen      }
       #82 :Ch:=^V;  { Einfügen     }
       #81 :Ch:=^Q;  { Page-down    }
       #73 :CH:=^Z;  { Page-up      }
     else
       begin
         Ch:=#0;
         F:=Ord(Zweiter)+1000;
       end;
     end;
   end;
   If F=-1 then F:=Ord(Upcase(Ch));
 end;


Function ReadKbd(Var Ch:Char):Integer;

Var    F,X,Y   :Integer;
       Valid       :Boolean;
begin
 F:=0;
 Valid:=false;
 Repeat
   If Keypressed then Lesetastatur(Ch,F,Valid)
    else Mauskey(Ch,Valid);
 Until Valid;
 ReadKbd:=F;
end;

Procedure InputKbd(var S     : Str80;      (*Eingabestring*)
                       L,X,Y : Integer;    (* L= max. Länge,XY=Schirmpos.*)
                       Term  : CharSet;    (* Menge der Terminierungszeichen*)
                       OkSet : CharSet;    (* zulässige Eingabezeichen *)
                   var TC    : Char    );  (* Terminierungszeichen*)
(* Narrensichere String-eingabe mit vollen Editiermöglichkeiten *)
var
  P,Dummy : Integer;
  SaveCursor:Word;
  SaveTxtCol:Byte;
  Ch : Char;
  ErasePossible:Boolean;

begin
  FlushKbd;
  ErasePossible:=Auto_ClrInp;
  SaveTxtCol:=TextAttr;
  GetCursor(SaveCursor);
  SetCursor(CursorInital);
  TextColor(Editforeground);
  TextBackground(Editbackground);
  GotoXY(X,Y); Write(S,ConstStr(FuellChar,L - Length(S)));
  P := 0;
  repeat
    GotoXY(X + P,Y); Dummy:=ReadKbd(Ch);
    If Ch in Okset then
     begin
       If ErasePossible then
        begin
         GotoXY(X,Y);
         Write(ConstStr(FuellChar,Length(S)));
         S:='';
         GotoXY(X,Y);
        end;
       if P < L then
          begin
            P := P + 1;
            If Overwrite then
              begin Insert(Ch,S,P);Delete(S,P+1,1); end
            else
              begin
                if Length(S) = L then Delete(S,L,1);
                Insert(Ch,S,P);
              end;
            Write(Copy(S,P,L));
          end else Beep
     end
   else
     case Ch of
        ^V        : OverWrite:=Not(OverWrite);
        ^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),FuellChar);
                    end;
        ^H,#127   : if P > 0 then
                    begin
                      Delete(S,P,1);
                      Write(^H,Copy(S,P,L),FuellChar);
                      P := P - 1;
                    end
                    else Beep;
        ^Y        : begin
                      Write(ConstStr(FuellChar,Length(S) - P));
                      Delete(S,P + 1,L);
                    end;
      else
        if not (Ch in Term) then Beep;
      end;  {of case}
    ErasePossible:=False;
  until Ch in Term;
  TextAttr:=SaveTxtCol;
  P := Length(S);
  GotoXY(X,Y);Write(S);
  GotoXY(X + P,Y);
  Write('':L - P);
  TC := Ch;
  SetCursor(SaveCursor);
end;

Function LeseInt(I, L,X,Y,Min,Max :Integer;Var TC  :Char): Integer;
(* Narrensichere Integereingabe mit vollen Editiermöglichkeiten *)
(* Min,Max : Maximaler Zahlenbereich, sonst wie InputKbd *)
Var Result,Wert: Integer;
    Ok :Boolean;
begin
  Result:=0;Wert:=0;Ok:=true;
  LeseInt:=I;
  Str(I,OutString);
  Repeat
    If result <>0 then
    Delete(Outstring,Result,Length(Outstring)-Result+1)
    else  Str(I,OutString);
    InputKbd(OutString,L,X,Y,Term,['-','0'..'9'],TC);
    Val(OutString,Wert,Result);
    Ok:=(Result=0) and (Wert<=Max) and (Wert>=Min);
    If Not(Ok ) then Beep;
  Until Ok;
  LeseInt:=Wert;
end;

Function Cardinal(X:Integer):Real;
(* Wandelt Integer in Real (0..65535) um *)
Var  Z:Word absolute X;
Begin
  Cardinal:=Z;
end;

Procedure RealStr(X:Real;L: Integer; Var S :Str80);
(* Wandelt Reals in String um,L gültige Ziffern, entfernt Blanks und 0*)
  begin
    Str(X:13:7,S);
    While S[1]=' ' Do Delete(S,1,1);
    While (S[Length(S)]='0') and Not(S[Length(S)-1] ='.') Do
      Delete(S,Length(S),1);
    Delete(S,L+1,Length(S)-L);
  end;

Function LeseReal(Zahl:Real; L,X,Y :Integer;Min,Max :Real ;
                  Var TC  :Char): Real;
(* L = Anzahl gueltiger Ziffern +2 (Punkt,Vorzeichen) *)
(* Narrensichere Realeingabe mit vollen Editiermöglichkeiten *)
(* Min,Max : Maximaler Zahlenbereich, sonst wie InputKbd *)
Var Result: Integer;
    Wert :Real;
    Ok   :Boolean;
    I:Byte;
begin
  Result:=0;Wert:=0;
  LeseReal:=Zahl;
  RealStr(Zahl,L,OutString);
  If max>0 then
   Max:=Max*1.00000001
  else
   Max:=Max*0.99999999;
  If min>0 then
   Min:=Min*0.99999999
  else
   Min:=Min*1.00000001;
  Repeat
    If result <>0 then
    Delete(Outstring,Result,Length(Outstring)-Result+1)
    else  RealStr(Zahl,L,OutString);
    InputKbd(OutString,L,X,Y,Term,[',','.','-','0'..'9'],TC);
    For I:=1 to Byte(OutString[0]) do
      If OutString[I]=',' then OutString[I]:='.';
    Val(OutString,Wert,Result);
    Ok :=(Result=0) and (Wert<=Max) and (Wert>=Min);
    If Not(Ok) then Beep;
  Until Ok;
  LeseReal:=Wert;
end;

Procedure Select(    Prompt : Str80;
                     Term   : CharSet;
                 var TC     : Char    );
(* Behandlung von Ein-Zeichen Abfragen *)
var
  Ch : Char;
  Dummy :Integer;
begin
  Write(Prompt ); ClrEol;
  repeat
    Dummy:=ReadKbd(Ch);
    TC := Upcase(Ch);
    if not (TC in Term) then
      Beep;
  until TC in Term;
  If TC in [' '..#127] then Write(TC);
end;

Function Menueende(Var L :Integer;Max,Genug :Integer;TC :Char) :Boolean;
(* Wird in Menüs als Abbruchkriterium gebraucht   *)
begin
  If (TC = ^I) or (TC = ^M) or (TC = ^X) or (TC=^Q) then
      if L = Max then
        L := 1
      else L := L + 1
    else
      if TC = ^E then
        if L = 1 then
          L := Max
        else L := L - 1;
   Menueende:=((TC = ^M) and (L = 1))or ((TC=^Q) and (L=Genug))
              or (TC = ^Z) or (TC=Esc);
end;

Procedure LeseFname(Var S :Str10;X,Y :Integer;Var TC:Char);
Var L  :Integer;
    Key :Char;
    Gut :Boolean;
Const Buchstaben :Charset = ['A'..'Z','a'..'z','0'..'9'];
begin
  s:='';
  GotoXY(X,Y);Write('Dateiname :');
  L:=1;
  Repeat
    InputKbd(S,8,X+12,Y,Term,Buchstaben,TC);
    Gut:=(Length(S)>0) or (TC=ESc);
  Until Menueende(L,1,1,TC) and Gut;
  S:=UpcaseStr(S);
end;


Procedure WaitonKey;
Var Ch :Char;
Begin
  If Keypressed Then Ch:=ReadKey;
  Repeat Until Keypressed;
  Ch:=ReadKey;
End;

Function LoadHelpScreen(Var S:HelpScreen):Boolean;
begin
  {$I-}
  LoadHelpscreen:=false;
  Assign(Helpfile,SearchFile(Helpfilename));
  Reset(Helpfile);
  MaxHelpNr:=Pred(FileSize(HelpFile));
  If IOresult=0 then
  begin
    If MaxHelpNr=-1 Then
    begin
      MaxHelpNr:=FileSize(HelpFile);
      HelpAvailable:=MaxHelpNr>0;
      MaxHelpNr:=Pred(MaxHelpNr);
    end;
    If ActualHelp>MaxHelpNr Then ActualHelp:=0;
    Seek(Helpfile,ActualHelp);
    If IOresult=0 then
    begin
      Read(Helpfile,S);
      LoadHelpscreen:=Ioresult=0;
    end;
    Close(Helpfile);
  end else Helpavailable:=false;
  {$I+}
end;

PROCEDURE Crea_Help;
Var S:Helpscreen;
  BEGIN
    If Not(ModeCO80) then
    begin
      HlpWinCol  :=CalcAttr(Crt.black,Crt.lightgray);
      HlpNorCol  :=CalcAttr(Crt.black,Crt.lightgray);
      HlpHeadCol :=CalcAttr(Crt.White,Crt.black);
    end;
    HelpAvailable:=LoadHelpScreen(S);
    If HelpAvailable Then
    begin
      MakeWindow (Help_Win,6,6,68,16,HlpWinCol,Help_Wok);
      HelpAvailable:=Help_Wok=0;
    end;
  END;

Procedure MakeHelp(Var HelpScr:HelpScreen);
  Var I:Integer;
      S:Str80;
  begin
    FillChar(S,Sizeof(S),32);
    S[0]:=#66;
    For I:=2 to 15 do
    begin
      WritetoWindow(Help_Win,2,I,HlpNorCol,S);
      WritetoWindow(Help_Win,3,I,HlpNorCol,HelpScr[I]);
     end;
  end;

Procedure Dohelp;
Var SaveCursor :Word;
    OK,First  :Boolean;
    Help:HelpScreen;
    P0  :Integer;
    KeyF:Integer;
    Key :Char;
    Prev:Integer;
BEGIN
  If HelpAvailable and Not(HelpActive) Then
  begin
    HelpActive:=true;
    Ok:=LoadHelpScreen(Help);
    If Ok Then
     begin
       First:=True;
       GetCursor(SaveCursor);
       SetCursor($2020);
       Repeat
         MakeFrame(Help_Win,HlpWinCol,2);
         WriteToWindow(Help_Win,10,16,HlpHeadCol,
                       ' <PgUp>,<PgDn> - ALT-R:Register - <ESC>:Ende ');
         If Ok Then
           begin
            P0:=(66-Length(Help[1])) shr 1;
            WritetoWindow(Help_Win,P0,1,HlpHeadCol,' '+Help[1]+' ');
            MakeHelp(Help);
           end
           else
             WritetoWindow(Help_Win,16,1,HlpHeadCol,' Fehler in Hilfe-Datei ');
         If First Then PutWindow (Help_Win,Help_Wok)
         else ShowWindow(Help_Win);                   { Hilfe anzeigen }
         First:=false;
         If Help_Wok=0 then
         begin
           KeyF:=ReadKbd(Key);
           Prev:=ActualHelp;
           Case Key of
             ^Q :Inc(ActualHelp,1);
             ^Z :Dec(ActualHelp,1);
             else
              begin
                If KeyF=1019 then ActualHelp:=0 else
                begin
                  Key:=Upcase(Key);
                  If (Ord(Key)>=Ord('A')) and (Ord(Key)<=Ord('Z')) then
                   ActualHelp:=HelpTable[Key];
                end;
              end;
            end;
            If ActualHelp<0 Then ActualHelp:=0;
            If ActualHelp>MaxHelpNr Then ActualHelp:=MaxHelpNr;
            If Prev<>ActualHelp Then
                Ok:=LoadHelpScreen(Help);
           end else Key:=Esc;
       UNTIL Key =Esc;
       FlushKbd;
       RestoreWindow (Help_Win,Help_Wok);            { Hintergrund anzeigen }
       SetCursor(SaveCursor);
      end;
   end;
   HelpActive:=false;
END;

Function SelectError(Msg,Head:Str80;OkSet:Charset):Char;
Var TC:Char;
    L:Integer;
    Wind_err:WindowType;
    Wok     :Integer;
begin
  If Length(Msg)>76 then Msg:=Copy(Msg,1,76);
  If Length(Head)>74 then Head:=Copy(Head,1,74);
  L:=Length(Msg)+4;
  If L<Length(Head) then L:=Length(Head)+6;
  If L>80 then L:=80;
  MakeWindow (wind_err,(80-L+1) div 2,17,L,3,ErrWinCol,wok);
  MakeFrame(wind_err,ErrWinCol,2);
  If Head<>'' then WriteToWindow(wind_err,3,1,ErrHeadCol,' '+Head+' ');
  WritetoWindow(wind_err,3,2,ErrwinCol,Msg);
  PutWindow(Wind_err,Wok);
  While Crt.Keypressed do TC:=Crt.ReadKey;
  Repeat
    TC:=Upcase(Crt.ReadKey);
  until TC in OkSet;
  SelectError:=TC;
  RestoreWindow(Wind_err,wok);
  DeleteWindow(Wind_err);
end;

Procedure  Message(Msg:Str80);
Var L:Integer;
    Wind_err:WindowType;
    Wok     :Integer;
begin
  If Length(Msg)>76 then Msg:=Copy(Msg,1,76);
  L:=Length(Msg)+4;
  If L>80 then L:=80;
  MakeWindow (wind_err,(80-L+1) div 2,14,L,3,DiaWinCol,wok);
  MakeFrame(wind_err,DiaWinCol,2);
  WriteToWindow(wind_err,3,3,DiaWinCol,' <irgendeine Taste> ');
  WritetoWindow(wind_err,3,2,DiaHeadCol,Msg);
  PutWindow(Wind_err,Wok);
  WaitonKey;
  RestoreWindow(Wind_err,wok);
  DeleteWindow(Wind_err);
end;