( 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: ) ( ) ( ) ( ) ( Novel table of contents and preface here: ) ( . ) ( 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 ) ( . ) ( 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: . ) ( HTML documentation can be found on the web at ) ( ) ( which includes a tutorial for experienced programmers. ) ( An easier tutorial for Forth can be found at ) ( .) ( 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 ) ( , ) ( but if you want to play with that, you'll have to compile it yourself. ) ( Look in the wiki at 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: . ( 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 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 )