• 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

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

Log Message

at this point it more or less runs

Change Summary

Incremental Difference

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -69,6 +69,8 @@
6969 ( Using baroque identifiers for ancient Forths. )
7070 ( fig-Forth used first three character + length significance in symbol tables. )
7171
72+( And I should do this all in hexadecimal, to get a more accurate flavor. )
73+
7274
7375 ( INVERT, UM*, UM/MOD, S>D, 2DUP, and D- are already there in most modern Forths. )
7476 ( These definitions are only for ancient Forths, without the full set loaded, )
@@ -417,6 +419,7 @@ CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
417419 : PLUS 43 EMIT ;
418420 : DASH 45 EMIT ;
419421 : STAR 42 EMIT ;
422+: ZERO 48 EMIT ;
420423
421424 ( No trailing space. )
422425 : PSNUM ( number -- )
@@ -762,6 +765,12 @@ CELLWIDTH NEGATE ALLOT ( Back up to store values. )
762765 7 CONSTANT DPWK ( Days per week. )
763766
764767
768+16 CONSTANT JIRPERDAY ( About 90 minutes. )
769+16 CONSTANT GOBUPERJIR ( About 5.6 minutes. )
770+16 CONSTANT BUNEIGHPERGOB ( About 21 seconds. )
771+16 CONSTANT MYOTPERBUNEIGH ( About 13 seconds. )
772+
773+
765774 ( For the cycles use scaled 485 / 686, keep scale in 16 bits. )
766775 RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
767776 2LCYCLE 16 * CONSTANT DECYCLE ( denominator: 10976 )
@@ -773,8 +782,6 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
773782 ( Fake DCONSTANT: )
774783 : SMPERIOD10976 [ SMPERIODINT DECYCLE UM* SMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ;
775784 ( 28 9645 / 10976 == 316973 / 10976 )
776-: SM16THPERIOD10976 SMPERIOD10976 JM/MOD ROT DROP
777-
778785
779786 0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
780787 0 CONSTANT SMOFFFRAC10976 ( Fractional part. )
@@ -786,6 +793,19 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
786793 0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
787794 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
788795
796+: SM16THPERIOD10976 [ SMPERIOD10976 8. D+ 16 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
797+: SM32NDPERIOD10976 [ SMPERIOD10976 16. D+ 32 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
798+
799+( Could pre-divide the period into 16ths but this is an output function, )
800+( can be a little slow. )
801+: SMSHOWPHASE ( --- ) ( --- ) ( Show the Slowmoon phase with no spacing. )
802+ SMSTATEFRAC10976 D@ SM32NDPERIOD10976 D+ 0. SM16THPERIOD10976 SLOW-UMD/MOD
803+ 2SWAP 2DROP DROP DUP 16 < 0= IF 16 - THEN
804+ ." S:" HEX 0 .R DECIMAL
805+;
806+
807+3 CONSTANT SPHASEWIDTH
808+
789809
790810 ( The smaller moon orbits their world in just under seven and one eighth days, )
791811 ( about forty-nine and a half lunar weeks a year )
@@ -805,6 +825,21 @@ RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
805825 0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
806826 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
807827
828+: FM16THPERIOD10976 [ FMPERIOD10976 8. D+ 16 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
829+: FM32NDPERIOD10976 [ FMPERIOD10976 16. D+ 32 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
830+
831+( Could pre-divide the period into 16ths but this is an output function, )
832+( can be a little slow. )
833+: FMSHOWPHASE ( --- ) ( Show the Fastmoon phase with no spacing. )
834+ FMSTATEFRAC10976 D@ FM32NDPERIOD10976 D+ 0. FM16THPERIOD10976 SLOW-UMD/MOD
835+ 2SWAP 2DROP DROP DUP 16 < 0= IF 16 - THEN
836+ JIRPERDAY 1 - SWAP - ( Retrograde. )
837+ ." F:" HEX 0 .R DECIMAL
838+;
839+
840+3 CONSTANT FPHASEWIDTH
841+
842+
808843 ( Modern Forths will leave the initialization 0 behind. )
809844 0 VARIABLE CYEAR 0 CYEAR !
810845 ( Modern Forths will leave the initialization 0 behind. )
@@ -1049,67 +1084,74 @@ CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
10491084 I TPWDAY
10501085 DUP SPACES OVER SPACES
10511086 VBAR
1052- LOOP CR
1087+ LOOP
1088+ CR
10531089 DROP DROP
10541090 ;
10551091
1056-: BOLD ( n1 n2 --- n1 n2 )
1057- 2DUP = IF STAR ELSE SPACE THEN ;
1092+: BOLD ( n1 n2 --- )
1093+ = IF STAR ELSE SPACE THEN ;
10581094
1059-: PDFIELD ( day today --- day today ) ( Print one numeric day field, emphasis on today. )
1060- DFIELD 4 - 2 /MOD SWAP ( day today half rem )
1061- OVER + ( day today half rem+half )
1062- SPACES >R ( day today ) ( [ half ] )
1063- BOLD OVER 2 .R BOLD ( day today ) ( [ half ] )
1095+: PDFIELD ( day1 day2 --- ) ( Print day2 in day field with emphasis if same as day1. )
1096+ DFIELD 4 - 2 /MOD ( day1 day2 rem half )
1097+ DUP ROT + ( day1 day2 half half+rem )
1098+ SPACES >R ( day1 day2 ) ( [ half ] )
1099+ 2DUP BOLD DUP 2 .R BOLD ( --- ) ( [ half ] )
10641100 R> SPACES
10651101 VBAR
10661102 ;
10671103
1068-: DAYLINE ( rollover start today --- ) ( DPWK days from start, from 0 at rollove )
1069- >R ( rollover start ) ( [ today ] )
1104+( DPWK days from start, emphasize and reset day if matched for month. )
1105+: DAYLINE ( month day --- month daydone )
10701106 VBAR
10711107 DPWK 0 DO
1072- 2DUP > 0= IF DROP 0 THEN ( rollover day ) ( [ today ] )
1073- R> PDFIELD >R
1074- 1+
1108+ OVER CMONTH @ = IF DUP ELSE -1 THEN
1109+ CDATE @
1110+ PDFIELD
1111+ 1 DADJUST
10751112 LOOP
1076- R> DROP
1077- DROP DROP
1113+ CR
10781114 ;
10791115
10801116
1117+: PHLINE ( --- )
1118+ VBAR
1119+ DPWK 0 DO
1120+ SMSHOWPHASE
1121+ DFIELD SPHASEWIDTH - FPHASEWIDTH - SPACES
1122+ FMSHOWPHASE
1123+ VBAR
1124+ 1 SLOMADJ 1 FASMADJ
1125+ LOOP
1126+ CR
1127+;
1128+
10811129 : CALMONTH ( year month day --- )
10821130 CR
1131+ ROT ROT STYCYCLES
1132+ CMONTH @ SWAP ( Remember month and day. )
10831133 WLINELENGTH MWIDTH - 2 - 2 / SPACES
1084- ROT DUP 4 .R SPACE
1085- ROT DUP TPMONTH CR
1134+ CYEAR @ 4 .R SPACE
1135+ CMONTH @ TPMONTH CR
10861136 HLINE
10871137 PWKDAYS
10881138 HLINE
1089- SPLINE
1090- ROT ROT ( Save calendar day away. )
1091- 2DUP STYCYCLES
10921139 DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
10931140 DUP ( Count of days to back up. )
10941141 IF
1095- DUP NEGATE DUP SLOMADJ FASMADJ
1096- >R 2DUP 1 - DIMONTH ( day year month rollover )
1097- 3 LC@ SWAP ( day year month day rollover )
1098- DUP R> - ( day year month day rollover start )
1099- DAYLINE
1100- print phases of moons
1101- add dPWK to start
1102- calculate rolloever of current month.
1142+ NEGATE DMADJUST
11031143 ELSE
1104-
1105- drop DIMONTH ( Of current month. )
1106- set start to zero
1144+ DROP
11071145 THEN
11081146 BEGIN
1109-
1110-
1111- pass rollover UNTIL
1112-
1147+ SPLINE
1148+ DAYLINE
1149+ SPLINE
1150+ SPLINE
1151+ PHLINE
1152+ HLINE
1153+ OVER CMONTH @ < UNTIL
1154+ DROP DROP
11131155 ;
11141156
11151157