Commit: f01969bb1260db120c0155af7115e7d9519bf43d - xhilr_calendar (git)

Functions for working with the idealized calendar of Planet Xhilr

Commit MetaInfo

• Revision: f01969bb1260db120c0155af7115e7d9519bf43d (tree)
• Zeit: 2017-06-13 18:11:14
• Autor: Joel Matthew Rees <joel.rees@gmai...>
• Commiter: Joel Matthew Rees

Log Message

refactoring and comments, progress

Ändern Zusammenfassung

• modified: econmonths.fs

Diff

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -70,13 +70,16 @@
 ( fig-Forth used first three character + length significance in symbol tables. )
 
 
-( UM*, UM/MOD, S>D, 2DUP, and D- are already there in most modern Forths. )
+( INVERT, UM*, UM/MOD, S>D, 2DUP, and D- are already there in most modern Forths. )
 ( These definitions are only for ancient Forths, without the full set loaded, )
 ( especially pre-1983 fig and bif-c. )
 ( Un-comment them if you see errors like )
 ( UM* ? err # 0 )
 ( from PRMONTH or thereabouts. )
 
+( : INVERT NOT ; ( n1 --- n2 : Bit invert is in some ancient Forths as NOT. )
+: INVERT -1 XOR ; ( n1 --- n2 : Bit invert is not found at all in some ancient Forths. )
+
 : UM* U* ; ( u u --- ud : modern name for unsigned mixed multiply )
 
 ( So this is just sloppy renaming in a sloppy fashion: )
@@ -84,16 +87,25 @@
 : UM/MOD U/ ; ( uddividend udivisor --- uremainder uquotient : If this doesn't work try M/MOD DROP: )
 ( : UM/MOD M/MOD DROP ; ( uddividend udivisor --- uremainder uquotient )
 
+
 : S>D S->D ; ( n --- d : Modern name for single-to-double. )
 : NEGATE MINUS ; ( n --- -n : Modern name for numeric negation. )
 : DNEGATE DMINUS ; ( d --- -d : Modern name for double number negation. )
 
+: DINVERT  INVERT SWAP INVERT SWAP ;   ( d1 --- d2 : Double bit invert. )
+
 : 2DUP  OVER OVER ; ( d --- d d : DUPlicate top double cell on stack. )
 
 : 2DROP DROP DROP ; ( d --- : DROP a double, for readability. )
 
 : D-  DNEGATE D+ ; (  d1 d2 --- d : Difference of two doubles. )
 
+: M* ( n n --- d : signed mixed multiply )
+  2DUP XOR >R   ( The archetypical definition. )
+  ABS SWAP ABS UM* 
+  R> 0< IF DNEGATE THEN
+; 
+
 : 2SWAP ROT >R ROT R> ; ( d1 d2 --- d2 d1 : Swap top two doubles )
 
 : 2ROT >R >R 2SWAP R> R> 2SWAP ; ( d0 d1 d2 --- d1 d2 d0 )
@@ -114,6 +126,10 @@
 
 : 4DUP 2OVER 2OVER ; ( q --- q q : DUPlicate the top four cells on stack. )
 
+( : QNEGATE ( q1 --- q2 : Negate top quadruple word. )
+(  >R 0. R> 0 d- >r four times, or is it three with double at end? )
+  
+
 : DMAX ( d1 d2 --- d : Leave larger of top two. )
   4DUP D< IF 2SWAP 2DROP ELSE 2DROP THEN ;
 
@@ -404,10 +420,10 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
 
 ( No trailing space. )
 : PSNUM ( number -- )
- 0 .R ;
+  0 .R ;
 
 : PSDNUM ( number -- )
- 0 D.R ;
+  0 D.R ;
 
 ( Do it in integers! )
 
@@ -520,7 +536,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
 
 : SH1IDEALYEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
   CR
-  12 0 DO 
+  MPYEAR 0 DO 
     5 LC@ PSNUM SPACE ( year )
     I PSNUM COLON SPACE
     SU1MONTH 
@@ -572,15 +588,16 @@ LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2
 
 
 ( At this point, I hit a condundrum. )
-( Modern "standard" Forths want uninitialized variables, )
+( Modern "standard" Forths want variables without initial values, )
 ( but ancient, especially fig-Forths want initialized variables. )
 ( The lower-level <BUILDS DOES> for fig is only partially part of the modern standard. )
 ( And CREATE is initialized as a CONSTANT in the fig-Forth, )
 ( but has no initial characteristic code or value in modern standards. )
 ( So. )
-( On ancient Forths, VARIABLE wants an initial value. We give it a zero. )
-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
-( The zero stays around forever on modern Forths, or until you drop it. )
+( I can't fix this easily. )
+( We give the ancient Forths a zero. )
+( Modern Forths will leave the 0 given here on the stack. )
+( Then the zero stays around forever on modern Forths, or until you drop it. )
 0 VARIABLE DIMARRAY  ( Days In Months array )
 
 CELLWIDTH NEGATE ALLOT ( Back up to store values. )
@@ -602,10 +619,10 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 ( Accept one year year plus or minus, to help calendar on first and last month. )
 : DIMONTH ( year month -- days )
   DUP 0< IF
-    SWAP 1 - SWAP 12 + 
+    SWAP 1 - SWAP MPYEAR + 
   ELSE
     DUP MPYEAR < 0= IF
-      SWAP 1 + SWAP 12 -
+      SWAP 1 + SWAP MPYEAR -
     THEN
   THEN
   DUP 0 < 0=
@@ -622,7 +639,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
     
 : SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
   CR
-  12 0 DO 
+  MPYEAR 0 DO 
     5 LC@ PSNUM SPACE ( year )
     I PSNUM COLON SPACE
     SU1MONTH  ( ideal month )
@@ -712,7 +729,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
   D+
 ; 
 
-( Saturates on month > 12. Generally use to month 11. )
+( Saturates on month > MPYEAR. Generally use to month MPYEAR - 1. )
 : DTM ( uyear umonth --- days ) ( Just the days from the beginning of the year. )
   DUP IF
     0 SWAP 0 DO
@@ -723,20 +740,23 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 ;
 
 
+( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE CALENDAR-WIDTH
 80  CALENDAR-WIDTH !
 ( But we won't use this because we don't have real strings. )
+( Okay, we'll use it anyway. )
 
-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE DAYCOUNT
 0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. )
 
 
+( Modern Forths will leave the initialization 0 behind. )
 0 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. )
 0 VARIABLE 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
 0 1STDAYOFWEEK !
 
-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE DOWKSTATE ( Current day of week. )
 
 7 CONSTANT DPWK ( Days per week. )
@@ -753,15 +773,16 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 ( Fake DCONSTANT: )
 : SMPERIOD10976 [ SMPERIODINT DECYCLE UM* SMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ; 
 ( 28 9645 / 10976 == 316973 / 10976 )
+: SM16THPERIOD10976 SMPERIOD10976 JM/MOD ROT DROP 
 
 
 0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
 0 CONSTANT SMOFFFRAC10976 ( Fractional part. )
 
-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE SMSTATEINT ( Slow moon state integer part. )
 0 SMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
 
@@ -777,23 +798,83 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. )
 0 CONSTANT FMOFFFRAC10976 ( Fractional part. )
 
-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE FMSTATEINT ( Fast moon state integer part. )
 0 FMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
-( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
 
+( Modern Forths will leave the initialization 0 behind. )
+0 VARIABLE CYEAR 0 CYEAR !
+( Modern Forths will leave the initialization 0 behind. )
+0 VARIABLE CMONTH 0 CMONTH !
+( Modern Forths will leave the initialization 0 behind. )
+0 VARIABLE CDATE 0 CDATE !
 
 ( Start the weekday counter for the year and month, remember the days. )
+( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
 : WKSTCYCLES ( uyear umonth --- ) 
+  2DUP
+  CMONTH !
+  CYEAR !
+  0 CDATE !
   OVER DTY 
   2SWAP DTM 0 D+
   2DUP DAYCOUNT D!
   WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE !
 ;
 
+( Leaves things out of sync if not called by DADJUST. )
+: BKMONTH ( --- )
+  CMONTH @ 1 - DUP 0< IF
+    CYEAR @ 1 - CYEAR !
+    MPYEAR +
+  THEN
+  CMONTH !
+;
+
+( Leaves things out of sync if not called by DADJUST. )
+: UPMONTH ( --- )
+  CMONTH @ 1+ 
+  DUP MPYEAR < 0= IF
+    MPYEAR -
+  THEN
+  CMONTH !
+;
+
+( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
+( Negative days will have previous month's DIMONTH as limit. )
+( Leaves things out of sync if not called by DADJUST. )
+: DTADJUST ( days --- )
+  CDATE @ + 
+  DUP 0< IF
+    BKMONTH ( Previous month's DIMONTH. )
+    CYEAR @ CMONTH @ DIMONTH +
+  ELSE
+    CYEAR @ CMONTH @ DIMONTH 2DUP < 0= IF
+      -
+      UPMONTH
+    ELSE
+      DROP
+    THEN
+  THEN
+  CDATE !
+;
+
+( Leaves things out of sync if not called by DADJUST. )
+: WDADJUST ( days --- )  ( Adjust the day of the week. )
+  DOWKSTATE @ +
+  DUP 0< IF 
+    NEGATE DPWK MOD DPWK SWAP - 
+  ELSE
+    DPWK MOD 
+  THEN
+  DOWKSTATE !
+;
+
 ( Start the slowmoon cycle counter by the day count. )
+( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
 : SLOMSTCYCLES ( ddays --- ) 
   DECYCLE S>D UMD* SMPERIOD10976 SLOW-UMD/MOD 
   2SWAP SMOFFFRAC10976 S>D D+
@@ -804,7 +885,24 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
   SMOFFINT S>D D+ SMSTATEINT D!
 ;
 
+( Add signed days to slow month state. days must be less than period. )
+: SLOMADJ ( days --- )  
+  DECYCLE M* 
+  SMSTATEFRAC10976 D@ D+ 
+  2DUP D0< IF
+    SMSTATEINT D@ 1. D- SMSTATEINT D!
+    SMPERIOD10976 D+ 
+  ELSE
+    2DUP SMPERIOD10976 D< 0= IF
+      SMSTATEINT D@ 1. D+ SMSTATEINT D!
+      SMPERIOD10976 D-
+    THEN
+  THEN 
+  SMSTATEFRAC10976 D!
+;
+
 ( Start the fastmoon cycle counter by the day count. )
+( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
 : FASMSTCYCLES ( ddays --- ) 
   DECYCLE S>D UMD* FMPERIOD10976 SLOW-UMD/MOD 
   2SWAP FMOFFFRAC10976 S>D D+
@@ -815,6 +913,23 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
   FMOFFINT S>D D+ FMSTATEINT D!
 ;
 
+( Add signed days to fast month state. days must be less than period. )
+: FASMADJ ( days --- )  
+  DECYCLE M* 
+  FMSTATEFRAC10976 D@ D+ 
+  2DUP D0< IF
+    FMSTATEINT D@ 1. D- FMSTATEINT D!
+    FMPERIOD10976 D+ 
+  ELSE
+    2DUP FMPERIOD10976 D< 0= IF
+      FMSTATEINT D@ 1. D+ FMSTATEINT D!
+      FMPERIOD10976 D-
+    THEN
+  THEN 
+  FMSTATEFRAC10976 D!
+;
+
+( Call from here to keep things in sync! )
 : STYCYCLES ( year month --- ) ( Start the counters for the year. )
   WKSTCYCLES 
   DAYCOUNT D@ 2DUP SLOMSTCYCLES FASMSTCYCLES
@@ -823,6 +938,21 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 ( : TEST STYCYCLES DAYCOUNT D@ D. CR SMSTATEINT D@ D. CR SMSTATEFRAC10976 D@ D. CR )
 ( FMSTATEINT D@ D. CR FMSTATEFRAC10976 D@ D. CR ; )
 
+( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
+( Negative days will have previous month's DIMONTH as limit. )
+( Call from here to keep DAYCOUNT, DOWKSTATE, CYEAR, CMONTH, and CDATE in sync. )
+: DADJUST ( days --- ) 
+  DUP S>D DAYCOUNT D@ D+ DAYCOUNT D!
+  DUP WDADJUST DTADJUST
+;
+
+( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
+( Negative days will have previous month's DIMONTH as limit. )
+( Call from here to keep moon phases also in sync. )
+: DMADJUST ( days --- )
+  DUP DADJUST DUP SLOMADJ FASMADJ
+;
+
 
 ( Ancient Forths do not have standard WORDs, )
 ( and that makes it hard to have portable arrays of strings for those Forths. )
@@ -957,19 +1087,21 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
   PWKDAYS
   HLINE
   SPLINE
-  ROT ROT   ( Save day away. )
+  ROT ROT   ( Save calendar day away. )
   2DUP STYCYCLES
   DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
-  DUP   ( Save back up count. )
+  DUP   ( Count of days to back up. )
   IF
-    back up phases of moons to beginning of week
-    >R 1 - DIMONTH   ( Of previous month. )
-    DUP R> -   ( day rollover start )
+    DUP NEGATE DUP SLOMADJ FASMADJ
+    >R 2DUP 1 - DIMONTH   ( day year month rollover )
+    3 LC@ SWAP   ( day year month day rollover )
+    DUP R> -   ( day year month day rollover start )
     DAYLINE
     print phases of moons
     add dPWK to start
     calculate rolloever of current month.
   ELSE 
+
     drop DIMONTH   ( Of current month. )
     set start to zero
   THEN
@@ -983,7 +1115,7 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
 
 
 
-( Lots -- 7? -- of 0s left behind on modern Forths. )
+( Lots -- 10? -- of 0s left behind on modern Forths. )