home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 04 / tricks / rechnen.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-01-10  |  10.9 KB  |  396 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      RECHNEN.PAS                       *)
  3. (*  Die 4 Grundrechenarten bis zu einer Genauigkeit von   *)
  4. (*                  maximal 250 Ziffern                   *)
  5. (*         (c) 1989 Christian Ramsauer  &  TOOLBOX        *)
  6. (* ------------------------------------------------------ *)
  7. PROGRAM Rechnen;
  8.  
  9. TYPE  Operat = STRING[255];
  10.  
  11. VAR  a, b, c : Operat;
  12.      ch      : CHAR;
  13.      i       : INTEGER;
  14.  
  15. FUNCTION Komma(VAR s, t : Operat) : INTEGER;
  16. BEGIN
  17.   IF Pos('.', s) = 0 THEN s := s + '.';
  18.   IF Pos('.', t) = 0 THEN t := t + '.';
  19.   WHILE (Length(s) - Pos('.', s)) <
  20.         (Length(t) - Pos('.', t)) DO s := s + '0';
  21.   WHILE (Length(s) - Pos('.', s)) >
  22.         (Length(t) - Pos('.', t)) DO t := t + '0';
  23.   WHILE Length(s) > Length(t) DO t := '0' + t;
  24.   WHILE Length(s) < Length(t) DO s := '0' + s;
  25.   IF s[Length(s)] = '.' THEN Delete(s, Length(s), 1);
  26.   IF t[Length(t)] = '.' THEN Delete(t, Length(t), 1);
  27.   IF (Pos('.', s) > 0) THEN BEGIN
  28.     Komma := Length(s) - 1 - Pos('.', s);
  29.     Delete(s, Pos('.', s), 1);
  30.     Delete(t, Pos('.', t), 1);
  31.   END ELSE Komma := 0;
  32. END;
  33.  
  34. PROCEDURE Korrektur(VAR x: Operat);
  35. BEGIN
  36.   WHILE (x[1] = '0') AND (x[2] <> '.') AND
  37.         (Length(x)>1) DO Delete(x, 1, 1);
  38.   WHILE (x[Length(x)] IN ['0', '.']) AND (Pos('.', x) > 0)
  39.         AND (Length(x) > 1) DO Delete(x, Length(x), 1);
  40. END;
  41.  
  42. FUNCTION Add0(x, y : Operat) : Operat;
  43. VAR  b       : Operat;
  44.      i, u, z : INTEGER;
  45. BEGIN
  46.   u := 0;
  47.   b := '';
  48.   FOR i := 1 TO Length(x) - Length(y) DO y := '0' + y;
  49.   FOR i := 1 TO Length(y) - Length(x) DO x := '0' + x;
  50.   FOR i := Length(x) DOWNTO 1 DO BEGIN
  51.     z := Ord(x[i]) + Ord(y[i]) - 96 + u;
  52.     u := z DIV 10;
  53.     b := Chr(48 + (z MOD 10)) + b;
  54.   END;
  55.   IF u = 1 THEN b := '1' + b;
  56.   Korrektur(b);
  57.   Add0 := b;
  58. END;
  59.  
  60. FUNCTION Add1(x, y : Operat) : Operat;
  61. VAR  b   : Operat;
  62.      kom : INTEGER;
  63. BEGIN
  64.   kom := Komma(x, y);
  65.   b := Add0(x, y);
  66.   IF kom <> 0 THEN Insert('.', b, Length(b) - kom);
  67.   IF b[1] = '.' THEN b := '0' + b;
  68.   Korrektur(b);
  69.   Add1 := b;
  70. END;
  71.  
  72. FUNCTION Sub0(x, y : Operat) : Operat;
  73. VAR b       : Operat;
  74.     i, u, z : INTEGER;
  75. BEGIN
  76.   b := '';
  77.   u := 0;
  78.   FOR i := 1 TO Length(x) - Length(y) DO y := '0' + y;
  79.   FOR i := 1 TO Length(y) - Length(x) DO x := '0' + x;
  80.   FOR i := Length(x) DOWNTO 1 DO BEGIN
  81.     IF Ord(x[i]) >= (Ord(y[i]) + u) THEN BEGIN
  82.       z := Ord(x[i]) - Ord(y[i]) - u;
  83.       u := 0;
  84.     END ELSE BEGIN
  85.       z := Ord(x[i]) - Ord(y[i]) + 10 - u;
  86.       u := 1;
  87.     END;
  88.     b := Chr(48 + z) + b;
  89.   END;
  90.   Korrektur(b);
  91.   Sub0 := b;
  92. END;
  93.  
  94. FUNCTION Sub1(x, y : Operat) : Operat;
  95. VAR b            : Operat;
  96.     kom, i, u, z : INTEGER;
  97. BEGIN
  98.   kom := Komma(x, y);
  99.   b := Sub0(x, y);
  100.   IF (kom <> 0) AND (Length(b) >= kom) THEN
  101.     Insert('.', b, Length(b) - kom);
  102.   IF b[1] = '.' THEN b := '0' + b;
  103.   Korrektur(b);
  104.   Sub1 := b;
  105. END;
  106.  
  107. FUNCTION Mul1(x, y : Operat) : Operat;
  108. VAR  b ,z                 : Operat;
  109.      kommax, kommay, i, j : INTEGER;
  110. BEGIN
  111.   IF Pos('.', x) <> 0 THEN kommax := Length(x) - Pos('.', x)
  112.                       ELSE kommax := 0;
  113.   IF Pos('.', y) <> 0 THEN kommay := Length(y) - Pos('.', y)
  114.                       ELSE kommay := 0;
  115.   Delete(x, Pos('.', x), 1);
  116.   Delete(y, Pos('.', y), 1);
  117.   b := '0';
  118.   FOR i := 1 TO Length(x) DO BEGIN
  119.     z := '0';
  120.     FOR j := 1 TO Ord(x[i]) - 48 DO z := Add0(z, y);
  121.     FOR j := 1 TO Length(x) - i  DO z := z + '0';
  122.     b := Add0(b, z);
  123.   END;
  124.   IF kommax + kommay > 0 THEN BEGIN
  125.     FOR j := 1 TO 250 - Length(b) DO b := '0' + b;
  126.     Insert('.', b, Length(b) + 1 - kommax - kommay);
  127.   END;
  128.   Korrektur(b);
  129.   Mul1 := b;
  130. END;
  131.  
  132. FUNCTION kl(x, y : Operat) : BOOLEAN;
  133. VAR  kx, ky, i : INTEGER;
  134. BEGIN
  135.   WHILE (x[1] = '0') AND (Length(x) > 1) DO Delete(x, 1, 1);
  136.   WHILE (y[1] = '0') AND (Length(y) > 1) DO Delete(y, 1, 1);
  137.   IF Pos('.', x) = 0 THEN x := x + '.';
  138.   IF Pos('.', y) = 0 THEN y := y + '.';
  139.   kx := Length(x) - Pos('.', x);
  140.   ky := Length(y) - Pos('.', y);
  141.   FOR i := 1 TO kx - ky DO y := y + '0';
  142.   FOR i := 1 TO ky - kx DO x := x + '0';
  143.   IF Length(x) < Length(y) THEN kl := TRUE;
  144.   IF Length(x) > Length(y) THEN kl := FALSE;
  145.   IF Length(x) = Length(y) THEN
  146.     IF x < y THEN kl := TRUE ELSE kl := FALSE;
  147. END;
  148.  
  149. FUNCTION Div1(x, y : Operat; g : INTEGER) : Operat;
  150. VAR  b, xx, z, yy      : Operat;
  151.      kommax, kommay, i : INTEGER;
  152.      fertig, first     : BOOLEAN;
  153. BEGIN
  154.   IF Pos('.', x) <> 0 THEN kommax := Length(x) - Pos('.', x)
  155.                       ELSE kommax := 0;
  156.   IF Pos('.', y) <> 0 THEN kommay := Length(y) - Pos('.', y)
  157.                       ELSE kommay := 0;
  158.   FOR i := 1 TO kommax - kommay DO y := y + '0';
  159.   FOR i := 1 TO kommay - kommax DO x := x + '0';
  160.   Delete(x, Pos('.', x), 1);
  161.   Delete(y, Pos('.', y), 1);
  162.   xx := '';
  163.   b := '';
  164.   first := TRUE;
  165.   REPEAT
  166.     fertig := FALSE;
  167.     IF Length(x) > 0 THEN BEGIN
  168.       xx := xx + Copy(x, 1, 1);
  169.       Delete(x, 1, 1);
  170.     END ELSE BEGIN
  171.       IF first THEN BEGIN
  172.         first := FALSE;
  173.         b := b + '.';
  174.       END;
  175.       xx := xx + '0';
  176.     END;
  177.     IF kl(xx, y) THEN b := b + '0'
  178.     ELSE BEGIN
  179.       i := 0;
  180.       REPEAT
  181.         i := i + 1;
  182.       UNTIL (kl(xx, Mul1(Chr(i + 48), y))) OR (i = 10);
  183.       b := b + Chr(47 + i);
  184.       xx := Sub0(xx, Mul1(Chr(47 + i), y));
  185.       fertig := TRUE;
  186.       FOR i := 1 TO Length(xx) DO
  187.         IF xx[i] <> '0' THEN fertig := FALSE;
  188.     END;
  189.     IF (b[1] = '0') AND (b[2] <> '.') THEN Delete(b, 1, 1);
  190.   UNTIL (Length(b) > g) OR fertig;
  191.   IF b[1] = '.' THEN b := '0' + b;
  192.   Div1 := b;
  193. END;
  194.  
  195. FUNCTION Neg(VAR xy : Operat) : BOOLEAN;
  196. BEGIN
  197.   IF xy[1] = '-' THEN Neg := TRUE ELSE Neg := FALSE;
  198.   IF (xy[1] = '-') OR (xy[1] = '+') THEN Delete(xy, 1, 1);
  199. END;
  200.  
  201. FUNCTION Groesse(x, y : Operat) : BOOLEAN;
  202. VAR  x1, x2, y1, y2 : INTEGER;
  203. BEGIN
  204.   IF Pos('.', x) > 0 THEN BEGIN
  205.     x1 := Pos('.', x) - 1;
  206.     x2 := Length(x) - 1 - x1;
  207.   END ELSE BEGIN
  208.     x1 := Length(x);
  209.     x2 := 0;
  210.   END;
  211.   IF Pos('.', y) > 0 THEN BEGIN
  212.     y1 := Pos('.', y) - 1;
  213.     y2 := Length(y) - 1 - y1;
  214.   END ELSE BEGIN
  215.     y1 := Length(y);
  216.     y2 := 0;
  217.   END;
  218.   IF (x1 + y2 > 250) OR (y1 + x2 > 250) THEN
  219.     Groesse := FALSE
  220.   ELSE Groesse := TRUE;
  221. END;
  222.  
  223. FUNCTION Addition(x, y : Operat) : Operat;
  224. VAR  b    : Operat;
  225.      null : BOOLEAN;
  226. BEGIN
  227.   Korrektur(x);
  228.   Korrektur(y);
  229.   IF NOT Groesse(x, y) THEN BEGIN
  230.     Addition := 'Ergebnis übersteigt die Kapazität!';
  231.     Exit;
  232.   END;
  233.   CASE Neg(x) OF
  234.     TRUE:  CASE Neg(y) OF
  235.              TRUE :  b := '-' + Add1(x, y);
  236.              FALSE: IF kl(y, x) THEN b := '-' + Sub1(x, y)
  237.                                 ELSE b := Sub1(y, x);
  238.            END;
  239.     FALSE: CASE Neg(y) OF
  240.              TRUE : IF kl(y, x) THEN b := Sub1(x, y)
  241.                                 ELSE b := '-' + Sub1(y, x);
  242.              FALSE: b := Add1(x,y);
  243.            END;
  244.   END;
  245.   null := TRUE;
  246.   FOR i := 1 TO Length(b) DO
  247.     IF b[i] IN ['1'..'9'] THEN null := FALSE;
  248.   IF null THEN b := '0';
  249.   Addition := b;
  250. END;
  251.  
  252. FUNCTION Subtraktion(x, y : Operat) : Operat;
  253. VAR  b    : Operat;
  254.      null : BOOLEAN;
  255. BEGIN
  256.   Korrektur(x);
  257.   Korrektur(y);
  258.   IF NOT Groesse(x, y) THEN BEGIN
  259.     Subtraktion := 'Ergebnis übersteigt die Kapazität!';
  260.     Exit;
  261.   END;
  262.   CASE Neg(x) OF
  263.     TRUE:  CASE Neg(y) OF
  264.              TRUE : IF kl(x, y) THEN b := Sub1(y, x)
  265.                                 ELSE b := '-' + Sub1(x, y);
  266.              FALSE: b := '-' + Add1(x, y);
  267.            END;
  268.     FALSE: CASE Neg(y) OF
  269.              TRUE : b := Add1(x, y);
  270.              FALSE: IF kl(y, x) THEN b := Sub1(x, y)
  271.                                 ELSE b := '-' + Sub1(y, x);
  272.            END;
  273.   END;
  274.   null := TRUE;
  275.   FOR i := 1 TO Length(b) DO
  276.     IF b[i] IN ['1'..'9'] THEN null := FALSE;
  277.   IF null THEN b := '0';
  278.   Subtraktion := b;
  279. END;
  280.  
  281. FUNCTION Multiplikation(x, y : Operat) : Operat;
  282. VAR  b    : Operat;
  283.      null : BOOLEAN;
  284.      i    : INTEGER;
  285. BEGIN
  286.   Korrektur(x);
  287.   Korrektur(y);
  288.   IF Length(x) + Length(y) <= 250 THEN BEGIN
  289.     IF Neg(x) = Neg(y) THEN b := Mul1(x, y)
  290.                        ELSE b := '-' + Mul1(x, y);
  291.     null := TRUE;
  292.     FOR i := 1 TO Length(b) DO
  293.       IF b[i] IN ['1'..'9'] THEN null := FALSE;
  294.     IF null THEN b := '0';
  295.   END ELSE b := 'Ergebnis übersteigt die Kapazität!';
  296.   Multiplikation := b;
  297. END;
  298.  
  299. FUNCTION Division(x, y : Operat) : Operat;
  300. CONST stell = 20;
  301. VAR  b            : Operat;
  302.      null, d_null : BOOLEAN;
  303.      maximum, i   : INTEGER;
  304. BEGIN
  305.   IF Length(x) > Length(y) THEN maximum := Length(x)
  306.                            ELSE maximum := Length(y);
  307.   IF maximum < stell THEN maximum := stell;
  308.   Korrektur(x);
  309.   Korrektur(y);
  310.   IF x = '0' THEN null := TRUE ELSE null := FALSE;
  311.   IF y = '0' THEN d_null := TRUE ELSE d_null := FALSE;
  312.   IF d_null THEN b := 'Division durch Null!'
  313.     ELSE IF null THEN b := '0'
  314.       ELSE IF Neg(x) = Neg(y) THEN b := Div1(x, y, maximum)
  315.         ELSE b := '-' + Div1(x, y, maximum);
  316.   Division := b;
  317. END;
  318.  
  319. FUNCTION Zahl : Operat;
  320. VAR  b     : Operat;
  321.      ch    : CHAR;
  322.      i     : INTEGER;
  323.      punkt : BOOLEAN;
  324. BEGIN
  325.   i := 0;
  326.   punkt := FALSE;
  327.   b := '';
  328.   REPEAT
  329.     REPEAT
  330.       Read(KBD,ch)
  331.     UNTIL ch IN ['0'..'9','.','+','-',#8,#13];
  332.     CASE ch OF
  333.       '0'..'9': IF i < 251 THEN BEGIN
  334.                   i := i + 1;
  335.                   b := b + ch;
  336.                   Write(ch);
  337.                 END;
  338.       '.': IF (i < 251) AND (b[Length(b)] IN ['0'..'9'])
  339.            AND NOT punkt THEN BEGIN
  340.              i := i + 1;
  341.              b := b + ch;
  342.              Write(ch);
  343.              punkt := TRUE;
  344.            END;
  345.       '+','-': IF i = 0 THEN BEGIN
  346.                  i := i + 1;
  347.                  b := b + ch;
  348.                  Write(ch);
  349.                END;
  350.       #8: IF i > 0 THEN BEGIN
  351.             i := i - 1;
  352.             IF b[Length(b)] = '.' THEN punkt := FALSE;
  353.             Delete(b, Length(b), 1);
  354.             IF WhereX = 1 THEN BEGIN
  355.               GotoXY(80, WhereY - 1);
  356.               Write(#32);
  357.               GotoXY(80, WhereY - 1);
  358.             END ELSE Write(#8, #32, #8);
  359.           END;
  360.     END;
  361.   UNTIL (ch = #13) AND (i > 0);
  362.   Zahl := b;
  363.   WriteLn;
  364. END;
  365.  
  366. BEGIN
  367.   REPEAT
  368.     ClrScr;
  369.     WriteLn('**** Genaue Grundrechenarten ****');
  370.     WriteLn;
  371.     Write('Operand 1: ');
  372.     a := Zahl;
  373.     Write('Rechenart: ');
  374.     REPEAT
  375.       Read(KBD,ch)
  376.     UNTIL ch IN ['+','-','*','/'];
  377.     WriteLn(ch);
  378.     Write('Operant 2: ');
  379.     b := Zahl;
  380.     WriteLn('           =');
  381.     CASE ch OF
  382.      '+': c := Addition(a,b);
  383.      '-': c := Subtraktion(a,b);
  384.      '*': c := Multiplikation(a,b);
  385.      '/': c := Division(a,b);
  386.     END;
  387.     Write('Ergebnis:  ');
  388.     WriteLn(c);
  389.     WriteLn;
  390.     Write('Weitermachen (J/N) ?');
  391.     Read(KBD,ch);
  392.   UNTIL ch IN ['n','N'];
  393. END.
  394. (* ------------------------------------------------------ *)
  395. (*                  Ende von RECHNEN.PAS                  *)
  396.