Functions for working with the idealized calendar of Planet Xhilr
リビジョン | f01969bb1260db120c0155af7115e7d9519bf43d (tree) |
---|---|
日時 | 2017-06-13 18:11:14 |
作者 | Joel Matthew Rees <joel.rees@gmai...> |
コミッター | Joel Matthew Rees |
refactoring and comments, progress
@@ -70,13 +70,16 @@ | ||
70 | 70 | ( fig-Forth used first three character + length significance in symbol tables. ) |
71 | 71 | |
72 | 72 | |
73 | -( UM*, UM/MOD, S>D, 2DUP, and D- are already there in most modern Forths. ) | |
73 | +( INVERT, UM*, UM/MOD, S>D, 2DUP, and D- are already there in most modern Forths. ) | |
74 | 74 | ( These definitions are only for ancient Forths, without the full set loaded, ) |
75 | 75 | ( especially pre-1983 fig and bif-c. ) |
76 | 76 | ( Un-comment them if you see errors like ) |
77 | 77 | ( UM* ? err # 0 ) |
78 | 78 | ( from PRMONTH or thereabouts. ) |
79 | 79 | |
80 | +( : INVERT NOT ; ( n1 --- n2 : Bit invert is in some ancient Forths as NOT. ) | |
81 | +: INVERT -1 XOR ; ( n1 --- n2 : Bit invert is not found at all in some ancient Forths. ) | |
82 | + | |
80 | 83 | : UM* U* ; ( u u --- ud : modern name for unsigned mixed multiply ) |
81 | 84 | |
82 | 85 | ( So this is just sloppy renaming in a sloppy fashion: ) |
@@ -84,16 +87,25 @@ | ||
84 | 87 | : UM/MOD U/ ; ( uddividend udivisor --- uremainder uquotient : If this doesn't work try M/MOD DROP: ) |
85 | 88 | ( : UM/MOD M/MOD DROP ; ( uddividend udivisor --- uremainder uquotient ) |
86 | 89 | |
90 | + | |
87 | 91 | : S>D S->D ; ( n --- d : Modern name for single-to-double. ) |
88 | 92 | : NEGATE MINUS ; ( n --- -n : Modern name for numeric negation. ) |
89 | 93 | : DNEGATE DMINUS ; ( d --- -d : Modern name for double number negation. ) |
90 | 94 | |
95 | +: DINVERT INVERT SWAP INVERT SWAP ; ( d1 --- d2 : Double bit invert. ) | |
96 | + | |
91 | 97 | : 2DUP OVER OVER ; ( d --- d d : DUPlicate top double cell on stack. ) |
92 | 98 | |
93 | 99 | : 2DROP DROP DROP ; ( d --- : DROP a double, for readability. ) |
94 | 100 | |
95 | 101 | : D- DNEGATE D+ ; ( d1 d2 --- d : Difference of two doubles. ) |
96 | 102 | |
103 | +: M* ( n n --- d : signed mixed multiply ) | |
104 | + 2DUP XOR >R ( The archetypical definition. ) | |
105 | + ABS SWAP ABS UM* | |
106 | + R> 0< IF DNEGATE THEN | |
107 | +; | |
108 | + | |
97 | 109 | : 2SWAP ROT >R ROT R> ; ( d1 d2 --- d2 d1 : Swap top two doubles ) |
98 | 110 | |
99 | 111 | : 2ROT >R >R 2SWAP R> R> 2SWAP ; ( d0 d1 d2 --- d1 d2 d0 ) |
@@ -114,6 +126,10 @@ | ||
114 | 126 | |
115 | 127 | : 4DUP 2OVER 2OVER ; ( q --- q q : DUPlicate the top four cells on stack. ) |
116 | 128 | |
129 | +( : QNEGATE ( q1 --- q2 : Negate top quadruple word. ) | |
130 | +( >R 0. R> 0 d- >r four times, or is it three with double at end? ) | |
131 | + | |
132 | + | |
117 | 133 | : DMAX ( d1 d2 --- d : Leave larger of top two. ) |
118 | 134 | 4DUP D< IF 2SWAP 2DROP ELSE 2DROP THEN ; |
119 | 135 |
@@ -404,10 +420,10 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS | ||
404 | 420 | |
405 | 421 | ( No trailing space. ) |
406 | 422 | : PSNUM ( number -- ) |
407 | - 0 .R ; | |
423 | + 0 .R ; | |
408 | 424 | |
409 | 425 | : PSDNUM ( number -- ) |
410 | - 0 D.R ; | |
426 | + 0 D.R ; | |
411 | 427 | |
412 | 428 | ( Do it in integers! ) |
413 | 429 |
@@ -520,7 +536,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE | ||
520 | 536 | |
521 | 537 | : SH1IDEALYEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays ) |
522 | 538 | CR |
523 | - 12 0 DO | |
539 | + MPYEAR 0 DO | |
524 | 540 | 5 LC@ PSNUM SPACE ( year ) |
525 | 541 | I PSNUM COLON SPACE |
526 | 542 | SU1MONTH |
@@ -572,15 +588,16 @@ LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2 | ||
572 | 588 | |
573 | 589 | |
574 | 590 | ( At this point, I hit a condundrum. ) |
575 | -( Modern "standard" Forths want uninitialized variables, ) | |
591 | +( Modern "standard" Forths want variables without initial values, ) | |
576 | 592 | ( but ancient, especially fig-Forths want initialized variables. ) |
577 | 593 | ( The lower-level <BUILDS DOES> for fig is only partially part of the modern standard. ) |
578 | 594 | ( And CREATE is initialized as a CONSTANT in the fig-Forth, ) |
579 | 595 | ( but has no initial characteristic code or value in modern standards. ) |
580 | 596 | ( So. ) |
581 | -( On ancient Forths, VARIABLE wants an initial value. We give it a zero. ) | |
582 | -( Modern Forths initialize to 0, will leave the 0 given here on the stack. ) | |
583 | -( The zero stays around forever on modern Forths, or until you drop it. ) | |
597 | +( I can't fix this easily. ) | |
598 | +( We give the ancient Forths a zero. ) | |
599 | +( Modern Forths will leave the 0 given here on the stack. ) | |
600 | +( Then the zero stays around forever on modern Forths, or until you drop it. ) | |
584 | 601 | 0 VARIABLE DIMARRAY ( Days In Months array ) |
585 | 602 | |
586 | 603 | CELLWIDTH NEGATE ALLOT ( Back up to store values. ) |
@@ -602,10 +619,10 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. ) | ||
602 | 619 | ( Accept one year year plus or minus, to help calendar on first and last month. ) |
603 | 620 | : DIMONTH ( year month -- days ) |
604 | 621 | DUP 0< IF |
605 | - SWAP 1 - SWAP 12 + | |
622 | + SWAP 1 - SWAP MPYEAR + | |
606 | 623 | ELSE |
607 | 624 | DUP MPYEAR < 0= IF |
608 | - SWAP 1 + SWAP 12 - | |
625 | + SWAP 1 + SWAP MPYEAR - | |
609 | 626 | THEN |
610 | 627 | THEN |
611 | 628 | DUP 0 < 0= |
@@ -622,7 +639,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. ) | ||
622 | 639 | |
623 | 640 | : SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays ) |
624 | 641 | CR |
625 | - 12 0 DO | |
642 | + MPYEAR 0 DO | |
626 | 643 | 5 LC@ PSNUM SPACE ( year ) |
627 | 644 | I PSNUM COLON SPACE |
628 | 645 | SU1MONTH ( ideal month ) |
@@ -712,7 +729,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. ) | ||
712 | 729 | D+ |
713 | 730 | ; |
714 | 731 | |
715 | -( Saturates on month > 12. Generally use to month 11. ) | |
732 | +( Saturates on month > MPYEAR. Generally use to month MPYEAR - 1. ) | |
716 | 733 | : DTM ( uyear umonth --- days ) ( Just the days from the beginning of the year. ) |
717 | 734 | DUP IF |
718 | 735 | 0 SWAP 0 DO |
@@ -723,20 +740,23 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. ) | ||
723 | 740 | ; |
724 | 741 | |
725 | 742 | |
743 | +( Modern Forths will leave the initialization 0 behind. ) | |
726 | 744 | 0 VARIABLE CALENDAR-WIDTH |
727 | 745 | 80 CALENDAR-WIDTH ! |
728 | 746 | ( But we won't use this because we don't have real strings. ) |
747 | +( Okay, we'll use it anyway. ) | |
729 | 748 | |
730 | -( Modern Forths initialize to 0, will leave the 0 given here on the stack. ) | |
749 | +( Modern Forths will leave the initialization 0 behind. ) | |
731 | 750 | 0 VARIABLE DAYCOUNT |
732 | 751 | 0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. ) |
733 | 752 | |
734 | 753 | |
754 | +( Modern Forths will leave the initialization 0 behind. ) | |
735 | 755 | 0 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. ) |
736 | 756 | 0 VARIABLE 1STDAYOFWEEK ( Weekday corresponding to first day of week. ) |
737 | 757 | 0 1STDAYOFWEEK ! |
738 | 758 | |
739 | -( Modern Forths initialize to 0, will leave the 0 given here on the stack. ) | |
759 | +( Modern Forths will leave the initialization 0 behind. ) | |
740 | 760 | 0 VARIABLE DOWKSTATE ( Current day of week. ) |
741 | 761 | |
742 | 762 | 7 CONSTANT DPWK ( Days per week. ) |
@@ -753,15 +773,16 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 ) | ||
753 | 773 | ( Fake DCONSTANT: ) |
754 | 774 | : SMPERIOD10976 [ SMPERIODINT DECYCLE UM* SMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ; |
755 | 775 | ( 28 9645 / 10976 == 316973 / 10976 ) |
776 | +: SM16THPERIOD10976 SMPERIOD10976 JM/MOD ROT DROP | |
756 | 777 | |
757 | 778 | |
758 | 779 | 0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. ) |
759 | 780 | 0 CONSTANT SMOFFFRAC10976 ( Fractional part. ) |
760 | 781 | |
761 | -( Modern Forths initialize to 0, will leave the 0 given here on the stack. ) | |
782 | +( Modern Forths will leave the initialization 0 behind. ) | |
762 | 783 | 0 VARIABLE SMSTATEINT ( Slow moon state integer part. ) |
763 | 784 | 0 SMSTATEINT ! 0 , ( Initialize cleared, make double variable. ) |
764 | -( Modern Forths initialize to 0, will leave the 0 given here on the stack. ) | |
785 | +( Modern Forths will leave the initialization 0 behind. ) | |
765 | 786 | 0 VARIABLE SMSTATEFRAC10976 ( Fractional part. ) |
766 | 787 | 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. ) |
767 | 788 |
@@ -777,23 +798,83 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 ) | ||
777 | 798 | 0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. ) |
778 | 799 | 0 CONSTANT FMOFFFRAC10976 ( Fractional part. ) |
779 | 800 | |
780 | -( Modern Forths initialize to 0, will leave the 0 given here on the stack. ) | |
801 | +( Modern Forths will leave the initialization 0 behind. ) | |
781 | 802 | 0 VARIABLE FMSTATEINT ( Fast moon state integer part. ) |
782 | 803 | 0 FMSTATEINT ! 0 , ( Initialize cleared, make double variable. ) |
783 | -( Modern Forths initialize to 0, will leave the 0 given here on the stack. ) | |
804 | +( Modern Forths will leave the initialization 0 behind. ) | |
784 | 805 | 0 VARIABLE FMSTATEFRAC10976 ( Fractional part. ) |
785 | 806 | 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. ) |
786 | 807 | |
808 | +( Modern Forths will leave the initialization 0 behind. ) | |
809 | +0 VARIABLE CYEAR 0 CYEAR ! | |
810 | +( Modern Forths will leave the initialization 0 behind. ) | |
811 | +0 VARIABLE CMONTH 0 CMONTH ! | |
812 | +( Modern Forths will leave the initialization 0 behind. ) | |
813 | +0 VARIABLE CDATE 0 CDATE ! | |
787 | 814 | |
788 | 815 | ( Start the weekday counter for the year and month, remember the days. ) |
816 | +( Intended to be called from STYCYCLES. Other use will leave things out of sync. ) | |
789 | 817 | : WKSTCYCLES ( uyear umonth --- ) |
818 | + 2DUP | |
819 | + CMONTH ! | |
820 | + CYEAR ! | |
821 | + 0 CDATE ! | |
790 | 822 | OVER DTY |
791 | 823 | 2SWAP DTM 0 D+ |
792 | 824 | 2DUP DAYCOUNT D! |
793 | 825 | WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE ! |
794 | 826 | ; |
795 | 827 | |
828 | +( Leaves things out of sync if not called by DADJUST. ) | |
829 | +: BKMONTH ( --- ) | |
830 | + CMONTH @ 1 - DUP 0< IF | |
831 | + CYEAR @ 1 - CYEAR ! | |
832 | + MPYEAR + | |
833 | + THEN | |
834 | + CMONTH ! | |
835 | +; | |
836 | + | |
837 | +( Leaves things out of sync if not called by DADJUST. ) | |
838 | +: UPMONTH ( --- ) | |
839 | + CMONTH @ 1+ | |
840 | + DUP MPYEAR < 0= IF | |
841 | + MPYEAR - | |
842 | + THEN | |
843 | + CMONTH ! | |
844 | +; | |
845 | + | |
846 | +( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. ) | |
847 | +( Negative days will have previous month's DIMONTH as limit. ) | |
848 | +( Leaves things out of sync if not called by DADJUST. ) | |
849 | +: DTADJUST ( days --- ) | |
850 | + CDATE @ + | |
851 | + DUP 0< IF | |
852 | + BKMONTH ( Previous month's DIMONTH. ) | |
853 | + CYEAR @ CMONTH @ DIMONTH + | |
854 | + ELSE | |
855 | + CYEAR @ CMONTH @ DIMONTH 2DUP < 0= IF | |
856 | + - | |
857 | + UPMONTH | |
858 | + ELSE | |
859 | + DROP | |
860 | + THEN | |
861 | + THEN | |
862 | + CDATE ! | |
863 | +; | |
864 | + | |
865 | +( Leaves things out of sync if not called by DADJUST. ) | |
866 | +: WDADJUST ( days --- ) ( Adjust the day of the week. ) | |
867 | + DOWKSTATE @ + | |
868 | + DUP 0< IF | |
869 | + NEGATE DPWK MOD DPWK SWAP - | |
870 | + ELSE | |
871 | + DPWK MOD | |
872 | + THEN | |
873 | + DOWKSTATE ! | |
874 | +; | |
875 | + | |
796 | 876 | ( Start the slowmoon cycle counter by the day count. ) |
877 | +( Intended to be called from STYCYCLES. Other use will leave things out of sync. ) | |
797 | 878 | : SLOMSTCYCLES ( ddays --- ) |
798 | 879 | DECYCLE S>D UMD* SMPERIOD10976 SLOW-UMD/MOD |
799 | 880 | 2SWAP SMOFFFRAC10976 S>D D+ |
@@ -804,7 +885,24 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 ) | ||
804 | 885 | SMOFFINT S>D D+ SMSTATEINT D! |
805 | 886 | ; |
806 | 887 | |
888 | +( Add signed days to slow month state. days must be less than period. ) | |
889 | +: SLOMADJ ( days --- ) | |
890 | + DECYCLE M* | |
891 | + SMSTATEFRAC10976 D@ D+ | |
892 | + 2DUP D0< IF | |
893 | + SMSTATEINT D@ 1. D- SMSTATEINT D! | |
894 | + SMPERIOD10976 D+ | |
895 | + ELSE | |
896 | + 2DUP SMPERIOD10976 D< 0= IF | |
897 | + SMSTATEINT D@ 1. D+ SMSTATEINT D! | |
898 | + SMPERIOD10976 D- | |
899 | + THEN | |
900 | + THEN | |
901 | + SMSTATEFRAC10976 D! | |
902 | +; | |
903 | + | |
807 | 904 | ( Start the fastmoon cycle counter by the day count. ) |
905 | +( Intended to be called from STYCYCLES. Other use will leave things out of sync. ) | |
808 | 906 | : FASMSTCYCLES ( ddays --- ) |
809 | 907 | DECYCLE S>D UMD* FMPERIOD10976 SLOW-UMD/MOD |
810 | 908 | 2SWAP FMOFFFRAC10976 S>D D+ |
@@ -815,6 +913,23 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 ) | ||
815 | 913 | FMOFFINT S>D D+ FMSTATEINT D! |
816 | 914 | ; |
817 | 915 | |
916 | +( Add signed days to fast month state. days must be less than period. ) | |
917 | +: FASMADJ ( days --- ) | |
918 | + DECYCLE M* | |
919 | + FMSTATEFRAC10976 D@ D+ | |
920 | + 2DUP D0< IF | |
921 | + FMSTATEINT D@ 1. D- FMSTATEINT D! | |
922 | + FMPERIOD10976 D+ | |
923 | + ELSE | |
924 | + 2DUP FMPERIOD10976 D< 0= IF | |
925 | + FMSTATEINT D@ 1. D+ FMSTATEINT D! | |
926 | + FMPERIOD10976 D- | |
927 | + THEN | |
928 | + THEN | |
929 | + FMSTATEFRAC10976 D! | |
930 | +; | |
931 | + | |
932 | +( Call from here to keep things in sync! ) | |
818 | 933 | : STYCYCLES ( year month --- ) ( Start the counters for the year. ) |
819 | 934 | WKSTCYCLES |
820 | 935 | DAYCOUNT D@ 2DUP SLOMSTCYCLES FASMSTCYCLES |
@@ -823,6 +938,21 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 ) | ||
823 | 938 | ( : TEST STYCYCLES DAYCOUNT D@ D. CR SMSTATEINT D@ D. CR SMSTATEFRAC10976 D@ D. CR ) |
824 | 939 | ( FMSTATEINT D@ D. CR FMSTATEFRAC10976 D@ D. CR ; ) |
825 | 940 | |
941 | +( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. ) | |
942 | +( Negative days will have previous month's DIMONTH as limit. ) | |
943 | +( Call from here to keep DAYCOUNT, DOWKSTATE, CYEAR, CMONTH, and CDATE in sync. ) | |
944 | +: DADJUST ( days --- ) | |
945 | + DUP S>D DAYCOUNT D@ D+ DAYCOUNT D! | |
946 | + DUP WDADJUST DTADJUST | |
947 | +; | |
948 | + | |
949 | +( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. ) | |
950 | +( Negative days will have previous month's DIMONTH as limit. ) | |
951 | +( Call from here to keep moon phases also in sync. ) | |
952 | +: DMADJUST ( days --- ) | |
953 | + DUP DADJUST DUP SLOMADJ FASMADJ | |
954 | +; | |
955 | + | |
826 | 956 | |
827 | 957 | ( Ancient Forths do not have standard WORDs, ) |
828 | 958 | ( and that makes it hard to have portable arrays of strings for those Forths. ) |
@@ -957,19 +1087,21 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD | ||
957 | 1087 | PWKDAYS |
958 | 1088 | HLINE |
959 | 1089 | SPLINE |
960 | - ROT ROT ( Save day away. ) | |
1090 | + ROT ROT ( Save calendar day away. ) | |
961 | 1091 | 2DUP STYCYCLES |
962 | 1092 | DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN |
963 | - DUP ( Save back up count. ) | |
1093 | + DUP ( Count of days to back up. ) | |
964 | 1094 | IF |
965 | - back up phases of moons to beginning of week | |
966 | - >R 1 - DIMONTH ( Of previous month. ) | |
967 | - DUP R> - ( day rollover start ) | |
1095 | + DUP NEGATE DUP SLOMADJ FASMADJ | |
1096 | + >R 2DUP 1 - DIMONTH ( day year month rollover ) | |
1097 | + 3 LC@ SWAP ( day year month day rollover ) | |
1098 | + DUP R> - ( day year month day rollover start ) | |
968 | 1099 | DAYLINE |
969 | 1100 | print phases of moons |
970 | 1101 | add dPWK to start |
971 | 1102 | calculate rolloever of current month. |
972 | 1103 | ELSE |
1104 | + | |
973 | 1105 | drop DIMONTH ( Of current month. ) |
974 | 1106 | set start to zero |
975 | 1107 | THEN |
@@ -983,7 +1115,7 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD | ||
983 | 1115 | |
984 | 1116 | |
985 | 1117 | |
986 | -( Lots -- 7? -- of 0s left behind on modern Forths. ) | |
1118 | +( Lots -- 10? -- of 0s left behind on modern Forths. ) | |
987 | 1119 | |
988 | 1120 | |
989 | 1121 |