Power-Programmierung/CD1.mdf/pascal/library/dos/s5/extend.pas

Pascal/Delphi Source File | 1990-12-27 | 27.0 KB | 1,130 lines

unit extend;
{$D+,I-,R-,S-,F-,V-,B-,L-}
{$M 4096,0,65535}

interface

uses
crt,dos;


type
range              =  set of char;
str12              =  string[12];
str20              =  string[20];
filename           =  str12;
screenptr          =  ^screentype;
screentype         =  record
                        pos  :  array[1..25,1..80] of record
                                                        ch :  char;
                                                        at :  byte;
                                                      end;
                      end;


const
_spmax             :  byte  = 80;
_zmax              :  byte  = 25;
_inpwinsp          :  byte  = 20;
_inpwinz           :  byte  = 11;
_inpwinlen         :  byte  = 40;
_dirwinmax         :  byte  = 60;
_dirwinsp          :  byte  = 15;
_dirwinz           :  byte  = 7;
_dirwinfwide       :  byte  = 13;
_dirwinanzsp       :  byte  = 4;
_auswahl_chpos     :  byte  = 1;

terminator         :  range = [#13,#27];
extterminator      :  range = [#1..#27];
csrterm            :  range = [#73,#81];
jn                 :  range = ['J','j','Y','y','N','n'];
buchstaben         :  range = ['A'..'Z','a'..'z'];
filechar           :  range = ['A'..'Z','a'..'z','_','.','\',':'];
wildcards          :  range = ['*','?'];
umlaute            :  range = ['Ü','ü','Ö','ö','Ä','ä','ß'];
grossbuchstaben    :  range = ['A'..'Z','Ä','Ö','Ü'];
kleinbuchstaben    :  range = ['a'..'z','ä','ö','ü','ß'];
ziffern            :  range = ['0'..'9'];
vorzeichen         :  range = ['+','-'];
punkt              :  range = ['.'];
binchar            :  range = ['0','1'];
hexchar            :  range = ['0'..'9','A'..'F'];
backspace          =  #8;
space              =  #32;
esc                =  #27;
cr                 =  #13;
lf                 =  #10;
ff                 =  #12;
f1                 =  #59;
f2                 =  #60;
f3                 =  #61;
f4                 =  #62;
f5                 =  #63;
f6                 =  #64;
f7                 =  #65;
f8                 =  #66;
f9                 =  #67;
f10                =  #68;
sf1                =  #84;
sf2                =  #85;
sf3                =  #86;
sf4                =  #87;
sf5                =  #88;
sf6                =  #89;
sf7                =  #90;
sf8                =  #91;
sf9                =  #92;
sf10               =  #93;
cf1                =  #94;
cf2                =  #95;
cf3                =  #96;
cf4                =  #97;
cf5                =  #98;
cf6                =  #99;
cf7                =  #100;
cf8                =  #101;
cf9                =  #102;
cf10               =  #103;
af1                =  #104;
af2                =  #105;
af3                =  #106;
af4                =  #107;
af5                =  #108;
af6                =  #109;
af7                =  #110;
af8                =  #111;
af9                =  #112;
af10               =  #113;
csr_up             =  #72;
csr_dn             =  #80;
csr_l              =  #75;
csr_r              =  #77;
pgup               =  #73;
pgdn               =  #81;
home               =  #71;
ende               =  #79;
initdrucker        =  #27'@'#24;
schmalschriftein   =  #15;
schmalschriftaus   =  #18;
normalschriftein   =  #27'T';
fettdruckein       =  #27'E';
fettdruckaus       =  #27'F';
elite              =  #27'M';
pica               =  #27'P';
doppeldruckein     =  #27'G';
doppeldruckaus     =  #27'H';
tiefstellenein     =  #27'S1';
hochstellenein     =  #27'S0';
breitschriftein    =  #27'W1';
breitschriftaus    =  #27'W0';
unterstreichenein  =  #27'-1';
unterstreichenaus  =  #27'-0';
kursivein          =  #27'4';
kursivaus          =  #27'5';

messageattr        :  byte = $F0;
frageattr          :  byte = $F0;
inputattr          :  byte = $F0;
fensterattr        :  byte = $70;
auswahlattr        :  byte = $17;
normalattr         :  byte = $07;
highlightattr      :  byte = $F0;
askmask            :  boolean = true;
extterm            :  boolean = false;
_80x87             :  boolean = false;
_game              :  boolean = false;
_dma               :  boolean = false;
screenadr          :  word = $B800;
screen_init        :  boolean = false;

var
com1               :  word    absolute $0040:$0000;
com2               :  word    absolute $0040:$0002;
com3               :  word    absolute $0040:$0004;
com4               :  word    absolute $0040:$0006;
lpt1               :  word    absolute $0040:$0008;
lpt2               :  word    absolute $0040:$000A;
lpt3               :  word    absolute $0040:$000C;
lpt4               :  word    absolute $0040:$000E;
equipment          :  word    absolute $0040:$0010;
ram                :  word    absolute $0040:$0013;
kbdstat            :  byte    absolute $0040:$0017;
videomode          :  byte    absolute $0040:$0049;
cursor_form        :  word    absolute $0040:$0060;
doszeit            :  longint absolute $0040:$006C;
anz_hd             :  byte    absolute $0040:$0075;
last_fd            :  byte    absolute $0050:$0004;
computer           :  byte    absolute $F000:$FFFE;
anz_fd             :  byte;
anz_com            :  byte;
anz_lpt            :  byte;
regs               :  registers;
fkey,ja            :  boolean;
ch,key             :  char;
mask               :  string;
screen             :  screenptr;
screenbuffer       :  array[1..6] of screenptr;
value              :  range;
errnum             :  word;
wahlterm           :  byte;
_wherex,_wherey    :  byte;
_windmin,_windmax  :  word;
_textattr          :  word;
max_screen         :  word;
dira               :  array[1..100] of str12;

function  tstbit (zahl : word; bitnr : byte) : boolean;
function  setbit (zahl : word; bitnr : byte) : word;
function  clrbit (zahl : word; bitnr : byte) : word;
function  bytehex (b : byte) : string;
function  bytebin (b : byte) : string;
function  wordhex (w : word) : string;
function  wordbin (w : word) : string;
procedure save_cursor;
procedure restore_cursor;
procedure save_window;
procedure restore_window;
procedure save_textattr;
procedure restore_textattr;
procedure cursor_block;
procedure cursor_ein;
procedure cursor_aus;
procedure write_screen( s,z : integer; str : string);
procedure screen_attr(nr,ss,es,sz,ez : integer; attr : byte);
procedure init_screen( max : integer );
procedure save_screen( i : integer );
procedure restore_screen( i : integer);
procedure getkey;
procedure std_inout;
procedure crt_inout;
function  upstring(s : string) : string;
function  lostring(s : string) : string;
function  exist(n : string) : boolean;
function  load_screen(i : integer; n : string) : boolean;
procedure rahmen(s,z,b,h : integer);
procedure fenster(s,z,b,h : integer);
procedure wait(s : word);
procedure p1(attr : byte);
procedure message(s : string);
function  frage_jn(s : string) : boolean;
procedure input_str(msg : string;VAR s : string; l : integer; valid : range);
function  input_int(s : string;a : boolean;l : integer; i, min, max : longint) : longint;
function  input_real(s : string;a : boolean;l, d : integer; i, min, max : real) : real;
procedure read_str(VAR s : string; l : integer; valid : range);
function  read_int(a : boolean;l : integer; i, min, max : longint) : longint;
function  read_real(a : boolean;l, d : integer; i, min, max : real) : real;
function  int_to_str(i : longint; w : integer) : string;
function  real_to_str(r : real; w,d : integer) : string;
function  int_from_str(z : string; von,len : integer) : longint;
function  real_from_str(z : string; von,len : integer) : real;
function  int_from_cmdline(nr,von,bis : integer) : longint;
function  real_from_cmdline(nr : integer;von,bis : real) : real;
procedure Auswahl(xPos,yPos,Breite,Spalten : INTEGER;
                  UmRahmung : BOOLEAN; AnzahlBytes : INTEGER;
                  VAR Menue; Anzahl : INTEGER; VAR Wahl : INTEGER);
function  dirwin : string;

implementation

const
spaces             =  '                                                                                ';
line               =  '════════════════════════════════════════════════════════════════════════════════';

var
i,j,max            :  integer;
path               :  string;
srec               :  searchrec;


function  tstbit (zahl : word; bitnr : byte) : boolean;

begin
  tstbit           := (((zahl shr bitnr) and 1) = 1);
end;


function  setbit (zahl : word; bitnr : byte) : word;

begin
  setbit           := zahl or (1 shl bitnr);
end;


function  clrbit (zahl : word; bitnr : byte) : word;

begin
  clrbit           := zahl and not (1 shl bitnr);
end;


function  bytehex (b : byte) : string;

var
nl,nh              :  byte;

begin
  nh               := b div 16;
  if (nh > 9) then inc(nh,7);
  nl               := b mod 16;
  if (nl > 9) then inc(nl,7);
  bytehex          := chr(nh+48) + chr(nl+48);
end;


function  bytebin (b : byte) : string;

const
c                  :  array[1..8] of byte = (128,64,32,16,8,4,2,1);

var
n                  :  integer;
s                  :  str20;

begin
  s                := '';
  for n            := 1 to 8 do
    if (c[n] > b) then
      s            := s + '0'
    else
    begin
      s            := s + '1';
      b            := b - c[n];
    end;
  bytebin          := s;
end;


function  wordhex (w : word) : string;

begin
  wordhex          := bytehex(hi(w)) + bytehex(lo(w));
end;


function  wordbin (w : word) : string;

begin
  wordbin          := bytebin(hi(w)) + bytebin(lo(w));
end;


procedure save_cursor;

begin
  _wherex          := wherex;
  _wherey          := wherey;
end;


procedure restore_cursor;

begin
  gotoxy(_wherex,_wherey);
end;


procedure save_window;

begin
  _windmin         := windmin;
  _windmax         := windmax;
end;


procedure restore_window;

begin
  windmin          := _windmin;
  windmax          := _windmax;
end;


procedure save_textattr;

begin
  _textattr        := textattr;
end;


procedure restore_textattr;

begin
  textattr         := _textattr;
end;


procedure cursor( l,h : byte );


begin
  regs.ah          := 1;
  regs.cl          := l;
  regs.ch          := h;
  intr   (16,regs);
end;


procedure cursor_block;

begin
  if (videomode = 7) then
    cursor (13, 0)
  else
    cursor ( 7, 0);
end;


procedure cursor_ein;

begin
  if (videomode = 7) then
    cursor (13,12)
  else
    cursor ( 7, 6);
end;


procedure cursor_aus;

begin
  if (videomode = 7) then
    cursor ( 0,14)
  else
    cursor ( 0, 1);
end;


procedure write_screen( s,z : integer; str : string);

var
i                  :  integer;

begin
    if ((s in [1.._spmax]) and (z in [1.._zmax])) then
    begin
      dec(s);
      if ((length(str) +  s)  <= _spmax) then
        for i      := 1 to length(str) do
          screen^.pos[z,s+i].ch := str[i];
    end;
end;


procedure screen_attr(nr,ss,es,sz,ez : integer; attr : byte);

var
i                  :  integer;

begin
  if (screen_init and (nr <= max_screen)) then
  begin
    if ((ss in [1.._spmax]) and (es in [1.._spmax])  and
        (sz in [1.._zmax ]) and (ez in [1.._zmax])) then
    begin
      for j        := sz to ez do
        for i      := ss to es do
          screenbuffer[nr]^.pos[j,i].at := attr;
    end;
  end;
end;


procedure save_screen( i : integer );

begin
  if (screen_init and (i <= max_screen)) then
    screenbuffer[i]^         := screen^;
end;


procedure restore_screen( i : integer );

begin
  if (screen_init and (i <= max_screen)) then
    screen^        := screenbuffer[i]^;
end;


procedure getkey;

begin
  while keypressed do key := readkey;

  repeat
  until keypressed;

  key              := readkey;
  if (key = #0) then
  begin
    key            := readkey;
    fkey           := true;
    ja             := false;
  end
  else
  begin
    fkey           := false;
    ja             := (upcase(key) in ['Y','J']);
  end;
end;


procedure std_inout;

begin
  assign (input,''); Reset (input);
  assign (output,''); Rewrite (output);
end;


procedure crt_inout;

begin
  close(input); assignCrt (input); Reset (input);
  close(output); assignCrt (output); Rewrite (output);
end;


function upstring(s : string) : string;

var
i                  :  integer;

begin
  for i            := 1 to length(s) do s[i] := upcase(s[i]);
  upstring         := s;
end;


function lostring(s : string) : string;

var
i                  :  integer;

begin
  for i            := 1 to length(s) do
  if (s[i] in ['A'..'Z']) then
    s[i]           := char(byte(s[i])+32);
  lostring         := s;
end;


function exist(n : string) : boolean;

var
f                  : file;

begin
  assign (f,n);
  (*$I-*)
  reset (f);
  errnum           := ioresult;
  (*$I+*)
  if errnum = 0 then close (f);
  exist            := (errnum = 0);
end;


function load_screen(i : integer; n : string) : boolean;

var
f                  :  file;
ids                :  word;

begin
  if ((screen_init and (i <= max_screen)) or (i = 0)) then
  begin
  if exist(n) then
  begin
    assign (f,n);
    reset (f,1);
    if (filesize(f) = (_spmax*_zmax*2)) then
    begin
      if i=0 then
        blockread(f,screen^,(_spmax*_zmax*2),ids)
      else
        blockread(f,screenbuffer[i]^,(_spmax*_zmax*2),ids);
      load_screen  := true;
    end
    else
      load_screen  := false;
    close (f);
  end
  else
    load_screen    := false;
  end;
end;


procedure rahmen(s,z,b,h : integer);

var
i                  :  integer;

begin
  gotoxy (s, z);
  write  ('╒',copy(line,1,b),'╕');
  gotoxy (s,z+h+1);
  write  ('╘',copy(line,1,b),'╛');
  for i            := z+1 to z+h do
  begin
    gotoxy (s, i);
    write  ('│',copy(spaces,1,b),'│');
  end;
end;


procedure fenster(s,z,b,h : integer);

begin
  textattr         := fensterattr;
  rahmen(s,z,b,h);
  window(s+1,z+1,s+b,z+h);
  clrscr;
end;


procedure wait(s : word);

begin
  for i            := 1 to s * 1000 do
  begin
    delay(1);
    if keypressed then
    begin
      ch           := readkey;
      exit;
    end;
  end;
end;



procedure Auswahl(xPos,yPos,Breite,Spalten : INTEGER;
                  UmRahmung : BOOLEAN; AnzahlBytes : INTEGER;
                  VAR Menue; Anzahl : INTEGER; VAR Wahl : INTEGER);
(*                                                                          *)
(*   p Auswahl(xPos,yPos,Breite,Spalten,UmRahmung,                          *)
(*             AnzahlBytes,Menue,Anzahl,Wahl                                *)
(*      xPos, yPos : Bildschirm-Koordinaten des ersten Menüpunktes          *)
(*      Breite     : (INTEGER) Breite des Leuchtbalkens                     *)
(*      Spalten    : (INTEGER) Anzahl der Tabellen-Spalten                  *)
(*      UmRahmung  : (BOOLEAN) Rahmen zeichnen oder nicht                   *)
(*      AnzahlBytes: (INTEGER) = SizeOf(Menue[1])                           *)
(*      Menue      : (ARRAY[1..Anzahl] OF STRING[X]) das Menü               *)
(*      Anzahl     : (INTEGER) Anzahl der angezeigten Menüpunkte            *)
(*      Wahl       : (VAR INTEGER)                                          *)
(*                     >0 Der gewählte Punkt                                *)
(*                     =0 Auswahl wurde über <ESC> verlassen                *)

   TYPE StrPtr = ^String;
   VAR  MenueStr : ARRAY[1..255] OF StrPtr;
        Zeilen, i,j : INTEGER;
        term : range;


   PROCEDURE Locate(Nr : INTEGER);
     BEGIN
       gotoxy(xPos+(pred(Nr) DIV Zeilen)*Breite,yPos+(pred(Nr) MOD Zeilen))
     END (* Locate *);

   PROCEDURE Print(Nr : INTEGER);
     VAR i : INTEGER;
     BEGIN
       Write(copy(MenueStr[Nr]^,1,Breite));
       FOR i:=succ(length(MenueStr[Nr]^)) TO Breite DO Write(' ')
     END (* Print *);

   PROCEDURE ChangeHighLight(VAR alt, neu : INTEGER);
     BEGIN
       Locate(alt); textattr := auswahlattr; Print(alt);
       Locate(neu); textattr := highlightattr; Print(neu);
       Locate(neu); textattr := auswahlattr; alt:=neu;
     END (* ChangeHighLight *);

   BEGIN
     cursor_aus;
     save_textattr;
     textattr      := auswahlattr;
     term          := terminator;
     if extterm then term := extterminator;
     Zeilen:=pred(Anzahl+Spalten) DIV Spalten; Wahl:=Wahl AND 255;
     IF UmRahmung THEN Rahmen(xPos-1,yPos-1,Breite*Spalten,Zeilen);
     IF (Wahl>Anzahl) OR (Wahl<1) THEN Wahl:=1;
     FOR i:=1 TO Anzahl DO BEGIN
       MenueStr[i]:=Ptr(Seg(Menue),Ofs(Menue)+pred(i)*AnzahlBytes);
       Locate(i); IF i=Wahl THEN textattr := highlightattr ELSE textattr := auswahlattr;
       Print(i)
     END; (* FOR *)
     Locate(Wahl); i:=Wahl;
     REPEAT
       IF i<>Wahl THEN ChangeHighLight(i,Wahl);
       getkey;
       if fkey then
       begin
         CASE key OF
         csr_l : IF Wahl>Zeilen THEN Wahl:=Wahl-Zeilen ELSE
                 IF Wahl>1 THEN Wahl:=Wahl+pred(Spalten)*Zeilen-1 ELSE
                 WAHL:=Anzahl;
         csr_r : IF Wahl<=Anzahl-Zeilen THEN Wahl:=Wahl+Zeilen ELSE
                 IF (Wahl>pred(Spalten)*Zeilen) AND (Wahl<Anzahl)
                 THEN Wahl:=Wahl-pred(Spalten)*Zeilen+1 ELSE
                 Wahl:=1;
         csr_up: IF Wahl>1 THEN Wahl:=Wahl-1
                 ELSE Wahl:=Anzahl;
         csr_dn: IF Wahl<Anzahl THEN Wahl:=Wahl+1
                 ELSE Wahl:=1;
         home  : Wahl:=1;
         ende  : Wahl:=Anzahl;
         END (* CASE *)
       end
       else
       begin
         if (upcase(key) in buchstaben) then
         begin
           if (upcase(key) = copy(MenueStr[Wahl]^,_auswahl_chpos,1)) then
             j := Wahl
           else
             j := 0;
           repeat
             inc(j);
           until (j >= Anzahl) or (upcase(key) = copy(MenueStr[j]^,_auswahl_chpos,1));
           if (upcase(key) = copy(MenueStr[j]^,_auswahl_chpos,1)) then
             Wahl := j;
         end;
         if ((key in ziffern) and ((ord(key)-48) <= Anzahl)) then
         begin
           Wahl := ord(key)-48;
         end;
       end;
       if (key = esc) then wahl := 0;
     UNTIL ((key in term) and not fkey) or (fkey and (key in csrterm));
   wahlterm := byte(key);
   restore_textattr;
   cursor_ein;
   END (* Auswahl *);


procedure p9;

begin
  delay(500);
  restore_textattr;
  if screen_init then restore_screen(max_screen);
end;


function dirwin : string;

var
marked             :  integer;
ende               :  boolean;


procedure sortdira(von,bis : integer);

var
i,j                :  integer;
s                  :  str12;

begin
  for i            := von to bis do
    for j          := von to bis do
      if dira[j] > dira[i] then
      begin
        s          := dira[i];
        dira[i]    := dira[j];
        dira[j]    := s;
      end;
end;

procedure dir;

begin
  srec.name        := '*.*';
  i                := 0;
  findfirst(copy(path,1,length(path)-length(mask))+'*.*',$20+$10,srec);
  while not (doserror = 18) and (i <= _dirwinmax) do
  begin
    if srec.attr = Directory then
    begin
      if srec.name <> '.' then
      begin
        inc(i);
        dira[i]    := srec.name + '\';
      end;
    end;
    findnext(srec);
  end;
  max              := i;
  if (i > 1) then sortdira(1,i);

  srec.name        := path;
  findfirst(path,Archive or Hidden,srec);
  while not (doserror = 18) and (i <= _dirwinmax) do
  begin
      inc(i);
      if ((srec.attr and Hidden) = Hidden) then
        dira[i]    := lostring(srec.name)
      else
        dira[i]    := srec.name;
    findnext(srec);
  end;
  if dira[1] = (copy(path,1,3) + mask) then dec(i);

  if (i > max+1) then sortdira(max+1,i);
  max              := i;
end;

begin
  if screen_init then save_screen(max_screen);
  save_textattr;
  if askmask then input_str('Suchmaske',mask,12,filechar + wildcards);
  if (key <> esc) then
  begin
  getdir(0,path);
  if length(path) > 3 then path := path + '\';
  path             := path + mask;
  repeat
  clrscr;
  dir;
  if max < 1 then
  begin
    max            := 1;
    dira[max]      := 'No files!';
  end;
  marked           := 1;
  ende             := true;
  auswahl(_dirwinsp,_dirwinz,_dirwinfwide,_dirwinanzsp,true,sizeof(dira[1]),dira,max,marked);
  if (marked > 0) then
  begin
    if (dira[marked][length(dira[marked])] = '\') then
    begin
      ende         := false;
        if dira[marked] = '..\' then
        begin
          if path <> mask then
          begin
            i      := length(path)-length(mask)-1;
            while (path[i] <> '\') do dec(i);
            delete(path,i,length(path)-length(mask)-i);
          end;
        end
        else
        begin
          delete(dira[marked],length(dira[marked]),1);
          dira[marked] := '\' + dira[marked];
          insert(dira[marked],path,length(path)-length(mask));
        end;
    end
    else
      dirwin       := copy(path,1,length(path)-length(mask)) + dira[marked];
  end;
  if (marked < 1) or (dira[1] = 'No files!') then
    dirwin         := '<ESC>';
  until ende;
  if (length(path)-length(mask)) > 3 then
    chdir(copy(path,1,length(path)-length(mask)-1))
  else
    chdir(copy(path,1,length(path)-length(mask)));
  end
  else
    dirwin         := '<ESC>';
  p9;
end;


procedure p1(attr : byte);

begin
  if screen_init then save_screen(max_screen);
  save_textattr;
  textattr         := attr;
  rahmen(_inpwinsp-1,_inpwinz-1,_inpwinlen,1);
  gotoxy(_inpwinsp,_inpwinz);
end;


procedure message(s : string);

begin
  p1(messageattr);
  write (s);
  wait(4);
  p9;
end;


function frage_jn(s : string) : boolean;

begin
  p1(frageattr);
  if length(s) > (_inpwinlen-14) then delete(s,(_inpwinlen-14),255);
  write  (s + ' (J/N): ');
  repeat
    getkey;
  until (key in jn);

  if ja then
    writeln('Ja')
  else
    writeln('Nein');

  frage_jn         := ja;
  p9;
end;


procedure read_str(VAR s : string; l : integer; valid : range);

var
i, j, x, y         :  integer;

begin
  i                := length(s);
  x                := wherex;
  y                := wherey;
  gotoxy (x,y);
  write  (s);
  for j            := i + 1 to l do write  ('_');
  repeat
    repeat
      gotoxy (x + i,y);
      key          := readkey;
    until (key in terminator) or (key in valid) or (key = backspace);
    if ((key in valid) and (i < l)) then
    begin
      inc(i);
      s            := s + key;
      write  (key);
    end
    else
    begin
      if (key = backspace) and (i > 0) then
      begin
        dec(i);
        delete(s,length(s),1);
        gotoxy (x + i,y);
        write  ('_');
      end;
    end;
  until (key in terminator);
end;


function read_int(a : boolean;l : integer; i, min, max : longint) : longint;

var
j                  :  integer;
s                  :  string;

begin
  save_cursor;
  repeat
    if a then
      str(i, s)
    else
      s            := '';
    restore_cursor;
    read_str(s, l, vorzeichen + ziffern);
    val(s, i, j);
  until (j = 0) and ((i >= min) and (i <= max));
  read_int         := i;
end;


function read_real(a : boolean;l, d : integer; i, min, max : real) : real;

var
j                  :  integer;
s                  :  string;

begin
  save_cursor;
  repeat
    if a then
      str(i:0:d, s)
    else
      s            := '';
    restore_cursor;
    read_str(s, l, vorzeichen + punkt + ziffern + [',']);
    for j          := 1 to length(s) do
      if s[j] = ',' then s[j] := '.';
    val(s, i, j);
  until (j = 0) and ((i >= min) and (i <= max));
  read_real        := i;
end;


procedure p3(VAR msg : string;l : integer);

begin
  if (length(msg)+l) > 35 then delete(msg,35-l,255);
  write  (msg + ': ');
end;


procedure input_str(msg : string;VAR s : string; l : integer; valid : range);

begin
  p1(inputattr);
  p3(msg,l);
  read_str(s,l,valid);
  p9;
end;


function input_int(s : string;a : boolean;l : integer; i, min, max : longint) : longint;

begin
  p1(inputattr);
  p3(s,l);
  input_int        := read_int(a,l,i,min,max);
  p9;
end;


function input_real(s : string;a : boolean;l, d : integer; i, min, max : real) : real;

begin
  p1(inputattr);
  p3(s,l);
  input_real       := read_real(a,l,d,i,min,max);
  p9;
end;


function  int_to_str(i : longint; w : integer) : string;

var
s                  :  string;

begin
  str(i:w,s);
  int_to_str       := s;
end;



function  real_to_str(r : real; w,d : integer) : string;

var
s                  :  string;

begin
  str(r:w:d,s);
  real_to_str      := s;
end;


function int_from_str(z : string; von,len : integer) : longint;

var
i,j                :  integer;
r                  :  longint;
s                  :  string;

begin
  s                := copy(z,von,len);
  for i            := 1 to length(s) do
    if not (s[i] in (vorzeichen + ziffern)) then s[i] := '0';

  val(s,r,j);
  if j = 0 then
    int_from_str   := r
  else
    int_from_str   := 0;
end;


function real_from_str(z : string; von,len : integer) : real;

var
i,j                :  integer;
r                  :  real;
s                  :  string;
begin
  s                := copy(z,von,len);
  for i            := 1 to length(s) do
    if not (s[i] in (vorzeichen + ziffern + punkt)) then s[i] := '0';

  val(s,r,j);
  if j = 0 then
    real_from_str  := r
  else
    real_from_str  := 0.0;
end;


function int_from_cmdline(nr,von,bis : integer) : longint;

var
i,j                :  integer;
r                  :  longint;

begin
  val(paramstr(nr),r,i);
  if ((i <> 0) or (r < von) or (r > bis)) then
  begin
    writeln('Parameter ',paramstr(nr),' ungültig.');
    halt(nr);
  end;
  int_from_cmdline := r;
end;


function real_from_cmdline(nr : integer;von,bis : real) : real;

var
i                  :  integer;
r                  :  real;

begin
  val(paramstr(nr),r,i);
  if ((i <> 0) or (r < von) or (r > bis)) then
  begin
    writeln('Parameter ',paramstr(nr),' ungültig.');
    halt(nr);
  end;
  real_from_cmdline:= r;
end;


procedure init_screen( max : integer );

begin
  if screen_init then exit;
  if max > 6 then max := 6;
  for i            := 1 to max do
    new(screenbuffer[i]);

  screen_init      := true;
  max_screen       := max;
end;


(* Initialisierung der UNIT *)

begin
  _wherex          := 1;
  _wherey          := 1;
  mask             := '*.*';

  if (videomode = 7) then
    screenadr      := $B000;

  new(screen);
  screen           := ptr(screenadr,$0000);

  _dma             := (equipment and $0100) = $0100;
  _game            := (equipment and $1000) = $1000;
  _80x87           := (equipment and $0002) = $0002;
  anz_lpt          := hi(equipment) shr 6;
  anz_com          := hi(equipment) and $0F shr 1;
  if (equipment and $0001) = 1 then
    anz_fd         := lo(equipment) shr 6 + 1
  else
    anz_fd         := 0;

end.