unit rwptool;


interface

(*------------------------------------------------------------------------*)

uses crt,dos;


var ioFehler : integer;


function titxt(w:word):string;

function itxt(i:integer):string;

function litxt(li:longint):string;

function dtxt(d:double;stellen:integer):string;

function bittxt(w:word):string;

function hextxt(b:byte):string;

function string2real(s:string):double;

function fehlertext(fehlernummer:integer):string;

procedure pruefe_auf_fehler;

function bcd(n:byte):byte;

(* function delta(i,j:integer): double; *)

procedure x_writeln(var f:text; s:string);

function Datumstext:string;

function Uhrzeittext:string;

function Datumzeit:string;

function trytogetnumber(s:string):double;

function trytogetinteger(s:string):longint;

function ftaste(c:char) : integer;

implementation

(*------------------------------------------------------------------------*)

const
      fehleranzahl = 25;
      fnummer : array[1..fehleranzahl] of integer = (
                   2,3,4,5,6,12,15,100,102,103,104,106,150,151,152,153,154,
                   155,156,157,158,159,160,161,162);
      ftext   : array[0..fehleranzahl] of string[50] = (
                  'Unbekannter Fehler',
                  'Datei nicht gefunden',
                  'Pfad nicht gefunden',
                  'Zu viele Dateien ge”ffnet',
                  'Dateizugriff verweigert',
                  'Handle ung�ltig  /  Datei zerst”rt',
                  'Ung�ltiger Dateimodus',
                  'Laufwerksnummer unzul„ssig',
                  'Fehler beim Lesen der Datei',
                  'Datei-Variable ist keiner Datei zugeordnet',
                  'Datei ist nicht offen',
                  'Datei wurde nicht f�r Leseoperation ge”ffnet',
                  'Ung�ltiges Numerisches Format',
                  'Diskette ist schreibgesch�tzt',
                  'Peripherieger„t nicht bekannt',
                  'Laufwerk nicht betriebsbereit',
                  'Ung�ltiger DOS - Funktionscode',
                  'Pr�fsummenfehler beim Lesen von der Festplatte',
                  'Ung�ltiger Disk-Parameterblock',
                  'Kopf-Positionierungsfehler auf der Festplatte',
                  'Unbekanntes Sektorformat',
                  'Diskettensektor nicht lokalisierbar',
                  'Kein Papier im Drucker',
                  'Schreibfehler beim Zugriff auf ein Peripherieger„t',
                  'Lesefehler beim Zugriff auf ein Peripherieger„t',
                  'Nicht genau bestimmbarer Hardware-Fehler'
                  );

(*------------------------------------------------------------------------*)

procedure leer_weg(var s : string);
begin
 while s[1]=' ' do delete(s,1,1);
end;


function titxt(w:word):string;
var s : string;
begin
    str(w,s);
    if w<10 then titxt:='0'+s else titxt:=s;
end;

function itxt(i:integer):string;
var hilf : string;
begin
  str(i,hilf);
  leer_weg(hilf);
  itxt:=hilf;
end;

function litxt(li:longint):string;
var hilf : string;
begin
  str(li,hilf);
  leer_weg(hilf);
  litxt:=hilf;
end;

function dtxt(d:double;stellen:integer):string;
var s,t : string;
    p : integer;
    ord,i : integer;
begin
  if (abs(d)<1e-4) or (abs(d)>1e6) then begin
       str(d:(stellen+8),s);
       leer_weg(s);
       while s[pos('E',s)-1]='0' do   delete(s,pos('E',s)-1,1);
       if    s[pos('E',s)-1]='.' then delete(s,pos('E',s)-1,1);
       p:=pos('E',s);
       while (p+2<=length(s)) and (s[p+2]='0') do delete(s,p+2,1);
       if s[p+1]='+' then delete(s,p+1,1);
       if s[length(s)]='E' then delete(s,length(s),1);
       end
  else begin
       str(d:(stellen+8),s);
       p:=pos('E',s);
       val(copy(s,p+1,255),ord,i);
       stellen:=stellen-ord-1;
       if stellen<2 then stellen:=2;
       str(d:stellen:stellen,s);
       leer_weg(s);
       while s[length(s)]='0' do   delete(s,length(s),1);
       if    s[length(s)]='.' then delete(s,length(s),1);
       end;
  dtxt:=s;
end;

function bittxt(w:word):string;
var i : integer;
    s : string;
begin
    s:='';
    for i:=0 to 15 do
        if (w and (1 shl i) ) <>0 then s := '1' + s
                                  else s := '0' + s;
    bittxt:=s;
end;

const hexcode : array[0..15] of char =
      ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F' );

function hextxt(b:byte):string;
begin
    hextxt := hexcode[ b shr 4 ] + hexcode[ b and $F ];
end;


function string2real(s:string):double;
var c : integer;
    d : double;
begin
   repeat
     val(s,d,c);
     if c<>0 then delete(s,c,1);
   until (s='') or (c=0);
   if s='' then string2real:=0 else string2real:=d;
end;



(*------------------------------------------------------------------------*)

function fehlertext(fehlernummer:integer):string;
var i,fn : integer;
begin
     fn:=0;
     for i:=1 to fehleranzahl do if fnummer[i]=fehlernummer then fn:=i;
     fehlertext:=ftext[fn];
end;

procedure pruefe_auf_fehler;
var ch    : char;
begin
     IOFehler:=IOResult;
end;

procedure x_writeln(var f:text; s:string);
begin
  if iofehler=0 then begin
   {$I-}
   writeln(f,s);
   pruefe_auf_fehler;
   {$I-}
   end;
end;


function bcd(n:byte):byte;
begin
   bcd:=((n and $F0) shr 4)*10+(n and $0F);
end;

(*-------------------------------------------------------------------------*)

var h0,min0,sec0,hsec0  : word;
    year0,mon0,day0,dof : word;
    tmax                : double;
    altzeit             : double;

procedure timer_start(time:double);
begin
   gettime(h0,min0,sec0,hsec0);
   getdate(year0,mon0,day0,dof);
   tmax:=time;
   if tmax<0 then tmax:=0;
   if tmax>120 then tmax:=120;
   altzeit:=0;
end;

(*------------------------------------------------------------NEU----------*)

function stxt(w:word):string;
var s : string;
begin
   str(w,s);
   if w<10 then stxt:='0'+s else stxt:=s;
end;

const doftxt : array[1..7] of string[2] = (
               'MO','TU','WE','TH','FR','SA','SO' );

function Datumstext:string;
var da,mo,ye,dof:word;
begin
    getdate(ye,mo,da,dof);
    Datumstext:=doftxt[dof]+' '+stxt(da)+'.'+stxt(mo)+'.'+stxt(ye-1900);
end;

function Uhrzeittext:string;
var ho,mi,se,hs:word;
begin
    gettime(ho,mi,se,hs);
    Uhrzeittext:=stxt(ho)+':'+stxt(mi)+':'+stxt(se)+'.'+stxt(hs);
end;

function DatumZeit:string;
begin
    DatumZeit:=Datumstext+' '+Uhrzeittext;
end;

(*-------------------------------------------------------------------*)

(*-------------------------------------------------------------------*)

function trytogetnumber(s:string):double;
var d : double;
    c : integer;
begin
    if s<>'' then
       repeat
          val(s,d,c);
          if c<>0 then begin
             if c>length(s) then delete(s,length(s),1) else delete(s,c,1);
             end;
       until (c=0)or(s='');
    if s='' then trytogetnumber:=0 else trytogetnumber:=d;
end;


function trytogetinteger(s:string):longint;
var d : double;
begin
    d:=trytogetnumber(s);
         if d>65536  then trytogetinteger := 65536
    else if d<-32766 then trytogetinteger := -32766
    else trytogetinteger := round(d);
end;

(*-------------------------------------------------------------------*)

function ftaste(c:char):integer;
var f:integer;
begin
   case c of
        #59..#68  : ftaste:=ord(c)-58;
                    { F1 .. F10        ->  1 ..10   }
        #84..#93  : ftaste:=ord(c)-73;
                    { F11 .. F18 bzw.
                      shift F1 .. F10  ->  11..20   }
        #120..#129  : ftaste:=ord(c)-109;
                    { alt-1 .. 0       ->  11..20   } {wegen Olivetti..}
        #94..#103 : ftaste:=ord(c)-73;
                    { ctrl F1 .. F10   ->  21..30   }
        else
        ftaste:=0;
        end;

end;

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

procedure removespaces(var s:string);
var p : integer;
begin
   if length(s)>0 then p:=pos(' ',s) else p:=0;
   while (length(s)>0) and (p>0) do begin
         delete(s,p,1);
         p:=pos(' ',s);
         end;
end;

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

begin

end.