提交: 7651eb0d212262ea8c202690ccc3cba681773f5d - xhilr_calendar (git)

Functions for working with the idealized calendar of Planet Xhilr

Commit MetaInfo

• 修订版: 7651eb0d212262ea8c202690ccc3cba681773f5d (tree)
• 时间: 2017-06-13 17:48:41
• 作者: Joel Matthew Rees <joel.rees@gmai...>
• Commiter: Joel Matthew Rees

Log Message

side path (bad days added early)

更改概述

• modified: badweekdayshere.fs
• add: econcalendar.fs

差异

--- a/badweekdayshere.fs
+++ b/badweekdayshere.fs
@@ -84,5 +84,32 @@ DECIMAL
 : TESTMONTHS ( year -- )
  13 0 DO CR DUP I . I  MDAYS . CR LOOP  DROP ;
 
+( UDS* should be good. )
+: UDS* ( ud u --- uhq ) ( AL AH B --- QL QML QMH )
+  DUP >R SWAP >R 
+  ( AL B ) UM* 
+  0 ( ready to sum into )
+  R> R> 
+  ( AH B ) UM*
+  D+ ;
+
+( I misshandle the return stack here. )
+( I don't see any advantage to this approach. )
+( It's just interesting, if I can fix the stack handling. )
+: UFD* ( ud1 ud2 --- uq ) ( AL AH BL BH --- QL QML QMH QH )
+  >R ( AL AH BL . BH ) 
+  ROT DUP >R ( AH BL AL . BH AL )
+  ROT DUP >R ( BL AL AH . BH AL AH )
+  ROT ( AL AH BL ) 
+  UDS* ( QL QMLp QMHp . BH AL AH )
+  R> R> ( AH AL . BH ) SWAP ( AL AH . BH ) 
+  R> ( QL QMLp QMHp AL AH BH . )
+  UDS* ( QL QMLp QMHp QMLq QMHq QHq )
+  >R >R ( QL QMLp QMHp QMLq . QHq QMHq )
+  ROT ( QL QMHp QMLq QMLp )
+  >R 0 R> 0 D+ ( QL QMHp QML QMHpq )
+  ROT >R 0 R> 0 D+ ( QL QML QMH QHpq )
+  R> + ; 
+
 
 

--- /dev/null
+++ b/econcalendar.fs
@@ -0,0 +1,151 @@
+( Display a calendar for Bokadakr/Xhilr )
+( by Ted Turpin of Bokadakr/Xhilr )
+( Copyright 2017 Joel Matthew Rees )
+
+
+SP@ SP@ - ABS CONSTANT CELLWIDTH
+
+
+12 CONSTANT MPYMONTHS
+
+0 VARIABLE DOMDAYS
+( Modern Forths don't initialize, will leave 0 on stack. )
+
+CELLWIDTH - ALLOT ( Back up to store values. )
+
+30 C, 
+29 C,
+30 C,
+29 C,
+29 C,
+30 C,
+29 C,
+30 C,
+29 C,
+29 C,
+30 C,
+29 C,
+
+352 CONSTANT YDAYS
+
+98 CONSTANT C98
+343 CONSTANT C343
+686 CONSTANT C686
+
+  0 CONSTANT SKMONTH
+  1 CONSTANT SK1
+  4 CONSTANT SK2
+ 48 CONSTANT SK48
+186 CONSTANT LP186  ( 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 C98 MOD SK48 =
+  IF DROP -1  ( One specified extra skip year in medium cycle. )
+  ELSE
+    DUP 7 MOD DUP
+    SK1 =
+    ( Using OR and AND to synthesize conditional math )
+    ( depends on TRUE being all bits on: -1 on two's complement math architectures. )
+    SWAP SK2 = OR  ( Two specified skip years in short cycle, but ... )
+    SWAP C686 MOD LP186 = 0= AND ( not the specified exception in the long cycle. )
+  ENDIF
+;
+
+: PRCH EMIT ;
+
+: COMMA 44 PRCH ;
+: COLON 58 PRCH ;
+: POINT 46 PRCH ;
+: LPAREN 40 PRCH ;
+: RPAREN 41 PRCH ;
+
+: MK8YBITS ( startyear --- )
+   DUP 7 + DO 
+     I ISKIPYEAR 1 AND 0 .R 
+     -1 +LOOP ;
+
+: MKYBITS ( maxyear --- )
+  CR
+  0 SWAP 
+  7 + 
+  0 DO LPAREN SPACE I 6 .R COLON SPACE RPAREN SPACE
+    I MK8YBITS COMMA 
+    1+ DUP 1 AND IF CR ELSE SPACE THEN
+    8 +LOOP ;
+
+
+
+: MDAYS ( year month -- days )
+  DUP 0 < 0=
+  OVER 12 < AND 0= 
+  IF
+    DROP DROP 0  ( Out of range. No days. )
+  ELSE
+    DUP DOMDAYS + C@  ( 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 
+;
+
+
+
+( 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. )
+   DUP 0 = IF ."  Sunday " ELSE ( Fake case format to line the strings up. )
+   DUP 1 = IF ." Moonsday" ELSE
+   DUP 2 = IF ." Aegisday" ELSE
+   DUP 3 = IF ."  Gefnday" ELSE
+   DUP 4 = IF ."  Freyday" ELSE
+   DUP 5 = IF ." Tewesday" ELSE 
+   DUP 6 = IF ."  Vensday" ELSE ( DUP here allows final single DROP. )
+     ."   ???   " 
+   THEN 
+   THEN
+   THEN
+   THEN
+   THEN
+   THEN
+   THEN 
+   DROP ;
+
+: TPMONTH ( n --- ) ( TYPE the name of the month. )
+(   DUP 6 < IF * Use this if the compile stack overflows. )
+     DUP  0 = IF ." Time-division" ELSE ( Fake case format to line the strings up. )
+     DUP  1 = IF ."  Deep-winter " ELSE
+     DUP  2 = IF ."    War-time  " ELSE
+     DUP  3 = IF ."   Thaw-time  " ELSE
+     DUP  4 = IF ."    Rebirth   " ELSE
+     DUP  5 = IF ."  Brides-month" ELSE 
+(       ." ???" )
+(     THEN THEN THEN THEN THEN THEN )
+(   ELSE )
+     DUP  6 = IF ."   Imperious  " ELSE
+     DUP  7 = IF ."  Senatorious " ELSE
+     DUP  8 = IF ."  False-summer" ELSE
+     DUP  9 = IF ."    Harvest   " ELSE
+     DUP 10 = IF ."   Gratitude  " ELSE
+     DUP 11 = IF ."  Winter-month" ELSE ( DUP here allows final single DROP. )
+       ." ???" 
+     THEN
+     THEN
+     THEN
+     THEN
+     THEN
+     THEN
+ ( For 0 to 5: )
+     THEN
+     THEN
+     THEN
+     THEN
+     THEN
+     THEN 
+(   THEN )
+   DROP ;
+
+