• R/O
  • HTTP
  • SSH
  • HTTPS

Commit

Tags
No Tags

Frequently used words (click to add to your profile)

javac++androidcocoaobjective-cc#誰得gamephpbathyscapheqtrubyclinuxomegat翻訳pythontwitterwindowsbtronvb.nettestframeworkgui計画中(planning stage)directxpreviewerpukiwikidommruby

Functions for working with the idealized calendar of Planet Xhilr


Commit MetaInfo

Revisionf01969bb1260db120c0155af7115e7d9519bf43d (tree)
Time2017-06-13 18:11:14
AuthorJoel Matthew Rees <joel.rees@gmai...>
CommiterJoel Matthew Rees

Log Message

refactoring and comments, progress

Change Summary

Incremental Difference

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -70,13 +70,16 @@
7070 ( fig-Forth used first three character + length significance in symbol tables. )
7171
7272
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. )
7474 ( These definitions are only for ancient Forths, without the full set loaded, )
7575 ( especially pre-1983 fig and bif-c. )
7676 ( Un-comment them if you see errors like )
7777 ( UM* ? err # 0 )
7878 ( from PRMONTH or thereabouts. )
7979
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+
8083 : UM* U* ; ( u u --- ud : modern name for unsigned mixed multiply )
8184
8285 ( So this is just sloppy renaming in a sloppy fashion: )
@@ -84,16 +87,25 @@
8487 : UM/MOD U/ ; ( uddividend udivisor --- uremainder uquotient : If this doesn't work try M/MOD DROP: )
8588 ( : UM/MOD M/MOD DROP ; ( uddividend udivisor --- uremainder uquotient )
8689
90+
8791 : S>D S->D ; ( n --- d : Modern name for single-to-double. )
8892 : NEGATE MINUS ; ( n --- -n : Modern name for numeric negation. )
8993 : DNEGATE DMINUS ; ( d --- -d : Modern name for double number negation. )
9094
95+: DINVERT INVERT SWAP INVERT SWAP ; ( d1 --- d2 : Double bit invert. )
96+
9197 : 2DUP OVER OVER ; ( d --- d d : DUPlicate top double cell on stack. )
9298
9399 : 2DROP DROP DROP ; ( d --- : DROP a double, for readability. )
94100
95101 : D- DNEGATE D+ ; ( d1 d2 --- d : Difference of two doubles. )
96102
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+
97109 : 2SWAP ROT >R ROT R> ; ( d1 d2 --- d2 d1 : Swap top two doubles )
98110
99111 : 2ROT >R >R 2SWAP R> R> 2SWAP ; ( d0 d1 d2 --- d1 d2 d0 )
@@ -114,6 +126,10 @@
114126
115127 : 4DUP 2OVER 2OVER ; ( q --- q q : DUPlicate the top four cells on stack. )
116128
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+
117133 : DMAX ( d1 d2 --- d : Leave larger of top two. )
118134 4DUP D< IF 2SWAP 2DROP ELSE 2DROP THEN ;
119135
@@ -404,10 +420,10 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
404420
405421 ( No trailing space. )
406422 : PSNUM ( number -- )
407- 0 .R ;
423+ 0 .R ;
408424
409425 : PSDNUM ( number -- )
410- 0 D.R ;
426+ 0 D.R ;
411427
412428 ( Do it in integers! )
413429
@@ -520,7 +536,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
520536
521537 : SH1IDEALYEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
522538 CR
523- 12 0 DO
539+ MPYEAR 0 DO
524540 5 LC@ PSNUM SPACE ( year )
525541 I PSNUM COLON SPACE
526542 SU1MONTH
@@ -572,15 +588,16 @@ LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2
572588
573589
574590 ( At this point, I hit a condundrum. )
575-( Modern "standard" Forths want uninitialized variables, )
591+( Modern "standard" Forths want variables without initial values, )
576592 ( but ancient, especially fig-Forths want initialized variables. )
577593 ( The lower-level <BUILDS DOES> for fig is only partially part of the modern standard. )
578594 ( And CREATE is initialized as a CONSTANT in the fig-Forth, )
579595 ( but has no initial characteristic code or value in modern standards. )
580596 ( 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. )
584601 0 VARIABLE DIMARRAY ( Days In Months array )
585602
586603 CELLWIDTH NEGATE ALLOT ( Back up to store values. )
@@ -602,10 +619,10 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
602619 ( Accept one year year plus or minus, to help calendar on first and last month. )
603620 : DIMONTH ( year month -- days )
604621 DUP 0< IF
605- SWAP 1 - SWAP 12 +
622+ SWAP 1 - SWAP MPYEAR +
606623 ELSE
607624 DUP MPYEAR < 0= IF
608- SWAP 1 + SWAP 12 -
625+ SWAP 1 + SWAP MPYEAR -
609626 THEN
610627 THEN
611628 DUP 0 < 0=
@@ -622,7 +639,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
622639
623640 : SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
624641 CR
625- 12 0 DO
642+ MPYEAR 0 DO
626643 5 LC@ PSNUM SPACE ( year )
627644 I PSNUM COLON SPACE
628645 SU1MONTH ( ideal month )
@@ -712,7 +729,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
712729 D+
713730 ;
714731
715-( Saturates on month > 12. Generally use to month 11. )
732+( Saturates on month > MPYEAR. Generally use to month MPYEAR - 1. )
716733 : DTM ( uyear umonth --- days ) ( Just the days from the beginning of the year. )
717734 DUP IF
718735 0 SWAP 0 DO
@@ -723,20 +740,23 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
723740 ;
724741
725742
743+( Modern Forths will leave the initialization 0 behind. )
726744 0 VARIABLE CALENDAR-WIDTH
727745 80 CALENDAR-WIDTH !
728746 ( But we won't use this because we don't have real strings. )
747+( Okay, we'll use it anyway. )
729748
730-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
749+( Modern Forths will leave the initialization 0 behind. )
731750 0 VARIABLE DAYCOUNT
732751 0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. )
733752
734753
754+( Modern Forths will leave the initialization 0 behind. )
735755 0 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. )
736756 0 VARIABLE 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
737757 0 1STDAYOFWEEK !
738758
739-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
759+( Modern Forths will leave the initialization 0 behind. )
740760 0 VARIABLE DOWKSTATE ( Current day of week. )
741761
742762 7 CONSTANT DPWK ( Days per week. )
@@ -753,15 +773,16 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
753773 ( Fake DCONSTANT: )
754774 : SMPERIOD10976 [ SMPERIODINT DECYCLE UM* SMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ;
755775 ( 28 9645 / 10976 == 316973 / 10976 )
776+: SM16THPERIOD10976 SMPERIOD10976 JM/MOD ROT DROP
756777
757778
758779 0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
759780 0 CONSTANT SMOFFFRAC10976 ( Fractional part. )
760781
761-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
782+( Modern Forths will leave the initialization 0 behind. )
762783 0 VARIABLE SMSTATEINT ( Slow moon state integer part. )
763784 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. )
765786 0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
766787 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
767788
@@ -777,23 +798,83 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
777798 0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. )
778799 0 CONSTANT FMOFFFRAC10976 ( Fractional part. )
779800
780-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
801+( Modern Forths will leave the initialization 0 behind. )
781802 0 VARIABLE FMSTATEINT ( Fast moon state integer part. )
782803 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. )
784805 0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
785806 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
786807
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 !
787814
788815 ( 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. )
789817 : WKSTCYCLES ( uyear umonth --- )
818+ 2DUP
819+ CMONTH !
820+ CYEAR !
821+ 0 CDATE !
790822 OVER DTY
791823 2SWAP DTM 0 D+
792824 2DUP DAYCOUNT D!
793825 WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE !
794826 ;
795827
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+
796876 ( Start the slowmoon cycle counter by the day count. )
877+( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
797878 : SLOMSTCYCLES ( ddays --- )
798879 DECYCLE S>D UMD* SMPERIOD10976 SLOW-UMD/MOD
799880 2SWAP SMOFFFRAC10976 S>D D+
@@ -804,7 +885,24 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
804885 SMOFFINT S>D D+ SMSTATEINT D!
805886 ;
806887
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+
807904 ( Start the fastmoon cycle counter by the day count. )
905+( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
808906 : FASMSTCYCLES ( ddays --- )
809907 DECYCLE S>D UMD* FMPERIOD10976 SLOW-UMD/MOD
810908 2SWAP FMOFFFRAC10976 S>D D+
@@ -815,6 +913,23 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
815913 FMOFFINT S>D D+ FMSTATEINT D!
816914 ;
817915
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! )
818933 : STYCYCLES ( year month --- ) ( Start the counters for the year. )
819934 WKSTCYCLES
820935 DAYCOUNT D@ 2DUP SLOMSTCYCLES FASMSTCYCLES
@@ -823,6 +938,21 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
823938 ( : TEST STYCYCLES DAYCOUNT D@ D. CR SMSTATEINT D@ D. CR SMSTATEFRAC10976 D@ D. CR )
824939 ( FMSTATEINT D@ D. CR FMSTATEFRAC10976 D@ D. CR ; )
825940
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+
826956
827957 ( Ancient Forths do not have standard WORDs, )
828958 ( and that makes it hard to have portable arrays of strings for those Forths. )
@@ -957,19 +1087,21 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
9571087 PWKDAYS
9581088 HLINE
9591089 SPLINE
960- ROT ROT ( Save day away. )
1090+ ROT ROT ( Save calendar day away. )
9611091 2DUP STYCYCLES
9621092 DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
963- DUP ( Save back up count. )
1093+ DUP ( Count of days to back up. )
9641094 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 )
9681099 DAYLINE
9691100 print phases of moons
9701101 add dPWK to start
9711102 calculate rolloever of current month.
9721103 ELSE
1104+
9731105 drop DIMONTH ( Of current month. )
9741106 set start to zero
9751107 THEN
@@ -983,7 +1115,7 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
9831115
9841116
9851117
986-( Lots -- 7? -- of 0s left behind on modern Forths. )
1118+( Lots -- 10? -- of 0s left behind on modern Forths. )
9871119
9881120
9891121