• R/O
  • HTTP
  • SSH
  • HTTPS

Tags
No Tags

Frequently used words (click to add to your profile)

javaandroidc++objective-cc#cocoa誰得gamephpbathyscapherubyqtlinuxcomegat翻訳pythontwitterwindowsbtronvb.nettestframeworkgui計画中(planning stage)directxpreviewerpukiwikidommruby

Functions for working with the idealized calendar of Planet Xhilr


File Info

Rev. c9ca731a29c3838146d1e7e85626e1273ae7ca7f
Size 39,257 bytes
Time 2017-06-17 10:35:04
Author Joel Matthew Rees
Log Message

UD/MOD double integer division in M6800 assembler within figForth.
The assembler I use to assemble it is here:
https://sourceforge.net/p/asm68c/wiki/Home/
and it can be run on Joe H Allen's exorsim v. 1.1.
Surprisingly, the High-level Forth version is only around twice as slow as the assembler-level version (because it only uses right-shifts).

Content

  1. ( Forth code for calculating idealized lengths of months )
  2. ( relative to skip years in the world of )
  3. ( Bobbie, Karel, Dan, and Kristi, Sociology 500, a Novel. )
  4. ( by Ted Turpin, of the Union of Independent States, Xhilr )
  5. ( Earth Copyright 2017, Joel Matthew Rees )
  6. ( Permission granted to use for personal entertainment only. )
  7. ( -- If you need it for other purposes, rewriting it yourself is not that hard, )
  8. ( and the result will be guaranteed to satisfy your needs much more effectively. )
  9. ( See these chapters of Sociology 500, a Novel, on line: )
  10. ( <http://joel-rees-economics.blogspot.com/2017/03/soc500-03-08-calendar-math.html> )
  11. ( <http://joel-rees-economics.blogspot.jp/2017/04/soc500-03-09-calculating-months-skip-years.html> )
  12. ( <http://joel-rees-economics.blogspot.com/2017/04/soc500-03-10-computers.html> )
  13. ( Novel table of contents and preface here: )
  14. ( <http://joel-rees-economics.blogspot.com/2017/01/soc500-00-00-toc.html>. )
  15. ( You can save it as something like "econmonths.fs". )
  16. ( In gforth and most modern or emulated environments, )
  17. ( just paste it into the terminal of a running Forth session. )
  18. ( Run it with )
  19. ( 7 SHOWIDEALMONTHS )
  20. ( for seven years, etc. )
  21. ( gforth can be found in the repositories at )
  22. ( <https://www.gnu.org/software/gforth/>. )
  23. ( It can also be obtained as a package from most modern OS distributions )
  24. ( and in many applications stores -- Android, yes, iOS, not yet for a while. )
  25. ( Or, for MSWindows, you can get it through Cygwin: <https://www.cygwin.com/>. )
  26. ( HTML documentation can be found on the web at )
  27. ( <http://www.complang.tuwien.ac.at/forth/gforth/Docs-html/> )
  28. ( which includes a tutorial for experienced programmers. )
  29. ( An easier tutorial for Forth can be found at )
  30. ( <https://www.forth.com/starting-forth/>. )
  31. ( There is a newsgroup: comp.lang.forth, )
  32. ( which can be accessed from the web via, for example, Google newsgroups. )
  33. ( Joel Matthew Rees's own implementation of Forth can be found via )
  34. ( <http://bif-c.sourceforge.net/>, )
  35. ( but if you want to play with that, you'll have to compile it yourself. )
  36. ( Look in the wiki at <https://sourceforge.net/p/bif-c/wiki/Home/> for help. )
  37. ( Many other Forths should also work. )
  38. ( If you don't like Forth's postfix syntax, you might try bc, )
  39. ( which is an ancient calculator found in many modern OSses and Cygwin. )
  40. ( The bc source is here: <https://osdn.net/users/reiisi/pastebin/4988>. )
  41. ( This file is here: <https://osdn.net/users/reiisi/pastebin/4990>. )
  42. ( Uses integer math throughout. )
  43. ( Forth expression syntax is mostly postfix. )
  44. ( Only the definition syntax is prefix or infix. )
  45. ( I've added some comments with equivalent infix expressions )
  46. ( to help those unfamiliar with Forth. )
  47. ( Using baroque identifiers for ancient Forths. )
  48. ( fig-Forth used first three character + length significance in symbol tables. )
  49. ( And I should do this all in hexadecimal, to get a more accurate flavor. )
  50. ( INVERT, UM*, UM/MOD, S>D, 2DUP, and D- are already there in most modern Forths. )
  51. ( These definitions are only for ancient Forths, without the full set loaded, )
  52. ( especially pre-1983 fig and bif-c. )
  53. ( Un-comment them if you see errors like )
  54. ( UM* ? err # 0 )
  55. ( from PRMONTH or thereabouts. )
  56. ( : INVERT NOT ; ( n1 --- n2 : Bit invert is in some ancient Forths as NOT. )
  57. : INVERT -1 XOR ; ( n1 --- n2 : Bit invert is not found at all in some ancient Forths. )
  58. : UM* U* ; ( u u --- ud : modern name for unsigned mixed multiply )
  59. ( So this is just sloppy renaming in a sloppy fashion: )
  60. ( unsigned division with modulo remainder )
  61. : UM/MOD U/ ; ( uddividend udivisor --- uremainder uquotient : If this doesn't work try M/MOD DROP: )
  62. ( : UM/MOD M/MOD DROP ; ( uddividend udivisor --- uremainder uquotient )
  63. : S>D S->D ; ( n --- d : Modern name for single-to-double. )
  64. : NEGATE MINUS ; ( n --- -n : Modern name for numeric negation. )
  65. : DNEGATE DMINUS ; ( d --- -d : Modern name for double number negation. )
  66. : DINVERT INVERT SWAP INVERT SWAP ; ( d1 --- d2 : Double bit invert. )
  67. : 2DUP OVER OVER ; ( d --- d d : DUPlicate top double cell on stack. )
  68. : 2DROP DROP DROP ; ( d --- : DROP a double, for readability. )
  69. : D- DNEGATE D+ ; ( d1 d2 --- d : Difference of two doubles. )
  70. : M* ( n n --- d : signed mixed multiply )
  71. 2DUP XOR >R ( The archetypical definition. )
  72. ABS SWAP ABS UM*
  73. R> 0< IF DNEGATE THEN
  74. ;
  75. : 2SWAP ROT >R ROT R> ; ( d1 d2 --- d2 d1 : Swap top two doubles )
  76. : 2ROT >R >R 2SWAP R> R> 2SWAP ; ( d0 d1 d2 --- d1 d2 d0 )
  77. : 2OVER >R >R 2DUP R> R> 2SWAP ; ( d0 d1 --- d0 d1 d0 )
  78. : D0= OR 0= ; ( d0 --- f : Test top double. )
  79. : D0< SWAP DROP 0< ; ( d0 --- f : Test top double sign. )
  80. : D= D- D0= ; ( d1 d2 --- f : Test the top two doubles for equality. )
  81. : D< D- D0< ; ( d1 d2 --- f : Test the top two doubles for left being less. )
  82. : 2>R SWAP >R >R ; ( Save a double away in true order, high word handy. )
  83. : 2R> R> R> SWAP ; ( Bring back saved double. )
  84. : 4DUP 2OVER 2OVER ; ( q --- q q : DUPlicate the top four cells on stack. )
  85. ( : QNEGATE ( q1 --- q2 : Negate top quadruple word. )
  86. ( >R 0. R> 0 d- >r four times, or is it three with double at end? )
  87. : DMAX ( d1 d2 --- d : Leave larger of top two. )
  88. 4DUP D< IF 2SWAP 2DROP ELSE 2DROP THEN ;
  89. : DMIN ( d1 d2 --- d : Leave smaller of top two. )
  90. 4DUP D< IF 2DROP ELSE 2SWAP 2DROP THEN ;
  91. ( : R@ R ; ( Modern name for copy top of return stack. )
  92. ( Showing the above in infix won't help. )
  93. ( From here, we should load okay in modern Forths. )
  94. ( Most of the doubles handling will be faster at assembler level )
  95. ( -- even if all you have is the bit math. )
  96. ( JM/MOD is already there as M/MOD in some Forths: )
  97. ( : JM/MOD M/MOD ; ( uddividend udivisor -- uremainder udquotient )
  98. : JM/MOD ( uddividend udivisor -- uremainder udquotient )
  99. >R 0 R> DUP >R UM/MOD R> SWAP >R UM/MOD R> ;
  100. ( Tick ' has various semantics, even in different fig Forths. )
  101. ( This definition is safe, anyway. )
  102. SP@ SP@ - ABS CONSTANT CELLWIDTH
  103. ( Infix won't help here, either, but I can try to explain: )
  104. ( CELLWIDTH = absolute-value-of difference-between SP-without-pointer and SP-with-pointer. )
  105. ( Infix will be confusing here, too. )
  106. : D@ ( adr --- d ) ( fetch a double )
  107. DUP CELLWIDTH + @ ( LS-CELL )
  108. SWAP @ ( MS-CELL )
  109. ;
  110. ( Infix will be confusing here, too. )
  111. : D! ( d adr --- ) ( store a double )
  112. SWAP OVER ! ( MS-CELL )
  113. CELLWIDTH + ! ( MS-CELL )
  114. ;
  115. ( Left shifts can be done with addition. )
  116. : SUM-2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest, not too slow. )
  117. : SUM-D2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
  118. : SLOW-Q2* ( uq1 --- uq2 : Double the top double cell. Not fastest. )
  119. SUM-D2* >R OVER 0< IF
  120. 1 OR ( carry )
  121. THEN
  122. >R
  123. SUM-D2*
  124. R> R> ;
  125. : MY-BIT-COUNTER ( --- u ) ( Let's figure out how wide a CELL is. )
  126. 0. 1. BEGIN
  127. SUM-D2* 2SWAP 1. D+ 2SWAP SP@ @
  128. UNTIL 2DROP DROP ;
  129. MY-BIT-COUNTER CONSTANT CELLBITS
  130. CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
  131. ( Semi-simulate local variables with the ability to fetch and store relative to top of stack. )
  132. ( Infix will be confusing here, too. )
  133. : LC@ ( index -- sp[ix] ) ( 0 is top. PICK is available on many modern Forths. )
  134. 1 + CELLWIDTH * ( Skips over the index on stack. )
  135. SP@ + @ ( Assumes push-down stack. Will fail on push-up. )
  136. ;
  137. ( Infix will be confusing here, too. )
  138. : LC! ( n index -- ) ( 0 is top. Just store. This is not ROLL. )
  139. 2 + CELLWIDTH * ( Skips over index and value on stack. )
  140. SP@ + ( Assumes push-down stack. )
  141. ! ( *** Will fail in MISERABLE ways on push-up stacks! *** )
  142. ;
  143. ( Infix will be confusing here, too. )
  144. : DLC@ ( index -- sp[ix] ) ( 0 is top. PICK is available on many modern Forths. )
  145. 1 + CELLWIDTH * ( Skips over the index on stack. )
  146. SP@ + D@ ( Assumes push-down stack. Will fail on push-up. )
  147. ;
  148. ( Infix will be confusing here, too. )
  149. : DLC! ( d index -- ) ( 0 is top. Just store. This is not ROLL. )
  150. 3 + CELLWIDTH * ( Skips over index and double value on stack. )
  151. SP@ + ( Assumes push-down stack. )
  152. D! ( *** Will fail in MISERABLE ways on push-up stacks! *** )
  153. ;
  154. ( This probably isn't really a good idea. Much better to just implement UMD* in assembler. )
  155. ( AL AH B --- QL QML QMH : unsigned double by unsigned single yielding three-cell unsigned )
  156. : UDS* ( ud u --- uhq )
  157. DUP >R SWAP >R
  158. ( AL B ) UM*
  159. 0 ( ready to sum into )
  160. R> R>
  161. ( AH B ) UM*
  162. D+
  163. ;
  164. ( only for stealing by U3S/MOD and UQS/MOD ! )
  165. ( Should actually be in a private vocabulary, but old Forths and new Forths do those differently. )
  166. : (HIDDEN3S/MOD) ( uq u --- uremainder uhquotient )
  167. DUP >R JM/MOD DROP ( AL AM R QMH ) ( B )
  168. R> SWAP >R ( AL AM R B ) ( QMH )
  169. DUP >R JM/MOD DROP ( AL R QML ) ( QMH B )
  170. R> SWAP >R ( AL R B ) ( QMH QML )
  171. JM/MOD DROP ( R QL ) ( QMH QML )
  172. R> R> ( R QL QML QMH )
  173. ;
  174. ( AL AML AMH B --- R QL QML QMH : unsigned 3-cell by unsigned single yielding 3-cell unsigned )
  175. : U3S/MOD ( uhq u --- uremainder uhqquotient )
  176. 0 SWAP ( AL AM AH 0 B ) ( Prime the chain. )
  177. (HIDDEN3S/MOD)
  178. ;
  179. ( You want to know why this is okay. )
  180. ( For the intuitive approach, )
  181. ( consider the cell lower in order than the current cell )
  182. ( as on the other side of the effective fraction point. )
  183. ( Now consider that the lower order cell cannot be as large as 1 in the current cell. )
  184. ( The remainder cannot be as large as the divisor.
  185. ( Added together, they still cannot be as large as the divisor. )
  186. ( Therefore, once you prime the chain with a zero in the cell above, )
  187. ( the result cannot overfow into the higher order cell of the double dividend. )
  188. ( AL AML AMH AH B --- R QL QML QMH QH : unsigned 4-cell by unsigned single yielding 4-cell unsigned )
  189. : UQS/MOD ( uqdividend udivisor --- uremainder uqquotient )
  190. 0 SWAP ( AL AML AMH AH 0 B ) ( Prime the chain. )
  191. DUP >R JM/MOD DROP ( AL AML AMH R QH ) ( B )
  192. R> SWAP >R ( AL AML AMH R B ) ( QH )
  193. (HIDDEN3S/MOD)
  194. ( DUP >R JM/MOD DROP -- AL AML R QMH ) ( QH B )
  195. ( R> SWAP >R -- AL AML R B ) ( QH QMH )
  196. ( DUP >R JM/MOD DROP -- AL R QML ) ( QH QMH B )
  197. ( R> SWAP >R -- AL R B ) ( QH QMH QML )
  198. ( JM/MOD DROP -- R QL ) ( QH QMH QML )
  199. ( R> R> )
  200. R> ( R QL QML QMH )
  201. ;
  202. ( Given AABB / EEFF == SSTT rem MMNN, )
  203. ( AA/EE == RR rem LL is an approximation, iff EE is not zero. )
  204. ( But EE == 00 => use AABB / FF. )
  205. ( For EE > 0, RR * EE + LL == AA, or [ RR + LL / EE ] * EE == AA )
  206. ( But LL / EE < 1, or [ LL / EE ] * 100 < 100 )
  207. ( { [ RR + LL / EE ] * EE } * 100 == AA * 100 } )
  208. ( { [ RR * EE ] * 100 + LL * 100 } < { AA * 100 + BB } )
  209. ( Thus, { RR * EE00 + LL00 } < AABB )
  210. ( Now, BB < 100, so )
  211. ( { [ RR * EE + 1 ] * 100 + LL * 100 } > { AA * 100 + BB } )
  212. ( or AABB < { [ RR + 1 ] * EE00 + LL00 }
  213. ( This gives us some confidence that )
  214. ( { [ RR - 1 ] * EEFF } <= AABB <= { [ RR + 1 ] * EEFF } )
  215. ( which means that a trial division should be easy to restore to the true result. )
  216. ( But we want to know for sure. )
  217. ( { RR * EE00 + LL00 } == AA00 )
  218. ( { RR * EE00 + LL00 + BB } == AABB )
  219. ( { RR * [ EE00 + FF ] + LL00 + BB } > AABB )
  220. ( { RR * EE00 + RR * FF + LL00 + BB } > AABB )
  221. ( { RR * EE00 + RR * FF + LL00 + BB } == { AABB + RR * FF } )
  222. ( { RR * EE00 + RR * FF + LL00 + BB } == { AA00 + BB + RR * FF } )
  223. ( Good thing we checked. )
  224. ( The closer BB -LL gets to FF, the harder it is to recover. )
  225. ( Pathological case, hexadecimal - 32FF / 1FF in byte columns: )
  226. ( 32FF / 100 == 32rFF, 32 * 1FF == 63CE. )
  227. ( 32FF / 1FF is almost 32FF / 200: 19r177. )
  228. ( In sixteen bits, not useful. )
  229. ( In eight bits, better, but still not very useful. )
  230. ( Starting from scratch: )
  231. ( A/B == CrD => C * B + D == A, D < B )
  232. ( B can be expressed in terms of the magnitude of the columns: )
  233. ( If B < Radix R, or the magnitude of the columns, use UQS/MOD. )
  234. ( If B == Magnitude of the columns, shift A. )
  235. ( B > Radix R, B/R == PrL, )
  236. ( B == P*R + L, P == [B-L]/R )
  237. ( L == B - P*R )
  238. ( Then, )
  239. ( A == C * [ P*R + L] + D )
  240. ( A == CPR + CL + D )
  241. ( A / [P*R] == C + CL/[P*R] + D/[P*R] )
  242. ( A / [P*R] == C * [1 + L/[P*R]] + D/[P*R] This goes in a circle. )
  243. ( A == C * [PR + L] + D )
  244. ( A / [PR + L] == C + D / [PR + L] , 0 <= D < B or 0 <= D < PR + L )
  245. ( C <= A / [PR + L] < C + 1 , which isn't all that useful, either. )
  246. ( But 0 <= L < R, so )
  247. ( A / {[P + 1] * R} < A / [PR + L] <= A / PR , which restates the above. )
  248. ( Asking at comp.lang.forth produced this suggestion from Andrew Haley: )
  249. ( http://surface.syr.edu/cgi/viewcontent.cgi?article=1162&context=eecs_techreports )
  250. ( And from Rudy Velthius -- also mentions divmnu.c )
  251. ( https://github.com/rvelthuis/BigNumbers )
  252. ( It pretty much agrees with what I'm seeing above. )
  253. ( Doing it in binary math is the right way for this. )
  254. ( AL AH BL BH --- QL QML QMH QH : unsigned double by unsigned double yielding unsigned quad )
  255. : UMD* ( ud1 ud2 --- uq )
  256. ( AL ) 3 LC@ ( BL ) 2 LC@ UM* 0 ( QL QML QMH : low cells product, ready to sum into QML QMH )
  257. ( AH ) 5 LC@ ( BL ) 5 LC@ UM* >R 0 D+ ( inner product low int QML and carry )
  258. ( AL ) 6 LC@ ( BH ) 4 LC@ UM* >R 0 D+ ( again, QML complete. )
  259. 0 ( zero to QH, ready to sum into QMH QH )
  260. R> 0 D+ R> 0 D+ ( QL QML QMH QH : inner product high into QMH and carry )
  261. ( AH ) 6 LC@ ( BH ) 5 LC@ UM* D+ ( Product complete, now store it. )
  262. 3 LC! 3 LC! 3 LC! 3 LC!
  263. ;
  264. ( 2/ and d2/ require words which have various names -- u/, etc., )
  265. ( and are very slow. )
  266. ( Just best to do in assembler, along with UD* and UQD/MOD . )
  267. ( Do it in assembler instead! Hundreds of times as slow!!!! )
  268. : DIV-2/ ( u1 --- u2 : Halve the top cell. REALLY SLOW! )
  269. S>D 2 UM/MOD SWAP DROP ;
  270. ( Do it in assembler instead! Hundreds of times as slow!!!! )
  271. : DIV-D2/ ( ud1 --- ud2 : Halve the top double cell. REALLY SLOW! )
  272. 2 JM/MOD ROT DROP ;
  273. ( Scaling, to keep the steps time-bounded, )
  274. ( is going to leave me at the binary long division )
  275. ( unless I use tables. )
  276. ( Tables will not fit in a 16-bit address space. )
  277. ( And scaling requires shifts, )
  278. ( which are painfully slow if not defined low level. )
  279. ( Some dividends will overflow quotient, not valid for such cases. )
  280. ( Intended to be used for known products of two doubles.
  281. ( AL AML AMH AH BL BH --- RL RH QL QH : unsigned quad by unsigned double yielding unsigned double )
  282. : SLOW-UMD/MOD ( uqdividend uddivisor --- udremainder udquotient )
  283. DUP 0= IF
  284. DROP UQS/MOD 2DROP 0 ROT ROT ( Get divisor high word 0 easy case done quickly. )
  285. ELSE
  286. 2ROT 2ROT ( Get the divisor out of the way, but accessible with pick. )
  287. CELLBITS SUM-2* 1+ >R ( Count )
  288. 0 >R ( Force flag )
  289. BEGIN ( BL BH AL AML AMH AH ) ( [ count force ] )
  290. 2DUP ( high double of dividend : BL BH AL AML AMH AH AMH AH )
  291. 6 DLC@ D< 0= ( Greater or equal? : BL BH AL AML AMH AH f )
  292. R> OR ( Force it? )
  293. IF ( BL BH AL AML AMH AH ) ( [ count ] )
  294. 4 DLC@ D- 1 ( Mark the subtraction. )
  295. ELSE
  296. 0 ( Mark no subtraction. )
  297. THEN ( BL BH AL AML AMH AH bit ) ( [ count ] )
  298. SWAP >R SWAP >R ( Save top half of remainder and bury the subtraction flag. )
  299. ( BL BH AL AML bit ) ( [ count AH AMH ] )
  300. OVER >R ( Remember the carry from bottom to top half -- AML. )
  301. ( BL BH AL AML bit ) ( [ count AH AMH AML ] )
  302. >R SUM-D2* ( Save subtraction flag and shift the bottom half: AL AML. )
  303. ( BL BH sAL rsAML ) ( [ count AH AMH AML bit ] )
  304. SWAP ( BL BH rsAML sAL ) ( [ count AH AMH AML bit ] )
  305. R> OR SWAP ( Record the subtraction in emptied bit of remainder. )
  306. ( BL BH rsAL rsAML ) ( [ count AH AMH AML ] )
  307. R> 0< IF 1 ELSE 0 THEN ( Convert AML to bit to shift in to top half. )
  308. ( BL BH rsAL rsAML carry ) ( [ count AH AMH ] )
  309. R> R> ( BL BH rsAL rsAML carry AMH AH ) ( [ count ] )
  310. R> 1 - DUP >R ( Count down. )
  311. ( BL BH rsAL rsAML carry AMH AH newcount ) ( [ newcount ] )
  312. WHILE ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount ] )
  313. DUP 0< >R ( Remember the high bit of the remainder, to force subtract. )
  314. ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount newforce ] )
  315. SUM-D2* ( BL BH rsAL rsAML carry sAMH rsAH ) ( [ newcount newforce ] )
  316. >R OR R> ( Shift the remainder, with the bit from the low half. )
  317. ( BL BH rsAL rsAML rsAMH rsAH ) ( [ newcount newforce ] )
  318. REPEAT ( BL BH rsAL rsAML rsAMH rsAH ) ( [ newcount newforce ] )
  319. ( BL BH rsAL rsAML carry AMH AH ) ( [ newcount ] )
  320. R> DROP ( the count ) ( BL BH rsAL rsAML carry AMH AH )
  321. ROT DROP ( BL BH QL QH RL RH )
  322. 2ROT 2DROP ( QL QH RL RH )
  323. 2SWAP ( RL RH QL QH )
  324. THEN
  325. ;
  326. ( Make things easier to read. )
  327. ( Infix will be confusing here, too. )
  328. : PRCH EMIT ;
  329. : COMMA 44 PRCH ;
  330. : COLON 58 PRCH ;
  331. : POINT 46 PRCH ;
  332. : LPAREN 40 PRCH ;
  333. : RPAREN 41 PRCH ;
  334. : VBAR 124 EMIT ;
  335. : PLUS 43 EMIT ;
  336. : DASH 45 EMIT ;
  337. : STAR 42 EMIT ;
  338. : ZERO 48 EMIT ;
  339. ( No trailing space. )
  340. : PSNUM ( number -- )
  341. 0 .R ;
  342. : PSDNUM ( number -- )
  343. 0 D.R ;
  344. ( Do it in integers! )
  345. ( Watch limits on 16 bit processors! )
  346. 7 CONSTANT SCYCLE ( years in short cycle )
  347. ( SCYCLE = 7 )
  348. 7 2 * CONSTANT SPMCYC ( short cycles in medium cycle )
  349. ( SPMCYC = 7 × 2 )
  350. SCYCLE SPMCYC * CONSTANT MCYCLE ( years in medium cycle, should be 98 )
  351. ( MCYCLE = SCYCLE × SPMCYC )
  352. 7 7 * CONSTANT SPLCYC ( short cycles in single long cycle )
  353. ( SPLCYC = 7 × 7 )
  354. SCYCLE SPLCYC * CONSTANT LCYCLE ( years in single long cycle, should be 343 )
  355. ( LCYCLE = SCYCLE × SPLCYC )
  356. 7 CONSTANT MP2LCYC ( medium cycles in double long cycle )
  357. ( MP2LCYC = 7 )
  358. ( MPLCYC would not be an integer: 3 1/2 )
  359. MCYCLE MP2LCYC * CONSTANT 2LCYCLE ( years in double long cycle, should be 686 )
  360. ( 2LCYCLE = MCYCLE × MP2LCYC )
  361. 352 CONSTANT DPSKIPYEAR ( floor of days per year )
  362. 5 CONSTANT RDSCYCLE ( remainder days in short cycle )
  363. DPSKIPYEAR SCYCLE * RDSCYCLE + CONSTANT DPSCYCLE ( whole days per 7 year cycle )
  364. ( DPSCYCLE = DPSKIPYEAR × SCYCLE + RDSCYCLE )
  365. ( DPMCYCLE and DP2LCYCLE would overflow on 16-bit math CPUs. )
  366. ( No particular problem on 32 bit CPUs. Need DCONSTANT for 16-bit CPUs. )
  367. ( But we need the constants more than we need to puzzle out )
  368. ( the differences between CREATE DOES> and <BUILDS DOES>. )
  369. 1 CONSTANT EDMCYCLE ( whole days adjusted down in 98 year cycle )
  370. RDSCYCLE SPMCYC * EDMCYCLE - CONSTANT RDMCYCLE ( remainder days in medium cycle )
  371. ( RDMCYCLE = RDSCYCLE × SPMCYC - EDMCYCLE )
  372. ( DPSCYCLE SPMCYC UM* EDMCYCLE 0 D- DCONSTANT DPMCYCLE : 34565, too large for signed 16 bit. )
  373. ( DPMCYCLE = DPSCYCLE × SPMCYC - EDMCYCLE )
  374. ( Fake DCONSTANT: )
  375. : DPMCYCLE [ DPSCYCLE SPMCYC UM* EDMCYCLE 0 D- SWAP ] LITERAL LITERAL ; ( Fits in unsigned 16 bit. )
  376. 2 CONSTANT SD2LCYCLE ( whole days adjusted up in 686 year cycle )
  377. RDMCYCLE MP2LCYC * SD2LCYCLE + CONSTANT RD2LCYCLE ( remainder days in double long cycle -- odd number )
  378. ( RD2LCYCLE = RDMCYCLE × MP2LCYC + SD2LCYCLE )
  379. ( RD2LCYCLE / 2LCYCLE is fractional part of year. )
  380. ( Ergo, length of year is DPSKIPYEAR + RD2LCYCLE / 2LCYCLE, )
  381. ( or 352 485/686 days. )
  382. ( D* is not defined, but, luckily, DPMCYCLE fits in unsigned 16 bit. )
  383. ( 100 years of 365.24 also fits in unsigned 16 bit, FWIW. )
  384. ( DPLCYCLE would not be an integer, leaves a half day over. )
  385. ( DPMCYCLE MP2LCYC S>D D* SD2LCYCLE 0 D+ DCONSTANT DP2LCYCLE : 241957 , too large for 16 bit. )
  386. ( DP2LCYCLE = DPMCYCLE × MP2LCYC + SD2LCYCLE )
  387. ( Fake DCONSTANT: )
  388. : DP2LCYCLE [ DPMCYCLE ( 34565 ) DROP MP2LCYC UM* SD2LCYCLE 0 D+ SWAP ] LITERAL LITERAL ;
  389. 12 CONSTANT MPYEAR ( months per year )
  390. DPSKIPYEAR MPYEAR /MOD CONSTANT FDMONTH ( floor of days per month )
  391. ( FDMONTH = DPSKIPYEAR / MPYEAR )
  392. CONSTANT FRMONTH ( floored minimum remainder days per month )
  393. ( FRMONTH = DPSKIPYEAR MOD MPYEAR )
  394. 2LCYCLE MPYEAR * CONSTANT MDENOMINATOR ( denominator of month fractional part )
  395. ( MDENOMINATOR = 2LCYCLE × MPYEAR )
  396. FRMONTH 2LCYCLE * RD2LCYCLE + CONSTANT MNUMERATOR ( numerator of month fractional part )
  397. ( MNUMERATOR = FRMONTH × 2LCYCLE + RD2LCYCLE )
  398. ( Ergo, length of month is FDMONTH + MNUMERATOR / MDENOMINATOR, )
  399. ( or 29 3229/8232 days. )
  400. MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
  401. ( Infix will be confusing below here, as well. )
  402. ( Hopefully, the comments and explanations will provide enough clues. )
  403. ( Sum up the days of the months in a year. )
  404. : SU1MONTH ( startfractional dstartdays -- endfractional denddays )
  405. FDMONTH S>D D+ ( Add the whole part. )
  406. ROT ( Make the fractional part available to work on. )
  407. MNUMERATOR + ( Add the fractional part. )
  408. DUP MDENOMINATOR < ( Have we got a whole day yet? )
  409. IF
  410. ROT ROT ( No, restore stack order for next pass. )
  411. ELSE
  412. MDENOMINATOR - ( Take one whole day from the fractional part. )
  413. ROT ROT 1 S>D D+ ( Restore stack and add the day carried in. )
  414. THEN
  415. ;
  416. : PRMONTH ( fractional ddays -- fractional ddays )
  417. SPACE 2DUP PSDNUM POINT ( whole days )
  418. 2 LC@ 1000 UM* ( Fake three digits of decimal precision. )
  419. MROUNDFUDGE S>D D+ ( Round the bottom digit. )
  420. MDENOMINATOR UM/MOD ( Divide, or evaluate the fraction. )
  421. S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
  422. TYPE ( Fake decimal output. )
  423. DROP SPACE
  424. ;
  425. : SH1IDEALYEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
  426. CR
  427. MPYEAR 0 DO
  428. 5 LC@ PSNUM SPACE ( year )
  429. I PSNUM COLON SPACE
  430. SU1MONTH
  431. 2DUP 5 DLC@ D- ( difference in days )
  432. 4 LC@ ( push difference to ceiling ) IF 1. D+ THEN
  433. 2DUP PSDNUM SPACE ( show theoretical days in month )
  434. 5 DLC@ D+ ( sum of days: adjusted difference plus daysmemory )
  435. LPAREN 2DUP PSDNUM COMMA SPACE
  436. 3 DLC! ( update daysmemory )
  437. PRMONTH RPAREN CR
  438. LOOP
  439. ;
  440. : SHOWIDEALMONTHS ( years -- )
  441. >R
  442. 0 0. 0 0. ( year, ddaysmemory, fractional, ddays )
  443. R> 0 DO
  444. CR
  445. SH1IDEALYEAR
  446. 5 LC@ 1+ 5 LC!
  447. LOOP
  448. 2DROP DROP 2DROP DROP
  449. ;
  450. 0 CONSTANT SKMONTH
  451. 1 CONSTANT SK1SHORTCYC
  452. 4 CONSTANT SK2SHORTCYC
  453. 48 CONSTANT SKMEDIUMCYC
  454. 186 CONSTANT LPLONGCYC ( Must be short1 or short2 within the seven year cycle. )
  455. LCYCLE LPLONGCYC + CONSTANT LPLONGCYC2
  456. ( Since skipyears are the exception, )
  457. ( we test for skipyears instead of leapyears. )
  458. ( Calendar system starts with year 0, not year 1. )
  459. ( Would need to check and adjust if the calendar started with year )
  460. : ISKIPYEAR ( year -- flag )
  461. DUP 0< IF
  462. NEGATE 2LCYCLE MOD 2LCYCLE SWAP -
  463. THEN
  464. DUP MCYCLE MOD SKMEDIUMCYC =
  465. IF DROP -1 ( One specified extra skip year in medium cycle. )
  466. ELSE
  467. DUP SCYCLE MOD DUP
  468. SK1SHORTCYC =
  469. SWAP SK2SHORTCYC = OR ( Two specified skip years in short cycle, but ... )
  470. SWAP LCYCLE MOD LPLONGCYC = 0= AND ( not the specified exception in the long cycle. )
  471. THEN
  472. ;
  473. ( At this point, I hit a condundrum. )
  474. ( Modern "standard" Forths want variables without initial values, )
  475. ( but ancient, especially fig-Forths want initialized variables. )
  476. ( The lower-level <BUILDS DOES> for fig is only partially part of the modern standard. )
  477. ( And CREATE is initialized as a CONSTANT in the fig-Forth, )
  478. ( but has no initial characteristic code or value in modern standards. )
  479. ( So. )
  480. ( I can't fix this easily. )
  481. ( We give the ancient Forths a zero. )
  482. ( Modern Forths will leave the 0 given here on the stack. )
  483. ( Then the zero stays around forever on modern Forths, or until you drop it. )
  484. 0 VARIABLE DIMARRAY ( Days In Months array )
  485. CELLWIDTH NEGATE ALLOT ( Back up to store values. )
  486. 30 C,
  487. 29 C,
  488. 30 C,
  489. 29 C,
  490. 29 C,
  491. 30 C,
  492. 29 C,
  493. 30 C,
  494. 29 C,
  495. 29 C,
  496. 30 C,
  497. 29 C,
  498. 0 ,
  499. ( Accept one year year plus or minus, to help calendar on first and last month. )
  500. : DIMONTH ( year month -- days )
  501. DUP 0< IF
  502. SWAP 1 - SWAP MPYEAR +
  503. ELSE
  504. DUP MPYEAR < 0= IF
  505. SWAP 1 + SWAP MPYEAR -
  506. THEN
  507. THEN
  508. DUP 0 < 0=
  509. OVER MPYEAR < AND 0=
  510. IF
  511. DROP DROP 0 ( Out of range. No days. )
  512. ELSE
  513. DUP DIMARRAY + C@ ( Get the basic days. )
  514. SWAP SKMONTH = ( true if skip month )
  515. ROT ISKIPYEAR AND ( true if skip month of skip year )
  516. 1 AND - ( Subtrahend is 1 only if skip month of skip year. )
  517. THEN
  518. ;
  519. : SH1YEAR ( year ddaysmemory fractional ddays -- year ddaysmemory fractional ddays )
  520. CR
  521. MPYEAR 0 DO
  522. 5 LC@ PSNUM SPACE ( year )
  523. I PSNUM COLON SPACE
  524. SU1MONTH ( ideal month )
  525. 5 LC@ I DIMONTH ( real month )
  526. DUP PSNUM SPACE ( show days in month )
  527. S>D 5 DLC@ D+ ( sum of days )
  528. LPAREN 2DUP PSDNUM COMMA SPACE
  529. 3 DLC! ( update )
  530. PRMONTH RPAREN CR
  531. LOOP
  532. ;
  533. : SHOWMONTHS ( years --- )
  534. >R
  535. 0 0. 0 0. ( year, ddaysmemory, fractional, ddays )
  536. R> 0 DO
  537. CR
  538. SH1YEAR
  539. 5 LC@ 1+ 5 LC!
  540. LOOP
  541. 2DROP DROP 2DROP DROP
  542. ;
  543. : D, ( d --- ) ( Store a double into the dictionary. )
  544. SWAP , , ;
  545. : DINY ( year --- days )
  546. ISKIPYEAR 0= 1 AND DPSKIPYEAR + ;
  547. : DTYLONGLOOP ( years --- ddays ) ( Days in years. )
  548. 0. ROT DUP IF
  549. 0 DO
  550. I DINY S>D D+
  551. LOOP
  552. ELSE
  553. DROP
  554. THEN
  555. ;
  556. ( Already did these the other way: )
  557. ( : DPMCYCLE [ MCYCLE DTYLONGLOOP SWAP ] LITERAL LITERAL ; ( 34565 )
  558. ( : DP2LCYCLE [ 2LCYCLE DTYLONGLOOP SWAP ] LITERAL LITERAL ; ( 241957 )
  559. ( Synthetic division is faster than general division. )
  560. : DTYLONG ( ddays1 uyear1 --- ddays2 uyear2 ) ( Sum long cycle years. )
  561. BEGIN
  562. 2LCYCLE - DUP 0< 0= WHILE
  563. >R DP2LCYCLE D+ R>
  564. REPEAT
  565. 2LCYCLE +
  566. ;
  567. ( Synthetic division is faster than general division. )
  568. : DTYMEDIUM ( ddays1 uyear1 --- ddays2 uyear2 ) ( Sum medium cycle years with leaps. )
  569. DUP LPLONGCYC2 > IF
  570. >R 2. D+ R>
  571. ELSE
  572. DUP LPLONGCYC > IF >R 1. D+ R> THEN
  573. THEN
  574. BEGIN
  575. MCYCLE - DUP 0< 0= WHILE
  576. >R DPMCYCLE D+ R>
  577. REPEAT
  578. MCYCLE +
  579. ;
  580. ( Synthetic division is still faster : max 98 / 7 loops. )
  581. : DTYSHORT ( ddays1 uyear1 --- ddays2 uyear2 ) ( Sum short cycle years with skip. )
  582. DUP SKMEDIUMCYC > IF
  583. >R 1. D- R>
  584. THEN
  585. BEGIN
  586. SCYCLE - DUP 0< 0= WHILE
  587. >R DPSCYCLE 0 D+ R>
  588. REPEAT
  589. SCYCLE +
  590. ;
  591. ( Synthetic division is faster than general division. )
  592. ( Anyway, this has only algorithmic meaning prior to the standard calendar. )
  593. : DTY ( uyear --- ddays )
  594. 0. ROT
  595. DTYLONG
  596. DTYMEDIUM
  597. DTYSHORT
  598. DTYLONGLOOP
  599. D+
  600. ;
  601. ( Saturates on month > MPYEAR. Generally use to month MPYEAR - 1. )
  602. : DTM ( uyear umonth --- days ) ( Just the days from the beginning of the year. )
  603. DUP IF
  604. 0 SWAP 0 DO
  605. OVER I DIMONTH +
  606. LOOP
  607. THEN
  608. SWAP DROP
  609. ;
  610. ( Modern Forths will leave the initialization 0 behind. )
  611. 0 VARIABLE CALENDAR-WIDTH
  612. 80 CALENDAR-WIDTH !
  613. ( But we won't use this because we don't have real strings. )
  614. ( Okay, we'll use it anyway. )
  615. ( Modern Forths will leave the initialization 0 behind. )
  616. 0 VARIABLE DAYCOUNT
  617. 0 DAYCOUNT ! 0 , ( Double variable, initialize cleared. )
  618. ( Modern Forths will leave the initialization 0 behind. )
  619. 6 CONSTANT WKDAYOFFSET ( Weekday corresponding to day zero of year zero. )
  620. 0 VARIABLE 1STDAYOFWEEK ( Weekday corresponding to first day of week. )
  621. 0 1STDAYOFWEEK !
  622. ( Modern Forths will leave the initialization 0 behind. )
  623. 0 VARIABLE DOWKSTATE ( Current day of week. )
  624. 7 CONSTANT DPWK ( Days per week. )
  625. 16 CONSTANT JIRPERDAY ( About 90 minutes. )
  626. 16 CONSTANT GOBUPERJIR ( About 5.6 minutes. )
  627. 16 CONSTANT BUNEIGHPERGOB ( About 21 seconds. )
  628. 16 CONSTANT MYOTPERBUNEIGH ( About 13 seconds. )
  629. ( For the cycles use scaled 485 / 686, keep scale in 16 bits. )
  630. RD2LCYCLE 16 * CONSTANT NUCYCLE ( numerator: 7760 )
  631. 2LCYCLE 16 * CONSTANT DECYCLE ( denominator: 10976 )
  632. ( Their larger moon orbits their world in about twenty-eight and seven eighths days, )
  633. ( about twelve and one fifth long lunar months each year.)
  634. 28 CONSTANT SMPERIODINT ( Slow moon period integer part. )
  635. 7 DECYCLE 8 */ 41 + CONSTANT SMPERIODFRAC10976 ( Slow moon period fractional part. )
  636. ( Fake DCONSTANT: )
  637. : SMPERIOD10976 [ SMPERIODINT DECYCLE UM* SMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ;
  638. ( 28 9645 / 10976 == 316973 / 10976 )
  639. ( Modern Forths will leave the initialization 0 behind. )
  640. 0 VARIABLE SMSTATEINT ( Slow moon state integer part. )
  641. 0 SMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
  642. ( Modern Forths will leave the initialization 0 behind. )
  643. 0 VARIABLE SMSTATEFRAC10976 ( Fractional part. )
  644. 0 SMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
  645. : SM16THPERIOD10976 [ SMPERIOD10976 8. D+ 16 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
  646. : SM32NDPERIOD10976 [ SMPERIOD10976 16. D+ 32 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
  647. ( start + mt = 1/2, start + gt = 3/4 => t * { g - m } = 1/4 => t = 1 / 4 * { g - m } )
  648. ( g = 1 rot/day, m = 10976 / 316973 rev/day => t = 1 / { 4 * [ 316973 - 10976 ] / 316973 } )
  649. ( s + gt = 3/4 => s = 3/4 - t; s = 3/4 - 1 / { 4 * [ 316973 - 10976 ] / 316973 } )
  650. ( s + mt = 1/2 => s = 1/2 - mt; s = 1/2 - 10976 / [ 4 * { 316973 - 10976 } ] )
  651. ( s = [ 2 * 316973 - 3 * 10976 ] / [ 4 * { 316973 - 10976 } ] )
  652. ( s = 601018 / 1223988 )
  653. : SMTARGET
  654. [ 2. SMPERIOD10976 UMD* 2DROP 3 DECYCLE UM* D-
  655. SMPERIOD10976 UMD* ( Scale it by period and keep high double word. )
  656. 4. SMPERIOD10976 DECYCLE 0 D- UMD* 2DROP
  657. SLOW-UMD/MOD 2SWAP 2DROP SWAP
  658. ] LITERAL LITERAL ;
  659. ( Used SMTARGET like this, with SMOFFFRAC10976 set to 0.: )
  660. ( 34 3 STYCYCLES 5 DMADJUST SMSTATEFRAC10976 D@ SMTARGET 2SWAP D- )
  661. ( SMPERIOD10976 D+ D. <enter> 311395 OK )
  662. 0 CONSTANT SMOFFINT ( Slow moon offset at year 0 day 0, integer part. )
  663. : SMOFFFRAC10976 [ 311395. SWAP ] LITERAL LITERAL ; ( Fractional part. )
  664. ( Below was guessing wrong: )
  665. ( [ SM32NDPERIOD10976 28 UDS* DROP )
  666. ( SM32NDPERIOD10976 DIV-D2/ D+ 4 JM/MOD ROT DROP SWAP ] )
  667. ( Could pre-divide the period into 16ths but this is an output function, )
  668. ( can be a little slow. )
  669. : SMSHOWPHASE ( --- ) ( --- ) ( Show the Slowmoon phase with no spacing. )
  670. SMSTATEFRAC10976 D@ SM32NDPERIOD10976 D+ 0. SM16THPERIOD10976 SLOW-UMD/MOD
  671. 2SWAP 2DROP DROP DUP 16 < 0= IF 16 - THEN
  672. ." S:" HEX 0 .R DECIMAL
  673. ;
  674. 3 CONSTANT SPHASEWIDTH
  675. ( The smaller moon orbits their world in just under seven and one eighth days, )
  676. ( about forty-nine and a half lunar weeks a year )
  677. 7 CONSTANT FMPERIODINT ( Fast moon period integer part. )
  678. 1 DECYCLE 8 */ 9 - CONSTANT FMPERIODFRAC10976 ( Fast moon period fractional part. )
  679. ( Fake DCONSTANT: )
  680. : FMPERIOD10976 [ FMPERIODINT DECYCLE UM* FMPERIODFRAC10976 0 D+ SWAP ] LITERAL LITERAL ;
  681. ( 7 1364 / 10976 == 78196 / 10976 )
  682. ( start + mt = 1/2, start + gt = 3/4 => t * { g - m } = 1/4 => t = 1 / 4 * { g - m } )
  683. ( g = 1 rot/day, m = -10976 / 78196 rev/day => t = 1 / { 4 * [ 78196 + 10976 ] / 78196 } )
  684. ( s + gt = 3/4 => s = 3/4 - t; s = 3/4 - 1 / { 4 * [ 78196 + 10976 ] / 78196 } )
  685. ( s + mt = 1/2 => s = 1/2 - mt; s = 1/2 + 10976 / [ 4 * { 78196 + 10976 } ] )
  686. ( s = [ 2 * 78196 + 3 * 10976 ] / [ 4 * { 78196 + 10976 } ] )
  687. ( s = 189318 / 356684 )
  688. : FMTARGET
  689. [ 2. FMPERIOD10976 UMD* 2DROP 3 DECYCLE UM* D+
  690. FMPERIOD10976 UMD* ( Scale it by period and keep high double word. )
  691. 4. FMPERIOD10976 DECYCLE 0 D+ UMD* 2DROP
  692. SLOW-UMD/MOD 2SWAP 2DROP SWAP
  693. ] LITERAL LITERAL ;
  694. ( Used FMTARGET like this, with FMOFFFRAC10976 set to 0.: )
  695. ( 34 3 STYCYCLES 5 DMADJUST FMSTATEFRAC10976 D@ FMTARGET 2SWAP D- )
  696. ( D. <enter> 4287 OK )
  697. 0 CONSTANT FMOFFINT ( Fast moon offset at year 0 day 0, integer part. )
  698. : FMOFFFRAC10976 [ 4287. SWAP ] LITERAL LITERAL ; ( Fractional part. )
  699. ( Modern Forths will leave the initialization 0 behind. )
  700. 0 VARIABLE FMSTATEINT ( Fast moon state integer part. )
  701. 0 FMSTATEINT ! 0 , ( Initialize cleared, make double variable. )
  702. ( Modern Forths will leave the initialization 0 behind. )
  703. 0 VARIABLE FMSTATEFRAC10976 ( Fractional part. )
  704. 0 FMSTATEFRAC10976 ! 0 , ( Initialize cleared, make double variable. )
  705. : FM16THPERIOD10976 [ FMPERIOD10976 8. D+ 16 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
  706. : FM32NDPERIOD10976 [ FMPERIOD10976 16. D+ 32 JM/MOD ROT DROP SWAP ] LITERAL LITERAL ;
  707. ( Could pre-divide the period into 16ths but this is an output function, )
  708. ( can be a little slow. )
  709. : FMSHOWPHASE ( --- ) ( Show the Fastmoon phase with no spacing. )
  710. FMSTATEFRAC10976 D@ FM32NDPERIOD10976 D+ 0. FM16THPERIOD10976 SLOW-UMD/MOD
  711. 2SWAP 2DROP DROP
  712. JIRPERDAY SWAP - ( Retrograde. )
  713. DUP 16 < 0= IF 16 - THEN
  714. ." F:" HEX 0 .R DECIMAL
  715. ;
  716. 3 CONSTANT FPHASEWIDTH
  717. ( Modern Forths will leave the initialization 0 behind. )
  718. 0 VARIABLE CYEAR 0 CYEAR !
  719. ( Modern Forths will leave the initialization 0 behind. )
  720. 0 VARIABLE CMONTH 0 CMONTH !
  721. ( Modern Forths will leave the initialization 0 behind. )
  722. 0 VARIABLE CDATE 0 CDATE !
  723. ( Start the weekday counter for the year and month, remember the days. )
  724. ( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
  725. : WKSTCYCLES ( uyear umonth --- )
  726. 2DUP
  727. CMONTH !
  728. CYEAR !
  729. 0 CDATE !
  730. OVER DTY
  731. 2SWAP DTM 0 D+
  732. 2DUP DAYCOUNT D!
  733. WKDAYOFFSET 0 D- DPWK JM/MOD 2DROP DOWKSTATE !
  734. ;
  735. ( Leaves things out of sync if not called by DADJUST. )
  736. : BKMONTH ( --- )
  737. CMONTH @ 1 - DUP 0< IF
  738. CYEAR @ 1 - CYEAR !
  739. MPYEAR +
  740. THEN
  741. CMONTH !
  742. ;
  743. ( Leaves things out of sync if not called by DADJUST. )
  744. : UPMONTH ( --- )
  745. CMONTH @ 1+
  746. DUP MPYEAR < 0= IF
  747. MPYEAR -
  748. THEN
  749. CMONTH !
  750. ;
  751. ( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
  752. ( Negative days will have previous month's DIMONTH as limit. )
  753. ( Leaves things out of sync if not called by DADJUST. )
  754. : DTADJUST ( days --- )
  755. CDATE @ +
  756. DUP 0< IF
  757. BKMONTH ( Previous month's DIMONTH. )
  758. CYEAR @ CMONTH @ DIMONTH +
  759. ELSE
  760. CYEAR @ CMONTH @ DIMONTH 2DUP < 0= IF
  761. -
  762. UPMONTH
  763. ELSE
  764. DROP
  765. THEN
  766. THEN
  767. CDATE !
  768. ;
  769. ( Leaves things out of sync if not called by DADJUST. )
  770. : WDADJUST ( days --- ) ( Adjust the day of the week. )
  771. DOWKSTATE @ +
  772. DUP 0< IF
  773. NEGATE DPWK MOD DPWK SWAP -
  774. ELSE
  775. DPWK MOD
  776. THEN
  777. DOWKSTATE !
  778. ;
  779. ( Start the slowmoon cycle counter by the day count. )
  780. ( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
  781. : SLOMSTCYCLES ( ddays --- )
  782. DECYCLE S>D UMD* SMPERIOD10976 SLOW-UMD/MOD
  783. 2SWAP SMOFFFRAC10976 D+
  784. 2DUP SMPERIOD10976 D< 0= IF
  785. SMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
  786. THEN
  787. SMSTATEFRAC10976 D!
  788. SMOFFINT S>D D+ SMSTATEINT D!
  789. ;
  790. ( Add signed days to slow month state. days must be less than period. )
  791. : SLOMADJ ( days --- )
  792. DECYCLE M*
  793. SMSTATEFRAC10976 D@ D+
  794. 2DUP D0< IF
  795. SMSTATEINT D@ 1. D- SMSTATEINT D!
  796. SMPERIOD10976 D+
  797. ELSE
  798. 2DUP SMPERIOD10976 D< 0= IF
  799. SMSTATEINT D@ 1. D+ SMSTATEINT D!
  800. SMPERIOD10976 D-
  801. THEN
  802. THEN
  803. SMSTATEFRAC10976 D!
  804. ;
  805. ( Start the fastmoon cycle counter by the day count. )
  806. ( Intended to be called from STYCYCLES. Other use will leave things out of sync. )
  807. : FASMSTCYCLES ( ddays --- )
  808. DECYCLE S>D UMD* FMPERIOD10976 SLOW-UMD/MOD
  809. 2SWAP FMOFFFRAC10976 D+
  810. 2DUP FMPERIOD10976 D< 0= IF
  811. FMPERIOD10976 D- 2SWAP 1. D+ 2SWAP
  812. THEN
  813. FMSTATEFRAC10976 D!
  814. FMOFFINT S>D D+ FMSTATEINT D!
  815. ;
  816. ( Add signed days to fast month state. days must be less than period. )
  817. : FASMADJ ( days --- )
  818. DECYCLE M*
  819. FMSTATEFRAC10976 D@ D+
  820. 2DUP D0< IF
  821. FMSTATEINT D@ 1. D- FMSTATEINT D!
  822. FMPERIOD10976 D+
  823. ELSE
  824. 2DUP FMPERIOD10976 D< 0= IF
  825. FMSTATEINT D@ 1. D+ FMSTATEINT D!
  826. FMPERIOD10976 D-
  827. THEN
  828. THEN
  829. FMSTATEFRAC10976 D!
  830. ;
  831. ( Call from here to keep things in sync! )
  832. : STYCYCLES ( year month --- ) ( Start the counters for the year. )
  833. WKSTCYCLES
  834. DAYCOUNT D@ 2DUP SLOMSTCYCLES FASMSTCYCLES
  835. ;
  836. ( : TEST STYCYCLES DAYCOUNT D@ D. CR SMSTATEINT D@ D. CR SMSTATEFRAC10976 D@ D. CR )
  837. ( FMSTATEINT D@ D. CR FMSTATEFRAC10976 D@ D. CR ; )
  838. ( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
  839. ( Negative days will have previous month's DIMONTH as limit. )
  840. ( Call from here to keep DAYCOUNT, DOWKSTATE, CYEAR, CMONTH, and CDATE in sync. )
  841. : DADJUST ( days --- )
  842. DUP S>D DAYCOUNT D@ D+ DAYCOUNT D!
  843. DUP WDADJUST DTADJUST
  844. ;
  845. ( Adjusting by more than DIMONTH will leave CMONTH and maybe CYEAR incorrect. )
  846. ( Negative days will have previous month's DIMONTH as limit. )
  847. ( Call from here to keep moon phases also in sync. )
  848. : DMADJUST ( days --- )
  849. DUP DADJUST DUP SLOMADJ FASMADJ
  850. ;
  851. ( Ancient Forths do not have standard WORDs, )
  852. ( and that makes it hard to have portable arrays of strings for those Forths. )
  853. : TPWDAY ( n --- ) ( TYPE the name of the day of the week, modulo. )
  854. DPWK MOD
  855. DUP 0 = IF ." Sunday " ELSE ( Fake case format to line the strings up. )
  856. DUP 1 = IF ." Moonsday" ELSE
  857. DUP 2 = IF ." Aegisday" ELSE
  858. DUP 3 = IF ." Gefnday " ELSE
  859. DUP 4 = IF ." Freyday " ELSE
  860. DUP 5 = IF ." Tewesday" ELSE ( DUP here allows final single DROP. )
  861. ." Vensday "
  862. THEN
  863. THEN
  864. THEN
  865. THEN
  866. THEN
  867. THEN
  868. DROP ;
  869. 8 CONSTANT DWIDTH
  870. : TPMONTH ( n --- ) ( TYPE the name of the month. )
  871. ( DUP 6 < IF * Use this if the compile stack overflows. )
  872. DUP 0 = IF ." Time-division" ELSE ( Fake case format to line the strings up. )
  873. DUP 1 = IF ." Deep-winter " ELSE
  874. DUP 2 = IF ." War-time " ELSE
  875. DUP 3 = IF ." Thaw-time " ELSE
  876. DUP 4 = IF ." Rebirth " ELSE
  877. DUP 5 = IF ." Brides-month" ELSE
  878. ( ." ???" )
  879. ( THEN THEN THEN THEN THEN THEN )
  880. ( ELSE )
  881. DUP 6 = IF ." Imperious " ELSE
  882. DUP 7 = IF ." Senatorious " ELSE
  883. DUP 8 = IF ." False-summer" ELSE
  884. DUP 9 = IF ." Harvest " ELSE
  885. DUP 10 = IF ." Gratitude " ELSE
  886. DUP 11 = IF ." Winter-month" ELSE ( DUP here allows final single DROP. )
  887. ." ??? "
  888. THEN
  889. THEN
  890. THEN
  891. THEN
  892. THEN
  893. THEN
  894. ( For 0 to 5: )
  895. THEN
  896. THEN
  897. THEN
  898. THEN
  899. THEN
  900. THEN
  901. ( THEN )
  902. DROP ;
  903. 13 CONSTANT MWIDTH
  904. CALENDAR-WIDTH @ DPWK / 1 - CONSTANT DFIELD
  905. : WLINELENGTH CALENDAR-WIDTH @ DPWK / DPWK * ;
  906. : DASHES ( count --- ) ( EMIT a string of count DASHes. )
  907. DUP 0 > IF
  908. 0 DO DASH LOOP
  909. ELSE
  910. DROP
  911. THEN
  912. ;
  913. : HLINE ( --- )
  914. PLUS
  915. DPWK 0 DO
  916. DFIELD DASHES PLUS
  917. LOOP
  918. CR
  919. ;
  920. : SPLINE ( --- )
  921. VBAR
  922. DPWK 0 DO
  923. DFIELD SPACES VBAR
  924. LOOP
  925. CR
  926. ;
  927. : PWKDAYS ( --- ) ( Adjust by 1STDAYOFWEEK. )
  928. VBAR
  929. DFIELD DWIDTH - 1 - 2 /MOD
  930. SWAP OVER +
  931. 1STDAYOFWEEK @ DUP DPWK + SWAP
  932. DO
  933. DUP SPACES
  934. I TPWDAY
  935. DUP SPACES OVER SPACES
  936. VBAR
  937. LOOP
  938. CR
  939. DROP DROP
  940. ;
  941. : BOLD ( n1 n2 --- )
  942. = IF STAR ELSE SPACE THEN ;
  943. : PDFIELD ( day1 day2 --- ) ( Print day2 in day field with emphasis if same as day1. )
  944. DFIELD 4 - 2 /MOD ( day1 day2 rem half )
  945. DUP ROT + ( day1 day2 half half+rem )
  946. SPACES >R ( day1 day2 ) ( [ half ] )
  947. 2DUP BOLD DUP 2 .R BOLD ( --- ) ( [ half ] )
  948. R> SPACES
  949. VBAR
  950. ;
  951. ( DPWK days from start, emphasize and reset day if matched for month. )
  952. : DAYLINE ( month day --- month daydone )
  953. VBAR
  954. DPWK 0 DO
  955. OVER CMONTH @ = IF DUP ELSE -1 THEN
  956. CDATE @
  957. PDFIELD
  958. 1 DADJUST
  959. LOOP
  960. CR
  961. ;
  962. : PHLINE ( --- )
  963. VBAR
  964. DPWK 0 DO
  965. SMSHOWPHASE
  966. DFIELD SPHASEWIDTH - FPHASEWIDTH - SPACES
  967. FMSHOWPHASE
  968. VBAR
  969. 1 SLOMADJ 1 FASMADJ
  970. LOOP
  971. CR
  972. ;
  973. : CALMONTH ( year month day --- )
  974. CR
  975. ROT ROT STYCYCLES
  976. CMONTH @ SWAP ( Remember month and day. )
  977. WLINELENGTH MWIDTH - 2 - 2 / SPACES
  978. CYEAR @ 4 .R SPACE
  979. CMONTH @ TPMONTH CR
  980. HLINE
  981. PWKDAYS
  982. HLINE
  983. DOWKSTATE @ 1STDAYOFWEEK @ - DUP 0< IF DPWK + THEN
  984. DUP ( Count of days to back up. )
  985. IF
  986. NEGATE DMADJUST
  987. ELSE
  988. DROP
  989. THEN
  990. BEGIN
  991. SPLINE
  992. DAYLINE
  993. SPLINE
  994. SPLINE
  995. PHLINE
  996. HLINE
  997. OVER CMONTH @ < UNTIL
  998. DROP DROP
  999. ;
  1000. ( Lots -- 10? -- of 0s left behind on modern Forths. )