Commit: bc60507b8572deb44261417ef6d3e034619bf296 - xhilr_calendar (git)

Functions for working with the idealized calendar of Planet Xhilr

Commit MetaInfo

• Révision: bc60507b8572deb44261417ef6d3e034619bf296 (tree)
• l'heure: 2017-06-13 17:53:37
• Auteur: Joel Matthew Rees <joel.rees@gmai...>
• Commiter: Joel Matthew Rees

Message de Log

progression

Change Summary

• modified: econmonths.fs

Modification

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -70,21 +70,33 @@
 ( fig-Forth used first three character + length significance in symbol tables. )
 
 
-( UM*, FM/MOD, and S>D are already there in most modern Forths. )
-( These definitions are only for ancient Forths, )
+( UM*, FM/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. )
 
-( : UM* U* ; ) ( modern name for unsigned mixed multiply )
+: UM* U* ; ( modern name for unsigned mixed multiply )
 
 ( This is a cheat! Behavior is not well defined for negative numbers, )
 ( but we don't do negatives here. )
 ( So this is just sloppy renaming in a sloppy fashion: )
-( : FM/MOD M/MOD DROP ; ) ( unsigned division with modulo remainder )
+: FM/MOD M/MOD DROP ; ( unsigned division with modulo remainder )
 
-( : S>D S->D ; ) ( Modern name for single-to-double. )
+: S>D S->D ; ( Modern name for single-to-double. )
+
+: 2DUP  OVER OVER ; ( d --- d d : DUPlicate top double word on stack. )
+
+: 2DROP DROP DROP ; ( d --- : DROP a double, for readability. )
+
+: D-  DMINUS D+ ; (  d1 d2 --- d : Difference of two doubles. )
+( : D-  DNEGATE D+ (  d1 d2 --- d : Difference of two doubles, if no DMINUS. )
+
+( : R@ R ; ( Modern name for copy top of return stack. )
+
+
+( From here, we should load okay in modern Forths. ) 
 
 ( Showing the above in infix won't help. )
 
@@ -92,21 +104,46 @@ SP@ SP@ - ABS CONSTANT CELLWIDTH
 ( Infix won't help here, either, but I can try to explain: )
 ( CELLWIDTH = absolute-value-of difference-between SP-without-pointer and SP-with-pointer.  )
 
+( Infix will be confusing here, too. )
+: D@ ( adr --- d ) ( fetch a double )
+  DUP CELLWIDTH + @ ( LS-CELL )
+  SWAP @ ( MS-CELL )
+;
+
+( Infix will be confusing here, too. )
+: D! ( d adr --- ) ( store a double )
+  SWAP OVER ! ( MS-CELL )
+  CELLWIDTH + ! ( MS-CELL )
+;
+
 ( Semi-simulate local variables with the ability to fetch and store relative to top of stack. )
 
 ( Infix will be confusing here, too. )
 : LC@ ( index -- sp[ix] ) ( 0 is top. PICK is available on many modern Forths. )
-  1 + CELLWIDTH *  ( Skip over the stack address on stack. )
+  1 + CELLWIDTH *  ( Skips over the index on stack. )
   SP@ + @  ( Assumes push-down stack. Will fail on push-up. )
 ;
 
 ( Infix will be confusing here, too. )
 : LC! ( n index -- ) ( 0 is top. Just store. This is not ROLL. )
-  2 + CELLWIDTH *  ( Index and stack address are extra on stack during calculation. )
+  2 + CELLWIDTH *  ( Skips over index and value on stack. )
   SP@ +  ( Assumes push-down stack. )
   ! ( *** Will fail in MISERABLE ways on push-up stacks! *** )
 ;
 
+( Infix will be confusing here, too. )
+: DLC@ ( index -- sp[ix] ) ( 0 is top. PICK is available on many modern Forths. )
+  1 + CELLWIDTH *  ( Skips over the index on stack. )
+  SP@ + D@  ( Assumes push-down stack. Will fail on push-up. )
+;
+
+( Infix will be confusing here, too. )
+: DLC! ( d index -- ) ( 0 is top. Just store. This is not ROLL. )
+  3 + CELLWIDTH *  ( Skips over index and double value on stack. )
+  SP@ +  ( Assumes push-down stack. )
+  D! ( *** Will fail in MISERABLE ways on push-up stacks! *** )
+;
+
 ( Make things easier to read. )
 ( Infix will be confusing here, too. )
 
@@ -122,6 +159,8 @@ SP@ SP@ - ABS CONSTANT CELLWIDTH
 : PSNUM ( number -- )
  0 .R ;
 
+: PSDNUM ( number -- )
+ 0 D.R ;
 
 ( Do it in integers! )
 
@@ -156,12 +195,18 @@ MCYCLE MP2LCYC * CONSTANT 2LCYCLE ( years in double long cycle, should be 686 )
 
 DPSKIPYEAR SCYCLE * RDSCYCLE + CONSTANT DPSCYCLE ( whole days per 7 year cycle )
 ( DPSCYCLE = DPSKIPYEAR × SCYCLE + RDSCYCLE )
-( DPSCYCLE SPMCYC * CONSTANT DPMCYCLE )
+( DPSCYCLE SPMCYC * DCONSTANT DPMCYCLE )
 ( DPMCYCLE = DPSCYCLE × SPMCYC )
-( DPMCYCLE MP2LCYC * CONSTANT DP2LCYCLE )
+( DPMCYCLE MP2LCYC * DCONSTANT DP2LCYCLE )
 ( DP2LCYCLE = DPMCYCLE × MP2LCYC )
-( DPMCYCLE and DP2LCYCLE would overflow on 16 bit math CPUs. ) 
-( No particular problem on 32 bit CPUs.
+( DPMCYCLE and DP2LCYCLE would overflow on 16-bit math CPUs. ) 
+( No particular problem on 32 bit CPUs. Need DCONSTANT for 16-bit CPUs. )
+( But we need the constants more than we need to puzzle out )
+( the differences between CREATE DOES> and <BUILDS DOES>. )
+: DPMCYCLE DPSCYCLE SPMCYC UM* ; ( Takes a little extra time this way. )
+( DPMCYCLE is actually 34566, so the high CELL is 0, )
+( but the low CELL must be treated as unsigned. )
+: DP2LCYCLE DPMCYCLE DROP MP2LCYC UM* ;
 
 RDSCYCLE SPMCYC * 1 - CONSTANT RDMCYCLE ( remainder days in medium cycle )
 ( RDMCYCLE = RDSCYCLE × SPMCYC - 1 )
@@ -193,54 +238,54 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
 ( Hopefully, the comments and explanations will provide enough clues. )
 
 ( Sum up the days of the months in a year. )
-: SU1MONTH ( startfractional startdays -- endfractional enddays )
-  FDMONTH + ( Add the whole part. )
-  SWAP ( Make the fractional part available to work on. )
+: SU1MONTH ( startfractional dstartdays -- endfractional denddays )
+  FDMONTH S>D D+ ( Add the whole part. )
+  ROT ( Make the fractional part available to work on. )
   MNUMERATOR + ( Add the fractional part. )
   DUP MDENOMINATOR < ( Have we got a whole day yet? )
   IF 
-    SWAP ( No, restore stack order for next pass. )
+    ROT ROT ( No, restore stack order for next pass. )
   ELSE
     MDENOMINATOR - ( Take one whole day from the fractional part. )
-    SWAP 1+ ( Restore stack and add the day carried in. )
+    ROT ROT 1 S>D D+ ( Restore stack and add the day carried in. )
   ENDIF
 ;
 
-: PRMONTH ( fractional days -- fractional days )
-  SPACE DUP PSNUM POINT ( whole days )
-  OVER 1000 UM* ( Fake three digits of decimal precision. )
-  MROUNDFUDGE 0 D+ ( Round the bottom digit. )
+: PRMONTH ( fractional ddays -- fractional ddays )
+  SPACE 2DUP PSDNUM POINT ( whole days )
+  2 LC@ 1000 UM* ( Fake three digits of decimal precision. )
+  MROUNDFUDGE S>D D+ ( Round the bottom digit. )
   MDENOMINATOR FM/MOD ( Divide, or evaluate the fraction. )
   S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
   TYPE ( Fake decimal output. )
   DROP SPACE 
 ;
 
-: SH1IDEALYEAR ( year daysmemory fractional days -- year daysmemory fractional days )
+: SH1IDEALYEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
   CR
   12 0 DO 
-    3 LC@ PSNUM SPACE ( year )
+    5 LC@ PSNUM SPACE ( year )
     I PSNUM COLON SPACE
     SU1MONTH 
-    DUP 3 LC@ - ( difference in days )
-    2 LC@ ( ceiling ) IF 1+ ENDIF 
-    DUP PSNUM SPACE ( show theoretical days in month )
-    3 LC@ + ( sum of days ) 
-    LPAREN DUP PSNUM COMMA SPACE 
-    2 LC! ( update )
+    2DUP 5 DLC@ D- ( difference in days )
+    4 LC@ ( push difference to ceiling ) IF 1. D+ ENDIF 
+    2DUP PSDNUM SPACE ( show theoretical days in month )
+    5 DLC@ D+ ( sum of days: adjusted difference plus daysmemory ) 
+    LPAREN 2DUP PSDNUM COMMA SPACE 
+    3 DLC! ( update daysmemory )
     PRMONTH RPAREN CR
   LOOP
 ;
 
 : SHOWIDEALMONTHS ( years -- )
   >R
-  0 0 0 0 ( year, daysmemory, fractional, days )
+  0 0. 0 0. ( year, ddaysmemory, fractional, ddays )
   R> 0 DO
     CR
     SH1IDEALYEAR
-    3 LC@ 1+ 3 LC!
+    5 LC@ 1+ 5 LC!
   LOOP
-  DROP DROP DROP DROP
+  2DROP DROP 2DROP DROP
 ;
 
   0 CONSTANT SKMONTH
@@ -275,19 +320,23 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
 ( On ancient Forths, VARIABLE wants an initial value. We give it a zero. )
 ( The zero stays around forever on modern Forths, or until you drop it. )
 0 VARIABLE DIMARRAY  ( Days In Months array )
-   30 DIMARRAY !  ( 1st month )
-   29 ,
-   30 ,
-   29 ,
-   29 ,
-   30 ,
-   29 ,
-   30 ,
-   29 ,
-   29 ,
-   30 ,
-   29 ,
-   0 ,
+( Modern Forths don't initialize, will leave 0 on stack. )
+
+CELLWIDTH - ALLOT ( Back up to store values. )
+
+30 C, 
+29 C,
+30 C,
+29 C,
+29 C,
+30 C,
+29 C,
+30 C,
+29 C,
+29 C,
+30 C,
+29 C,
+ 0 ,
 
 : DIMONTH ( year month -- days )
   DUP 0 < 0=
@@ -295,14 +344,149 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
   IF
     DROP DROP 0  ( Out of range. No days. )
   ELSE
-    DUP CELLWIDTH * DIMARRAY + @  ( Get the basic days. )
+    DUP DIMARRAY + C@  ( Get the basic days. )
     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 
 ;
     
-: SH1YEAR ( year daysmemory fractional days -- year daysmemory fractional days )
+: SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
+  CR
+  12 0 DO 
+    5 LC@ PSNUM SPACE ( year )
+    I PSNUM COLON SPACE
+    SU1MONTH  ( ideal month )
+    5 LC@ I DIMONTH  ( real month )
+    DUP PSNUM SPACE ( show days in month )
+    S>D 5 DLC@ D+ ( sum of days ) 
+    LPAREN 2DUP PSDNUM COMMA SPACE 
+    3 DLC! ( update )
+    PRMONTH RPAREN CR
+  LOOP
+;
+
+: SHOWMONTHS ( years -- )
+  >R
+  0 0. 0 0. ( year, ddaysmemory, fractional, ddays )
+  R> 0 DO
+    CR
+    SH1YEAR
+    5 LC@ 1+ 5 LC!
+  LOOP
+  2DROP DROP 2DROP DROP
+;
+
+( 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. )
+   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 
+   THEN
+   THEN
+   THEN
+   THEN
+   THEN
+   THEN 
+   DROP ;
+
+: 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. )
+     DUP  1 = IF ."  Deep-winter " ELSE
+     DUP  2 = IF ."    War-time  " ELSE
+     DUP  3 = IF ."   Thaw-time  " ELSE
+     DUP  4 = IF ."    Rebirth   " ELSE
+     DUP  5 = IF ."  Brides-month" ELSE 
+(       ." ???" )
+(     THEN THEN THEN THEN THEN THEN )
+(   ELSE )
+     DUP  6 = IF ."   Imperious  " ELSE
+     DUP  7 = IF ."  Senatorious " ELSE
+     DUP  8 = IF ."  False-summer" ELSE
+     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
+     THEN
+     THEN
+     THEN
+ ( For 0 to 5: )
+     THEN
+     THEN
+     THEN
+     THEN
+     THEN
+     THEN 
+(   THEN )
+   DROP ;
+
+
+
+( Below here is scratch work I'm leaving for my notes. )
+( It can be deleted. )
+
+: oldSU1MONTH ( startfractional startdays -- endfractional enddays )
+  FDMONTH + ( Add the whole part. )
+  SWAP ( Make the fractional part available to work on. )
+  MNUMERATOR + ( Add the fractional part. )
+  DUP MDENOMINATOR < ( Have we got a whole day yet? )
+  IF 
+    SWAP ( No, restore stack order for next pass. )
+  ELSE
+    MDENOMINATOR - ( Take one whole day from the fractional part. )
+    SWAP 1+ ( Restore stack and add the day carried in. )
+  ENDIF
+;
+
+: oldPRMONTH ( fractional days -- fractional days )
+  SPACE DUP PSNUM POINT ( whole days )
+  OVER 1000 UM* ( Fake three digits of decimal precision. )
+  MROUNDFUDGE 0 D+ ( Round the bottom digit. )
+  MDENOMINATOR FM/MOD ( Divide, or evaluate the fraction. )
+  S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
+  TYPE ( Fake decimal output. )
+  DROP SPACE 
+;
+
+: oldSH1IDEALYEAR ( year daysmemory fractional days -- year daysmemory fractional days )
+  CR
+  12 0 DO 
+    3 LC@ PSNUM SPACE ( year )
+    I PSNUM COLON SPACE
+    oldSU1MONTH 
+    DUP 3 LC@ - ( difference in days )
+    2 LC@ ( ceiling ) IF 1+ ENDIF 
+    DUP PSNUM SPACE ( show theoretical days in month )
+    3 LC@ + ( sum of days ) 
+    LPAREN DUP PSNUM COMMA SPACE 
+    2 LC! ( update )
+    oldPRMONTH RPAREN CR
+  LOOP
+;
+
+: oldSHOWIDEALMONTHS ( years -- )
+  >R
+  0 0 0 0 ( year, daysmemory, fractional, days )
+  R> 0 DO
+    CR
+    oldSH1IDEALYEAR
+    3 LC@ 1+ 3 LC!
+  LOOP
+  DROP DROP DROP DROP
+;
+
+: oldSH1YEAR ( year daysmemory fractional days -- year daysmemory fractional days )
   CR
   12 0 DO 
     3 LC@ PSNUM SPACE ( year )
@@ -317,7 +501,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
   LOOP
 ;
 
-: SHOWMONTHS ( years -- )
+: oldSHOWMONTHS ( years -- )
   >R
   0 0 0 0 ( year, daysmemory, fractional, days )
   R> 0 DO
@@ -327,10 +511,6 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
   LOOP
   DROP DROP DROP DROP
 ;
-  
-
-( Below here is scratch work I'm leaving for my notes. )
-( It can be deleted. )
 
 : V2-SHOWMONTHS ( years -- )
   >R