Pastebin: econmonths.fs

Formato

Plain text

Post date

2017-04-11 01:35

Publication Period

Unlimited

 ( 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>.
  
 
 ( 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. )
 
 
 ( UM*, FM/MOD, and S>D are already there in most modern Forths. )
 ( These definitions are only for ancient Forths, )
 ( 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 )
 
 ( 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 )
 
 ( : S>D S->D ; ) ( Modern name for single-to-double. )
 
 ( Showing the above in infix won't help. )
 
 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.  )
 
 ( 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 *  ( Skip over the stack address on stack. )
   SP@ + @  ( Assumes push-down stack. Will fail on push-up. )
 ;
 
 ( Infix will be confusing here, too. )
 : LC! ( n index -- ) ( 0 is top. Just store. This is not ROLL. )
   2 + CELLWIDTH *  ( Index and stack address are extra on stack during calculation. )
   SP@ +  ( Assumes push-down stack. )
   ! ( *** Will fail in MISERABLE ways on push-up stacks! *** )
 ;
 
 ( Make things easier to read. )
 ( Infix will be confusing here, too. )
 
 : PRCH EMIT ;
 
 : COMMA 44 PRCH ;
 : COLON 58 PRCH ;
 : POINT 46 PRCH ;
 : LPAREN 40 PRCH ;
 : RPAREN 41 PRCH ;
 
 ( No trailing space. )
 : PSNUM ( number -- )
  0 .R ;
 
 
 ( 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 )
 ( DPSCYCLE SPMCYC * CONSTANT DPMCYCLE )
 ( DPMCYCLE = DPSCYCLE × SPMCYC )
 ( DPMCYCLE MP2LCYC * CONSTANT DP2LCYCLE )
 ( DP2LCYCLE = DPMCYCLE × MP2LCYC )
 ( DPMCYCLE and DP2LCYCLE would overflow on 16 bit math CPUs. ) 
 ( No particular problem on 32 bit CPUs.
 
 RDSCYCLE SPMCYC * 1 - CONSTANT RDMCYCLE ( remainder days in medium cycle )
 ( RDMCYCLE = RDSCYCLE × SPMCYC - 1 )
 
 RDMCYCLE MP2LCYC * 2 + CONSTANT RD2LCYCLE ( remainder days in double long cycle -- odd number )
 ( RD2LCYCLE = RDMCYCLE × MP2LCYC + 2 )
 ( RD2LCYCLE / 2LCYCLE is fractional part of year. )
 ( Ergo, length of year is DPSKIPYEAR + RD2LCYCLE / 2LCYCLE, )
 ( or 352 485/686 days. )
 
 12 CONSTANT MPYEAR ( months per year )
 
 DPSKIPYEAR MPYEAR /MOD CONSTANT FDMONTH ( floor of days per month )
 ( FDMONTH = DPSKIPYEAR / MPYEAR )
 CONSTANT FRMONTH ( floored minimum remainder days per month )
 ( FRMONTH = DPSKIPYEAR MOD MPYEAR )
 
 2LCYCLE MPYEAR * CONSTANT MDENOMINATOR ( denominator of month fractional part )
 ( MDENOMINATOR = 2LCYCLE × MPYEAR  )
 
 FRMONTH 2LCYCLE * RD2LCYCLE + CONSTANT MNUMERATOR ( numerator of month fractional part )
 ( MNUMERATOR  = FRMONTH × 2LCYCLE + RD2LCYCLE )
 ( Ergo, length of month is FDMONTH + MNUMERATOR / MDENOMINATOR, )
 ( or 29 3229/8232 days. )
 
 MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
 
 ( Infix will be confusing below here, as well. )
 ( Hopefully, the comments and explanations will provide enough clues. )
 
 ( Sum up the days of the months in a year. )
 : SU1MONTH ( startfractional startdays -- endfractional enddays )
   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
 ;
 
 : PRMONTH ( fractional days -- fractional days )
   SPACE DUP PSNUM POINT ( whole days )
   OVER 1000 UM* ( Fake three digits of decimal precision. )
   MROUNDFUDGE 0 D+ ( Round the bottom digit. )
   MDENOMINATOR FM/MOD ( Divide, or evaluate the fraction. )
   S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
   TYPE ( Fake decimal output. )
   DROP SPACE 
 ;
 
 : SH1IDEALYEAR ( year daysmemory fractional days -- year daysmemory fractional days )
   CR
   12 0 DO 
     3 LC@ PSNUM SPACE ( year )
     I PSNUM COLON SPACE
     SU1MONTH 
     DUP 3 LC@ - ( difference in days )
     2 LC@ ( ceiling ) IF 1+ ENDIF 
     DUP PSNUM SPACE ( show theoretical days in month )
     3 LC@ + ( sum of days ) 
     LPAREN DUP PSNUM COMMA SPACE 
     2 LC! ( update )
     PRMONTH RPAREN CR
   LOOP
 ;
 
 : SHOWIDEALMONTHS ( years -- )
   >R
   0 0 0 0 ( year, daysmemory, fractional, days )
   R> 0 DO
     CR
     SH1IDEALYEAR
     3 LC@ 1+ 3 LC!
   LOOP
   DROP DROP DROP DROP
 ;
 
   0 CONSTANT SKMONTH
   1 CONSTANT SK1SHORTCYC
   4 CONSTANT SK2SHORTCYC
  48 CONSTANT SKMEDIUMCYC
 186 CONSTANT LPLONGCYC  ( Must be short1 or short2 within the seven year cycle. )
 
 ( Since skipyears are the exception, )
 ( we test for skipyears instead of leapyears. )
 ( Calendar system starts with year 0, not year 1. )
 ( Would need to check and adjust if the calendar started with year )
 : ISKIPYEAR ( year -- flag )
   DUP MCYCLE MOD SKMEDIUMCYC =
   IF DROP -1  ( One specified extra skip year in medium cycle. )
   ELSE
     DUP SCYCLE MOD DUP
     SK1SHORTCYC =
     SWAP SK2SHORTCYC = OR  ( Two specified skip years in short cycle, but ... )
     SWAP LCYCLE MOD LPLONGCYC = 0= AND ( not the specified exception in the long cycle. )
   ENDIF
 ;
 
 
 ( At this point, I hit a condundrum. )
 ( Modern "standard" Forths want uninitialized variables, )
 ( but ancient, especially fig-Forths want initialized variables. )
 ( The lower-level <BUILDS DOES> for fig is only partially part of the modern standard. )
 ( And CREATE is initialized as a CONSTANT in the fig-Forth, )
 ( but has no initial characteristic code or value in modern standards. )
 ( So. )
 ( On ancient Forths, VARIABLE wants an initial value. We give it a zero. )
 ( The zero stays around forever on modern Forths, or until you drop it. )
 0 VARIABLE DIMARRAY  ( Days In Months array )
    30 DIMARRAY !  ( 1st month )
    29 ,
    30 ,
    29 ,
    29 ,
    30 ,
    29 ,
    30 ,
    29 ,
    29 ,
    30 ,
    29 ,
    0 ,
 
 : DIMONTH ( year month -- days )
   DUP 0 < 0=
   OVER MPYEAR < AND 0= 
   IF
     DROP DROP 0  ( Out of range. No days. )
   ELSE
     DUP CELLWIDTH * DIMARRAY + @  ( Get the basic days. )
     SWAP SKMONTH =  ( true if skip month )
     ROT ISKIPYEAR AND  ( true if skip month of skip year )
     1 AND - ( Subtrahend is 1 only if skip month of skip year. )
   ENDIF 
 ;
     
 : SH1YEAR ( year daysmemory fractional days -- year daysmemory fractional days )
   CR
   12 0 DO 
     3 LC@ PSNUM SPACE ( year )
     I PSNUM COLON SPACE
     SU1MONTH  ( ideal month )
     3 LC@ I DIMONTH  ( real month )
     DUP PSNUM SPACE ( show days in month )
     3 LC@ + ( sum of days ) 
     LPAREN DUP PSNUM COMMA SPACE 
     2 LC! ( update )
     PRMONTH RPAREN CR
   LOOP
 ;
 
 : SHOWMONTHS ( years -- )
   >R
   0 0 0 0 ( year, daysmemory, fractional, days )
   R> 0 DO
     CR
     SH1YEAR
     3 LC@ 1+ 3 LC!
   LOOP
   DROP DROP DROP DROP
 ;
   
 
 ( Below here is scratch work I'm leaving for my notes. )
 ( It can be deleted. )
 
 : V2-SHOWMONTHS ( years -- )
   >R
   0 0 0 ( daysmemory, fractional, days )
   R> 0 DO
     CR
     12 0 DO 
       J PSNUM SPACE ( year )
       I PSNUM COLON SPACE
       SU1MONTH 
       DUP 3 LC@ - ( difference in days )
       2 LC@ ( ceiling ) IF 1+ ENDIF 
       DUP PSNUM SPACE ( show theoretical days in month )
       3 LC@ + ( sum of days ) 
       LPAREN DUP PSNUM COMMA SPACE 
       2 LC! ( update )
       PRMONTH RPAREN CR
     LOOP 
   LOOP
   DROP DROP DROP 
 ;
 
 
 : NUMERATORS ( count -- )
 DUP 1+ 0 DO 
    I PSNUM COLON SPACE
    I 1000 * OVER / PSNUM COMMA ( 1000 times I divided by count )
    SPACE LOOP 
 DROP ;
 
 : FRACTIONS ( count -- )
 1 DO 
    I NUMERATORS CR 
 LOOP ;
 
 ( : ABS  number -- absolute-value *** built in! *** )
 ( DUP 0< IF NEGATE THEN ; )
 
 : WITHIN1 ( n1 n2 -- flag ) 
  - ABS 1 <= ; ( n1 and n2 are within 1 of each other )
 
 ( Negatives end in division by zero or infinite loop. )
 : SQRT ( number -- square-root )
 DUP IF ( square root of zero is zero. )
   ABS 
   2 ( initial guess )
   BEGIN
     OVER OVER / ( test guess by divide ) 
     OVER OVER - ABS 1 <= ( number guess quotient flag )
     IF ( number guess quotient )
       MIN -1 ( number result flag )
     ELSE
       OVER + 2 / ( number guess avg )
       SWAP OVER ( number avg guess avg )
       - 1 <= ( number avg flag ) ( Integer average will always be floored. )
     ENDIF
   UNTIL ( number result )
   SWAP DROP
 ENDIF ;
 
 
 353 CONSTANT DPYEAR ( nominal days per year )
 
 7 CONSTANT 7YEARS
 
 2 CONSTANT DS7CYCLE ( days short in seven year cycle )
 
 DPYEAR 7YEARS * DS7CYCLE - CONSTANT DP7YEAR ( whole days per 7 year cycle )
 
 7YEARS 7 2 * * CONSTANT 98YEARS
 
 98YEARS 7YEARS / DS7CYCLE * 1 + CONSTANT DS98CYCLE ( days short in 98 year cycle )
 
 98YEARS 7 * CONSTANT 686YEARS 
 
 686YEARS 98YEARS / DS98CYCLE * 2 - CONSTANT DS686CYCLE ( days short in 686 year cycle )