{ ************************************ }
{                      Atari Portfolio }
{ POCRT                                }
{                                      }
{                                      }
{ Copyright (C) 1989,90,91             }
{ bei KlickSoft  Boris Polenske        }
{                                      }
{ Letzte Žnderung:  3.9.1991           }
{ ************************************ }

Unit POCRT;
Interface

Uses DOS,
     CRT;

Const
 Basisadresse = $B000;

Const
 MaxWindowAnzahl                       = 10;
 MaxRahmenAnzahl                       =  4;
Type
 String80                              = String[80];
 Zeichenmengentyp                      = Set of Char;
 NoteRecord                            = Record
                                          C,CF,D,DF,E,F,
                                          FF,G,GF,A,AF,H : Integer;
                                         end;
 CursorSchalter                        = (Aus,Strich,Block);
 Rahmentyptyp                          = Array[1..MaxRahmenAnzahl,1..6] of
                                          Byte;
 Windowtyp                             = Array[1..2] of Byte;
 Windowpositionstyp                    = Record
                                          Altx,Alty,
                                          Ax1,Ay1,Ax2,Ay2      : Byte;
                                          Windowgroesse        : Integer;
                                          WindowPointer        : ^Windowtyp
                                         end;

Const
 Rahmentyp                             : Rahmentyptyp = ((201,187,200,
                                                          188,205,186),
                                                         (218,191,192,
                                                          217,196,179),
                                                         (213,184,212,
                                                          190,205,179),
                                                         (214,183,211,
                                                          189,196,186));
 Notes                                 : NoteRecord
                                          = (C:1;CF:2;D:3;DF:4;E:5;F:6;FF:7;
                                             G:8;GF:9;A:10;AF:11;H:12);

Var
 Windowpositionsstack                  : Array[0..MaxWindowAnzahl] of
                                          Windowpositionstyp;
 WTos                                  : -1..MaxWindowAnzahl;
 CursorTyp                             : CursorSchalter;
 Breite                                : Byte ABSOLUTE $40:$004A;
 Hoehe                                 : Byte ABSOLUTE $40:$0084;
 MaFehler                              : Integer;

{ ------------------------------------------------------------------ }

Procedure ProgramInit;

Procedure ProgramExit;

Function CreditCardOk(DrNum : Byte) : Boolean;

Procedure Play(Oktave,Note,Dauer: integer);

Procedure Off;

Procedure FillLen(Var St : String; Len : Byte);

Procedure ClearTastaturPuffer;

Procedure Refresh;

Procedure Pips;

Procedure SetzeCursor(x,y : Byte);

Procedure Cursor(Typ : CursorSchalter);

Function Cursorx : Byte;

Function Cursory : Byte;

Function Offset(x,y : Byte) : Integer;

Function HoleZeichen(x,y : Byte) : Byte;

Procedure SchreibeZeichen(x,y,Anzahl,Zeichen : Byte);

Procedure FWrite(x,y : Byte; Text : String);

Procedure FWriteZent(x1,x2,y : Byte; Text : String);

Procedure WriteRahmen(x1,y1,x2,y2,Rahmennummer : Byte);

Procedure WindowLeft;

Procedure WindowRight;

Procedure WindowClr(x1,y1,x2,y2 : Byte);

Procedure MakeWindow(x1,y1,x2,y2,Rahmennummer : Byte);

Procedure RestauriereWindow;

Procedure DosFehler;

Procedure PutMessage(Message : String80);

Function PutQuestion(Question : String80; Zeichen : Zeichenmengentyp) : Char;

Procedure StuffKey(W : Word);

Procedure Clrscr;

{ ------------------------------------------------------------------ }
{ ------------------------------------------------------------------ }

Implementation

{ ------------------------------------------------------------------ }


Procedure FillLen(Var St : String; Len : Byte);
begin
 If Length(St)<Len then
  FillChar(St[Succ(Length(St))],Len-Length(St),#32);
 St[0]:=Chr(Len);
end;

Function Int24Result : Integer;
begin
 Int24Result:=IOResult;
end;

Function KeyPressed : Boolean;
begin
 KeyPressed:=CRT.KeyPressed;
end;

Function Readkey : Char;
begin
 Readkey:=CRT.Readkey;
end;

Procedure ClearTastaturPuffer;
begin
 Mem[$0040:$001C]:=Mem[$0040:$001A];
end;

Procedure Pips;
begin
 Write(#7);
end;

Procedure Refresh;
Var
 Register                              : Registers;
begin
 With Register do begin
  ah:=$12;
  Intr($61,Register);
 end;
end;

Procedure SetzeCursor(x,y : Byte);
Var Register                           : Registers;
begin
 With Register do begin
  ah:=2;
  dl:=Pred(x);
  dh:=Pred(y);
  Intr($10,Register);
 end;
end;

Procedure Cursor(Typ : CursorSchalter);
Var
 Register                              : Registers;
begin
 With Register do begin
  ah:=$0F;
  al:=1;
  Case Typ of
             Aus    : bl:=0;
             Strich : bl:=2;
             Block  : bl:=2;
          end;
  Intr($61,Register);
  Cursortyp:=Typ;
 end;
end;

Function Cursorx : Byte;
Var Register                           : Registers;
begin
 With Register do begin
  ah:=3;
  Intr($10,Register);
  Cursorx:=Succ(dl);
 end;
end;

Function Cursory : Byte;
Var Register                           : Registers;
begin
 With Register do begin
  ah:=3;
  Intr($10,Register);
  Cursory:=Succ(dh);
 end;
end;

Function Offset(x,y : Byte) : Integer;
begin
 Offset:=(Pred(x) shl 1)+Pred(y)*(Breite*2);
end;

Function HoleZeichen(x,y : Byte) : Byte;
begin
 HoleZeichen:=Mem[Basisadresse:Offset(x,y)]
end;

Procedure SchreibeZeichen(x,y,Anzahl,Zeichen : Byte);
Var Off,Zaehler                        : Integer;
begin
 Off:=Offset(x,y);
 For Zaehler:=1 to Anzahl do begin
  Mem[Basisadresse:Off]:=Zeichen;
  Inc(Off,2);
 end;
end;

{ ------------------------------------------------------------------ }

Procedure FWrite(x,y : Byte; Text : String);
Var Zaehler,Off                        : Integer;
begin
 Off:=Offset(x,y);
 For Zaehler:=1 to Length(Text) do begin
  Mem[Basisadresse:Off]:=Ord(Text[Zaehler]);
  Inc(Off,2);
 end;
end;

{ ------------------------------------------------------------------ }

Procedure FWriteZent(x1,x2,y : Byte; Text : String);
Var Zaehler,Off                        : Integer;
begin
 Off:=Offset(x1+Succ((x2-x1-Length(Text)) div 2),y);
 For Zaehler:=1 to Length(Text) do begin
  Mem[Basisadresse:Off]:=Ord(Text[Zaehler]);
  Inc(Off,2);
 end;
end;

{ ------------------------------------------------------------------ }

Procedure WriteRahmen(x1,y1,x2,y2,Rahmennummer : Byte);
Var Zaehler                            : Integer;
    Altx,Alty                          : Byte;
begin
 If RahmenNummer=5 then
  Exit;
 SchreibeZeichen(x1,y1,1,Rahmentyp[Rahmennummer,1]);
 SchreibeZeichen(x1,y2,1,Rahmentyp[Rahmennummer,3]);

 SchreibeZeichen(Succ(x1),y1,x2-x1-1,Rahmentyp[Rahmennummer,5]);
 SchreibeZeichen(Succ(x1),y2,x2-x1-1,Rahmentyp[Rahmennummer,5]);

 For Zaehler:=Succ(y1) to Pred(y2)+2 do begin
  If Zaehler<=Pred(y2) then begin
   SchreibeZeichen(x1,Zaehler,1,Rahmentyp[Rahmennummer,6]);
   SchreibeZeichen(x2,Zaehler,1,Rahmentyp[Rahmennummer,6]);
  end;
 end;

 SchreibeZeichen(x2,y1,1,Rahmentyp[Rahmennummer,2]);
 SchreibeZeichen(x2,y2,1,Rahmentyp[Rahmennummer,4]);
end;

{ ------------------------------------------------------------------ }

Procedure WindowLeft;
Var
 x,y                                   : Byte;
begin
 For y:=2 to 7 do begin
  For x:=2 to 38 do
   SchreibeZeichen(x,y,1,HoleZeichen(Succ(x),y));
  SchreibeZeichen(39,y,1,32);
 end;
end;

Procedure WindowRight;
Var
 x,y                                   : Byte;
begin
 For y:=2 to 7 do begin
  For x:=39 downto 3 do
   SchreibeZeichen(x,y,1,HoleZeichen(Pred(x),y));
  SchreibeZeichen(2,y,1,32);
 end;
end;

Procedure WindowClr(x1,y1,x2,y2 : Byte);
Var Register                           : Registers;
begin
 With Register do begin
  ah:=6;
  al:=0;
  ch:=y1;
  cl:=x1;
  dh:=y2;
  dl:=x2;
  bh:=$F;
 end;
 Intr($10,Register);
end;

Procedure MakeWindowCustom(x1,y1,x2,y2,Rahmennummer : Byte; Var Window : WindowPositionstyp);
Var
 y,i                                   : Integer;
 ArrOff,WindowBreite                   : Integer;
 Off                                   : Word;
 zs                                    : string[10];
begin
 With Window do begin
  Altx:=Cursorx;
  Alty:=Cursory;
  Ax1:=x1;
  Ax2:=x2;
  Ay1:=y1;
  Ay2:=y2;
  Windowgroesse:=Succ(Ax2-Ax1)*Succ(Ay2-Ay1);
  WindowBreite:=Succ(Ax2-Ax1);
  GetMem(WindowPointer,Windowgroesse);
  ArrOff:=1;
  For y:=Ay1 to Ay2 do begin
   Off:=Offset(Ax1,y);
   For i:=Ax1 to Ax2 do begin
    WindowPointer^[ArrOff]:=Byte(Ptr(Basisadresse,Off)^);
    Inc(ArrOff);
    Inc(Off,2);
   end;
  end;
 end;
 If RahmenNummer<>6 then begin
  WindowClr(Pred(x1),Pred(y1),Pred(x2),Pred(y2));
  WriteRahmen(x1,y1,x2,y2,Rahmennummer);
 end;
end;

Procedure MakeWindow(x1,y1,x2,y2,Rahmennummer : Byte);
begin
 WTos:=Succ(WTos);
 MakeWindowCustom(x1,y1,x2,y2,Rahmennummer,WindowpositionsStack[WTos]);
 Refresh;
end;

{ ------------------------------------------------------------------ }

Procedure RestauriereWindowCustom(Var Window : WindowPositionstyp);
Var
 y,i                                   : Integer;
 x                                     : Byte;
 Off,ArrOff,WindowBreite               : Integer;
begin
 With Window do begin
  If WindowPointer<>Nil then begin
   ArrOff:=1;
   WindowBreite:=Succ(Ax2-Ax1);
   For y:=Ay1 to Ay2 do begin
    Off:=Offset(Ax1,y);
    For i:=Ax1 to Ax2 do begin
     Byte(Ptr(Basisadresse,Off)^):=WindowPointer^[ArrOff];
     Inc(ArrOff,1);
     Inc(Off,2);
    end;
{    Move(Ptr(Seg(WindowPointer^[ArrOff]),Ofs(WindowPointer^[ArrOff]))^,
         Ptr(Basisadresse,Off)^,WindowBreite);
    Inc(ArrOff,WindowBreite);}
   end;
   SetzeCursor(Altx,Alty);
   FreeMem(WindowPointer,Windowgroesse);
   WindowPointer:=Nil;
  end;
 end;
end;

Procedure RestauriereWindow;
begin
 If WTos>0 then begin
  RestauriereWindowCustom(Windowpositionsstack[WTos]);
  Dec(WTos,1);
 end;
 Refresh;
end;

{ ------------------------------------------------------------------ }

Procedure DosFehler;
Var Nummer                             : String[3];
    Taste                              : Char;
begin
 MakeWindow(1,6,40,8,1);
 Pips;
 Str(MaFehler:3,Nummer);
 Case Hi(MaFehler) of
                  1 : FWrite(3,7,'Ung�ltige Laufwerksnummer!');
                  2 : FWrite(3,7,'Laufwerk nicht bereit!');
                  7 : FWrite(3,7,'Disk Format nicht beekannt!');
                $0A : FWrite(3,7,'Schreibfehler!');
                $0B : FWrite(3,7,'Lesefehler!');
                $0D : FWrite(3,7,'Diskette schreibgesch�tzt!');
 else
  Case Lo(MaFehler) of
                   2 : FWrite(3,7,'Datei nicht gefunden!');
                   3 : FWrite(3,7,'Pfad nicht gefunden!');
                   4 : FWrite(3,7,'Maximalanzahl an Dateien bereits offen!');
                   5 : FWrite(3,7,'Dateizugriff verweigert!');
                  15 : FWrite(3,7,'Ung�ltige Laufwerksnummer!');
                  16 : FWrite(3,7,'Als Standard gesetztes Verzeichnis kann nicht gel”scht werden!');
                  17 : FWrite(3,7,'Verschieben nur innerhalb eines Laufwerkes!');
                 else If MaFehler>0 then
                       FWrite(3,7,'Fehler beim Zugriff! Fehler: '+Nummer);
                 end;
 end;
 FWriteZent(1,40,8,'<Bitte beliebige Taste dr�cken>');
 Refresh;
 Taste:=Readkey;
 ClearTastaturPuffer;
 RestauriereWindow;
 MaFehler:=0;
end;

Procedure PutMessage(Message : String80);
Var
 Taste                                 : Char;

begin
 ClearTastaturPuffer;
 MakeWindow(1,6,40,8,2);
 FWrite(3,7,Message);
 Refresh;
 Taste:=Readkey;
 If Taste=#0 then
  Taste:=Readkey;
 ClearTastaturPuffer;
 RestauriereWindow;
end;

Function PutQuestion(Question : String80; Zeichen : Zeichenmengentyp) : Char;
Var
 Taste                                 : Char;
begin
 ClearTastaturPuffer;
 MakeWindow(1,6,40,8,2);
 FWrite(3,7,Question+#32);
 SetzeCursor(3+Length(Question),7);
 Cursor(Strich);
 Refresh;
 Repeat
  Taste:=Upcase(Readkey);
 Until Taste in Zeichen;
 Cursor(Aus);
 PutQuestion:=Taste;
 ClearTastaturPuffer;
 RestauriereWindow;
end;

Procedure SaveBackG(NeuFarbe : Byte);
begin
end;

Procedure RestoreBackG;
begin
end;

Procedure StuffKey(W : Word);
const
  KbdStart = $1E;
  KbdEnd = $3C;
var
  KbdHead : Word absolute $40 : $1A;
  KbdTail : Word absolute $40 : $1C;
  SaveKbdTail : Word;
begin
 If W=0 then Exit;
 SaveKbdTail := KbdTail;
 If KbdTail = KbdEnd then
  KbdTail := KbdStart
 else
  Inc(KbdTail, 2);
 If KbdTail = KbdHead then
  KbdTail := SaveKbdTail
 else
  MemW[$40:SaveKbdTail] := W;
end;

Procedure HoleAktDatum(Var AktJahr,AktMonat,AktTag,AktStunde,AktMinute : Byte);
Var
 Z1,Z2,Z3,Z4               : Word;

begin
 GetDate(Z1,Z2,Z3,Z4);
 AktJahr:=Z1-1900;
 AktMonat:=Z2;
 AktTag:=Z3;
 GetTime(Z1,Z2,Z3,Z4);
 AktStunde:=Z1;
 AktMinute:=Z2;
end;

Procedure InitGraph;
Var
 Reg                                   : Registers;
begin
 With Reg do begin
  ah:=$0E;
  al:=1;
  dl:=$80;
  Intr($61,Reg);
 end;
end;

Function CreditCardOk(DrNum : Byte) : Boolean;
Var
 Reg                                   : Registers;
begin
 With Reg do begin
  ah:=$0B;
  al:=DrNum;
  Intr($61,Reg);
  CreditCardOk:=(Flags and 1)=0;
 end;
end;


Procedure Play(Oktave,Note,Dauer: integer);
Var
 Regs                                  : Registers;
begin
 With Regs do begin;
  DL:=0;
  If Oktave=2 then begin
   Case Note of
               1 : DL:=$39;
               2 : DL:=$3A;
               3 : DL:=$29;
               4 : DL:=$3B;
               5 : DL:=$3C;
               6 : DL:=$3D;
               7 : DL:=$0E;
               8 : DL:=$3E;
               9 : DL:=$2C;
              10 : DL:=$3F;
              11 : DL:=$04;
              12 : DL:=$05;
   end;
  end else begin
   Case Note of
               1 : DL:=$30;
               2 : DL:=$30;
               3 : DL:=$30;
               4 : DL:=$30;
               5 : DL:=$31;
               6 : DL:=$32;
               7 : DL:=$33;
               8 : DL:=$34;
               9 : DL:=$35;
              10 : DL:=$36;
              11 : DL:=$37;
              12 : DL:=$38;
   end;
  end;
  Ah:=$16;
  CX:=Dauer div 30;
 end;
 Intr($61,Regs);
end;

Procedure Off;
Var
 Reg                                   : Registers;
begin
 Reg.ah:=$2D;
 Intr($61,Reg);
end;

Var
 ExitSave                              : Pointer;

Procedure ProgramInit;
Var
 Reg                                   : Registers;
begin
 With Reg do begin
  ah:=0;
  Intr($61,Reg);
 end;
 With Reg do begin
  ah:=$0E;
  al:=1;
  dl:=1;
  Intr($61,Reg);
 end;

 With Reg do begin
  ah:=$1E;
  al:=1;
  bx:=0;
  Intr($61,Reg);
 end;
 WindowClr(0,0,39,7);
end;

Procedure ProgramExit;
Var
 Reg                                   : Registers;
begin
 Windowclr(0,0,39,7);
 With Reg do begin
  ah:=$0E;
  al:=1;
  dl:=1;
  Intr($61,Reg);
 end;

 Cursor(Strich);
 ExitProc:=ExitSave;
end;

Procedure ClrScr;
begin
 Windowclr(0,0,39,7);
end;


begin
 ExitSave:=ExitProc;
 ExitProc:=@ProgramExit;
 ProgramInit;
end.