path: root/system/std.zusatz/1.7.3/src/longint

PACKET longint    DEFINES LONGINT,        (* Autoren: S.Baumann,A.Bentrup *)
                          :=,             (*          T.Sillke *)
                          <,              (* Stand:   17.03.81 *)
                          >, 
                          <=,
                          >=,
                          <>,
                          =,
                          -,
                          +,
                          *,
                          **,
                          ABS,
                          abs,
                          DECR,
                          DIV,
                          get,
                          INCR,
                          int,
                        (*last rest,*)
                          longint,
                          max,
                          max longint,
                          min,
                          MOD,
                          put,
                          random,
                          SIGN,
                          sign,
                          text,
                          zero:
 
TYPE LONGINT = TEXT;
 
LONGINT VAR   result,aleft,aright;
TEXT    VAR   ergebnis,x,y,z,h;
INT     VAR   v byte,slr,sll;
INT     CONST snull    :: code("0"), mtl :: 300 ;
TEXT    CONST negativ  :: code(127),max digit :: code(99),null :: code(0),
              overflow :: "LONGINT overflow",eins :: code(1); 
BOOL    VAR   vorl,vorr,vleft,vright;

OP := (LONGINT VAR left, LONGINT CONST right) :
   CONCR(left) := CONCR(right)
END OP :=;
 
BOOL OP <  (LONGINT CONST left,right) :
   slr := sign(right)*length(right);
   sll := sign(left )*length(left );
   IF slr <> sll THEN
      IF slr > sll THEN TRUE ELSE FALSE FI
   ELSE IF slr>0
        THEN CONCR(left) < CONCR(right)
        ELSE CONCR(left) > CONCR(right) FI
   FI
END  OP < ;
 
BOOL OP >  (LONGINT CONST left,right) :
   slr := sign(right)*length(right);
   sll := sign(left )*length(left );
   IF slr <> sll THEN
      IF slr < sll THEN TRUE ELSE FALSE FI
   ELSE IF slr>0
        THEN CONCR(left) > CONCR(right)
        ELSE CONCR(left) < CONCR(right) FI
   FI
END  OP > ;
 
BOOL OP <= (LONGINT CONST left,right) :
   NOT (left > right)
END  OP <=;
 
BOOL OP >= (LONGINT CONST left,right) :
   NOT (left < right)
END  OP >=;
 
BOOL OP <> (LONGINT CONST left,right) :
   CONCR (left) <> CONCR (right)
END OP  <>;
 
BOOL OP =  (LONGINT CONST left,right) :
   CONCR (left) =  CONCR (right)
END  OP = ;
 
LONGINT OP - (LONGINT CONST arg) : 
   SELECT  code(CONCR(arg)SUB1)  OF
     CASE 0  : zero
     CASE 127: LONGINT : (subtext(CONCR(arg),2))
     OTHERWISE LONGINT : (negativ + CONCR(arg))
   END SELECT
END OP -;
 
LONGINT OP + (LONGINT CONST arg) :   arg  END OP +;
 
LONGINT OP - (LONGINT CONST left,right) :
   IF   CONCR(left ) = null       THEN LEAVE - WITH -right
   ELIF CONCR(right) = null       THEN LEAVE - WITH   left
   ELIF sign(left) <> sign(right) THEN LEAVE - WITH left + (-right) FI;
   betrag(left,right);
   BOOL CONST betrag max :: aleft > aright;
   IF   betrag max
        THEN result := LONGINT : (CONCR(aleft ) SUB CONCR(aright))
        ELSE result := LONGINT : (CONCR(aright) SUB CONCR(aleft )) FI;
        kuerze fuehrende nullen(CONCR(result),null);
   IF   vleft  XOR  betrag max  THEN -result ELSE result FI
END OP -;
 
LONGINT OP + (LONGINT CONST left,right) :
   IF   sign(left) <> sign(right) THEN LEAVE + WITH left - (-right) FI;
   betrag(left,right);
   IF aleft > aright
      THEN result := LONGINT : (CONCR(aleft ) ADD CONCR(aright))
      ELSE result := LONGINT : (CONCR(aright) ADD CONCR(aleft )) FI;
   IF vleft THEN result ELSE -result FI
END OP +;
 
LONGINT OP * (LONGINT CONST left,right) :
   IF   CONCR(left) = null OR CONCR(right) = null THEN LEAVE * WITH zero
   ELIF length(left) + length(right) > mtl THEN errorstop (overflow) FI;
   betrag(left,right);
   IF   aleft < aright 
        THEN result := LONGINT : (CONCR(aright) MUL CONCR(aleft ))
        ELSE result := LONGINT : (CONCR(aleft ) MUL CONCR(aright))  FI;
   IF   length(CONCR(result)) = mtl  THEN errorstop(overflow) FI;
   IF   vleft XOR vright THEN -result ELSE result FI
END OP *;
 
LONGINT OP ** (LONGINT CONST arg,exp) :
   IF exp > longint(max int) THEN errorstop (overflow) FI;
   arg ** int(exp)
END OP **;
 
LONGINT OP ** (LONGINT CONST arg,INT CONST exp) :
   IF   exp < 0 THEN errorstop ("LONGINT OP ** : negativ exp")
   ELIF CONCR(arg)=null AND exp=0 THEN errorstop(text(0 ** 0)) FI;
   IF   exp = 0  THEN one
   ELIF exp = 1  THEN arg
   ELIF sign(arg) = -1 AND exp MOD 2 <> 0
        THEN -LONGINT:(CONCR(abs(arg))EXPexp) 
        ELSE  LONGINT:(CONCR(abs(arg))EXPexp) FI
END OP **; 
 
LONGINT OP ABS (LONGINT CONST arg) : abs(arg) END OP ABS;
 
LONGINT PROC abs (LONGINT CONST a) : 
 IF (CONCR(a)SUB1)=negativ THEN LONGINT:(subtext(CONCR(a),2)) ELSE a FI
END PROC abs;
 
OP DECR (LONGINT VAR result,LONGINT CONST ab) :
   result := result - ab;
END OP DECR;
 
LONGINT OP DIV (LONGINT CONST left,right) :
   IF CONCR(right) = null THEN error stop("LONGINT OP DIV by zero") FI;
   betrag(left,right);        h    := CONCR(aright);
   y := null + CONCR(aleft ); vorl := vleft;
   z := null + CONCR(aright); vorr := vright;
   IF aleft < aright THEN y:=CONCR(aleft); LEAVE DIV WITH zero FI;
   INT  VAR try,i,cr1 :: code(z SUB 2),cr2,cr3,zw;
   BOOL VAR sh :: length(z) <> 2;
   IF sh THEN cr3:=code(zSUB3); cr2:=10*cr1+cr3DIV10; cr3:=100*cr1+cr3 FI;
   CONCR(result) := "";
   FOR i FROM 0 UPTO length(y)-length(z) REP
      laufe eine abschaetzung durch; 
      CONCR (result) CAT code(try)
   PER;  kuerze fuehrende nullen(y,null);
   IF(CONCR(result)SUB1)=nullTHEN CONCR(result):=subtext(CONCR(result),2)FI;
   IF vleft XOR vright THEN -result ELSE result FI.
 
   laufe eine abschaetzung durch :
      zw := 100*code(y SUB i+1) + code(y SUB i+2);
      IF zw < 3276 AND sh THEN IF zw < 327
      THEN try := min((100*zw + code(ySUBi+3))     DIV cr3, 99)
      ELSE try := min(( 10*zw + code(ySUBi+3)DIV10)DIV cr2, 99) FI
      ELSE try := min(     zw                      DIV cr1, 99) FI;
       x := z MUL code(try); 
      WHILE x > subtext(y,i+1,i+length(x)) REP
            try DECR 1;   x := x SUB z     PER;
      replace(y,i + 1,subtext(y,i + 1,i + length(x)) SUB x) 
END OP DIV;
 
PROC get (LONGINT VAR result) : 
   get (ergebnis);
   result := longint(ergebnis);
END PROC get;
 
PROC get (FILE VAR file,LONGINT VAR result) :
   get(file,ergebnis);
   result := longint(ergebnis);
END PROC get;
 
OP INCR (LONGINT VAR result,LONGINT CONST dazu) : 
   result := result + dazu;
END OP INCR;
 
INT PROC int (LONGINT CONST longint) :
   IF length(longint) > 3 
      THEN max int + 1
      ELSE ergebnis := (3-length(longint))*null + CONCR(abs(longint));
           (code(ergebnis SUB 1)  * 10000 +
            code(ergebnis SUB 2)  * 100   +
            code(ergebnis SUB 3)) * sign(longint)
   FI
END PROC int;
 
LONGINT PROC longint (INT CONST int) :
   CONCR(result) :=  code( abs(int)            DIV 10000) +
                     code((abs(int) MOD 10000) DIV 100)   +
                     code( abs(int) MOD 100);
   kuerze fuehrende nullen (CONCR(result),null);
   IF int < 1 THEN -result ELSE result FI
END PROC longint;
 
LONGINT PROC longint (TEXT CONST text) :
   INT  VAR i;
   ergebnis := compress(text);
   BOOL VAR minus :: (ergebnisSUB1) = "-"; 
   IF (ergebnisSUB1)="+" OR minus THEN ergebnis:=subtext(ergebnis,2) FI;
   kuerze fuehrende nullen(ergebnis,"0");
   kuerze die unzulaessigen zeichen aus ergebnis;
   schreibe ergebnis im hundertersystem in result;
   result mit vorzeichen.

   kuerze die unzulaessigen zeichen aus ergebnis :
      ergebnis := subtext(ergebnis,1,letztes zulaessiges zeichen).
   letztes zulaessiges zeichen :
      FOR i FROM 1 UPTO length(ergebnis) REP 
      UNTIL pos("0123456789", ergebnis SUB i) = 0 PER;
      i - 1.
   schreibe ergebnis im hundertersystem in result :
      sll := length(ergebnis);
      IF sll MOD 2 <> 0 THEN ergebnis := "0"+ergebnis; sll INCR 1 FI; 
      i := 1; CONCR(result) := "";
      REP schreibe ein zeichen im hundertersystem in result;
          i INCR 2
      UNTIL i >= sll PER.
   schreibe ein zeichen im hundertersystem in result :
      CONCR(result) CAT code((code(ergebnis SUB i    ) - snull) * 10 +
                              code(ergebnis SUB i + 1) - snull).
   result mit vorzeichen : 
      IF ergebnis="" THEN zero ELIF minus THEN -result ELSE result FI
END PROC longint;
 
LONGINT PROC max (LONGINT CONST left,right) :
   IF left > right THEN left ELSE right FI
END PROC max;
 
LONGINT PROC max longint :
   LONGINT : ((mtl - 1) * max digit)
END PROC max longint;
 
LONGINT PROC min (LONGINT CONST left,right) :
   IF left < right THEN left ELSE right FI
END PROC min;
 
LONGINT OP MOD (LONGINT CONST left,right) :
   IF CONCR(right) = null THEN errorstop("LONGINT OP MOD by zero") FI;
   result := left DIV right; last rest 
END OP MOD;
 
PROC put (LONGINT CONST longint) :
   INT  VAR i :: 1,zwei ziffern;
   IF sign(longint) = -1 THEN out("-"); i:=2 FI;
   out(text(code(CONCR(longint) SUB i)));
   FOR i FROM i + 1 UPTO length(CONCR(longint)) REP
       zwei ziffern := code(CONCR(longint) SUB i);
       out(code(zwei ziffern DIV 10 + snull));
       out(code(zwei ziffern MOD 10 + snull));
   PER;out(" ")
END PROC put;
 
PROC put (FILE VAR file,LONGINT CONST longint) :
   put(file,text(longint));
END PROC put;
 
LONGINT PROC random (LONGINT CONST lower bound,upper bound) :
   INT VAR i; x := CONCR(upper bound - lower bound - one); y := "";
   FOR i FROM 1 UPTO length(x) REP y CAT code(random(0,99)) PER;
   upper bound - (LONGINT : (y) MOD LONGINT : (x)) 
END PROC random;
 
INT OP SIGN (LONGINT CONST arg) : sign(arg) END OP SIGN;
 
INT PROC sign (LONGINT CONST arg) :
   SELECT code(CONCR(arg) SUB 1) OF
      CASE 0   :  0
      CASE 127 : -1
      OTHERWISE   1
   END SELECT
END PROC sign;
 
TEXT PROC text (LONGINT CONST longint) :
   INT  VAR i::1,zwei ziffern; ergebnis := "";
   IF sign(longint) = -1 THEN ergebnis := "-"; i:=2  FI;
   ergebnis CAT text (code (CONCR (longint) SUB i ) ) ;
   FOR i FROM i+1 UPTO length(CONCR(longint)) REP
      zwei ziffern := code(CONCR(longint) SUB i);
      ergebnis CAT code(zwei ziffern DIV 10 + snull);
      ergebnis CAT code(zwei ziffern MOD 10 + snull) 
   PER;   ergebnis
END PROC text;
 
TEXT PROC text (LONGINT CONST longint,INT CONST length) :
   x := text(longint); sll := LENGTH x;
   IF sll > length THEN length * "*" ELSE (length - sll)*" " + x FI
END PROC text; 

LONGINT PROC last rest :
  IF y=null THEN LEAVE last rest WITH zero FI; 
  IF vorl XOR vorr THEN y := h SUB y; kuerze fuehrende nullen(y,null);
                        vorl := TRUE FI;
  IF NOTvorr THEN y:=negativ+y; vorr := TRUE FI; LONGINT:(y) 
END PROC last rest;
 
LONGINT PROC zero :   LONGINT : (null)   END PROC zero;
LONGINT PROC one  :   LONGINT : (""1"")  END PROC one;
 
 
(* ----------------------- INTERNE HILFSPROZEDUREN ----------------------- *)
 
TEXT OP ADD (TEXT CONST left,right) :
   INT  VAR   carrybit :: 0,i,dif :: length(left) - length(right);
   ergebnis := left; 
   FOR i FROM length(left) DOWNTO dif + 1 REP
      replace(ergebnis,i,das result der addition)
   PER;
   IF carrybit = 1 THEN addiere den uebertrag  FI; 
   ergebnis.
 
   das result der addition :
      v byte := (code(left SUB i) + code(right SUB i - dif) + carrybit);
      IF v byte > 99 
         THEN carrybit := 1; code(v byte - 100)
         ELSE carrybit := 0; code(v byte)
      FI. 
   addiere den uebertrag :
      FOR i FROM i DOWNTO 1
          WHILE (ergebnis SUB i) >= max digit REP
          replace(ergebnis,i,null) 
      PER;
      IF (ergebnis SUB 1) = null  OR  dif = 0
         THEN pruefe auf longint overflow 
         ELSE replace(ergebnis,i,code(code(ergebnis SUB i) + 1))
      FI.
   pruefe auf longint overflow :
      IF length(ergebnis) = mtl - 1 THEN errorstop(overflow) FI;
      ergebnis := eins + ergebnis
END OP ADD;
 
PROC betrag (LONGINT CONST a, b) :
   vleft := (CONCR(a)SUB1)<>negativ; vright := (CONCR(b)SUB1)<>negativ;
   IF vleft  THEN aleft :=a ELSE CONCR(aleft ):=subtext(CONCR(a),2) FI;
   IF vright THEN aright:=b ELSE CONCR(aright):=subtext(CONCR(b),2) FI
END PROC betrag;

TEXT OP EXP (TEXT CONST arg,INT CONST exp) :
   INT VAR zaehler :: exp;
   x := arg; z := eins;
   REP  IF zaehler MOD 2 = 1 THEN z := z MUL x FI; 
        zaehler := zaehler DIV 2; x := x MUL x 
   UNTIL zaehler = 1 PER;
    x MUL z 
END OP EXP;
 
PROC kuerze fuehrende nullen ( TEXT VAR text,TEXT CONST snull) :
   INT VAR i;
   text := subtext(text,erste nicht snull).
 
   erste nicht snull :
   FOR i FROM 1 UPTO length (text) - 1 REP
   UNTIL (text SUB i) <> snull PER;
   i
END PROC kuerze fuehrende nullen;
 
INT PROC length (LONGINT CONST a) : 
  IF (CONCR(a)SUB1)=negativ THEN length(CONCR(a))-1 ELSE length(CONCR(a)) FI
END PROC length;
 
TEXT OP MUL (TEXT CONST left,right) :
   INT VAR i,j,carrybit,v,w;
   ergebnis := (length(left) + length(right) - 1) * null;
   FOR i FROM length(ergebnis) DOWNTO length(left) REP
       v := i - length(left); w := length(right) - length(ergebnis) + i;
       carrybit := 0;
      FOR j FROM length(left) DOWNTO 1 REP
            replace(ergebnis,v + j,result der addition)
      PER;
       replace(ergebnis,v,code(code(ergebnis SUB v) + carrybit));
   PER;
   IF carrybit = 0 THEN ergebnis ELSE code(carrybit) + ergebnis FI.

   result der addition :
      v byte := code(right    SUB w) * code(left SUB j) + carrybit +
                code(ergebnis SUB v + j);
      carrybit := v byte DIV 100;
      code(v byte MOD 100)
END OP MUL;
 
TEXT OP SUB (TEXT CONST left,right) : 
   INT  VAR   carrybit :: 0,i,dif :: length(left) - length(right);
   ergebnis := left;
   FOR i FROM length(left) DOWNTO dif + 1 REP 
       replace(ergebnis,i,das result der subtraktion);
   PER;
   IF carrybit = 1 THEN subtrahiere den uebertrag FI;
   ergebnis.
 
   das result der subtraktion :
      v byte := (code(left SUB i) - code(right SUB i - dif) - carrybit);
      IF v byte < 0 
         THEN carrybit := 1;code(v byte + 100)
         ELSE carrybit := 0;code(v byte)
      FI.
   subtrahiere den uebertrag :
      FOR i FROM i DOWNTO 2 
          WHILE (ergebnis SUB i) = null REP
          replace(ergebnis,i,max digit)
      PER;
      replace(ergebnis,i,code(code(ergebnis SUB i) - 1))
END OP SUB;
 
END PACKET longint;