File : ffa_calc.adb
1 ------------------------------------------------------------------------------
2 ------------------------------------------------------------------------------
3 -- This file is part of 'Finite Field Arithmetic', aka 'FFA'. --
4 -- --
5 -- (C) 2019 Stanislav Datskovskiy ( www.loper-os.org ) --
6 -- http://wot.deedbot.org/17215D118B7239507FAFED98B98228A001ABFFC7.html --
7 -- --
8 -- You do not have, nor can you ever acquire the right to use, copy or --
9 -- distribute this software ; Should you use this software for any purpose, --
10 -- or copy and distribute it to anyone or in any manner, you are breaking --
11 -- the laws of whatever soi-disant jurisdiction, and you promise to --
12 -- continue doing so for the indefinite future. In any case, please --
13 -- always : read and understand any software ; verify any PGP signatures --
14 -- that you use - for any purpose. --
15 -- --
16 -- See also http://trilema.com/2015/a-new-software-licensing-paradigm . --
17 ------------------------------------------------------------------------------
18 ------------------------------------------------------------------------------
19
20 -- Basics
21 with Version; use Version;
22 with OS; use OS;
23 with CmdLine; use CmdLine;
24
25 -- FFA
26 with FFA; use FFA;
27
28 -- For the intrinsic equality operator on Words
29 use type FFA.Word;
30
31 -- For RNG:
32 with FFA_RNG; use FFA_RNG;
33
34
35 procedure FFA_Calc is
36
37 Width : Positive; -- Desired FFA Width
38 Height : Positive; -- Desired Height of Stack
39 RNG : RNG_Device; -- The active RNG device.
40
41 begin
42 if Arg_Count < 3 or Arg_Count > 4 then
43 Eggog("Usage: ./ffa_calc WIDTH HEIGHT [/dev/rng]");
44 end if;
45
46 declare
47 Arg1 : CmdLineArg;
48 Arg2 : CmdLineArg;
49 begin
50 -- Get commandline args:
51 Get_Argument(1, Arg1); -- First arg
52 Get_Argument(2, Arg2); -- Second arg
53
54 if Arg_Count = 4 then
55 -- RNG was specified:
56 declare
57 Arg3 : CmdLineArg;
58 begin
59 Get_Argument(3, Arg3); -- Third arg (optional)
60
61 -- Ada.Sequential_IO chokes on paths with trailing whitespace!
62 -- So we have to give it a trimmed path. But we can't use
63 -- Ada.Strings.Fixed.Trim, because it suffers from
64 -- SecondaryStackism-syphilis. Instead we are stuck doing this:
65 Init_RNG(RNG, Arg3(Arg3'First .. Len_Arg(3)));
66 end;
67 else
68 -- RNG was NOT specified:
69 Init_RNG(RNG); -- Use the machine default then
70 end if;
71
72 -- Parse into Positives:
73 Width := Positive'Value(Arg1);
74 Height := Positive'Value(Arg2);
75 exception
76 when others =>
77 Eggog("Invalid arguments!");
78 end;
79
80 -- Test if proposed Width is permissible:
81 if not FFA_FZ_Valid_Bitness_P(Width) then
82 Eggog("Invalid Width: " & FFA_Validity_Rule_Doc);
83 end if;
84
85 -- The Calculator itself:
86 declare
87
88 -- The number of Words required to make a FZ of the given Bitness.
89 Wordness : Indices := Indices(Width / Bitness);
90
91 --------------------------------------------------------
92 -- State --
93 --------------------------------------------------------
94 -- The Stack:
95 subtype Stack_Positions is Natural range 0 .. Height;
96 type Stacks is array(Stack_Positions range <>) of FZ(1 .. Wordness);
97 Stack : Stacks(Stack_Positions'Range);
98
99 -- Stack Pointer:
100 SP : Stack_Positions := Stack_Positions'First;
101
102 -- Carry/Borrow Flag:
103 Flag : WBool := 0;
104
105 -- Odometer:
106 Pos : Natural := 0;
107
108 -- The current levels of the three types of nestedness:
109 QuoteLevel : Natural := 0;
110 CommLevel : Natural := 0;
111 CondLevel : Natural := 0;
112
113 -- Prefixed Operators
114 PrevC : Character := ' ';
115 HavePrefix : Boolean := False;
116
117 --------------------------------------------------------
118
119
120 -- Clear the stack and set SP to bottom.
121 procedure Zap is
122 begin
123 -- Clear the stack
124 for i in Stack'Range loop
125 FFA_FZ_Clear(Stack(i));
126 end loop;
127 -- Set SP to bottom
128 SP := Stack_Positions'First;
129 -- Clear Overflow flag
130 Flag := 0;
131 -- Clear prefix
132 HavePrefix := False;
133 PrevC := ' ';
134 end Zap;
135
136
137 -- Report a fatal error condition at the current symbol
138 procedure E(S : in String) is
139 begin
140 Eggog("Pos:" & Natural'Image(Pos) & ": " & S);
141 end E;
142
143
144 -- Move SP up
145 procedure Push is
146 begin
147 if SP = Stack_Positions'Last then
148 E("Stack Overflow!");
149 else
150 SP := SP + 1;
151 end if;
152 end Push;
153
154
155 -- Discard the top of the stack
156 procedure Drop is
157 begin
158 FFA_FZ_Clear(Stack(SP));
159 SP := SP - 1;
160 end Drop;
161
162
163 -- Check if stack has the necessary N items
164 procedure Want(N : in Positive) is
165 begin
166 if SP < N then
167 E("Stack Underflow!");
168 end if;
169 end Want;
170
171
172 -- Ensure that a divisor is not zero
173 procedure MustNotZero(D : in FZ) is
174 begin
175 if FFA_FZ_ZeroP(D) = 1 then
176 E("Division by Zero!");
177 end if;
178 end MustNotZero;
179
180
181 -- Slide a new hex digit into the FZ on top of stack
182 procedure Ins_Hex_Digit(Digit : in Nibble) is
183 Overflow : WBool := 0;
184 begin
185
186 -- Insert the given nibble, and detect any overflow:
187 FFA_FZ_Insert_Bottom_Nibble(N => Stack(SP),
188 D => Digit,
189 Overflow => Overflow);
190
191 -- Constants which exceed the Width are forbidden:
192 if Overflow = 1 then
193 E("Constant Exceeds Bitness!");
194 end if;
195
196 end;
197
198
199 -- Emit an ASCII representation of N to the terminal
200 procedure Print_FZ(N : in FZ) is
201 S : String(1 .. FFA_FZ_ASCII_Length(N)); -- Mandatorily, exact size
202 begin
203 FFA_FZ_To_Hex_String(N, S); -- Convert N to ASCII hex
204 Write_String(S); -- Print the result to stdout
205 Write_Newline; -- Print newline, for clarity.
206 end Print_FZ;
207
208
209 -- Denote that the given op is a prefix
210 procedure IsPrefix is
211 begin
212 HavePrefix := True;
213 end IsPrefix;
214
215
216 -- Execute a Normal Op
217 procedure Op_Normal(C : in Character) is
218
219 -- Over/underflow output from certain ops
220 F : Word;
221
222 begin
223
224 case C is
225
226 --------------
227 -- Stickies --
228 --------------
229 -- Enter Commented
230 when '(' =>
231 CommLevel := 1;
232
233 -- Exit Commented (but we aren't in it!)
234 when ')' =>
235 E("Mismatched close-comment parenthesis !");
236
237 -- Enter Quoted
238 when '[' =>
239 QuoteLevel := 1;
240
241 -- Exit Quoted (but we aren't in it!)
242 when ']' =>
243 E("Mismatched close-quote bracket !");
244
245 -- Enter a ~taken~ Conditional branch:
246 when '{' =>
247 Want(1);
248 if FFA_FZ_ZeroP(Stack(SP)) = 1 then
249 CondLevel := 1;
250 end if;
251 Drop;
252
253 -- Exit from a ~non-taken~ Conditional branch:
254 -- ... we push a 0, to suppress the 'else' clause
255 when '}' =>
256 Push;
257 FFA_WBool_To_FZ(0, Stack(SP));
258
259 ----------------
260 -- Immediates --
261 ----------------
262
263 -- These operate on the FZ ~currently~ at top of the stack;
264 -- and this means that the stack may NOT be empty.
265
266 when '0' .. '9' =>
267 Want(1);
268 Ins_Hex_Digit(Character'Pos(C) - Character'Pos('0'));
269
270 when 'A' .. 'F' =>
271 Want(1);
272 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('A'));
273
274 when 'a' .. 'f' =>
275 Want(1);
276 Ins_Hex_Digit(10 + Character'Pos(C) - Character'Pos('a'));
277
278 ------------------
279 -- Stack Motion --
280 ------------------
281
282 -- Push a 0 onto the stack
283 when '.' =>
284 Push;
285 FFA_FZ_Clear(Stack(SP));
286
287 -- Dup
288 when '"' =>
289 Want(1);
290 Push;
291 Stack(SP) := Stack(SP - 1);
292
293 -- Drop
294 when '_' =>
295 Want(1);
296 Drop;
297
298 -- Swap
299 when ''' =>
300 Want(2);
301 FFA_FZ_Swap(Stack(SP), Stack(SP - 1));
302
303 -- Over
304 when '`' =>
305 Want(2);
306 Push;
307 Stack(SP) := Stack(SP - 2);
308
309 ----------------
310 -- Predicates --
311 ----------------
312
313 -- Equality
314 when '=' =>
315 Want(2);
316 FFA_WBool_To_FZ(FFA_FZ_EqP(X => Stack(SP),
317 Y => Stack(SP - 1)),
318 Stack(SP - 1));
319 Drop;
320
321 -- Less-Than
322 when '<' =>
323 Want(2);
324 FFA_WBool_To_FZ(FFA_FZ_LessThanP(X => Stack(SP - 1),
325 Y => Stack(SP)),
326 Stack(SP - 1));
327 Drop;
328
329 -- Greater-Than
330 when '>' =>
331 Want(2);
332 FFA_WBool_To_FZ(FFA_FZ_GreaterThanP(X => Stack(SP - 1),
333 Y => Stack(SP)),
334 Stack(SP - 1));
335 Drop;
336
337 ----------------
338 -- Arithmetic --
339 ----------------
340
341 -- Subtract
342 when '-' =>
343 Want(2);
344 FFA_FZ_Subtract(X => Stack(SP - 1),
345 Y => Stack(SP),
346 Difference => Stack(SP - 1),
347 Underflow => F);
348 Flag := FFA_Word_NZeroP(F);
349 Drop;
350
351 -- Add
352 when '+' =>
353 Want(2);
354 FFA_FZ_Add(X => Stack(SP - 1),
355 Y => Stack(SP),
356 Sum => Stack(SP - 1),
357 Overflow => F);
358 Flag := FFA_Word_NZeroP(F);
359 Drop;
360
361 -- Divide and give Quotient and Remainder
362 when '\' =>
363 Want(2);
364 MustNotZero(Stack(SP));
365 FFA_FZ_IDiv(Dividend => Stack(SP - 1),
366 Divisor => Stack(SP),
367 Quotient => Stack(SP - 1),
368 Remainder => Stack(SP));
369
370 -- Divide and give Quotient only
371 when '/' =>
372 Want(2);
373 MustNotZero(Stack(SP));
374 FFA_FZ_Div(Dividend => Stack(SP - 1),
375 Divisor => Stack(SP),
376 Quotient => Stack(SP - 1));
377 Drop;
378
379 -- Divide and give Remainder only
380 when '%' =>
381 Want(2);
382 MustNotZero(Stack(SP));
383 FFA_FZ_Mod(Dividend => Stack(SP - 1),
384 Divisor => Stack(SP),
385 Remainder => Stack(SP - 1));
386 Drop;
387
388 -- Multiply, give bottom and top halves
389 when '*' =>
390 Want(2);
391 FFA_FZ_Multiply(X => Stack(SP - 1),
392 Y => Stack(SP),
393 XY_Lo => Stack(SP - 1),
394 XY_Hi => Stack(SP));
395
396 -- Square, give bottom and top halves
397 when 'S' =>
398 Want(1);
399 Push;
400 FFA_FZ_Square(X => Stack(SP - 1),
401 XX_Lo => Stack(SP - 1),
402 XX_Hi => Stack(SP));
403
404 -- Greatest Common Divisor (GCD)
405 when 'G' =>
406 Want(2);
407
408 -- Note that GCD(0,0) is not factually zero, or unique.
409 -- But it is permissible to define it as zero.
410 -- (See Ch. 15 discussion.)
411
412 FFA_FZ_Greatest_Common_Divisor(X => Stack(SP - 1),
413 Y => Stack(SP),
414 Result => Stack(SP - 1));
415 Drop;
416
417 -----------------
418 -- Bitwise Ops --
419 -----------------
420
421 -- Bitwise-And
422 when '&' =>
423 Want(2);
424 FFA_FZ_And(X => Stack(SP - 1),
425 Y => Stack(SP),
426 Result => Stack(SP - 1));
427 Drop;
428
429 -- Bitwise-Or
430 when '|' =>
431 Want(2);
432 FFA_FZ_Or(X => Stack(SP - 1),
433 Y => Stack(SP),
434 Result => Stack(SP - 1));
435 Drop;
436
437 -- Bitwise-Xor
438 when '^' =>
439 Want(2);
440 FFA_FZ_Xor(X => Stack(SP - 1),
441 Y => Stack(SP),
442 Result => Stack(SP - 1));
443 Drop;
444
445 -- Bitwise-Not (1s-Complement)
446 when '~' =>
447 Want(1);
448 FFA_FZ_Not(Stack(SP), Stack(SP));
449
450 -----------
451 -- Other --
452 -----------
453
454 -- Push a FZ of RNGolade onto the stack
455 when '?' =>
456 Push;
457 FFA_FZ_Clear(Stack(SP));
458 FZ_Random(RNG, Stack(SP));
459
460 -- mUx
461 when 'U' =>
462 Want(3);
463 FFA_FZ_Mux(X => Stack(SP - 2),
464 Y => Stack(SP - 1),
465 Result => Stack(SP - 2),
466 Sel => FFA_FZ_NZeroP(Stack(SP)));
467 Drop;
468 Drop;
469
470 -- Find the position of eldest nonzero bit, if any exist
471 when 'W' =>
472 Want(1);
473 declare
474 -- Find the measure ( 0 if no 1s, or 1 .. FZBitness )
475 Measure : FZBit_Index := FFA_FZ_Measure(Stack(SP));
476 begin
477 -- Put on top of stack
478 FFA_FZ_Clear(Stack(SP));
479 FFA_FZ_Set_Head(Stack(SP), Word(Measure));
480 end;
481
482 -- Put the Overflow flag on the stack
483 when 'O' =>
484 Push;
485 FFA_WBool_To_FZ(Flag, Stack(SP));
486
487 -- Print the FZ on the top of the stack
488 when '#' =>
489 Want(1);
490 Print_FZ(Stack(SP));
491 Drop;
492
493 -- Zap (reset)
494 when 'Z' =>
495 Zap;
496
497 -- Quit with Stack Trace
498 when 'Q' =>
499 for I in reverse Stack'First + 1 .. SP loop
500 Print_FZ(Stack(I));
501 end loop;
502 Quit(0);
503
504 -- Put the FFACalc Program Version on the stack,
505 -- followed by FFA Program Version.
506 when 'V' =>
507 Push;
508 Push;
509 -- FFACalc Version:
510 FFA_FZ_Clear(Stack(SP - 1));
511 FFA_FZ_Set_Head(Stack(SP - 1), Word(FFACalc_K_Version));
512 -- FFA Version:
513 FFA_FZ_Clear(Stack(SP));
514 FFA_FZ_Set_Head(Stack(SP), Word(FFA_K_Version));
515
516 -- Constant-Time Miller-Rabin Test on N using the given Witness.
517 -- Witness will be used as-is if it conforms to the valid range,
518 -- i.e. 2 <= Witness <= N - 2; else will be transformed into a
519 -- valid Witness via modular arithmetic.
520 -- Outputs ONE if N WAS FOUND composite; ZERO if NOT FOUND.
521 -- Handles degenerate cases of N that M-R per se cannot eat:
522 -- N=0, N=1: ALWAYS 'FOUND COMPOS.'; 2, 3 - ALWAYS 'NOT FOUND'.
523 -- If N is Even and not equal to 2, N is ALWAYS 'FOUND COMPOS.'
524 -- For ALL other N, the output is equal to that of the M-R test.
525 -- At most 1/4 of all possible Witnesses will be 'liars' for
526 -- a particular composite N , i.e. fail to attest to its
527 -- compositivity.
528 when 'P' =>
529 Want(2);
530 declare
531 MR_Result : WBool :=
532 FFA_FZ_MR_Composite_On_Witness(N => Stack(SP - 1),
533 Witness => Stack(SP));
534 begin
535 FFA_WBool_To_FZ(MR_Result, Stack(SP - 1));
536 end;
537 Drop;
538
539 --------------
540 -- Prefixes --
541 --------------
542
543 -- 'Left...' :
544 when 'L' =>
545 IsPrefix;
546
547 -- 'Right...' :
548 when 'R' =>
549 IsPrefix;
550
551 -- 'Modular...' :
552 when 'M' =>
553 IsPrefix;
554
555 ---------------------------------------------------------
556 -- Reserved Ops, i.e. ones we have not defined yet: --
557 ---------------------------------------------------------
558 when '!' | '@' | '$' | ':' | ';' | ',' |
559 'H' | 'I' | 'J' | 'K' | 'N' |
560 'T' | 'X' | 'Y' =>
561
562 E("This Operator is not defined yet: " & C);
563 ---------------------------------------------------------
564
565 ----------
566 -- NOPs --
567 ----------
568
569 -- Unprintables and spaces DO NOTHING:
570 when others =>
571 null;
572
573 end case;
574
575 end Op_Normal;
576
577
578 -- Execute a Prefixed Op
579 procedure Op_Prefixed(Prefix : in Character;
580 O : in Character) is
581 begin
582
583 -- The Prefixed Op:
584 case Prefix is
585
586 ---------------------------------------------------------
587 -- Left...
588 when 'L' =>
589
590 -- Which L-op?
591 case O is
592
593 -- ... Shift :
594 when 'S' =>
595 Want(2);
596 declare
597 -- Number of bit positions to shift by:
598 ShiftCount : FZBit_Index
599 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
600 begin
601 FFA_FZ_Quiet_ShiftLeft(N => Stack(SP - 1),
602 ShiftedN => Stack(SP - 1),
603 Count => ShiftCount);
604 end;
605 Drop;
606
607 -- ... Rotate :
608 when 'R' =>
609 E("Left-Rotate not yet defined!");
610
611 -- ... Unknown:
612 when others =>
613 E("Undefined Op: L" & O);
614
615 end case;
616 ---------------------------------------------------------
617 -- Right...
618 when 'R' =>
619
620 -- Which R-op?
621 case O is
622
623 -- ... Shift:
624 when 'S' =>
625 Want(2);
626 declare
627 -- Number of bit positions to shift by:
628 ShiftCount : FZBit_Index
629 := FZBit_Index(FFA_FZ_Get_Head(Stack(SP)));
630 begin
631 FFA_FZ_Quiet_ShiftRight(N => Stack(SP - 1),
632 ShiftedN => Stack(SP - 1),
633 Count => ShiftCount);
634 end;
635 Drop;
636
637 -- ... Rotate:
638 when 'R' =>
639 E("Right-Rotate not yet defined!");
640
641 -- 'Right-Multiply', give only lower half of the product XY
642 when '*' =>
643 Want(2);
644 FFA_FZ_Low_Multiply(X => Stack(SP - 1),
645 Y => Stack(SP),
646 XY => Stack(SP - 1));
647 Drop;
648
649 -- ... Unknown:
650 when others =>
651 E("Undefined Op: R" & O);
652
653 end case;
654 ---------------------------------------------------------
655 -- Modular...
656 when 'M' =>
657
658 -- Which M-op?
659 case O is
660
661 -- ... Multiplication (Conventional) :
662 when '*' =>
663 Want(3);
664 MustNotZero(Stack(SP));
665 FFA_FZ_Modular_Multiply(X => Stack(SP - 2),
666 Y => Stack(SP - 1),
667 Modulus => Stack(SP),
668 Product => Stack(SP - 2));
669 Drop;
670 Drop;
671
672 -- ... Squaring (Conventional) :
673 when 'S' =>
674 Want(2);
675 MustNotZero(Stack(SP));
676 FFA_FZ_Modular_Square(X => Stack(SP - 1),
677 Modulus => Stack(SP),
678 Product => Stack(SP - 1));
679 Drop;
680
681 -- ... Exponentiation (Barrettronic) :
682 when 'X' =>
683 Want(3);
684 MustNotZero(Stack(SP));
685 FFA_FZ_Modular_Exponentiate(Base => Stack(SP - 2),
686 Exponent => Stack(SP - 1),
687 Modulus => Stack(SP),
688 Result => Stack(SP - 2));
689 Drop;
690 Drop;
691
692 -- ... Unknown:
693 when others =>
694 E("Undefined Op: M" & O);
695
696 end case;
697 ---------------------------------------------------------
698 -- ... Unknown: (impossible per mechanics, but must handle case)
699 when others =>
700 E("Undefined Prefix: " & Prefix);
701
702 end case;
703
704 end Op_Prefixed;
705
706
707 -- Process a Symbol
708 procedure Op(C : in Character) is
709 begin
710 -- First, see whether we are in a state of nestedness:
711
712 -- ... in a Comment block:
713 if CommLevel > 0 then
714 case C is
715 when ')' => -- Drop a nesting level:
716 CommLevel := CommLevel - 1;
717 when '(' => -- Add a nesting level:
718 CommLevel := CommLevel + 1;
719 when others =>
720 null; -- Other symbols have no effect at all
721 end case;
722
723 -- ... in a Quote block:
724 elsif QuoteLevel > 0 then
725 case C is
726 when ']' => -- Drop a nesting level:
727 QuoteLevel := QuoteLevel - 1;
728 when '[' => -- Add a nesting level:
729 QuoteLevel := QuoteLevel + 1;
730 when others =>
731 null; -- Other symbols have no effect on the level
732 end case;
733
734 -- If we aren't the mode-exiting ']', print current symbol:
735 if QuoteLevel > 0 then
736 Write_Char(C);
737 end if;
738
739 --- ... in a ~taken~ Conditional branch:
740 elsif CondLevel > 0 then
741 case C is
742 when '}' => -- Drop a nesting level:
743 CondLevel := CondLevel - 1;
744
745 -- If we exited the Conditional as a result,
746 -- we push a 1 to trigger the possible 'else' clause:
747 if CondLevel = 0 then
748 Push;
749 FFA_WBool_To_FZ(1, Stack(SP));
750 end if;
751
752 when '{' => -- Add a nesting level:
753 CondLevel := CondLevel + 1;
754 when others =>
755 null; -- Other symbols have no effect on the level
756 end case;
757
758 --- ... if in a prefixed op:
759 elsif HavePrefix then
760
761 -- Drop the prefix-op hammer, until another prefix-op cocks it
762 HavePrefix := False;
763
764 -- Dispatch this op, where prefix is the preceding character
765 Op_Prefixed(Prefix => PrevC, O => C);
766
767 else
768 -- This is a Normal Op, so proceed with the normal rules.
769 Op_Normal(C);
770 end if;
771
772 end Op;
773
774
775 -- Current Character
776 C : Character;
777
778 begin
779 -- Reset the Calculator
780 Zap;
781 -- Process characters until EOF:
782 loop
783 if Read_Char(C) then
784 -- Execute Op:
785 Op(C);
786 -- Advance Odometer
787 Pos := Pos + 1;
788 -- Save the op for use in prefixed ops
789 PrevC := C;
790 else
791 Zap;
792 Quit(0); -- if EOF, we're done
793 end if;
794 end loop;
795 end;
796
797 end FFA_Calc;