Commit: 746c818c56c8880b88dea46b9f10f414d5d2476b - xhilr_calendar (git)

Functions for working with the idealized calendar of Planet Xhilr

Commit MetaInfo

• Révision: 746c818c56c8880b88dea46b9f10f414d5d2476b (tree)
• l'heure: 2017-06-13 18:09:13
• Auteur: Joel Matthew Rees <joel.rees@gmai...>
• Commiter: Joel Matthew Rees

Message de Log

cycles and the digging into the actual calendar

Change Summary

• modified: econmonths.fs

Modification

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -23,17 +23,17 @@
 ( In gforth and most modern or emulated environments, )
 ( just paste it into the terminal of a running Forth session. )
 
-( Run it with 
+( Run it with )
 
- 7 SHOWIDEALMONTHS
+( 7 SHOWIDEALMONTHS )
 
-  for seven years, etc. )
+(  for seven years, etc. )
 
 ( gforth can be found in the repositories at )
 ( <https://www.gnu.org/software/gforth/>. )
 
 ( It can also be obtained as a package from most modern OS distributions )
-( and in many applications stores (Android, yes, iOS, not yet for a while). )
+( and in many applications stores -- Android, yes, iOS, not yet for a while. )
 ( Or, for MSWindows, you can get it through Cygwin: <https://www.cygwin.com/>. )
 
 ( HTML documentation can be found on the web at )
@@ -41,7 +41,7 @@
 ( which includes a tutorial for experienced programmers. )
 
 ( An easier tutorial for Forth can be found at )
-( <https://www.forth.com/starting-forth/>.)
+( <https://www.forth.com/starting-forth/>. )
 
 ( There is a newsgroup: comp.lang.forth, )
 ( which can be accessed from the web via, for example, Google newsgroups. )
@@ -154,19 +154,19 @@ SP@ SP@ - ABS CONSTANT CELLWIDTH
 ;
 
 ( Left shifts can be done with addition. )
-: SUM2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest, not too slow. )
-: SUMD2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
-: SLOWQ2*  ( uq1 --- uq2 : Double the top double cell. Not fastest. )
-  SUMD2* >R OVER 0< IF 
+: SUM-2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest, not too slow. )
+: SUM-D2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
+: SLOW-Q2*  ( uq1 --- uq2 : Double the top double cell. Not fastest. )
+  SUM-D2* >R OVER 0< IF 
     1 OR ( carry )
   THEN
   >R 
-  SUMD2*
+  SUM-D2*
   R> R> ;
 
 : MY-BIT-COUNTER ( --- u ) ( Let's figure out how wide a CELL is. )
   0. 1. BEGIN
-    SUMD2* 2SWAP 1. D+ 2SWAP SP@ @
+    SUM-D2* 2SWAP 1. D+ 2SWAP SP@ @
   UNTIL 2DROP DROP ;
 
 MY-BIT-COUNTER CONSTANT CELLBITS 
@@ -341,12 +341,12 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
 ( Some dividends will overflow quotient, not valid for such cases. )
 ( Intended to be used for known products of two doubles. 
 ( AL AML AMH AH BL BH --- RL RH QL QH : unsigned quad by unsigned double yielding unsigned double )
-: MOLASSES-UMD/MOD ( uqdividend uddivisor --- udremainder udquotient )
+: SLOW-UMD/MOD ( uqdividend uddivisor --- udremainder udquotient )
   DUP 0= IF
     DROP UQS/MOD 2DROP 0 ROT ROT ( Get divisor high word 0 easy case done quickly. )
   ELSE
     2ROT 2ROT ( Get the divisor out of the way, but accessible with pick. )
-    CELLBITS SUM2* 1+ >R   ( Count )
+    CELLBITS SUM-2* 1+ >R   ( Count )
     0 >R   ( Force flag )
     BEGIN ( BL BH AL AML AMH AH ) ( [ count force ] )
       2DUP    ( high double of dividend : BL BH AL AML AMH AH AMH AH )
@@ -361,7 +361,7 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
       ( BL BH AL AML bit ) ( [ count AH AMH ] )
       OVER >R   ( Remember the carry from bottom to top half -- AML. )
       ( BL BH AL AML bit ) ( [ count AH AMH AML ] )
-      >R SUMD2*   ( Save subtraction flag and shift the bottom half: AL AML. )
+      >R SUM-D2*   ( Save subtraction flag and shift the bottom half: AL AML. )
       ( BL BH sAL rsAML ) ( [ count AH AMH AML bit ] )
       SWAP    ( BL BH rsAML sAL ) ( [ count AH AMH AML bit ] )
       R> OR SWAP   ( Record the subtraction in emptied bit of remainder. )
@@ -374,7 +374,7 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
       WHILE   ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount ] )
         DUP 0< >R   ( Remember the high bit of the remainder, to force subtract. )
         ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount newforce ] )
-        SUMD2*   ( BL BH rsAL rsAML carry sAMH rsAH ) ( [ newcount newforce ] )
+        SUM-D2*   ( BL BH rsAL rsAML carry sAMH rsAH ) ( [ newcount newforce ] )
         >R OR R>   ( Shift the remainder, with the bit from the low half. )
         ( BL BH rsAL rsAML rsAMH rsAH ) ( [ newcount newforce ] )
     REPEAT   ( BL BH rsAL rsAML rsAMH rsAH ) ( [ newcount newforce ] )
@@ -386,19 +386,6 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
   THEN
 ; 
 
-( If your 16-bit Forth has UD/MOD, uncomment this and comment out the fake! *********** )
-( : JUD/MOD UD/MOD ; ( uqdividend uddivisor -- udremainder udquotient : If it exists. )
-( If UD/MOD does not exist and we are working on 32 or 64 bit, fake it. )
-( But make it safe! )
-: JUD/MOD ( uqdividend uddivisor -- udremainder udquotien : fake double division )
-  
-  CELLWIDTH 4 < 0= IF 
-    DROP >R 2DROP R> JM/MOD  
-  ELSE ( Things get hairy! )
-    
-  THEN ; 
-( In 32-bit or more, get rid of unneeded stuff and use single division. )
-
 
 ( Make things easier to read. )
 ( Infix will be confusing here, too. )
@@ -410,6 +397,10 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
 : POINT 46 PRCH ;
 : LPAREN 40 PRCH ;
 : RPAREN 41 PRCH ;
+: VBAR 124 EMIT ;
+: PLUS 43 EMIT ;
+: DASH 45 EMIT ;
+: STAR 42 EMIT ;
 
 ( No trailing space. )
 : PSNUM ( number -- )
@@ -514,7 +505,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
   ELSE
     MDENOMINATOR - ( Take one whole day from the fractional part. )
     ROT ROT 1 S>D D+ ( Restore stack and add the day carried in. )
-  ENDIF
+  THEN
 ;
 
 : PRMONTH ( fractional ddays -- fractional ddays )
@@ -534,7 +525,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
     I PSNUM COLON SPACE
     SU1MONTH 
     2DUP 5 DLC@ D- ( difference in days )
-    4 LC@ ( push difference to ceiling ) IF 1. D+ ENDIF 
+    4 LC@ ( push difference to ceiling ) IF 1. D+ THEN 
     2DUP PSDNUM SPACE ( show theoretical days in month )
     5 DLC@ D+ ( sum of days: adjusted difference plus daysmemory ) 
     LPAREN 2DUP PSDNUM COMMA SPACE 
@@ -566,14 +557,17 @@ LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2
 ( Calendar system starts with year 0, not year 1. )
 ( Would need to check and adjust if the calendar started with year )
 : ISKIPYEAR ( year -- flag )
-  DUP MCYCLE MOD SKMEDIUMCYC =
+  DUP 0< IF
+    NEGATE 2LCYCLE MOD 2LCYCLE SWAP -
+  THEN
+    DUP MCYCLE MOD SKMEDIUMCYC =
   IF DROP -1  ( One specified extra skip year in medium cycle. )
   ELSE
     DUP SCYCLE MOD DUP
     SK1SHORTCYC =
     SWAP SK2SHORTCYC = OR  ( Two specified skip years in short cycle, but ... )
     SWAP LCYCLE MOD LPLONGCYC = 0= AND ( not the specified exception in the long cycle. )
-  ENDIF
+  THEN
 ;
 
 
@@ -585,9 +579,9 @@ LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2
 ( 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. )
 0 VARIABLE DIMARRAY  ( Days In Months array )
-( Modern Forths don't initialize, will leave 0 on stack. )
 
 CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 
@@ -605,7 +599,15 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 29 C,
  0 ,
 
+( 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 + 
+  ELSE
+    DUP MPYEAR < 0= IF
+      SWAP 1 + SWAP 12 -
+    THEN
+  THEN
   DUP 0 < 0=
   OVER MPYEAR < AND 0= 
   IF
@@ -615,7 +617,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
     SWAP SKMONTH =  ( true if skip month )
     ROT ISKIPYEAR AND  ( true if skip month of skip year )
     1 AND - ( Subtrahend is 1 only if skip month of skip year. )
-  ENDIF 
+  THEN 
 ;
     
 : SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
@@ -711,7 +713,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 ; 
 
 ( Saturates on month > 12. Generally use to month 11. )
-: DTM ( year month --- days ) ( Just the days from the beginning of the year. )
+: DTM ( uyear umonth --- days ) ( Just the days from the beginning of the year. )
   DUP IF
     0 SWAP 0 DO
       OVER I DIMONTH +
@@ -723,15 +725,19 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 
 0 VARIABLE CALENDAR-WIDTH
 80  CALENDAR-WIDTH !
+( But we won't use this because we don't have real strings. )
 
+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
 0 VARIABLE DAYCOUNT
-0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. Modern Forths leave a zero. )
+0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. )
 
 
 0 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. )
-0 CONSTANT 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
+0 VARIABLE 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
+0 1STDAYOFWEEK !
 
-0 VARIABLE DOWKSTATE ( Current day of week. Modern Forths leave a zero. )
+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+0 VARIABLE DOWKSTATE ( Current day of week. )
 
 7 CONSTANT DPWK ( Days per week. )
 
@@ -752,9 +758,11 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
 0 CONSTANT SMOFFFRAC10976 ( Fractional part. )
 
-0 VARIABLE SMSTATEINT ( Slow moon state integer part. Modern Forths leave a zero. )
+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+0 VARIABLE SMSTATEINT ( Slow moon state integer part. )
 0 SMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
-0 VARIABLE SMSTATEFRAC10976 ( Fractional part. Modern Forths leave a zero. )
+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
 
 
@@ -769,20 +777,25 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. )
 0 CONSTANT FMOFFFRAC10976 ( Fractional part. )
 
-0 VARIABLE FMSTATEINT ( Fast moon state integer part. Modern Forths leave a zero. )
+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+0 VARIABLE FMSTATEINT ( Fast moon state integer part. )
 0 FMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
-0 VARIABLE FMSTATEFRAC10976 ( Fractional part. Modern Forths leave a zero. )
+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
+0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
 
 
-: WSTYCYCLES ( year --- ) ( Start the weekday counter for the year, keep the days. )
-  DTY 2DUP DAYCOUNT D!
+( Start the weekday counter for the year and month, remember the days. )
+: WKSTCYCLES ( uyear umonth --- ) 
+  OVER DTY 
+  2SWAP DTM 0 D+
+  2DUP DAYCOUNT D!
   WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE !
 ;
 
-: SSTYCYCLES ( ddays --- ) ( Start the slowmoon cycle counter for the year. )
-  DECYCLE UDS* DROP SMPERIOD10976 DROP JM/MOD >R >R S>D R> R> ( 32-bit, 64-bit )
-(  DECYCLE S>D UMD* SMPERIOD10976 UD/MOD ( 16-bit )
+( Start the slowmoon cycle counter by the day count. )
+: SLOMSTCYCLES ( ddays --- ) 
+  DECYCLE S>D UMD* SMPERIOD10976 SLOW-UMD/MOD 
   2SWAP SMOFFFRAC10976 S>D D+
   2DUP SMPERIOD10976 D< 0= IF
     SMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
@@ -791,9 +804,9 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
   SMOFFINT S>D D+ SMSTATEINT D!
 ;
 
-: FSTYCYCLES ( ddays --- ) ( Start the fastmoon cycle counter for the year. )
-  DECYCLE UDS* DROP FMPERIOD10976 DROP JM/MOD >R >R S>D R> R> ( 32-bit, 64-bit )
-(  DECYCLE S>D UMD* FMPERIOD10976 UD/MOD ( 16-bit )
+( Start the fastmoon cycle counter by the day count. )
+: FASMSTCYCLES ( ddays --- ) 
+  DECYCLE S>D UMD* FMPERIOD10976 SLOW-UMD/MOD 
   2SWAP FMOFFFRAC10976 S>D D+
   2DUP FMPERIOD10976 D< 0= IF
     FMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
@@ -802,42 +815,26 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
   FMOFFINT S>D D+ FMSTATEINT D!
 ;
 
-: STYCYCLES ( year --- ) ( Start the counters for the year. )
-  WSTYCYCLES 
-  DAYCOUNT D@ 2DUP SSTYCYCLES FSTYCYCLES
+: STYCYCLES ( year month --- ) ( Start the counters for the year. )
+  WKSTCYCLES 
+  DAYCOUNT D@ 2DUP SLOMSTCYCLES FASMSTCYCLES
 ;
 
-: STMCYCLES ( year month --- ) ( The year is started, start the month. )
-  DTM 0 DAYCOUNT D@ D+ 2DUP DAYCOUNT !
-  2DUP DPWK JM/MOD 2DROP DOWKSTATE ! ( Overwrite the state, don't sum it. )
-  
-;   
-
-
-
-: PRMONTH ( year month day --- )
-  >R OVER STYCYCLES
-
-Have to adjust by defined 1st day of week.
-
-
-
-
-( Lots -- 6? -- of 0s left behind on modern Forths. )
+( : TEST STYCYCLES DAYCOUNT D@ D. CR SMSTATEINT D@ D. CR SMSTATEFRAC10976 D@ D. CR )
+( FMSTATEINT D@ D. CR FMSTATEFRAC10976 D@ D. CR ; )
 
 
 ( Ancient Forths do not have standard WORDs, )
 ( and that makes it hard to have portable arrays of strings for those Forths. )
-: TPWDAY ( n --- ) ( TYPE the name of the day of the week. )
+: TPWDAY ( n --- ) ( TYPE the name of the day of the week, modulo. )
+   DPWK MOD
    DUP 0 = IF ."  Sunday " ELSE ( Fake case format to line the strings up. )
    DUP 1 = IF ." Moonsday" ELSE
    DUP 2 = IF ." Aegisday" ELSE
-   DUP 3 = IF ."  Gefnday" ELSE
-   DUP 4 = IF ."  Freyday" ELSE
-   DUP 5 = IF ." Tewesday" ELSE 
-   DUP 6 = IF ."  Vensday" ELSE ( DUP here allows final single DROP. )
-     ."   ???   " 
-   THEN 
+   DUP 3 = IF ." Gefnday " ELSE
+   DUP 4 = IF ." Freyday " ELSE
+   DUP 5 = IF ." Tewesday" ELSE  ( DUP here allows final single DROP. )
+              ." Vensday " 
    THEN
    THEN
    THEN
@@ -846,6 +843,8 @@ Have to adjust by defined 1st day of week.
    THEN 
    DROP ;
 
+8 CONSTANT DWIDTH
+
 : TPMONTH ( n --- ) ( TYPE the name of the month. )
 (   DUP 6 < IF * Use this if the compile stack overflows. )
      DUP  0 = IF ." Time-division" ELSE ( Fake case format to line the strings up. )
@@ -863,7 +862,7 @@ Have to adjust by defined 1st day of week.
      DUP  9 = IF ."    Harvest   " ELSE
      DUP 10 = IF ."   Gratitude  " ELSE
      DUP 11 = IF ."  Winter-month" ELSE ( DUP here allows final single DROP. )
-       ." ???" 
+                 ."      ???     " 
      THEN
      THEN
      THEN
@@ -880,6 +879,112 @@ Have to adjust by defined 1st day of week.
 (   THEN )
    DROP ;
 
+13 CONSTANT MWIDTH
+
+CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
+
+: WLINELENGTH CALENDAR-WIDTH @ DPWK / DPWK * ;
+
+: DASHES ( count --- ) ( EMIT a string of count DASHes. )
+  DUP 0 > IF
+    0 DO DASH LOOP 
+  ELSE
+    DROP
+  THEN
+;
+
+: HLINE ( --- )
+  PLUS 
+  DPWK 0 DO 
+    DFIELD DASHES PLUS
+  LOOP
+  CR
+;
+
+: SPLINE ( --- )
+  VBAR 
+  DPWK 0 DO 
+    DFIELD SPACES VBAR
+  LOOP
+  CR
+;
+
+: PWKDAYS ( --- ) ( Adjust by 1STDAYOFWEEK. )
+  VBAR
+  DFIELD DWIDTH - 1 - 2 /MOD 
+  SWAP OVER + 
+  1STDAYOFWEEK @ DUP DPWK + SWAP 
+  DO
+    DUP SPACES 
+    I TPWDAY 
+    DUP SPACES OVER SPACES
+    VBAR
+  LOOP CR
+  DROP DROP
+;
+
+: BOLD ( n1 n2 --- n1 n2 )
+  2DUP = IF STAR ELSE SPACE THEN ;
+
+: PDFIELD ( day today --- day today ) ( Print one numeric day field, emphasis on today. )
+  DFIELD 4 - 2 /MOD SWAP   ( day today half rem )
+  OVER +   ( day today half rem+half )
+  SPACES >R   ( day today ) ( [ half ] )
+  BOLD OVER 2 .R BOLD   ( day today ) ( [ half ] )
+  R> SPACES 
+  VBAR
+;
+
+: DAYLINE ( rollover start today --- ) ( DPWK days from start,  from 0 at rollove )
+  >R   ( rollover start ) ( [ today ] )
+  VBAR 
+  DPWK 0 DO
+    2DUP > 0= IF DROP 0 THEN   ( rollover day )  ( [ today ] )
+    R> PDFIELD >R
+    1+
+  LOOP
+  R> DROP
+  DROP DROP
+;
+
+
+: CALMONTH ( year month day --- )
+  CR
+  WLINELENGTH MWIDTH - 2 - 2 / SPACES 
+  ROT DUP 4 .R SPACE
+  ROT DUP TPMONTH CR
+  HLINE
+  PWKDAYS
+  HLINE
+  SPLINE
+  ROT ROT   ( Save day away. )
+  2DUP STYCYCLES
+  DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
+  DUP   ( Save back up count. )
+  IF
+    back up phases of moons to beginning of week
+    >R 1 - DIMONTH   ( Of previous month. )
+    DUP R> -   ( 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
+  BEGIN
+  
+  
+    pass rollover UNTIL
+  
+;
+
+
+
+
+( Lots -- 7? -- of 0s left behind on modern Forths. )
+