Calendar for Planet Xhilr

Fork

(
// Forth program 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! 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. )

( 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 ;


( 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. )
  0 <# # # # #> ( Formatting puts most significant digits in buffer first. )
  TYPE ( Fake decimal output. )
  DROP SPACE 
;

: SH1YEAR ( 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
;

: 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 can be deleted. )

: V2-SHOWMONTHS ( 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 
;


: 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 ;

( : 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 )