├── .github
└── FUNDING.yml
├── .gitignore
├── LICENSE
├── makefile
├── readme.md
├── subleq.c
├── subleq.dec
└── subleq.fth
/.github/FUNDING.yml:
--------------------------------------------------------------------------------
1 | # These are supported funding model platforms
2 |
3 | github: howerj
4 | patreon: # Replace with a single Patreon username
5 | open_collective: # Replace with a single Open Collective username
6 | ko_fi: # Replace with a single Ko-fi username
7 | tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel
8 | community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry
9 | liberapay: # Replace with a single Liberapay username
10 | issuehunt: # Replace with a single IssueHunt username
11 | lfx_crowdfunding: # Replace with a single LFX Crowdfunding project-name e.g., cloud-foundry
12 | polar: # Replace with a single Polar username
13 | buy_me_a_coffee: # Replace with a single Buy Me a Coffee username
14 | custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2']
15 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *.hex
2 | *.txt
3 | *.dec
4 | subleq
5 | full
6 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | This is free and unencumbered software released into the public domain.
2 |
3 | Anyone is free to copy, modify, publish, use, compile, sell, or
4 | distribute this software, either in source code form or as a compiled
5 | binary, for any purpose, commercial or non-commercial, and by any
6 | means.
7 |
8 | In jurisdictions that recognize copyright laws, the author or authors
9 | of this software dedicate any and all copyright interest in the
10 | software to the public domain. We make this dedication for the benefit
11 | of the public at large and to the detriment of our heirs and
12 | successors. We intend this dedication to be an overt act of
13 | relinquishment in perpetuity of all present and future rights to this
14 | software under copyright law.
15 |
16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
22 | OTHER DEALINGS IN THE SOFTWARE.
23 |
24 | For more information, please refer to
25 |
--------------------------------------------------------------------------------
/makefile:
--------------------------------------------------------------------------------
1 | CFLAGS=-std=c99 -Wall -Wextra -pedantic -O3
2 |
3 | .PHONY: all clean test run gforth
4 |
5 | all: subleq
6 |
7 | run: subleq subleq.dec
8 | ./subleq subleq.dec
9 |
10 | 1.dec: subleq subleq.dec subleq.fth
11 | ./subleq subleq.dec < subleq.fth > $@
12 |
13 | 2.dec: subleq 1.dec subleq.fth
14 | ./subleq 1.dec < subleq.fth > $@
15 |
16 | test: 1.dec 2.dec
17 | diff -w 1.dec 2.dec
18 |
19 | gforth.dec: subleq.fth
20 | gforth $< > $@
21 |
22 | gforth: subleq gforth.dec
23 | ./subleq gforth.dec
24 |
25 | clean:
26 | git clean -dffx
27 |
28 |
--------------------------------------------------------------------------------
/readme.md:
--------------------------------------------------------------------------------
1 | # 16-bit SUBLEQ eForth
2 |
3 | * Author: Richard James Howe
4 | * Email:
5 | * Repo:
6 | * License: [The Unlicense](LICENSE) / Public Domain
7 |
8 | If you feel like supporting the project you can buy a book from
9 | Amazon, available [here](https://www.amazon.com/SUBLEQ-EFORTH-Forth-Metacompilation-Machine-ebook/dp/B0B5VZWXPL)
10 | that describes how the project works and how to port a Forth to
11 | a new platform.
12 |
13 | This project contains a working (self-hosting) Forth interpreter that runs
14 | on top of a SUBLEQ 16-bit machine. SUBLEQ machines belong to the class
15 | of One Instruction Set Computers, they only execute a single instruction
16 | but are still Turing Complete. The Forth system, specifically a variant
17 | of eForth, is provided as [subleq.dec](subleq.dec), passing this image
18 | to the tiny (~ 600 bytes) [SUBLEQ C virtual machine](subleq.c) allows
19 | you to run eForth on the machine. For a list of commands type "words"
20 | and hit enter, numbers are entered using Reverse Polish Notation, eg. "2
21 | 2 + . cr" prints "4", and new functions can be defined like so:
22 |
23 | : hello cr ." Hello, World" ;
24 |
25 | Be careful with the spaces, they matter, after typing that in, type
26 | "hello" and hit enter. A Forth tutorial will not be provided here. Many
27 | Forth words are defined *including the bitwise words*.
28 |
29 | To build and run you will need a C compiler and Make, type "make run",
30 | failing that:
31 |
32 | cc subleq.c -o subleq
33 | ./subleq subleq.dec
34 |
35 | The system is self hosting, that is it can generate new eForth images
36 | using the current eForth image and the eForth source code. This is done
37 | like so:
38 |
39 | ./subleq subleq.dec < subleq.fth > new-image.dec
40 |
41 | There is a website available that runs an interactive SUBLEQ interpreter
42 | in the browser in case you do not want to both compiling things, it is
43 | available at . Or if you just want to
44 | try it out directly .
45 |
46 | Happy hacking, and a shiny penny for anyone that manages to do something
47 | useful with this project!
48 |
49 | ## Other SUBLEQ projects
50 |
51 | *
52 | *
53 | *
54 | *
55 | *
56 | *
57 |
58 | ## References
59 |
60 | *
61 | *
62 | *
63 | *
64 | *
65 | *
66 | *
67 | *
68 | *
69 | *
70 | *
71 | *
72 | * 8086 eForth 1.0 by Bill Muench and C. H. Ting, 1990
73 | * ,
74 | For multitasking support
75 | * ,
76 | For the block word-set, which is partially implemented.
77 | *
78 | * URISC, the original OISC, a SUBLEQ machine:
79 | Mavaddat, F.; Parhami, B. (October 1988). "URISC: The
80 | Ultimate Reduced Instruction Set Computer".
81 | * , which
82 | SUBLEQ could be argued to be one.
83 | * For other Single Instruction Set Computers:
84 |
85 | * For the Forth-83 Standard:
86 |
87 |
88 | * DPANS84 FORTH standard:
89 |
90 |
91 |
--------------------------------------------------------------------------------
/subleq.c:
--------------------------------------------------------------------------------
1 | #include
2 | #include
3 |
4 | typedef uint16_t u16;
5 | static const u16 n = -1;
6 | static u16 m[1<<16], pc = 0, prog = 0;
7 |
8 | int main(int argc, char **argv) {
9 | for (long i = 1, d = 0; i < argc; i++) {
10 | FILE *f = fopen(argv[i], "rb");
11 | if (!f)
12 | return 1;
13 | while (fscanf(f, "%ld,", &d) > 0)
14 | m[prog++] = d;
15 | if (fclose(f) < 0)
16 | return 2;
17 | }
18 | for (pc = 0; pc < 32768;) {
19 | u16 a = m[pc++], b = m[pc++], c = m[pc++];
20 | if (a == n) {
21 | m[b] = getchar();
22 | } else if (b == n) {
23 | if (putchar(m[a]) < 0)
24 | return 3;
25 | if (fflush(stdout) < 0)
26 | return 4;
27 | } else {
28 | u16 r = m[b] - m[a];
29 | if (r == 0 || r & 32768)
30 | pc = c;
31 | m[b] = r;
32 | }
33 | }
34 | return 0;
35 | }
36 |
--------------------------------------------------------------------------------
/subleq.dec:
--------------------------------------------------------------------------------
1 | 0
2 | 0
3 | 131
4 | 25
5 | 2174
6 | 128
7 | -1
8 | 1
9 | 16
10 | 64
11 | 0
12 | 0
13 | 0
14 | 0
15 | 0
16 | 0
17 | 401
18 | 245
19 | 16
20 | 12954
21 | 32256
22 | -18437
23 | 0
24 | 0
25 | 0
26 | 0
27 | 0
28 | 0
29 | 0
30 | 0
31 | 62
32 | 12936
33 | 12900
34 | 11690
35 | 12626
36 | 6151
37 | 12260
38 | 12936
39 | 0
40 | 1
41 | 50
42 | 0
43 | 0
44 | 32384
45 | 32384
46 | 32512
47 | 32512
48 | 69
49 | 114
50 | 114
51 | 111
52 | 114
53 | 58
54 | 32
55 | 78
56 | 111
57 | 116
58 | 32
59 | 97
60 | 32
61 | 49
62 | 54
63 | 45
64 | 98
65 | 105
66 | 116
67 | 32
68 | 83
69 | 85
70 | 66
71 | 76
72 | 69
73 | 81
74 | 32
75 | 86
76 | 77
77 | 13
78 | 10
79 | -1
80 | 47
81 | 10
82 | 10
83 | 83
84 | 79
85 | 0
86 | 86
87 | 0
88 | 10
89 | 89
90 | 0
91 | 0
92 | 92
93 | 107
94 | 107
95 | 95
96 | 10
97 | 0
98 | 98
99 | 0
100 | 107
101 | 101
102 | 0
103 | 0
104 | 104
105 | 11
106 | 11
107 | 107
108 | 0
109 | 0
110 | 110
111 | 0
112 | 11
113 | 113
114 | 0
115 | 0
116 | 116
117 | 6
118 | 10
119 | 119
120 | 0
121 | 11
122 | 128
123 | 11
124 | -1
125 | 125
126 | 0
127 | 0
128 | 92
129 | 0
130 | 0
131 | -1
132 | 10
133 | 10
134 | 134
135 | 6
136 | 10
137 | 137
138 | 11
139 | 11
140 | 140
141 | 6
142 | 11
143 | 143
144 | 10
145 | 0
146 | 146
147 | 0
148 | 10
149 | 149
150 | 0
151 | 0
152 | 152
153 | 6
154 | 11
155 | 155
156 | 12
157 | 12
158 | 158
159 | 11
160 | 0
161 | 161
162 | 0
163 | 12
164 | 164
165 | 0
166 | 0
167 | 167
168 | 9
169 | 12
170 | 170
171 | 0
172 | 12
173 | 176
174 | 0
175 | 0
176 | 80
177 | 0
178 | 10
179 | 182
180 | 0
181 | 0
182 | 143
183 | 12
184 | 12
185 | 185
186 | 11
187 | 0
188 | 188
189 | 0
190 | 12
191 | 191
192 | 0
193 | 0
194 | 194
195 | 18
196 | 18
197 | 197
198 | 11
199 | 0
200 | 200
201 | 0
202 | 18
203 | 203
204 | 0
205 | 0
206 | 206
207 | 8
208 | 12
209 | 209
210 | 0
211 | 12
212 | 227
213 | 226
214 | 226
215 | 215
216 | 16
217 | 0
218 | 218
219 | 0
220 | 226
221 | 221
222 | 0
223 | 0
224 | 224
225 | 0
226 | 0
227 | 227
228 | 8
229 | 11
230 | 230
231 | 11
232 | 0
233 | 236
234 | 0
235 | 0
236 | 242
237 | 0
238 | 0
239 | 239
240 | 0
241 | 11
242 | 245
243 | 0
244 | 0
245 | 80
246 | 46
247 | 46
248 | 248
249 | 45
250 | 0
251 | 251
252 | 0
253 | 46
254 | 254
255 | 0
256 | 0
257 | 257
258 | 44
259 | 44
260 | 260
261 | 43
262 | 0
263 | 263
264 | 0
265 | 44
266 | 266
267 | 0
268 | 0
269 | 269
270 | 41
271 | 41
272 | 272
273 | 35
274 | 0
275 | 275
276 | 0
277 | 41
278 | 278
279 | 0
280 | 0
281 | 281
282 | 296
283 | 296
284 | 284
285 | 41
286 | 0
287 | 287
288 | 0
289 | 296
290 | 290
291 | 0
292 | 0
293 | 293
294 | 10
295 | 10
296 | 296
297 | 0
298 | 0
299 | 299
300 | 0
301 | 10
302 | 302
303 | 0
304 | 0
305 | 305
306 | 6
307 | 41
308 | 308
309 | 11
310 | 11
311 | 311
312 | 4
313 | 0
314 | 314
315 | 0
316 | 11
317 | 317
318 | 0
319 | 0
320 | 320
321 | 10
322 | 11
323 | 323
324 | 0
325 | 11
326 | 341
327 | 340
328 | 340
329 | 329
330 | 10
331 | 0
332 | 332
333 | 0
334 | 340
335 | 335
336 | 0
337 | 0
338 | 338
339 | 0
340 | 0
341 | 341
342 | 6
343 | 44
344 | 344
345 | 44
346 | 0
347 | 347
348 | 359
349 | 359
350 | 350
351 | 360
352 | 360
353 | 353
354 | 0
355 | 359
356 | 356
357 | 0
358 | 360
359 | 359
360 | 0
361 | 0
362 | 362
363 | 41
364 | 1
365 | 365
366 | 372
367 | 372
368 | 368
369 | 0
370 | 372
371 | 371
372 | 1
373 | 0
374 | 374
375 | 0
376 | 0
377 | 377
378 | 1
379 | 1
380 | 380
381 | 41
382 | 41
383 | 383
384 | 10
385 | 0
386 | 386
387 | 0
388 | 41
389 | 389
390 | 0
391 | 0
392 | 392
393 | 0
394 | 0
395 | 281
396 | 0
397 | 0
398 | 0
399 | 0
400 | 0
401 | -16
402 | 15
403 | 15
404 | 404
405 | 7
406 | 15
407 | 407
408 | 18
409 | 395
410 | 410
411 | 395
412 | 400
413 | 413
414 | 395
415 | 395
416 | 416
417 | 399
418 | 399
419 | 419
420 | 17
421 | 395
422 | 422
423 | 395
424 | 399
425 | 425
426 | 395
427 | 395
428 | 428
429 | 6
430 | 399
431 | -1
432 | 446
433 | 446
434 | 434
435 | 17
436 | 395
437 | 437
438 | 395
439 | 446
440 | 440
441 | 395
442 | 395
443 | 443
444 | 397
445 | 397
446 | 446
447 | 0
448 | 395
449 | 449
450 | 395
451 | 397
452 | 452
453 | 395
454 | 395
455 | 455
456 | 6
457 | 17
458 | 458
459 | 473
460 | 473
461 | 461
462 | 17
463 | 395
464 | 464
465 | 395
466 | 473
467 | 467
468 | 395
469 | 395
470 | 470
471 | 398
472 | 398
473 | 473
474 | 0
475 | 395
476 | 476
477 | 395
478 | 398
479 | 479
480 | 395
481 | 395
482 | 482
483 | 6
484 | 17
485 | 485
486 | 399
487 | 399
488 | 488
489 | 397
490 | 395
491 | 491
492 | 395
493 | 399
494 | 494
495 | 395
496 | 395
497 | 497
498 | 6
499 | 399
500 | 500
501 | 395
502 | 399
503 | 683
504 | 399
505 | 399
506 | 506
507 | 398
508 | 395
509 | 509
510 | 395
511 | 399
512 | 512
513 | 395
514 | 395
515 | 515
516 | 6
517 | 399
518 | 518
519 | 395
520 | 399
521 | 650
522 | 536
523 | 536
524 | 524
525 | 397
526 | 395
527 | 527
528 | 395
529 | 536
530 | 530
531 | 395
532 | 395
533 | 533
534 | 397
535 | 397
536 | 536
537 | 0
538 | 395
539 | 539
540 | 395
541 | 397
542 | 542
543 | 395
544 | 395
545 | 545
546 | 398
547 | 395
548 | 548
549 | 555
550 | 555
551 | 551
552 | 395
553 | 555
554 | 554
555 | 397
556 | 0
557 | 557
558 | 395
559 | 395
560 | 560
561 | 575
562 | 575
563 | 563
564 | 398
565 | 395
566 | 566
567 | 395
568 | 575
569 | 569
570 | 395
571 | 395
572 | 572
573 | 397
574 | 397
575 | 575
576 | 0
577 | 395
578 | 578
579 | 395
580 | 397
581 | 581
582 | 395
583 | 395
584 | 584
585 | 399
586 | 399
587 | 587
588 | 400
589 | 395
590 | 590
591 | 395
592 | 399
593 | 593
594 | 395
595 | 395
596 | 596
597 | 397
598 | 395
599 | 599
600 | 395
601 | 397
602 | 602
603 | 395
604 | 395
605 | 605
606 | 7
607 | 399
608 | 608
609 | 395
610 | 399
611 | 614
612 | 395
613 | 395
614 | 596
615 | 395
616 | 397
617 | 623
618 | 6
619 | 17
620 | 620
621 | 395
622 | 395
623 | 416
624 | 638
625 | 638
626 | 626
627 | 17
628 | 395
629 | 629
630 | 395
631 | 638
632 | 632
633 | 395
634 | 395
635 | 635
636 | 17
637 | 17
638 | 638
639 | 0
640 | 395
641 | 641
642 | 395
643 | 17
644 | 644
645 | 395
646 | 395
647 | 647
648 | 395
649 | 395
650 | 416
651 | 665
652 | 665
653 | 653
654 | 397
655 | 395
656 | 656
657 | 395
658 | 665
659 | 659
660 | 395
661 | 395
662 | 662
663 | 397
664 | 397
665 | 665
666 | 0
667 | 395
668 | 668
669 | 395
670 | 397
671 | 671
672 | 395
673 | 395
674 | 674
675 | 397
676 | -1
677 | 677
678 | 6
679 | 17
680 | 680
681 | 395
682 | 395
683 | 416
684 | -1
685 | 397
686 | 686
687 | 398
688 | 395
689 | 689
690 | 701
691 | 701
692 | 692
693 | 702
694 | 702
695 | 695
696 | 395
697 | 701
698 | 698
699 | 395
700 | 702
701 | 701
702 | 0
703 | 0
704 | 704
705 | 397
706 | 396
707 | 707
708 | 714
709 | 714
710 | 710
711 | 395
712 | 714
713 | 713
714 | 396
715 | 0
716 | 716
717 | 395
718 | 395
719 | 719
720 | 396
721 | 396
722 | 722
723 | 6
724 | 17
725 | 725
726 | 395
727 | 395
728 | 416
729 | 10
730 | 10
731 | 731
732 | 42
733 | 0
734 | 734
735 | 0
736 | 10
737 | 737
738 | 0
739 | 0
740 | 740
741 | 755
742 | 755
743 | 743
744 | 46
745 | 0
746 | 746
747 | 0
748 | 755
749 | 749
750 | 0
751 | 0
752 | 752
753 | 42
754 | 42
755 | 755
756 | 0
757 | 0
758 | 758
759 | 0
760 | 42
761 | 761
762 | 0
763 | 0
764 | 764
765 | 46
766 | 0
767 | 767
768 | 779
769 | 779
770 | 770
771 | 780
772 | 780
773 | 773
774 | 0
775 | 779
776 | 776
777 | 0
778 | 780
779 | 779
780 | 0
781 | 0
782 | 782
783 | 10
784 | 1
785 | 785
786 | 792
787 | 792
788 | 788
789 | 0
790 | 792
791 | 791
792 | 1
793 | 0
794 | 794
795 | 0
796 | 0
797 | 797
798 | 1
799 | 1
800 | 800
801 | 0
802 | 0
803 | 281
804 | 7
805 | 46
806 | 806
807 | 46
808 | 0
809 | 809
810 | 821
811 | 821
812 | 812
813 | 822
814 | 822
815 | 815
816 | 0
817 | 821
818 | 818
819 | 0
820 | 822
821 | 821
822 | 0
823 | 0
824 | 824
825 | 42
826 | 1
827 | 827
828 | 834
829 | 834
830 | 830
831 | 0
832 | 834
833 | 833
834 | 1
835 | 0
836 | 836
837 | 0
838 | 0
839 | 839
840 | 1
841 | 1
842 | 842
843 | 0
844 | 0
845 | 281
846 | 7
847 | 46
848 | 848
849 | 46
850 | 0
851 | 851
852 | 863
853 | 863
854 | 854
855 | 864
856 | 864
857 | 857
858 | 0
859 | 863
860 | 860
861 | 0
862 | 864
863 | 863
864 | 0
865 | 0
866 | 866
867 | 42
868 | 1
869 | 869
870 | 876
871 | 876
872 | 872
873 | 0
874 | 876
875 | 875
876 | 1
877 | 0
878 | 878
879 | 0
880 | 0
881 | 881
882 | 1
883 | 1
884 | 884
885 | 899
886 | 899
887 | 887
888 | 44
889 | 0
890 | 890
891 | 0
892 | 899
893 | 893
894 | 0
895 | 0
896 | 896
897 | 42
898 | 42
899 | 899
900 | 0
901 | 0
902 | 902
903 | 0
904 | 42
905 | 905
906 | 0
907 | 0
908 | 908
909 | 7
910 | 44
911 | 911
912 | 0
913 | 0
914 | 281
915 | 6
916 | 44
917 | 917
918 | 44
919 | 0
920 | 920
921 | 932
922 | 932
923 | 923
924 | 933
925 | 933
926 | 926
927 | 0
928 | 932
929 | 929
930 | 0
931 | 933
932 | 932
933 | 0
934 | 0
935 | 935
936 | 42
937 | 1
938 | 938
939 | 945
940 | 945
941 | 941
942 | 0
943 | 945
944 | 944
945 | 1
946 | 0
947 | 947
948 | 0
949 | 0
950 | 950
951 | 1
952 | 1
953 | 953
954 | 968
955 | 968
956 | 956
957 | 46
958 | 0
959 | 959
960 | 0
961 | 968
962 | 962
963 | 0
964 | 0
965 | 965
966 | 42
967 | 42
968 | 968
969 | 0
970 | 0
971 | 971
972 | 0
973 | 42
974 | 974
975 | 0
976 | 0
977 | 977
978 | 6
979 | 46
980 | 980
981 | 0
982 | 0
983 | 281
984 | 998
985 | 998
986 | 986
987 | 42
988 | 0
989 | 989
990 | 0
991 | 998
992 | 992
993 | 0
994 | 0
995 | 995
996 | 42
997 | 42
998 | 998
999 | 0
1000 | 0
1001 | 1001
1002 | 0
1003 | 42
1004 | 1004
1005 | 0
1006 | 0
1007 | 1007
1008 | 0
1009 | 0
1010 | 281
1011 | 1025
1012 | 1025
1013 | 1013
1014 | 46
1015 | 0
1016 | 1016
1017 | 0
1018 | 1025
1019 | 1019
1020 | 0
1021 | 0
1022 | 1022
1023 | 10
1024 | 10
1025 | 1025
1026 | 0
1027 | 0
1028 | 1028
1029 | 0
1030 | 10
1031 | 1031
1032 | 0
1033 | 0
1034 | 1034
1035 | 42
1036 | 0
1037 | 1037
1038 | 1049
1039 | 1049
1040 | 1040
1041 | 1050
1042 | 1050
1043 | 1043
1044 | 0
1045 | 1049
1046 | 1046
1047 | 0
1048 | 1050
1049 | 1049
1050 | 0
1051 | 0
1052 | 1052
1053 | 10
1054 | 1
1055 | 1055
1056 | 1062
1057 | 1062
1058 | 1058
1059 | 0
1060 | 1062
1061 | 1061
1062 | 1
1063 | 0
1064 | 1064
1065 | 0
1066 | 0
1067 | 1067
1068 | 1
1069 | 1
1070 | 1070
1071 | 6
1072 | 46
1073 | 1073
1074 | 0
1075 | 0
1076 | 953
1077 | 42
1078 | -1
1079 | 1079
1080 | 0
1081 | 0
1082 | 953
1083 | 1097
1084 | 1097
1085 | 1085
1086 | 44
1087 | 0
1088 | 1088
1089 | 0
1090 | 1097
1091 | 1091
1092 | 0
1093 | 0
1094 | 1094
1095 | 41
1096 | 41
1097 | 1097
1098 | 0
1099 | 0
1100 | 1100
1101 | 0
1102 | 41
1103 | 1103
1104 | 0
1105 | 0
1106 | 1106
1107 | 7
1108 | 44
1109 | 1109
1110 | 0
1111 | 0
1112 | 281
1113 | 6
1114 | 41
1115 | 1115
1116 | 0
1117 | 0
1118 | 281
1119 | 10
1120 | 10
1121 | 1121
1122 | 42
1123 | 0
1124 | 1124
1125 | 0
1126 | 10
1127 | 1127
1128 | 0
1129 | 0
1130 | 1130
1131 | 1145
1132 | 1145
1133 | 1133
1134 | 46
1135 | 0
1136 | 1136
1137 | 0
1138 | 1145
1139 | 1139
1140 | 0
1141 | 0
1142 | 1142
1143 | 42
1144 | 42
1145 | 1145
1146 | 0
1147 | 0
1148 | 1148
1149 | 0
1150 | 42
1151 | 1151
1152 | 0
1153 | 0
1154 | 1154
1155 | 6
1156 | 46
1157 | 1157
1158 | 10
1159 | 0
1160 | 1163
1161 | 0
1162 | 0
1163 | 1169
1164 | 0
1165 | 0
1166 | 1166
1167 | 0
1168 | 10
1169 | 1172
1170 | 0
1171 | 0
1172 | 1112
1173 | 7
1174 | 10
1175 | 1175
1176 | 0
1177 | 10
1178 | 1181
1179 | 0
1180 | 0
1181 | 1112
1182 | 1196
1183 | 1196
1184 | 1184
1185 | 41
1186 | 0
1187 | 1187
1188 | 0
1189 | 1196
1190 | 1190
1191 | 0
1192 | 0
1193 | 1193
1194 | 41
1195 | 41
1196 | 1196
1197 | 0
1198 | 0
1199 | 1199
1200 | 0
1201 | 41
1202 | 1202
1203 | 0
1204 | 0
1205 | 1205
1206 | 0
1207 | 0
1208 | 281
1209 | 1223
1210 | 1223
1211 | 1211
1212 | 44
1213 | 0
1214 | 1214
1215 | 0
1216 | 1223
1217 | 1217
1218 | 0
1219 | 0
1220 | 1220
1221 | 10
1222 | 10
1223 | 1223
1224 | 0
1225 | 0
1226 | 1226
1227 | 0
1228 | 10
1229 | 1229
1230 | 0
1231 | 0
1232 | 1232
1233 | 0
1234 | 10
1235 | 1277
1236 | 7
1237 | 10
1238 | 1238
1239 | 44
1240 | 0
1241 | 1241
1242 | 1253
1243 | 1253
1244 | 1244
1245 | 1254
1246 | 1254
1247 | 1247
1248 | 0
1249 | 1253
1250 | 1250
1251 | 0
1252 | 1254
1253 | 1253
1254 | 0
1255 | 0
1256 | 1256
1257 | 10
1258 | 1
1259 | 1259
1260 | 1266
1261 | 1266
1262 | 1262
1263 | 0
1264 | 1266
1265 | 1265
1266 | 1
1267 | 0
1268 | 1268
1269 | 0
1270 | 0
1271 | 1271
1272 | 1
1273 | 1
1274 | 1274
1275 | 0
1276 | 0
1277 | 1181
1278 | 7
1279 | 44
1280 | 1280
1281 | 0
1282 | 0
1283 | 1112
1284 | 42
1285 | 0
1286 | 1289
1287 | 0
1288 | 0
1289 | 1295
1290 | 0
1291 | 0
1292 | 1292
1293 | 0
1294 | 42
1295 | 1301
1296 | 42
1297 | 42
1298 | 1298
1299 | 0
1300 | 0
1301 | 1319
1302 | 7
1303 | 42
1304 | 1304
1305 | 0
1306 | 42
1307 | 1313
1308 | 42
1309 | 42
1310 | 1310
1311 | 0
1312 | 0
1313 | 1319
1314 | 42
1315 | 42
1316 | 1316
1317 | 7
1318 | 42
1319 | 1319
1320 | 0
1321 | 0
1322 | 281
1323 | 0
1324 | 42
1325 | 1328
1326 | 42
1327 | 42
1328 | 281
1329 | 42
1330 | 42
1331 | 1331
1332 | 6
1333 | 42
1334 | 1334
1335 | 0
1336 | 0
1337 | 281
1338 | 46
1339 | 0
1340 | 1340
1341 | 1347
1342 | 1347
1343 | 1343
1344 | 0
1345 | 1347
1346 | 1346
1347 | 42
1348 | 0
1349 | 1349
1350 | 0
1351 | 0
1352 | 1352
1353 | 0
1354 | 0
1355 | 953
1356 | 46
1357 | 0
1358 | 1358
1359 | 42
1360 | 1
1361 | 1361
1362 | 1368
1363 | 1368
1364 | 1364
1365 | 0
1366 | 1368
1367 | 1367
1368 | 1
1369 | 0
1370 | 1370
1371 | 0
1372 | 0
1373 | 1373
1374 | 1
1375 | 1
1376 | 1376
1377 | 0
1378 | 0
1379 | 953
1380 | 10
1381 | 10
1382 | 1382
1383 | 8
1384 | 0
1385 | 1385
1386 | 0
1387 | 10
1388 | 1388
1389 | 0
1390 | 0
1391 | 1391
1392 | 42
1393 | 10
1394 | 1394
1395 | 1409
1396 | 1409
1397 | 1397
1398 | 46
1399 | 0
1400 | 1400
1401 | 0
1402 | 1409
1403 | 1403
1404 | 0
1405 | 0
1406 | 1406
1407 | 42
1408 | 42
1409 | 1409
1410 | 0
1411 | 0
1412 | 1412
1413 | 0
1414 | 42
1415 | 1415
1416 | 0
1417 | 0
1418 | 1418
1419 | 6
1420 | 46
1421 | 1421
1422 | 11
1423 | 11
1424 | 1424
1425 | 11
1426 | 0
1427 | 1427
1428 | 0
1429 | 11
1430 | 1430
1431 | 0
1432 | 0
1433 | 1433
1434 | 0
1435 | 42
1436 | 1439
1437 | 0
1438 | 0
1439 | 1463
1440 | 12
1441 | 12
1442 | 1442
1443 | 42
1444 | 0
1445 | 1445
1446 | 0
1447 | 12
1448 | 1448
1449 | 0
1450 | 0
1451 | 1451
1452 | 6
1453 | 12
1454 | 1454
1455 | 0
1456 | 12
1457 | 1460
1458 | 0
1459 | 0
1460 | 1463
1461 | 6
1462 | 11
1463 | 1463
1464 | 42
1465 | 0
1466 | 1466
1467 | 0
1468 | 42
1469 | 1469
1470 | 0
1471 | 0
1472 | 1472
1473 | 7
1474 | 10
1475 | 1475
1476 | 0
1477 | 10
1478 | 1481
1479 | 0
1480 | 0
1481 | 1424
1482 | 42
1483 | 42
1484 | 1484
1485 | 11
1486 | 0
1487 | 1487
1488 | 0
1489 | 42
1490 | 1490
1491 | 0
1492 | 0
1493 | 1493
1494 | 0
1495 | 0
1496 | 281
1497 | 10
1498 | 10
1499 | 1499
1500 | 8
1501 | 0
1502 | 1502
1503 | 0
1504 | 10
1505 | 1505
1506 | 0
1507 | 0
1508 | 1508
1509 | 11
1510 | 11
1511 | 1511
1512 | 1526
1513 | 1526
1514 | 1514
1515 | 46
1516 | 0
1517 | 1517
1518 | 0
1519 | 1526
1520 | 1520
1521 | 0
1522 | 0
1523 | 1523
1524 | 13
1525 | 13
1526 | 1526
1527 | 0
1528 | 0
1529 | 1529
1530 | 0
1531 | 13
1532 | 1532
1533 | 0
1534 | 0
1535 | 1535
1536 | 6
1537 | 46
1538 | 1538
1539 | 1553
1540 | 1553
1541 | 1541
1542 | 46
1543 | 0
1544 | 1544
1545 | 0
1546 | 1553
1547 | 1547
1548 | 0
1549 | 0
1550 | 1550
1551 | 14
1552 | 14
1553 | 1553
1554 | 0
1555 | 0
1556 | 1556
1557 | 0
1558 | 14
1559 | 1559
1560 | 0
1561 | 0
1562 | 1562
1563 | 6
1564 | 46
1565 | 1565
1566 | 11
1567 | 0
1568 | 1568
1569 | 0
1570 | 11
1571 | 1571
1572 | 0
1573 | 0
1574 | 1574
1575 | 0
1576 | 42
1577 | 1592
1578 | 12
1579 | 12
1580 | 1580
1581 | 13
1582 | 0
1583 | 1583
1584 | 0
1585 | 12
1586 | 1586
1587 | 0
1588 | 0
1589 | 1589
1590 | 0
1591 | 0
1592 | 1628
1593 | 12
1594 | 12
1595 | 1595
1596 | 42
1597 | 0
1598 | 1598
1599 | 0
1600 | 12
1601 | 1601
1602 | 0
1603 | 0
1604 | 1604
1605 | 6
1606 | 12
1607 | 1607
1608 | 0
1609 | 12
1610 | 1616
1611 | 0
1612 | 0
1613 | 1577
1614 | 0
1615 | 0
1616 | 1628
1617 | 12
1618 | 12
1619 | 1619
1620 | 14
1621 | 0
1622 | 1622
1623 | 0
1624 | 12
1625 | 1625
1626 | 0
1627 | 0
1628 | 1628
1629 | 0
1630 | 12
1631 | 1634
1632 | 0
1633 | 0
1634 | 1646
1635 | 6
1636 | 12
1637 | 1637
1638 | 0
1639 | 12
1640 | 1643
1641 | 0
1642 | 0
1643 | 1646
1644 | 6
1645 | 11
1646 | 1646
1647 | 42
1648 | 0
1649 | 1649
1650 | 0
1651 | 42
1652 | 1652
1653 | 0
1654 | 0
1655 | 1655
1656 | 13
1657 | 0
1658 | 1658
1659 | 0
1660 | 13
1661 | 1661
1662 | 0
1663 | 0
1664 | 1664
1665 | 14
1666 | 0
1667 | 1667
1668 | 0
1669 | 14
1670 | 1670
1671 | 0
1672 | 0
1673 | 1673
1674 | 7
1675 | 10
1676 | 1676
1677 | 0
1678 | 10
1679 | 1682
1680 | 0
1681 | 0
1682 | 1565
1683 | 42
1684 | 42
1685 | 1685
1686 | 11
1687 | 0
1688 | 1688
1689 | 0
1690 | 42
1691 | 1691
1692 | 0
1693 | 0
1694 | 1694
1695 | 0
1696 | 0
1697 | 281
1698 | 1712
1699 | 1712
1700 | 1700
1701 | 46
1702 | 0
1703 | 1703
1704 | 0
1705 | 1712
1706 | 1706
1707 | 0
1708 | 0
1709 | 1709
1710 | 10
1711 | 10
1712 | 1712
1713 | 0
1714 | 0
1715 | 1715
1716 | 0
1717 | 10
1718 | 1718
1719 | 0
1720 | 0
1721 | 1721
1722 | 11
1723 | 11
1724 | 1724
1725 | 6
1726 | 11
1727 | 1727
1728 | 42
1729 | 10
1730 | 1730
1731 | 10
1732 | 0
1733 | 1736
1734 | 0
1735 | 0
1736 | 1739
1737 | 0
1738 | 0
1739 | 1802
1740 | 42
1741 | 0
1742 | 1742
1743 | 0
1744 | 10
1745 | 1745
1746 | 0
1747 | 0
1748 | 1748
1749 | 7
1750 | 11
1751 | 1751
1752 | 42
1753 | 42
1754 | 1754
1755 | 11
1756 | 0
1757 | 1757
1758 | 0
1759 | 42
1760 | 1760
1761 | 0
1762 | 0
1763 | 1763
1764 | 46
1765 | 0
1766 | 1766
1767 | 1778
1768 | 1778
1769 | 1769
1770 | 1779
1771 | 1779
1772 | 1772
1773 | 0
1774 | 1778
1775 | 1775
1776 | 0
1777 | 1779
1778 | 1778
1779 | 0
1780 | 0
1781 | 1781
1782 | 10
1783 | 1
1784 | 1784
1785 | 1791
1786 | 1791
1787 | 1787
1788 | 0
1789 | 1791
1790 | 1790
1791 | 1
1792 | 0
1793 | 1793
1794 | 0
1795 | 0
1796 | 1796
1797 | 1
1798 | 1
1799 | 1799
1800 | 0
1801 | 0
1802 | 281
1803 | 0
1804 | 0
1805 | 1724
1806 | 0
1807 | 39
1808 | 1811
1809 | 0
1810 | 0
1811 | 281
1812 | 1826
1813 | 1826
1814 | 1814
1815 | 20
1816 | 0
1817 | 1817
1818 | 0
1819 | 1826
1820 | 1820
1821 | 0
1822 | 0
1823 | 1823
1824 | 10
1825 | 10
1826 | 1826
1827 | 0
1828 | 0
1829 | 1829
1830 | 0
1831 | 10
1832 | 1832
1833 | 0
1834 | 0
1835 | 1835
1836 | 0
1837 | 10
1838 | 2171
1839 | 6
1840 | 38
1841 | 1841
1842 | 11
1843 | 11
1844 | 1844
1845 | 20
1846 | 0
1847 | 1847
1848 | 0
1849 | 11
1850 | 1850
1851 | 0
1852 | 0
1853 | 1853
1854 | 6
1855 | 11
1856 | 1856
1857 | 11
1858 | 0
1859 | 1859
1860 | 1871
1861 | 1871
1862 | 1862
1863 | 1872
1864 | 1872
1865 | 1865
1866 | 0
1867 | 1871
1868 | 1868
1869 | 0
1870 | 1872
1871 | 1871
1872 | 0
1873 | 0
1874 | 1874
1875 | 41
1876 | 1
1877 | 1877
1878 | 1884
1879 | 1884
1880 | 1880
1881 | 0
1882 | 1884
1883 | 1883
1884 | 1
1885 | 0
1886 | 1886
1887 | 0
1888 | 0
1889 | 1889
1890 | 1
1891 | 1
1892 | 1892
1893 | 6
1894 | 11
1895 | 1895
1896 | 11
1897 | 0
1898 | 1898
1899 | 1910
1900 | 1910
1901 | 1901
1902 | 1911
1903 | 1911
1904 | 1904
1905 | 0
1906 | 1910
1907 | 1907
1908 | 0
1909 | 1911
1910 | 1910
1911 | 0
1912 | 0
1913 | 1913
1914 | 42
1915 | 1
1916 | 1916
1917 | 1923
1918 | 1923
1919 | 1919
1920 | 0
1921 | 1923
1922 | 1922
1923 | 1
1924 | 0
1925 | 1925
1926 | 0
1927 | 0
1928 | 1928
1929 | 1
1930 | 1
1931 | 1931
1932 | 6
1933 | 11
1934 | 1934
1935 | 11
1936 | 0
1937 | 1937
1938 | 1949
1939 | 1949
1940 | 1940
1941 | 1950
1942 | 1950
1943 | 1943
1944 | 0
1945 | 1949
1946 | 1946
1947 | 0
1948 | 1950
1949 | 1949
1950 | 0
1951 | 0
1952 | 1952
1953 | 44
1954 | 1
1955 | 1955
1956 | 1962
1957 | 1962
1958 | 1958
1959 | 0
1960 | 1962
1961 | 1961
1962 | 1
1963 | 0
1964 | 1964
1965 | 0
1966 | 0
1967 | 1967
1968 | 1
1969 | 1
1970 | 1970
1971 | 6
1972 | 11
1973 | 1973
1974 | 11
1975 | 0
1976 | 1976
1977 | 1988
1978 | 1988
1979 | 1979
1980 | 1989
1981 | 1989
1982 | 1982
1983 | 0
1984 | 1988
1985 | 1985
1986 | 0
1987 | 1989
1988 | 1988
1989 | 0
1990 | 0
1991 | 1991
1992 | 46
1993 | 1
1994 | 1994
1995 | 2001
1996 | 2001
1997 | 1997
1998 | 0
1999 | 2001
2000 | 2000
2001 | 1
2002 | 0
2003 | 2003
2004 | 0
2005 | 0
2006 | 2006
2007 | 1
2008 | 1
2009 | 2009
2010 | 43
2011 | 43
2012 | 2012
2013 | 10
2014 | 0
2015 | 2015
2016 | 0
2017 | 43
2018 | 2018
2019 | 0
2020 | 0
2021 | 2021
2022 | 5
2023 | 0
2024 | 2024
2025 | 0
2026 | 43
2027 | 2027
2028 | 0
2029 | 0
2030 | 2030
2031 | 45
2032 | 45
2033 | 2033
2034 | 43
2035 | 0
2036 | 2036
2037 | 0
2038 | 45
2039 | 2039
2040 | 0
2041 | 0
2042 | 2042
2043 | 5
2044 | 0
2045 | 2045
2046 | 0
2047 | 45
2048 | 2048
2049 | 0
2050 | 0
2051 | 2051
2052 | 20
2053 | 20
2054 | 2054
2055 | 10
2056 | 0
2057 | 2057
2058 | 0
2059 | 20
2060 | 2060
2061 | 0
2062 | 0
2063 | 2063
2064 | 6
2065 | 10
2066 | 2066
2067 | 2081
2068 | 2081
2069 | 2069
2070 | 10
2071 | 0
2072 | 2072
2073 | 0
2074 | 2081
2075 | 2075
2076 | 0
2077 | 0
2078 | 2078
2079 | 41
2080 | 41
2081 | 2081
2082 | 0
2083 | 0
2084 | 2084
2085 | 0
2086 | 41
2087 | 2087
2088 | 0
2089 | 0
2090 | 2090
2091 | 6
2092 | 10
2093 | 2093
2094 | 2108
2095 | 2108
2096 | 2096
2097 | 10
2098 | 0
2099 | 2099
2100 | 0
2101 | 2108
2102 | 2102
2103 | 0
2104 | 0
2105 | 2105
2106 | 42
2107 | 42
2108 | 2108
2109 | 0
2110 | 0
2111 | 2111
2112 | 0
2113 | 42
2114 | 2114
2115 | 0
2116 | 0
2117 | 2117
2118 | 6
2119 | 10
2120 | 2120
2121 | 2135
2122 | 2135
2123 | 2123
2124 | 10
2125 | 0
2126 | 2126
2127 | 0
2128 | 2135
2129 | 2129
2130 | 0
2131 | 0
2132 | 2132
2133 | 44
2134 | 44
2135 | 2135
2136 | 0
2137 | 0
2138 | 2138
2139 | 0
2140 | 44
2141 | 2141
2142 | 0
2143 | 0
2144 | 2144
2145 | 6
2146 | 10
2147 | 2147
2148 | 2162
2149 | 2162
2150 | 2150
2151 | 10
2152 | 0
2153 | 2153
2154 | 0
2155 | 2162
2156 | 2156
2157 | 0
2158 | 0
2159 | 2159
2160 | 46
2161 | 46
2162 | 2162
2163 | 0
2164 | 0
2165 | 2165
2166 | 0
2167 | 46
2168 | 2168
2169 | 0
2170 | 0
2171 | 2171
2172 | 0
2173 | 0
2174 | 281
2175 | 0
2176 | 11009
2177 | 1355
2178 | 1082
2179 | 4348
2180 | 11521
2181 | 1337
2182 | 1082
2183 | 4356
2184 | 25091
2185 | 25977
2186 | 128
2187 | 1082
2188 | 4364
2189 | 25603
2190 | 28789
2191 | 803
2192 | 1082
2193 | 4374
2194 | 25604
2195 | 28530
2196 | 112
2197 | 953
2198 | 1082
2199 | 4384
2200 | 29444
2201 | 24951
2202 | 112
2203 | 728
2204 | 1082
2205 | 4396
2206 | 29190
2207 | 26739
2208 | 26217
2209 | 116
2210 | 1379
2211 | 1082
2212 | 0
2213 | 23299
2214 | 23872
2215 | 983
2216 | 1082
2217 | 4422
2218 | 23299
2219 | 23841
2220 | 1010
2221 | 1082
2222 | 4408
2223 | 12290
2224 | 61
2225 | 1283
2226 | 1082
2227 | 4432
2228 | 27652
2229 | 29029
2230 | 48
2231 | 1322
2232 | 1082
2233 | 4452
2234 | 27907
2235 | 30837
2236 | 1496
2237 | 1082
2238 | 4464
2239 | 28677
2240 | 30049
2241 | 25971
2242 | 1805
2243 | 1082
2244 | 4442
2245 | 12802
2246 | 42
2247 | 803
2248 | 1355
2249 | 1082
2250 | 4474
2251 | 10279
2252 | 28515
2253 | 29550
2254 | 10612
2255 | 845
2256 | 983
2257 | 1082
2258 | 4498
2259 | 8962
2260 | 48
2261 | 2254
2262 | 0
2263 | 4514
2264 | 8962
2265 | 49
2266 | 2254
2267 | 1
2268 | 4524
2269 | 8963
2270 | 12589
2271 | 2254
2272 | -1
2273 | 4534
2274 | 8962
2275 | 50
2276 | 2254
2277 | 2
2278 | 4544
2279 | 11525
2280 | 25955
2281 | 27756
2282 | 2254
2283 | -2
2284 | 4486
2285 | 12546
2286 | 43
2287 | 2265
2288 | 1355
2289 | 1082
2290 | 4566
2291 | 12546
2292 | 45
2293 | 2265
2294 | 1337
2295 | 1082
2296 | 4554
2297 | 10246
2298 | 30064
2299 | 26739
2300 | 41
2301 | 845
2302 | 803
2303 | 983
2304 | 728
2305 | 2286
2306 | 914
2307 | 1082
2308 | 4590
2309 | 10276
2310 | 28789
2311 | 41
2312 | 845
2313 | 803
2314 | 983
2315 | 2300
2316 | 20
2317 | 983
2318 | 2246
2319 | 1355
2320 | 728
2321 | 2286
2322 | 914
2323 | 1082
2324 | 4614
2325 | 10277
2326 | 24950
2327 | 10610
2328 | 845
2329 | 2246
2330 | 1082
2331 | 4646
2332 | 10278
2333 | 29557
2334 | 29285
2335 | 41
2336 | 845
2337 | 983
2338 | 2300
2339 | 20
2340 | 983
2341 | 2246
2342 | 1355
2343 | 1082
2344 | 4578
2345 | 10561
2346 | 1082
2347 | 4686
2348 | 28420
2349 | 25974
2350 | 114
2351 | 728
2352 | 803
2353 | 914
2354 | 728
2355 | 845
2356 | 1082
2357 | 4692
2358 | 26886
2359 | 30318
2360 | 29285
2361 | 116
2362 | 2270
2363 | 728
2364 | 1337
2365 | 1082
2366 | 4712
2367 | 30723
2368 | 29295
2369 | 914
2370 | 803
2371 | 2361
2372 | 728
2373 | 845
2374 | 1496
2375 | 1082
2376 | 4730
2377 | 28418
2378 | 114
2379 | 2350
2380 | 1496
2381 | 1082
2382 | 4750
2383 | 24835
2384 | 25710
2385 | 2260
2386 | 728
2387 | 1496
2388 | 1082
2389 | 4762
2390 | 12802
2391 | 47
2392 | 2265
2393 | 1379
2394 | 1082
2395 | 4776
2396 | 16385
2397 | 2391
2398 | 983
2399 | 1082
2400 | 4788
2401 | 8449
2402 | 2391
2403 | 1010
2404 | 1082
2405 | 4660
2406 | 16386
2407 | 43
2408 | 803
2409 | 2396
2410 | 1082
2411 | 4798
2412 | 15364
2413 | 27503
2414 | 62
2415 | 2335
2416 | 20
2417 | 4808
2418 | 15366
2419 | 28005
2420 | 29801
2421 | 62
2422 | 2335
2423 | 22
2424 | 4832
2425 | 15365
2426 | 25963
2427 | 15993
2428 | 2335
2429 | 24
2430 | 4846
2431 | 15366
2432 | 25445
2433 | 28520
2434 | 62
2435 | 2335
2436 | 26
2437 | 4858
2438 | 15369
2439 | 26988
2440 | 25972
2441 | 24946
2442 | 15980
2443 | 2335
2444 | 28
2445 | 4872
2446 | 15365
2447 | 24948
2448 | 15984
2449 | 2335
2450 | 30
2451 | 4888
2452 | 15368
2453 | 30821
2454 | 25968
2455 | 29795
2456 | 62
2457 | 2335
2458 | 32
2459 | 4900
2460 | 15367
2461 | 29285
2462 | 28530
2463 | 15986
2464 | 2335
2465 | 34
2466 | 4916
2467 | 15366
2468 | 28514
2469 | 29807
2470 | 62
2471 | 2300
2472 | 70
2473 | 1082
2474 | 4930
2475 | 15366
2476 | 30065
2477 | 29801
2478 | 62
2479 | 2300
2480 | 72
2481 | 1082
2482 | 4820
2483 | 25351
2484 | 29301
2485 | 25970
2486 | 29806
2487 | 2300
2488 | 60
2489 | 1082
2490 | 4962
2491 | 29192
2492 | 28527
2493 | 11636
2494 | 28534
2495 | 99
2496 | 2300
2497 | 66
2498 | 1082
2499 | 4978
2500 | 29700
2501 | 26984
2502 | 115
2503 | 2311
2504 | 0
2505 | 1082
2506 | 4996
2507 | 28675
2508 | 25697
2509 | 2502
2510 | 2300
2511 | 960
2512 | 1355
2513 | 1082
2514 | 5010
2515 | 8965
2516 | 28534
2517 | 29539
2518 | 2254
2519 | 8
2520 | 5026
2521 | 25351
2522 | 28271
2523 | 25972
2524 | 29816
2525 | 2300
2526 | 44
2527 | 1082
2528 | 5038
2529 | 25091
2530 | 27500
2531 | 2327
2532 | 0
2533 | 5054
2534 | 29443
2535 | 29283
2536 | 2327
2537 | 47
2538 | 5064
2539 | 25092
2540 | 29537
2541 | 101
2542 | 2335
2543 | 36
2544 | 5074
2545 | 25603
2546 | 27760
2547 | 2335
2548 | 38
2549 | 5086
2550 | 26627
2551 | 25708
2552 | 2335
2553 | 40
2554 | 5096
2555 | 29445
2556 | 24948
2557 | 25972
2558 | 2335
2559 | 42
2560 | 5106
2561 | 15875
2562 | 28265
2563 | 2335
2564 | 44
2565 | 5118
2566 | 29444
2567 | 24944
2568 | 110
2569 | 2335
2570 | 46
2571 | 5128
2572 | 25090
2573 | 108
2574 | 2254
2575 | 32
2576 | 4946
2577 | 26626
2578 | 63
2579 | 2254
2580 | 38
2581 | 5150
2582 | 25350
2583 | 25465
2584 | 25964
2585 | 115
2586 | 2254
2587 | 76
2588 | 5160
2589 | 29442
2590 | 112
2591 | 2254
2592 | 92
2593 | 5174
2594 | 29957
2595 | 25971
2596 | 16242
2597 | 2254
2598 | 80
2599 | 5184
2600 | 25355
2601 | 27745
2602 | 25193
2603 | 24946
2604 | 26996
2605 | 28271
2606 | 2327
2607 | 5120
2608 | 5196
2609 | 29189
2610 | 25697
2611 | 30825
2612 | 2541
2613 | 2396
2614 | 1082
2615 | 5140
2616 | 26628
2617 | 29285
2618 | 101
2619 | 2578
2620 | 2396
2621 | 1082
2622 | 5228
2623 | 29443
2624 | 16496
2625 | 2590
2626 | 2396
2627 | 2286
2628 | 1082
2629 | 5242
2630 | 29443
2631 | 8560
2632 | 2292
2633 | 2300
2634 | 46
2635 | 1010
2636 | 2265
2637 | 953
2638 | 1082
2639 | 5256
2640 | 29219
2641 | 16496
2642 | 2300
2643 | 44
2644 | 983
2645 | 2292
2646 | 1082
2647 | 5276
2648 | 29219
2649 | 8560
2650 | 845
2651 | 728
2652 | 2300
2653 | 44
2654 | 1010
2655 | 914
2656 | 1082
2657 | 5292
2658 | 26627
2659 | 30821
2660 | 2300
2661 | 16
2662 | 2541
2663 | 2401
2664 | 1082
2665 | 5312
2666 | 25607
2667 | 25445
2668 | 28009
2669 | 27745
2670 | 2300
2671 | 10
2672 | 2541
2673 | 2401
2674 | 1082
2675 | 5328
2676 | 23809
2677 | 2270
2678 | 2557
2679 | 2401
2680 | 1082
2681 | 5348
2682 | 23361
2683 | 2260
2684 | 2557
2685 | 2401
2686 | 1082
2687 | 5360
2688 | 28163
2689 | 28777
2690 | 728
2691 | 953
2692 | 1082
2693 | 5372
2694 | 29700
2695 | 25461
2696 | 107
2697 | 728
2698 | 2350
2699 | 1082
2700 | 5384
2701 | 16132
2702 | 30052
2703 | 112
2704 | 803
2705 | 1118
2706 | 2707
2707 | 803
2708 | 1082
2709 | 5398
2710 | 29218
2711 | 64
2712 | 845
2713 | 845
2714 | 2696
2715 | 914
2716 | 914
2717 | 1082
2718 | 5416
2719 | 29187
2720 | 29807
2721 | 914
2722 | 728
2723 | 845
2724 | 728
2725 | 1082
2726 | 5434
2727 | 11524
2728 | 28530
2729 | 116
2730 | 2720
2731 | 2720
2732 | 1082
2733 | 5450
2734 | 12805
2735 | 29284
2736 | 28783
2737 | 953
2738 | 953
2739 | 1082
2740 | 5464
2741 | 12804
2742 | 30052
2743 | 112
2744 | 2350
2745 | 2350
2746 | 1082
2747 | 5214
2748 | 29444
2749 | 25960
2750 | 100
2751 | 2720
2752 | 953
2753 | 1082
2754 | 5478
2755 | 15617
2756 | 1337
2757 | 1283
2758 | 1082
2759 | 5506
2760 | 15362
2761 | 62
2762 | 2755
2763 | 1283
2764 | 1082
2765 | 5516
2766 | 12290
2767 | 62
2768 | 1322
2769 | 1283
2770 | 1082
2771 | 5528
2772 | 12291
2773 | 15932
2774 | 1283
2775 | 1283
2776 | 1082
2777 | 5540
2778 | 12291
2779 | 15676
2780 | 2767
2781 | 1283
2782 | 1082
2783 | 5552
2784 | 15361
2785 | 2743
2786 | 1322
2787 | 728
2788 | 1322
2789 | 1118
2790 | 2815
2791 | 1118
2792 | 2810
2793 | 2743
2794 | 2286
2795 | 1322
2796 | 728
2797 | 2286
2798 | 1322
2799 | 1118
2800 | 2803
2801 | 953
2802 | 1181
2803 | 2808
2804 | 1118
2805 | 2808
2806 | 2736
2807 | 2260
2808 | 1082
2809 | 1181
2810 | 2813
2811 | 2736
2812 | 2270
2813 | 1082
2814 | 1181
2815 | 2820
2816 | 1118
2817 | 2820
2818 | 2736
2819 | 2260
2820 | 1082
2821 | 2743
2822 | 1337
2823 | 1322
2824 | 1118
2825 | 2836
2826 | 728
2827 | 2286
2828 | 728
2829 | 1337
2830 | 1322
2831 | 1118
2832 | 2834
2833 | 2270
2834 | 1082
2835 | 2260
2836 | 1082
2837 | 2736
2838 | 2260
2839 | 1082
2840 | 5564
2841 | 15873
2842 | 728
2843 | 2784
2844 | 1082
2845 | 5678
2846 | 12290
2847 | 60
2848 | 2260
2849 | 2784
2850 | 1082
2851 | 5688
2852 | 12291
2853 | 15678
2854 | 2847
2855 | 1283
2856 | 1082
2857 | 5700
2858 | 15874
2859 | 61
2860 | 2784
2861 | 1283
2862 | 1082
2863 | 5712
2864 | 15362
2865 | 61
2866 | 2841
2867 | 1283
2868 | 1082
2869 | 5724
2870 | 29954
2871 | 60
2872 | 2743
2873 | 2853
2874 | 728
2875 | 2853
2876 | 2761
2877 | 914
2878 | 2784
2879 | 845
2880 | 2761
2881 | 1082
2882 | 5736
2883 | 29954
2884 | 62
2885 | 728
2886 | 2871
2887 | 1082
2888 | 5762
2889 | 29955
2890 | 15678
2891 | 2871
2892 | 1283
2893 | 1082
2894 | 5774
2895 | 29955
2896 | 15676
2897 | 2884
2898 | 1283
2899 | 1082
2900 | 5786
2901 | 30470
2902 | 29801
2903 | 26984
2904 | 110
2905 | 2350
2906 | 1337
2907 | 914
2908 | 1337
2909 | 845
2910 | 2871
2911 | 1082
2912 | 5798
2913 | 28166
2914 | 26469
2915 | 29793
2916 | 101
2917 | 2292
2918 | 2361
2919 | 1082
2920 | 5822
2921 | 29443
2922 | 25662
2923 | 803
2924 | 2847
2925 | 1082
2926 | 5838
2927 | 24835
2928 | 29538
2929 | 2922
2930 | 1118
2931 | 2932
2932 | 2916
2933 | 1082
2934 | 5850
2935 | 25348
2936 | 27749
2937 | 108
2938 | 2254
2939 | 2
2940 | 5866
2941 | 25349
2942 | 27749
2943 | 11116
2944 | 2937
2945 | 1355
2946 | 1082
2947 | 5878
2948 | 25349
2949 | 27749
2950 | 29548
2951 | 2246
2952 | 1082
2953 | 5892
2954 | 25349
2955 | 27749
2956 | 11628
2957 | 2937
2958 | 1337
2959 | 1082
2960 | 5904
2961 | 25863
2962 | 25976
2963 | 30051
2964 | 25972
2965 | 2391
2966 | 914
2967 | 1082
2968 | 5492
2969 | 16392
2970 | 30821
2971 | 25445
2972 | 29813
2973 | 101
2974 | 2396
2975 | 2964
2976 | 1082
2977 | 5918
2978 | 16165
2979 | 30821
2980 | 29801
2981 | 1118
2982 | 2983
2983 | 1106
2984 | 1082
2985 | 5952
2986 | 27396
2987 | 31077
2988 | 63
2989 | 1805
2990 | 2270
2991 | 983
2992 | 2916
2993 | 2922
2994 | 1118
2995 | 3007
2996 | 2300
2997 | 6
2998 | 2396
2999 | 2300
3000 | 8
3001 | 2384
3002 | 1118
3003 | 3004
3004 | 128
3005 | 953
3006 | 2260
3007 | 1082
3008 | 2270
3009 | 1082
3010 | 5968
3011 | 27395
3012 | 31077
3013 | 2427
3014 | 2973
3015 | 1118
3016 | 3012
3017 | 1082
3018 | 6018
3019 | 25860
3020 | 26989
3021 | 116
3022 | 2421
3023 | 2973
3024 | 1082
3025 | 6034
3026 | 25346
3027 | 114
3028 | 2300
3029 | 13
3030 | 3021
3031 | 2300
3032 | 10
3033 | 3021
3034 | 1082
3035 | 6048
3036 | 26379
3037 | 29797
3038 | 25389
3039 | 29301
3040 | 25970
3041 | 29806
3042 | 2486
3043 | 2396
3044 | 1082
3045 | 6068
3046 | 29451
3047 | 29797
3048 | 25389
3049 | 29301
3050 | 25970
3051 | 29806
3052 | 2486
3053 | 2401
3054 | 1082
3055 | 5934
3056 | 27652
3057 | 29537
3058 | 116
3059 | 3041
3060 | 2396
3061 | 1082
3062 | 6088
3063 | 28676
3064 | 25449
3065 | 107
3066 | 2624
3067 | 1355
3068 | 983
3069 | 1082
3070 | 6122
3071 | 11010
3072 | 33
3073 | 2391
3074 | 2696
3075 | 983
3076 | 1355
3077 | 728
3078 | 1010
3079 | 1082
3080 | 6138
3081 | 27654
3082 | 26739
3083 | 26217
3084 | 116
3085 | 2916
3086 | 1379
3087 | 1082
3088 | 6158
3089 | 25346
3090 | 64
3091 | 2407
3092 | 728
3093 | 2265
3094 | 2384
3095 | 1118
3096 | 3100
3097 | 2300
3098 | 8
3099 | 1379
3100 | 1082
3101 | 2300
3102 | 255
3103 | 2384
3104 | 1082
3105 | 6174
3106 | 25346
3107 | 33
3108 | 728
3109 | 2300
3110 | 255
3111 | 2384
3112 | 803
3113 | 2300
3114 | 8
3115 | 3084
3116 | 2378
3117 | 728
3118 | 2696
3119 | 2407
3120 | 728
3121 | 2265
3122 | 2384
3123 | 1283
3124 | 2300
3125 | 255
3126 | 2368
3127 | 914
3128 | 2350
3129 | 2368
3130 | 845
3131 | 2384
3132 | 2368
3133 | 728
3134 | 2401
3135 | 1082
3136 | 6108
3137 | 25347
3138 | 11072
3139 | 803
3140 | 3090
3141 | 1082
3142 | 6208
3143 | 27907
3144 | 30817
3145 | 2743
3146 | 2841
3147 | 1496
3148 | 1082
3149 | 6282
3150 | 27907
3151 | 28265
3152 | 2743
3153 | 2784
3154 | 1496
3155 | 1082
3156 | 6296
3157 | 29449
3158 | 30063
3159 | 25458
3160 | 11621
3161 | 25705
3162 | 2311
3163 | 16
3164 | 2396
3165 | 1082
3166 | 6310
3167 | 12802
3168 | 33
3169 | 2696
3170 | 2401
3171 | 2943
3172 | 2401
3173 | 1082
3174 | 6330
3175 | 12802
3176 | 64
3177 | 803
3178 | 2943
3179 | 2396
3180 | 728
3181 | 2396
3182 | 1082
3183 | 6346
3184 | 12835
3185 | 29246
3186 | 845
3187 | 728
3188 | 914
3189 | 728
3190 | 914
3191 | 914
3192 | 1082
3193 | 6364
3194 | 12835
3195 | 15986
3196 | 845
3197 | 845
3198 | 728
3199 | 845
3200 | 728
3201 | 914
3202 | 1082
3203 | 6270
3204 | 29699
3205 | 28789
3206 | 2335
3207 | 48
3208 | 0
3209 | 6384
3210 | 29446
3211 | 30063
3212 | 25458
3213 | 101
3214 | 3205
3215 | 3176
3216 | 1082
3217 | 6416
3218 | 24839
3219 | 26988
3220 | 28263
3221 | 25701
3222 | 803
3223 | 2265
3224 | 2384
3225 | 2773
3226 | 2265
3227 | 2384
3228 | 1355
3229 | 1082
3230 | 6432
3231 | 24837
3232 | 26988
3233 | 28263
3234 | 2618
3235 | 3221
3236 | 2578
3237 | 2401
3238 | 1082
3239 | 6458
3240 | 24837
3241 | 27756
3242 | 29807
3243 | 2578
3244 | 3072
3245 | 1082
3246 | 6476
3247 | 11265
3248 | 3233
3249 | 2618
3250 | 2401
3251 | 2937
3252 | 3242
3253 | 1082
3254 | 6490
3255 | 25346
3256 | 44
3257 | 2618
3258 | 3107
3259 | 2265
3260 | 3242
3261 | 1082
3262 | 6506
3263 | 25349
3264 | 30063
3265 | 29806
3266 | 803
3267 | 2286
3268 | 728
3269 | 3090
3270 | 1082
3271 | 6522
3272 | 11015
3273 | 29811
3274 | 26994
3275 | 26478
3276 | 2265
3277 | 2350
3278 | 3151
3279 | 2720
3280 | 2350
3281 | 1355
3282 | 2729
3283 | 1337
3284 | 1082
3285 | 6404
3286 | 11781
3287 | 28005
3288 | 29801
3289 | 803
3290 | 2573
3291 | 2300
3292 | 127
3293 | 2904
3294 | 2300
3295 | 46
3296 | 728
3297 | 1496
3298 | 3021
3299 | 1082
3300 | 6540
3301 | 29700
3302 | 28793
3303 | 101
3304 | 2292
3305 | 914
3306 | 3265
3307 | 3021
3308 | 1208
3309 | 3305
3310 | 953
3311 | 1082
3312 | 6598
3313 | 25349
3314 | 28525
3315 | 25974
3316 | 2260
3317 | 3144
3318 | 914
3319 | 1181
3320 | 3327
3321 | 914
3322 | 3138
3323 | 2711
3324 | 3107
3325 | 2286
3326 | 845
3327 | 2286
3328 | 1208
3329 | 3320
3330 | 2736
3331 | 1082
3332 | 6622
3333 | 26116
3334 | 27753
3335 | 108
3336 | 728
3337 | 2260
3338 | 3144
3339 | 914
3340 | 728
3341 | 1181
3342 | 3345
3343 | 2743
3344 | 3107
3345 | 2286
3346 | 1208
3347 | 3342
3348 | 2736
3349 | 1082
3350 | 6662
3351 | 25861
3352 | 24946
3353 | 25971
3354 | 2260
3355 | 3335
3356 | 1082
3357 | 6568
3358 | 25603
3359 | 9327
3360 | 3195
3361 | 2246
3362 | 803
3363 | 3265
3364 | 1355
3365 | 3221
3366 | 2391
3367 | 914
3368 | 728
3369 | 914
3370 | 1082
3371 | 6712
3372 | 10243
3373 | 10532
3374 | 3359
3375 | 1082
3376 | 6740
3377 | 11778
3378 | 36
3379 | 3359
3380 | 3265
3381 | 3303
3382 | 1082
3383 | 6698
3384 | 29445
3385 | 24944
3386 | 25955
3387 | 2573
3388 | 3021
3389 | 1082
3390 | 6764
3391 | 25349
3392 | 29793
3393 | 26723
3394 | 2624
3395 | 914
3396 | 2311
3397 | 10
3398 | 2396
3399 | 914
3400 | 2641
3401 | 2311
3402 | 10
3403 | 2401
3404 | 2964
3405 | 845
3406 | 2311
3407 | 10
3408 | 2401
3409 | 1106
3410 | 2260
3411 | 1082
3412 | 6778
3413 | 29701
3414 | 29288
3415 | 30575
3416 | 2703
3417 | 1118
3418 | 3431
3419 | 2311
3420 | 10
3421 | 2396
3422 | 2649
3423 | 845
3424 | 2311
3425 | 10
3426 | 2401
3427 | 845
3428 | 728
3429 | 914
3430 | 2631
3431 | 845
3432 | 1082
3433 | 6822
3434 | 24837
3435 | 28514
3436 | 29810
3437 | 2270
3438 | 3415
3439 | 1082
3440 | 6750
3441 | 10247
3442 | 25185
3443 | 29295
3444 | 10612
3445 | 3359
3446 | 728
3447 | 1118
3448 | 3451
3449 | 3265
3450 | 3303
3451 | 3436
3452 | 953
3453 | 1082
3454 | 6878
3455 | 25605
3456 | 28773
3457 | 26740
3458 | 2300
3459 | 90
3460 | 2396
3461 | 2624
3462 | 1337
3463 | 2292
3464 | 1082
3465 | 6906
3466 | 16134
3467 | 25956
3468 | 29808
3469 | 104
3470 | 3457
3471 | 2859
3472 | 2300
3473 | -4
3474 | 2384
3475 | 3415
3476 | 1082
3477 | 6864
3478 | 29955
3479 | 11117
3480 | 2743
3481 | 1355
3482 | 914
3483 | 2711
3484 | 2853
3485 | 914
3486 | 2743
3487 | 2384
3488 | 2847
3489 | 845
3490 | 2378
3491 | 914
3492 | 2378
3493 | 2847
3494 | 845
3495 | 2384
3496 | 2916
3497 | 845
3498 | 728
3499 | 1082
3500 | 6952
3501 | 25607
3502 | 25966
3503 | 24935
3504 | 25972
3505 | 2361
3506 | 914
3507 | 2361
3508 | 2265
3509 | 3479
3510 | 845
3511 | 1355
3512 | 1082
3513 | 6998
3514 | 25602
3515 | 43
3516 | 914
3517 | 728
3518 | 914
3519 | 3479
3520 | 845
3521 | 1355
3522 | 845
3523 | 1355
3524 | 1082
3525 | 7024
3526 | 29955
3527 | 10861
3528 | 2260
3529 | 728
3530 | 2300
3531 | 15
3532 | 914
3533 | 803
3534 | 3479
3535 | 3185
3536 | 803
3537 | 3479
3538 | 845
3539 | 1355
3540 | 845
3541 | 1118
3542 | 3547
3543 | 914
3544 | 2350
3545 | 3479
3546 | 845
3547 | 1355
3548 | 1208
3549 | 3532
3550 | 2750
3551 | 1082
3552 | 7048
3553 | 10753
3554 | 3527
3555 | 953
3556 | 1082
3557 | 7102
3558 | 29958
3559 | 12141
3560 | 28525
3561 | 100
3562 | 2703
3563 | 1283
3564 | 2300
3565 | -10
3566 | 2384
3567 | 3415
3568 | 2743
3569 | 2871
3570 | 1118
3571 | 3609
3572 | 2916
3573 | 2300
3574 | 15
3575 | 914
3576 | 914
3577 | 803
3578 | 3479
3579 | 3185
3580 | 803
3581 | 3479
3582 | 845
3583 | 1355
3584 | 803
3585 | 845
3586 | 2711
3587 | 728
3588 | 914
3589 | 3479
3590 | 845
3591 | 2773
3592 | 728
3593 | 2773
3594 | 1355
3595 | 1118
3596 | 3602
3597 | 914
3598 | 953
3599 | 2286
3600 | 845
3601 | 1181
3602 | 3603
3603 | 953
3604 | 845
3605 | 1208
3606 | 3575
3607 | 953
3608 | 728
3609 | 1082
3610 | 2736
3611 | 953
3612 | 2270
3613 | 803
3614 | 1082
3615 | 7112
3616 | 27909
3617 | 27951
3618 | 25711
3619 | 2922
3620 | 803
3621 | 914
3622 | 1118
3623 | 3627
3624 | 2916
3625 | 914
3626 | 3504
3627 | 845
3628 | 914
3629 | 2922
3630 | 1118
3631 | 3633
3632 | 2711
3633 | 1355
3634 | 845
3635 | 3561
3636 | 845
3637 | 1118
3638 | 3641
3639 | 728
3640 | 2916
3641 | 728
3642 | 1082
3643 | 7228
3644 | 12036
3645 | 28525
3646 | 100
3647 | 2350
3648 | 2847
3649 | 728
3650 | 3618
3651 | 1082
3652 | 7284
3653 | 27907
3654 | 25711
3655 | 3646
3656 | 953
3657 | 1082
3658 | 7302
3659 | 12033
3660 | 3646
3661 | 2689
3662 | 1082
3663 | 6928
3664 | 10246
3665 | 28005
3666 | 29801
3667 | 41
3668 | 1805
3669 | 1076
3670 | 1082
3671 | 7314
3672 | 25860
3673 | 26723
3674 | 111
3675 | 2434
3676 | 2973
3677 | 1082
3678 | 7324
3679 | 29699
3680 | 28769
3681 | 803
3682 | 3674
3683 | 2350
3684 | 3107
3685 | 2286
3686 | 1082
3687 | 7354
3688 | 27396
3689 | 24948
3690 | 112
3691 | 803
3692 | 803
3693 | 2300
3694 | 13
3695 | 2761
3696 | 914
3697 | 2300
3698 | 10
3699 | 2761
3700 | 845
3701 | 2384
3702 | 1118
3703 | 3735
3704 | 803
3705 | 2300
3706 | 8
3707 | 2761
3708 | 914
3709 | 2300
3710 | 127
3711 | 2761
3712 | 845
3713 | 2384
3714 | 1118
3715 | 3718
3716 | 2573
3717 | 3680
3718 | 1082
3719 | 914
3720 | 2350
3721 | 2711
3722 | 2784
3723 | 803
3724 | 1118
3725 | 3732
3726 | 2300
3727 | 8
3728 | 803
3729 | 3674
3730 | 2573
3731 | 3674
3732 | 3674
3733 | 845
3734 | 1355
3735 | 1082
3736 | 953
3737 | 2689
3738 | 803
3739 | 1082
3740 | 7340
3741 | 24838
3742 | 25443
3743 | 28773
3744 | 116
3745 | 2350
3746 | 1355
3747 | 2350
3748 | 2743
3749 | 2761
3750 | 1118
3751 | 3767
3752 | 3012
3753 | 803
3754 | 2573
3755 | 1337
3756 | 2300
3757 | 95
3758 | 2871
3759 | 1118
3760 | 3763
3761 | 3680
3762 | 1181
3763 | 3765
3764 | 2448
3765 | 2973
3766 | 1181
3767 | 3747
3768 | 953
3769 | 2350
3770 | 1337
3771 | 1082
3772 | 7478
3773 | 25862
3774 | 28792
3775 | 25445
3776 | 116
3777 | 2456
3778 | 2973
3779 | 2568
3780 | 2401
3781 | 953
3782 | 1082
3783 | 7542
3784 | 29699
3785 | 25193
3786 | 3213
3787 | 953
3788 | 1082
3789 | 7564
3790 | 28933
3791 | 25973
3792 | 31090
3793 | 3785
3794 | 2300
3795 | 256
3796 | 2456
3797 | 2973
3798 | 3205
3799 | 2401
3800 | 953
3801 | 2260
3802 | 2562
3803 | 2401
3804 | 1082
3805 | 7576
3806 | 11529
3807 | 29300
3808 | 26977
3809 | 26988
3810 | 26478
3811 | 914
3812 | 1181
3813 | 3824
3814 | 2573
3815 | 2350
3816 | 2711
3817 | 1355
3818 | 3090
3819 | 2784
3820 | 1118
3821 | 3824
3822 | 845
3823 | 2286
3824 | 1082
3825 | 1208
3826 | 3813
3827 | 2260
3828 | 1082
3829 | 7372
3830 | 27652
3831 | 28527
3832 | 107
3833 | 728
3834 | 914
3835 | 2729
3836 | 803
3837 | 1118
3838 | 3857
3839 | 2350
3840 | 3090
3841 | 2711
3842 | 1337
3843 | 2711
3844 | 2573
3845 | 2755
3846 | 2300
3847 | 4
3848 | 3065
3849 | 2964
3850 | 1118
3851 | 3854
3852 | 1106
3853 | 2750
3854 | 1082
3855 | 3275
3856 | 1181
3857 | 3835
3858 | 1106
3859 | 2750
3860 | 1082
3861 | 7656
3862 | 29959
3863 | 28014
3864 | 29793
3865 | 26723
3866 | 1118
3867 | 3869
3868 | 2767
3869 | 1082
3870 | 2773
3871 | 1082
3872 | 7720
3873 | 27909
3874 | 29793
3875 | 26723
3876 | 3865
3877 | 2361
3878 | 1082
3879 | 7608
3880 | 28677
3881 | 29281
3882 | 25971
3883 | 914
3884 | 3785
3885 | 2562
3886 | 2396
3887 | 1355
3888 | 3205
3889 | 2396
3890 | 2562
3891 | 2396
3892 | 1337
3893 | 2711
3894 | 914
3895 | 2350
3896 | 845
3897 | 728
3898 | 3185
3899 | 2711
3900 | 2300
3901 | 7730
3902 | 3832
3903 | 2743
3904 | 845
3905 | 2300
3906 | 7750
3907 | 3832
3908 | 728
3909 | 845
3910 | 1337
3911 | 914
3912 | 1337
3913 | 845
3914 | 2286
3915 | 2562
3916 | 3072
3917 | 845
3918 | 2573
3919 | 2755
3920 | 1118
3921 | 3922
3922 | 3810
3923 | 2260
3924 | 3144
3925 | 1082
3926 | 7742
3927 | 25094
3928 | 28257
3929 | 25966
3930 | 114
3931 | 914
3932 | 803
3933 | 2767
3934 | 1118
3935 | 3940
3936 | 2711
3937 | 3021
3938 | 2292
3939 | 1181
3940 | 3931
3941 | 953
3942 | 1106
3943 | 1082
3944 | 7756
3945 | 26628
3946 | 27759
3947 | 100
3948 | 2270
3949 | 2551
3950 | 3072
3951 | 2551
3952 | 2396
3953 | 3107
3954 | 1082
3955 | 7886
3956 | 8962
3957 | 62
3958 | 2736
3959 | 2551
3960 | 2396
3961 | 2502
3962 | 2300
3963 | 896
3964 | 1355
3965 | 2350
3966 | 1337
3967 | 1082
3968 | 7850
3969 | 25863
3970 | 29816
3971 | 24946
3972 | 29795
3973 | 803
3974 | 914
3975 | 3561
3976 | 845
3977 | 728
3978 | 914
3979 | 3561
3980 | 845
3981 | 2720
3982 | 1082
3983 | 7934
3984 | 25605
3985 | 26473
3986 | 29801
3987 | 2300
3988 | 9
3989 | 2350
3990 | 2784
3991 | 2300
3992 | 7
3993 | 2384
3994 | 1355
3995 | 2300
3996 | 48
3997 | 1355
3998 | 1082
3999 | 7908
4000 | 8961
4001 | 2275
4002 | 3469
4003 | 2260
4004 | 2611
4005 | 3972
4006 | 3986
4007 | 3947
4008 | 1082
4009 | 7996
4010 | 8962
4011 | 115
4012 | 4000
4013 | 2743
4014 | 2378
4015 | 1283
4016 | 1118
4017 | 4011
4018 | 1082
4019 | 8016
4020 | 15362
4021 | 35
4022 | 2502
4023 | 2300
4024 | 896
4025 | 1355
4026 | 2551
4027 | 2401
4028 | 1082
4029 | 8036
4030 | 29444
4031 | 26473
4032 | 110
4033 | 2853
4034 | 2980
4035 | 2300
4036 | 45
4037 | 3947
4038 | 1082
4039 | 8056
4040 | 29955
4041 | 29230
4042 | 914
4043 | 2260
4044 | 4021
4045 | 4011
4046 | 3957
4047 | 845
4048 | 2350
4049 | 1337
4050 | 2573
4051 | 3930
4052 | 3303
4053 | 1082
4054 | 8076
4055 | 29954
4056 | 46
4057 | 3386
4058 | 2260
4059 | 4041
4060 | 1082
4061 | 7964
4062 | 10243
4063 | 10542
4064 | 2928
4065 | 2611
4066 | 1697
4067 | 2703
4068 | 1118
4069 | 4070
4070 | 4063
4071 | 3986
4072 | 3021
4073 | 1082
4074 | 8106
4075 | 11777
4076 | 3386
4077 | 2922
4078 | 1118
4079 | 4082
4080 | 2300
4081 | 45
4082 | 3021
4083 | 4063
4084 | 1082
4085 | 8146
4086 | 15879
4087 | 30062
4088 | 25197
4089 | 29285
4090 | 803
4091 | 1283
4092 | 2980
4093 | 2743
4094 | 3185
4095 | 953
4096 | 3090
4097 | 2611
4098 | 914
4099 | 2300
4100 | 48
4101 | 1337
4102 | 2300
4103 | 9
4104 | 2350
4105 | 2784
4106 | 1118
4107 | 4115
4108 | 2300
4109 | 7
4110 | 1337
4111 | 803
4112 | 2300
4113 | 10
4114 | 2784
4115 | 2378
4116 | 803
4117 | 845
4118 | 2871
4119 | 1283
4120 | 1118
4121 | 4124
4122 | 953
4123 | 3195
4124 | 1082
4125 | 728
4126 | 2611
4127 | 3527
4128 | 953
4129 | 2720
4130 | 2611
4131 | 3527
4132 | 3515
4133 | 3195
4134 | 3275
4135 | 803
4136 | 1283
4137 | 1118
4138 | 4092
4139 | 1082
4140 | 8168
4141 | 28167
4142 | 28021
4143 | 25954
4144 | 16242
4145 | 2270
4146 | 2546
4147 | 2401
4148 | 2611
4149 | 914
4150 | 2350
4151 | 3090
4152 | 2300
4153 | 45
4154 | 2755
4155 | 803
4156 | 914
4157 | 1118
4158 | 4159
4159 | 3275
4160 | 2350
4161 | 3090
4162 | 2300
4163 | 36
4164 | 2755
4165 | 1118
4166 | 4168
4167 | 2659
4168 | 3275
4169 | 3185
4170 | 2260
4171 | 803
4172 | 3195
4173 | 4089
4174 | 803
4175 | 1118
4176 | 4200
4177 | 2350
4178 | 3090
4179 | 2300
4180 | 46
4181 | 2761
4182 | 1118
4183 | 4192
4184 | 2750
4185 | 2720
4186 | 845
4187 | 2736
4188 | 2260
4189 | 845
4190 | 2541
4191 | 2401
4192 | 1082
4193 | 2292
4194 | 2546
4195 | 2401
4196 | 2286
4197 | 2546
4198 | 2396
4199 | 1181
4200 | 4172
4201 | 2736
4202 | 845
4203 | 1118
4204 | 4205
4205 | 3504
4206 | 845
4207 | 2541
4208 | 2401
4209 | 2270
4210 | 1082
4211 | 8278
4212 | 11778
4213 | 115
4214 | 3457
4215 | 914
4216 | 1181
4217 | 4220
4218 | 2711
4219 | 3065
4220 | 4075
4221 | 1208
4222 | 4217
4223 | 1082
4224 | 8420
4225 | 25351
4226 | 28015
4227 | 24944
4228 | 25970
4229 | 2720
4230 | 2350
4231 | 1337
4232 | 2703
4233 | 1118
4234 | 4239
4235 | 914
4236 | 2736
4237 | 845
4238 | 2689
4239 | 1082
4240 | 914
4241 | 1181
4242 | 4254
4243 | 3265
4244 | 2720
4245 | 3265
4246 | 2720
4247 | 1337
4248 | 2703
4249 | 1118
4250 | 4254
4251 | 1106
4252 | 2689
4253 | 2689
4254 | 1082
4255 | 1208
4256 | 4242
4257 | 2736
4258 | 2260
4259 | 1082
4260 | 8446
4261 | 28163
4262 | 24934
4263 | 2943
4264 | 1082
4265 | 8518
4266 | 25347
4267 | 24934
4268 | 4262
4269 | 3138
4270 | 2300
4271 | 31
4272 | 2384
4273 | 1355
4274 | 2943
4275 | 2281
4276 | 2384
4277 | 1082
4278 | 8120
4279 | 10248
4280 | 25971
4281 | 29281
4282 | 26723
4283 | 41
4284 | 728
4285 | 914
4286 | 803
4287 | 803
4288 | 1118
4289 | 4318
4290 | 803
4291 | 4262
4292 | 3265
4293 | 2300
4294 | 159
4295 | 2384
4296 | 2711
4297 | 3265
4298 | 4228
4299 | 1283
4300 | 1118
4301 | 4314
4302 | 1106
4303 | 803
4304 | 4262
4305 | 2300
4306 | 64
4307 | 728
4308 | 2396
4309 | 2384
4310 | 2773
4311 | 2265
4312 | 2378
4313 | 2916
4314 | 1082
4315 | 2689
4316 | 2407
4317 | 1181
4318 | 4286
4319 | 1106
4320 | 2736
4321 | 2260
4322 | 1082
4323 | 8554
4324 | 10246
4325 | 26982
4326 | 25710
4327 | 41
4328 | 914
4329 | 2524
4330 | 2407
4331 | 1118
4332 | 4348
4333 | 2407
4334 | 2396
4335 | 2711
4336 | 728
4337 | 4283
4338 | 2703
4339 | 1118
4340 | 4345
4341 | 914
4342 | 2750
4343 | 845
4344 | 1106
4345 | 1082
4346 | 2943
4347 | 1181
4348 | 4329
4349 | 953
4350 | 2260
4351 | 845
4352 | 2260
4353 | 1082
4354 | 8528
4355 | 29455
4356 | 24933
4357 | 25458
4358 | 11624
4359 | 28535
4360 | 25714
4361 | 26988
4362 | 29811
4363 | 4283
4364 | 2750
4365 | 1082
4366 | 8706
4367 | 26116
4368 | 28265
4369 | 100
4370 | 4327
4371 | 2750
4372 | 1082
4373 | 8730
4374 | 25383
4375 | 28015
4376 | 26992
4377 | 25964
4378 | 845
4379 | 803
4380 | 983
4381 | 3247
4382 | 2286
4383 | 914
4384 | 1082
4385 | 8644
4386 | 10249
4387 | 26988
4388 | 25972
4389 | 24946
4390 | 10604
4391 | 2557
4392 | 2396
4393 | 1118
4394 | 4397
4395 | 4377
4396 | 2300
4397 | 3247
4398 | 1082
4399 | 8744
4400 | 27719
4401 | 29801
4402 | 29285
4403 | 27745
4404 | 2442
4405 | 2973
4406 | 1082
4407 | 8796
4408 | 25352
4409 | 28015
4410 | 26992
4411 | 25964
4412 | 44
4413 | 2391
4414 | 3247
4415 | 1082
4416 | 8768
4417 | 16134
4418 | 28518
4419 | 28277
4420 | 100
4421 | 2980
4422 | 3386
4423 | 3265
4424 | 3303
4425 | 2300
4426 | 63
4427 | 3021
4428 | 3027
4429 | 2300
4430 | -13
4431 | 3415
4432 | 1082
4433 | 8812
4434 | 26889
4435 | 29806
4436 | 29285
4437 | 29296
4438 | 29797
4439 | 4369
4440 | 2703
4441 | 1118
4442 | 4470
4443 | 2557
4444 | 2396
4445 | 1118
4446 | 4455
4447 | 2767
4448 | 1118
4449 | 4452
4450 | 4267
4451 | 2964
4452 | 1082
4453 | 4267
4454 | 4412
4455 | 1082
4456 | 953
4457 | 803
4458 | 4262
4459 | 3090
4460 | 2300
4461 | 32
4462 | 2384
4463 | 2773
4464 | 2300
4465 | -14
4466 | 2384
4467 | 3415
4468 | 4267
4469 | 2964
4470 | 1082
4471 | 803
4472 | 914
4473 | 3265
4474 | 4144
4475 | 1118
4476 | 4493
4477 | 1106
4478 | 2546
4479 | 2396
4480 | 2847
4481 | 1118
4482 | 4485
4483 | 953
4484 | 1181
4485 | 4491
4486 | 2557
4487 | 2396
4488 | 1118
4489 | 4490
4490 | 728
4491 | 4403
4492 | 4403
4493 | 1082
4494 | 845
4495 | 2260
4496 | 4420
4497 | 1082
4498 | 8864
4499 | 26377
4500 | 29797
4501 | 28461
4502 | 25714
4503 | 29285
4504 | 2524
4505 | 2260
4506 | 914
4507 | 2407
4508 | 2711
4509 | 2368
4510 | 1118
4511 | 4514
4512 | 2943
4513 | 1181
4514 | 4506
4515 | 1106
4516 | 803
4517 | 2956
4518 | 728
4519 | 2524
4520 | 1337
4521 | 2391
4522 | 803
4523 | 914
4524 | 2292
4525 | 2922
4526 | 2300
4527 | -50
4528 | 2384
4529 | 3415
4530 | 914
4531 | 1181
4532 | 4535
4533 | 2407
4534 | 728
4535 | 2956
4536 | 1208
4537 | 4532
4538 | 2396
4539 | 845
4540 | 1082
4541 | 0
4542 | 29449
4543 | 29797
4544 | 28461
4545 | 25714
4546 | 29285
4547 | 803
4548 | 2270
4549 | 2755
4550 | 1118
4551 | 4556
4552 | 953
4553 | 2495
4554 | 2265
4555 | 4546
4556 | 1082
4557 | 803
4558 | 2517
4559 | 2841
4560 | 2300
4561 | -49
4562 | 2384
4563 | 3415
4564 | 2524
4565 | 728
4566 | 914
4567 | 1181
4568 | 4571
4569 | 2696
4570 | 2401
4571 | 2943
4572 | 1208
4573 | 4568
4574 | 2260
4575 | 728
4576 | 2401
4577 | 1082
4578 | 8994
4579 | 10247
4580 | 29295
4581 | 25956
4582 | 10610
4583 | 803
4584 | 1118
4585 | 4599
4586 | 2292
4587 | 728
4588 | 914
4589 | 4582
4590 | 2350
4591 | 2711
4592 | 2368
4593 | 1118
4594 | 4598
4595 | 2286
4596 | 845
4597 | 2729
4598 | 1082
4599 | 1106
4600 | 1082
4601 | 9154
4602 | 11526
4603 | 29295
4604 | 25956
4605 | 114
4606 | 4503
4607 | 4582
4608 | 2689
4609 | 4546
4610 | 1082
4611 | 9200
4612 | 11014
4613 | 29295
4614 | 25956
4615 | 114
4616 | 803
4617 | 914
4618 | 4605
4619 | 4503
4620 | 845
4621 | 728
4622 | 2286
4623 | 4546
4624 | 1082
4625 | 9080
4626 | 26126
4627 | 29295
4628 | 26740
4629 | 30509
4630 | 29295
4631 | 27748
4632 | 29545
4633 | 116
4634 | 2254
4635 | 62
4636 | 9248
4637 | 29446
4638 | 29561
4639 | 25972
4640 | 109
4641 | 2254
4642 | 68
4643 | 9270
4644 | 26117
4645 | 29295
4646 | 26740
4647 | 2495
4648 | 4633
4649 | 2275
4650 | 4546
4651 | 1082
4652 | 9284
4653 | 28420
4654 | 27758
4655 | 121
4656 | 2270
4657 | 4546
4658 | 1082
4659 | 8830
4660 | 11779
4661 | 25705
4662 | 4262
4663 | 3265
4664 | 2300
4665 | 31
4666 | 2384
4667 | 3303
4668 | 3386
4669 | 1082
4670 | 9302
4671 | 30469
4672 | 29295
4673 | 29540
4674 | 3027
4675 | 4503
4676 | 2703
4677 | 1118
4678 | 4700
4679 | 728
4680 | 2396
4681 | 2703
4682 | 1118
4683 | 4697
4684 | 803
4685 | 4262
4686 | 3090
4687 | 2300
4688 | 128
4689 | 2384
4690 | 1283
4691 | 1118
4692 | 4694
4693 | 803
4694 | 4661
4695 | 2396
4696 | 1181
4697 | 4680
4698 | 2292
4699 | 1181
4700 | 4675
4701 | 1082
4702 | 9220
4703 | 25611
4704 | 26213
4705 | 28265
4706 | 29801
4707 | 28521
4708 | 29550
4709 | 2524
4710 | 2396
4711 | 3051
4712 | 1082
4713 | 9402
4714 | 30468
4715 | 29295
4716 | 100
4717 | 2265
4718 | 3469
4719 | 3882
4720 | 2618
4721 | 3221
4722 | 803
4723 | 914
4724 | 2743
4725 | 2401
4726 | 2286
4727 | 728
4728 | 3315
4729 | 845
4730 | 1082
4731 | 9316
4732 | 29701
4733 | 27503
4734 | 28261
4735 | 2573
4736 | 4716
4737 | 1082
4738 | 9460
4739 | 16135
4740 | 28277
4741 | 29033
4742 | 25973
4743 | 803
4744 | 3041
4745 | 4283
4746 | 1283
4747 | 2980
4748 | 3386
4749 | 2736
4750 | 2300
4751 | 74
4752 | 2396
4753 | 4661
4754 | 3378
4755 | 29193
4756 | 25701
4757 | 26213
4758 | 28265
4759 | 25701
4760 | 3027
4761 | 1082
4762 | 9474
4763 | 16132
4764 | 30062
4765 | 108
4766 | 3138
4767 | 2980
4768 | 2300
4769 | -16
4770 | 3415
4771 | 1082
4772 | 9522
4773 | 16132
4774 | 25964
4775 | 110
4776 | 3138
4777 | 2300
4778 | 31
4779 | 2841
4780 | 2300
4781 | -19
4782 | 2384
4783 | 3415
4784 | 1082
4785 | 9424
4786 | 25348
4787 | 24936
4788 | 114
4789 | 4734
4790 | 4765
4791 | 3265
4792 | 953
4793 | 3090
4794 | 1082
4795 | 9568
4796 | 23366
4797 | 26723
4798 | 29281
4799 | 93
4800 | 4788
4801 | 4377
4802 | 2300
4803 | 3247
4804 | 1082
4805 | 9588
4806 | 15201
4807 | 2300
4808 | -13570
4809 | 2761
4810 | 2300
4811 | -22
4812 | 2384
4813 | 3415
4814 | 2300
4815 | 1082
4816 | 3247
4817 | 2682
4818 | 2703
4819 | 1118
4820 | 4822
4821 | 3041
4822 | 2401
4823 | 1082
4824 | 9608
4825 | 14849
4826 | 3233
4827 | 2618
4828 | 803
4829 | 2300
4830 | 74
4831 | 2401
4832 | 3058
4833 | 3247
4834 | 4734
4835 | 4765
4836 | 4775
4837 | 4742
4838 | 3265
4839 | 1355
4840 | 2578
4841 | 2401
4842 | 3233
4843 | 2300
4844 | -13570
4845 | 2676
4846 | 1082
4847 | 9646
4848 | 14855
4849 | 28526
4850 | 24942
4851 | 25965
4852 | 3233
4853 | 2618
4854 | 2260
4855 | 2300
4856 | -13570
4857 | 2676
4858 | 1082
4859 | 9692
4860 | 9985
4861 | 4734
4862 | 4369
4863 | 4420
4864 | 4267
4865 | 1082
4866 | 9716
4867 | 29287
4868 | 25445
4869 | 29301
4870 | 25971
4871 | 2300
4872 | 74
4873 | 2396
4874 | 4267
4875 | 4412
4876 | 1082
4877 | 9542
4878 | 29702
4879 | 26479
4880 | 27751
4881 | 101
4882 | 2696
4883 | 2396
4884 | 2368
4885 | 728
4886 | 2401
4887 | 1082
4888 | 9752
4889 | 26628
4890 | 25705
4891 | 101
4892 | 4734
4893 | 4369
4894 | 4420
4895 | 4262
4896 | 2300
4897 | 128
4898 | 728
4899 | 4881
4900 | 1082
4901 | 9774
4902 | 27940
4903 | 29281
4904 | 107
4905 | 2618
4906 | 2260
4907 | 3247
4908 | 1082
4909 | 9730
4910 | 25189
4911 | 26469
4912 | 28265
4913 | 2618
4914 | 1082
4915 | 9816
4916 | 26978
4917 | 102
4918 | 2300
4919 | 1118
4920 | 3247
4921 | 4904
4922 | 1082
4923 | 9828
4924 | 30053
4925 | 29806
4926 | 27753
4927 | 2391
4928 | 4917
4929 | 2401
4930 | 1082
4931 | 9844
4932 | 24933
4933 | 24935
4934 | 28265
4935 | 2300
4936 | 1181
4937 | 3247
4938 | 4412
4939 | 1082
4940 | 9860
4941 | 29796
4942 | 25960
4943 | 110
4944 | 2618
4945 | 2391
4946 | 728
4947 | 2401
4948 | 1082
4949 | 9878
4950 | 30565
4951 | 26984
4952 | 25964
4953 | 4917
4954 | 1082
4955 | 9896
4956 | 29286
4957 | 28773
4958 | 24933
4959 | 116
4960 | 728
4961 | 4934
4962 | 4943
4963 | 1082
4964 | 9908
4965 | 25956
4966 | 29548
4967 | 101
4968 | 2300
4969 | 1181
4970 | 3247
4971 | 4904
4972 | 728
4973 | 4943
4974 | 1082
4975 | 9926
4976 | 26211
4977 | 29295
4978 | 2300
4979 | 914
4980 | 3247
4981 | 2618
4982 | 1082
4983 | 9948
4984 | 24931
4985 | 29798
4986 | 953
4987 | 2300
4988 | 1181
4989 | 3247
4990 | 4904
4991 | 2618
4992 | 728
4993 | 1082
4994 | 9964
4995 | 28260
4996 | 30821
4997 | 116
4998 | 2300
4999 | 1208
5000 | 3247
5001 | 4412
5002 | 1082
5003 | 9800
5004 | 10280
5005 | 24941
5006 | 27506
5007 | 29285
5008 | 41
5009 | 845
5010 | 2246
5011 | 2407
5012 | 2578
5013 | 2401
5014 | 2943
5015 | 2396
5016 | 3041
5017 | 2401
5018 | 1082
5019 | 9986
5020 | 25350
5021 | 25970
5022 | 29793
5023 | 101
5024 | 2557
5025 | 2396
5026 | 914
5027 | 4825
5028 | 953
5029 | 845
5030 | 2557
5031 | 2401
5032 | 4377
5033 | 2327
5034 | 3041
5035 | 2401
5036 | 1082
5037 | 10036
5038 | 30216
5039 | 29281
5040 | 24937
5041 | 27746
5042 | 101
5043 | 5023
5044 | 2260
5045 | 3247
5046 | 1082
5047 | 10072
5048 | 25352
5049 | 28271
5050 | 29811
5051 | 28257
5052 | 116
5053 | 5023
5054 | 2281
5055 | 3242
5056 | 4377
5057 | 2254
5058 | 3247
5059 | 1082
5060 | 10092
5061 | 29956
5062 | 25971
5063 | 114
5064 | 5023
5065 | 2281
5066 | 3242
5067 | 4377
5068 | 2335
5069 | 2937
5070 | 2596
5071 | 3072
5072 | 2596
5073 | 2396
5074 | 3247
5075 | 1082
5076 | 10118
5077 | 15877
5078 | 28514
5079 | 31076
5080 | 2943
5081 | 1082
5082 | 10004
5083 | 10278
5084 | 28516
5085 | 29541
5086 | 41
5087 | 3195
5088 | 2246
5089 | 728
5090 | 914
5091 | 1082
5092 | 10162
5093 | 10278
5094 | 28515
5095 | 28781
5096 | 41
5097 | 845
5098 | 2300
5099 | 74
5100 | 2396
5101 | 4267
5102 | 2401
5103 | 1082
5104 | 10150
5105 | 25701
5106 | 25967
5107 | 15987
5108 | 4377
5109 | 5096
5110 | 4377
5111 | 5086
5112 | 1082
5113 | 10206
5114 | 27910
5115 | 29281
5116 | 25963
5117 | 114
5118 | 3058
5119 | 3233
5120 | 2618
5121 | 5023
5122 | 2281
5123 | 3242
5124 | 4377
5125 | 5008
5126 | 3247
5127 | 3247
5128 | 1082
5129 | 10224
5130 | 15970
5131 | 114
5132 | 4377
5133 | 914
5134 | 1082
5135 | 10256
5136 | 29282
5137 | 62
5138 | 4377
5139 | 845
5140 | 1082
5141 | 10268
5142 | 29285
5143 | 29284
5144 | 28783
5145 | 4377
5146 | 1106
5147 | 1082
5148 | 10280
5149 | 25956
5150 | 27000
5151 | 116
5152 | 4377
5153 | 1082
5154 | 1082
5155 | 10182
5156 | 10243
5157 | 10611
5158 | 3233
5159 | 2300
5160 | 34
5161 | 4716
5162 | 3265
5163 | 2689
5164 | 2286
5165 | 3242
5166 | 3233
5167 | 1082
5168 | 10294
5169 | 11874
5170 | 34
5171 | 4377
5172 | 3378
5173 | 5157
5174 | 1082
5175 | 10334
5176 | 9314
5177 | 34
5178 | 4377
5179 | 3373
5180 | 5157
5181 | 1082
5182 | 10348
5183 | 24934
5184 | 28514
5185 | 29810
5186 | 34
5187 | 4377
5188 | 3444
5189 | 5157
5190 | 1082
5191 | 10362
5192 | 10305
5193 | 2300
5194 | 41
5195 | 3882
5196 | 2736
5197 | 1082
5198 | 10380
5199 | 11842
5200 | 40
5201 | 2300
5202 | 41
5203 | 3882
5204 | 3303
5205 | 1082
5206 | 10394
5207 | 23617
5208 | 3785
5209 | 2396
5210 | 2562
5211 | 2401
5212 | 1082
5213 | 10410
5214 | 28744
5215 | 29551
5216 | 28788
5217 | 28271
5218 | 101
5219 | 4734
5220 | 4369
5221 | 4420
5222 | 4267
5223 | 4412
5224 | 1082
5225 | 10308
5226 | 10245
5227 | 26222
5228 | 10593
5229 | 3058
5230 | 4262
5231 | 4881
5232 | 1082
5233 | 10424
5234 | 26889
5235 | 28013
5236 | 25701
5237 | 24937
5238 | 25972
5239 | 2300
5240 | 64
5241 | 5228
5242 | 1082
5243 | 10464
5244 | 25356
5245 | 28015
5246 | 26992
5247 | 25964
5248 | 28461
5249 | 27758
5250 | 121
5251 | 2300
5252 | 32
5253 | 5228
5254 | 1082
5255 | 10484
5256 | 29443
5257 | 25957
5258 | 4734
5259 | 4369
5260 | 4420
5261 | 3027
5262 | 2407
5263 | 2300
5264 | 1082
5265 | 2761
5266 | 1118
5267 | 5279
5268 | 2407
5269 | 4075
5270 | 2943
5271 | 2618
5272 | 2350
5273 | 2784
5274 | 1118
5275 | 5277
5276 | 953
5277 | 1082
5278 | 1181
5279 | 5261
5280 | 2396
5281 | 4056
5282 | 1082
5283 | 10508
5284 | 25604
5285 | 28021
5286 | 112
5287 | 3221
5288 | 2703
5289 | 1118
5290 | 5298
5291 | 728
5292 | 2407
5293 | 4075
5294 | 2943
5295 | 728
5296 | 2956
5297 | 1181
5298 | 5287
5299 | 953
5300 | 1082
5301 | 10448
5302 | 25349
5303 | 29547
5304 | 28021
5305 | 3221
5306 | 803
5307 | 2300
5308 | -16162
5309 | 1337
5310 | 914
5311 | 2703
5312 | 1118
5313 | 5323
5314 | 728
5315 | 2407
5316 | 845
5317 | 1355
5318 | 914
5319 | 2943
5320 | 728
5321 | 2956
5322 | 1181
5323 | 5310
5324 | 953
5325 | 845
5326 | 1082
5327 | 10564
5328 | 25607
5329 | 26213
5330 | 28265
5331 | 25701
5332 | 4734
5333 | 4369
5334 | 2689
5335 | 2773
5336 | 1082
5337 | 10652
5338 | 23366
5339 | 26740
5340 | 28261
5341 | 93
5342 | 1082
5343 | 10672
5344 | 23366
5345 | 27749
5346 | 25971
5347 | 93
5348 | 4734
5349 | 3138
5350 | 1118
5351 | 5366
5352 | 4369
5353 | 953
5354 | 4267
5355 | 803
5356 | 2300
5357 | 10694
5358 | 2755
5359 | 728
5360 | 2300
5361 | 10682
5362 | 2755
5363 | 2378
5364 | 2980
5365 | 1181
5366 | 5347
5367 | 3792
5368 | 953
5369 | 1181
5370 | 5347
5371 | 1082
5372 | 10684
5373 | 23364
5374 | 26217
5375 | 93
5376 | 2980
5377 | 5347
5378 | 1082
5379 | 10742
5380 | 27906
5381 | 115
5382 | 914
5383 | 1805
5384 | 2605
5385 | 2396
5386 | 914
5387 | 1208
5388 | 5386
5389 | 1208
5390 | 5382
5391 | 1082
5392 | 10756
5393 | 25092
5394 | 27749
5395 | 108
5396 | 2300
5397 | 7
5398 | 3021
5399 | 1082
5400 | 10600
5401 | 25347
5402 | 26995
5403 | 2300
5404 | 27
5405 | 3021
5406 | 2300
5407 | 91
5408 | 3021
5409 | 1082
5410 | 10782
5411 | 28676
5412 | 26465
5413 | 101
5414 | 5402
5415 | 3378
5416 | 12802
5417 | 74
5418 | 5402
5419 | 3378
5420 | 12548
5421 | 12603
5422 | 72
5423 | 1082
5424 | 10818
5425 | 24837
5426 | 11636
5427 | 31096
5428 | 2611
5429 | 2669
5430 | 914
5431 | 5402
5432 | 2260
5433 | 4041
5434 | 3378
5435 | 15105
5436 | 2260
5437 | 4041
5438 | 3378
5439 | 18433
5440 | 845
5441 | 2541
5442 | 2401
5443 | 1082
5444 | 10846
5445 | 25093
5446 | 25135
5447 | 26229
5448 | 2254
5449 | 1024
5450 | 10798
5451 | 25349
5452 | 25135
5453 | 26229
5454 | 2254
5455 | 512
5456 | 10898
5457 | 15367
5458 | 27746
5459 | 25455
5460 | 15979
5461 | 2327
5462 | 10972
5463 | 10910
5464 | 25092
5465 | 26229
5466 | 48
5467 | 2254
5468 | -3072
5469 | 10924
5470 | 25606
5471 | 29289
5472 | 31092
5473 | 48
5474 | 2327
5475 | 0
5476 | 10936
5477 | 25092
5478 | 27500
5479 | 48
5480 | 2327
5481 | -1
5482 | 10950
5483 | 10247
5484 | 27746
5485 | 25455
5486 | 10603
5487 | 1805
5488 | 914
5489 | 1181
5490 | 5498
5491 | 2743
5492 | 983
5493 | 728
5494 | 1010
5495 | 2286
5496 | 728
5497 | 2286
5498 | 728
5499 | 1208
5500 | 5490
5501 | 2736
5502 | 1082
5503 | 10962
5504 | 30214
5505 | 27745
5506 | 25705
5507 | 63
5508 | 803
5509 | 2265
5510 | 2300
5511 | 128
5512 | 2904
5513 | 1082
5514 | 11004
5515 | 29704
5516 | 24946
5517 | 29550
5518 | 25958
5519 | 114
5520 | 5460
5521 | 2396
5522 | 2964
5523 | 1082
5524 | 11026
5525 | 15876
5526 | 27746
5527 | 107
5528 | 2292
5529 | 5453
5530 | 3553
5531 | 1082
5532 | 11046
5533 | 25349
5534 | 25964
5535 | 28257
5536 | 2260
5537 | 5473
5538 | 2401
5539 | 1082
5540 | 11062
5541 | 26890
5542 | 30318
5543 | 27745
5544 | 25705
5545 | 29793
5546 | 101
5547 | 2270
5548 | 5479
5549 | 2401
5550 | 1082
5551 | 11078
5552 | 25092
5553 | 30064
5554 | 116
5555 | 5507
5556 | 1118
5557 | 5563
5558 | 5527
5559 | 5466
5560 | 2391
5561 | 5453
5562 | 5519
5563 | 1082
5564 | 953
5565 | 1082
5566 | 11100
5567 | 25092
5568 | 25959
5569 | 116
5570 | 5507
5571 | 1118
5572 | 5579
5573 | 5527
5574 | 5466
5575 | 2391
5576 | 728
5577 | 5453
5578 | 5519
5579 | 1082
5580 | 953
5581 | 1082
5582 | 11130
5583 | 27655
5584 | 24943
5585 | 25956
5586 | 16228
5587 | 803
5588 | 5479
5589 | 2396
5590 | 2755
5591 | 1082
5592 | 10886
5593 | 29958
5594 | 25712
5595 | 29793
5596 | 101
5597 | 2270
5598 | 5473
5599 | 2401
5600 | 1082
5601 | 11182
5602 | 29452
5603 | 30305
5604 | 11621
5605 | 30050
5606 | 26214
5607 | 29285
5608 | 115
5609 | 5473
5610 | 2396
5611 | 1118
5612 | 5616
5613 | 5479
5614 | 2396
5615 | 5554
5616 | 5535
5617 | 1082
5618 | 11200
5619 | 26117
5620 | 30060
5621 | 26739
5622 | 5608
5623 | 5546
5624 | 1082
5625 | 11234
5626 | 25869
5627 | 28781
5628 | 31092
5629 | 25133
5630 | 26229
5631 | 25958
5632 | 29554
5633 | 5535
5634 | 5546
5635 | 1082
5636 | 11248
5637 | 25094
5638 | 26229
5639 | 25958
5640 | 114
5641 | 2265
5642 | 3469
5643 | 5507
5644 | 1283
5645 | 2300
5646 | -35
5647 | 2384
5648 | 3415
5649 | 5586
5650 | 1118
5651 | 5654
5652 | 953
5653 | 5466
5654 | 1082
5655 | 5608
5656 | 5479
5657 | 2401
5658 | 5466
5659 | 1082
5660 | 11270
5661 | 25093
5662 | 28524
5663 | 27491
5664 | 5586
5665 | 1118
5666 | 5669
5667 | 953
5668 | 5466
5669 | 1082
5670 | 803
5671 | 5640
5672 | 728
5673 | 5569
5674 | 1082
5675 | 11318
5676 | 25093
5677 | 24940
5678 | 27502
5679 | 2573
5680 | 3335
5681 | 1082
5682 | 11348
5683 | 27652
5684 | 29545
5685 | 116
5686 | 5413
5687 | 3027
5688 | 803
5689 | 914
5690 | 5663
5691 | 2300
5692 | 15
5693 | 914
5694 | 2300
5695 | 15
5696 | 2711
5697 | 1337
5698 | 2300
5699 | 3
5700 | 4041
5701 | 3386
5702 | 2300
5703 | 63
5704 | 914
5705 | 3265
5706 | 3288
5707 | 1208
5708 | 5704
5709 | 3027
5710 | 1208
5711 | 5693
5712 | 953
5713 | 845
5714 | 2535
5715 | 2401
5716 | 1082
5717 | 11362
5718 | 26377
5719 | 29797
5720 | 26925
5721 | 28782
5722 | 29813
5723 | 3213
5724 | 2562
5725 | 2396
5726 | 3161
5727 | 2414
5728 | 2396
5729 | 1082
5730 | 11432
5731 | 29449
5732 | 29797
5733 | 26925
5734 | 28782
5735 | 29813
5736 | 2414
5737 | 2401
5738 | 2311
5739 | 16
5740 | 2401
5741 | 2562
5742 | 2401
5743 | 3205
5744 | 3168
5745 | 1082
5746 | 11162
5747 | 28418
5748 | 107
5749 | 2557
5750 | 2396
5751 | 2980
5752 | 3378
5753 | 8195
5754 | 27503
5755 | 3027
5756 | 1082
5757 | 11490
5758 | 25860
5759 | 24950
5760 | 108
5761 | 4734
5762 | 3138
5763 | 1118
5764 | 5769
5765 | 4438
5766 | 2260
5767 | 3469
5768 | 1181
5769 | 5760
5770 | 953
5771 | 2414
5772 | 2973
5773 | 1082
5774 | 11458
5775 | 25864
5776 | 24950
5777 | 30060
5778 | 29793
5779 | 101
5780 | 5722
5781 | 3185
5782 | 3185
5783 | 914
5784 | 2260
5785 | 2270
5786 | 2300
5787 | 4690
5788 | 5735
5789 | 2300
5790 | 11520
5791 | 3393
5792 | 845
5793 | 3195
5794 | 3195
5795 | 5735
5796 | 3415
5797 | 1082
5798 | 11512
5799 | 27652
5800 | 28265
5801 | 101
5802 | 2300
5803 | 6
5804 | 3084
5805 | 728
5806 | 5663
5807 | 1355
5808 | 2300
5809 | 64
5810 | 1082
5811 | 11594
5812 | 27656
5813 | 24943
5814 | 27748
5815 | 28265
5816 | 101
5817 | 5801
5818 | 5779
5819 | 1082
5820 | 11546
5821 | 27652
5822 | 24943
5823 | 100
5824 | 2530
5825 | 2396
5826 | 914
5827 | 803
5828 | 2530
5829 | 2401
5830 | 2260
5831 | 2300
5832 | 15
5833 | 914
5834 | 2743
5835 | 3185
5836 | 5816
5837 | 3195
5838 | 2286
5839 | 1208
5840 | 5833
5841 | 2736
5842 | 845
5843 | 2530
5844 | 2401
5845 | 1082
5846 | 9338
5847 | 25862
5848 | 28518
5849 | 29810
5850 | 104
5851 | 2254
5852 | -1
5853 | 11620
5854 | 26884
5855 | 26222
5856 | 111
5857 | 3027
5858 | 3378
5859 | 25883
5860 | 28486
5861 | 29810
5862 | 8296
5863 | 22646
5864 | 22574
5865 | 8236
5866 | 30032
5867 | 27746
5868 | 25449
5869 | 17440
5870 | 28015
5871 | 26977
5872 | 11374
5873 | 2618
5874 | 4075
5875 | 3027
5876 | 3378
5877 | 21033
5878 | 25449
5879 | 24936
5880 | 25714
5881 | 18976
5882 | 28001
5883 | 29541
5884 | 18464
5885 | 30575
5886 | 11365
5887 | 26656
5888 | 30575
5889 | 11877
5890 | 11890
5891 | 11882
5892 | 14648
5893 | 26432
5894 | 24941
5895 | 27753
5896 | 25390
5897 | 28015
5898 | 3027
5899 | 3378
5900 | 26656
5901 | 29812
5902 | 29552
5903 | 12090
5904 | 26415
5905 | 29801
5906 | 30056
5907 | 11874
5908 | 28515
5909 | 12141
5910 | 28520
5911 | 25975
5912 | 27250
5913 | 29487
5914 | 25205
5915 | 25964
5916 | 113
5917 | 3027
5918 | 1082
5919 | 11704
5920 | 30469
5921 | 29281
5922 | 30318
5923 | 2300
5924 | 30
5925 | 2396
5926 | 1118
5927 | 5946
5928 | 3378
5929 | 22305
5930 | 29281
5931 | 26990
5932 | 26478
5933 | 8250
5934 | 26966
5935 | 29810
5936 | 24949
5937 | 8300
5938 | 13873
5939 | 25133
5940 | 29801
5941 | 21280
5942 | 16981
5943 | 17740
5944 | 8273
5945 | 19798
5946 | 3027
5947 | 1082
5948 | 11836
5949 | 30723
5950 | 28521
5951 | 2300
5952 | 7488
5953 | 2456
5954 | 2401
5955 | 2448
5956 | 2401
5957 | 2434
5958 | 2401
5959 | 2414
5960 | 2401
5961 | 1082
5962 | 11894
5963 | 26628
5964 | 28257
5965 | 100
5966 | 2300
5967 | 11496
5968 | 2300
5969 | 7334
5970 | 2300
5971 | 6
5972 | 2396
5973 | 2265
5974 | 2384
5975 | 1118
5976 | 5979
5977 | 953
5978 | 2300
5979 | 4392
5980 | 2300
5981 | 7380
5982 | 2682
5983 | 5950
5984 | 1082
5985 | 11922
5986 | 28676
5987 | 25441
5988 | 101
5989 | 2300
5990 | 11
5991 | 3021
5992 | 1082
5993 | 11968
5994 | 26116
5995 | 27753
5996 | 101
5997 | 2300
5998 | 11976
5999 | 2300
6000 | 4392
6001 | 2300
6002 | 7380
6003 | 5950
6004 | 1082
6005 | 11984
6006 | 25351
6007 | 28271
6008 | 28531
6009 | 25964
6010 | 2300
6011 | 5976
6012 | 2427
6013 | 2401
6014 | 2300
6015 | 7334
6016 | 2421
6017 | 2401
6018 | 5965
6019 | 1082
6020 | 12008
6021 | 26883
6022 | 8559
6023 | 6009
6024 | 1082
6025 | 12038
6026 | 29705
6027 | 29537
6028 | 11627
6029 | 28265
6030 | 29801
6031 | 2300
6032 | 40
6033 | 2396
6034 | 728
6035 | 2300
6036 | 40
6037 | 2401
6038 | 2502
6039 | 2391
6040 | 2311
6041 | 0
6042 | 2401
6043 | 2300
6044 | 4370
6045 | 2391
6046 | 2311
6047 | 2
6048 | 2401
6049 | 2502
6050 | 2300
6051 | 256
6052 | 1355
6053 | 2391
6054 | 2311
6055 | 6
6056 | 2401
6057 | 2502
6058 | 2300
6059 | 512
6060 | 1355
6061 | 2391
6062 | 2311
6063 | 8
6064 | 2401
6065 | 2260
6066 | 2311
6067 | 4
6068 | 2401
6069 | 2669
6070 | 6022
6071 | 2300
6072 | 8780
6073 | 2442
6074 | 2401
6075 | 2300
6076 | 4370
6077 | 2463
6078 | 2401
6079 | 2260
6080 | 2562
6081 | 2401
6082 | 2270
6083 | 2546
6084 | 2401
6085 | 2502
6086 | 2300
6087 | 512
6088 | 1355
6089 | 2260
6090 | 3205
6091 | 3168
6092 | 2300
6093 | 40
6094 | 2401
6095 | 1082
6096 | 12048
6097 | 26883
6098 | 26990
6099 | 2300
6100 | 40
6101 | 2396
6102 | 6030
6103 | 1082
6104 | 12190
6105 | 10247
6106 | 29285
6107 | 28530
6108 | 10610
6109 | 803
6110 | 3386
6111 | 4075
6112 | 2300
6113 | 63
6114 | 3021
6115 | 3027
6116 | 2270
6117 | 2755
6118 | 1118
6119 | 6120
6120 | 128
6121 | 6098
6122 | 2300
6123 | 12216
6124 | 2463
6125 | 2401
6126 | 1082
6127 | 11638
6128 | 28932
6129 | 26997
6130 | 116
6131 | 2300
6132 | 12216
6133 | 2463
6134 | 2401
6135 | 3792
6136 | 2300
6137 | 11520
6138 | 3393
6139 | 2703
6140 | 1118
6141 | 6143
6142 | 2463
6143 | 2973
6144 | 1181
6145 | 6134
6146 | 1082
6147 | 12206
6148 | 10246
6149 | 28514
6150 | 29807
6151 | 41
6152 | 4646
6153 | 4708
6154 | 6098
6155 | 2300
6156 | 6
6157 | 2396
6158 | 2300
6159 | 16
6160 | 2384
6161 | 1118
6162 | 6163
6163 | 5922
6164 | 2300
6165 | 6
6166 | 2396
6167 | 2300
6168 | 4
6169 | 2384
6170 | 1118
6171 | 6172
6172 | 5856
6173 | 2300
6174 | 6
6175 | 2396
6176 | 2275
6177 | 2384
6178 | 1118
6179 | 6209
6180 | 2300
6181 | 8
6182 | 2396
6183 | 2246
6184 | 803
6185 | 2618
6186 | 728
6187 | 1337
6188 | 5304
6189 | 2300
6190 | 42
6191 | 2396
6192 | 2761
6193 | 1118
6194 | 6201
6195 | 3378
6196 | 25097
6197 | 25697
6198 | 25376
6199 | 29547
6200 | 28021
6201 | 128
6202 | 2300
6203 | 6
6204 | 2396
6205 | 2275
6206 | 2368
6207 | 2300
6208 | 6
6209 | 2401
6210 | 2478
6211 | 2396
6212 | 2964
6213 | 1082
6214 | 12292
6215 | 29701
6216 | 29537
6217 | 14955
6218 | 5023
6219 | 2618
6220 | 5447
6221 | 3242
6222 | 2391
6223 | 6030
6224 | 1082
6225 | 12426
6226 | 24840
6227 | 29795
6228 | 30313
6229 | 29793
6230 | 101
6231 | 803
6232 | 6030
6233 | 803
6234 | 914
6235 | 728
6236 | 2391
6237 | 728
6238 | 2300
6239 | 2
6240 | 1355
6241 | 2401
6242 | 845
6243 | 2502
6244 | 2396
6245 | 914
6246 | 803
6247 | 2391
6248 | 2502
6249 | 2401
6250 | 845
6251 | 728
6252 | 2401
6253 | 1082
6254 | 12448
6255 | 30468
6256 | 26977
6257 | 116
6258 | 1805
6259 | 2407
6260 | 1118
6261 | 6257
6262 | 2260
6263 | 728
6264 | 2401
6265 | 1082
6266 | 12506
6267 | 29446
6268 | 26473
6269 | 24942
6270 | 108
6271 | 2502
6272 | 728
6273 | 2401
6274 | 1082
6275 | 12530
6276 | 29446
6277 | 28265
6278 | 27751
6279 | 101
6280 | 2265
6281 | 2300
6282 | 78
6283 | 2401
6284 | 1082
6285 | 12548
6286 | 27909
6287 | 27765
6288 | 26996
6289 | 2260
6290 | 2300
6291 | 78
6292 | 2401
6293 | 1082
6294 | 12568
6295 | 29444
6296 | 28261
6297 | 100
6298 | 2502
6299 | 2350
6300 | 2300
6301 | 12
6302 | 1355
6303 | 1805
6304 | 2407
6305 | 1283
6306 | 1118
6307 | 6302
6308 | 2401
6309 | 2300
6310 | 14
6311 | 1355
6312 | 2401
6313 | 1082
6314 | 12586
6315 | 29191
6316 | 25445
6317 | 26981
6318 | 25974
6319 | 1805
6320 | 2311
6321 | 12
6322 | 2396
6323 | 1118
6324 | 6318
6325 | 2311
6326 | 14
6327 | 2396
6328 | 2311
6329 | 12
6330 | 2396
6331 | 2260
6332 | 2311
6333 | 12
6334 | 2401
6335 | 1082
6336 | 12252
6337 | 25862
6338 | 26980
6339 | 28532
6340 | 114
6341 | 2300
6342 | 64
6343 | 4615
6344 | 1082
6345 | 0
6346 | 28929
6347 | 2300
6348 | 64
6349 | 4605
6350 | 1082
6351 | 12688
6352 | 16129
6353 | 2535
6354 | 2396
6355 | 4075
6356 | 1082
6357 | 12700
6358 | 27649
6359 | 2535
6360 | 2396
6361 | 5685
6362 | 1082
6363 | 12712
6364 | 30721
6365 | 6346
6366 | 2535
6367 | 2396
6368 | 5823
6369 | 6340
6370 | 1082
6371 | 12724
6372 | 26882
6373 | 97
6374 | 2275
6375 | 3469
6376 | 2300
6377 | 6
6378 | 3084
6379 | 1355
6380 | 2535
6381 | 2396
6382 | 5663
6383 | 1355
6384 | 3785
6385 | 2562
6386 | 2396
6387 | 1355
6388 | 728
6389 | 3213
6390 | 2689
6391 | 2562
6392 | 2396
6393 | 1337
6394 | 3315
6395 | 3785
6396 | 2396
6397 | 2562
6398 | 2401
6399 | 6358
6400 | 1082
6401 | 12740
6402 | 24833
6403 | 2260
6404 | 728
6405 | 6373
6406 | 1082
6407 | 12800
6408 | 30465
6409 | 4503
6410 | 2300
6411 | 64
6412 | 2265
6413 | 4546
6414 | 4673
6415 | 4546
6416 | 1082
6417 | 12812
6418 | 29441
6419 | 5596
6420 | 5621
6421 | 1082
6422 | 12832
6423 | 28161
6424 | 2265
6425 | 2535
6426 | 3072
6427 | 6358
6428 | 1082
6429 | 12842
6430 | 28673
6431 | 2270
6432 | 2535
6433 | 3072
6434 | 6358
6435 | 1082
6436 | 12856
6437 | 29185
6438 | 2535
6439 | 2401
6440 | 6358
6441 | 1082
6442 | 12870
6443 | 31233
6444 | 2535
6445 | 2396
6446 | 5663
6447 | 5447
6448 | 5678
6449 | 6358
6450 | 1082
6451 | 12882
6452 | 25601
6453 | 2265
6454 | 3469
6455 | 914
6456 | 2535
6457 | 2396
6458 | 5663
6459 | 845
6460 | 2300
6461 | 6
6462 | 3084
6463 | 1355
6464 | 2300
6465 | 64
6466 | 5678
6467 | 6358
6468 | 1082
6469 | 12670
6470 | 25348
6471 | 27759
6472 | 100
6473 | 2300
6474 | 70
6475 | 2246
6476 | 2973
6477 | 1082
6478 |
--------------------------------------------------------------------------------
/subleq.fth:
--------------------------------------------------------------------------------
1 | defined eforth [if] ' ) ! [then] ( Turn off ok prompt )
2 | \ Project: Cross Compiler / eForth interpreter for a SUBLEQ CPU
3 | \ License: The Unlicense
4 | \ Author: Richard James Howe
5 | \ Email: howe.r.j.89@gmail.com
6 | \ Repo:
7 | \
8 | \ References:
9 | \
10 | \ -
11 | \ -
12 | \ -
13 | \ -
14 | \ -
15 | \ - 8086 eForth 1.0 by Bill Muench and C. H. Ting, 1990
16 | \ - ,
17 | \ For multitasking support
18 | \ - ,
19 | \ For the block word-set, which is partially implemented.
20 | \ - The optional Forth floating point code is derived from
21 | \ code found in Vierte Dimensions, Vol.2, No.4, 1986. It has
22 | \ a liberal license, so long as the following copyright is
23 | \ still attached:
24 | \
25 | \ FORTH-83 FLOATING POINT.
26 | \ ----------------------------------
27 | \ COPYRIGHT 1985 BY ROBERT F. ILLYES
28 | \
29 | \ PO BOX 2516, STA. A
30 | \ CHAMPAIGN, IL 61820
31 | \ PHONE: 217/826-2734
32 | \
33 | \ The way this cross compiler works is the following:
34 | \
35 | \ 1. An assembler for the SUBLEQ machine is made.
36 | \ 2. A virtual machine is made with that assembler that can
37 | \ support higher level programming constructs, specifically,
38 | \ the easy execution of Forth.
39 | \ 3. Forth word definitions are built up, which are then used
40 | \ to construct a full Forth interpreter.
41 | \ 4. The resulting image is output to standard out.
42 | \
43 | \ Check the references for more detailed examples for other
44 | \ systems. Some keywords that will help are; Forth,
45 | \ Meta-compilation, Cross compiler, eForth, 8086 eForth,
46 | \ JonesForth, j1eforth.
47 | \
48 | \ Notes:
49 | \
50 | \ - If "see", the decompiler, was advanced enough we could
51 | \ dispense with the source code, an interesting concept.
52 | \ - The eForth image could determine the SUBLEQ machine size,
53 | \ and adjust itself accordingly, it would not even require a
54 | \ power-of-two integer width. Another interesting concept would
55 | \ be to adapt this eForth to a SUBLEQ machine that used bignums
56 | \ for each cell, this would require re-engineering functions
57 | \ like bitwise AND/OR/XOR as they require a fixed cell width to
58 | \ work efficiently.
59 | \ - The eForth image could be compressed with LZSS to save on
60 | \ space. If the de-compressor was written in pure SUBLEQ it
61 | \ would compression of most of the image instead of just the
62 | \ eForth section of it.
63 | \ - A website with an interactive simulator is available at:
64 | \
65 | \ - It would be nice to make a 7400 Integrated Circuit board
66 | \ that could run and execute this code, or a project in VHDL
67 | \ for an FPGA that could do it.
68 | \ - The virtual machine could be sped up with optimization
69 | \ magic
70 | \ - Half of the memory used is just for the virtual machine
71 | \ that allows Forth to be written.
72 | \ - The BLOCK word-set does not use mass storage, but maps
73 | \ blocks to memory, if a mass storage peripheral were to be
74 | \ added these functions would have to be modified. It might be
75 | \ nice to make a Forth File System based on blocks as well,
76 | \ then this system could act like a primitive DOS.
77 | \ - Reformatting the text for a 64 byte line width would allow
78 | \ storage in Forth blocks. This file could then perhaps we
79 | \ stored within the image.
80 | \ - Much like my Embed VM project and Forth interpreter,
81 | \ available at \ , this file
82 | \ could be documented extensively and explain how to build up
83 | \ a Forth interpreter from scratch.
84 | \
85 | only forth definitions hex
86 | 1 constant opt.multi ( Add in large "pause" primitive )
87 | 1 constant opt.editor ( Add in Text Editor )
88 | 1 constant opt.info ( Add info printing function )
89 | 0 constant opt.generate-c ( Generate C code )
90 | 0 constant opt.better-see ( Replace 'see' with better version )
91 | 0 constant opt.control ( Add in more control structures )
92 | 0 constant opt.allocate ( Add in "allocate"/"free" )
93 | 0 constant opt.float ( Add in floating point code )
94 | 0 constant opt.glossary ( Add in "glossary" word )
95 | 0 constant opt.sm-vm-err ( Smaller VM error message )
96 | 0 constant opt.optimize ( Enable extra optimization )
97 | 1 constant opt.divmod ( Use "opDivMod" primitive )
98 | 1 constant opt.self ( Enable self-interpreter )
99 | : sys.echo-off 1 or ; ( bit #1 = turn echoing chars off )
100 | : sys.cksum 2 or ; ( bit #2 = turn checksumming on )
101 | : sys.info 4 or ; ( bit #3 = print info msg on startup )
102 | : sys.eof 8 or ; ( bit #4 = die if received EOF )
103 | : sys.warnv $10 or ; ( bit #5 = warn if virtualized )
104 | 0 ( sys.cksum ) sys.eof sys.echo-off sys.warnv constant opt.sys
105 | defined (order) 0= [if]
106 | : (order) ( w wid*n n -- wid*n w n )
107 | dup if
108 | 1- swap >r recurse over r@ xor
109 | if 1+ r> -rot exit then rdrop
110 | then ;
111 | : -order get-order (order) nip set-order ; ( wid -- )
112 | : +order dup >r -order get-order r> swap 1+ set-order ;
113 | [then]
114 | defined [unless] 0= [if]
115 | : [unless] 0= postpone [if] ; immediate
116 | [then]
117 | defined eforth [if]
118 | : wordlist here cell allot 0 over ! ; ( -- wid : alloc wid )
119 | [then]
120 | wordlist constant meta.1 ( meta-compiler word set )
121 | wordlist constant target.1 ( target eForth word set )
122 | wordlist constant assembler.1 ( assembler word set )
123 | wordlist constant target.only.1 ( target only word set )
124 | defined eforth [if] system +order [then]
125 | meta.1 +order definitions
126 | 2 constant =cell \ Target cell size
127 | 4000 constant size \ Size of image working area
128 | 100 constant =buf \ Size of text input buffers in target
129 | 100 constant =stksz \ Size of return and variable stacks
130 | FC00 constant =thread \ Initial start of thread area
131 | 0008 constant =bksp \ Backspace character value
132 | 000A constant =lf \ Line feed character value
133 | 000D constant =cr \ Carriage Return character value
134 | 007F constant =del \ Delete character
135 | create tflash tflash size cells allot size erase
136 | variable tzreg 0 tzreg !
137 | variable tareg 1 tareg !
138 | variable tdp 0 tdp ! ( target dictionary pointer )
139 | variable tlast 0 tlast ! ( last defined target word pointer )
140 | variable tlocal 0 tlocal ! ( local variable allocator )
141 | variable voc-last 0 voc-last ! ( last defined in any vocab )
142 | : :m meta.1 +order definitions : ; ( --, "name" )
143 | : ;m postpone ; ; immediate ( -- )
144 | :m tcell 2 ;m ( -- 2 : bytes in a target cell )
145 | :m there tdp @ ;m ( -- a : target dictionary pointer value )
146 | :m tc! tflash + c! ;m ( c a -- : target write char )
147 | :m tc@ tflash + c@ ;m ( a -- c : target get char )
148 | :m t! over FF and over tc! swap 8 rshift swap 1+ tc! ;m
149 | :m t@ dup tc@ swap 1+ tc@ 8 lshift or ;m ( a -- u : target @ )
150 | :m taligned dup 1 and + ;m ( u -- u : align target pointer )
151 | :m talign there 1 and tdp +! ;m ( -- : align target dic. ptr. )
152 | :m tc, there tc! 1 tdp +! ;m ( c -- : write char to targ. dic.)
153 | :m t, there t! 2 tdp +! ;m ( u -- : write cell to target dic. )
154 | :m tallot tdp +! ;m ( u -- : allocate bytes in target dic. )
155 | :m mdrop drop ;m ( u -- : always call drop )
156 | :m mswap swap ;m ( u -- : always call swap )
157 | :m mdecimal decimal ;m ( -- : always call decimal )
158 | :m mhex hex ;m ( -- : always call hex )
159 | defined eforth [if]
160 | :m tpack dup tc, for aft count tc, then next drop ;m
161 | :m parse-word bl word ?nul count ;m ( -- a u )
162 | :m limit ;m ( u -- u16 : not needed on 16-bit systems )
163 | [else]
164 | :m tpack talign dup tc, 0 ?do count tc, loop drop ;m
165 | :m limit FFFF and ;m ( u -- u16 : limit variable to 16 bits )
166 | [then]
167 | :m $literal talign [char] " word count tpack talign ;m
168 | defined eforth [if]
169 | :m #dec s>d if [char] - emit then (.) ;m ( n16 -- )
170 | [else]
171 | :m #dec dup 8000 u>= if negate limit -1 >r else 0 >r then
172 | 0 <# #s r> sign #> type ;m ( n16 -- )
173 | [then]
174 | opt.generate-c [if]
175 | :m msep 2C emit ;m ( -- : emit "," as separator )
176 | [else]
177 | :m msep A emit ;m ( -- : emit space as separator )
178 | [then]
179 | :m mdump taligned ( a u -- )
180 | begin ?dup
181 | while swap dup @ limit #dec msep tcell + swap tcell -
182 | repeat drop ;m
183 | :m save-target decimal tflash there mdump ;m ( -- )
184 | :m .end only forth definitions decimal ;m ( -- )
185 | :m atlast tlast @ ;m ( -- a : meta-comp last defined word )
186 | :m local? tlocal @ ;m ( -- u : meta-comp local offset )
187 | :m lallot >r tlocal @ r> + tlocal ! ;m ( u -- allot in target )
188 | :m tuser ( --, "name", Created-Word: -- u )
189 | get-current >r meta.1 set-current create r>
190 | set-current tlocal @ =cell lallot , does> @ ;m
191 | :m tvar get-current >r ( --, "name", Created-Word: -- a )
192 | meta.1 set-current create
193 | r> set-current there , t, does> @ ;m
194 | :m label: get-current >r ( --, "name", Created-Word: -- a )
195 | meta.1 set-current create
196 | r> set-current there , does> @ ;m
197 | :m tdown =cell negate and ;m ( a -- a : align down )
198 | :m tnfa =cell + ;m ( pwd -- nfa : move to name field address )
199 | :m tcfa tnfa dup c@ 1F and + =cell + tdown ;m ( pwd -- cfa )
200 | :m compile-only voc-last @ tnfa t@ 20 or voc-last @ tnfa t! ;m
201 | :m immediate voc-last @ tnfa t@ 40 or voc-last @ tnfa t! ;m
202 | :m half dup 1 and abort" unaligned" 2/ ;m ( a -- a : meta 2/ )
203 | :m double 2* ;m ( a -- a : meta-comp 2* )
204 | defined eforth [if]
205 | :m (') bl word find ?found cfa ;m
206 | :m t' (') >body @ ;m ( --, "name" )
207 | :m to' target.only.1 +order (') >body @ target.only.1 -order ;m
208 | [else]
209 | :m t' ' >body @ ;m ( --, "name" )
210 | :m to' target.only.1 +order ' >body @ target.only.1 -order ;m
211 | [then]
212 | :m tcompile to' half t, ;m
213 | :m >tbody =cell + ;m
214 | :m tcksum taligned dup C0DE - FFFF and >r
215 | begin ?dup
216 | while swap dup t@ r> + FFFF and >r =cell + swap =cell -
217 | repeat drop r> ;m ( a u -- u : compute a checksum )
218 | :m mkck dup there swap - tcksum ;m ( -- u : checksum of image )
219 | :m postpone ( --, "name" )
220 | target.only.1 +order t' target.only.1 -order 2/ t, ;m
221 | :m thead talign there tlast @ t, dup tlast ! voc-last !
222 | parse-word talign tpack talign ;m ( --, "name" )
223 | :m header >in @ thead >in ! ;m ( --, "name" )
224 | :m :ht ( "name" -- : forth routine, no header )
225 | get-current >r target.1 set-current create
226 | r> set-current CAFE talign there ,
227 | does> @ 2/ t, ;m
228 | :m :t header :ht ;m ( "name" -- : forth routine )
229 | :m :to ( "name" -- : forth, target only routine )
230 | header
231 | get-current >r
232 | target.only.1 set-current create
233 | r> set-current
234 | CAFE talign there ,
235 | does> @ 2/ t, ;m
236 | :m :a ( "name" -- : assembly routine, no header )
237 | 1234 target.1 +order definitions
238 | create talign there , assembler.1 +order does> @ 2/ t, ;m
239 | :m (fall-through); 1234 <>
240 | if abort" unstructured" then assembler.1 -order ;m
241 | :m (a); (fall-through); ;m
242 | defined eforth [if] system -order [then]
243 | :m Z tzreg @ t, ;m ( -- : Address 0 must contain 0 )
244 | :m A, Z ;m ( -- : Synonym for 'Z', temporary location )
245 | :m V, tareg @ t, ;m ( -- : Address 1 also contains 0, tmp loc )
246 | :m NADDR there 2/ 1+ t, ;m ( --, jump to next cell )
247 | :m HALT Z Z -1 t, ;m ( --, Halt but do not catch fire )
248 | :m JMP 2/ Z Z t, ;m ( a --, Jump to location )
249 | :m ADD swap 2/ t, Z NADDR Z 2/ t, NADDR Z Z NADDR ;m
250 | :m SUB swap 2/ t, 2/ t, NADDR ;m ( a a -- : subtract )
251 | :m NOOP Z Z NADDR ;m ( -- : No operation )
252 | :m ZERO dup 2/ t, 2/ t, NADDR ;m ( a -- : zero a location )
253 | :m PUT 2/ t, -1 t, NADDR ;m ( a -- : put a byte )
254 | :m GET 2/ -1 t, t, NADDR ;m ( a -- : get a byte )
255 | :m MOV 2/ >r r@ dup t, t, NADDR 2/ t, Z NADDR r> Z t, NADDR
256 | Z Z NADDR ;m
257 | :m iJMP there 2/ E + 2* MOV Z Z NADDR ;m ( a -- )
258 | :m iADD ( a a -- : indirect add )
259 | 2/ t, A, NADDR
260 | 2/ t, V, NADDR
261 | there 2/ 7 + dup dup t, t, NADDR
262 | A, t, NADDR
263 | V, 0 t, NADDR
264 | A, A, NADDR
265 | V, V, NADDR ;m
266 | :m iSUB ( a a -- : indirect sub )
267 | 2/ t, A, NADDR
268 | 2/ >r
269 | there 2/ 7 + dup dup t, t, NADDR
270 | A, t, NADDR
271 | r> t, 0 t, NADDR
272 | A, A, NADDR ;m
273 | :m iSTORE ( a a -- : Indirect Store )
274 | 2/ t, A, NADDR
275 | there 2/ 3 4 * + dup t, t, NADDR
276 | there 2/ $A + dup t, t, NADDR
277 | A, there 2/ 5 + t, NADDR
278 | A, there 2/ 3 + t, NADDR
279 | 0 t, 0 t, NADDR
280 | 2/ t, V, NADDR
281 | there 2/ 7 + dup dup t, t, NADDR
282 | A, t, NADDR
283 | V, 0 t, NADDR
284 | A, A, NADDR
285 | V, V, NADDR
286 | ;m
287 | :m iLOAD there 2/ 3 4 * 3 + + 2* MOV 0 swap MOV ;m ( a a -- )
288 | assembler.1 +order definitions
289 | : begin talign there ; ( -- a )
290 | : again JMP ; ( a -- )
291 | : mark there 0 t, ; ( -- a : create hole in dictionary )
292 | : if talign ( a -- a : NB. "if" does not work for $8000 )
293 | 2/ dup t, Z there 2/ 4 + dup t, Z Z 6 + t, Z Z NADDR Z t,
294 | mark ;
295 | : until 2/ dup t, Z there 2/ 4 + dup t, Z Z 6 + t,
296 | Z Z NADDR Z t, 2/ t, ; ( a -- a )
297 | : else talign Z Z mark swap there 2/ swap t! ; ( a -- a )
298 | : +if talign Z 2/ t, mark ; ( a -- a )
299 | : -if talign
300 | 2/ t, Z there 2/ 4 + t, Z Z there 2/ 4 + t, Z Z mark ;
301 | : then begin 2/ swap t! ; ( a -- )
302 | : while if swap ; ( a a -- a a )
303 | : repeat JMP then ; ( a a -- )
304 | assembler.1 -order
305 | meta.1 +order definitions
306 | 0 t, 0 t, \ both locations must be zero
307 | label: entry \ used to set entry point in next cell
308 | -1 t, \ system entry point, set later
309 | opt.sys tvar {options} \ bit #1=echo off, #2 = checksum on,
310 | \ #4=info, #8=die on EOF
311 | 0 tvar primitive \ any address lower must be a VM primitive
312 | =stksz half tvar stacksz \ must contain $80
313 | -1 tvar neg1 \ must contain -1
314 | 1 tvar one \ must contain 1
315 | $10 tvar bwidth \ must contain 16
316 | $40 tvar mwidth \ maximum machine width
317 | 0 tvar r0 \ working pointer 1 (register r0)
318 | 0 tvar r1 \ register 1
319 | 0 tvar r2 \ register 2
320 | 0 tvar r3 \ register 3
321 | 0 tvar r4 \ register 4
322 | opt.self [if]
323 | 0 tvar {virtual} \ are we virtualized?
324 | 0 tvar {self} \ location of the self interpreter
325 | 0 tvar {pc} \ Emulated SUBLEQ Machine program counter
326 | $10 tvar {width} \ set by size detection routines
327 | [then]
328 | 0 tvar h \ dictionary pointer
329 | =thread half tvar {up} \ Current task addr. (Half size)
330 | 0 tvar check \ used for system checksum
331 | 0 tvar {context} E tallot \ vocabulary context
332 | 0 tvar {current} \ vocabulary to add new definitions to
333 | 0 tvar {forth-wordlist} \ forth word list (main vocabulary)
334 | 0 tvar {editor} \ editor vocabulary
335 | 0 tvar {root-voc} \ absolute minimum vocabulary
336 | 0 tvar {system} \ system functions vocabulary
337 | 0 tvar {boot} \ entry point of VM program, set later on
338 | 0 tvar {quit} \ Execution token called after init
339 | 0 tvar {last} \ last defined word
340 | 0 tvar {cycles} \ number of times we have switched tasks
341 | 1 tvar {single} \ is multi processing off? +ve = off
342 | 0 tvar {user} \ Number of locals assigned
343 | \ Thread variables, not all of which are user variables
344 | 0 tvar ip \ instruction pointer
345 | 0 tvar tos \ top of stack
346 | =thread =stksz + half dup tvar {rp0} tvar {rp}
347 | =thread =stksz double + half dup tvar {sp0} tvar {sp}
348 | 200 constant =tib \ Start of terminal input buffer
349 | 380 constant =num \ Start of numeric input buffer
350 | tuser {next-task} \ next task in task list
351 | tuser {ip-save} \ saved instruction pointer
352 | tuser {tos-save} \ saved top of variable stack
353 | tuser {rp-save} \ saved return stack pointer
354 | tuser {sp-save} \ saved variable stack pointer
355 | tuser {handler} \ throw/catch handler
356 | tuser {sender} \ multitasking; msg. send, 0 = no message
357 | tuser {message} \ multitasking; the message itself
358 | tuser {id} \ executing from block or terminal?
359 | tuser {precision} \ floating point precision (if FP on)
360 | :m INC 2/ neg1 2/ t, t, NADDR ;m ( b -- )
361 | :m DEC 2/ one 2/ t, t, NADDR ;m ( b -- )
362 | :m ONE! dup ZERO INC ; ( a -- : set address to '1' )
363 | :m NG1! dup ZERO DEC ; ( a -- : set address to '-1' )
364 | :m ++sp {sp} DEC ;m ( -- : grow variable stack )
365 | :m --sp {sp} INC ;m ( -- : shrink variable stack )
366 | :m --rp {rp} DEC ;m ( -- : shrink return stack )
367 | :m ++rp {rp} INC ;m ( -- : grow return stack )
368 | opt.optimize [if] ( optimizations on )
369 | :m a-optim 2/ >r there =cell - r> swap t! ;m ( a -- )
370 | [else]
371 | :m a-optim drop ;m ( a -- : optimization off )
372 | [then]
373 | opt.sm-vm-err [if]
374 | ( Smaller, more cryptic, error message string "Error" )
375 | 45 tvar err-str
376 | 72 t, 72 t, 6F t, 72 t, 0D t, 0A t, -1 t,
377 | [else]
378 | ( Error message string "Error: Not a 16-bit SUBLEQ VM" )
379 | 45 tvar err-str
380 | 72 t, 72 t, 6F t, 72 t, 3A t, 20 t, 4E t,
381 | 6F t, 74 t, 20 t, 61 t, 20 t, 31 t, 36 t, 2D t,
382 | 62 t, 69 t, 74 t, 20 t, 53 t, 55 t, 42 t, 4C t,
383 | 45 t, 51 t, 20 t, 56 t, 4D t, 0D t, 0A t, -1 t,
384 | [then]
385 | err-str 2/ tvar err-str-addr
386 | assembler.1 +order
387 | label: die
388 | err-str-addr r0 MOV ( load string address )
389 | label: die.loop
390 | r1 r0 iLOAD ( load character )
391 | r0 INC ( increment to next cell )
392 | r1 +if
393 | r1 PUT ( output single byte )
394 | die.loop JMP ( sentinel is a negative val )
395 | then
396 | ( fall-through )
397 | :a bye ( -- : first VM word, "bye", or halt the Forth system )
398 | HALT (a); ( ...like tears in rain. Time to die. )
399 | assembler.1 +order
400 | label: start \ System Entry Point
401 | start 2/ entry t! \ Set the system entry point
402 | r0 ONE! \ r0 = shift bit loop count
403 | r1 ONE! \ r1 = number of bits
404 | label: chk16
405 | r0 r0 ADD \ r0 = r0 * 2
406 | r1 INC \ r1++
407 | r1 r2 MOV \ r2 = r1
408 | mwidth r2 SUB r2 +if die JMP then \ check length < max width
409 | r0 +if chk16 JMP then \ check if still positive
410 | opt.self [if] \ if width > 16, jump to 16-bit emulator
411 | r1 r2 MOV
412 | r1 {width} MOV \ Save actual machine width
413 | bwidth r2 SUB r2 +if {self} iJMP then
414 | [then]
415 | bwidth r1 SUB r1 if die JMP then \ r1 - bwidth should be 0
416 | opt.self [if] ( self JMP ) there 2/ {pc} t! [then]
417 | {sp0} {sp} MOV \ Setup initial variable stack
418 | {rp0} {rp} MOV \ Setup initial return stack
419 | {boot} ip MOV \ Get the first instruction to execute
420 | ( fall-through )
421 | label: vm ( Forth Inner Interpreter )
422 | r0 ip iLOAD \ Get instruction to execute from IP
423 | ip INC \ IP now points to next instruction!
424 | primitive r1 MOV \ Copy as SUB is destructive
425 | r0 r1 SUB \ Check if it is a primitive
426 | r1 +if r0 iJMP then \ Jump straight to VM functions if it is
427 | ++rp \ If it wasn't a VM instruction, inc {rp}
428 | ip {rp} iSTORE \ and store ip to return stack
429 | r0 ip MOV vm a-optim \ "r0" holds our next instruction
430 | vm JMP \ Ad infinitum...
431 | :m ;a (fall-through); vm a-optim vm JMP ;m
432 | opt.self [if]
433 | 0 tvar {zreg} {zreg} 2/ tzreg !
434 | 0 tvar {areg} {areg} 2/ tareg !
435 | 0000 tvar {a} ( Emulated 'a' operand )
436 | 0000 tvar {b} ( Emulated 'b' operand )
437 | 0000 tvar {v} ( Temporary register 'v' )
438 | -0010 tvar {count} ( Top bit count, modified later )
439 | label: self
440 | self 2/ {self} t!
441 | {virtual} NG1!
442 | {width} {count} ADD
443 | label: self-loop
444 | {pc} {v} MOV \ Copy {pc} for next instruction
445 | neg1 2/ t, {v} 2/ t, -1 t, \ Conditionally halt on '{c}'
446 | {a} {pc} iLOAD {pc} INC
447 | {b} {pc} iLOAD {pc} INC
448 | {a} {v} MOV {v} INC {v} +if ( Input byte? )
449 | {b} {v} MOV {v} INC {v} +if ( Output byte? )
450 | ( Neither Input nor Output, must be normal instruction )
451 | \ This section performs "m[b] = m[b] - m[a]" and loads
452 | \ the result back into "{a}". A custom "iSUB" routine
453 | \ might speed things up here, one that stored the result
454 | \ in "{b}" but also kept a copy in "{a}".
455 | {a} {a} iLOAD \ a = m[a]
456 | {a} {b} iSUB \ m[b] = m[b] - a
457 | {a} {b} iLOAD \ a = m[b]
458 | \ This section prepares "{a}" for the next "+if", it
459 | \ shifts the 16-bit into the top place depending on the
460 | \ machine width. The bits lower than the 16-bit do not
461 | \ matter unless they are all zero, in which case this
462 | \ shifting has no effect anyway.
463 | {count} {v} MOV
464 | label: self.bit
465 | {a} {a} ADD {v} DEC
466 | {v} +if self.bit JMP then
467 | {a} +if \ !(v == 0 || v & 0x8000)
468 | {pc} INC
469 | self-loop JMP
470 | then
471 | {pc} {pc} iLOAD \ pc = m[c]
472 | self-loop JMP
473 | then ( Output byte from m[a] )
474 | {a} {a} iLOAD
475 | {a} PUT
476 | {pc} INC
477 | self-loop JMP
478 | then ( Input byte and store in m[b] )
479 | {a} GET
480 | {a} {b} iSTORE
481 | {pc} INC
482 | self-loop JMP ( And do it again... )
483 | 0 tzreg !
484 | 1 tareg !
485 | [then]
486 | assembler.1 -order
487 | :a opSwap tos r0 MOV tos {sp} iLOAD r0 {sp} iSTORE ;a
488 | :a opDup ++sp tos {sp} iSTORE ;a ( n -- n n )
489 | :a opFromR ++sp tos {sp} iSTORE tos {rp} iLOAD --rp ;a
490 | :a opToR ++rp tos {rp} iSTORE (fall-through); ( !!! )
491 | :a opDrop tos {sp} iLOAD --sp ;a ( n -- )
492 | :a [@] tos tos iLOAD ;a ( a -- a : load SUBLEQ address )
493 | :a [!] r0 {sp} iLOAD r0 tos iSTORE --sp t' opDrop JMP (a);
494 | :a opEmit tos PUT t' opDrop JMP (a); ( n -- )
495 | :a opExit ip {rp} iLOAD (fall-through); ( !!! ) ( R: a -- )
496 | :a rdrop --rp ;a ( R: u -- )
497 | :a opIpInc ip INC ;a ( -- : increment instruction pointer )
498 | :a opJumpZ ( u -- : Conditional jump on zero )
499 | tos r0 MOV
500 | tos {sp} iLOAD --sp
501 | r0 if t' opIpInc JMP then r0 DEC r0 +if t' opIpInc JMP then
502 | (fall-through); ( !!! )
503 | :a opJump ip ip iLOAD ;a ( -- : Unconditional jump )
504 | :a opNext r0 {rp} iLOAD ( R: n -- | n-1 )
505 | r0 +if r0 DEC r0 {rp} iSTORE t' opJump JMP then
506 | --rp t' opIpInc JMP (a);
507 | :a op0= ( n -- f : not equal to zero )
508 | ( does not work: "tos if tos ZERO else tos NG1! then vm JMP" )
509 | tos if ( assembly 'if' does not work for entire range )
510 | tos ZERO
511 | else ( deal with incorrect results )
512 | tos DEC
513 | tos +if tos ZERO else tos NG1! then
514 | then ;a
515 | :a leq0 ( n -- 0|1 : less than or equal to zero )
516 | Z tos 2/ t, there 2/ 4 + t,
517 | tos 2/ dup t, t, vm 2/ t,
518 | tos ONE! ;a
519 | :a - tos {sp} iSUB t' opDrop JMP (a); ( n n -- n )
520 | :a + tos {sp} iADD t' opDrop JMP (a); ( n n -- n )
521 | :a shift ( u n -- u : right shift 'u' by 'n' places )
522 | bwidth r0 MOV \ load machine bit width
523 | tos r0 SUB \ adjust tos by machine width
524 | tos {sp} iLOAD --sp \ pop value to shift
525 | r1 ZERO \ zero result register
526 | label: shift.loop
527 | r1 r1 ADD \ double r1, equivalent to left shift by one
528 | \ work out what bit to shift into r1
529 | tos +if else
530 | tos r2 MOV r2 INC r2 +if else r1 INC then then
531 | tos tos ADD \ double tos, equivalent to left shift by one
532 | r0 DEC \ decrement loop counter
533 | r0 +if shift.loop JMP then
534 | r1 tos MOV ;a \ move result back into tos
535 | :a opMux ( u1 u2 u3 -- u : bitwise multiplexor function )
536 | \ tos contains multiplexor value
537 | bwidth r0 MOV \ load loop counter initial value [16]
538 | r1 ZERO \ zero results register
539 | r3 {sp} iLOAD --sp \ pop first input
540 | r4 {sp} iLOAD --sp \ pop second input
541 |
542 | label: opMux.loop
543 | r1 r1 ADD \ shift results register
544 | \ determine topmost bit of 'tos', place result in 'r2'
545 | \ this is used to select whether to use r3 or r4
546 | tos +if label: opMux.r3 r3 r2 MOV else
547 | tos r2 MOV
548 | r2 INC r2 +if
549 | opMux.r3 JMP ( space saving ) else
550 | r4 r2 MOV then then
551 | \ determine whether we should add 0/1 into result
552 | r2 +if else r2 INC r2 +if else r1 INC then then
553 | tos tos ADD \ shift tos
554 | r3 r3 ADD \ shift r3
555 | r4 r4 ADD \ shift r4
556 | r0 DEC \ decrement loop counter
557 | r0 +if opMux.loop JMP then
558 | r1 tos MOV ;a \ move r1 to tos, returning our result
559 | opt.divmod [if]
560 | :a opDivMod ( u1 u2 -- u1 u2 )
561 | r0 {sp} iLOAD
562 | r1 ZERO ( zero quotient )
563 | label: divStep
564 | r1 INC ( increment quotient )
565 | tos r0 SUB ( repeated subtraction )
566 | r0 -if
567 | tos r0 ADD ( correct remainder )
568 | r1 DEC ( correct quotient )
569 | r1 tos MOV ( store results back to tos )
570 | r0 {sp} iSTORE ( ...and stack )
571 | vm JMP ( finish... )
572 | then
573 | divStep JMP ( perform another division step )
574 | (a);
575 | [then]
576 | opt.multi [if]
577 | :a pause ( -- : pause and switch task )
578 | \ "{single}" must be positive and not zero to
579 | \ turn off "pause", this is to save space as "+if" can be
580 | \ used.
581 | {single} +if vm JMP then \ Do nothing if single-threaded mode
582 | r0 {up} iLOAD \ load next task pointer from user storage
583 | \ "+if" saves space, "r0" should never be negative anyway as
584 | \ this would mean that the thread was above the 32678 mark
585 | \ and thus in an area where "@" and "!" would not work (only
586 | \ "[@]" and "[!]".
587 | r0 +if
588 | {cycles} INC \ increment "pause" count
589 | {up} r1 MOV r1 INC \ load TASK pointer, skip next task loc
590 | ip r1 iSTORE r1 INC \ save registers to current task
591 | tos r1 iSTORE r1 INC \ only a few need to be saved
592 | {rp} r1 iSTORE r1 INC
593 | {sp} r1 iSTORE
594 | r0 {rp0} MOV stacksz {rp0} ADD \ change {rp0} to new loc
595 | {rp0} {sp0} MOV stacksz {sp0} ADD \ same but for {sp0}
596 | r0 {up} MOV r0 INC \ set next task
597 | ip r0 iLOAD r0 INC \ reverse of save registers
598 | tos r0 iLOAD r0 INC
599 | {rp} r0 iLOAD r0 INC
600 | {sp} r0 iLOAD \ we're all golden
601 | then ;a
602 | [else]
603 | :m pause ;m ( -- [disabled] )
604 | [then]
605 | there 2/ primitive t! ( set 'primitive', needed for VM )
606 | :m munorder target.only.1 -order talign ;m
607 | :m (;t)
608 | CAFE <> if abort" Unstructured" then
609 | munorder ;m
610 | :m ;t (;t) opExit ;m
611 | :m :s tlast @ {system} t@ tlast ! F00D :t drop 0 ;m
612 | :m :so tlast @ {system} t@ tlast ! F00D :to drop 0 ;m
613 | :m ;s drop CAFE ;t F00D <> if abort" unstructured" then
614 | tlast @ {system} t! tlast ! ;m
615 | :m :r tlast @ {root-voc} t@ tlast ! BEEF :t drop 0 ;m
616 | :m ;r drop CAFE ;t BEEF <> if abort" unstructured" then
617 | tlast @ {root-voc} t! tlast ! ;m
618 | :m :e tlast @ {editor} t@ tlast ! DEAD :t drop 0 ;m
619 | :m ;e drop CAFE ;t DEAD <> if abort" unstructured" then
620 | tlast @ {editor} t! tlast ! ;m
621 | :m system[ tlast @ {system} t@ tlast ! BABE ;m
622 | :m ]system BABE <> if abort" unstructured" then
623 | tlast @ {system} t! tlast ! ;m
624 | :m root[ tlast @ {root-voc} t@ tlast ! D00D ;m
625 | :m ]root D00D <> if abort" unstructured" then
626 | tlast @ {root-voc} t! tlast ! ;m
627 | :m : :t ;m ( -- ???, "name" : start cross-compilation )
628 | :m ; ;t ;m ( ??? -- : end cross-compilation of a target word )
629 | :m begin talign there ;m ( -- a : meta 'begin' )
630 | :m until talign opJumpZ 2/ t, ;m ( a -- : meta 'until' )
631 | :m again talign opJump 2/ t, ;m ( a -- : meta 'again' )
632 | :m if opJumpZ there 0 t, ;m ( -- a : meta 'if' )
633 | :m tmark opJump there 0 t, ;m ( -- a : meta mark location )
634 | :m then there 2/ swap t! ;m ( a -- : meta 'then' )
635 | :m else tmark swap then ;m ( a -- a : meta 'else' )
636 | :m while if ;m ( -- a : meta 'while' )
637 | :m repeat swap again then ;m ( a a -- : meta 'repeat' )
638 | :m aft drop tmark begin swap ;m ( a -- a a : meta 'aft' )
639 | :m next talign opNext 2/ t, ;m ( a -- : meta 'next' )
640 | :m for opToR begin ;m ( -- a : meta 'for )
641 | :m =jump [ t' opJump half ] literal ;m ( -- a )
642 | :m =jumpz [ t' opJumpZ half ] literal ;m ( -- a )
643 | :m =unnest [ t' opExit half ] literal ;m ( -- a )
644 | :m =>r [ t' opToR half ] literal ;m ( -- a )
645 | :m =next [ t' opNext half ] literal ;m ( -- a )
646 | :m dup opDup ;m ( -- : compile opDup into the dictionary )
647 | :m drop opDrop ;m ( -- : compile opDrop into the dictionary )
648 | :m swap opSwap ;m ( -- : compile opSwap into the dictionary )
649 | :m >r opToR ;m ( -- : compile opTorR into the dictionary )
650 | :m r> opFromR ;m ( -- : compile opFromR into the dictionary )
651 | :m 0= op0= ;m ( -- : compile op0= into the dictionary )
652 | :m mux opMux ;m ( -- : compile opMux into the dictionary )
653 | :m exit opExit ;m ( -- : compile opExit into the dictionary )
654 | :m rshift shift ;m ( -- : compile shift into the dictionary )
655 | :to + + ; ( n n -- n : addition )
656 | :to - - ; ( n1 n2 -- n : subtract n2 from n1 )
657 | :to bye bye ; ( -- : halt the system )
658 | :to dup dup ; ( n -- n n : duplicate top of variable stack )
659 | :to drop opDrop ; ( n -- : drop top of variable stack )
660 | :to swap opSwap ; ( x y -- y x : swap two variables on stack )
661 | :to rshift shift ; ( u n -- u : logical right shift by "n" )
662 | :so [@] [@] ;s ( vma -- : fetch -VM Address- )
663 | :so [!] [!] ;s ( u vma -- : store to -VM Address- )
664 | :to 0= op0= ; ( n -- f : equal to zero )
665 | :so leq0 leq0 ;s ( n -- 0|1 : less than or equal to zero )
666 | :so mux opMux ;s ( u1 u2 sel -- u : bitwise multiplex op. )
667 | :so pause pause ;s ( -- : pause current task, task switch )
668 | : 2* dup + ; ( u -- u : multiply by two )
669 | :s (const) r> [@] ;s compile-only ( R: a --, -- u )
670 | :m constant :t mdrop (const) t, munorder ;m
671 | system[
672 | 0 constant #0 ( -- 0 : push the number zero onto the stack )
673 | 1 constant #1 ( -- 1 : push one onto the stack )
674 | -1 constant #-1 ( -- -1 : push negative one onto the stack )
675 | 2 constant #2 ( -- 2 : push two onto the stack )
676 | -2 constant -cell ( -- -2 : push negative two onto the stack )
677 | ]system
678 | : 1+ #1 + ; ( n -- n : increment value in cell )
679 | : 1- #1 - ; ( n -- n : decrement value in cell )
680 | :s (push) r> dup [@] swap 1+ >r ;s ( -- n : inline push value )
681 | :m lit (push) t, ;m ( n -- : compile a literal )
682 | :m literal lit ;m ( n -- : synonym for "lit" )
683 | :m ] ;m ( -- : meta-compiler version of "]", do nothing )
684 | :m [ ;m ( -- : meta-compiler version of "[", do nothing )
685 | :s (up) r> dup [@] [ {up} half ] literal [@] 2* + swap 1+ >r ;s
686 | compile-only ( -- n : user variable implementation word )
687 | :s (var) r> 2* ;s compile-only ( R: a --, -- a )
688 | :s (user) r> [@] [ {up} half ] literal [@] 2* + ;s compile-only
689 | ( R: a --, -- u )
690 | :m up (up) t, ;m ( n -- : compile user variable )
691 | :m [char] char (push) t, ;m ( --, "name" : compile char )
692 | :m char char (push) t, ;m ( --, "name" : compile char )
693 | :m variable :t mdrop (var) 0 t, munorder ;m ( --, "name": var )
694 | :m user :t mdrop (user) local? =cell lallot t, munorder ;m
695 | :to ) ; immediate ( -- : NOP, terminate comment )
696 | : over swap dup >r swap r> ; ( n1 n2 -- n1 n2 n1 )
697 | : invert #-1 swap - ; ( u -- u : bitwise invert )
698 | : xor >r dup invert swap r> mux ; ( u u -- u : bitwise xor )
699 | : or over mux ; ( u u -- u : bitwise or )
700 | : and #0 swap mux ; ( u u -- u : bitwise and )
701 | : 2/ #1 rshift ; ( u -- u : divide by two )
702 | : @ 2/ [@] ; ( a -- u : fetch a cell to a memory location )
703 | : ! 2/ [!] ; ( u a -- : write a cell to a memory location )
704 | :s @+ dup @ ;s ( a -- a u : non-destructive load )
705 | user ( -- a : okay prompt xt loc. )
706 | system[
707 | user ( -- a : emit xt loc. )
708 | user ( -- a : key xt loc. )
709 | user ( -- a : echo xt loc. )
710 | user ( -- a : literal xt loc. )
711 | user ( -- a : tap xt loc. )
712 | user ( -- a : expect xt loc. )
713 | user ( -- a : xt container. )
714 | ]system
715 | :s [ {boot} ] literal ;s ( -- a : cold xt loc. )
716 | :s [ {quit} ] literal ;s ( -- a : quit xt loc. )
717 | : current ( -- a : get current vocabulary )
718 | [ {current} ] literal ;
719 | : root-voc ( -- a : get root vocabulary )
720 | [ {root-voc} ] literal ;
721 | : this [ 0 ] up ; ( -- a : address of task thread memory )
722 | : pad this [ 3C0 ] literal + ; ( -- a : index into pad area )
723 | 8 constant #vocs ( -- u : number of vocabularies )
724 | : context [ {context} ] literal ; ( -- a )
725 | variable blk ( -- a : loaded block )
726 | variable scr ( -- a : latest listed block )
727 | 2F t' scr >tbody t! ( Set default block to list, an empty one )
728 | user base ( -- a : push the radix for numeric I/O )
729 | user dpl ( -- a : decimal point variable )
730 | user hld ( -- a : index to hold space for num. I/O)
731 | user state ( -- f : interpreter state )
732 | user >in ( -- a : input buffer position var )
733 | user span ( -- a : number of chars saved by expect )
734 | $20 constant bl ( -- 32 : push space character )
735 | system[
736 | h constant h? ( -- a : push the location of dict. ptr )
737 | {cycles} constant cycles ( -- a : number of "cycles" ran for )
738 | {sp} constant sp ( -- a : address of v.stk ptr. )
739 | {user} constant user? ( -- a : address of user alloc var )
740 | variable calibration 1400 t' calibration >tbody t!
741 | ]system
742 | :s radix base @ ;s ( -- u : retrieve base )
743 | : here h? @ ; ( -- u : push the dictionary pointer )
744 | : sp@ sp @ 1+ ; ( -- a : Fetch variable stack pointer )
745 | : sp! 1- [ {sp} half ] literal [!] #1 drop ;
746 | : rp@ [ {rp} half ] literal [@] 1- ; compile-only
747 | : rp! r> swap [ {rp} half ] literal [!] >r ; compile-only
748 | : hex [ $10 ] literal base ! ; ( -- : hexadecimal base )
749 | : decimal [ $A ] literal base ! ; ( -- : decimal base )
750 | :to ] #-1 state ! ; ( -- : return to compile mode )
751 | :to [ #0 state ! ; immediate ( -- : initiate command mode )
752 | : nip swap drop ; ( x y -- y : remove second item on stack )
753 | : tuck swap over ; ( x y -- y x y : save item for rainy day )
754 | : ?dup dup if dup then ; ( x -- x x | 0 : conditional dup )
755 | : r@ r> r> tuck >r >r ; compile-only ( R: n -- n, -- n )
756 | : rot >r swap r> swap ; ( x y z -- y z x : "rotate" stack )
757 | : -rot rot rot ; ( x y z -- z x y : "rotate" stack backwards )
758 | : 2drop drop drop ; ( x x -- : drop it like it is hot )
759 | : 2dup over over ; ( x y -- x y x y )
760 | :s shed rot drop ;s ( x y z -- y z : drop third stack item )
761 | : = - 0= ; ( u1 u2 -- f : equality )
762 | : <> = 0= ; ( u1 u2 -- f : inequality )
763 | : 0> leq0 0= ; ( n -- f : greater than zero )
764 | : 0<> 0= 0= ; ( n -- f : not equal to zero )
765 | : 0<= 0> 0= ; ( n -- f : less than or equal to zero )
766 | : < ( n1 n2 -- f : less than, is n1 less than n2 )
767 | 2dup leq0 swap leq0 if
768 | if
769 | 2dup 1+ leq0 swap 1+ leq0
770 | if drop else if 2drop #0 exit then then
771 | else 2drop #-1 exit then \ a0 && !b0
772 | else
773 | if 2drop #0 exit then \ !a0 && b0
774 | then
775 | 2dup - leq0 if
776 | swap 1+ swap - leq0 if #-1 exit then
777 | #0 exit
778 | then
779 | 2drop #0 ;
780 | : > swap < ; ( n1 n2 -- f : signed greater than )
781 | : 0< #0 < ; ( n -- f : less than zero )
782 | : 0>= 0< 0= ; ( n1 n2 -- f : greater or equal to zero )
783 | : >= < 0= ; ( n1 n2 -- f : greater than or equal to )
784 | : <= > 0= ; ( n1 n2 -- f : less than or equal to )
785 | : u< 2dup 0>= swap 0>= <> >r < r> <> ; ( u1 u2 -- f )
786 | : u> swap u< ; ( u1 u2 -- f : unsigned greater than )
787 | : u>= u< 0= ; ( u1 u2 -- f : unsigned greater or equal to )
788 | : u<= u> 0= ; ( u1 u2 -- f : unsigned less than or equal to )
789 | : within over - >r - r> u< ; ( u lo hi -- f )
790 | : negate 1- invert ; ( n -- n : twos compliment negation )
791 | : s>d dup 0< ; ( n -- d : signed to double width cell )
792 | : abs s>d if negate then ; ( n -- u : absolute value )
793 | 2 constant cell ( -- u : push bytes in cells to stack )
794 | : cell+ cell + ; ( a -- a : increment address by cell width )
795 | : cells 2* ; ( u -- u : multiply # of cells to get bytes )
796 | : cell- cell - ; ( a -- a : decrement address by cell width )
797 | : execute 2/ >r ; ( xt -- : execute an execution token )
798 | :s @execute ( ?dup 0= ?exit ) @ execute ;s ( xt -- )
799 | : ?exit if rdrop then ; compile-only ( u --, R: -- |??? )
800 | : key? pause #-1 [@] negate ( -- c 0 | -1 : get byte of input )
801 | s>d if
802 | [ {options} ] literal @
803 | [ 8 ] literal and if bye then drop #0 exit
804 | then #-1 ;
805 | : key begin @execute until ; ( -- c )
806 | : emit @execute ; ( c -- : output byte )
807 | : cr ( -- : emit new line )
808 | [ =cr ] literal emit
809 | [ =lf ] literal emit ;
810 | : get-current current @ ; ( -- wid : get definitions vocab. )
811 | : set-current current ! ; ( -- wid : set definitions vocab. )
812 | :s last get-current @ ;s ( -- wid : get last defined word )
813 | : pick sp@ + [@] ; ( nu...n0 u -- nu : pick item on stack )
814 | : +! 2/ tuck [@] + swap [!] ; ( u a -- : add val to cell )
815 | : lshift negate shift ; ( u n -- u : left shift 'u' by 'n' )
816 | : c@ ( a -- c : character load )
817 | @+ swap #1 and if
818 | [ 8 ] literal rshift exit
819 | then [ FF ] literal and ;
820 | : c! swap [ FF ] literal and dup [ 8 ] literal lshift or swap
821 | tuck @+ swap #1 and 0= [ FF ] literal xor
822 | >r over xor r> and xor swap ! ; ( c a -- character store )
823 | :s c@+ dup c@ ;s ( b -- b u : non-destructive 'c@' )
824 | : max 2dup > mux ; ( n1 n2 -- n : highest of two numbers )
825 | : min 2dup < mux ; ( n1 n2 -- n : lowest of two numbers )
826 | : source-id [ {id} ] up @ ; ( -- u : input type )
827 | : 2! tuck ! cell+ ! ; ( u1 u2 a -- : store two cells )
828 | : 2@ dup cell+ @ swap @ ; ( a -- u1 u2 : fetch two cells )
829 | : 2>r r> swap >r swap >r >r ; compile-only ( n n --,R: -- n n )
830 | : 2r> r> r> swap r> swap >r ; compile-only ( -- n n,R: n n -- )
831 | system[ user tup =cell tallot ]system
832 | : source tup 2@ ; ( -- a u : get terminal input source )
833 | : aligned dup #1 and 0<> #1 and + ; ( u -- u : align up ptr. )
834 | : align here aligned h? ! ; ( -- : align up dict. ptr. )
835 | : allot h? +! ; ( n -- : allocate space in dictionary )
836 | : , align here ! cell allot ; ( u -- : write value into dict. )
837 | : c, here c! #1 allot ; ( c -- : write character into dict. )
838 | : count dup 1+ swap c@ ; ( b -- b c : advance string )
839 | : +string #1 over min rot over + -rot - ; ( b u -- b u )
840 | :s .emit ( c -- : print char, replacing non-graphic ones )
841 | dup bl [ $7F ] literal within [char] . swap mux emit ;s
842 | : type 1- for count emit next drop ;
843 | : cmove ( b1 b2 n -- : move character blocks around )
844 | #0 max for aft >r c@+ r@ c! 1+ r> 1+ then next 2drop ;
845 | : fill ( b n c -- : write byte 'c' to array 'b' of 'u' length )
846 | swap #0 max for swap aft 2dup c! 1+ then next 2drop ;
847 | : erase #0 fill ; ( b u -- : write zeros to array )
848 | :s do$ 2r> 2* dup count + aligned 2/ >r swap >r ;s ( -- a )
849 | :s ($) do$ ;s ( -- a : do string NB. )
850 | :s .$ do$ count type ;s ( -- : print string in next cells )
851 | :m ." .$ $literal ;m ( --, ccc" : compile string )
852 | :m $" ($) $literal ;m ( --, ccc" : compile string )
853 | : space bl emit ; ( -- : emit a space )
854 | : catch ( xt -- exception# | 0 \ return addr on stack )
855 | sp@ >r ( xt ) \ save data stack pointer
856 | [ {handler} ] up @ >r ( xt ) \ and previous handler
857 | rp@ [ {handler} ] up ! ( xt ) \ set current handler
858 | execute ( ) \ execute returns if no throw
859 | r> [ {handler} ] up ! ( ) \ restore previous handler
860 | rdrop ( ) \ discard saved stack ptr
861 | #0 ; ( 0 ) \ normal completion
862 | : throw ( ??? exception# -- ??? exception# )
863 | ?dup if ( exc# ) \ 0 throw is no-op
864 | [ {handler} ] up @ rp! ( exc# ) \ restore prev ret. stack
865 | r> [ {handler} ] up ! ( exc# ) \ restore prev handler
866 | r> swap >r ( saved-sp ) \ exc# on return stack
867 | sp! r> ( exc# ) \ restore stack
868 | then ;
869 | : abort #-1 throw ; ( -- : Time to die. )
870 | :s (abort) do$ swap if count type abort then drop ;s ( n -- )
871 | :s depth [ {sp0} ] literal @ sp@ - 1- ;s ( -- n : stk. depth )
872 | :s ?depth depth >= [ -$4 ] literal and throw ;s ( ??? n -- )
873 | : um+ 2dup + >r r@ 0>= >r ( u u -- u carry )
874 | 2dup and 0< r> or >r or 0< r> and negate r> swap ;
875 | : dnegate invert >r invert #1 um+ r> + ; ( d -- d )
876 | : d+ >r swap >r um+ r> + r> + ; ( d d -- d )
877 | : um* ( u u -- ud : double cell width multiply )
878 | #0 swap ( u1 0 u2 )
879 | [ $F ] literal for ( 16 times )
880 | dup um+ 2>r dup um+ r> + r>
881 | if >r over um+ r> + then
882 | next shed ;
883 | : * um* drop ; ( n n -- n : multiply two numbers )
884 | : um/mod ( ud u -- ur uq : unsigned double cell div/mod )
885 | ?dup 0= [ -$A ] literal and throw ( divisor is non zero? )
886 | 2dup u<
887 | if
888 | negate
889 | [ $F ] literal for ( 16 times )
890 | >r dup um+ 2>r dup um+ r> + dup
891 | r> r@ swap >r um+ r> ( or -> ) 0<> swap 0<> +
892 | if >r drop 1+ r> else drop then r>
893 | next
894 | drop swap exit
895 | then 2drop drop #-1 dup ;
896 | : m/mod ( d n -- r q : floored division, hopefully not flawed )
897 | s>d dup >r
898 | if negate >r dnegate r> then
899 | >r s>d if r@ + then r> um/mod r> ( modify um/mod result )
900 | if swap negate swap then ;
901 | : /mod over 0< swap m/mod ; ( u1 u2 -- u1%u2 u1/u2 )
902 | : mod /mod drop ; ( u1 u2 -- u1%u2 )
903 | : / /mod nip ; ( u1 u2 -- u1/u2 )
904 | :s (emit) pause opEmit ;s ( c -- : output byte to terminal )
905 | : echo @execute ; ( c -- : emit a single character )
906 | :s tap dup echo over c! 1+ ;s ( bot eot cur c -- bot eot cur )
907 | :s ktap ( bot eot cur c -- bot eot cur )
908 | ( Not EOL? )
909 | dup dup [ =cr ] literal <> >r [ =lf ] literal <> r> and if
910 | ( Not Del Char? )
911 | dup [ =bksp ] literal <> >r [ =del ] literal <> r> and if
912 | bl tap ( replace any other character with bl )
913 | exit
914 | then
915 | >r over r@ < dup if ( if not at start of line )
916 | [ =bksp ] literal dup echo bl echo echo ( erase char )
917 | then
918 | r> + ( add 0/-1 to cur )
919 | exit
920 | then drop nip dup ;s ( set cur = eot )
921 | : accept ( b u -- b u : read in a line of user input )
922 | over + over begin
923 | 2dup <>
924 | while
925 | key dup
926 | bl - [ $5F ] literal u< ( magic: within 32-127? )
927 | if tap else @execute then
928 | repeat drop over - ;
929 | : expect @execute span ! drop ; ( a u -- )
930 | : tib source drop ; ( -- b : get Terminal Input Buffer )
931 | : query ( -- : get a new line of input, store it in TIB )
932 | tib [ =buf ] literal @execute tup ! drop #0 >in ! ;
933 | : -trailing for aft ( b u -- b u : remove trailing spaces )
934 | bl over r@ + c@ < if r> 1+ exit then
935 | then next #0 ;
936 | :s look ( b u c xt -- b u : skip until *xt* test succeeds )
937 | swap >r -rot
938 | begin
939 | dup
940 | while
941 | over c@ r@ - r@ bl = [ 4 ] literal pick execute
942 | if rdrop shed exit then
943 | +string
944 | repeat rdrop shed ;s
945 | :s unmatch if 0> exit then 0<> ;s ( c1 c2 -- t )
946 | :s match unmatch invert ;s ( c1 c2 -- t )
947 | : parse ( c -- b u ; )
948 | >r tib >in @ + tup @ >in @ - r@ ( get memory to parse )
949 | >r over r> swap 2>r
950 | r@ [ t' unmatch ] literal look 2dup ( find start of match )
951 | r> [ t' match ] literal look swap ( find end of match )
952 | r> - >r - r> 1+ ( b u c -- b u delta : compute match len )
953 | >in +!
954 | r> bl = if -trailing then
955 | #0 max ;
956 | :s banner ( +n c -- : output 'c' 'n' times )
957 | >r begin dup 0> while r@ emit 1- repeat drop rdrop ;s
958 | : hold #-1 hld +! hld @ c! ; ( c -- : save char in hold space )
959 | : #> 2drop hld @ this [ =num ] literal + over - ; ( u -- b u )
960 | :s extract ( ud ud -- ud u : extract digit from number )
961 | dup >r um/mod r> swap >r um/mod r> rot ;s
962 | :s digit ( u -- c : extract a character from number )
963 | [ 9 ] literal over < [ 7 ] literal and + [char] 0 + ;s
964 | : # #2 ?depth #0 radix extract digit hold ; ( d -- d )
965 | : #s begin # 2dup ( d0= -> ) or 0= until ; ( d -- 0 )
966 | : <# this [ =num ] literal + hld ! ; ( -- : start num. output )
967 | : sign 0>= ?exit [char] - hold ; ( n -- )
968 | : u.r >r #0 <# #s #> r> over - bl banner type ; ( u r -- )
969 | : u. space #0 u.r ; ( u -- : unsigned numeric output )
970 | opt.divmod [if]
971 | :s (.) abs radix opDivMod ?dup if (.) then digit emit ;s
972 | : . space s>d if [char] - emit then (.) ; ( n -- )
973 | [else]
974 | : . space dup >r abs #0 <# #s r> sign #> type ; ( n -- )
975 | [then]
976 | : >number ( ud b u -- ud b u : convert string to number )
977 | dup 0= ?exit
978 | begin
979 | 2dup 2>r drop c@ radix ( get next character )
980 | ( digit? -> ) >r [char] 0 - [ 9 ] literal over <
981 | if
982 | ( next line: c base -- u f )
983 | [ 7 ] literal - dup [ $A ] literal < or then dup r> u<
984 | 0= if ( d char )
985 | drop ( d char -- d )
986 | 2r> ( restore string )
987 | exit ( finished...exit )
988 | then ( d char )
989 | swap radix um* drop rot radix um* d+ ( accumulate digit )
990 | 2r> ( restore string )
991 | +string dup 0= ( advance, test for end )
992 | until ;
993 | : number? ( a u -- d -1 | a u 0 : easier to use than >number )
994 | #-1 dpl !
995 | radix >r
996 | over c@ [char] - = dup >r if +string then
997 | over c@ [char] $ = if hex +string
998 | ( dup 0= if dup rdrop r> base ! exit then )
999 | then
1000 | 2>r #0 dup 2r>
1001 | begin
1002 | >number dup
1003 | while over c@ [char] . <>
1004 | if shed rot r> 2drop #0 r> base ! exit then
1005 | 1- dpl ! 1+ dpl @
1006 | repeat
1007 | 2drop r> if dnegate then r> base ! #-1 ;
1008 | : .s depth for aft r@ pick . then next ; ( -- : show stack )
1009 | : compare ( a1 u1 a2 u2 -- n : string comparison )
1010 | rot
1011 | over - ?dup if >r 2drop r> nip exit then
1012 | for ( a1 a2 )
1013 | aft
1014 | count rot count rot - ?dup
1015 | if rdrop nip nip exit then
1016 | then
1017 | next 2drop #0 ;
1018 | : nfa cell+ ; ( pwd -- nfa : move word ptr to name field )
1019 | : cfa ( pwd -- cfa : move to Code Field Address )
1020 | nfa c@+ [ 1F ] literal and + cell+ -cell and ;
1021 | :s (search) ( a wid -- PWD PWD 1 | PWD PWD -1 | 0 a 0 )
1022 | \ Search for word "a" in "wid"
1023 | swap >r dup
1024 | begin
1025 | dup
1026 | while
1027 | ( $9F = $1F:word-length + $80:hidden )
1028 | dup nfa count [ $9F ] literal
1029 | and r@ count compare 0=
1030 | if ( found! )
1031 | rdrop
1032 | dup ( immediate? -> ) nfa [ $40 ] literal swap @ and 0<>
1033 | #1 or negate exit
1034 | then
1035 | nip @+
1036 | repeat
1037 | rdrop 2drop #0 ;s
1038 | :s (find) ( a -- pwd pwd 1 | pwd pwd -1 | 0 a 0 : find a word )
1039 | >r
1040 | context
1041 | begin
1042 | @+
1043 | while
1044 | @+ @ r@ swap (search) ?dup
1045 | if
1046 | >r shed r> rdrop exit
1047 | then
1048 | cell+
1049 | repeat drop #0 r> #0 ;s
1050 | : search-wordlist ( a wid -- PWD 1|PWD -1|a 0 )
1051 | (search) shed ;
1052 | : find ( a -- pwd 1 | pwd -1 | a 0 : find word in dictionary )
1053 | (find) shed ;
1054 | : compile r> dup [@] , 1+ >r ; compile-only ( -- )
1055 | :s (literal) state @ if compile (push) , then ;s ( u -- )
1056 | :to literal @execute ; immediate ( u -- )
1057 | : compile, ( align <- called by "," ) 2/ , ; ( xt -- )
1058 | :s ?found ?exit ( b f -- b | ??? )
1059 | space count type [char] ? emit cr [ -$D ] literal throw ;s
1060 | : interpret ( b -- : interpret a counted word )
1061 | find ?dup if
1062 | state @
1063 | if
1064 | 0> if cfa execute exit then \ <- execute immediate words
1065 | cfa compile, exit \ <- compiling word are...compiled.
1066 | then
1067 | drop
1068 | ( next line performs "?compile" )
1069 | dup nfa c@ [ 20 ] literal and 0<> [ -$E ] literal and throw
1070 | \ if it's not compiling, execute it then exit *interpreter*
1071 | cfa execute exit
1072 | then
1073 | \ not a word
1074 | dup >r count number? if rdrop \ it is numeric!
1075 | dpl @ 0< if \ <- dpl is -1 if it's a single cell number
1076 | drop \ drop high cell from 'number?' for single cell
1077 | else \ <- dpl is not -1, it is a double cell number
1078 | state @ if swap then
1079 | postpone literal \ literal executed twice if # is double
1080 | then \ NB. "literal" is state aware
1081 | postpone literal exit
1082 | then
1083 | \ N.B. Could vector ?found here, to handle arbitrary words
1084 | r> #0 ?found ;
1085 | : get-order ( -- widn...wid1 n : get current search order )
1086 | context
1087 | \ next line finds first empty cell
1088 | #0 >r begin @+ r@ xor while cell+ repeat rdrop
1089 | dup cell- swap
1090 | context - 2/ dup >r 1- s>d [ -$32 ] literal and throw
1091 | for aft @+ swap cell- then next @ r> ;
1092 | :r set-order ( widn ... wid1 n -- : set current search order )
1093 | \ NB. Uses recursion, however the meta-compiler does not use
1094 | \ the Forth compilation mechanism, so the current definition
1095 | \ of "set-order" is available immediately.
1096 | dup #-1 = if drop root-voc #1 set-order exit then
1097 | dup #vocs > [ -$31 ] literal and throw
1098 | context swap for aft tuck ! cell+ then next #0 swap ! ;r
1099 | : (order) ( w wid*n n -- wid*n w n )
1100 | dup if
1101 | 1- swap >r ( recurse -> ) (order) over r@ xor
1102 | if 1+ r> -rot exit then rdrop
1103 | then ;
1104 | : -order ( wid -- : remove vocabulary from search order )
1105 | get-order (order) nip set-order ;
1106 | : +order ( wid -- : add vocabulary to search order )
1107 | dup >r -order get-order r> swap 1+ set-order ;
1108 | root[
1109 | {forth-wordlist} constant forth-wordlist ( -- wid )
1110 | {system} constant system ( -- wid )
1111 | ]root
1112 | :r forth ( -- : set system to contain default vocabularies )
1113 | root-voc forth-wordlist #2 set-order ;r
1114 | :r only #-1 set-order ;r ( -- : set minimal search order )
1115 | :s .id ( pwd -- : print word )
1116 | nfa count [ $1F ] literal and type space ;s
1117 | :r words ( -- : list all words in all loaded vocabularies )
1118 | cr get-order
1119 | begin ?dup while swap ( dup u. ." : " ) @
1120 | begin ?dup
1121 | while dup nfa c@ [ $80 ] literal and 0= if dup .id then @
1122 | repeat ( cr )
1123 | 1- repeat ;r
1124 | : definitions context @ set-current ; ( -- )
1125 | : word ( c -- b : parse a character delimited word )
1126 | #1 ?depth parse here aligned dup >r 2dup ! 1+ swap cmove r> ;
1127 | :s token bl word ;s ( -- b : get space delimited word )
1128 | :s ?unique ( a -- a : warn if word definition is not unique )
1129 | dup get-current (search) 0= ?exit space
1130 | 2drop [ {last} ] literal @ .id ." redefined" cr ;s ( b -- b )
1131 | :s ?nul ( b -- b : check not null )
1132 | c@+ ?exit [ -$10 ] literal throw ;s
1133 | :s ?len ( b -- b )
1134 | c@+ [ 1F ] literal > [ -$13 ] literal and throw ;s
1135 | :to char token ?nul count drop c@ ; ( "name", -- c )
1136 | :to [char] postpone char compile (push) , ; immediate
1137 | :to ; ( -- : end a word definition )
1138 | ( next line: check compiler safety )
1139 | [ $CAFE ] literal <> [ -$16 ] literal and throw
1140 | [ =unnest ] literal , ( compile exit )
1141 | postpone [ ( back to command mode )
1142 | ?dup if ( link word in if non 0 )
1143 | get-current ! ( this inks the word in )
1144 | then ; immediate compile-only
1145 | :to : ( "name", -- colon-sys )
1146 | align ( must be aligned before hand )
1147 | here dup ( push location for ";" )
1148 | [ {last} ] literal ! ( set last defined word )
1149 | last , ( point to previous word in header )
1150 | token ?nul ?len ?unique ( parse word and do basic checks )
1151 | count + h? ! align ( skip over packed word and align )
1152 | [ $CAFE ] literal ( push constant for compiler safety )
1153 | postpone ] ; ( turn compile mode on )
1154 | :to :noname ( "name", -- xt : make a definition with no name )
1155 | align here #0 [ $CAFE ] literal postpone ] ;
1156 | :to ' ( "name" -- xt : get xt of word [or throw] )
1157 | token find ?found cfa ;
1158 | :to recurse ( -- : recursive call to current definition )
1159 | [ {last} ] literal @ cfa compile, ; immediate compile-only
1160 | :s toggle tuck @ xor swap ! ;s ( u a -- : toggle bits at addr )
1161 | :s hide token find ?found nfa [ $80 ] literal swap toggle ;s
1162 | :s mark here #0 , ;s compile-only
1163 | :to begin here ; immediate compile-only
1164 | :to if [ =jumpz ] literal , mark ; immediate compile-only
1165 | :to until 2/ postpone if ! ; immediate compile-only
1166 | :to again [ =jump ] literal , compile, ; immediate compile-only
1167 | :to then here 2/ swap ! ; immediate compile-only
1168 | :to while postpone if ; immediate compile-only
1169 | :to repeat swap postpone again postpone then ;
1170 | immediate compile-only
1171 | :to else [ =jump ] literal , mark swap postpone then ;
1172 | immediate compile-only
1173 | :to for [ =>r ] literal , here ; immediate compile-only
1174 | :to aft drop [ =jump ] literal , mark here swap ;
1175 | immediate compile-only
1176 | :to next [ =next ] literal , compile, ; immediate compile-only
1177 | :s (marker) r> 2* @+ h? ! cell+ @ get-current ! ;s compile-only
1178 | : create state @ >r postpone : drop r> state ! compile (var)
1179 | get-current ! ;
1180 | :to variable create #0 , ;
1181 | :to constant create -cell allot compile (const) , ;
1182 | :to user create -cell allot compile (user)
1183 | cell user? +! user? @ , ;
1184 | : >body cell+ ; ( a -- a : move to a create words body )
1185 | :s (does) 2r> 2* swap >r ;s compile-only
1186 | :s (comp)
1187 | r> [ {last} ] literal @ cfa
1188 | ! ;s compile-only
1189 | : does> compile (comp) compile (does) ;
1190 | immediate compile-only
1191 | :to marker last align here create -cell allot compile
1192 | (marker) , , ; ( --, "name" )
1193 | :to >r compile opToR ; immediate compile-only
1194 | :to r> compile opFromR ; immediate compile-only
1195 | :to rdrop compile rdrop ; immediate compile-only
1196 | :to exit compile opExit ; immediate compile-only
1197 | :s (s) align [char] " word count nip 1+ allot align ;s
1198 | :to ." compile .$ (s) ; immediate compile-only
1199 | :to $" compile ($) (s) ; immediate compile-only
1200 | :to abort" compile (abort) (s) ; immediate compile-only
1201 | :to ( [char] ) parse 2drop ; immediate ( c"xxx" -- )
1202 | :to .( [char] ) parse type ; immediate ( c"xxx" -- )
1203 | :to \ tib @ >in ! ; immediate ( c"xxx" -- )
1204 | :to postpone token find ?found cfa compile, ; immediate
1205 | :s (nfa) last nfa toggle ;s ( u -- )
1206 | :to immediate ( -- : mark prev word as immediate )
1207 | [ $40 ] literal (nfa) ;
1208 | :to compile-only ( -- : mark prev word as compile-only )
1209 | [ $20 ] literal (nfa) ;
1210 | opt.better-see [unless]
1211 | :to see token find ?found cr ( --, "name" : decompile word )
1212 | begin @+ [ =unnest ] literal <>
1213 | while @+ . cell+ here over < if drop exit then
1214 | repeat @ u. ;
1215 | [then]
1216 | opt.better-see [if] ( Start conditional compilation )
1217 | :s ndrop for aft drop then next ;s ( x0...xn n -- )
1218 | :s validate ( pwd cfa -- nfa | 0 )
1219 | over cfa <> if drop #0 exit then nfa ;s
1220 | :s cfa? ( wid cfa -- nfa | 0 : search for CFA in a wordlist )
1221 | cells >r
1222 | begin
1223 | dup
1224 | while
1225 | dup @ over r@ -rot within
1226 | if dup @ r@ validate ?dup if rdrop nip exit then then
1227 | @
1228 | repeat rdrop ;s
1229 | :s name ( cwf -- a | 0 : search for CFA in the dictionary )
1230 | >r
1231 | get-order
1232 | begin
1233 | dup
1234 | while
1235 | swap r@ cfa? ?dup if
1236 | >r 1- ndrop r> rdrop exit then
1237 | 1- repeat rdrop ;s
1238 | :s instruction ( u -- )
1239 | [ primitive ] literal @ over u> if ." VM " 2* else
1240 | dup name ?dup if space count [ $1F ] literal
1241 | and type drop exit then
1242 | then
1243 | u. ;s
1244 | :s decompile ( a u -- a )
1245 | dup [ =jumpz ] literal = if
1246 | drop ." jumpz " cell+ dup @ 2* u. exit
1247 | then
1248 | dup [ =jump ] literal = if
1249 | drop ." jump " cell+ dup @ 2* u. exit
1250 | then
1251 | dup [ =next ] literal = if
1252 | drop ." next " cell+ dup @ 2* u. exit
1253 | then
1254 | dup [ to' compile half ] literal = if
1255 | drop ." compile" cell+ dup @ instruction exit
1256 | then
1257 | dup [ to' (up) half ] literal = if drop
1258 | ." (up) " cell+ dup @ u. exit
1259 | then
1260 | dup [ to' (push) half ] literal = if drop
1261 | ." (push) " cell+ dup @ u. exit
1262 | then
1263 | dup [ to' (user) half ] literal = if drop
1264 | ." (user) " cell+ @ u. [ $7FFF ] literal exit
1265 | then
1266 | dup [ to' (const) half ] literal = if drop
1267 | ." (const) " cell+ @ u. [ $7FFF ] literal exit
1268 | then
1269 | dup [ to' (var) half ] literal = if drop
1270 | ." (var) " cell+ dup u. ." -> " @ . [ $7FFF ] literal
1271 | exit
1272 | then
1273 | dup [ to' .$ half ] literal = if drop ." ." [char] "
1274 | emit space
1275 | cell+ count 2dup type [char] " emit + aligned cell -
1276 | exit then
1277 | dup [ to' ($) half ] literal = if drop ." $" [char] "
1278 | emit space
1279 | cell+ count 2dup type [char] " emit + aligned cell -
1280 | exit then
1281 | instruction ;s
1282 | :s compile-only? ( pwd -- f )
1283 | nfa [ $20 ] literal swap @ and 0<> ;s
1284 | :s immediate? ( pwd -- f )
1285 | nfa [ $40 ] literal swap @ and 0<> ;s
1286 | :to see token dup find ?found swap ." : " count type cr
1287 | dup >r cfa
1288 | begin dup @ [ =unnest ] literal <>
1289 | while
1290 | dup dup [ $5 ] literal u.r ." | "
1291 | @ decompile cr cell+ here over u< if drop rdrop exit then
1292 | repeat drop ." ;"
1293 | r> dup immediate? if ." immediate" then
1294 | compile-only? if ." compile-only" then cr ;
1295 | [then] ( End conditional compilation of entire section )
1296 | : dump aligned ( a u -- : display section of memory )
1297 | begin ?dup
1298 | while swap @+ . cell+ swap cell-
1299 | repeat drop ;
1300 | :s cksum aligned dup [ $C0DE ] literal - >r ( a u -- u )
1301 | begin ?dup
1302 | while swap @+ r> + >r cell+ swap cell-
1303 | repeat drop r> ;s
1304 | : defined token find nip 0<> ; ( -- f )
1305 | :to [then] ; immediate ( -- : end [if]...[else]...[then] )
1306 | :to [else] ( -- : skip until '[then]' )
1307 | begin
1308 | begin token c@+ while
1309 | find drop cfa dup
1310 | [ to' [else] ] literal = swap [ to' [then] ] literal = or
1311 | ?exit repeat query drop again ; immediate
1312 | :to [if] ?exit postpone [else] ; immediate
1313 | : ms for pause calibration @ for next next ; ( ms -- )
1314 | : bell [ $7 ] literal emit ; ( -- : emit ASCII BEL character )
1315 | :s csi ( -- : ANSI Term. Esc. Seq. )
1316 | [ $1B ] literal emit [ $5B ] literal emit ;s
1317 | : page csi ." 2J" csi ." 1;1H" ( csi ." 0m" ) ;
1318 | : at-xy radix decimal ( x y -- : set cursor position )
1319 | >r csi #0 u.r ." ;" #0 u.r ." H" r> base ! ;
1320 | $400 constant b/buf ( -- u : size of the block buffer )
1321 | system[
1322 | $200 constant c/buf ( -- cu : cells in the block buffer )
1323 | variable ( -- a : xt for "block" word )
1324 | $F400 constant buf0 ( -- ca : location of block buffer )
1325 | variable dirty0 ( -- a : is block buffer dirty? )
1326 | variable blk0 ( -- a : what block is stored in buffer? )
1327 | -1 t' blk0 >tbody t! ( set initial loaded block to be invalid )
1328 | ]system
1329 | :s (block) ( ca ca cu -- : transfer to/from "mass storage" )
1330 | pause ( pause for multitasking )
1331 | for
1332 | aft 2dup [@] swap [!] 1+ swap 1+ swap
1333 | then
1334 | next 2drop ;s
1335 | t' (block) t' >tbody t!
1336 | ( :s swap? 0= ?exit swap ;s ( x y sel -- x y | y x )
1337 | :s valid? dup #1 [ $80 ] literal within ;s ( k -- k f )
1338 | :s transfer @ execute ;s ( a a u -- )
1339 | :s >blk 1- c/buf * ;s ( k -- ca )
1340 | :s clean #0 dirty0 ! ;s ( -- : opposite of 'update' )
1341 | :s invalidate #-1 blk0 ! ;s ( -- : store invalid block # )
1342 | :s bput valid? if >blk buf0 2/ c/buf transfer exit then drop ;s
1343 | :s bget
1344 | valid? if >blk buf0 2/ swap c/buf transfer exit then drop ;s
1345 | :s loaded? dup blk0 @ = ;s ( k -- k f )
1346 | : update #-1 dirty0 ! ; ( -- )
1347 | : save-buffers dirty0 @ if blk0 @ bput clean then ; ( -- )
1348 | : flush save-buffers invalidate ; ( -- )
1349 | : empty-buffers clean invalidate ; ( -- )
1350 | : buffer ( k -- a )
1351 | #1 ?depth ( sanity check stack depth )
1352 | valid? ( validity check )
1353 | 0= [ -$23 ] literal and throw ( throw if invalid )
1354 | loaded? if drop buf0 exit then ( already loaded )
1355 | save-buffers ( save buffer if dirty )
1356 | blk0 ! ( set current loaded block )
1357 | buf0 ; ( return block buffer loc. )
1358 | : block
1359 | loaded? if drop buf0 exit then ( already loaded )
1360 | dup buffer swap bget ; ( k -- a )
1361 | : blank bl fill ; ( a u -- : blank an area of memory )
1362 | : list ( k -- : display a block )
1363 | page cr ( clean the screen )
1364 | dup >r block ( save block number and call "block" )
1365 | [ $F ] literal for ( for each line in the block )
1366 | [ $F ] literal r@ - [ $3 ] literal u.r space
1367 | [ $3F ] literal for count .emit next cr ( print line )
1368 | next drop r> scr ! ;
1369 | : get-input source >in @ source-id @ ; ( -- n1...n5 )
1370 | : set-input ! [ {id} ] up ! >in ! tup 2! ; ( n1...n5 -- )
1371 | :s ok state @ ?exit ." ok" cr ;s ( -- : okay prompt )
1372 | :s eval ( "word" -- )
1373 | begin token c@+ while
1374 | interpret #0 ?depth
1375 | repeat drop @execute ;s
1376 | : evaluate ( a u -- : evaluate a string )
1377 | get-input 2>r 2>r >r ( save the current input state )
1378 | #0 #-1 [ to' ) ] literal set-input ( set new input )
1379 | [ t' eval ] literal catch ( evaluate the string )
1380 | r> 2r> 2r> set-input ( restore input state )
1381 | throw ; ( throw on error )
1382 | :s line ( k l -- a u )
1383 | [ $6 ] literal lshift swap block + [ $40 ] literal ;s
1384 | :s loadline line evaluate ;s ( k l -- ??? : execute a line! )
1385 | : load ( k -- : execute a block )
1386 | blk @ >r dup blk ! #0 [ $F ] literal for
1387 | 2dup 2>r loadline 2r> 1+ next 2drop r> blk ! ;
1388 | root[
1389 | $FFFF constant eforth ( --, version )
1390 | ]root
1391 | opt.info [if]
1392 | :s info cr ( --, print system info )
1393 | ." eForth vX.X, Public Domain," here . cr
1394 | ." Richard James Howe, howe.r.j.89@gmail.com" cr
1395 | ." https://github.com/howerj/subleq" cr ;s
1396 | [else]
1397 | :s info ;s ( --, [disabled] print system info )
1398 | [then]
1399 | opt.self [if]
1400 | :s warnv [ {virtual} ] literal @ if
1401 | ." Warning: Virtual 16-bit SUBLEQ VM" cr
1402 | then ;s
1403 | [then]
1404 | :s xio ( xt xt xt -- : exchange I/O )
1405 | [ t' accept ] literal ! ! ! ! ;s
1406 | :s hand ( -- )
1407 | [ t' ok ] lit
1408 | [ t' (emit) ] literal ( Default: echo on )
1409 | [ {options} ] literal @ #1 and
1410 | if drop [ to' drop ] literal then
1411 | [ t' ktap ] literal postpone [ xio ;s
1412 | :s pace [ $B ] literal emit ;s ( -- : emit pacing character )
1413 | :s file ( -- )
1414 | [ t' pace ] literal
1415 | [ to' drop ] literal
1416 | [ t' ktap ] literal xio ;s
1417 | :s console
1418 | [ t' key? ] literal !
1419 | [ t' (emit) ] literal !
1420 | hand ;s
1421 | :s io! console ;s ( -- : setup system I/O )
1422 | :s task-init ( task-addr -- : initialize USER task )
1423 | [ {up} ] literal @ swap [ {up} ] literal !
1424 | this 2/ [ {next-task} ] up !
1425 | \ Default xt token )
1426 | [ to' bye ] literal 2/ [ {ip-save} ] up !
1427 | this [ =stksz ] literal + 2/ [ {rp-save} ] up !
1428 | this [ =stksz double ] literal + 2/ [ {sp-save} ] up !
1429 | #0 [ {tos-save} ] up !
1430 | decimal
1431 | io!
1432 | [ t' (literal) ] literal !
1433 | opt.float [if] [ $3 ] literal [ {precision} ] up ! [then]
1434 | [ to' bye ] literal !
1435 | #0 >in ! #-1 dpl !
1436 | \ Set terminal input buffer loc.
1437 | this [ =tib ] literal + #0 tup 2!
1438 | [ {up} ] literal ! ;s
1439 | :s ini ( -- : initialize current task )
1440 | [ {up} ] literal @ task-init ;s
1441 | :s (error) ( u -- : quit loop error handler )
1442 | dup space . [char] ? emit cr #-1 = if bye then
1443 | ini [ t' (error) ] literal ! ;s
1444 | : quit ( -- : interpreter loop )
1445 | [ t' (error) ] literal ! ( set error handler )
1446 | begin ( infinite loop start... )
1447 | query [ t' eval ] literal catch ( evaluate a line )
1448 | ?dup if @execute then ( error? )
1449 | again ; ( do it all again... )
1450 | :s (boot) ( -- : Forth boot sequence )
1451 | forth definitions ( un-mess-up dictionary / set it )
1452 | ini ( initialize the current thread correctly )
1453 | opt.self [if]
1454 | [ {options} ] literal @ [ $10 ] literal and if warnv then
1455 | [then]
1456 | [ {options} ] literal @ [ 4 ] literal and if info then
1457 | [ {options} ] literal @ #2 and if ( checksum on? )
1458 | [ primitive ] literal @ 2* dup here swap - cksum
1459 | [ check ] literal @ <> if ." bad cksum" bye then ( oops... )
1460 | [ {options} ] literal @ #2 xor [ {options} ] literal !
1461 | then
1462 | @ execute ;s ( call the interpreter loop AKA "quit" )
1463 | opt.multi [if]
1464 | :s task: ( "name" -- : create a named task )
1465 | create here b/buf allot 2/ task-init ;s
1466 | :s activate ( xt task-address -- : start task executing xt )
1467 | dup task-init
1468 | ( set execution word )
1469 | dup >r swap 2/ swap [ {ip-save} ] literal + !
1470 | r> this @ >r dup 2/ this ! r> swap ! ;s ( link in task )
1471 | [then]
1472 | opt.multi [if]
1473 | :s wait ( addr -- : wait for signal )
1474 | begin pause @+ until #0 swap ! ;s
1475 | :s signal this swap ! ;s ( addr -- : signal to wait )
1476 | [then]
1477 | opt.multi [if]
1478 | :s single ( -- : disable other tasks )
1479 | #1 [ {single} ] literal ! ;s
1480 | :s multi ( -- : enable multitasking )
1481 | #0 [ {single} ] literal ! ;s
1482 | [then]
1483 | opt.multi [if]
1484 | :s send ( msg task-addr -- : send message to task )
1485 | this over [ {sender} ] literal + ( msg this msg-addr )
1486 | begin pause @+ 0= until ( pause until zero )
1487 | ! [ {message} literal + ! ;s ( send message )
1488 | :s receive ( -- msg task-addr : block until message )
1489 | begin pause [ {sender} ] up @ until ( wait until non-zero )
1490 | [ {message} ] up @ [ {sender} ] up @
1491 | #0 [ {sender} ] up ! ;s
1492 | [then]
1493 | opt.editor [if]
1494 | : editor [ {editor} ] literal +order ; ( BLOCK editor )
1495 | :e q [ {editor} ] literal -order ;e ( -- : quit editor )
1496 | :e ? scr @ . ;e ( -- : print block number of current block )
1497 | :e l scr @ list ;e ( -- : list current block )
1498 | :e x q scr @ load editor ;e ( -- : evaluate current block )
1499 | :e ia #2 ?depth [ $6 ] literal lshift + scr @ block + tib
1500 | >in @ + swap source nip >in @ - cmove tib @ >in ! l ;e
1501 | :e a #0 swap ia ;e ( line --, "line" : insert line at )
1502 | :e w get-order [ {editor} ] literal #1 ( -- : list cmds )
1503 | set-order words set-order ;e
1504 | :e s update flush ;e ( -- : save edited block )
1505 | :e n #1 scr +! l ;e ( -- : display next block )
1506 | :e p #-1 scr +! l ;e ( -- : display previous block )
1507 | :e r scr ! l ;e ( k -- : retrieve given block )
1508 | :e z scr @ block b/buf blank l ;e ( -- : erase current block )
1509 | :e d #1 ?depth >r scr @ block r> [ $6 ] literal lshift +
1510 | [ $40 ] literal blank l ;e ( line -- : delete line )
1511 | [then]
1512 | opt.control [if]
1513 | : rpick ( n -- u, R: ??? -- ??? : pick a value off ret. stk. )
1514 | rp@ swap - 1- 2* @ ;
1515 | : many #0 >in ! ; ( -- : repeat current line )
1516 | :s (case) r> swap >r >r ;s compile-only
1517 | :s (of) r> r@ swap >r = ;s compile-only
1518 | :s (endcase) r> r> drop >r ;s
1519 | : case compile (case) [ $1E ] literal ; compile-only immediate
1520 | : of compile (of) postpone if ; compile-only immediate
1521 | : endof postpone else [ $1F ] literal ; compile-only immediate
1522 | : endcase
1523 | begin
1524 | dup [ $1F ] literal =
1525 | while
1526 | drop
1527 | postpone then
1528 | repeat
1529 | [ $1E ] literal <> [ -$16 ] literal and throw
1530 | compile (endcase) ; compile-only immediate
1531 | :s r+ 1+ ;s ( NB. Should be cell+ on most platforms )
1532 | :s (unloop) r> rdrop rdrop rdrop >r ;s compile-only
1533 | :s (leave) rdrop rdrop rdrop ;s compile-only
1534 | :s (j) [ $4 ] literal rpick ;s compile-only
1535 | :s (k) [ $7 ] literal rpick ;s compile-only
1536 | :s (do) r> dup >r swap rot >r >r r+ >r ;s compile-only
1537 | :s (?do)
1538 | 2dup <> if
1539 | r> dup >r swap rot >r >r r+ >r exit
1540 | then 2drop ;s compile-only
1541 | :s (loop)
1542 | r> r> 1+ r> 2dup <> if
1543 | >r >r 2* @ >r exit \ NB. 2* and 2/ cause porting problems
1544 | then >r 1- >r r+ >r ;s compile-only
1545 | :s (+loop)
1546 | r> swap r> r> 2dup - >r
1547 | #2 pick r@ + r@ xor 0>=
1548 | [ $3 ] literal pick r> xor 0>= or if
1549 | >r + >r 2* @ >r exit
1550 | then >r >r drop r+ >r ;s compile-only
1551 | : unloop compile (unloop) ; immediate compile-only
1552 | : i compile r@ ; immediate compile-only ( current loop count )
1553 | : j compile (j) ; immediate compile-only ( nested loop count )
1554 | : k compile (k) ; immediate compile-only ( nested+1 loop cnt )
1555 | : leave compile (leave) ; immediate compile-only
1556 | : do compile (do) #0 , here ; immediate compile-only
1557 | : ?do compile (?do) #0 , here ; immediate compile-only
1558 | : loop ( increment loop count )
1559 | compile (loop) dup 2/ ,
1560 | compile (unloop)
1561 | cell- here cell- 2/ swap ! ; immediate compile-only
1562 | : +loop ( increment loop by amount )
1563 | compile (+loop) dup 2/ ,
1564 | compile (unloop)
1565 | cell- here cell- 2/ swap ! ; immediate compile-only
1566 | :s scopy ( b u -- b u : copy a string into the dictionary )
1567 | align here >r aligned dup allot
1568 | r@ swap dup >r cmove r> r> swap ;s
1569 | :s (macro) r> 2* 2@ swap evaluate ;s
1570 | : macro ( c" xxx" --, : create a late-binding macro )
1571 | create postpone immediate
1572 | -cell allot compile (macro)
1573 | align here #2 cells + ,
1574 | #0 parse dup , scopy 2drop ;
1575 | [then] ( opt.control )
1576 | opt.allocate [if]
1577 | system[
1578 | ( pointer to beginning of free space )
1579 | variable freelist 0 t, 0 t, ( 0 t' freelist t! )
1580 | : >length #2 cells + ; ( freelist -- length-field )
1581 | : pool ( default memory pool )
1582 | [ $F800 ] literal [ $400 ] literal ;
1583 | : arena! ( start-addr len -- : initialize memory pool )
1584 | >r dup [ $80 ] literal u< if
1585 | [ -$B ] literal throw ( arena too small )
1586 | then
1587 | dup r@ >length !
1588 | 2dup erase
1589 | over dup r> ! #0 swap ! swap cell+ ! ;
1590 | : arena? ( ptr freelist -- f : is "ptr" within arena? )
1591 | dup >r @ 0= if rdrop drop #0 exit then
1592 | r> swap >r dup >r @ dup r> >length @ + r> within ;
1593 | : >size ( ptr freelist -- size : get size of allocated ptr )
1594 | over swap arena? 0= if [ -$3B ] literal throw then
1595 | cell- @ cell- ;
1596 | : (allocate) ( u -- addr ior : dynamic allocate of 'u' bytes )
1597 | >r
1598 | aligned
1599 | r@ @ 0= if pool r@ arena! then ( init to default pool )
1600 | dup 0= if rdrop drop #0 [ -$3B ] literal exit then
1601 | cell+ r@ dup
1602 | begin
1603 | while dup @ cell+ @ #2 pick u<
1604 | if
1605 | @ @ dup ( get new link )
1606 | else
1607 | dup @ cell+ @ #2 pick - #2 cells max dup #2 cells =
1608 | if
1609 | drop dup @ dup @ rot
1610 | ( prevent freelist address from being overwritten )
1611 | dup r@ = if
1612 | rdrop 2drop 2drop #0 [ -$3B ] literal exit
1613 | then
1614 | !
1615 | else
1616 | 2dup swap @ cell+ ! swap @ +
1617 | then
1618 | 2dup ! cell+ #0 ( store size, bump pointer )
1619 | then ( and set exit flag )
1620 | repeat
1621 | rdrop nip dup 0= [ -$3B ] literal and ;
1622 | : (free) ( ptr freelist -- ior : free pointer from "allocate" )
1623 | >r
1624 | dup 0= if rdrop #0 exit then
1625 | dup r@ arena? 0= if rdrop drop [ -$3C ] literal exit then
1626 | cell- dup @ swap 2dup cell+ ! r> dup
1627 | begin
1628 | dup [ $3 ] literal pick u< and
1629 | while
1630 | @ dup @
1631 | repeat
1632 | dup @ dup [ $3 ] literal pick ! ?dup
1633 | if
1634 | dup [ $3 ] literal pick [ $5 ] literal pick + =
1635 | if
1636 | dup cell+ @ [ $4 ] literal pick +
1637 | [ $3 ] literal pick cell+ ! @ #2 pick !
1638 | else
1639 | drop
1640 | then
1641 | then
1642 | dup cell+ @ over + #2 pick =
1643 | if
1644 | over cell+ @ over cell+ dup @ rot + swap ! swap @ swap !
1645 | else
1646 | !
1647 | then
1648 | drop #0 ;
1649 | : (resize) ( a-addr1 u freelist -- a-addr2 ior )
1650 | >r
1651 | dup 0= if drop r> (free) exit then
1652 | over 0= if nip r> (allocate) exit then
1653 | 2dup swap r@ >size u<= if drop #0 exit then
1654 | r@ (allocate) if drop [ -$3D ] literal exit then
1655 | over r@ >size
1656 | #1 pick [ $3 ] literal pick >r >r cmove r> r> r>
1657 | (free) if drop [ -$3D ] literal exit then #0 ;
1658 | ]system
1659 | : allocate freelist (allocate) ; ( u -- ptr ior )
1660 | : free freelist (free) ; ( ptr -- ior )
1661 | : resize freelist (resize) ; ( ptr u -- ptr ior )
1662 | [then]
1663 | opt.float [if] ( Large section of optional code! )
1664 | system[
1665 | $10 constant #bits ( = 1 cells 8 * )
1666 | $8000 constant #msb ( = 1 #bits 1- lshift )
1667 | ]system
1668 | :s (2const) r> 2* 2@ ;s compile-only ( R: a --, -- u )
1669 | :m 2constant :t mdrop (2const) t, t, ;m
1670 | :m 2variable :t mdrop mswap (var) t, t, munorder ;m
1671 | :m 2literal mswap lit lit ;m
1672 | :m mcreate :t mdrop (var) munorder ;m ( --, "name": var )
1673 | : 2+ #2 + ; ( n -- n )
1674 | : 2- #2 - ; ( n -- n )
1675 | : 1+! #1 swap +! ; ( a -- )
1676 | : /string ( b u1 u2 -- b u : advance string u2 )
1677 | over min rot over + -rot - ;
1678 | : spaces bl banner ; ( +n -- : print space 'n' times )
1679 | : convert count >number drop ; ( +d1 addr1 -- +d2 addr2 )
1680 | : arshift ( n u -- n : arithmetic right shift )
1681 | 2dup rshift >r swap #msb and if
1682 | [ $10 ] literal swap - #-1 swap lshift
1683 | else drop #0 then r> or ;
1684 | : d2* over #msb and >r 2* swap 2* swap r> if #1 or then ;
1685 | : d2/ dup #1 and >r 2/ swap 2/ r> if #msb or then swap ;
1686 | : d- dnegate d+ ; ( d d -- d : double cell subtraction )
1687 | : d= rot = -rot = and ; ( d d -- f : double cell equal )
1688 | : d0= or 0= ; ( d -- f : double cell number equal to zero )
1689 | : d0<> d0= 0= ; ( d -- f : double not equal to zero )
1690 | : 2swap >r -rot r> -rot ; ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
1691 | : dabs s>d if dnegate then ; ( d -- ud )
1692 | : 2over ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 )
1693 | >r >r 2dup r> swap >r swap r> r> -rot ;
1694 | : 2, , , ; ( n n -- : write to values into dictionary )
1695 | :to 2constant create -cell allot compile (2const) 2, ;
1696 | :to 2variable create #0 , #0 , ; \ does> ; ( d --, Run: -- a )
1697 | :to 2literal swap postpone literal postpone literal ; immediate
1698 | :s +- 0< if negate then ;s ( n n -- n : copy sign )
1699 | : m* ( n n -- d : single to double cell multiply [16x16->32] )
1700 | 2dup xor 0< >r abs swap abs um* r> if dnegate then ;
1701 | : sm/rem ( dl dh nn -- rem quo: symmetric division )
1702 | over >r >r ( dl dh nn -- dl dh, R: -- dh nn )
1703 | dabs r@ abs um/mod ( dl dh -- rem quo, R: dh nn -- dh nn )
1704 | r> r@ xor +- swap r> +- swap ;
1705 | : */mod ( a b c -- rem a*b/c : double prec. intermediate val )
1706 | >r m* r> sm/rem ;
1707 | system[
1708 | mcreate lookup ( 16 values, CORDIC atan table )
1709 | $3243 t, $1DAC t, $0FAD t, $07F5 t,
1710 | $03FE t, $01FF t, $00FF t, $007F t,
1711 | $003F t, $001F t, $000F t, $0007 t,
1712 | $0003 t, $0001 t, $0000 t, $0000 t,
1713 | $26DD constant cordic_1K ( CORDIC scaling factor )
1714 | $6487 constant hpi
1715 | variable tx variable ty variable tz
1716 | variable cx variable cy variable cz
1717 | variable cd variable ck
1718 | ]system
1719 | ( CORDIC: valid in range -pi/2 to pi/2, arguments in fixed )
1720 | ( point format with 1 = 16384, angle is given in radians. )
1721 | : cordic ( angle -- sine cosine | x y -- atan sqrt )
1722 | cz ! cordic_1K cx ! #0 cy ! #0 ck !
1723 | [ $10 ] literal begin ?dup while
1724 | cz @ 0< cd !
1725 | cx @ cy @ ck @ arshift cd @ xor cd @ - - tx !
1726 | cy @ cx @ ck @ arshift cd @ xor cd @ - + ty !
1727 | cz @ ck @ cells lookup + @ cd @ xor cd @ - - tz !
1728 | tx @ cx ! ty @ cy ! tz @ cz !
1729 | ck 1+!
1730 | 1-
1731 | repeat
1732 | cy @ cx @ ;
1733 | : sin cordic drop ; ( rad/16384 -- sin : fixed-point sine )
1734 | : cos cordic nip ; ( rad/16384 -- cos : fixed-point cosine )
1735 | : fabs [ $7FFF ] literal and ; ( r -- r : FP absolute value )
1736 | system[
1737 | mdecimal
1738 | mcreate ftable
1739 | 0.001 t, t, 0.010 t, t,
1740 | 0.100 t, t, 1.000 t, t,
1741 | 10.000 t, t, 100.000 t, t,
1742 | 1000.000 t, t, 10000.000 t, t,
1743 | 100000.000 t, t, 1000000.000 t, t,
1744 | mhex
1745 | ]system
1746 | :s null ( f -- f : zero exponent if mantissa is )
1747 | over 0= if drop #0 then ;s
1748 | :s norm >r 2dup or ( normalize input float )
1749 | if begin s>d invert
1750 | while d2* r> 1- >r
1751 | repeat swap 0< - ?dup
1752 | if r> else #msb r> 1+ then
1753 | else r> drop then ;s
1754 | :s lalign [ $20 ] literal min for aft d2/ then next ;s
1755 | :s ralign 1- ?dup if lalign then #1 #0 d+ d2/ ;s
1756 | :s tens 2* cells ftable + 2@ ;s ( a -- d )
1757 | :s shifts fabs [ $4010 ] literal - s>d invert if
1758 | [ -$2B ] literal throw then negate ;s
1759 | :s base? ( -- : check base )
1760 | base @ [ $A ] literal <> [ -$40 ] literal and throw ;s
1761 | :s unaligned? ( -- : chk ptr )
1762 | dup #1 and = [ -$9 ] literal and throw ;s
1763 | :s -+ drop swap 0< if negate then ;s
1764 | : fdepth depth 2/ ; ( -- n : number of floats, approximate )
1765 | : fcopysign #msb and nip >r fabs r> or ; ( r1 r2 -- r1 )
1766 | : floats 2* cells ; ( u -- u )
1767 | : float+ [ 4 ] literal ( [ 1 floats ] literal ) + ; ( a -- a )
1768 | : set-precision ( +n -- : set FP decimals printed out )
1769 | dup #0 [ 5 ] literal within if ( check within range )
1770 | [ {precision} ] up ! exit ( precision ok )
1771 | then [ -$2B ] literal throw ; ( precision un-ok )
1772 | : precision ( -- u : precision of FP values )
1773 | [ {precision} ] up @ ;
1774 | : f@ unaligned? 2@ ; ( a -- r : fetch FP value )
1775 | : f! unaligned? 2! ; ( r a -- : store FP value )
1776 | : f, 2, ; ( r -- : write float into dictionary )
1777 | : falign align ; ( -- : align the dict. to store a FP )
1778 | : faligned aligned ; ( a -- a : align point for FP )
1779 | : fdup #2 ?depth 2dup ; ( r -- r r : FP duplicate )
1780 | : fswap [ 4 ] literal ?depth 2swap ; ( r1 r2 -- r2 r1 )
1781 | : fover [ 4 ] literal ?depth 2over ; ( r1 r2 -- r1 r2 r1 )
1782 | : f2dup fover fover ; ( r1 r2 -- r1 r2 r1 r2 )
1783 | : ftuck fdup 2>r fswap 2r> ; ( r1 r2 -- r2 r1 r2 )
1784 | : frot 2>r fswap 2r> fswap ; ( r1 r2 r3 -- r2 r3 r1 )
1785 | : -frot frot frot ; ( r1 r2 r3 -- r3 r1 r2 )
1786 | : fdrop #2 ?depth 2drop ; ( r -- : floating point drop )
1787 | : f2drop fdrop fdrop ; ( r1 r2 -- : FP 2drop )
1788 | : fnip fswap fdrop ; ( r1 r2 -- r2 : FP nip )
1789 | : fnegate #msb xor null ; ( r -- r : FP negate )
1790 | : fsign fabs over 0< if >r dnegate r> #msb or then ;
1791 | : f2* #2 ?depth 1+ null ; ( r -- r : FP times by two )
1792 | : f2/ #2 ?depth 1- null ; ( r -- r : FP divide by two )
1793 | : f* ( r r -- r : FP multiply )
1794 | [ $4 ] literal ?depth rot + [ $4000 ] literal
1795 | - >r um* r> norm ;
1796 | : fsq fdup f* ; ( r -- r : FP square )
1797 | : f0= fabs null d0= ; ( r -- r : FP equal to zero [incl -0.0] )
1798 | : um/ ( ud u -- u : ud/u and round )
1799 | dup >r um/mod swap r> over 2* 1+ u< swap 0< or - ;
1800 | : f/ ( r1 r2 -- r1/r2 : floating point division )
1801 | [ $4 ] literal ?depth
1802 | fdup f0= [ -$2A ] literal and throw
1803 | rot swap - [ $4000 ] literal + >r
1804 | #0 -rot 2dup u<
1805 | if um/ r> null
1806 | else >r d2/ fabs r> um/ r> 1+
1807 | then ;
1808 | : f+ ( r r -- r : floating point addition )
1809 | [ $4 ] literal ?depth
1810 | rot 2dup >r >r fabs swap fabs -
1811 | dup if s>d
1812 | if rot swap negate
1813 | r> r> swap >r >r
1814 | then #0 swap ralign
1815 | then swap #0 r> r@ xor 0<
1816 | if r@ 0< if 2swap then d-
1817 | r> fsign rot swap norm
1818 | else d+ if 1+ 2/ #msb or r> 1+
1819 | else r> then then ;
1820 | 0 0 2constant fzero
1821 | : f- fnegate f+ ; ( r1 r2 -- t : floating point subtract )
1822 | : f< f- 0< nip ; ( r1 r2 -- t : floating point less than )
1823 | : f> fswap f< ; ( r1 r2 -- t : floating point greater than )
1824 | : f>= f< 0= ; ( r1 r2 -- t : FP greater or equal )
1825 | : f<= f> 0= ; ( r1 r2 -- t : FP less than or equal )
1826 | : f= d= ; ( r1 r2 -- t : FP exact equality )
1827 | : f0> fzero f> ; ( r1 r2 -- t : FP greater than zero )
1828 | : f0< fzero f< ; ( r1 r2 -- t : FP less than zero )
1829 | : f0<= f0> 0= ; ( r1 r2 -- t : FP less than or equal to zero )
1830 | : f0>= f0< 0= ; ( r1 r2 -- t : FP more than or equal to zero )
1831 | : fmin f2dup f< if fdrop exit then fnip ; ( r1 r2 -- f : min )
1832 | : fmax f2dup f> if fdrop exit then fnip ; ( r1 r2 -- f : max )
1833 | : fwithin ( r1 r2 r3 -- f : r2 <= r1 < r3 )
1834 | frot ftuck f>= >r f<= r> and ;
1835 | : d>f ( d -- r : double to float, dOwN 2 fLoAt lul )
1836 | [ $4020 ] literal fsign norm ;
1837 | : s>f s>d d>f ; ( n -- r : single to float )
1838 | : f#
1839 | base?
1840 | >r precision tens drop um* r> shifts
1841 | ralign precision ?dup if for aft # then next
1842 | [char] . hold then #s rot sign ;
1843 | : f.r >r tuck <# f# #> r> over - spaces type ; ( f +n -- )
1844 | : f. space #0 f.r ; ( f -- : output floating point )
1845 | ( N.B. 'f' and 'e' require "dpl" to be set correctly! )
1846 | : f ( n|d -- f : formatted double to float )
1847 | base?
1848 | dpl @ 0< if ( input was single number )
1849 | #1 ?depth s>d #0 dpl !
1850 | else ( else a double )
1851 | #2 ?depth
1852 | then
1853 | d>f dpl @ tens d>f f/ ;
1854 | :to fconstant ( "name", r --, Run Time: -- r )
1855 | f postpone 2constant ;
1856 | :to fliteral ( r --, Run: -- r : compile a literal in a word )
1857 | f postpone 2literal ; immediate
1858 | : fix tuck #0 swap shifts ralign -+ ; ( r -- n : f>s rounding )
1859 | : f>s tuck #0 swap shifts lalign -+ ; ( r -- n : f>s truncate )
1860 | : floor f>s s>f ; ( r -- r )
1861 | : fround fix s>f ; ( r -- r )
1862 | : fmod f2dup f/ floor f* f- ; ( r1 r2 -- r )
1863 | $8000 $4001 2constant fone ( 1.0 fconstant fone )
1864 | : f1+ fone f+ ; ( r -- r : increment FP number )
1865 | : f1- fone f- ; ( r -- r : decrement FP number )
1866 | : finv fone fswap f/ ; ( r -- r : FP 1/x )
1867 | : exp ( r -- r : raise 2.0 to the power of 'r' )
1868 | 2dup f>s dup >r s>f f-
1869 | f2* [ $E1E5 $C010 ] 2literal ( [ -57828.0 ] fliteral )
1870 | 2over fsq [ $FA26 $400B ] 2literal ( [ 2001.18 ] fliteral )
1871 | f+ f/
1872 | 2over f2/ f-
1873 | [ $8AAC $4006 ] 2literal ( [ 34.6680 ] fliteral )
1874 | f+ f/ f1+ fsq r> + ;
1875 | : fexp ( r -- r : raise e to the power of 'r' )
1876 | \ 1.4427 = log2(e)
1877 | [ $B8AA $4001 ] 2literal ( [ 1.4427 ] fliteral ) f* exp ;
1878 | : falog ( r -- r )
1879 | [ $D49A $4002 ] 2literal ( [ 3.3219 ] fliteral ) f* exp ;
1880 | :s nget ( "123" -- : get a single signed number )
1881 | bl word dup 1+ c@ [char] - = tuck -
1882 | #0 #0 rot convert drop ( should throw if not number... )
1883 | -+ ;s
1884 | : fexpm1 fexp fone f- ; ( r1 -- r2 : e raised to 'r1' less 1 )
1885 | : fsinh fexpm1 fdup fdup f1+ f/ f+ f2/ ; ( r -- fsinh : h-sin )
1886 | : fcosh fexp fdup fone fswap f/ f+ f2/ ; ( r -- fcosh : h-cos )
1887 | : fsincosh fdup fsinh fswap fcosh ; ( f -- sinh cosh )
1888 | : ftanh fsincosh f/ ; ( f -- ftanh : hyperbolic tangent )
1889 | mdecimal
1890 | : e.r ( r +n -- : output scientific notation )
1891 | >r
1892 | tuck fabs [ 16384 ] literal tuck -
1893 | [ 4004 ] literal [ 13301 ] literal */mod >r
1894 | s>f [ 4004 ] literal s>f f/ exp f*
1895 | 2dup fone f<
1896 | if [ 10 ] literal s>f f* r> 1- >r then
1897 | <# r@ abs #0 #s r> sign 2drop
1898 | [char] e hold f# #> r> over - spaces type ;
1899 | : e ( f "123" -- usage "1.23 e 10", input scientific notation )
1900 | f nget >r r@ abs [ 13301 ] literal [ 4004 ] literal */mod
1901 | >r s>f [ 4004 ] literal s>f f/ exp r> +
1902 | r> 0< if f/ else f* then ;
1903 | mhex
1904 | : e. space #0 e.r ;
1905 | ( : fe. e. ; ( r -- : display in engineering notation )
1906 | : fs. e. ; ( r -- : display in scientific notation )
1907 | ( Define some useful constants )
1908 | $C911 $4002 2constant fpi \ Pi = 3.14159265 fconstant fpi )
1909 | $C911 $4001 2constant fhpi \ 1/2pi = 1.57079632 fconstant fhpi
1910 | $C911 $4003 2constant f2pi \ 2pi = 6.28318530 fconstant f2pi
1911 | $ADF8 $4002 2constant fe \ e = 2.71828182 fconstant fe
1912 | $B172 $4000 2constant fln2 \ ln[2] = 0.69314718 fconstant fln2
1913 | $935D $4002 2constant fln10 \ ln[10] 2.30258509 fconstant fln10
1914 | : fdeg ( rad -- deg : FP radians to degrees )
1915 | f2pi f/ [ $B400 $4009 ] 2literal ( [ 360.0 ] fliteral ) f* ;
1916 | : frad ( deg -- rad : FP degrees to radians )
1917 | [ $B400 $4009 ] 2literal ( [ 360.0 ] fliteral ) f/ f2pi f* ;
1918 | :s >cordic ( f -- n )
1919 | [ $8000 $400F ] 2literal ( [ 16384.0 ] fliteral ) f* f>s ;s
1920 | :s cordic> ( n -- f )
1921 | s>f [ $8000 $400F ] 2literal ( [ 16384.0 ] fliteral ) f/ ;s
1922 | :s quadrant
1923 | fdup fhpi f< if fdrop #0 exit then
1924 | fdup fpi f< if fdrop #1 exit then
1925 | [ $96CD $4003 ] 2literal ( [ fpi fhpi f+ ] 2 literal ) f<
1926 | if #2 exit then
1927 | [ $3 ] literal ;s
1928 | :s >sin #2 [ $4 ] literal within if fnegate then ;s
1929 | :s >cos #1 [ $3 ] literal within if fnegate then ;s
1930 | :s scfix >r
1931 | r@ #1 = if fnegate fpi f+ rdrop exit then
1932 | r> [ $3 ] literal = if fnegate f2pi f+ then ;s
1933 | :s (fsincos) fhpi fmod >cordic cordic >r cordic> r> cordic> ;s
1934 | : fsincos ( rads -- sin cos )
1935 | fdup f0< >r
1936 | fabs
1937 | f2pi fmod fdup quadrant dup >r scfix (fsincos)
1938 | r@ >cos fswap r> >sin fswap
1939 | r> if fswap fnegate fswap then ;
1940 | : fsin fsincos fdrop ; ( rads -- sin )
1941 | : fcos fsincos fnip ; ( rads -- cos )
1942 | : ftan fsincos f/ ; ( rads -- tan )
1943 | : f~ ( r1 r2 r3 -- flag )
1944 | fdup f0> if 2>r f- fabs 2r> f< exit then
1945 | fdup f0= if fdrop f= exit then
1946 | fabs 2>r f2dup fabs fswap fabs f+ 2r> f* 2>r f- fabs 2r> f< ;
1947 | : fsqrt ( r -- r : square root of 'r' )
1948 | fdup f0< if fdrop [ -$2E ] literal throw then
1949 | fdup f0= if fdrop fzero exit then
1950 | fone
1951 | [ $10 ] literal for aft
1952 | f2dup fsq fswap f- fover f2* f/ f-
1953 | then next
1954 | fnip ;
1955 | : filog2 ( r -- u : Floating point integer logarithm )
1956 | null
1957 | fdup fzero f<= [ -$2E ] literal and throw
1958 | ( norm ) nip [ $4001 ] literal - ;
1959 | : fhypot f2dup f> if fswap then ( a b -- c : hypotenuse )
1960 | fabs 2>r fdup 2r> fswap f/ fsq f1+ fsqrt f* ;
1961 | : sins
1962 | f2pi fnegate
1963 | begin
1964 | fdup f2pi f<
1965 | while
1966 | fdup fdup f. [char] , emit space fsincos
1967 | fswap f. [char] , emit space f. cr
1968 | [ $80AF $3FFE ] 2literal ( [ f2pi 50.0 f f/ ] 2literal )
1969 | f+
1970 | repeat fdrop ;
1971 | : agm f2dup f* fsqrt 2>r f+ f2/ 2r> fswap ; ( r1 r2 -- r1 r2 )
1972 | : fln ( r -- r : natural logarithm )
1973 | [ $8000 $3FF7 ] 2literal ( [ 2 12 - s>f exp ] 2literal )
1974 | fswap f/
1975 | fone fswap
1976 | [ $C ] literal for aft agm then next f+ fpi
1977 | fswap f/
1978 | [ $8516 $4004 ] 2literal ( [ 12 s>f fln2 f* ] 2literal )
1979 | f- ;
1980 | : flnp1 fone f+ fln ; ( r -- r )
1981 | : flog2 fln fln2 f/ ; ( r -- r : base 2 logarithm )
1982 | : flog fln fln10 f/ ; ( r -- r : base 10 logarithm )
1983 | : f** fswap flog2 f* exp ; ( r1 r2 -- r : pow[r1, r2] )
1984 | : fatanh ( r1 -- r2 : atanh, -1 < r1 < 1 )
1985 | fdup f1+ fswap fone fswap f- f/ fln f2/ ;
1986 | : facosh ( r1 -- r2 : acosh, 1 <= r1 < INF )
1987 | fdup fsq f1- fsqrt f+ fln ;
1988 | : fasinh fdup fsq f1+ fsqrt f+ fln ; ( r -- r )
1989 | :s fatan-lo ( r -- r : fatan for r <= 1.0 only )
1990 | fdup fsq fdup
1991 | [ $9F08 $3FFD ] 2literal f* ( Consider A = 0.07765095 )
1992 | [ $932B $BFFF ] 2literal f+ f* ( Constant B = -0.28743447 )
1993 | [ $FEC5 $4000 ] 2literal f+ f* ;s ( Constant C = Pi/4 - A - B )
1994 | :s fatan-hi finv fatan-lo fhpi fswap f- ;s ( r -- r )
1995 | : fatan ( r -- r : compute atan )
1996 | fdup fabs fone f> if fatan-hi exit then fatan-lo ;
1997 | : fatan2 ( r1=y r2=x -- r3 )
1998 | fdup f0> if f/ fatan exit then
1999 | fdup f0< if
2000 | fover f0<
2001 | if f/ fatan fpi f+
2002 | else f/ fatan fpi f- then
2003 | exit
2004 | then
2005 | fdrop
2006 | fdup f0> if fdrop fhpi exit then
2007 | fdup f0< if
2008 | fdrop [ $C911 $C001 ] 2literal ( [ fhpi fnegate ] 2literal )
2009 | exit then
2010 | [ -$2E ] literal throw ;
2011 | : fasin fdup fsq fone fswap f- fsqrt f/ fatan ; ( r -- r )
2012 | : facos fasin fhpi fswap f- ; ( r -- r )
2013 | [then] ( opt.float )
2014 | opt.glossary [if]
2015 | :s .n . ;s ( n -- : display an address )
2016 | :s .pwd dup ." PWD:" .n ;s ( pwd -- pwd )
2017 | :s .nfa dup ." NFA:" nfa .n ;s ( pwd -- pwd : print NFA addr )
2018 | :s .cfa dup ." CFA:" cfa .n ;s ( pwd -- pwd : print CFA addr )
2019 | :s .blank ." --- " ;s ( -- : print attribute not set )
2020 | :s .immediate ( nfa -- nfa : is word an "immediate" word? )
2021 | dup [ $40 ] literal and if ." IMM " exit then .blank ;s
2022 | :s .compile-only ( nfa -- nfa : is word "compile-only"? )
2023 | dup [ $20 ] literal and if ." CMP " exit then .blank ;s
2024 | :s .hidden ( nfa -- nfa : is word hidden? )
2025 | dup [ $80 ] literal and if ." HID " exit then .blank ;s
2026 | :s =vm [ to' pause ] literal @ ;s ( pause = last defined BLT )
2027 | :s =exit [ to' pause ] literal cell+ @ ;s ( exit follows BLT )
2028 | :s rvm? dup @ =vm u<= swap cell+ @ =exit = and ;s ( cfa -- f )
2029 | :s cvm? ( cfa -- f )
2030 | dup @ [ t' compile ] literal 2/ = swap cell+ rvm? and ;s
2031 | :s vm? dup rvm? swap cvm? or ;s ( cfa -- f )
2032 | :s .built-in dup cfa vm? if ." BLT " exit then .blank ;s
2033 | :s display ( pwd -- pwd : display info about single word )
2034 | dup .pwd .nfa .cfa space .built-in nfa count
2035 | .immediate .compile-only .hidden
2036 | [ $1F ] literal and type cr ;s
2037 | :s (w) begin ?dup while display @ repeat ;s ( voc -- )
2038 | :s .voc dup ." voc: " . cr ;s ( voc -- voc )
2039 | : glossary get-order for aft .voc @ (w) then next ; ( -- )
2040 | [then]
2041 | : cold [ {boot} ] literal 2* @execute ; ( -- )
2042 | t' (boot) half {boot} t! \ Set starting Forth word
2043 | t' quit {quit} t! \ Set initial Forth word
2044 | atlast {forth-wordlist} t! \ Make wordlist work
2045 | {forth-wordlist} {current} t! \ Set "current" dictionary
2046 | there h t! \ Assign dictionary pointer
2047 | local? {user} t! \ Assign number of locals
2048 | primitive t@ double mkck check t! \ Set checksum over Forth
2049 | atlast {last} t! \ Set last defined word
2050 | save-target \ Output target
2051 | .end \ Get back to normal Forth
2052 | bye \ Auf Wiedersehen
2053 | As we have called "bye", we can write what we want here without
2054 | it being run.
2055 | :a opOr
2056 | bwidth r0 MOV
2057 | r5 ZERO
2058 | r2 {sp} iLOAD
2059 | --sp
2060 | begin r0 while
2061 | r5 r5 ADD
2062 | tos r1 MOV r3 ZERO
2063 | r1 -if r3 NG1! then r1 INC r1 -if r3 NG1! then
2064 | r2 r1 MOV r4 ZERO
2065 | r1 -if r4 NG1! then r1 INC r1 -if r4 NG1! then
2066 | r3 r4 ADD r4 if r5 INC then
2067 | r2 r2 ADD
2068 | tos tos ADD
2069 | r0 DEC
2070 | repeat
2071 | r5 tos MOV ;a
2072 | :a opr5or
2073 | bwidth r0 MOV
2074 | r5 ZERO
2075 | r2 {sp} iLOAD
2076 | --sp
2077 | begin r0 while
2078 | r5 r5 ADD
2079 | tos r1 MOV r3 ZERO r1
2080 | -if r3 NG1! then r1 INC r1 -if r3 NG1! then
2081 | r2 r1 MOV r4 ZERO r1
2082 | -if r4 NG1! then r1 INC r1 -if r4 NG1! then
2083 | r3 r4 ADD r4 INC r3 ONE!
2084 | r4 if r3 ZERO then r3 r5 ADD
2085 | r2 r2 ADD
2086 | tos tos ADD
2087 | r0 DEC
2088 | repeat
2089 | r5 tos MOV ;a
2090 | :a opAnd
2091 | bwidth r0 MOV
2092 | r5 ZERO
2093 | r2 {sp} iLOAD
2094 | --sp
2095 | begin r0 while
2096 | r5 r5 ADD
2097 | tos r1 MOV r3 ZERO r1
2098 | -if r3 NG1! then r1 INC r1 -if r3 NG1! then
2099 | r2 r1 MOV r4 ZERO r1
2100 | -if r4 NG1! then r1 INC r1 -if r4 NG1! then
2101 | r3 r4 ADD two r4 ADD r3 ONE!
2102 | r4 if r3 ZERO then r3 r5 ADD
2103 | r2 r2 ADD
2104 | tos tos ADD
2105 | r0 DEC
2106 | repeat
2107 | r5 tos MOV ;a
2108 | # SUBLEQ Self Interpreter: Assembly version
2109 | #
2110 | # This is a "Self Interpreter" for SUBLEQ, that is,
2111 | # it is an interpreter that executes a SUBLEQ program
2112 | # written for a SUBLEQ machine. It expects the SUBLEQ
2113 | # program to be appended to the end of this program,
2114 | # as such it has to patch up the program and subtract
2115 | # the length of this program from each of the cells
2116 | # before execution, excepting the special addresses
2117 | # for when one of the operands is negative one.
2118 | #
2119 | # A single SUBLEQ instruction is written as:
2120 | #
2121 | # SUBLEQ a, b, c
2122 | #
2123 | # Which is as there is only one instruction possible,
2124 | # SUBLEQ, is often just written as:
2125 | #
2126 | # a b c
2127 | #
2128 | # These three operands are stored in three continuous
2129 | # memory locations. Each operand is an address, They
2130 | # perform the following pseudo-code:
2131 | #
2132 | # [b] = [b] - [a]
2133 | # if [b] <= 0:
2134 | # goto c;
2135 | #
2136 | # There are three special cases, if 'c' is negative
2137 | # then execution halts (or sometimes if it is refers
2138 | # to somewhere outside of addressable memory). The
2139 | # other two are for Input and Output. If 'a' is -1
2140 | # then a byte is loaded from input into address 'b',
2141 | # if 'b' is negative then a byte is output from
2142 | # address 'a'.
2143 | #
2144 | # Note that apart from I/O nothing is said about how
2145 | # numbers are represented, what bit length they are
2146 | # (or if each cell is an arbitrary precision number)
2147 | # and how negative numbers implemented (twos'
2148 | # compliment, sign magnitude, etcetera).
2149 | #
2150 | # Usually two's complement is used, but 8, 16, 32 and
2151 | # 64-bit versions of SUBLEQ are all common, with
2152 | # 32-bit versions being the most so.
2153 | #
2154 | # Despite the simplicity of the instruction set it is
2155 | # possible to compute anything computable with it
2156 | # (given infinite memory and time).
2157 | #
2158 | # To implement anything non-trivial self-modifying
2159 | # code is very common. This program is no exception.
2160 | #
2161 | # The self interpreter is actually quite simple to
2162 | # implement for this language.
2163 | #
2164 | # The original SUBLEQ self interpreter was from:
2165 | #
2166 | #
2167 | # (Written by Clive Gifford, 29/30 August 2006).
2168 | #
2169 | # However it does not deal with I/O.
2170 | #
2171 | # An improved version deals with output, but not
2172 | # input is available from:
2173 | #
2174 | #
2175 | #
2176 | # Which is a dead link as of 03/01/2023, an archived
2177 | # version is available at:
2178 | #
2179 | #
2180 | #
2181 | # This version deals with input and output and has
2182 | # fewer superfluous instructions. There are a number
2183 | # of improvements that could be made, which include:
2184 | #
2185 | ## Notes on the SUBLEQ assembler:
2186 | #
2187 | # * Statements are terminated by ';' or new lines.
2188 | # * Each statement is a single SUBLEQ instruction.
2189 | # * Labels are denoted with ':' and are used for both
2190 | # data and jump locations, the initial value is an
2191 | # expression to the right of the colon which will be
2192 | # placed at the memory location of the labels.
2193 | # * Operands can be omitted, in which case default
2194 | # values will be used.
2195 | # * If the last operand, the jump location is
2196 | # omitted, it will be replaced with the location of
2197 | # the next instruction.
2198 | # * If both of the last two operands are omitted then
2199 | # the last will be replaced with the location of the
2200 | # next instruction and the second operand will be
2201 | # replaced with a copy of the first operand,
2202 | # effectively zeroing the contents at the location of
2203 | # the first operand.
2204 | # * '?' represents the address of the next cell, not
2205 | # the next instruction.
2206 | #
2207 | ## Special Registers
2208 | #
2209 | # * 'Z', A register that should start and end up as
2210 | # zero, it is known as the Zero Register.
2211 | # * 'pc', the program counter for the simulated
2212 | # device.
2213 | # * 'IOV', contains the value for the special I/O
2214 | # address values. This stands for I/O Value.
2215 | # * 'neg1', contains negative one. Used for
2216 | # incrementing # usually be subtracting negative one
2217 | # against a value. The same value is used for 'IOV'.
2218 | # * 'len', contains the length of this program image,
2219 | # as # such the variable must be the last one defined
2220 | # in the file.
2221 | # * 'a', Operand 'a' of SUBLEQ instruction
2222 | # * 'b', Operand 'b' of SUBLEQ instruction
2223 | # * 'c', Operand 'c' of SUBLEQ instruction
2224 | # * 'a1', used to load 'a' before indirection and as
2225 | # temp reg
2226 | # * 'b1', used to load 'b' before indirection and as
2227 | # temp reg
2228 | # * 'c1', used to load 'c' before indirection and as
2229 | # temp reg
2230 | #
2231 | # On to the program itself:
2232 | #
2233 | start:
2234 | # Load PC: [a1] = [pc]
2235 | a1; pc Z; Z a1; Z;
2236 | # [a] = [[a1]] (after modification from above)
2237 | a; a1:0 Z a2; a2:Z a; Z;
2238 | # Patch up operand 'A' if it is not -1
2239 | #
2240 | # if [a] != -1:
2241 | # [a] = [a] + [len]
2242 | #
2243 | a1; a Z; Z a1; Z; # [a1] = [a]
2244 | IOV a1 ?+3; # If [a1] is negative jump over next line
2245 | len a; # [a] = [a] + [len]
2246 | neg1 pc; # [pc] = [pc] + 1
2247 | b1; pc Z; Z b1; Z;
2248 | b; b1:0 Z b2; b2:Z b; Z;
2249 | # Patch up operand 'b' if it is not -1
2250 | #
2251 | # if [b] != -1:
2252 | # [b] = [b] + [len]
2253 | #
2254 | b1; b Z; Z b1; Z;
2255 | IOV b1 ?+3;
2256 | len b;
2257 | # We need to copy 'pc' into 'c' and not use it
2258 | # directly later on as the SUBLEQ instruction might
2259 | # modify 'c', if it does the *old* value of 'pc' must
2260 | # be used (it would be more useful if the new value
2261 | # was used, however that is not the case).
2262 | #
2263 | neg1 pc; # [pc] = [pc] + 1
2264 | c1; pc Z; Z c1; Z; # [c1] = [pc]
2265 | c; c1:0 Z c2; c2:Z c; Z; # [c] = [[c1]]
2266 | # Execute the SUBLEQ instruction.
2267 | #
2268 | # Note that 'a' and 'b' have been modified from
2269 | # above.
2270 | #
2271 | # The result stored in 'b' will need to subject to a
2272 | # signed modulo operation in order to emulate a
2273 | # 16-bit machine on machine widths larger than the
2274 | # current one, as this is an expensive operation this
2275 | # should be skipped by detecting the machine width
2276 | # and jumping over the modulo on 16-bit machines,
2277 | # when this is implemented...
2278 | #
2279 | a:0 b:0 leqz; # Emulate subtraction / instruction
2280 | neg1 pc; # [pc] = [pc] + 1
2281 | Z Z start; # Jump back to beginning
2282 | leqz:
2283 | pc; c Z; Z pc; Z; # [pc] = [c]
2284 | neg1 c -1; # Check if [c] is negative, halt if so.
2285 | len pc; # [pc] = [pc] + [len]
2286 | Z Z start; # Jump back to the beginning
2287 | # Declare and set some registers, 'len' must be last.
2288 | . Z:0 pc:len+1 c:0 IOV: neg1:-1 len:-?
2289 | 15 15 3
2290 | 145 144 6
2291 | 144 15 9
2292 | 144 144 12
2293 | 114 114 15
2294 | 0 144 18
2295 | 144 114 21
2296 | 144 144 24
2297 | 15 15 27
2298 | 114 144 30
2299 | 144 15 33
2300 | 144 144 36
2301 | 147 15 42
2302 | 148 114 42
2303 | 147 145 45
2304 | 60 60 48
2305 | 145 144 51
2306 | 144 60 54
2307 | 144 144 57
2308 | 115 115 60
2309 | 0 144 63
2310 | 144 115 66
2311 | 144 144 69
2312 | 60 60 72
2313 | 115 144 75
2314 | 144 60 78
2315 | 144 144 81
2316 | 147 60 87
2317 | 148 115 87
2318 | 147 145 90
2319 | 105 105 93
2320 | 145 144 96
2321 | 144 105 99
2322 | 144 144 102
2323 | 146 146 105
2324 | 0 144 108
2325 | 144 146 111
2326 | 144 144 114
2327 | 0 0 123
2328 | 147 145 120
2329 | 144 144 0
2330 | 145 145 126
2331 | 146 144 129
2332 | 144 145 132
2333 | 144 144 135
2334 | 147 146 -1
2335 | 148 145 141
2336 | 144 144 0
2337 | 0 149 0
2338 | -1 -149
2339 | @ ' ) !
2340 | : debug source type ." ok" cr ; ' debug !
2341 | system +order
2342 | 0 constant false
2343 | -1 constant true
2344 | variable seed here seed !
2345 | : random ( -- u : 16-bit xorshift )
2346 | seed @ dup 0= if 0= then ( seed must not be zero )
2347 | dup 13 lshift xor
2348 | dup 9 rshift xor
2349 | dup 7 lshift xor
2350 | dup seed ! ;
2351 | ( : wordlist here dup 1 cells allot 0 swap ! ; )
2352 | : anonymous ( -- : make anonymous vocabulary and enable it )
2353 | get-order 1+ here dup 1 cells allot 0 swap ! swap set-order ;
2354 | : undefined? bl word find nip 0= ; ( "name", -- f )
2355 | : defined? undefined? 0= ; ( "name", -- f: word defined ? )
2356 | : ?\ 0= if postpone \ then ; ( f --, | : cond comp. )
2357 | : rdup r> r> dup >r >r >r ; ( R: n -- n n )
2358 | : umin 2dup swap u< if swap then drop ; ( u u -- u )
2359 | : umax 2dup u< if swap then drop ; ( u u -- u )
2360 | : off false swap ! ; ( a -- )
2361 | : on true swap ! ; ( a -- )
2362 | : tab 9 emit ; ( -- : emit the tab character )
2363 | : spaces ( n -- : equiv. bl banner )
2364 | ?dup 0> if for aft space then next then ;
2365 | : 2+ 2 + ; ( u -- u : increment by two )
2366 | : 2- 2 - ; ( u -- u : decrement by two )
2367 | : 2, , , ; ( n n -- : write two numbers into the dictionary )
2368 | : not -1 xor ; ( u -- u : same as 'invert' in this Forth )
2369 | : binary $2 base ! ; ( -- : set numeric radix to binary )
2370 | : octal $8 base ! ; ( -- : set numeric base to octal )
2371 | : .base base @ dup decimal . base ! ; ( -- )
2372 | : also get-order over swap 1+ set-order ; ( -- )
2373 | : previous get-order nip 1- set-order ; ( -- )
2374 | ( : buffer block ; ( k -- a )
2375 | : enum dup constant 1+ ; ( n --, )
2376 | : logical 0= 0= ; ( n -- f : turn a number into a 0 or -1 )
2377 | : limit rot min max ; ( n lo hi -- n )
2378 | : odd 1 and logical ; ( n -- f )
2379 | : even odd invert ; ( n -- f )
2380 | : nor or invert ; ( u u -- u )
2381 | : nand and invert ; ( u u -- u )
2382 | ( : under >r dup r> ; ( n1 n2 -- n1 n1 n2 )
2383 | : under over swap ; ( n1 n2 -- n1 n1 n2 )
2384 | : 2nip >r >r 2drop r> r> ; ( n1 n2 n3 n4 -- n3 n4 )
2385 | ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 )
2386 | : 2over >r >r 2dup r> swap >r swap r> r> -rot ;
2387 | : 2swap >r -rot r> -rot ; ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
2388 | : 2tuck 2swap 2over ; ( n1 n2 n3 n4 -- n3 n4 n1 n2 n3 n4 )
2389 | : 4drop 2drop 2drop ; ( n1 n2 n3 n4 -- )
2390 | : 2rot >r >r 2swap r> r> 2swap ; ( d1 d2 d3 -- d2 d3 d1 )
2391 | : trip dup dup ; ( n -- n n n : triplicate )
2392 | : 2pick dup >r pick r> 2+ pick swap ;
2393 | : log >r 0 swap ( u base -- u : integer logarithm )
2394 | begin swap 1+ swap r@ / dup 0= until drop 1- rdrop ;
2395 | : log2 0 swap ( u -- u : integer logarithm in base 2 )
2396 | begin swap 1+ swap 2/ dup 0= until drop 1- ;
2397 | : average um+ 2 um/mod nip ; ( u u -- u )
2398 | : <=> 2dup > if 2drop -1 exit then < ;
2399 | : bounds over + swap ;
2400 | : d>s drop ; ( d -- n : convert dubs to single )
2401 | : dabs s>d if dnegate then ; ( d -- ud )
2402 | : d- dnegate d+ ; ( d d -- d )
2403 | : d< rot 2dup > ( d -- f )
2404 | if = nip nip if 0 exit then -1 exit then
2405 | 2drop u< ;
2406 | : d>= d< invert ; ( d -- f )
2407 | : d> 2swap d< ; ( d -- f )
2408 | : d<= d> invert ; ( d -- f )
2409 | : d0< nip 0< ; ( d -- f )
2410 | : d0>= d0< 0= ; ( d -- f )
2411 | : d0= or 0= ; ( d -- f )
2412 | : d0<> d0= 0= ; ( d -- f )
2413 | : du< rot swap u< if 2drop #-1 exit then u< ; ( ud ud -- f )
2414 | : du> 2swap du< ; ( ud -- t )
2415 | : d= rot = -rot = and ; ( d d -- f )
2416 | : d<> d= 0= ; ( d d -- f )
2417 | : dmax 2over 2over d< if 2swap then 2drop ; ( d1 d2 -- d )
2418 | : dmin 2over 2over d> if 2swap then 2drop ; ( d1 d2 -- d )
2419 | : d.r >r tuck dabs <# #s rot sign #> r> over - bl banner type ;
2420 | : ud.r >r <# #s #> r> over - bl banner type ; ( ud +n -- )
2421 | : d. 0 d.r space ; ( d -- )
2422 | : ud. 0 ud.r space ; ( ud -- )
2423 | : 2rdrop r> rdrop rdrop >r ; ( R: n n -- )
2424 | : 2. swap . . ; ( n n -- )
2425 | : m* 2dup xor 0< >r abs swap abs um* r> if dnegate then ;
2426 | : */mod >r m* r> m/mod ; ( n n n -- r q )
2427 | : */ */mod nip ; ( n n n -- q )
2428 | : holds begin dup while 1- 2dup + c@ hold repeat 2drop ;
2429 | : roll ?dup if swap >r 1- recurse r> swap then ;
2430 | : -roll ?dup if rot >r 1- recurse r> then ;
2431 | : reverse for aft r@ -roll then next ; ( x0...xn n -- xn...x0 )
2432 | : unpick 1+ sp@ + [!] ; ( n0..nx y nu -- n0..y..nx )
2433 | : flip -rot swap ; ( a b c -- c b a )
2434 | : signum s>d swap 0> 1 and xor ; ( n -- -1 | 0 1 : signum )
2435 | : >< dup 8 rshift swap 8 lshift or ; ( u -- u : swap bytes )
2436 | : #digits >r dup 0= if 1+ exit then r> log 1+ ; ( u b -- u )
2437 | : ** ( n u -- n : integer exponentiation )
2438 | ?dup if
2439 | over >r
2440 | begin
2441 | dup 1 >
2442 | while
2443 | swap r@ * swap 1-
2444 | repeat rdrop drop
2445 | else logical 1 and then ;
2446 | : ur. base @ >r base ! u. r> base ! ; ( u base -- )
2447 | : r. base @ >r base ! . r> base ! ; ( n base -- )
2448 | : b. $2 ur. ; ( u -- )
2449 | : h. $10 ur. ; ( u -- )
2450 | : o. $8 ur. ; ( u -- )
2451 | : d. $A r. ; ( n -- )
2452 | ( : b. base @ swap 2 base ! . base ! ; ( u -- )
2453 | ( : h. base @ swap hex . base ! ; ( u -- )
2454 | ( : o. base @ swap 8 base ! . base ! ; ( u -- )
2455 | ( : d. base @ swap decimal . base ! ; ( n -- )
2456 | : @bits swap @ and ; ( a u -- u )
2457 | : ?\ if postpone \ then ; immediate
2458 | : ?( if postpone ( then ; immediate ( )
2459 | : ?if compile dup postpone if ; immediate
2460 | : screens ( k1 k2 -- : list blocks k1 to k2 )
2461 | over -
2462 | for
2463 | dup . dup list 1+ key $D = if rdrop drop exit then
2464 | next drop ;
2465 | : thru over - for dup >r load r> 1+ next drop ; ( k1 k2 -- )
2466 | : /string over min rot over + -rot - ;
2467 | : ndrop for aft drop then next ; ( 0...n n -- )
2468 | : unused $FFFF here - ; ( 65536 bytes available in this VM )
2469 | : char+ 1+ ; ( b -- b )
2470 | : str= compare 0= ; ( a1 u1 a2 u2 -- f : string equality )
2471 | : str< compare 0< ; ( a1 u1 a2 u2 -- f )
2472 | : str> 2swap compare 0< ; ( a1 u1 a2 u2 -- f )
2473 | : str>= str< 0= ; ( a1 u1 a2 u2 -- f )
2474 | : str<= str> 0= ; ( a1 u1 a2 u2 -- f )
2475 | : mux dup >r and swap r> invert and or ; ( x1 x2 mask -- x )
2476 | : square dup * ; ( n -- n : square a number )
2477 | : sqrt ( n -- u : integer square root )
2478 | 1 ?depth
2479 | s>d if -$B throw then ( does not work for neg. values )
2480 | dup 2 < if exit then ( return 0 or 1 )
2481 | dup ( u u )
2482 | 2 rshift recurse 2* ( u sc )
2483 | dup ( u sc sc )
2484 | 1+ dup square ( u sc lc lc^2 )
2485 | >r rot r> < ( sc lc bool )
2486 | if drop else nip then ; ( return small or large candidate )
2487 | : log ( u base -- u : the integer logarithm of u in 'base' )
2488 | >r
2489 | dup 0= -$B and throw ( logarithm of zero is an error )
2490 | 0 swap
2491 | begin
2492 | swap 1+ swap r@ / dup 0= ( keep dividing until 'u' is 0 )
2493 | until
2494 | drop 1- rdrop ;
2495 | : clz ( u -- : count leading zeros )
2496 | ?dup 0= if $10 exit then
2497 | $8000 0 >r begin
2498 | 2dup and 0=
2499 | while
2500 | r> 1+ >r 2/
2501 | repeat
2502 | 2drop r> ;
2503 | ( : log2 2 log ; ( u -- u : binary integer logarithm )
2504 | : log2 ( u -- u )
2505 | ?dup 0= -$B and throw clz $10 swap - 1- ;
2506 | : count-bits ( number -- bits )
2507 | dup $5555 and swap 1 rshift $5555 and +
2508 | dup $3333 and swap 2 rshift $3333 and +
2509 | dup $0F0F and swap 4 rshift $0F0F and +
2510 | $FF mod ;
2511 | : first-bit ( number -- first-bit )
2512 | dup 1 rshift or
2513 | dup 2 rshift or
2514 | dup 4 rshift or
2515 | dup 8 rshift or
2516 | dup $10 rshift or
2517 | dup 1 rshift xor ;
2518 | : gray-encode dup 1 rshift xor ; ( gray -- u )
2519 | : gray-decode ( u -- gray )
2520 | \ dup $10 rshift xor ( <- 32 bit )
2521 | dup 8 rshift xor
2522 | dup 4 rshift xor
2523 | dup 2 rshift xor
2524 | dup 1 rshift xor ;
2525 | : n>r ( xn..x1 n -- , R: -- x1..xn n )
2526 | dup
2527 | begin dup
2528 | while rot r> swap >r >r 1-
2529 | repeat
2530 | drop r> swap >r >r ; compile-only
2531 | : nr> ( -- xn..x1 n, R: x1..xn n -- )
2532 | r> r> swap >r dup
2533 | begin dup
2534 | while r> r> swap >r -rot 1-
2535 | repeat
2536 | drop ; compile-only
2537 | : +leading ( b u -- b u: skip leading space )
2538 | begin over c@ dup bl = swap 9 = or while 1 /string repeat ;
2539 | system -order
2540 | .( DONE ) cr
2541 | : struct 0 ;
2542 | : field: ( offset size -- offset' )
2543 | create over , +
2544 | does> @ + ;
2545 | : byte: 1 field: ;
2546 | : cell: 2 field: ;
2547 | : long: 4 field: ;
2548 | : union: 0 field: ;
2549 | : unused + ;
2550 | : size: constant ;
2551 | : ;struct drop ;
2552 | : mark
2553 | $" defined (mark) [if] (mark) [then] marker (mark) "
2554 | count evaluate ;
2555 | mark
2556 | ' ) !
2557 | .( LOADED EFORTH. ) cr
2558 | .( DICTIONARY: ) here . cr
2559 | .( EFORTH: ) ' 1- u. cr
2560 | !
2561 | @ ' ) !
2562 | system +order
2563 | : wordlist here cell allot 0 over ! ; ( -- wid : alloc wid )
2564 | ( NB. Bitwise ops must be masked off on non 16-bit machines )
2565 | : crc ( b u -- u : calculate ccitt-ffff CRC )
2566 | $FFFF >r begin ?dup while
2567 | over c@ r> swap
2568 | ( CCITT polynomial $1021, or "x16 + x12 + x5 + 1" )
2569 | over $8 rshift xor ( crc x )
2570 | dup $4 rshift xor ( crc x )
2571 | dup $5 lshift xor ( crc x )
2572 | dup $C lshift xor ( crc x )
2573 | swap $8 lshift xor ( crc )
2574 | >r +string
2575 | repeat r> nip ;
2576 | ( A primitive user login system [that is super insecure]. )
2577 | wordlist +order definitions
2578 | wordlist constant users
2579 | constant (prompt) ( -- xt : store prompt for later use )
2580 | variable proceed 0 proceed !
2581 | : conceal $1B emit ." [8m" ; ( NB. Could also override )
2582 | : reveal $1B emit ." [28m" ;
2583 | : secure users 1 set-order ; ( load password database )
2584 | : restore only forth definitions decimal (prompt) ! ;
2585 | : message ." user: " ; ( -- : prompt asking for user-name )
2586 | : fail ." Invalid username or password" cr ; ( -- error msg )
2587 | : success 1 proceed ! ." logged in." ; ( signal success )
2588 | : pass token count crc ; ( "xxx" -- u : super-secure <_< )
2589 | : ask ." pass: " conceal query reveal ;
2590 | : empty depth for aft drop then next ; ( ??? -- : empty stack )
2591 | : prompt secure message ' ) ! ;
2592 | : get query eval ; ( "xxx" -- : get user name )
2593 | : retry begin prompt ' get catch drop empty proceed @ until ;
2594 | forth-wordlist +order definitions
2595 | : user: ( "user" "password" -- : create new user entry )
2596 | users +order definitions create pass , only forth definitions
2597 | does> ask @ pass = if restore success exit then fail ;
2598 | : login 0 proceed ! retry ; ( -- : enter login system )
2599 | : .users get-order secure words set-order ; ( -- : list users )
2600 | user: guest guest
2601 | user: admin password1
2602 | user: archer dangerzone
2603 | user: cyril figgis
2604 | user: lana stirling
2605 | .( EFORTH ONLINE ) cr
2606 | login
2607 | ' ( !
2608 | .( LOADING... ) cr
2609 | only forth definitions hex
2610 | variable sokoban-wordlist
2611 | sokoban-wordlist +order definitions
2612 | $20 constant maze ( blank, or space, can be moved on )
2613 | char X constant wall ( wall, a lovely brick construction )
2614 | char * constant boulder ( the burden of Sisyphus )
2615 | char . constant off ( switch / pressure plate )
2616 | char & constant on ( boulder + switch )
2617 | char @ constant player ( player character - amazing graphics )
2618 | char ~ constant player+ ( player + off pad )
2619 | $10 constant l/b ( lines per block )
2620 | $40 constant c/b ( columns per block )
2621 | 7 constant bell ( bell character )
2622 | variable position ( current player position )
2623 | variable moves ( moves made by player )
2624 | variable lblk ( last block loaded )
2625 | ( used to store rule being processed )
2626 | create rule 3 c, 0 c, 0 c, 0 c,
2627 | : n1+ swap 1+ swap ; ( n n -- n n : inc. second item on stk. )
2628 | : match ( a a -- f )
2629 | n1+ ( replace with umin of both counts? )
2630 | count
2631 | for aft
2632 | count rot count rot <> if 2drop rdrop 0 exit then
2633 | then next 2drop -1 ;
2634 | : beep bell emit ; ( -- : emit bell character )
2635 | : ?apply ( a a a -- a, R: ? -- ?| )
2636 | >r over swap match if drop r> rdrop exit then rdrop ;
2637 | : apply ( a -- a : check for a rule and apply it )
2638 | $" @ " $" @" ?apply
2639 | $" @." $" ~" ?apply
2640 | $" @* " $" @*" ?apply
2641 | $" @*." $" @&" ?apply
2642 | $" @&." $" ~&" ?apply
2643 | $" @& " $" ~*" ?apply
2644 | $" ~ " $" .@" ?apply
2645 | $" ~." $" .~" ?apply
2646 | $" ~* " $" .@*" ?apply
2647 | $" ~*." $" .@&" ?apply
2648 | $" ~&." $" .~&" ?apply
2649 | $" ~& " $" .~*" ?apply beep ;
2650 | : pack ( c0...cn b n -- )
2651 | 2dup swap c! for aft 1+ tuck c! then next drop ;
2652 | : locate ( b u c -- u f : locate 'c' in buffer b/u )
2653 | >r
2654 | begin
2655 | ?dup
2656 | while
2657 | 1- 2dup + c@ r@ = if nip rdrop -1 exit then
2658 | repeat
2659 | rdrop
2660 | drop
2661 | 0 0 ;
2662 | : relative swap c/b * + + ( $3ff and ) ; ( +x +y pos -- pos )
2663 | : +position position @ relative ; ( +x +y -- pos )
2664 | : double 2* swap 2* swap ; ( u u -- u u )
2665 | : arena lblk @ block b/buf ; ( -- b u )
2666 | : >arena arena drop + ; ( pos -- a )
2667 | : fetch ( +x +y -- a a a )
2668 | 2dup +position >arena >r
2669 | double +position >arena r> swap
2670 | position @ >arena -rot ;
2671 | : rule@ fetch c@ rot c@ rot c@ rot ; ( +x +y -- c c c )
2672 | : 3reverse -rot swap ; ( 1 2 3 -- 3 2 1 )
2673 | : rule! rule@ 3reverse rule 3 pack ; ( +x +y -- )
2674 | : think 2dup rule! rule apply >r fetch r> ; ( +x +y --a a a a )
2675 | : count! count rot c! ; ( a a -- )
2676 | : act ( a a a a -- )
2677 | count swap >r 2 =
2678 | if
2679 | drop swap r> count! count!
2680 | else
2681 | 3reverse r> count! count! count!
2682 | then drop ;
2683 | : #boulders ( -- n : number of boulders left on the map )
2684 | 0 arena
2685 | for aft
2686 | dup c@ boulder = if n1+ then
2687 | 1+
2688 | then next drop ;
2689 | : input key ; ( -- c : get a character of input )
2690 | : instructions ( -- : help could be stored in blocks )
2691 | ." THIS IS A GAME OF SOKOBAN, A GAME OF SKILL, DARING AND" cr
2692 | ." DARING SKILL. THE OBJECT OF THE GAME IS TO MOVE THE" cr
2693 | ." BOULDERS ON TO THE SWITCHES / PRESSURE PLATES IN THE" cr
2694 | ." FEWEST MOVES. TO PLAY THIS GAME YOU CAN TYPE:" cr cr
2695 | ." 30 sokoban" cr cr
2696 | ." THE PLAYER AND BOULDERS CAN ONLY BE PUSHED, AND ONLY" cr
2697 | ." PUSHED IN THE CARDINAL DIRECTIONS [NORTH, EAST, SOUTH" cr
2698 | ." AND WEST]. THE 'w', 'a', 's' AND 'd' KEYS ARE USED FOR" cr
2699 | ." MOVEMENT. 'q' CAN BE USED TO QUIT." cr
2700 | ." TILE KEY:" cr
2701 | ." ' ' : AN EMPTY, NAVIGABLE TILE" cr
2702 | ." 'X' : AN IMPASSIBLE WALL." cr
2703 | ." '*' : YOUR ARCH NEMESIS. THE BOULDER." cr
2704 | ." '.' : A SWITCH / PRESSURE PLATE." cr
2705 | ." '@' : YOU, THE HANDSOME AND WISE PLAYER CHARACTER." cr
2706 | ." '&' : BOULDER ON TOP OF SWITCH." cr
2707 | ." '~' : PLAYER ON TOP OF SWITCH." cr cr
2708 | ." THE GAME IS WON WHEN ALL '*' ARE ON TOP OF '.'" cr
2709 | ." GOOD LUCK COMMANDER." cr cr input drop ;
2710 | : .boulders ." BOLDERS: " #boulders u. cr ; ( -- )
2711 | : .moves ." MOVES: " moves @ u. cr ; ( -- )
2712 | : .help ." WASD: MOVEMENT" cr ( -- : short help )
2713 | ." H: HELP" cr ;
2714 | : .maze lblk @ list ; ( -- : display the maze )
2715 | : show ( page cr ) .maze .boulders .moves .help ; ( -- )
2716 | : solved? #boulders 0= ; ( -- : no boulders left = WIN )
2717 | : finished? solved? if 1 throw then ; ( -- : throw on victory )
2718 | : where >r arena r> locate ; ( c -- u f )
2719 | : player? player where 0= if drop player+ where else -1 then ;
2720 | : player! player? 0= -2 and throw position ! ; ( -- )
2721 | : start player! 0 moves ! ; ( -- : reset some state )
2722 | : .winner show cr ." SOLVED!" cr ; ( -- : Win message )
2723 | : .quit cr ." Quitter!" cr ; ( -- : Quit message )
2724 | : finish 1 = if .winner exit then .quit ; ( n -- )
2725 | : rules think act player! ; ( +x +y -- )
2726 | : +move 1 moves +! ; ( -- : increment move counter )
2727 | : ?ignore over <> if rdrop then ; ( c1 c2 --, R: x -- | x )
2728 | : left [char] a ?ignore -1 0 rules +move ; ( c -- c )
2729 | : right [char] d ?ignore 1 0 rules +move ; ( c -- c )
2730 | : up [char] w ?ignore 0 -1 rules +move ; ( c -- c )
2731 | : down [char] s ?ignore 0 1 rules +move ; ( c -- c )
2732 | : help [char] h ?ignore instructions ; ( c -- c )
2733 | : end [char] q ?ignore drop 2 throw ; ( c -- | c, R ? -- | ? )
2734 | : default drop ; ( c -- : action for unknown command )
2735 | : command up down left right help end default finished? ;
2736 | : maze! dup lblk ! block drop ; ( k -- : set block to use )
2737 | sokoban-wordlist -order definitions
2738 | sokoban-wordlist +order
2739 | : sokoban ( k -- : play a game of sokoban given a Forth block )
2740 | maze! start
2741 | begin ( loop until something throws )
2742 | show input ' command catch ?dup
2743 | until finish ;
2744 | only forth definitions decimal
2745 | editor 30 r z
2746 | 1 a XXXXX
2747 | 2 a X X
2748 | 3 a X* X
2749 | 4 a XXX *XXX
2750 | 5 a X * * X
2751 | 6 a XXX X XXX X XXXXXX
2752 | 7 a X X XXX XXXXXXX ..X
2753 | 8 a X * * ..X
2754 | 9 a XXXXX XXXX X@XXXX ..X
2755 | 10 a X XXX XXXXXX
2756 | 11 a XXXXXXXX
2757 | s n z
2758 | 1 a XXXXXXXXXXXX
2759 | 2 a X.. X XXX
2760 | 3 a X.. X * * X
2761 | 4 a X.. X*XXXX X
2762 | 5 a X.. @ XX X
2763 | 6 a X.. X X * XX
2764 | 7 a XXXXXX XX* * X
2765 | 8 a X * * * * X
2766 | 9 a X X X
2767 | 10 a XXXXXXXXXXXX
2768 | s n z
2769 | 1 a XXXXXXXX
2770 | 2 a X @X
2771 | 3 a X *X* XX
2772 | 4 a X * *X
2773 | 5 a XX* * X
2774 | 6 a XXXXXXXXX * X XXX
2775 | 7 a X.... XX * * X
2776 | 8 a XX... * * X
2777 | 9 a X.... XXXXXXXXXX
2778 | 10 a XXXXXXXX
2779 | s n z
2780 | 1 a XXXXXXXX
2781 | 2 a X ....X
2782 | 3 a XXXXXXXXXXXX ....X
2783 | 4 a X X * * ....X
2784 | 5 a X ***X* * X ....X
2785 | 6 a X * * X ....X
2786 | 7 a X ** X* * *XXXXXXXX
2787 | 8 a XXXX * X X
2788 | 9 a X X XXXXXXXXX
2789 | 10 a X * XX
2790 | 11 a X **X** @X
2791 | 12 a X X XX
2792 | 13 a XXXXXXXXX
2793 | s q
2794 | system +order ' ok ! only forth definitions decimal
2795 | .( LOADED ) cr
2796 | .( Type '# sokoban' to play, where '#' is a block number ) cr
2797 | .( For example "30 sokoban" ) cr
2798 | .( Follow the on screen instructions to play a game. ) cr
2799 | : nul? count nip 0= ; ( a -- f : is counted word empty? )
2800 | : grab ( -- a : get word from input stream )
2801 | begin token dup nul? 0= ?exit drop query again ;
2802 | : integer grab count number? nip ; ( -- n f : get int. )
2803 | : integer? integer 0= ( dpl @ 0>= or ) -$18 and throw ;
2804 | : ingest ( a u -- : opposite of 'dump', load nums into mem )
2805 | cell / for aft integer? over ! cell+ then next drop ;
2806 | : debug source type ." ok" cr ; ' debug !
2807 | only forth definitions system +order
2808 | : ?\ 0= if postpone \ then ; ( f --, | : cond. comp. )
2809 | : 1+! 1 swap +! ;
2810 | : dabs s>d if dnegate then ; ( d -- ud )
2811 | : +- 0< if negate then ; ( n n -- n : copy sign )
2812 | : >< dup 8 rshift swap 8 lshift or ; ( u -- u : byte swap )
2813 | : m* ( n n -- d : mixed multiplication )
2814 | 2dup xor 0< >r abs swap abs um* r> if dnegate then ;
2815 | : /string ( b u1 u2 -- b u : advance string u2 )
2816 | over min rot over + -rot - ;
2817 | : sm/rem ( dl dh nn -- rem quo: symmetric division )
2818 | over >r >r ( dl dh nn -- dl dh, R: -- dh nn )
2819 | dabs r@ abs um/mod ( dl dh -- rem quo, R: dh nn -- dh nn )
2820 | r> r@ xor +- swap r> +- swap ;
2821 | .( BEGIN TEST SUITE DEFINITIONS ) here . cr
2822 | .( SET MARKER 'XXX' ) cr
2823 | marker xxx
2824 | variable test
2825 | system +order
2826 | test +order definitions
2827 | variable total ( total number of tests )
2828 | variable passed ( number of tests that passed )
2829 | variable vsp ( stack depth at execution of '->' )
2830 | variable vsp0 ( stack depth at execution of 'T{' )
2831 | variable n ( temporary store for 'equal' )
2832 | variable verbose ( verbosity level of the tests )
2833 | 1 verbose !
2834 | : quine source type cr ; ( -- : print out current input line )
2835 | : ndrop for aft drop then next ; ( a0...an n -- )
2836 | : ndisplay for aft . then next ; ( a0...an n -- )
2837 | : empty-stacks depth ndrop ; ( a0...an -- )
2838 | : .pass verbose @ 1 > if ." ok: " space quine then ; ( -- )
2839 | : .failed verbose @ 0 > if ." fail: " space quine then ; ( -- )
2840 | : pass passed 1+! ; ( -- )
2841 | : fail empty-stacks -$B throw ; ( -- )
2842 | : equal ( a0...an b0...bn n -- a0...an b0...bn n f )
2843 | dup n !
2844 | for aft
2845 | r@ pick r@ n @ 1+ + pick xor if rdrop n @ 0 exit then
2846 | then next n @ -1 ;
2847 | : ?stacks ( u u -- )
2848 | 2dup xor
2849 | if
2850 | .failed ." Too Few/Many Arguments Provided" cr
2851 | ." Expected: " u. cr
2852 | ." Got: " u. cr
2853 | ." Full Stack:" .s cr
2854 | fail exit
2855 | else 2drop then ;
2856 | : ?equal ( a0...an b0...bn n -- )
2857 | dup >r
2858 | equal nip 0= if
2859 | .failed ." Argument Value Mismatch" cr
2860 | ." Expected: " r@ ndisplay cr
2861 | ." Got: " r@ ndisplay cr
2862 | fail exit
2863 | then r> 2* ndrop ;
2864 | only forth definitions system +order test +order
2865 | : }T depth vsp0 @ - vsp @ 2* ?stacks vsp @ ?equal pass .pass ;
2866 | : -> depth vsp0 @ - vsp ! ;
2867 | : T{ depth vsp0 ! total 1+! ;
2868 | : statistics total @ passed @ ;
2869 | : throws? ( "name" -- n )
2870 | postpone ' catch >r empty-stacks r> ;
2871 | : logger( ( "line" -- : print line if verbose set high )
2872 | verbose @ 1 > if postpone .( cr exit then postpone ( ;
2873 | : logger\ verbose @ 1 > if exit then postpone \ ;
2874 | system +order
2875 | test +order
2876 | .( BEGIN FORTH TEST SUITE ) cr
2877 | logger( DECIMAL BASE )
2878 | decimal
2879 | T{ 1. -> 1 0 }T
2880 | T{ -> }T
2881 | T{ 1 -> 1 }T
2882 | T{ 1 2 3 -> 1 2 3 }T
2883 | T{ 1 1+ -> 2 }T
2884 | T{ 2 2 + -> 4 }T
2885 | T{ 3 2 4 within -> -1 }T
2886 | T{ 2 2 4 within -> -1 }T
2887 | T{ 4 2 4 within -> 0 }T
2888 | T{ 98 4 min -> 4 }T
2889 | T{ 1 5 min -> 1 }T
2890 | T{ -1 5 min -> -1 }T
2891 | T{ -6 0 min -> -6 }T
2892 | T{ 55 3 max -> 55 }T
2893 | T{ -55 3 max -> 3 }T
2894 | T{ 3 10 max -> 10 }T
2895 | T{ -2 negate -> 2 }T
2896 | T{ 0 negate -> 0 }T
2897 | T{ 2 negate -> -2 }T
2898 | T{ $8000 negate -> $8000 }T
2899 | T{ 0 aligned -> 0 }T
2900 | T{ 1 aligned -> 2 }T
2901 | T{ 2 aligned -> 2 }T
2902 | T{ 3 aligned -> 4 }T
2903 | T{ 3 4 > -> 0 }T
2904 | T{ 3 -4 > -> -1 }T
2905 | T{ 5 5 > -> 0 }T
2906 | T{ 6 6 u> -> 0 }T
2907 | T{ 9 -8 u> -> 0 }T
2908 | T{ 5 2 u> -> -1 }T
2909 | T{ -4 abs -> 4 }T
2910 | T{ 0 abs -> 0 }T
2911 | T{ 7 abs -> 7 }T
2912 | T{ $100 $10 $8 /string -> $108 $8 }T
2913 | T{ $100 $10 $18 /string -> $110 $0 }T
2914 | T{ 1 2 3 4 5 1 pick -> 1 2 3 4 5 4 }T
2915 | T{ 1 2 3 4 5 0 pick -> 1 2 3 4 5 5 }T
2916 | T{ 1 2 3 4 5 3 pick -> 1 2 3 4 5 2 }T
2917 | T{ 3 4 / -> 0 }T
2918 | T{ 4 4 / -> 1 }T
2919 | T{ 1 0 throws? / -> -10 }T
2920 | T{ -10 0 throws? / -> -10 }T
2921 | T{ 2 2 throws? / -> 0 }T
2922 | marker string-tests
2923 | : s1 $" xxx" count ;
2924 | : s2 $" hello" count ;
2925 | : s3 $" 123" count ;
2926 | : s4 $" aBc" count ;
2927 | : s5 $" abc" count ;
2928 | : <#> 0 <# #s #> ; ( n -- b u )
2929 | logger( Test Strings: )
2930 | logger\ .( s1: ) space s1 type cr
2931 | logger\ .( s2: ) space s2 type cr
2932 | logger\ .( s3: ) space s3 type cr
2933 | T{ s1 s2 compare 0= -> 0 }T
2934 | T{ s2 s1 compare 0= -> 0 }T
2935 | T{ s1 s1 compare 0= -> -1 }T
2936 | T{ s2 s2 compare 0= -> -1 }T
2937 | .( COMPARE ) cr
2938 | T{ s3 123 <#> compare 0= -> -1 }T
2939 | T{ s3 -123 <#> compare 0= -> 0 }T
2940 | T{ s3 99 <#> compare 0= -> 0 }T
2941 | string-tests
2942 | T{ 0 ?dup -> 0 }T
2943 | T{ 3 ?dup -> 3 3 }T
2944 | T{ 1 2 3 rot -> 2 3 1 }T
2945 | T{ 1 2 3 -rot -> 3 1 2 }T
2946 | T{ 2 3 ' + execute -> 5 }T
2947 | T{ : test-1 [ $5 $3 * ] literal ; test-1 -> $F }T
2948 | marker variable-test
2949 | logger( Defined variable 'x' )
2950 | variable x
2951 | T{ 9 x ! x @ -> 9 }T
2952 | T{ 1 x +! x @ -> $A }T
2953 | variable-test
2954 | T{ 0 invert -> -1 }T
2955 | T{ -1 invert -> 0 }T
2956 | T{ $5555 invert -> $AAAA }T
2957 | T{ 0 0 and -> 0 }T
2958 | T{ 0 -1 and -> 0 }T
2959 | T{ -1 0 and -> 0 }T
2960 | T{ -1 -1 and -> -1 }T
2961 | T{ $FA50 $05AF and -> $0000 }T
2962 | T{ $FA50 $FA00 and -> $FA00 }T
2963 | T{ 0 0 or -> 0 }T
2964 | T{ 0 -1 or -> -1 }T
2965 | T{ -1 0 or -> -1 }T
2966 | T{ -1 -1 or -> -1 }T
2967 | T{ $FA50 $05AF or -> $FFFF }T
2968 | T{ $FA50 $FA00 or -> $FA50 }T
2969 | T{ 0 0 xor -> 0 }T
2970 | T{ 0 -1 xor -> -1 }T
2971 | T{ -1 0 xor -> -1 }T
2972 | T{ -1 -1 xor -> 0 }T
2973 | T{ $FA50 $05AF xor -> $FFFF }T
2974 | T{ $FA50 $FA00 xor -> $0050 }T
2975 | system +order
2976 | T{ $FFFF 1 um+ -> 0 1 }T
2977 | T{ $40 $FFFF um+ -> $3F 1 }T
2978 | T{ 4 5 um+ -> 9 0 }T
2979 | T{ $FFFF 1 um* -> $FFFF 0 }T
2980 | T{ $FFFF 2 um* -> $FFFE 1 }T
2981 | T{ $1004 $100 um* -> $400 $10 }T
2982 | T{ 3 4 um* -> $C 0 }T
2983 | system -order
2984 | T{ 1 1 < -> 0 }T
2985 | T{ 1 2 < -> -1 }T
2986 | T{ -1 2 < -> -1 }T
2987 | T{ -2 0 < -> -1 }T
2988 | T{ $8000 5 < -> -1 }T
2989 | T{ 5 -1 < -> 0 }T
2990 | T{ 1 1 u< -> 0 }T
2991 | T{ 1 2 u< -> -1 }T
2992 | T{ -1 2 u< -> 0 }T
2993 | T{ -2 0 u< -> 0 }T
2994 | T{ $8000 5 u< -> 0 }T
2995 | T{ 5 -1 u< -> -1 }T
2996 | T{ 1 1 = -> -1 }T
2997 | T{ -1 1 = -> 0 }T
2998 | T{ 1 0 = -> 0 }T
2999 | T{ 2 dup -> 2 2 }T
3000 | T{ 1 2 nip -> 2 }T
3001 | T{ 1 2 over -> 1 2 1 }T
3002 | T{ 1 2 tuck -> 2 1 2 }T
3003 | T{ 1 negate -> -1 }T
3004 | T{ 3 4 swap -> 4 3 }T
3005 | T{ 0 0= -> -1 }T
3006 | T{ 3 0= -> 0 }T
3007 | T{ -5 0< -> -1 }T
3008 | T{ 1 2 3 2drop -> 1 }T
3009 | T{ 1 2 lshift -> 4 }T
3010 | T{ 1 $10 lshift -> 0 }T
3011 | T{ $4001 4 lshift -> $0010 }T
3012 | T{ 8 2 rshift -> 2 }T
3013 | T{ $4001 4 rshift -> $0400 }T
3014 | T{ $8000 1 rshift -> $4000 }T
3015 | T{ 99 throws? throw -> 99 }T
3016 | T{ 50 10 /mod -> 0 5 }T
3017 | ( T{ -4 3 /mod -> -1 -1 }T )
3018 | ( T{ -8 3 /mod -> -2 -2 }T )
3019 | T{ 0 >< -> 0 }T
3020 | T{ -1 >< -> -1 }T
3021 | T{ $0001 >< -> $0100 }T
3022 | T{ $CAFE >< -> $FECA }T
3023 | T{ $1234 >< -> $3412 }T
3024 | marker definition-test
3025 | logger( Created word 'y' 0 , 0 , )
3026 | create y 0 , 0 ,
3027 | T{ 4 5 y 2! -> }T
3028 | T{ y 2@ -> 4 5 }T
3029 | : e1 $" 2 5 + " count ;
3030 | : e2 $" 4 0 / " count ;
3031 | : e3 $" : z [ 4 dup * ] literal ; " count ;
3032 | logger\ .( e1: ) space e1 type cr
3033 | logger\ .( e2: ) space e2 type cr
3034 | logger\ .( e3: ) space e3 type cr
3035 | T{ e1 evaluate -> 7 }T
3036 | T{ e2 throws? evaluate -> $A negate }T
3037 | T{ e3 evaluate z -> $10 }T
3038 | definition-test
3039 | T{ here 4 , @ -> 4 }T
3040 | T{ here 0 , here swap cell+ = -> -1 }T
3041 | T{ char 0 -> $30 }T
3042 | T{ char 1 -> $31 }T
3043 | T{ char g -> $67 }T
3044 | T{ char ghijk -> $67 }T
3045 | T{ #vocs 8 min -> 8 }T \ minimum number of vocabularies is 8
3046 | T{ b/buf -> $400 }T \ b/buf should always be 1024
3047 | T{ here 4 allot -4 allot here = -> -1 }T
3048 | $FFFF constant min-int
3049 | $7FFF constant max-int
3050 | $FFFF constant 1s
3051 | T{ 0 s>d 1 sm/rem -> 0 0 }T
3052 | T{ 1 s>d 1 sm/rem -> 0 1 }T
3053 | T{ 2 s>d 1 sm/rem -> 0 2 }T
3054 | T{ -1 s>d 1 sm/rem -> 0 -1 }T
3055 | T{ -2 s>d 1 sm/rem -> 0 -2 }T
3056 | T{ 0 s>d -1 sm/rem -> 0 0 }T
3057 | T{ 1 s>d -1 sm/rem -> 0 -1 }T
3058 | T{ 2 s>d -1 sm/rem -> 0 -2 }T
3059 | T{ -1 s>d -1 sm/rem -> 0 1 }T
3060 | T{ -2 s>d -1 sm/rem -> 0 2 }T
3061 | T{ 2 s>d 2 sm/rem -> 0 1 }T
3062 | T{ -1 s>d -1 sm/rem -> 0 1 }T
3063 | T{ -2 s>d -2 sm/rem -> 0 1 }T
3064 | T{ 7 s>d 3 sm/rem -> 1 2 }T
3065 | T{ 7 s>d -3 sm/rem -> 1 -2 }T
3066 | T{ -7 s>d 3 sm/rem -> -1 -2 }T
3067 | T{ -7 s>d -3 sm/rem -> -1 2 }T
3068 | T{ max-int s>d 1 sm/rem -> 0 max-int }T
3069 | T{ min-int s>d 1 sm/rem -> 0 min-int }T
3070 | T{ max-int s>d max-int sm/rem -> 0 1 }T
3071 | T{ min-int s>d min-int sm/rem -> 0 1 }T
3072 | T{ 1s 1 4 sm/rem -> 3 max-int }T
3073 | T{ 2 min-int m* 2 sm/rem -> 0 min-int }T
3074 | T{ 2 min-int m* min-int sm/rem -> 0 2 }T
3075 | T{ 2 max-int m* 2 sm/rem -> 0 max-int }T
3076 | T{ 2 max-int m* max-int sm/rem -> 0 2 }T
3077 | T{ min-int min-int m* min-int sm/rem -> 0 min-int }T
3078 | T{ min-int max-int m* min-int sm/rem -> 0 max-int }T
3079 | T{ min-int max-int m* max-int sm/rem -> 0 min-int }T
3080 | T{ max-int max-int m* max-int sm/rem -> 0 max-int }T
3081 | T{ :noname 2 6 + ; execute -> 8 }T
3082 | .( TESTS COMPLETE ) cr
3083 | decimal
3084 | .( passed: ) statistics u. space .( / ) 0 u.r cr
3085 | .( here: ) here . cr
3086 | statistics <> ?\ .( [FAILED] ) cr \ abort
3087 | statistics = ?\ .( [ALL PASSED] ) cr
3088 | .( CALLING MARKER 'XXX' ) cr
3089 | xxx
3090 | ( FORTH-83 FLOATING POINT.
3091 | ----------------------------------
3092 | COPYRIGHT 1985 BY ROBERT F. ILLYES
3093 | PO BOX 2516, STA. A
3094 | CHAMPAIGN, IL 61820
3095 | PHONE: 217/826-2734 ) HEX
3096 | : ZERO OVER 0= IF DROP 0 THEN ;
3097 | : FNEGATE 8000 XOR ZERO ;
3098 | : FABS 7FFF AND ;
3099 | : NORM >R 2DUP OR
3100 | IF BEGIN DUP 0< NOT
3101 | WHILE D2* R> 1- >R
3102 | REPEAT SWAP 0< - ?DUP
3103 | IF R> ELSE 8000 R> 1+ THEN
3104 | ELSE R> DROP THEN ;
3105 | : F2* 1+ ZERO ;
3106 | : F* ROT + 4000 - >R UM* R> NORM ;
3107 | : FSQ 2DUP F* ;
3108 | : F2/ 1- ZERO ;
3109 | : UM/ DUP >R UM/MOD SWAP R>
3110 | OVER 2* 1+ U< SWAP 0< OR - ;
3111 | : F/ ROT SWAP - 4000 + >R
3112 | 0 ROT ROT 2DUP U<
3113 | IF UM/ R> ZERO
3114 | ELSE >R D2/ FABS R> UM/ R> 1+
3115 | THEN ;
3116 | : ALIGN 20 MIN 0 DO D2/ LOOP ;
3117 | : RALIGN 1- ?DUP IF ALIGN THEN
3118 | 1 0 D+ D2/ ;
3119 | : FSIGN FABS OVER 0< IF >R DNEGATE R>
3120 | 8000 OR THEN ;
3121 | : F+ ROT 2DUP >R >R FABS SWAP FABS -
3122 | DUP IF DUP 0<
3123 | IF ROT SWAP NEGATE
3124 | R> R> SWAP >R >R
3125 | THEN 0 SWAP RALIGN
3126 | THEN SWAP 0 R> R@ XOR 0<
3127 | IF R@ 0< IF 2SWAP THEN D-
3128 | R> FSIGN ROT SWAP NORM
3129 | ELSE D+ IF 1+ 2/ 8000 OR R> 1+
3130 | ELSE R> THEN THEN ;
3131 | : F- FNEGATE F+ ;
3132 | : F< F- 0< SWAP DROP ;
3133 | ( FLOATING POINT INPUT/OUTPUT ) DECIMAL
3134 | CREATE PL 3 , HERE ,001 , , ,010 , ,
3135 | ,100 , , 1,000 , ,
3136 | 10,000 , , 100,000 , ,
3137 | 1,000,000 , , 10,000,000 , ,
3138 | 100,000,000 , , 1,000,000,000 , ,
3139 | : TENS 2* 2* LITERAL + 2@ ; HEX
3140 | : PLACES PL ! ;
3141 | : SHIFTS FABS 4010 - DUP 0< NOT
3142 | ABORT" TOO BIG" NEGATE ;
3143 | : F# >R PL @ TENS DROP UM* R> SHIFTS
3144 | RALIGN PL @ ?DUP IF 0 DO # LOOP
3145 | ". HOLD THEN #S ROT SIGN ;
3146 | : TUCK SWAP OVER ;
3147 | : F. TUCK <# F# #> TYPE SPACE ;
3148 | : DFLOAT 4020 FSIGN NORM ;
3149 | : F DFLOAT POINT TENS DFLOAT F/ ;
3150 | : FCONSTANT F 2CONSTANT ;
3151 | : FLOAT DUP 0< DFLOAT ;
3152 | : -+ DROP SWAP 0< IF NEGATE THEN ;
3153 | : FIX TUCK 0 SWAP SHIFTS RALIGN -+ ;
3154 | : INT TUCK 0 SWAP SHIFTS ALIGN -+ ;
3155 | 1. FCONSTANT ONE DECIMAL
3156 | 34.6680 FCONSTANT X1
3157 | -57828. FCONSTANT X2
3158 | 2001.18 FCONSTANT X3
3159 | 1.4427 FCONSTANT X4
3160 | : EXP 2DUP INT DUP >R FLOAT F-
3161 | F2* X2 2OVER FSQ X3 F+ F/
3162 | 2OVER F2/ F- X1 F+ F/
3163 | ONE F+ FSQ R> + ;
3164 | : FEXP X4 F* EXP ;
3165 | : GET BL WORD DUP 1+ C@ "- = TUCK -
3166 | 0 0 ROT CONVERT DROP -+ ;
3167 | : E F GET >R R@ ABS 13301 4004 */MOD
3168 | >R FLOAT 4004 FLOAT F/ EXP R> +
3169 | R> 0< IF F/ ELSE F* THEN ;
3170 | : E. TUCK FABS 16384 TUCK -
3171 | 4004 13301 */MOD >R
3172 | FLOAT 4004 FLOAT F/ EXP F*
3173 | 2DUP ONE F<
3174 | IF 10 FLOAT F* R> 1- >R THEN
3175 | <# R@ ABS 0 #S R> SIGN 2DROP
3176 | "E HOLD F# #> TYPE SPACE ;
3177 |
--------------------------------------------------------------------------------