Commit: bc537f1f710d466134764828000b7a88aa9fe7e7 - xhilr_calendar (git)

Functions for working with the idealized calendar of Planet Xhilr

Commit MetaInfo

• Revisión: bc537f1f710d466134764828000b7a88aa9fe7e7 (tree)
• Tiempo: 2017-06-13 17:28:36
• Autor: Joel Matthew Rees <joel.rees@gmai...>
• Commiter: Joel Matthew Rees

Log Message

pursuing two separate paths

Cambiar Resumen

• modified: econcalcmonths.fs
• add: econmonths.fs

Diferencia incremental

--- a/econcalcmonths.fs
+++ b/econcalcmonths.fs
@@ -39,7 +39,7 @@
 ( For ancient, especially pre-1983 fig, Forths: )
 ( Do not use these in modern Forths like gforth. )
 : UM* U* ;
-: FM/MOD M/MOD DROP ; ( Cheat! Behavior is not well defined for negative numbers. )
+: FM/MOD M/MOD DROP ; ( Cheat! fm/mod is supposed to be floored, not unsigned. )
 ( This is just renaming in a sloppy fashion, )
 ( to accomodate the difference between ancient fig-Forths and modern Forths. )
 ( Showing it in infix won't help. )

--- /dev/null
+++ b/econmonths.fs
@@ -0,0 +1,363 @@
+(
+// Forth programs for calculating idealized lengths of months
+// relative to skip years
+// for the world of Bobbie, Karel, Dan, and Kristie, 
+//
+// by Joel Matthew Rees, winter/spring 2017.
+// Copyright 2017, Joel Matthew Rees
+//
+// Permission granted to use for personal entertainment only.
+// -- You really shouldn't write programs like this on modern computers.
+//
+// http://joel-rees-economics.blogspot.com/2017/03/soc500-03-08-calendar-math.html
+// http://joel-rees-economics.blogspot.com/2017/03/soc500-03-09-calculating-skip-years.html
+// 
+//  Novel here:
+// http://joel-rees-economics.blogspot.com/2017/01/soc500-00-00-toc.html
+//
+//
+// Save as "econcalcmonth.fs"
+//
+// In gforth and most modern or emulated environments, 
+// just paste it into the terminal of a running Forth session. 
+// 
+// Run it with
+// 7 SHOWMONTHS
+// for seven years, etc.
+)
+
+( Using integer math. )
+( Forth expression syntax is mostly postfix. )
+( Only the definition syntax is prefix or infix. )
+( I've added comments with equivalent infix expressions to help those unfamiliar with Forth. )
+
+
+( Using baroque identifiers for ancient Forths. )
+( fig-Forth used first three character significant symbol tables. )
+
+
+( For ancient, especially pre-1983 fig, Forths: )
+( Do not use these in modern Forths like gforth. )
+: UM* U* ;
+: FM/MOD M/MOD DROP ; ( Cheat! Behavior is not well defined for negative numbers. )
+( This is just renaming in a sloppy fashion, )
+( to accomodate the difference between ancient fig-Forths and modern Forths. )
+( Showing it in infix won't help. )
+: S>D S->D ; ( Old fashioned name for single-to-double. )
+
+( Semi-simulate local variables. )
+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. )
+: LC@ ( index -- sp[ix] ) ( 0 is top. PICK is available on many modern Forths. )
+  1 + CELLWIDTH *  ( Skip over the stack address 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. )
+  SP@ +  ( Assumes push-down stack. )
+  ! ( *** Will fail in MISERABLE ways on push-up stacks! *** )
+;
+
+( Make things easier to read. )
+( Infix will be confusing here, too. )
+
+: PRCH EMIT ;
+
+: COMMA 44 PRCH ;
+: COLON 58 PRCH ;
+: POINT 46 PRCH ;
+: LPAREN 40 PRCH ;
+: RPAREN 41 PRCH ;
+
+( No trailing space. )
+: PSNUM ( number -- )
+ 0 .R ;
+
+
+: NUMERATORS ( count -- )
+DUP 1+ 0 DO 
+   I PSNUM COLON SPACE
+   I 1000 * OVER / PSNUM COMMA ( 1000 times I, divided by count )
+   SPACE LOOP 
+DROP ;
+
+: FRACTIONS ( count -- )
+1 DO 
+   I NUMERATORS CR 
+LOOP ;
+
+
+( Watch limits on 16 bit processors. )
+( Do it in integers! )
+
+7 CONSTANT SCYCLE ( years in short cycle )
+( SCYCLE = 7 )
+
+7 2 * CONSTANT SPMCYC ( short cycles in medium cycle )
+( SPMCYC = 7 × 2 )
+ 
+SCYCLE SPMCYC * CONSTANT MCYCLE ( years in medium cycle, should be 98 )
+( MCYCLE = SCYCLE × SPMCYC )
+
+7 7 * CONSTANT SPLCYC ( short cycles in single long cycle )
+( SPLCYC = 7 × 7 )
+
+SCYCLE SPLCYC * CONSTANT LCYCLE ( years in single long cycle, should be 343 )
+( LCYCLE = SCYCLE × SPLCYC )
+
+7 CONSTANT MP2LCYC ( medium cycles in double long cycle )
+( MP2LCYC = 7 )
+( MPLCYC would not be an integer: 3 1/2 )
+
+MCYCLE MP2LCYC * CONSTANT 2LCYCLE ( years in double long cycle, should be 686 )
+( 2LCYCLE = MCYCLE × MP2LCYC )
+
+352 CONSTANT DPSKIPYEAR ( floor of days per year  )
+
+
+5 CONSTANT RDSCYCLE ( remainder days in short cycle )
+
+DPSKIPYEAR SCYCLE * RDSCYCLE + CONSTANT DPSCYCLE ( whole days per 7 year cycle )
+( DPSCYCLE = DPSKIPYEAR × SCYCLE + RDSCYCLE )
+( DPMCYCLE and DP2LCYCLE would overflow on 16 bit math CPUs. ) 
+
+RDSCYCLE SPMCYC * 1 - CONSTANT RDMCYCLE ( remainder days in medium cycle )
+( RDMCYCLE = RDSCYCLE × SPMCYC - 1 )
+
+RDMCYCLE MP2LCYC * 2 + CONSTANT RD2LCYCLE ( remainder days in double long cycle -- odd number )
+( RD2LCYCLE = RDMCYCLE × MP2LCYC + 2 )
+( RD2LCYCLE / 2LCYCLE is fractional part of year. )
+( Ergo, length of year is DPSKIPYEAR + RD2LCYCLE / 2LCYCLE, )
+( or 352 485/686 days. )
+
+12 CONSTANT MPYEAR ( months per year )
+
+DPSKIPYEAR MPYEAR /MOD CONSTANT FDMONTH ( floor of days per month )
+( FDMONTH = DPSKIPYEAR / MPYEAR )
+CONSTANT FRMONTH ( floored minimum remainder days per month )
+( FRMONTH = DPSKIPYEAR MOD MPYEAR )
+
+2LCYCLE MPYEAR * CONSTANT MDENOMINATOR ( denominator of month fractional part )
+( MDENOMINATOR = 2LCYCLE × MPYEAR  )
+
+FRMONTH 2LCYCLE * RD2LCYCLE + CONSTANT MNUMERATOR ( numerator of month fractional part )
+( MNUMERATOR  = FRMONTH × 2LCYCLE + RD2LCYCLE )
+( Ergo, length of month is FDMONTH + MNUMERATOR / MDENOMINATOR, )
+( or 29 3229/8232 days. )
+
+MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
+
+( Infix will be confusing below here, as well. )
+( Hopefully, the comments and explanations will provide enough clues. )
+
+( Sum up the days of the months in a year. )
+: SU1MONTH ( startfractional startdays -- endfractional enddays )
+  29 + ( 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
+;
+
+: 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. )
+  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 )
+  CR
+  12 0 DO 
+    3 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 )
+    PRMONTH RPAREN CR
+  LOOP
+;
+
+: SHOWIDEALMONTHS ( years -- )
+  >R
+  0 0 0 0 ( year, daysmemory, fractional, days )
+  R> 0 DO
+    CR
+    SH1IDEALYEAR
+    3 LC@ 1+ 3 LC!
+  LOOP
+  DROP DROP DROP DROP
+;
+
+  0 CONSTANT SKMONTH
+  1 CONSTANT SK1SHORTCYC
+  4 CONSTANT SK2SHORTCYC
+ 48 CONSTANT SKMEDIUMCYC
+186 CONSTANT LPLONGCYC  ( Must be short1 or short2 within the seven year cycle. )
+
+( Since skipyears are the exception, )
+( we test for skipyears instead of leapyears. )
+( 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 =
+  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
+;
+
+
+( At this point, I hit a condundrum. )
+( Modern "standard" Forths want uninitialized variables, )
+( 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 one. )
+( It stays around forever. )
+0 VARIABLE DIMARRAY  ( Days In Months array )
+   30 DIMARRAY !  ( 1st month )
+   29 ,
+   30 ,
+   29 ,
+   29 ,
+   30 ,
+   29 ,
+   30 ,
+   29 ,
+   29 ,
+   30 ,
+   29 ,
+   0 ,
+
+: DIMONTH ( year month -- days )
+  DUP 0 < 0=
+  OVER MPYEAR < AND 0= 
+  IF
+    DROP DROP 0  ( Out of range. No days. )
+  ELSE
+    DUP CELLWIDTH * DIMARRAY + @  ( 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 )
+  CR
+  12 0 DO 
+    3 LC@ PSNUM SPACE ( year )
+    I PSNUM COLON SPACE
+    SU1MONTH  ( ideal month )
+    3 LC@ I DIMONTH  ( real month )
+    DUP PSNUM SPACE ( show days in month )
+    3 LC@ + ( sum of days ) 
+    LPAREN DUP PSNUM COMMA SPACE 
+    2 LC! ( update )
+    PRMONTH RPAREN CR
+  LOOP
+;
+
+: SHOWMONTHS ( years -- )
+  >R
+  0 0 0 0 ( year, daysmemory, fractional, days )
+  R> 0 DO
+    CR
+    SH1YEAR
+    3 LC@ 1+ 3 LC!
+  LOOP
+  DROP DROP DROP DROP
+;
+  
+
+
+( Below here is scratch work I'm leaving for my notes. )
+( It isn't necessary to the above, and can be deleted. )
+
+: V2-SHOWIDEALMONTHS ( years -- )
+  >R
+  0 0 0 ( daysmemory, fractional, days )
+  R> 0 DO
+    CR
+    12 0 DO 
+      J 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 )
+      PRMONTH RPAREN CR
+    LOOP 
+  LOOP
+  DROP DROP DROP 
+;
+
+
+( : ABS  number -- absolute-value *** built in! ***
+DUP 0< IF NEGATE THEN ; )
+
+: WITHIN1 ( n1 n2 -- flag ) 
+ - ABS 1 <= ; ( n1 and n2 are within 1 of each other )
+
+( Negatives end in division by zero or infinite loop. )
+: SQRT ( number -- square-root )
+DUP IF ( square root of zero is zero. )
+  ABS 
+  2 ( initial guess )
+  BEGIN
+    OVER OVER / ( test guess by divide ) 
+    OVER OVER - ABS 1 <= ( number guess quotient flag )
+    IF ( number guess quotient )
+      MIN -1 ( number result flag )
+    ELSE
+      OVER + 2 / ( number guess avg )
+      SWAP OVER ( number avg guess avg )
+      - 1 <= ( number avg flag ) ( Integer average will always be floored. )
+    ENDIF
+  UNTIL ( number result )
+  SWAP DROP
+ENDIF ;
+
+
+353 CONSTANT DPYEAR ( nominal days per year )
+
+7 CONSTANT 7YEARS
+
+2 CONSTANT DS7CYCLE ( days short in seven year cycle )
+
+DPYEAR 7YEARS * DS7CYCLE - CONSTANT DP7YEAR ( whole days per 7 year cycle )
+
+7YEARS 7 2 * * CONSTANT 98YEARS
+
+98YEARS 7YEARS / DS7CYCLE * 1 + CONSTANT DS98CYCLE ( days short in 98 year cycle )
+
+98YEARS 7 * CONSTANT 686YEARS 
+
+686YEARS 98YEARS / DS98CYCLE * 2 - CONSTANT DS686CYCLE ( days short in 686 year cycle )
+
+