Forth programs for showing the days in the years and months, with skip years (instead of leap years), for Bobbie, Karel, Dan, and Kristie's world. The novel can be found at http://joel-rees-economics.blogspot.com/2017/01/soc500-00-00-toc.html .

形式
Plain text
投稿日時
2017-04-11 01:35
公開期間
無期限
  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. ( Uses integer math throughout. )
  42. ( Forth expression syntax is mostly postfix. )
  43. ( Only the definition syntax is prefix or infix. )
  44. ( I've added some comments with equivalent infix expressions )
  45. ( to help those unfamiliar with Forth. )
  46. ( Using baroque identifiers for ancient Forths. )
  47. ( fig-Forth used first three character + length significance in symbol tables. )
  48. ( UM*, FM/MOD, and S>D are already there in most modern Forths. )
  49. ( These definitions are only for ancient Forths, )
  50. ( especially pre-1983 fig and bif-c. )
  51. ( Un-comment them if you see errors like )
  52. ( UM* ? err # 0 )
  53. ( from PRMONTH or thereabouts. )
  54. ( : UM* U* ; ) ( modern name for unsigned mixed multiply )
  55. ( This is a cheat! Behavior is not well defined for negative numbers, )
  56. ( but we don't do negatives here. )
  57. ( So this is just sloppy renaming in a sloppy fashion: )
  58. ( : FM/MOD M/MOD DROP ; ) ( unsigned division with modulo remainder )
  59. ( : S>D S->D ; ) ( Modern name for single-to-double. )
  60. ( Showing the above in infix won't help. )
  61. SP@ SP@ - ABS CONSTANT CELLWIDTH
  62. ( Infix won't help here, either, but I can try to explain: )
  63. ( CELLWIDTH = absolute-value-of difference-between SP-without-pointer and SP-with-pointer. )
  64. ( Semi-simulate local variables with the ability to fetch and store relative to top of stack. )
  65. ( Infix will be confusing here, too. )
  66. : LC@ ( index -- sp[ix] ) ( 0 is top. PICK is available on many modern Forths. )
  67. 1 + CELLWIDTH * ( Skip over the stack address on stack. )
  68. SP@ + @ ( Assumes push-down stack. Will fail on push-up. )
  69. ;
  70. ( Infix will be confusing here, too. )
  71. : LC! ( n index -- ) ( 0 is top. Just store. This is not ROLL. )
  72. 2 + CELLWIDTH * ( Index and stack address are extra on stack during calculation. )
  73. SP@ + ( Assumes push-down stack. )
  74. ! ( *** Will fail in MISERABLE ways on push-up stacks! *** )
  75. ;
  76. ( Make things easier to read. )
  77. ( Infix will be confusing here, too. )
  78. : PRCH EMIT ;
  79. : COMMA 44 PRCH ;
  80. : COLON 58 PRCH ;
  81. : POINT 46 PRCH ;
  82. : LPAREN 40 PRCH ;
  83. : RPAREN 41 PRCH ;
  84. ( No trailing space. )
  85. : PSNUM ( number -- )
  86. 0 .R ;
  87. ( Do it in integers! )
  88. ( Watch limits on 16 bit processors! )
  89. 7 CONSTANT SCYCLE ( years in short cycle )
  90. ( SCYCLE = 7 )
  91. 7 2 * CONSTANT SPMCYC ( short cycles in medium cycle )
  92. ( SPMCYC = 7 × 2 )
  93. SCYCLE SPMCYC * CONSTANT MCYCLE ( years in medium cycle, should be 98 )
  94. ( MCYCLE = SCYCLE × SPMCYC )
  95. 7 7 * CONSTANT SPLCYC ( short cycles in single long cycle )
  96. ( SPLCYC = 7 × 7 )
  97. SCYCLE SPLCYC * CONSTANT LCYCLE ( years in single long cycle, should be 343 )
  98. ( LCYCLE = SCYCLE × SPLCYC )
  99. 7 CONSTANT MP2LCYC ( medium cycles in double long cycle )
  100. ( MP2LCYC = 7 )
  101. ( MPLCYC would not be an integer: 3 1/2 )
  102. MCYCLE MP2LCYC * CONSTANT 2LCYCLE ( years in double long cycle, should be 686 )
  103. ( 2LCYCLE = MCYCLE × MP2LCYC )
  104. 352 CONSTANT DPSKIPYEAR ( floor of days per year )
  105. 5 CONSTANT RDSCYCLE ( remainder days in short cycle )
  106. DPSKIPYEAR SCYCLE * RDSCYCLE + CONSTANT DPSCYCLE ( whole days per 7 year cycle )
  107. ( DPSCYCLE = DPSKIPYEAR × SCYCLE + RDSCYCLE )
  108. ( DPSCYCLE SPMCYC * CONSTANT DPMCYCLE )
  109. ( DPMCYCLE = DPSCYCLE × SPMCYC )
  110. ( DPMCYCLE MP2LCYC * CONSTANT DP2LCYCLE )
  111. ( DP2LCYCLE = DPMCYCLE × MP2LCYC )
  112. ( DPMCYCLE and DP2LCYCLE would overflow on 16 bit math CPUs. )
  113. ( No particular problem on 32 bit CPUs.
  114. RDSCYCLE SPMCYC * 1 - CONSTANT RDMCYCLE ( remainder days in medium cycle )
  115. ( RDMCYCLE = RDSCYCLE × SPMCYC - 1 )
  116. RDMCYCLE MP2LCYC * 2 + CONSTANT RD2LCYCLE ( remainder days in double long cycle -- odd number )
  117. ( RD2LCYCLE = RDMCYCLE × MP2LCYC + 2 )
  118. ( RD2LCYCLE / 2LCYCLE is fractional part of year. )
  119. ( Ergo, length of year is DPSKIPYEAR + RD2LCYCLE / 2LCYCLE, )
  120. ( or 352 485/686 days. )
  121. 12 CONSTANT MPYEAR ( months per year )
  122. DPSKIPYEAR MPYEAR /MOD CONSTANT FDMONTH ( floor of days per month )
  123. ( FDMONTH = DPSKIPYEAR / MPYEAR )
  124. CONSTANT FRMONTH ( floored minimum remainder days per month )
  125. ( FRMONTH = DPSKIPYEAR MOD MPYEAR )
  126. 2LCYCLE MPYEAR * CONSTANT MDENOMINATOR ( denominator of month fractional part )
  127. ( MDENOMINATOR = 2LCYCLE × MPYEAR )
  128. FRMONTH 2LCYCLE * RD2LCYCLE + CONSTANT MNUMERATOR ( numerator of month fractional part )
  129. ( MNUMERATOR = FRMONTH × 2LCYCLE + RD2LCYCLE )
  130. ( Ergo, length of month is FDMONTH + MNUMERATOR / MDENOMINATOR, )
  131. ( or 29 3229/8232 days. )
  132. MDENOMINATOR 2 / CONSTANT MROUNDFUDGE
  133. ( Infix will be confusing below here, as well. )
  134. ( Hopefully, the comments and explanations will provide enough clues. )
  135. ( Sum up the days of the months in a year. )
  136. : SU1MONTH ( startfractional startdays -- endfractional enddays )
  137. FDMONTH + ( Add the whole part. )
  138. SWAP ( Make the fractional part available to work on. )
  139. MNUMERATOR + ( Add the fractional part. )
  140. DUP MDENOMINATOR < ( Have we got a whole day yet? )
  141. IF
  142. SWAP ( No, restore stack order for next pass. )
  143. ELSE
  144. MDENOMINATOR - ( Take one whole day from the fractional part. )
  145. SWAP 1+ ( Restore stack and add the day carried in. )
  146. ENDIF
  147. ;
  148. : PRMONTH ( fractional days -- fractional days )
  149. SPACE DUP PSNUM POINT ( whole days )
  150. OVER 1000 UM* ( Fake three digits of decimal precision. )
  151. MROUNDFUDGE 0 D+ ( Round the bottom digit. )
  152. MDENOMINATOR FM/MOD ( Divide, or evaluate the fraction. )
  153. S>D <# # # # #> ( Formatting puts most significant digits in buffer first. )
  154. TYPE ( Fake decimal output. )
  155. DROP SPACE
  156. ;
  157. : SH1IDEALYEAR ( year daysmemory fractional days -- year daysmemory fractional days )
  158. CR
  159. 12 0 DO
  160. 3 LC@ PSNUM SPACE ( year )
  161. I PSNUM COLON SPACE
  162. SU1MONTH
  163. DUP 3 LC@ - ( difference in days )
  164. 2 LC@ ( ceiling ) IF 1+ ENDIF
  165. DUP PSNUM SPACE ( show theoretical days in month )
  166. 3 LC@ + ( sum of days )
  167. LPAREN DUP PSNUM COMMA SPACE
  168. 2 LC! ( update )
  169. PRMONTH RPAREN CR
  170. LOOP
  171. ;
  172. : SHOWIDEALMONTHS ( years -- )
  173. >R
  174. 0 0 0 0 ( year, daysmemory, fractional, days )
  175. R> 0 DO
  176. CR
  177. SH1IDEALYEAR
  178. 3 LC@ 1+ 3 LC!
  179. LOOP
  180. DROP DROP DROP DROP
  181. ;
  182. 0 CONSTANT SKMONTH
  183. 1 CONSTANT SK1SHORTCYC
  184. 4 CONSTANT SK2SHORTCYC
  185. 48 CONSTANT SKMEDIUMCYC
  186. 186 CONSTANT LPLONGCYC ( Must be short1 or short2 within the seven year cycle. )
  187. ( Since skipyears are the exception, )
  188. ( we test for skipyears instead of leapyears. )
  189. ( Calendar system starts with year 0, not year 1. )
  190. ( Would need to check and adjust if the calendar started with year )
  191. : ISKIPYEAR ( year -- flag )
  192. DUP MCYCLE MOD SKMEDIUMCYC =
  193. IF DROP -1 ( One specified extra skip year in medium cycle. )
  194. ELSE
  195. DUP SCYCLE MOD DUP
  196. SK1SHORTCYC =
  197. SWAP SK2SHORTCYC = OR ( Two specified skip years in short cycle, but ... )
  198. SWAP LCYCLE MOD LPLONGCYC = 0= AND ( not the specified exception in the long cycle. )
  199. ENDIF
  200. ;
  201. ( At this point, I hit a condundrum. )
  202. ( Modern "standard" Forths want uninitialized variables, )
  203. ( but ancient, especially fig-Forths want initialized variables. )
  204. ( The lower-level <BUILDS DOES> for fig is only partially part of the modern standard. )
  205. ( And CREATE is initialized as a CONSTANT in the fig-Forth, )
  206. ( but has no initial characteristic code or value in modern standards. )
  207. ( So. )
  208. ( On ancient Forths, VARIABLE wants an initial value. We give it a zero. )
  209. ( The zero stays around forever on modern Forths, or until you drop it. )
  210. 0 VARIABLE DIMARRAY ( Days In Months array )
  211. 30 DIMARRAY ! ( 1st month )
  212. 29 ,
  213. 30 ,
  214. 29 ,
  215. 29 ,
  216. 30 ,
  217. 29 ,
  218. 30 ,
  219. 29 ,
  220. 29 ,
  221. 30 ,
  222. 29 ,
  223. 0 ,
  224. : DIMONTH ( year month -- days )
  225. DUP 0 < 0=
  226. OVER MPYEAR < AND 0=
  227. IF
  228. DROP DROP 0 ( Out of range. No days. )
  229. ELSE
  230. DUP CELLWIDTH * DIMARRAY + @ ( Get the basic days. )
  231. SWAP SKMONTH = ( true if skip month )
  232. ROT ISKIPYEAR AND ( true if skip month of skip year )
  233. 1 AND - ( Subtrahend is 1 only if skip month of skip year. )
  234. ENDIF
  235. ;
  236. : SH1YEAR ( year daysmemory fractional days -- year daysmemory fractional days )
  237. CR
  238. 12 0 DO
  239. 3 LC@ PSNUM SPACE ( year )
  240. I PSNUM COLON SPACE
  241. SU1MONTH ( ideal month )
  242. 3 LC@ I DIMONTH ( real month )
  243. DUP PSNUM SPACE ( show days in month )
  244. 3 LC@ + ( sum of days )
  245. LPAREN DUP PSNUM COMMA SPACE
  246. 2 LC! ( update )
  247. PRMONTH RPAREN CR
  248. LOOP
  249. ;
  250. : SHOWMONTHS ( years -- )
  251. >R
  252. 0 0 0 0 ( year, daysmemory, fractional, days )
  253. R> 0 DO
  254. CR
  255. SH1YEAR
  256. 3 LC@ 1+ 3 LC!
  257. LOOP
  258. DROP DROP DROP DROP
  259. ;
  260. ( Below here is scratch work I'm leaving for my notes. )
  261. ( It can be deleted. )
  262. : V2-SHOWMONTHS ( years -- )
  263. >R
  264. 0 0 0 ( daysmemory, fractional, days )
  265. R> 0 DO
  266. CR
  267. 12 0 DO
  268. J PSNUM SPACE ( year )
  269. I PSNUM COLON SPACE
  270. SU1MONTH
  271. DUP 3 LC@ - ( difference in days )
  272. 2 LC@ ( ceiling ) IF 1+ ENDIF
  273. DUP PSNUM SPACE ( show theoretical days in month )
  274. 3 LC@ + ( sum of days )
  275. LPAREN DUP PSNUM COMMA SPACE
  276. 2 LC! ( update )
  277. PRMONTH RPAREN CR
  278. LOOP
  279. LOOP
  280. DROP DROP DROP
  281. ;
  282. : NUMERATORS ( count -- )
  283. DUP 1+ 0 DO
  284. I PSNUM COLON SPACE
  285. I 1000 * OVER / PSNUM COMMA ( 1000 times I divided by count )
  286. SPACE LOOP
  287. DROP ;
  288. : FRACTIONS ( count -- )
  289. 1 DO
  290. I NUMERATORS CR
  291. LOOP ;
  292. ( : ABS number -- absolute-value *** built in! *** )
  293. ( DUP 0< IF NEGATE THEN ; )
  294. : WITHIN1 ( n1 n2 -- flag )
  295. - ABS 1 <= ; ( n1 and n2 are within 1 of each other )
  296. ( Negatives end in division by zero or infinite loop. )
  297. : SQRT ( number -- square-root )
  298. DUP IF ( square root of zero is zero. )
  299. ABS
  300. 2 ( initial guess )
  301. BEGIN
  302. OVER OVER / ( test guess by divide )
  303. OVER OVER - ABS 1 <= ( number guess quotient flag )
  304. IF ( number guess quotient )
  305. MIN -1 ( number result flag )
  306. ELSE
  307. OVER + 2 / ( number guess avg )
  308. SWAP OVER ( number avg guess avg )
  309. - 1 <= ( number avg flag ) ( Integer average will always be floored. )
  310. ENDIF
  311. UNTIL ( number result )
  312. SWAP DROP
  313. ENDIF ;
  314. 353 CONSTANT DPYEAR ( nominal days per year )
  315. 7 CONSTANT 7YEARS
  316. 2 CONSTANT DS7CYCLE ( days short in seven year cycle )
  317. DPYEAR 7YEARS * DS7CYCLE - CONSTANT DP7YEAR ( whole days per 7 year cycle )
  318. 7YEARS 7 2 * * CONSTANT 98YEARS
  319. 98YEARS 7YEARS / DS7CYCLE * 1 + CONSTANT DS98CYCLE ( days short in 98 year cycle )
  320. 98YEARS 7 * CONSTANT 686YEARS
  321. 686YEARS 98YEARS / DS98CYCLE * 2 - CONSTANT DS686CYCLE ( days short in 686 year cycle )
ダウンロード 印刷用表示

このコピペの URL

JavaScript での埋め込み

iframe での埋め込み

元のテキスト