 ( 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://joelreeseconomics.blogspot.com/2017/03/soc5000308calendarmath.html> )
 ( <http://joelreeseconomics.blogspot.jp/2017/04/soc5000309calculatingmonthsskipyears.html> )
 ( <http://joelreeseconomics.blogspot.com/2017/04/soc5000310computers.html> )

 ( Novel table of contents and preface here: )
 ( <http://joelreeseconomics.blogspot.com/2017/01/soc5000000toc.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/Docshtml/> )
 ( which includes a tutorial for experienced programmers. )

 ( An easier tutorial for Forth can be found at )
 ( <https://www.forth.com/startingforth/>. )

 ( 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://bifc.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/bifc/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. )
 ( figForth 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 pre1983 fig and bifc. )
 ( Uncomment 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 singletodouble. )
 : 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 = absolutevalueof differencebetween SPwithoutpointer and SPwithpointer. )

 ( Infix will be confusing here, too. )
 : D@ ( adr  d ) ( fetch a double )
 DUP CELLWIDTH + @ ( LSCELL )
 SWAP @ ( MSCELL )
 ;

 ( Infix will be confusing here, too. )
 : D! ( d adr  ) ( store a double )
 SWAP OVER ! ( MSCELL )
 CELLWIDTH + ! ( MSCELL )
 ;

 ( Left shifts can be done with addition. )
 : SUM2* DUP + ; ( u1  u2 : Double the top cell. Not fastest, not too slow. )
 : SUMD2* 2DUP D+ ; ( ud1  ud2 : Double the top double cell. Not fastest. )
 : SLOWQ2* ( uq1  uq2 : Double the top double cell. Not fastest. )
 SUMD2* >R OVER 0< IF
 1 OR ( carry )
 THEN
 >R
 SUMD2*
 R> R> ;

 : MYBITCOUNTER (  u ) ( Let's figure out how wide a CELL is. )
 0. 1. BEGIN
 SUMD2* 2SWAP 1. D+ 2SWAP SP@ @
 UNTIL 2DROP DROP ;

 MYBITCOUNTER CONSTANT CELLBITS
 CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS

 ( Semisimulate 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 pushdown stack. Will fail on pushup. )
 ;

 ( 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 pushdown stack. )
 ! ( *** Will fail in MISERABLE ways on pushup 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 pushdown stack. Will fail on pushup. )
 ;

 ( 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 pushdown stack. )
 D! ( *** Will fail in MISERABLE ways on pushup 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 threecell 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 3cell by unsigned single yielding 3cell 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 4cell by unsigned single yielding 4cell 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 == [BL]/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!!!! )
 : DIV2/ ( 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!!!! )
 : DIVD2/ ( ud1  ud2 : Halve the top double cell. REALLY SLOW! )
 2 JM/MOD ROT DROP ;

 ( Scaling, to keep the steps timebounded, )
 ( is going to leave me at the binary long division )
 ( unless I use tables. )
 ( Tables will not fit in a 16bit 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 )
 : SLOWUMD/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 SUM2* 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 SUMD2* ( 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 ] )
 SUMD2* ( 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 16bit math CPUs. )
 ( No particular problem on 32 bit CPUs. Need DCONSTANT for 16bit 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 figForths want initialized variables. )
 ( The lowerlevel <BUILDS DOES> for fig is only partially part of the modern standard. )
 ( And CREATE is initialized as a CONSTANT in the figForth, )
 ( 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 CALENDARWIDTH
 80 CALENDARWIDTH !
 ( 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 twentyeight 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
 SLOWUMD/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 DIVD2/ D+ 4 JM/MOD ROT DROP SWAP ] )

 ( Could predivide 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 SLOWUMD/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 fortynine 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
 SLOWUMD/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 predivide 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 SLOWUMD/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 SLOWUMD/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 SLOWUMD/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 ." Timedivision" ELSE ( Fake case format to line the strings up. )
 DUP 1 = IF ." Deepwinter " ELSE
 DUP 2 = IF ." Wartime " ELSE
 DUP 3 = IF ." Thawtime " ELSE
 DUP 4 = IF ." Rebirth " ELSE
 DUP 5 = IF ." Bridesmonth" ELSE
 ( ." ???" )
 ( THEN THEN THEN THEN THEN THEN )
 ( ELSE )
 DUP 6 = IF ." Imperious " ELSE
 DUP 7 = IF ." Senatorious " ELSE
 DUP 8 = IF ." Falsesummer" ELSE
 DUP 9 = IF ." Harvest " ELSE
 DUP 10 = IF ." Gratitude " ELSE
 DUP 11 = IF ." Wintermonth" 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

 CALENDARWIDTH @ DPWK / 1  CONSTANT DFIELD

 : WLINELENGTH CALENDARWIDTH @ 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. )



