stdlib/private/show.ajla

   1 {*
   2  * Copyright (C) 2024 Mikulas Patocka
   3  *
   4  * This file is part of Ajla.
   5  *
   6  * Ajla is free software: you can redistribute it and/or modify it under the
   7  * terms of the GNU General Public License as published by the Free Software
   8  * Foundation, either version 3 of the License, or (at your option) any later
   9  * version.
  10  *
  11  * Ajla is distributed in the hope that it will be useful, but WITHOUT ANY
  12  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  13  * A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License along with
  16  * Ajla. If not, see <https://www.gnu.org/licenses/>.
  17  *}
  18
  19 private unit private.show;
  20
  21 fn integer_to_bytes_base(n : int, b : int) : bytes;
  22 fn integer_to_bytes(n : int) : bytes;
  23 fn bytes_to_integer_base(a : bytes, b : int) : int;
  24 fn bytes_to_integer(a : bytes) : int;
  25
  26 fn real_to_bytes_base_precision(t : type, c : class_real_number(t), n : t, b : int, digits : int) : bytes;
  27 fn real_to_bytes(t : type, c : class_real_number(t), n : t) : bytes;
  28 fn bytes_to_real_base(t : type, implicit c : class_real_number(t), a : bytes, b : int) : t;
  29 fn bytes_to_real_hex(t : type, implicit c : class_real_number(t), a : bytes) : t;
  30 fn bytes_to_real(t : type, c : class_real_number(t), a : bytes) : t;
  31
  32 fn real_to_rational(t : type, implicit c : class_real_number(t), n : t) : rational;
  33 fn rational_to_real(t : type, implicit c : class_real_number(t), a : rational) : t;
  34
  35 implementation
  36
  37 uses exception;
  38
  39 fn byte_to_num(c : byte, b : int) : int
  40 [
  41         var v : int;
  42         if c >= #30 and c < #3a then
  43                 v := c - #30;
  44         else if c >= #41 and c < #5b then
  45                 v := c - #41 + 10;
  46         else if c >= #61 and c < #7b then
  47                 v := c - #61 + 10;
  48         else [
  49 exc:
  50                 abort exception_make(int, ec_sync, error_invalid_operation, 0, true);
  51         ]
  52         if v >= b then
  53                 goto exc;
  54         return v;
  55 ]
  56
  57 fn integer_to_bytes_base(n : int, b : int) : bytes
  58 [
  59         if b < 2 or b > 36 then
  60                 abort exception_make(bytes, ec_sync, error_invalid_operation, 0, true);
  61
  62         if n < 0 then
  63                 return "-" + integer_to_bytes_base(-n, b);
  64
  65         var result := empty(byte);
  66
  67         if (b and b - 1) = 0 then [
  68                 if n = 0 then
  69                         return "0";
  70
  71                 var bb := bsf b;
  72                 var pos := bsr n;
  73                 if (bb and bb - 1) = 0 then
  74                         pos and= not bb - 1;
  75                 else
  76                         pos -= pos mod bb;
  77
  78                 while pos >= 0 do [
  79                         var c := 0;
  80                         for i := 0 to bb do
  81                                 if n bt pos + i then
  82                                         c bts= i;
  83                         if c < 10 then
  84                                 c += #30;
  85                         else
  86                                 c += #41 - 10;
  87                         result +<= c;
  88                         pos -= bb;
  89                 ]
  90
  91                 return result;
  92         ]
  93
  94         var q := 1;
  95         while q * b <= n do
  96                 q *= b;
  97
  98         while q > 0 do [
  99                 var c := n div q;
 100                 n mod= q;
 101                 q div= b;
 102                 if c < 10 then
 103                         c += #30;
 104                 else
 105                         c += #41 - 10;
 106                 result +<= c;
 107         ]
 108
 109         return result;
 110 ]
 111
 112 fn integer_to_bytes(n : int) : bytes
 113 [
 114         return integer_to_bytes_base~inline(n, 10);
 115 ]
 116
 117 fn bytes_to_integer_base(a : bytes, b : int) : int
 118 [
 119         if b < 2 or b > 36 then [
 120 exc:
 121                 abort exception_make(bytes, ec_sync, error_invalid_operation, 0, true);
 122         ]
 123         var sign := 1;
 124         if len_greater_than(a, 0) and a[0] = '-' then [
 125                 sign := -1;
 126                 a := a[1 .. ];
 127         ] else if len_greater_than(a, 0) and a[0] = '+' then [
 128                 a := a[1 .. ];
 129         ]
 130         if not len_greater_than(a, 0) then
 131                 goto exc;
 132         var result := 0;
 133         for i := 0 to len(a) do [
 134                 var c := a[i];
 135                 var v := byte_to_num(c, b);
 136                 result := result * b + v;
 137         ]
 138         return result * sign;
 139 ]
 140
 141 fn bytes_to_integer(a : bytes) : int
 142 [
 143         return bytes_to_integer_base~inline(a, 10);
 144 ]
 145
 146
 147 fn real_to_bytes_base_precision(t : type, implicit c : class_real_number(t), n : t, b : int, digits : int) : bytes
 148 [
 149         if b < 2 or b > 36 or digits < 0 then
 150                 abort exception_make(bytes, ec_sync, error_invalid_operation, 0, true);
 151         var result := "";
 152         if is_negative n then [
 153                 result +<= '-';
 154                 n := -n;
 155         ]
 156         if is_infinity n then [
 157                 result += "inf";
 158                 return result;
 159         ]
 160         var inx : int := n;
 161         n -= inx;
 162         var frac := 0;
 163         for i := 0 to digits do [
 164                 n *= b;
 165                 var inn : int := n;
 166                 frac := frac * b + inn;
 167                 n -= inn;
 168         ]
 169         if n >= 0.5 then [
 170                 frac += 1;
 171                 var imul := ipower(b, digits);
 172                 if frac >= imul then [
 173                         frac -= imul;
 174                         inx += 1;
 175                 ]
 176         ]
 177         var fracstr : bytes;
 178         if digits > 0 then
 179                 fracstr := integer_to_bytes_base(frac, b);
 180         else
 181                 fracstr := "";
 182         if len(fracstr) < digits then
 183                 fracstr := fill(byte, '0', digits - len(fracstr)) + fracstr;
 184         result += integer_to_bytes_base(inx, b);
 185         result +<= '.';
 186         result += fracstr;
 187         return result;
 188 ]
 189
 190 fn real_to_bytes(t : type, implicit c : class_real_number(t), n : t) : bytes
 191 [
 192         return real_to_bytes_base_precision~inline(t, c, n, 10, 10);
 193 ]
 194
 195 fn bytes_to_real_base(t : type, implicit c : class_real_number(t), a : bytes, b : int) : t
 196 [
 197         if b < 2 or b > 36 then
 198                 abort exception_make(bytes, ec_sync, error_invalid_operation, 0, true);
 199         var r : t;
 200         var negative := false;
 201         if len_greater_than(a, 0), a[0] = '-' then [
 202                 a := a[1 .. ];
 203                 negative := true;
 204         ] else if len_greater_than(a, 0), a[0] = '+' then [
 205                 a := a[1 .. ];
 206         ]
 207         if a = "inf" then [
 208                 r := 1. / 0.;
 209                 goto ret;
 210         ]
 211
 212         var ex := select(b > 10, 'E', 'P');
 213         var ex_pos := list_search(a, ex);
 214         if ex_pos = -1 then
 215                 ex_pos := list_search(a, ex + #20);
 216         var e := 0;
 217         if ex_pos <> -1 then [
 218                 e := bytes_to_integer(a[ex_pos + 1 .. ]);
 219                 a := a[ .. ex_pos];
 220         ]
 221
 222         var before_dot after_dot : bytes;
 223         var dot := list_search(a, '.');
 224         if dot = -1 then [
 225                 before_dot := a;
 226                 after_dot := "";
 227         ] else [
 228                 before_dot := a[ .. dot];
 229                 after_dot := a[dot + 1 .. ];
 230         ]
 231
 232         if e > 0 then [
 233                 if e > len(after_dot) then [
 234                         after_dot += fill(byte, '0', e - len(after_dot));
 235                 ]
 236                 var t := after_dot[ .. e];
 237                 before_dot += t;
 238                 after_dot := after_dot[e .. ];
 239         ] else if e < 0 then [
 240                 e := -e;
 241                 if e > len(before_dot) then [
 242                         before_dot := fill(byte, '0', e - len(before_dot)) + before_dot;
 243                 ]
 244                 var t := before_dot[len(before_dot) - e .. ];
 245                 after_dot := t + after_dot;
 246                 before_dot := before_dot[ .. len(before_dot) - e];
 247         ]
 248
 249         //eval debug("before_dot: '" + before_dot + "', after_dot: '" + after_dot + "'");
 250         r := 0;
 251         while len(before_dot) > 0 do [
 252                 var d : t := byte_to_num(before_dot[0], b);
 253                 r := r * b + d;
 254                 before_dot := before_dot[1 .. ];
 255         ]
 256         var digits := c.one;
 257         while len(after_dot) > 0 do [
 258                 var d : t := byte_to_num(after_dot[0], b);
 259                 r := r + d * digits / b;
 260                 digits /= b;
 261                 after_dot := after_dot[1 .. ];
 262         ]
 263
 264 ret:
 265         if negative then
 266                 r := -r;
 267         return r;
 268 ]
 269
 270 fn bytes_to_real_hex(t : type, implicit c : class_real_number(t), a : bytes) : t
 271 [
 272         var b := empty(byte);
 273         for i := 0 to len(a) do [
 274                 if a[i] = 'p' or a[i] = 'P' then [
 275                         b +<= 'e';
 276                         b += a[i + 1 .. ];
 277                         break;
 278                 ]
 279                 if a[i] = '.' then [
 280                         b +<= '.';
 281                         continue;
 282                 ]
 283                 var str := [ a[i] ];
 284                 var bin := ntos_base(ston_base(str, 16), 2);
 285                 b += fill(byte, '0', 4 - len(bin));
 286                 b += bin;
 287         ]
 288         //eval debug("bytes_to_real_hex: " + a + " -> " + b + ".");
 289         return bytes_to_real_base(t, c, b, 2);
 290 ]
 291
 292 fn bytes_to_real(t : type, implicit c : class_real_number(t), a : bytes) : t
 293 [
 294         return bytes_to_real_base(t, c, a, 10);
 295 ]
 296
 297 fn real_to_rational(t : type, implicit c : class_real_number(t), n : t) : rational
 298 [
 299         if is_infinity n then [
 300                 if not is_negative n then [
 301                         return instance_real_number_rational.from_int(1) / instance_real_number_rational.from_int(0);
 302                 ] else [
 303                         return instance_real_number_rational.from_int(-1) / instance_real_number_rational.from_int(0);
 304                 ]
 305         ]
 306         var den := 1;
 307         if n = 0, is_negative n then
 308                 den := -1;
 309
 310         if fract(n) = 0 then
 311                 return instance_real_number_rational.from_int(n) / instance_real_number_rational.from_int(den);
 312
 313         var bit := 0;
 314         var q := 1 shl bit;
 315         while true do [
 316                 var nn := ldexp(n, q);
 317                 if fract(nn) = 0 then
 318                         break;
 319                 bit += 1;
 320                 q shl= 1;
 321         ]
 322         while bit > 0 do [
 323                 bit -= 1;
 324                 var qq := q - (1 shl bit);
 325                 var nn := ldexp(n, qq);
 326                 if fract(nn) = 0 then
 327                         q := qq;
 328         ]
 329         var num := ldexp(n, q);
 330         den *= (1 shl q);
 331         return instance_real_number_rational.from_int(num) / instance_real_number_rational.from_int(den);
 332 ]
 333
 334 fn int_to_real(t : type, implicit c : class_real_number(t), i : int) : (t, int)
 335 [
 336         var num := c.from_int(i);
 337         if not is_infinity num then
 338                 return num, 0;
 339
 340         var bit := 0;
 341         var q := 1 shl bit;
 342         while true do [
 343                 num := c.from_int(i shr q);
 344                 if not is_infinity num then
 345                         break;
 346                 bit += 1;
 347                 q shl= 1;
 348         ]
 349         while bit > 0 do [
 350                 bit -= 1;
 351                 var qq := q - (1 shl bit);
 352                 num := c.from_int(i shr qq);
 353                 if not is_infinity num then
 354                         q := qq;
 355         ]
 356
 357         num := c.from_int(i shr q);
 358         return num, q;
 359 ]
 360
 361 fn rational_to_real(t : type, implicit c : class_real_number(t), a : rational) : t
 362 [
 363         var num := a.num;
 364         var den := a.den;
 365         var num_t, adj_p := int_to_real(t, c, num);
 366         var den_t, adj_m := int_to_real(t, c, den);
 367         var adj := adj_p - adj_m;
 368         //return num_t / den_t * ldexp(c.one, adj);
 369         return ldexp(num_t / den_t, adj);
 370 ]