• R/O
  • HTTP
  • SSH
  • HTTPS

Commit

Tags
No Tags

Frequently used words (click to add to your profile)

javac++androidcocoaobjective-cc#誰得gamephpbathyscapheqtrubyclinuxomegat翻訳pythontwitterwindowsbtronvb.nettestframeworkgui計画中(planning stage)directxpreviewerpukiwikidommruby

Functions for working with the idealized calendar of Planet Xhilr


Commit MetaInfo

Revision746c818c56c8880b88dea46b9f10f414d5d2476b (tree)
Time2017-06-13 18:09:13
AuthorJoel Matthew Rees <joel.rees@gmai...>
CommiterJoel Matthew Rees

Log Message

cycles and the digging into the actual calendar

Change Summary

Incremental Difference

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -23,17 +23,17 @@
2323 ( In gforth and most modern or emulated environments, )
2424 ( just paste it into the terminal of a running Forth session. )
2525
26-( Run it with
26+( Run it with )
2727
28- 7 SHOWIDEALMONTHS
28+( 7 SHOWIDEALMONTHS )
2929
30- for seven years, etc. )
30+( for seven years, etc. )
3131
3232 ( gforth can be found in the repositories at )
3333 ( <https://www.gnu.org/software/gforth/>. )
3434
3535 ( It can also be obtained as a package from most modern OS distributions )
36-( and in many applications stores (Android, yes, iOS, not yet for a while). )
36+( and in many applications stores -- Android, yes, iOS, not yet for a while. )
3737 ( Or, for MSWindows, you can get it through Cygwin: <https://www.cygwin.com/>. )
3838
3939 ( HTML documentation can be found on the web at )
@@ -41,7 +41,7 @@
4141 ( which includes a tutorial for experienced programmers. )
4242
4343 ( An easier tutorial for Forth can be found at )
44-( <https://www.forth.com/starting-forth/>.)
44+( <https://www.forth.com/starting-forth/>. )
4545
4646 ( There is a newsgroup: comp.lang.forth, )
4747 ( which can be accessed from the web via, for example, Google newsgroups. )
@@ -154,19 +154,19 @@ SP@ SP@ - ABS CONSTANT CELLWIDTH
154154 ;
155155
156156 ( Left shifts can be done with addition. )
157-: SUM2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest, not too slow. )
158-: SUMD2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
159-: SLOWQ2* ( uq1 --- uq2 : Double the top double cell. Not fastest. )
160- SUMD2* >R OVER 0< IF
157+: SUM-2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest, not too slow. )
158+: SUM-D2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
159+: SLOW-Q2* ( uq1 --- uq2 : Double the top double cell. Not fastest. )
160+ SUM-D2* >R OVER 0< IF
161161 1 OR ( carry )
162162 THEN
163163 >R
164- SUMD2*
164+ SUM-D2*
165165 R> R> ;
166166
167167 : MY-BIT-COUNTER ( --- u ) ( Let's figure out how wide a CELL is. )
168168 0. 1. BEGIN
169- SUMD2* 2SWAP 1. D+ 2SWAP SP@ @
169+ SUM-D2* 2SWAP 1. D+ 2SWAP SP@ @
170170 UNTIL 2DROP DROP ;
171171
172172 MY-BIT-COUNTER CONSTANT CELLBITS
@@ -341,12 +341,12 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
341341 ( Some dividends will overflow quotient, not valid for such cases. )
342342 ( Intended to be used for known products of two doubles.
343343 ( AL AML AMH AH BL BH --- RL RH QL QH : unsigned quad by unsigned double yielding unsigned double )
344-: MOLASSES-UMD/MOD ( uqdividend uddivisor --- udremainder udquotient )
344+: SLOW-UMD/MOD ( uqdividend uddivisor --- udremainder udquotient )
345345 DUP 0= IF
346346 DROP UQS/MOD 2DROP 0 ROT ROT ( Get divisor high word 0 easy case done quickly. )
347347 ELSE
348348 2ROT 2ROT ( Get the divisor out of the way, but accessible with pick. )
349- CELLBITS SUM2* 1+ >R ( Count )
349+ CELLBITS SUM-2* 1+ >R ( Count )
350350 0 >R ( Force flag )
351351 BEGIN ( BL BH AL AML AMH AH ) ( [ count force ] )
352352 2DUP ( high double of dividend : BL BH AL AML AMH AH AMH AH )
@@ -361,7 +361,7 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
361361 ( BL BH AL AML bit ) ( [ count AH AMH ] )
362362 OVER >R ( Remember the carry from bottom to top half -- AML. )
363363 ( BL BH AL AML bit ) ( [ count AH AMH AML ] )
364- >R SUMD2* ( Save subtraction flag and shift the bottom half: AL AML. )
364+ >R SUM-D2* ( Save subtraction flag and shift the bottom half: AL AML. )
365365 ( BL BH sAL rsAML ) ( [ count AH AMH AML bit ] )
366366 SWAP ( BL BH rsAML sAL ) ( [ count AH AMH AML bit ] )
367367 R> OR SWAP ( Record the subtraction in emptied bit of remainder. )
@@ -374,7 +374,7 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
374374 WHILE ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount ] )
375375 DUP 0< >R ( Remember the high bit of the remainder, to force subtract. )
376376 ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount newforce ] )
377- SUMD2* ( BL BH rsAL rsAML carry sAMH rsAH ) ( [ newcount newforce ] )
377+ SUM-D2* ( BL BH rsAL rsAML carry sAMH rsAH ) ( [ newcount newforce ] )
378378 >R OR R> ( Shift the remainder, with the bit from the low half. )
379379 ( BL BH rsAL rsAML rsAMH rsAH ) ( [ newcount newforce ] )
380380 REPEAT ( BL BH rsAL rsAML rsAMH rsAH ) ( [ newcount newforce ] )
@@ -386,19 +386,6 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
386386 THEN
387387 ;
388388
389-( If your 16-bit Forth has UD/MOD, uncomment this and comment out the fake! *********** )
390-( : JUD/MOD UD/MOD ; ( uqdividend uddivisor -- udremainder udquotient : If it exists. )
391-( If UD/MOD does not exist and we are working on 32 or 64 bit, fake it. )
392-( But make it safe! )
393-: JUD/MOD ( uqdividend uddivisor -- udremainder udquotien : fake double division )
394-
395- CELLWIDTH 4 < 0= IF
396- DROP >R 2DROP R> JM/MOD
397- ELSE ( Things get hairy! )
398-
399- THEN ;
400-( In 32-bit or more, get rid of unneeded stuff and use single division. )
401-
402389
403390 ( Make things easier to read. )
404391 ( Infix will be confusing here, too. )
@@ -410,6 +397,10 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
410397 : POINT 46 PRCH ;
411398 : LPAREN 40 PRCH ;
412399 : RPAREN 41 PRCH ;
400+: VBAR 124 EMIT ;
401+: PLUS 43 EMIT ;
402+: DASH 45 EMIT ;
403+: STAR 42 EMIT ;
413404
414405 ( No trailing space. )
415406 : PSNUM ( number -- )
@@ -514,7 +505,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
514505 ELSE
515506 MDENOMINATOR - ( Take one whole day from the fractional part. )
516507 ROT ROT 1 S>D D+ ( Restore stack and add the day carried in. )
517- ENDIF
508+ THEN
518509 ;
519510
520511 : PRMONTH ( fractional ddays -- fractional ddays )
@@ -534,7 +525,7 @@ MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
534525 I PSNUM COLON SPACE
535526 SU1MONTH
536527 2DUP 5 DLC@ D- ( difference in days )
537- 4 LC@ ( push difference to ceiling ) IF 1. D+ ENDIF
528+ 4 LC@ ( push difference to ceiling ) IF 1. D+ THEN
538529 2DUP PSDNUM SPACE ( show theoretical days in month )
539530 5 DLC@ D+ ( sum of days: adjusted difference plus daysmemory )
540531 LPAREN 2DUP PSDNUM COMMA SPACE
@@ -566,14 +557,17 @@ LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2
566557 ( Calendar system starts with year 0, not year 1. )
567558 ( Would need to check and adjust if the calendar started with year )
568559 : ISKIPYEAR ( year -- flag )
569- DUP MCYCLE MOD SKMEDIUMCYC =
560+ DUP 0< IF
561+ NEGATE 2LCYCLE MOD 2LCYCLE SWAP -
562+ THEN
563+ DUP MCYCLE MOD SKMEDIUMCYC =
570564 IF DROP -1 ( One specified extra skip year in medium cycle. )
571565 ELSE
572566 DUP SCYCLE MOD DUP
573567 SK1SHORTCYC =
574568 SWAP SK2SHORTCYC = OR ( Two specified skip years in short cycle, but ... )
575569 SWAP LCYCLE MOD LPLONGCYC = 0= AND ( not the specified exception in the long cycle. )
576- ENDIF
570+ THEN
577571 ;
578572
579573
@@ -585,9 +579,9 @@ LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2
585579 ( but has no initial characteristic code or value in modern standards. )
586580 ( So. )
587581 ( On ancient Forths, VARIABLE wants an initial value. We give it a zero. )
582+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
588583 ( The zero stays around forever on modern Forths, or until you drop it. )
589584 0 VARIABLE DIMARRAY ( Days In Months array )
590-( Modern Forths don't initialize, will leave 0 on stack. )
591585
592586 CELLWIDTH NEGATE ALLOT ( Back up to store values. )
593587
@@ -605,7 +599,15 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
605599 29 C,
606600 0 ,
607601
602+( Accept one year year plus or minus, to help calendar on first and last month. )
608603 : DIMONTH ( year month -- days )
604+ DUP 0< IF
605+ SWAP 1 - SWAP 12 +
606+ ELSE
607+ DUP MPYEAR < 0= IF
608+ SWAP 1 + SWAP 12 -
609+ THEN
610+ THEN
609611 DUP 0 < 0=
610612 OVER MPYEAR < AND 0=
611613 IF
@@ -615,7 +617,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
615617 SWAP SKMONTH = ( true if skip month )
616618 ROT ISKIPYEAR AND ( true if skip month of skip year )
617619 1 AND - ( Subtrahend is 1 only if skip month of skip year. )
618- ENDIF
620+ THEN
619621 ;
620622
621623 : SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
@@ -711,7 +713,7 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
711713 ;
712714
713715 ( Saturates on month > 12. Generally use to month 11. )
714-: DTM ( year month --- days ) ( Just the days from the beginning of the year. )
716+: DTM ( uyear umonth --- days ) ( Just the days from the beginning of the year. )
715717 DUP IF
716718 0 SWAP 0 DO
717719 OVER I DIMONTH +
@@ -723,15 +725,19 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
723725
724726 0 VARIABLE CALENDAR-WIDTH
725727 80 CALENDAR-WIDTH !
728+( But we won't use this because we don't have real strings. )
726729
730+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
727731 0 VARIABLE DAYCOUNT
728-0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. Modern Forths leave a zero. )
732+0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. )
729733
730734
731735 0 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. )
732-0 CONSTANT 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
736+0 VARIABLE 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
737+0 1STDAYOFWEEK !
733738
734-0 VARIABLE DOWKSTATE ( Current day of week. Modern Forths leave a zero. )
739+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
740+0 VARIABLE DOWKSTATE ( Current day of week. )
735741
736742 7 CONSTANT DPWK ( Days per week. )
737743
@@ -752,9 +758,11 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
752758 0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
753759 0 CONSTANT SMOFFFRAC10976 ( Fractional part. )
754760
755-0 VARIABLE SMSTATEINT ( Slow moon state integer part. Modern Forths leave a zero. )
761+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
762+0 VARIABLE SMSTATEINT ( Slow moon state integer part. )
756763 0 SMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
757-0 VARIABLE SMSTATEFRAC10976 ( Fractional part. Modern Forths leave a zero. )
764+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
765+0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
758766 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
759767
760768
@@ -769,20 +777,25 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
769777 0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. )
770778 0 CONSTANT FMOFFFRAC10976 ( Fractional part. )
771779
772-0 VARIABLE FMSTATEINT ( Fast moon state integer part. Modern Forths leave a zero. )
780+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
781+0 VARIABLE FMSTATEINT ( Fast moon state integer part. )
773782 0 FMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
774-0 VARIABLE FMSTATEFRAC10976 ( Fractional part. Modern Forths leave a zero. )
783+( Modern Forths initialize to 0, will leave the 0 given here on the stack. )
784+0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
775785 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
776786
777787
778-: WSTYCYCLES ( year --- ) ( Start the weekday counter for the year, keep the days. )
779- DTY 2DUP DAYCOUNT D!
788+( Start the weekday counter for the year and month, remember the days. )
789+: WKSTCYCLES ( uyear umonth --- )
790+ OVER DTY
791+ 2SWAP DTM 0 D+
792+ 2DUP DAYCOUNT D!
780793 WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE !
781794 ;
782795
783-: SSTYCYCLES ( ddays --- ) ( Start the slowmoon cycle counter for the year. )
784- DECYCLE UDS* DROP SMPERIOD10976 DROP JM/MOD >R >R S>D R> R> ( 32-bit, 64-bit )
785-( DECYCLE S>D UMD* SMPERIOD10976 UD/MOD ( 16-bit )
796+( Start the slowmoon cycle counter by the day count. )
797+: SLOMSTCYCLES ( ddays --- )
798+ DECYCLE S>D UMD* SMPERIOD10976 SLOW-UMD/MOD
786799 2SWAP SMOFFFRAC10976 S>D D+
787800 2DUP SMPERIOD10976 D< 0= IF
788801 SMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
@@ -791,9 +804,9 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
791804 SMOFFINT S>D D+ SMSTATEINT D!
792805 ;
793806
794-: FSTYCYCLES ( ddays --- ) ( Start the fastmoon cycle counter for the year. )
795- DECYCLE UDS* DROP FMPERIOD10976 DROP JM/MOD >R >R S>D R> R> ( 32-bit, 64-bit )
796-( DECYCLE S>D UMD* FMPERIOD10976 UD/MOD ( 16-bit )
807+( Start the fastmoon cycle counter by the day count. )
808+: FASMSTCYCLES ( ddays --- )
809+ DECYCLE S>D UMD* FMPERIOD10976 SLOW-UMD/MOD
797810 2SWAP FMOFFFRAC10976 S>D D+
798811 2DUP FMPERIOD10976 D< 0= IF
799812 FMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
@@ -802,42 +815,26 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
802815 FMOFFINT S>D D+ FMSTATEINT D!
803816 ;
804817
805-: STYCYCLES ( year --- ) ( Start the counters for the year. )
806- WSTYCYCLES
807- DAYCOUNT D@ 2DUP SSTYCYCLES FSTYCYCLES
818+: STYCYCLES ( year month --- ) ( Start the counters for the year. )
819+ WKSTCYCLES
820+ DAYCOUNT D@ 2DUP SLOMSTCYCLES FASMSTCYCLES
808821 ;
809822
810-: STMCYCLES ( year month --- ) ( The year is started, start the month. )
811- DTM 0 DAYCOUNT D@ D+ 2DUP DAYCOUNT !
812- 2DUP DPWK JM/MOD 2DROP DOWKSTATE ! ( Overwrite the state, don't sum it. )
813-
814-;
815-
816-
817-
818-: PRMONTH ( year month day --- )
819- >R OVER STYCYCLES
820-
821-Have to adjust by defined 1st day of week.
822-
823-
824-
825-
826-( Lots -- 6? -- of 0s left behind on modern Forths. )
823+( : TEST STYCYCLES DAYCOUNT D@ D. CR SMSTATEINT D@ D. CR SMSTATEFRAC10976 D@ D. CR )
824+( FMSTATEINT D@ D. CR FMSTATEFRAC10976 D@ D. CR ; )
827825
828826
829827 ( Ancient Forths do not have standard WORDs, )
830828 ( and that makes it hard to have portable arrays of strings for those Forths. )
831-: TPWDAY ( n --- ) ( TYPE the name of the day of the week. )
829+: TPWDAY ( n --- ) ( TYPE the name of the day of the week, modulo. )
830+ DPWK MOD
832831 DUP 0 = IF ." Sunday " ELSE ( Fake case format to line the strings up. )
833832 DUP 1 = IF ." Moonsday" ELSE
834833 DUP 2 = IF ." Aegisday" ELSE
835- DUP 3 = IF ." Gefnday" ELSE
836- DUP 4 = IF ." Freyday" ELSE
837- DUP 5 = IF ." Tewesday" ELSE
838- DUP 6 = IF ." Vensday" ELSE ( DUP here allows final single DROP. )
839- ." ??? "
840- THEN
834+ DUP 3 = IF ." Gefnday " ELSE
835+ DUP 4 = IF ." Freyday " ELSE
836+ DUP 5 = IF ." Tewesday" ELSE ( DUP here allows final single DROP. )
837+ ." Vensday "
841838 THEN
842839 THEN
843840 THEN
@@ -846,6 +843,8 @@ Have to adjust by defined 1st day of week.
846843 THEN
847844 DROP ;
848845
846+8 CONSTANT DWIDTH
847+
849848 : TPMONTH ( n --- ) ( TYPE the name of the month. )
850849 ( DUP 6 < IF * Use this if the compile stack overflows. )
851850 DUP 0 = IF ." Time-division" ELSE ( Fake case format to line the strings up. )
@@ -863,7 +862,7 @@ Have to adjust by defined 1st day of week.
863862 DUP 9 = IF ." Harvest " ELSE
864863 DUP 10 = IF ." Gratitude " ELSE
865864 DUP 11 = IF ." Winter-month" ELSE ( DUP here allows final single DROP. )
866- ." ???"
865+ ." ??? "
867866 THEN
868867 THEN
869868 THEN
@@ -880,6 +879,112 @@ Have to adjust by defined 1st day of week.
880879 ( THEN )
881880 DROP ;
882881
882+13 CONSTANT MWIDTH
883+
884+CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
885+
886+: WLINELENGTH CALENDAR-WIDTH @ DPWK / DPWK * ;
887+
888+: DASHES ( count --- ) ( EMIT a string of count DASHes. )
889+ DUP 0 > IF
890+ 0 DO DASH LOOP
891+ ELSE
892+ DROP
893+ THEN
894+;
895+
896+: HLINE ( --- )
897+ PLUS
898+ DPWK 0 DO
899+ DFIELD DASHES PLUS
900+ LOOP
901+ CR
902+;
903+
904+: SPLINE ( --- )
905+ VBAR
906+ DPWK 0 DO
907+ DFIELD SPACES VBAR
908+ LOOP
909+ CR
910+;
911+
912+: PWKDAYS ( --- ) ( Adjust by 1STDAYOFWEEK. )
913+ VBAR
914+ DFIELD DWIDTH - 1 - 2 /MOD
915+ SWAP OVER +
916+ 1STDAYOFWEEK @ DUP DPWK + SWAP
917+ DO
918+ DUP SPACES
919+ I TPWDAY
920+ DUP SPACES OVER SPACES
921+ VBAR
922+ LOOP CR
923+ DROP DROP
924+;
925+
926+: BOLD ( n1 n2 --- n1 n2 )
927+ 2DUP = IF STAR ELSE SPACE THEN ;
928+
929+: PDFIELD ( day today --- day today ) ( Print one numeric day field, emphasis on today. )
930+ DFIELD 4 - 2 /MOD SWAP ( day today half rem )
931+ OVER + ( day today half rem+half )
932+ SPACES >R ( day today ) ( [ half ] )
933+ BOLD OVER 2 .R BOLD ( day today ) ( [ half ] )
934+ R> SPACES
935+ VBAR
936+;
937+
938+: DAYLINE ( rollover start today --- ) ( DPWK days from start, from 0 at rollove )
939+ >R ( rollover start ) ( [ today ] )
940+ VBAR
941+ DPWK 0 DO
942+ 2DUP > 0= IF DROP 0 THEN ( rollover day ) ( [ today ] )
943+ R> PDFIELD >R
944+ 1+
945+ LOOP
946+ R> DROP
947+ DROP DROP
948+;
949+
950+
951+: CALMONTH ( year month day --- )
952+ CR
953+ WLINELENGTH MWIDTH - 2 - 2 / SPACES
954+ ROT DUP 4 .R SPACE
955+ ROT DUP TPMONTH CR
956+ HLINE
957+ PWKDAYS
958+ HLINE
959+ SPLINE
960+ ROT ROT ( Save day away. )
961+ 2DUP STYCYCLES
962+ DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
963+ DUP ( Save back up count. )
964+ IF
965+ back up phases of moons to beginning of week
966+ >R 1 - DIMONTH ( Of previous month. )
967+ DUP R> - ( day rollover start )
968+ DAYLINE
969+ print phases of moons
970+ add dPWK to start
971+ calculate rolloever of current month.
972+ ELSE
973+ drop DIMONTH ( Of current month. )
974+ set start to zero
975+ THEN
976+ BEGIN
977+
978+
979+ pass rollover UNTIL
980+
981+;
982+
983+
984+
985+
986+( Lots -- 7? -- of 0s left behind on modern Forths. )
987+
883988
884989
885990