提交: a53e70fcf3522e44c3887eba918e3a7bc62e21b1 - xhilr_calendar (git)

Functions for working with the idealized calendar of Planet Xhilr

Commit MetaInfo

• 修订版: a53e70fcf3522e44c3887eba918e3a7bc62e21b1 (tree)
• 时间: 2017-06-13 18:13:25
• 作者: Joel Matthew Rees <joel.rees@gmai...>
• Commiter: Joel Matthew Rees

Log Message

at this point it more or less runs

更改概述

• modified: econmonths.fs

差异

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -69,6 +69,8 @@
 ( Using baroque identifiers for ancient Forths. )
 ( fig-Forth used first three character + length significance in symbol tables. )
 
+( And I should do this all in hexadecimal, to get a more accurate flavor. )
+
 
 ( 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, )
@@ -417,6 +419,7 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
 : PLUS 43 EMIT ;
 : DASH 45 EMIT ;
 : STAR 42 EMIT ;
+: ZERO 48 EMIT ;
 
 ( No trailing space. )
 : PSNUM ( number -- )
@@ -762,6 +765,12 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 7 CONSTANT DPWK ( Days per week. )
 
 
+16 CONSTANT JIRPERDAY ( About 90 minutes. )
+16 CONSTANT GOBUPERJIR ( About 5.6 minutes. )
+16 CONSTANT BUNEIGHPERGOB ( About 21 seconds. )
+16 CONSTANT MYOTPERBUNEIGH ( About 13 seconds. )
+
+
 ( For the cycles use scaled 485 / 686, keep scale in 16 bits. )
 RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 2LCYCLE 16 * CONSTANT DECYCLE ( denominator: 10976 )
@@ -773,8 +782,6 @@ 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. )
@@ -786,6 +793,19 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
 
+: SM16THPERIOD10976 [ SMPERIOD10976 8. D+ 16 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
+: SM32NDPERIOD10976 [ SMPERIOD10976 16. D+ 32 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
+
+( Could pre-divide the period into 16ths but this is an output function, )
+( can be a little slow. )
+: SMSHOWPHASE ( --- ) ( --- ) ( Show the Slowmoon phase with no spacing. )
+  SMSTATEFRAC10976 D@ SM32NDPERIOD10976 D+ 0. SM16THPERIOD10976 SLOW-UMD/MOD
+  2SWAP 2DROP DROP DUP 16 < 0= IF 16 - THEN
+  ." S:" HEX 0 .R DECIMAL
+;
+
+3 CONSTANT SPHASEWIDTH
+
 
 ( The smaller moon orbits their world in just under seven and one eighth days, )
 ( about forty-nine and a half lunar weeks a year )
@@ -805,6 +825,21 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
 0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
 
+: FM16THPERIOD10976 [ FMPERIOD10976 8. D+ 16 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
+: FM32NDPERIOD10976 [ FMPERIOD10976 16. D+ 32 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
+
+( Could pre-divide the period into 16ths but this is an output function, )
+( can be a little slow. )
+: FMSHOWPHASE ( --- ) ( Show the Fastmoon phase with no spacing. )
+  FMSTATEFRAC10976 D@ FM32NDPERIOD10976 D+ 0. FM16THPERIOD10976 SLOW-UMD/MOD
+  2SWAP 2DROP DROP DUP 16 < 0= IF 16 - THEN
+  JIRPERDAY 1 - SWAP - ( Retrograde. )
+  ." F:" HEX 0 .R DECIMAL
+;
+
+3 CONSTANT FPHASEWIDTH
+
+
 ( Modern Forths will leave the initialization 0 behind. )
 0 VARIABLE CYEAR 0 CYEAR !
 ( Modern Forths will leave the initialization 0 behind. )
@@ -1049,67 +1084,74 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
     I TPWDAY 
     DUP SPACES OVER SPACES
     VBAR
-  LOOP CR
+  LOOP
+  CR
   DROP DROP
 ;
 
-: BOLD ( n1 n2 --- n1 n2 )
-  2DUP = IF STAR ELSE SPACE THEN ;
+: BOLD ( n1 n2 --- )
+  = 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 ] )
+: PDFIELD ( day1 day2 --- ) ( Print day2 in day field with emphasis if same as day1. )
+  DFIELD 4 - 2 /MOD    ( day1 day2 rem half )
+  DUP ROT +   ( day1 day2 half half+rem )
+  SPACES >R   ( day1 day2 ) ( [ half ] )
+  2DUP BOLD DUP 2 .R BOLD   ( --- ) ( [ half ] )
   R> SPACES 
   VBAR
 ;
 
-: DAYLINE ( rollover start today --- ) ( DPWK days from start,  from 0 at rollove )
-  >R   ( rollover start ) ( [ today ] )
+( DPWK days from start, emphasize and reset day if matched for month. )
+: DAYLINE ( month day --- month daydone ) 
   VBAR 
   DPWK 0 DO
-    2DUP > 0= IF DROP 0 THEN   ( rollover day )  ( [ today ] )
-    R> PDFIELD >R
-    1+
+    OVER CMONTH @ = IF DUP ELSE -1 THEN
+    CDATE @ 
+    PDFIELD
+    1 DADJUST
   LOOP
-  R> DROP
-  DROP DROP
+  CR
 ;
 
 
+: PHLINE ( --- )
+  VBAR
+  DPWK 0 DO
+    SMSHOWPHASE
+    DFIELD SPHASEWIDTH - FPHASEWIDTH - SPACES
+    FMSHOWPHASE
+    VBAR
+    1 SLOMADJ 1 FASMADJ
+  LOOP
+  CR
+;
+
 : CALMONTH ( year month day --- )
   CR
+  ROT ROT STYCYCLES
+  CMONTH @ SWAP  ( Remember month and day. )
   WLINELENGTH MWIDTH - 2 - 2 / SPACES 
-  ROT DUP 4 .R SPACE
-  ROT DUP TPMONTH CR
+  CYEAR @ 4 .R SPACE
+  CMONTH @ TPMONTH CR
   HLINE
   PWKDAYS
   HLINE
-  SPLINE
-  ROT ROT   ( Save calendar day away. )
-  2DUP STYCYCLES
   DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
   DUP   ( Count of days to back up. )
   IF
-    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.
+    NEGATE DMADJUST
   ELSE 
-
-    drop DIMONTH   ( Of current month. )
-    set start to zero
+    DROP
   THEN
   BEGIN
-  
-  
-    pass rollover UNTIL
-  
+    SPLINE
+    DAYLINE
+    SPLINE
+    SPLINE
+    PHLINE
+    HLINE
+    OVER CMONTH @ < UNTIL
+  DROP DROP
 ;