Calendar for Planet Xhilr

Fork

( Forth code for calculating idealized lengths of months )
( relative to skip years in the world of )
( Bobbie, Karel, Dan, and Kristi, Sociology 500, a Novel. )

( by Ted Turpin, of the Union of Independent States, Xhilr )
( Earth Copyright 2017, Joel Matthew Rees )

( Permission granted to use for personal entertainment only. )

( -- If you need it for other purposes, rewriting it yourself is not that hard, )
( and the result will be guaranteed to satisfy your needs much more effectively. )

( See these chapters of Sociology 500, a Novel, on line: )
( <http://joel-rees-economics.blogspot.com/2017/03/soc500-03-08-calendar-math.html> )
( <http://joel-rees-economics.blogspot.jp/2017/04/soc500-03-09-calculating-months-skip-years.html> )
( <http://joel-rees-economics.blogspot.com/2017/04/soc500-03-10-computers.html> )

( Novel table of contents and preface here: )
( <http://joel-rees-economics.blogspot.com/2017/01/soc500-00-00-toc.html>. )

( You can save it as something like "econmonths.fs". ) 

( In gforth and most modern or emulated environments, )
( just paste it into the terminal of a running Forth session. )

( Run it with )

( 7 SHOWIDEALMONTHS )

(  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. )
( Or, for MSWindows, you can get it through Cygwin: <https://www.cygwin.com/>. )

( HTML documentation can be found on the web at )
( <http://www.complang.tuwien.ac.at/forth/gforth/Docs-html/> )
( which includes a tutorial for experienced programmers. )

( An easier tutorial for Forth can be found at )
( <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. )

( Joel Matthew Rees's own implementation of Forth can be found via )
( <http://bif-c.sourceforge.net/>, )
( but if you want to play with that, you'll have to compile it yourself. )
( Look in the wiki at <https://sourceforge.net/p/bif-c/wiki/Home/> for help. )

( Many other Forths should also work. )

( If you don't like Forth's postfix syntax, you might try bc, )
( which is an ancient calculator found in many modern OSses and Cygwin. )
( The bc source is here: <https://osdn.net/users/reiisi/pastebin/4988>. )
( This file is here: <https://osdn.net/users/reiisi/pastebin/4990>. )
 

( Uses integer math throughout. )
( Forth expression syntax is mostly postfix. )
( Only the definition syntax is prefix or infix. )
( I've added some comments with equivalent infix expressions )
( to help those unfamiliar with Forth. )


( 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, )
( especially pre-1983 fig and bif-c. )
( Un-comment them if you see errors like )
( UM* ? err # 0 )
( from PRMONTH or thereabouts. )

( : INVERT NOT ; ( n1 --- n2 : Bit invert is in some ancient Forths as NOT. )
: INVERT -1 XOR ; ( n1 --- n2 : Bit invert is not found at all in some ancient Forths. )

: UM* U* ; ( u u --- ud : modern name for unsigned mixed multiply )

( So this is just sloppy renaming in a sloppy fashion: )
( unsigned division with modulo remainder )
: UM/MOD U/ ; ( uddividend udivisor --- uremainder uquotient : If this doesn't work try M/MOD DROP: )
( : UM/MOD M/MOD DROP ; ( uddividend udivisor --- uremainder uquotient )


: S>D S->D ; ( n --- d : Modern name for single-to-double. )
: NEGATE MINUS ; ( n --- -n : Modern name for numeric negation. )
: DNEGATE DMINUS ; ( d --- -d : Modern name for double number negation. )

: DINVERT  INVERT SWAP INVERT SWAP ;   ( d1 --- d2 : Double bit invert. )

: 2DUP  OVER OVER ; ( d --- d d : DUPlicate top double cell on stack. )

: 2DROP DROP DROP ; ( d --- : DROP a double, for readability. )

: D-  DNEGATE D+ ; (  d1 d2 --- d : Difference of two doubles. )

: M* ( n n --- d : signed mixed multiply )
  2DUP XOR >R   ( The archetypical definition. )
  ABS SWAP ABS UM* 
  R> 0< IF DNEGATE THEN
; 

: 2SWAP ROT >R ROT R> ; ( d1 d2 --- d2 d1 : Swap top two doubles )

: 2ROT >R >R 2SWAP R> R> 2SWAP ; ( d0 d1 d2 --- d1 d2 d0 )

: 2OVER >R >R 2DUP R> R> 2SWAP ; ( d0 d1 --- d0 d1 d0 )

: D0= OR 0= ; ( d0 --- f : Test top double. )

: D0< SWAP DROP 0< ; ( d0 --- f : Test top double sign. )

: D= D- D0= ; ( d1 d2 --- f : Test the top two doubles for equality. )

: D< D- D0< ; ( d1 d2 --- f : Test the top two doubles for left being less. )

: 2>R SWAP >R >R ; ( Save a double away in true order, high word handy. )

: 2R> R> R> SWAP ; ( Bring back saved double. )

: 4DUP 2OVER 2OVER ; ( q --- q q : DUPlicate the top four cells on stack. )

( : QNEGATE ( q1 --- q2 : Negate top quadruple word. )
(  >R 0. R> 0 d- >r four times, or is it three with double at end? )
  

: DMAX ( d1 d2 --- d : Leave larger of top two. )
  4DUP D< IF 2SWAP 2DROP ELSE 2DROP THEN ;

: DMIN ( d1 d2 --- d : Leave smaller of top two. )
  4DUP D< IF 2DROP ELSE 2SWAP 2DROP THEN ;

( : R@ R ; ( Modern name for copy top of return stack. )

( Showing the above in infix won't help. )


( From here, we should load okay in modern Forths. ) 
( Most of the doubles handling will be faster at assembler level )
( -- even if all you have is the bit math. )


( JM/MOD is already there as M/MOD in some Forths: )
( : JM/MOD M/MOD ; ( uddividend udivisor -- uremainder udquotient ) 
: JM/MOD ( uddividend udivisor -- uremainder udquotient )
  >R 0 R> DUP >R UM/MOD R> SWAP >R UM/MOD R> ; 
( Tick ' has various semantics, even in different fig Forths. )
( This definition is safe, anyway. )

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

( Left shifts can be done with addition. )
: 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 
  SUM-D2*
  R> R> ;

: MY-BIT-COUNTER ( --- u ) ( Let's figure out how wide a CELL is. )
  0. 1. BEGIN
    SUM-D2* 2SWAP 1. D+ 2SWAP SP@ @
  UNTIL 2DROP DROP ;

MY-BIT-COUNTER CONSTANT CELLBITS 
CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS

( 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 *  ( 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 *  ( 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! *** )
;

( This probably isn't really a good idea. Much better to just implement UMD* in assembler. )
( AL AH B --- QL QML QMH : unsigned double by unsigned single yielding three-cell unsigned )
: UDS* ( ud u --- uhq ) 
  DUP >R SWAP >R 
  ( AL B ) UM* 
  0 ( ready to sum into )
  R> R> 
  ( AH B ) UM*
  D+ 
;

( only for stealing by U3S/MOD and UQS/MOD ! )
( Should actually be in a private vocabulary, but old Forths and new Forths do those differently. )
: (HIDDEN3S/MOD) ( uq u --- uremainder uhquotient ) 
  DUP >R JM/MOD DROP ( AL AM R QMH ) ( B )
  R> SWAP >R ( AL AM R B ) ( QMH )
  DUP >R JM/MOD DROP ( AL R QML ) ( QMH B )
  R> SWAP >R ( AL R B ) ( QMH QML )
  JM/MOD DROP ( R QL ) ( QMH QML )
  R> R> ( R QL QML QMH )
;

( AL AML AMH B --- R QL QML QMH : unsigned 3-cell by unsigned single yielding 3-cell unsigned )
: U3S/MOD ( uhq u --- uremainder uhqquotient )
  0 SWAP ( AL AM AH 0 B ) ( Prime the chain. )
  (HIDDEN3S/MOD) 
;
( You want to know why this is okay. )
( For the intuitive approach, )
( consider the cell lower in order than the current cell )
( as on the other side of the effective fraction point. )
( Now consider that the lower order cell cannot be as large as 1 in the current cell. )
( The remainder cannot be as large as the divisor.
( Added together, they still cannot be as large as the divisor. )
( Therefore, once you prime the chain with a zero in the cell above, )
( the result cannot overfow into the higher order cell of the double dividend. )

( AL AML AMH AH B --- R QL QML QMH QH : unsigned 4-cell by unsigned single yielding 4-cell unsigned )
: UQS/MOD ( uqdividend udivisor --- uremainder uqquotient )
  0 SWAP ( AL AML AMH AH 0 B ) ( Prime the chain. )
  DUP >R JM/MOD DROP ( AL AML AMH R QH ) ( B )
  R> SWAP >R ( AL AML AMH R B ) ( QH )
  (HIDDEN3S/MOD)
(  DUP >R JM/MOD DROP -- AL AML R QMH ) ( QH B )
(  R> SWAP >R -- AL AML R B ) ( QH QMH )
(  DUP >R JM/MOD DROP -- AL R QML ) ( QH QMH B )
(  R> SWAP >R -- AL R B ) ( QH QMH QML )
(  JM/MOD DROP -- R QL ) ( QH QMH QML )
(  R> R> )
  R> ( R QL QML QMH )
;

( Given  AABB / EEFF == SSTT rem MMNN, )
( AA/EE == RR rem LL is an approximation, iff EE is not zero. )
( But EE == 00 => use AABB / FF. )
( For EE > 0, RR * EE + LL == AA, or [ RR + LL / EE ] * EE == AA )
( But LL / EE < 1, or [ LL / EE ] * 100 < 100 )
( { [ RR + LL / EE ] * EE } * 100 == AA * 100 } )
( { [ RR * EE ] * 100 + LL * 100 } < { AA * 100 + BB } )
( Thus, { RR * EE00 + LL00 } < AABB )
( Now, BB < 100, so )
( { [ RR * EE + 1 ] * 100 + LL * 100 } > { AA * 100 + BB } )
( or AABB < { [ RR + 1 ] * EE00 + LL00 }
( This gives us some confidence that )
( { [ RR - 1 ] * EEFF } <= AABB <= { [ RR + 1 ] * EEFF } )
( which means that a trial division should be easy to restore to the true result. )
( But we want to know for sure. )
( { RR * EE00 + LL00 } == AA00 )
( { RR * EE00 + LL00 + BB } == AABB )
( { RR * [ EE00 + FF ] + LL00 + BB } > AABB )
( { RR * EE00 + RR * FF + LL00 + BB } > AABB )
( { RR * EE00 + RR * FF + LL00 + BB } == { AABB + RR * FF } )
( { RR * EE00 + RR * FF + LL00 + BB } == { AA00 + BB + RR * FF } )
( Good thing we checked. )
( The closer BB -LL gets to FF, the harder it is to recover. )
( Pathological case, hexadecimal - 32FF / 1FF in byte columns: )
( 32FF / 100 == 32rFF, 32 * 1FF == 63CE. )
( 32FF / 1FF is almost 32FF / 200: 19r177. )
( In sixteen bits, not useful. )
( In eight bits, better, but still not very useful. )

( Starting from scratch: )
( A/B == CrD => C * B + D == A, D < B )
( B can be expressed in terms of the magnitude of the columns: )
( If B < Radix R, or the magnitude of the columns, use UQS/MOD. )
( If B == Magnitude of the columns, shift A. )
( B > Radix R,  B/R == PrL, )
( B == P*R + L, P == [B-L]/R )
( L == B - P*R )
( Then, )
( A == C * [ P*R + L] + D )
( A == CPR + CL + D )
( A / [P*R] == C + CL/[P*R] + D/[P*R] )
( A / [P*R] == C * [1 + L/[P*R]] + D/[P*R]  This goes in a circle. )
( A == C * [PR + L] + D )
( A / [PR + L] == C + D / [PR + L] , 0 <= D < B or 0 <= D < PR + L )
( C <= A / [PR + L] < C + 1 , which isn't all that useful, either. )
( But 0 <= L < R, so )
( A / {[P + 1] * R} < A / [PR + L] <= A / PR , which restates the above. )

( Asking at comp.lang.forth produced this suggestion from Andrew Haley: )
( http://surface.syr.edu/cgi/viewcontent.cgi?article=1162&context=eecs_techreports )
( And from Rudy Velthius -- also mentions divmnu.c ) 
( https://github.com/rvelthuis/BigNumbers )
( It pretty much agrees with what I'm seeing above. )
( Doing it in binary math is the right way for this. )


( AL AH BL BH --- QL QML QMH QH : unsigned double by unsigned double yielding unsigned quad )
: UMD* ( ud1 ud2 --- uq ) 
  ( AL ) 3 LC@ ( BL ) 2 LC@ UM* 0 ( QL QML QMH : low cells product, ready to sum into QML QMH )
  ( AH ) 5 LC@ ( BL ) 5 LC@ UM* >R 0 D+ ( inner product low int QML and carry )
  ( AL ) 6 LC@ ( BH ) 4 LC@ UM* >R 0 D+ ( again, QML complete. )
  0 ( zero to QH, ready to sum into QMH QH )
  R> 0 D+ R> 0 D+ ( QL QML QMH QH : inner product high into QMH and carry )
  ( AH ) 6 LC@ ( BH ) 5 LC@ UM* D+ ( Product complete, now store it. )
  3 LC! 3 LC! 3 LC! 3 LC! 
;


( 2/ and d2/ require words which have various names -- u/, etc., )
( and are very slow. )
( Just best to do in assembler, along with UD* and UQD/MOD . )

( Do it in assembler instead! Hundreds of times as slow!!!! )
: DIV-2/ ( u1 --- u2 : Halve the top cell. REALLY SLOW! )
  S>D 2 UM/MOD SWAP DROP ;

( Do it in assembler instead! Hundreds of times as slow!!!! )
: DIV-D2/ ( ud1 --- ud2 : Halve the top double cell. REALLY SLOW! )
  2 JM/MOD ROT DROP ;

( Scaling, to keep the steps time-bounded, )
( is going to leave me at the binary long division )
( unless I use tables. )
( Tables will not fit in a 16-bit address space. )
( And scaling requires shifts, )
( which are painfully slow if not defined low level. )
( 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 )
: 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 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 )
      6 DLC@ D< 0=   ( Greater or equal? : BL BH AL AML AMH AH f )
      R> OR    ( Force it? )
      IF   ( BL BH AL AML AMH AH ) ( [ count ] )
        4 DLC@ D- 1 ( Mark the subtraction. )
      ELSE
        0 ( Mark no subtraction. )
      THEN   ( BL BH AL AML AMH AH bit ) ( [ count ] )
      SWAP >R SWAP >R   ( Save top half of remainder and bury the subtraction flag. )
      ( 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 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. )
      ( BL BH rsAL rsAML ) ( [ count AH AMH AML ] )
      R> 0< IF 1 ELSE 0 THEN ( Convert AML to bit to shift in to top half. )
      ( BL BH rsAL rsAML carry ) ( [ count AH AMH ] )
      R> R>   ( BL BH rsAL rsAML carry AMH AH ) ( [ count ] )
      R> 1 - DUP >R    ( Count down. )
      ( BL BH rsAL rsAML carry AMH AH newcount ) ( [ newcount ] )
      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 ] )
        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 ] )
    ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount ] )
    R> DROP   ( the count ) ( BL BH rsAL rsAML carry AMH AH )
    ROT DROP   ( BL BH QL QH RL RH )
    2ROT 2DROP   ( QL QH RL RH )
    2SWAP    ( RL RH QL QH )
  THEN
; 


( 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 ;
: VBAR 124 EMIT ;
: PLUS 43 EMIT ;
: DASH 45 EMIT ;
: STAR 42 EMIT ;
: ZERO 48 EMIT ;

( No trailing space. )
: PSNUM ( number -- )
  0 .R ;

: PSDNUM ( number -- )
  0 D.R ;

( Do it in integers! )

( Watch limits on 16 bit processors! )

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

1 CONSTANT EDMCYCLE ( whole days adjusted down in 98 year cycle )

RDSCYCLE SPMCYC * EDMCYCLE - CONSTANT RDMCYCLE ( remainder days in medium cycle )
( RDMCYCLE = RDSCYCLE × SPMCYC - EDMCYCLE )

( DPSCYCLE SPMCYC UM* EDMCYCLE 0 D- DCONSTANT DPMCYCLE : 34565, too large for signed 16 bit. )
( DPMCYCLE = DPSCYCLE × SPMCYC - EDMCYCLE )
( Fake DCONSTANT: )
: DPMCYCLE [ DPSCYCLE SPMCYC UM* EDMCYCLE 0 D- SWAP ] LITERAL LITERAL ; ( Fits in unsigned 16 bit. )

2 CONSTANT SD2LCYCLE ( whole days adjusted up in 686 year cycle )

RDMCYCLE MP2LCYC * SD2LCYCLE + CONSTANT RD2LCYCLE ( remainder days in double long cycle -- odd number )
( RD2LCYCLE = RDMCYCLE × MP2LCYC + SD2LCYCLE )
( RD2LCYCLE / 2LCYCLE is fractional part of year. )
( Ergo, length of year is DPSKIPYEAR + RD2LCYCLE / 2LCYCLE, )
( or 352 485/686 days. )

( D* is not defined, but, luckily, DPMCYCLE fits in unsigned 16 bit. )
( 100 years of 365.24 also fits in unsigned 16 bit, FWIW. )
( DPLCYCLE would not be an integer, leaves a half day over. )
( DPMCYCLE MP2LCYC S>D D* SD2LCYCLE 0 D+ DCONSTANT DP2LCYCLE : 241957 , too large for 16 bit. )
( DP2LCYCLE = DPMCYCLE × MP2LCYC + SD2LCYCLE )
( Fake DCONSTANT: )
: DP2LCYCLE [ DPMCYCLE ( 34565 ) DROP MP2LCYC UM* SD2LCYCLE 0 D+ SWAP ] LITERAL LITERAL ; 

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 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 
    ROT ROT ( No, restore stack order for next pass. )
  ELSE
    MDENOMINATOR - ( Take one whole day from the fractional part. )
    ROT ROT 1 S>D D+ ( Restore stack and add the day carried in. )
  THEN
;

: 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 UM/MOD ( Divide, or evaluate the fraction. )
  S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
  TYPE ( Fake decimal output. )
  DROP SPACE 
;

: SH1IDEALYEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
  CR
  MPYEAR 0 DO 
    5 LC@ PSNUM SPACE ( year )
    I PSNUM COLON SPACE
    SU1MONTH 
    2DUP 5 DLC@ D- ( difference in days )
    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 
    3 DLC! ( update daysmemory )
    PRMONTH RPAREN CR
  LOOP
;

: SHOWIDEALMONTHS ( years -- )
  >R
  0 0. 0 0. ( year, ddaysmemory, fractional, ddays )
  R> 0 DO
    CR
    SH1IDEALYEAR
    5 LC@ 1+ 5 LC!
  LOOP
  2DROP DROP 2DROP 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. )
LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2

( 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 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. )
  THEN
;


( At this point, I hit a condundrum. )
( Modern "standard" Forths want variables without initial values, )
( 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. )
( I can't fix this easily. )
( We give the ancient Forths a zero. )
( Modern Forths will leave the 0 given here on the stack. )
( Then the zero stays around forever on modern Forths, or until you drop it. )
0 VARIABLE DIMARRAY  ( Days In Months array )

CELLWIDTH NEGATE 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 ,

( 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 MPYEAR + 
  ELSE
    DUP MPYEAR < 0= IF
      SWAP 1 + SWAP MPYEAR -
    THEN
  THEN
  DUP 0 < 0=
  OVER MPYEAR < AND 0= 
  IF
    DROP DROP 0  ( Out of range. No days. )
  ELSE
    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. )
  THEN 
;
    
: SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
  CR
  MPYEAR 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
;

: D, ( d --- ) ( Store a double into the dictionary. )
  SWAP , , ;

: DINY ( year --- days )
  ISKIPYEAR 0= 1 AND DPSKIPYEAR + ;

: DTYLONGLOOP ( years --- ddays ) ( Days in years. )
  0. ROT DUP IF 
    0 DO
      I DINY S>D D+
    LOOP
  ELSE
    DROP
  THEN
;

( Already did these the other way: )
( : DPMCYCLE [ MCYCLE DTYLONGLOOP SWAP ] LITERAL LITERAL ; ( 34565  )
( : DP2LCYCLE [ 2LCYCLE DTYLONGLOOP SWAP ] LITERAL LITERAL ; ( 241957 )

( Synthetic division is faster than general division. )
: DTYLONG ( ddays1 uyear1 --- ddays2 uyear2 ) ( Sum long cycle years. )
  BEGIN 
    2LCYCLE - DUP 0< 0= WHILE
      >R DP2LCYCLE D+ R>
  REPEAT
  2LCYCLE +
;

( Synthetic division is faster than general division. )
: DTYMEDIUM ( ddays1 uyear1 --- ddays2 uyear2 ) ( Sum medium cycle years with leaps. )
  DUP LPLONGCYC2 > IF
    >R 2. D+ R> 
  ELSE
    DUP LPLONGCYC > IF >R 1. D+ R> THEN
  THEN
  BEGIN 
    MCYCLE - DUP 0< 0= WHILE
      >R DPMCYCLE D+ R>
  REPEAT
  MCYCLE +
;

( Synthetic division is still faster : max 98 / 7 loops. )
: DTYSHORT ( ddays1 uyear1 --- ddays2 uyear2 ) ( Sum short cycle years with skip. )
  DUP SKMEDIUMCYC > IF
    >R 1. D- R> 
  THEN
  BEGIN 
    SCYCLE - DUP 0< 0= WHILE
      >R DPSCYCLE 0 D+ R>
  REPEAT
  SCYCLE +
;

( Synthetic division is faster than general division. )
( Anyway, this has only algorithmic meaning prior to the standard calendar. )
: DTY ( uyear --- ddays )
  0. ROT
  DTYLONG
  DTYMEDIUM
  DTYSHORT
  DTYLONGLOOP
  D+
; 

( Saturates on month > MPYEAR. Generally use to month MPYEAR - 1. )
: DTM ( uyear umonth --- days ) ( Just the days from the beginning of the year. )
  DUP IF
    0 SWAP 0 DO
      OVER I DIMONTH +
    LOOP
  THEN
  SWAP DROP
;


( Modern Forths will leave the initialization 0 behind. )
0 VARIABLE CALENDAR-WIDTH
80  CALENDAR-WIDTH !
( But we won't use this because we don't have real strings. )
( Okay, we'll use it anyway. )

( Modern Forths will leave the initialization 0 behind. )
0 VARIABLE DAYCOUNT
0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. )


( Modern Forths will leave the initialization 0 behind. )
6 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. )
0 VARIABLE 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
0 1STDAYOFWEEK !

( Modern Forths will leave the initialization 0 behind. )
0 VARIABLE DOWKSTATE ( Current day of week. )

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 )

( Their larger moon orbits their world in about twenty-eight and seven eighths days, )
( about twelve and one fifth long lunar months each year.)
28 CONSTANT SMPERIODINT ( Slow moon period integer part. )
7 DECYCLE 8 */ 41 + CONSTANT SMPERIODFRAC10976 ( Slow moon period fractional part. )
( Fake DCONSTANT: )
: SMPERIOD10976 [ SMPERIODINT DECYCLE UM* SMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ; 
( 28 9645 / 10976 == 316973 / 10976 )

( Modern Forths will leave the initialization 0 behind. )
0 VARIABLE SMSTATEINT ( Slow moon state integer part. )
0 SMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
( Modern Forths will leave the initialization 0 behind. )
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 ;

( start + mt = 1/2, start + gt = 3/4 => t * { g - m } = 1/4 => t = 1 / 4 * { g - m } )
( g = 1 rot/day, m = 10976 / 316973 rev/day => t = 1 / { 4 * [ 316973 - 10976 ] / 316973 } )
( s + gt = 3/4 => s = 3/4 - t; s = 3/4 - 1 / { 4 * [ 316973 - 10976 ] / 316973 } ) 
( s + mt = 1/2 => s = 1/2 - mt; s = 1/2 - 10976 / [ 4 * { 316973 - 10976 } ] )
( s = [ 2 * 316973 - 3 * 10976 ] / [ 4 * { 316973 - 10976 } ] )
( s = 601018 / 1223988 )
: SMTARGET 
  [ 2. SMPERIOD10976 UMD* 2DROP 3 DECYCLE UM* D-
    SMPERIOD10976 UMD* ( Scale it by period and keep high double word. )
    4. SMPERIOD10976 DECYCLE 0 D- UMD* 2DROP 
    SLOW-UMD/MOD 2SWAP 2DROP SWAP
 ] LITERAL LITERAL ;
( Used SMTARGET like this, with SMOFFFRAC10976 set to 0.: )
( 34 3 STYCYCLES 5 DMADJUST SMSTATEFRAC10976 D@ SMTARGET 2SWAP  D- )
( SMPERIOD10976 D+ D. <enter> 311395 OK )
0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
: SMOFFFRAC10976  [ 311395. SWAP ] LITERAL LITERAL ; ( Fractional part. )

( Below was guessing wrong: )
(  [ SM32NDPERIOD10976 28 UDS* DROP )
(    SM32NDPERIOD10976 DIV-D2/ D+ 4 JM/MOD ROT DROP SWAP ] )

( 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 )
7 CONSTANT FMPERIODINT ( Fast moon period integer part. )
1 DECYCLE 8 */ 9 -  CONSTANT FMPERIODFRAC10976 ( Fast moon period fractional part. )
( Fake DCONSTANT: )
: FMPERIOD10976 [ FMPERIODINT DECYCLE UM* FMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ; 
( 7 1364 / 10976 == 78196 / 10976 )

( start + mt = 1/2, start + gt = 3/4 => t * { g - m } = 1/4 => t = 1 / 4 * { g - m } )
( g = 1 rot/day, m = -10976 / 78196 rev/day => t = 1 / { 4 * [ 78196 + 10976 ] / 78196 } )
( s + gt = 3/4 => s = 3/4 - t; s = 3/4 - 1 / { 4 * [ 78196 + 10976 ] / 78196 } ) 
( s + mt = 1/2 => s = 1/2 - mt; s = 1/2 + 10976 / [ 4 * { 78196 + 10976 } ] )
( s = [ 2 * 78196 + 3 * 10976 ] / [ 4 * { 78196 + 10976 } ] )
( s = 189318 / 356684 )
: FMTARGET 
  [ 2. FMPERIOD10976 UMD* 2DROP 3 DECYCLE UM* D+
    FMPERIOD10976 UMD* ( Scale it by period and keep high double word. )
    4. FMPERIOD10976 DECYCLE 0 D+ UMD* 2DROP 
    SLOW-UMD/MOD 2SWAP 2DROP SWAP
 ] LITERAL LITERAL ;
( Used FMTARGET like this, with FMOFFFRAC10976 set to 0.: )
( 34 3 STYCYCLES 5 DMADJUST FMSTATEFRAC10976 D@ FMTARGET 2SWAP  D- )
( D. <enter> 4287 OK )
0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. )
: FMOFFFRAC10976 [ 4287. SWAP ] LITERAL LITERAL ; ( Fractional part. )

( Modern Forths will leave the initialization 0 behind. )
0 VARIABLE FMSTATEINT ( Fast moon state integer part. )
0 FMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
( Modern Forths will leave the initialization 0 behind. )
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 
  JIRPERDAY SWAP - ( Retrograde. )
  DUP 16 < 0= IF 16 - THEN
  ." 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. )
0 VARIABLE CMONTH 0 CMONTH !
( Modern Forths will leave the initialization 0 behind. )
0 VARIABLE CDATE 0 CDATE !

( Start the weekday counter for the year and month, remember the days. )
( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
: WKSTCYCLES ( uyear umonth --- ) 
  2DUP
  CMONTH !
  CYEAR !
  0 CDATE !
  OVER DTY 
  2SWAP DTM 0 D+
  2DUP DAYCOUNT D!
  WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE !
;

( Leaves things out of sync if not called by DADJUST. )
: BKMONTH ( --- )
  CMONTH @ 1 - DUP 0< IF
    CYEAR @ 1 - CYEAR !
    MPYEAR +
  THEN
  CMONTH !
;

( Leaves things out of sync if not called by DADJUST. )
: UPMONTH ( --- )
  CMONTH @ 1+ 
  DUP MPYEAR < 0= IF
    MPYEAR -
  THEN
  CMONTH !
;

( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
( Negative days will have previous month's DIMONTH as limit. )
( Leaves things out of sync if not called by DADJUST. )
: DTADJUST ( days --- )
  CDATE @ + 
  DUP 0< IF
    BKMONTH ( Previous month's DIMONTH. )
    CYEAR @ CMONTH @ DIMONTH +
  ELSE
    CYEAR @ CMONTH @ DIMONTH 2DUP < 0= IF
      -
      UPMONTH
    ELSE
      DROP
    THEN
  THEN
  CDATE !
;

( Leaves things out of sync if not called by DADJUST. )
: WDADJUST ( days --- )  ( Adjust the day of the week. )
  DOWKSTATE @ +
  DUP 0< IF 
    NEGATE DPWK MOD DPWK SWAP - 
  ELSE
    DPWK MOD 
  THEN
  DOWKSTATE !
;

( Start the slowmoon cycle counter by the day count. )
( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
: SLOMSTCYCLES ( ddays --- ) 
  DECYCLE S>D UMD* SMPERIOD10976 SLOW-UMD/MOD 
  2SWAP SMOFFFRAC10976 D+
  2DUP SMPERIOD10976 D< 0= IF
    SMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
  THEN
  SMSTATEFRAC10976 D!
  SMOFFINT S>D D+ SMSTATEINT D!
;

( Add signed days to slow month state. days must be less than period. )
: SLOMADJ ( days --- )  
  DECYCLE M* 
  SMSTATEFRAC10976 D@ D+ 
  2DUP D0< IF
    SMSTATEINT D@ 1. D- SMSTATEINT D!
    SMPERIOD10976 D+ 
  ELSE
    2DUP SMPERIOD10976 D< 0= IF
      SMSTATEINT D@ 1. D+ SMSTATEINT D!
      SMPERIOD10976 D-
    THEN
  THEN 
  SMSTATEFRAC10976 D!
;

( Start the fastmoon cycle counter by the day count. )
( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
: FASMSTCYCLES ( ddays --- ) 
  DECYCLE S>D UMD* FMPERIOD10976 SLOW-UMD/MOD 
  2SWAP FMOFFFRAC10976 D+
  2DUP FMPERIOD10976 D< 0= IF
    FMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
  THEN
  FMSTATEFRAC10976 D!
  FMOFFINT S>D D+ FMSTATEINT D!
;

( Add signed days to fast month state. days must be less than period. )
: FASMADJ ( days --- )  
  DECYCLE M* 
  FMSTATEFRAC10976 D@ D+ 
  2DUP D0< IF
    FMSTATEINT D@ 1. D- FMSTATEINT D!
    FMPERIOD10976 D+ 
  ELSE
    2DUP FMPERIOD10976 D< 0= IF
      FMSTATEINT D@ 1. D+ FMSTATEINT D!
      FMPERIOD10976 D-
    THEN
  THEN 
  FMSTATEFRAC10976 D!
;

( Call from here to keep things in sync! )
: STYCYCLES ( year month --- ) ( Start the counters for the year. )
  WKSTCYCLES 
  DAYCOUNT D@ 2DUP SLOMSTCYCLES FASMSTCYCLES
;

( : TEST STYCYCLES DAYCOUNT D@ D. CR SMSTATEINT D@ D. CR SMSTATEFRAC10976 D@ D. CR )
( FMSTATEINT D@ D. CR FMSTATEFRAC10976 D@ D. CR ; )

( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
( Negative days will have previous month's DIMONTH as limit. )
( Call from here to keep DAYCOUNT, DOWKSTATE, CYEAR, CMONTH, and CDATE in sync. )
: DADJUST ( days --- ) 
  DUP S>D DAYCOUNT D@ D+ DAYCOUNT D!
  DUP WDADJUST DTADJUST
;

( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
( Negative days will have previous month's DIMONTH as limit. )
( Call from here to keep moon phases also in sync. )
: DMADJUST ( days --- )
  DUP DADJUST DUP SLOMADJ FASMADJ
;


( 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, 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 here allows final single DROP. )
              ." Vensday " 
   THEN
   THEN
   THEN
   THEN
   THEN
   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. )
     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 ;

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 --- )
  = IF STAR ELSE SPACE THEN ;

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

( DPWK days from start, emphasize and reset day if matched for month. )
: DAYLINE ( month day --- month daydone ) 
  VBAR 
  DPWK 0 DO
    OVER CMONTH @ = IF DUP ELSE -1 THEN
    CDATE @ 
    PDFIELD
    1 DADJUST
  LOOP
  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 
  CYEAR @ 4 .R SPACE
  CMONTH @ TPMONTH CR
  HLINE
  PWKDAYS
  HLINE
  DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
  DUP   ( Count of days to back up. )
  IF
    NEGATE DMADJUST
  ELSE 
    DROP
  THEN
  BEGIN
    SPLINE
    DAYLINE
    SPLINE
    SPLINE
    PHLINE
    HLINE
    OVER CMONTH @ < UNTIL
  DROP DROP
;




( Lots -- 10? -- of 0s left behind on modern Forths. )