コミット: ae9ce3df9af333a1c470db29d89f666cf1bbfea4 - xhilr_calendar (git)

Functions for working with the idealized calendar of Planet Xhilr

コミットメタ情報

• リビジョン: ae9ce3df9af333a1c470db29d89f666cf1bbfea4 (tree)
• 日時: 2017-06-13 17:58:44
• 作者: Joel Matthew Rees <joel.rees@gmai...>
• コミッター: Joel Matthew Rees

ログメッセージ

progress, corrections, and a detour in C

変更サマリ

• modified: econmonths.fs
• modified: lunar.fs
• add: stringheader.c

差分

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -70,35 +70,83 @@
 ( fig-Forth used first three character + length significance in symbol tables. )
 
 
-( UM*, FM/MOD, S>D, 2DUP, and D- are already there in most modern Forths. )
+( 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. )
 
-: UM* U* ; ( modern name for unsigned mixed multiply )
+: UM* U* ; ( u u --- ud : modern name for unsigned mixed multiply )
 
-( This is a cheat! Behavior is not well defined for negative numbers, )
-( but we don't do negatives here. )
 ( So this is just sloppy renaming in a sloppy fashion: )
-: FM/MOD M/MOD DROP ; ( unsigned division with modulo remainder )
+( 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 ; ( Modern name for single-to-double. )
+: S>D S->D ; ( n --- d : Modern name for single-to-double. )
+: NEGATE MINUS ; ( n --- -n : Modern name for single-to-double. )
+: DNEGATE DMINUS ; ( d --- -d : Modern name for single-to-double. )
 
-: 2DUP  OVER OVER ; ( d --- d d : DUPlicate top double word on stack. )
+: 2DUP  OVER OVER ; ( d --- d d : DUPlicate top double cell on stack. )
 
 : 2DROP DROP DROP ; ( d --- : DROP a double, for readability. )
 
-: D-  DMINUS D+ ; (  d1 d2 --- d : Difference of two doubles. )
-( : D-  DNEGATE D+ (  d1 d2 --- d : Difference of two doubles, if no DMINUS. )
+: D-  DNEGATE D+ ; (  d1 d2 --- d : Difference of two doubles. )
+
+: 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. )
+
+: 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 ;
+
+( 2/ and d2/ requires words which have various names -- u/, etc., )
+( and are very slow. )
+( Just best to do in assembler, along with UD* and UQD/MOD . )
+( : 2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest. )
+
+( : D2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
+
+( Do it in assembler instead! )
+( : 2/ 0 2 UM/MOD SWAP DROP ; ( u1 --- u2 : Halve the top cell. SLOW! )
+
+( Do it in assembler instead! )
+( : D2/ 2 M/MOD ROT DROP ; ( uD1 --- uD2 : Halve the top cell. SLOW! )
 
 ( : 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. )
 
-( Showing the above in infix won't help. )
+
+( 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> ; 
 
 SP@ SP@ - ABS CONSTANT CELLWIDTH
 ( Infix won't help here, either, but I can try to explain: )
@@ -144,6 +192,142 @@ SP@ SP@ - ABS CONSTANT CELLWIDTH
   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! 
+;
+
+( 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. )
+( AL AML AMH AH BL BH --- QL QML QMH QH : unsigned 4-cell by unsigned double yielding 4-cell unsigned )
+( : UQD/MOD ( uqdividend uddivisor --- udremainder uhqquotient )
+(  DUP 0= IF )
+(    DROP UQS/MOD ( Get divisor high word 0 case out of the way. )
+(  ELSE )
+(    2>R ( Divisor high byte handy. )
+(    DUP 0 R> DUP >R JM/MOD ( Trial division for guess. )
+(    ROT DROP 2R> 2DUP 2>R UMD* )
+( )
+(  THEN )
+( ; )
+
+( : UMQ* ( uqdividend uddivisor --- udremainder uqquotient )
+(  0. 2SWAP )
+
 ( Make things easier to read. )
 ( Infix will be confusing here, too. )
 
@@ -195,28 +379,38 @@ MCYCLE MP2LCYC * CONSTANT 2LCYCLE ( years in double long cycle, should be 686 )
 
 DPSKIPYEAR SCYCLE * RDSCYCLE + CONSTANT DPSCYCLE ( whole days per 7 year cycle )
 ( DPSCYCLE = DPSKIPYEAR × SCYCLE + RDSCYCLE )
-( DPSCYCLE SPMCYC * DCONSTANT DPMCYCLE )
-( DPMCYCLE = DPSCYCLE × SPMCYC )
-( DPMCYCLE MP2LCYC * DCONSTANT DP2LCYCLE )
-( DP2LCYCLE = DPMCYCLE × MP2LCYC )
+
 ( DPMCYCLE and DP2LCYCLE would overflow on 16-bit math CPUs. ) 
 ( No particular problem on 32 bit CPUs. Need DCONSTANT for 16-bit CPUs. )
 ( But we need the constants more than we need to puzzle out )
 ( the differences between CREATE DOES> and <BUILDS DOES>. )
-: DPMCYCLE DPSCYCLE SPMCYC UM* ; ( Takes a little extra time this way. )
-( DPMCYCLE is actually 34566, so the high CELL is 0, )
-( but the low CELL must be treated as unsigned. )
-: DP2LCYCLE DPMCYCLE DROP MP2LCYC UM* ;
 
-RDSCYCLE SPMCYC * 1 - CONSTANT RDMCYCLE ( remainder days in medium cycle )
-( RDMCYCLE = RDSCYCLE × SPMCYC - 1 )
+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 * 2 + CONSTANT RD2LCYCLE ( remainder days in double long cycle -- odd number )
-( RD2LCYCLE = RDMCYCLE × MP2LCYC + 2 )
+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 )
@@ -255,7 +449,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
   SPACE 2DUP PSDNUM POINT ( whole days )
   2 LC@ 1000 UM* ( Fake three digits of decimal precision. )
   MROUNDFUDGE S>D D+ ( Round the bottom digit. )
-  MDENOMINATOR FM/MOD ( Divide, or evaluate the fraction. )
+  MDENOMINATOR UM/MOD ( Divide, or evaluate the fraction. )
   S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
   TYPE ( Fake decimal output. )
   DROP SPACE 
@@ -293,6 +487,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
   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. )
@@ -322,7 +517,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
 0 VARIABLE DIMARRAY  ( Days In Months array )
 ( Modern Forths don't initialize, will leave 0 on stack. )
 
-CELLWIDTH - ALLOT ( Back up to store values. )
+CELLWIDTH NEGATE ALLOT ( Back up to store values. )
 
 30 C, 
 29 C,
@@ -366,7 +561,7 @@ CELLWIDTH - ALLOT ( Back up to store values. )
   LOOP
 ;
 
-: SHOWMONTHS ( years -- )
+: SHOWMONTHS ( years --- )
   >R
   0 0. 0 0. ( year, ddaysmemory, fractional, ddays )
   R> 0 DO
@@ -377,6 +572,182 @@ CELLWIDTH - ALLOT ( Back up to store values. )
   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 > 12. Generally use to month 11. )
+: DTM ( year month --- days ) ( Just the days from the beginning of the year. )
+  DUP IF
+    0 SWAP 0 DO
+      OVER I DIMONTH +
+    LOOP
+  THEN
+  SWAP DROP
+;
+
+
+0 VARIABLE CALENDAR-WIDTH
+80  CALENDAR-WIDTH !
+
+0 VARIABLE DAYCOUNT
+0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. Modern Forths leave a zero. )
+
+
+0 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. )
+0 CONSTANT 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
+
+0 VARIABLE DOWKSTATE ( Current day of week. Modern Forths leave a zero. )
+
+7 CONSTANT DPWK ( Days per week. )
+
+
+( 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 )
+( 
+
+
+0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
+0 CONSTANT SMOFFFRAC10976 ( Fractional part. )
+
+0 VARIABLE SMSTATEINT ( Slow moon state integer part. )
+0 SMSTATEINT ! ( Initialize cleared. Modern Forths leave a zero. )
+0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
+
+
+( 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 )
+
+0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. )
+0 CONSTANT FMOFFFRAC10976 ( Fractional part. )
+
+0 VARIABLE FMSTATEINT ( Fast moon state integer part. )
+0 FMSTATEINT ! ( Initialize cleared. Modern Forths leave a zero. )
+0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
+
+
+: WSTYCYCLES ( year --- ddays ) ( Start the weekday counter for the year, keep the days. )
+  DTY 2DUP DAYCOUNT D!
+  2DUP WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE !
+;
+
+: SSTYCYCLES ( ddays --- ) ( Start the slowmoon cycle counter for the year. )
+  SMOFFINT SMSTATEINT !
+  SMOFFFRAC10976 SMSTATEFRAC10976 !
+
+  2DUP DECYCLE UDS*  
+  
+;
+
+: FSTYCYCLES ( year --- ) ( Start the fastmoon cycle counter for the year. )
+  FMOFFINT 0 FMSTATEINT !
+  FMOFFFRAC10976 FMSTATEFRAC10976 !
+
+  2DUP DECYCLE UDS*  ( Have to dived by period, period is double. )
+
+;
+
+: STYCYCLES ( year --- ) ( Start the counters for the year. )
+  DUP WSTYCYCLES
+  DUP SSTYCYCLES
+  DUP FSTYCYCLES
+;
+
+: STMCYCLES ( year month --- ) ( The year is started, start the month. )
+  DTM 0 DAYCOUNT D@ D+ 2DUP DAYCOUNT !
+  2DUP DPWK JM/MOD 2DROP DOWKSTATE ! ( Overwrite the state, don't sum it. )
+  
+;   
+
+
+
+: PRMONTH ( year month day --- )
+  >R OVER STYCYCLES
+
+Have to adjust by defined 1st day of week.
+
+
+
+
+( Lots -- 6? -- of 0s left behind on modern Forths. )
+
+
 ( 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. )
@@ -433,159 +804,4 @@ CELLWIDTH - ALLOT ( Back up to store values. )
 
 
 
-( Below here is scratch work I'm leaving for my notes. )
-( It can be deleted. )
-
-: oldSU1MONTH ( startfractional startdays -- endfractional enddays )
-  FDMONTH + ( Add the whole part. )
-  SWAP ( Make the fractional part available to work on. )
-  MNUMERATOR + ( Add the fractional part. )
-  DUP MDENOMINATOR < ( Have we got a whole day yet? )
-  IF 
-    SWAP ( No, restore stack order for next pass. )
-  ELSE
-    MDENOMINATOR - ( Take one whole day from the fractional part. )
-    SWAP 1+ ( Restore stack and add the day carried in. )
-  ENDIF
-;
-
-: oldPRMONTH ( fractional days -- fractional days )
-  SPACE DUP PSNUM POINT ( whole days )
-  OVER 1000 UM* ( Fake three digits of decimal precision. )
-  MROUNDFUDGE 0 D+ ( Round the bottom digit. )
-  MDENOMINATOR FM/MOD ( Divide, or evaluate the fraction. )
-  S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
-  TYPE ( Fake decimal output. )
-  DROP SPACE 
-;
-
-: oldSH1IDEALYEAR ( year daysmemory fractional days -- year daysmemory fractional days )
-  CR
-  12 0 DO 
-    3 LC@ PSNUM SPACE ( year )
-    I PSNUM COLON SPACE
-    oldSU1MONTH 
-    DUP 3 LC@ - ( difference in days )
-    2 LC@ ( ceiling ) IF 1+ ENDIF 
-    DUP PSNUM SPACE ( show theoretical days in month )
-    3 LC@ + ( sum of days ) 
-    LPAREN DUP PSNUM COMMA SPACE 
-    2 LC! ( update )
-    oldPRMONTH RPAREN CR
-  LOOP
-;
-
-: oldSHOWIDEALMONTHS ( years -- )
-  >R
-  0 0 0 0 ( year, daysmemory, fractional, days )
-  R> 0 DO
-    CR
-    oldSH1IDEALYEAR
-    3 LC@ 1+ 3 LC!
-  LOOP
-  DROP DROP DROP DROP
-;
-
-: oldSH1YEAR ( year daysmemory fractional days -- year daysmemory fractional days )
-  CR
-  12 0 DO 
-    3 LC@ PSNUM SPACE ( year )
-    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
-;
-
-: oldSHOWMONTHS ( 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
-;
-
-: 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 )
-
 

--- a/lunar.fs
+++ b/lunar.fs
@@ -44,7 +44,7 @@ year/longmontha
 ( fastmoon is in prograde orbit with xhilr and tidelocked, )
 ( slowmoon is retrograde orbit with xhilr and not tidelocked, retrograde rotation in equilibrium with slowmoon ) 
 
-( Full double solar eclipse  )
+( Full double solar eclipse on death? )
 
 
 : U/R >R R U/ SWAP 2 * 0 R> U/ SWAP DROP + ;

--- /dev/null
+++ b/stringheader.c
@@ -0,0 +1,55 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+typedef struct string_header_s 
+{  short length; 
+   char string[ 1 ];
+} string_header_t;
+
+char bigblock[ 100000 ];
+char * here = bigblock;
+
+string_header_t * string_allocate( long length )
+{  char * place = here;;
+   if ( ( place = here + length + sizeof (string_header_t) ) >= bigblock + 100000 )
+   {  return NULL;
+   }
+   here = place;
+   ( (string_header_t *) place )->length = length;
+   return (string_header_t *) place;
+}
+
+string_header_t * string_save( char string[] )
+{  long length = strlen( string );
+   string_header_t * headerp = string_allocate( length );
+   memcpy( headerp->string, string, length );
+   headerp->string[ length ] = '\0';
+   return headerp;
+}
+
+void print_string( string_header_t * header )
+{  int i;
+   for ( i = 0; i < header->length; ++i )
+   {  putchar( header->string[ i ] );
+   }   
+}
+
+
+int main ( int argc, char * argv[] )
+{  string_header_t * thing;
+
+puts( "before thing" );
+
+   thing = string_save( "hello" );
+
+puts( "after thing" );
+
+   /* ... */ 
+
+   print_string( thing );
+   putchar( '\n' );
+
+   return EXIT_SUCCESS;
+}
+