home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / SysProg / ConsoleToolDemo.p < prev    next >
Encoding:
Text File  |  1994-07-23  |  3.6 KB  |  157 lines
  1. { MAXONPascal3-Anpassung / Test:  Falk Zühlsdorff (PackMAN) 1994 }
  2.  
  3. Program ConsoleToolDemo;
  4.  
  5. Const
  6.   Length = 80;
  7.  
  8. Type
  9.   String80 = String[80];
  10.  
  11. Var
  12.   Win: Ptr;
  13.   Con: Ptr;
  14.   St: String[80];
  15.   z: Long;
  16.  
  17.  Procedure WriteConInt(Con: ptr;    { Devicehandle }
  18.                        i: Long;     { Zahl, die ausgegeben werden soll }
  19.                        b: integer;  { Basis }
  20.                        f: integer); { Mindest-Feldbreite }
  21.  Var
  22.   s: String[40];
  23.   j,k,z,len: integer;
  24.   i2: Long;
  25.  Begin
  26.   j:=40;
  27.   s[40]:=chr(0);    { Nullbyte am Ende }
  28.   i2:=abs(i);
  29.   Repeat
  30.     j:= j-1;
  31.     z:= i2 mod b;   { letzte Ziffer von i2 }
  32.     If z<10 Then
  33.       s[j]:=chr(z+ord('0'))     { Ziffern 0 bis 10 }
  34.     Else
  35.       s[j]:=chr(z-10+ord('A')); { Hexziffern A bis F }
  36.     i2:= i2 Div b;
  37.   Until i2=0;
  38.   If b=16 Then
  39.     Begin
  40.       j:=j-1;
  41.       s[j]:='$'     { Hexzahlen automatisch mit "$" }
  42.     End;
  43.   If b=2 Then
  44.     Begin
  45.       j:=j-1;
  46.       s[j]:='%'     { Binärzahlen mit "%" }
  47.     End;
  48.   If i<0 Then
  49.     Begin
  50.       j:=j-1;
  51.       s[j]:='-'     { Minuszeichen bei neg. Zahlen }
  52.     End;
  53.   len:=40-j;        { Gesamtlänge der Zahl }
  54.   For k:=1 to f-len Do
  55.     WriteCon(Con, ' ');     { Am Anfang mit Spaces auffüllen }
  56.   WriteCon(Con, Str(^s[j])) { String ab j-tem Zeichen ausgeben }
  57.  End;
  58.  
  59.  Procedure ReadConString(Con:Ptr; Var s: String80);
  60.    Const
  61.      Backspace = chr(8);
  62.      Return = chr(13);
  63.    Var
  64.      ch: Char;
  65.      i: integer;
  66.      Sig: Long;
  67.    Begin
  68.      i:=1;
  69.      Repeat
  70.        Sig:=Wait(-1);
  71.        ch:=ReadCon(Con);
  72.        If ( (ch >= chr(32)) and (ch < chr(127)) ) or (ch>=chr(160)) Then
  73.          Begin
  74.            WriteCon(Con,ch);
  75.            s[i]:=ch;
  76.            i:=i+1
  77.          End;
  78.        If (ch=BackSpace) and (i>1) Then
  79.          Begin
  80.            WriteCon(Con,''\8' '\8);  { Ein Zeichen zurück, mit Space
  81.                                        überschreiben und wieder zurück }
  82.            i:=i-1
  83.          End;
  84.      Until (ch=Return) or (i>=79);
  85.      s[i]:=chr(0);    { mit Space abschließen }
  86.    End;
  87.  
  88.  Function Convert(s: String80): Long;
  89.  Var
  90.    i:Long;
  91.    j, b, z, sign: integer;
  92.  Begin
  93.    i:= 0;
  94.    b:= 10;  { Basis }
  95.    j:= 1;   { Stringanfang }
  96.    While s[j]=' ' Do
  97.      j:=j+1;           { führende Spaces überlesen }
  98.    If s[j]='-' Then
  99.      Begin   { negatives Vorzeichen }
  100.        sign:= -1;
  101.        j:=j+1
  102.      End
  103.    Else
  104.      Begin
  105.        sign:= 1;
  106.        If s[j]='+' Then j:=j+1   { Pluszeichen überlesen }
  107.      End;
  108.    If s[j] = '$' Then   { Hexzahl }
  109.      Begin
  110.        b:=16; j:=j+1
  111.      End;
  112.    If s[j] = '%' Then   { Binärzahl }
  113.      Begin
  114.        b:=2; j:=j+1
  115.      End;
  116.    Repeat
  117.      If (s[j] >= '0') and (s[j] <= '9') Then
  118.        z := ord(s[j]) - ord('0')
  119.      Else
  120.      If (s[j] >= 'a') and (s[j] <= 'z') Then
  121.        z := ord(s[j]) - ord('a') + 10
  122.      Else
  123.      If (s[j] >= 'A') and (s[j] <= 'Z') Then
  124.        z := ord(s[j]) - ord('A') + 10
  125.      Else
  126.        z:= -1;  { ungültige Ziffer }
  127.      If z >= b Then
  128.        z:= -1;  { zu groß für Basis }
  129.      If z >= 0 Then
  130.        i:= b*i + z;
  131.      j:= j+1
  132.    Until z<0;
  133.    Convert:= sign*i
  134.  End;
  135.  
  136.  
  137. Begin
  138.   Win := Open_Window(0,0,640,200,1,0,$1006,'Test',Nil,640,200,640,200);
  139.   Con := OpenConsole(Win);
  140.   Repeat
  141.     WriteCon(Con, 'Eingabe: ');
  142.     ReadConString(Con, St);
  143.     If St <> '' Then
  144.       Begin
  145.         z:=Convert(St);
  146.         WriteCon(Con,''\n\n); { eine Leerzeile }
  147.         WriteConInt(Con, z, 10, 12); { dezimal, rechtsbündig }
  148.         WriteConInt(Con, z, 16, 12);
  149.         WriteCon(Con,'  ');
  150.         WriteConInt(Con, z,  2,  1); { binär und linksbündig }
  151.         WriteCon(Con, ''\n\n)
  152.       End
  153.   Until St='';        { bei Leerzeile beenden }
  154.   CloseConsole(Con);
  155.   Close_Window(Win)
  156. End.
  157.