Data commit

Task/Arithmetic-Rational/ALGOL-68/arithmetic-rational.alg

@@ -0,0 +1,131 @@
+ MODE FRAC = STRUCT( INT num #erator#,  den #ominator#);
+ FORMAT frac repr = $g(-0)"//"g(-0)$;
+
+ PROC gcd = (INT a, b) INT: # greatest common divisor #
+   (a = 0 | b |: b = 0 | a |: ABS a > ABS b  | gcd(b, a MOD b) | gcd(a, b MOD a));
+
+ PROC lcm = (INT a, b)INT: # least common multiple #
+   a OVER gcd(a, b) * b;
+
+ PROC raise not implemented error = ([]STRING args)VOID: (
+   put(stand error, ("Not implemented error: ",args, newline));
+   stop
+ );
+
+ PRIO // = 9; # higher then the ** operator #
+ OP // = (INT num, den)FRAC: ( # initialise and normalise #
+   INT common = gcd(num, den);
+   IF den < 0 THEN
+     ( -num OVER common, -den OVER common)
+   ELSE
+     ( num OVER common, den OVER common)
+   FI
+ );
+
+ OP + = (FRAC a, b)FRAC: (
+   INT common = lcm(den OF a, den OF b);
+   FRAC result := ( common OVER den OF a * num OF a + common OVER den OF b * num OF b, common );
+   num OF result//den OF result
+ );
+
+ OP - = (FRAC a, b)FRAC: a + -b,
+    * = (FRAC a, b)FRAC: (
+   INT num = num OF a * num OF b,
+       den = den OF a * den OF b;
+   INT common = gcd(num, den);
+   (num OVER common) // (den OVER common)
+ );
+
+ OP /  = (FRAC a, b)FRAC: a * FRAC(den OF b, num OF b),# real division #
+    %  = (FRAC a, b)INT: ENTIER (a / b),               # integer divison #
+    %* = (FRAC a, b)FRAC: a/b - FRACINIT ENTIER (a/b), # modulo division #
+    ** = (FRAC a, INT exponent)FRAC:
+     IF exponent >= 0 THEN
+       (num OF a ** exponent, den OF a ** exponent )
+     ELSE
+       (den OF a ** exponent, num OF a ** exponent )
+     FI;
+
+ OP REALINIT = (FRAC frac)REAL: num OF frac / den OF frac,
+    FRACINIT = (INT num)FRAC: num // 1,
+    FRACINIT = (REAL num)FRAC: (
+      # express real number as a fraction # # a future execise! #
+      raise not implemented error(("Convert a REAL to a FRAC","!"));
+      SKIP
+    );
+
+ OP <  = (FRAC a, b)BOOL: num OF (a - b) <  0,
+    >  = (FRAC a, b)BOOL: num OF (a - b) >  0,
+    <= = (FRAC a, b)BOOL: NOT ( a > b ),
+    >= = (FRAC a, b)BOOL: NOT ( a < b ),
+    =  = (FRAC a, b)BOOL: (num OF a, den OF a) = (num OF b, den OF b),
+    /= = (FRAC a, b)BOOL: (num OF a, den OF a) /= (num OF b, den OF b);
+
+ # Unary operators #
+ OP - = (FRAC frac)FRAC: (-num OF frac, den OF frac),
+    ABS = (FRAC frac)FRAC: (ABS num OF frac, ABS den OF frac),
+    ENTIER = (FRAC frac)INT: (num OF frac OVER den OF frac) * den OF frac;
+
+ COMMENT Operators for extended characters set, and increment/decrement:
+ OP +:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a + b ),
+    +=: = (FRAC a, REF FRAC b)REF FRAC: ( b := a + b ),
+    -:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a - b ),
+    *:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a * b ),
+    /:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a / b ),
+    %:= = (REF FRAC a, FRAC b)REF FRAC: ( a := FRACINIT (a % b) ),
+    %*:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a %* b );
+
+ # OP aliases for extended character sets (eg: Unicode, APL, ALCOR and GOST 10859) #
+ OP ×  = (FRAC a, b)FRAC: a * b,
+    ÷  = (FRAC a, b)INT: a OVER b,
+    ÷× = (FRAC a, b)FRAC: a MOD b,
+    ÷* = (FRAC a, b)FRAC: a MOD b,
+    %× = (FRAC a, b)FRAC: a MOD b,
+    ≤  = (FRAC a, b)FRAC: a <= b,
+    ≥  = (FRAC a, b)FRAC: a >= b,
+    ≠  = (FRAC a, b)BOOL: a /= b,
+    ↑  = (FRAC frac, INT exponent)FRAC: frac ** exponent,
+
+    ÷×:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a MOD b ),
+    %×:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a MOD b ),
+    ÷*:= = (REF FRAC a, FRAC b)REF FRAC: ( a := a MOD b );
+
+ # BOLD aliases for CPU that only support uppercase for 6-bit bytes  - wrist watches #
+ OP OVER = (FRAC a, b)INT: a % b,
+    MOD = (FRAC a, b)FRAC: a %*b,
+    LT = (FRAC a, b)BOOL: a <  b,
+    GT = (FRAC a, b)BOOL: a >  b,
+    LE = (FRAC a, b)BOOL: a <= b,
+    GE = (FRAC a, b)BOOL: a >= b,
+    EQ = (FRAC a, b)BOOL: a =  b,
+    NE = (FRAC a, b)BOOL: a /= b,
+    UP = (FRAC frac, INT exponent)FRAC: frac**exponent;
+
+ # the required standard assignment operators #
+ OP PLUSAB  = (REF FRAC a, FRAC b)REF FRAC: ( a +:= b ), # PLUS #
+    PLUSTO  = (FRAC a, REF FRAC b)REF FRAC: ( a +=: b ), # PRUS #
+    MINUSAB = (REF FRAC a, FRAC b)REF FRAC: ( a *:= b ),
+    DIVAB   = (REF FRAC a, FRAC b)REF FRAC: ( a /:= b ),
+    OVERAB  = (REF FRAC a, FRAC b)REF FRAC: ( a %:= b ),
+    MODAB   = (REF FRAC a, FRAC b)REF FRAC: ( a %*:= b );
+
+END COMMENT
+Example: searching for Perfect Numbers.
+ FRAC sum:= FRACINIT 0;
+ FORMAT perfect = $b(" perfect!","")$;
+
+ FOR i FROM 2 TO 2**19 DO
+   INT candidate := i;
+   FRAC sum := 1 // candidate;
+   REAL real sum := 1 / candidate;
+   FOR factor FROM 2 TO ENTIER sqrt(candidate) DO
+     IF candidate MOD factor = 0 THEN
+       sum :=  sum + 1 // factor + 1 // ( candidate OVER factor);
+       real sum +:= 1 / factor + 1 / ( candidate OVER factor)
+     FI
+   OD;
+   IF den OF sum  = 1 THEN
+     printf(($"Sum of reciprocal factors of "g(-0)" = "g(-0)" exactly, about "g(0,real width) f(perfect)l$,
+             candidate, ENTIER sum, real sum, ENTIER sum = 1))
+   FI
+ OD