Turbo Toolbox/Turbo_Toolbox.iso/1989/02/tricks/zahlensy.pas

Pascal/Delphi Source File | 1988-10-06 | 6.1 KB | 224 lines

(* ------------------------------------------------------ *)
(*                    ZAHLENSY.PAS                        *)
(*     Binär <-> Dezimal <-> Hexadezimal <-> Binär        *)
(*      (c) 1988 by Christian Ramsauer & TOOLBOX          *)
(* ------------------------------------------------------ *)
(*            Compiler: Turbo Pascal 3.0                  *)
(* ------------------------------------------------------ *)
PROGRAM Zahlensysteme;

TYPE Zahl = STRING[252];

VAR     ch: CHAR;
        i : INTEGER;

(* ------------------------------------------------------ *)
(*             Addition zweier Zahlenketten               *)

FUNCTION Summe(x, y: Zahl): Zahl;
VAR b       : zahl;
    i, z, u : INTEGER;
BEGIN
  b := '';
  u := 0;
  WHILE Length(x) > Length(y) DO y := '0'+ y;
  WHILE Length(x) < Length(y) DO x := '0'+ x;
  FOR i := Length(x) DOWNTO 1 DO BEGIN
    z := Ord(x[i]) + Ord(y[i]) - 96 + u;
    u := z DIV 10;
    b := Chr(48 + (z MOD 10)) + b;
  END;
  IF u = 1 THEN b := '1' + b;
  Summe := b;
END;

(* ------------------------------------------------------ *)
(*               Hexadezimal -> dezimal                   *)

FUNCTION hd(a: Zahl): zahl;
VAR b, z    : Zahl;
    j, p, i : INTEGER;
BEGIN
  z := '1';
  b := '';
  FOR i := Length(a) DOWNTO 1 DO BEGIN
    IF a[i] IN ['0'..'9'] THEN p := Ord(a[i]) - 48
                          ELSE p := Ord(a[i]) - 55;
    FOR j := 1 TO p DO b := Summe(b, z);
    FOR j := 1 TO 4 DO z := Summe(z, z);
  END;
  IF b = '' THEN hd := '0' ELSE hd := b;
END;

(* ------------------------------------------------------ *)
(*                   Dezimal -> Binär                     *)

FUNCTION db(a: Zahl): Zahl;
VAR b, c    : Zahl;
    u, i, z : INTEGER;
BEGIN
  b := '';
  REPEAT
    c := a;
    a := '';
    u := 0;
    FOR i := 1 TO Length(c) DO BEGIN
      z := Ord(c[i]) - 48 + (u*10);
      u := z MOD 2;
      z := z DIV 2;
      a := a + Chr(48 + z);
    END;
    IF a[1] = '0' THEN Delete(a, 1, 1);
    b := Chr(48 + u) + b;
  UNTIL Length(a) = 0;
  db := b;
END;

(* ------------------------------------------------------ *)
(*                Binär -> Hexadezimal                    *)

FUNCTION bh(a: Zahl): Zahl;
VAR   b       : zahl;
      z, i, u : INTEGER;
CONST bi      : ARRAY[1..4] OF INTEGER = (8,4,2,1);

BEGIN
  b := '';
  WHILE Length(a) MOD 4 <> 0 DO a := '0' + a;
  REPEAT
    z := 0;
    FOR i := 1 TO 4 DO
      z := z + ((Ord(a[i]) - 48) * bi[i]);
    Delete(a, 1, 4);
    IF z < 10 THEN b := b + Chr(48 + z)
              ELSE b := b + Chr(55 + z);
  UNTIL Length(a) = 0;
  bh := b;
END;

(* ------------------------------------------------------ *)
(*                Dezimal -> Hexadezimal                  *)

FUNCTION dh(a: Zahl): Zahl;
VAR b, c    : Zahl;
    u, i, z : INTEGER;
BEGIN
  b := '';
  REPEAT
    c := a;
    a := '';
    u := 0;
    FOR i := 1 TO Length(c) DO BEGIN
      z := Ord(c[i]) - 48 + (u*10);
      u := z MOD 16;
      z := z DIV 16;
      a := a + Chr(48 + z);
    END;
    IF a[i] = '0' THEN Delete(a, 1, 1);
    IF u < 10 THEN b := Chr(48 + u) + b
              ELSE b := Chr(55 + u) + b;
  UNTIL Length(a) = 0;
  dh := b;
END;

(* ------------------------------------------------------ *)
(*                Hexadezimal -> Binär                    *)

FUNCTION hb(a: Zahl): Zahl;
BEGIN
  hb := db(hd(a));
END;

(* ------------------------------------------------------ *)
(*                   Binär -> Dezimal                     *)

FUNCTION bd(a: Zahl): Zahl;
BEGIN
  bd := hd(bh(a));
END;

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

FUNCTION Eingabe(inp, outp: INTEGER): Zahl;
TYPE  Menge  = SET OF CHAR;
VAR   i, max : INTEGER;
      ch     : CHAR;
      m      : Menge;
      b      : Zahl;
CONST s      : ARRAY[1..3] OF STRING[20] =
                 ('binäre','dezimale','hexadezimale');
BEGIN
  b := '';
  CASE inp  OF 1: m := [#8,#13,'0','1'];
               2: m := [#8,#13,'0'..'9'];
               3: m := [#8,#13,'0'..'9','A'..'F'];
  END;
  CASE outp OF 1: IF inp = 3 THEN max := 63 ELSE max := 76;
               2: IF inp = 3 THEN
                    max := 209 ELSE max := 252;
               3: max := 252;
  END;
  WriteLn('Geben Sie bitte die ',s[inp],' Zahl ein: ');
  REPEAT
    REPEAT
      Read(kbd, ch);
    UNTIL ch in m;
    IF (ch = #8) AND (Length(b) > 0) THEN BEGIN
      IF WhereX = 1 THEN BEGIN
        GotoXY(80, WhereY - 1);
        Write(#32);
        GotoXY(80, WhereY - 1);
      END ELSE
        Write(#8, #32, #8);
      Delete(b, Length(b), 1);
    END;
    IF ([ch]*[#8,#13]=[]) AND (Length(b) < max) THEN BEGIN
      b := b + ch;
      Write(ch);
    END;
  UNTIL (ch = #13) AND (Length(b) > 0);
  Eingabe := b;
  WriteLn;
  Write('Die Zahl hat in ',s[outp]);
  WriteLn('r Schreibweise folgende Form: ');
END;

(* ------------------------------------------------------ *)
(*                   Hauptprogramm                        *)
BEGIN
  ClrScr;
  WriteLn;
  WriteLn('*** Umwandlung zwischen Zahlensystemen ***');
  WriteLn;
  WriteLn('Welche Umwandlung wollen Sie vornehmen ?');
  Write  ('Bin->Dez(1) Bin->Hex(2) Dez->Bin(3) ');
  WriteLn('Dez->Hex(4) Hex->Bin(5) Hex->Dez(6)');
  REPEAT
    Write('Geben Sie bitte die entsprechende Ziffer ein: ');
    REPEAT
      Read(kbd, ch);
    UNTIL ch in ['1'..'6'];
    WriteLn(ch);
    WriteLn;
    CASE ch OF '1': WriteLn(bd(Eingabe(1,2)));
               '2': WriteLn(bh(Eingabe(1,3)));
               '3': WriteLn(db(Eingabe(2,1)));
               '4': WriteLn(dh(Eingabe(2,3)));
               '5': WriteLn(hb(Eingabe(3,1)));
               '6': WriteLn(hd(Eingabe(3,2)));
    END;
    WriteLn('Wollen Sie eine weitere Umwandlung (J/N) ? ');
    Read(kbd, ch);
    FOR i := 20 DOWNTO 6 DO BEGIN
      GotoXY(1,i);
      DelLine;
    END;
  UNTIL ch in ['n','N'];
END.
(* ------------------------------------------------------ *)
(*                Ende von ZAHLENSY.PAS                   *)