/contrib/worldclock/worldclock.forth

https://github.com/zeroflag/punyforth · Forth · 1578 lines · 1352 code · 226 blank · 0 comment · 56 complexity · 7deaa0a27f28b43bd52c5c6fc71e7917 MD5 · raw file

  1. \ World Clock App
  2. \ Misc Forth Utilities
  3. \ Written for PunyForth
  4. \ By: Craig A. Lindley and others
  5. \ Last Update: 01/21/2017
  6. \ (* Surround multiline comments with these *)
  7. : (*
  8. begin
  9. begin key [ char: * ] literal = until
  10. key [ char: ) ] literal =
  11. if
  12. exit
  13. then
  14. again
  15. ; immediate
  16. \ Add missing functions
  17. : negate -1 * ;
  18. : r@ ( -- n )
  19. r> r> dup >r swap >r ;
  20. ;
  21. \ ST7735 65K Color LCD Display Driver for the Adafruit 1.8" SPI LCD
  22. \ Only supports landscape mode with LCD connector on right
  23. \ Written for PunyForth
  24. \ By: Craig A. Lindley
  25. \ Last Update: 01/21/2017
  26. \ Must have core and gpio modules loaded
  27. \ Define the wiring between the NodeMCU Amica and the LCD display
  28. 14 constant: SCL \ SCL D5
  29. 13 constant: SDA \ SDA D7
  30. 2 constant: DC \ DC D4
  31. 15 constant: CS \ CS D8
  32. \ NOTE: the RESET and LITE signals on the LCD are tied to 3.3VDC
  33. \ SPI interface number
  34. 1 constant: BUS
  35. \ Define some 16 bit color values
  36. hex: 0000 constant: BLK
  37. hex: F800 constant: RED
  38. hex: FFE0 constant: YEL
  39. hex: 07E0 constant: GRN
  40. hex: 001F constant: BLU
  41. hex: 07FF constant: CYA
  42. hex: F81F constant: MAG
  43. hex: FFFF constant: WHT
  44. \ ST7735 commands
  45. hex: 01 constant: SWRST \ software reset
  46. hex: 11 constant: SLPOUT \ sleep out
  47. hex: 29 constant: DISPON \ display on
  48. hex: 2A constant: CASET \ column address set
  49. hex: 2B constant: RASET \ row address set
  50. hex: 2C constant: RAMWR \ RAM write
  51. hex: 36 constant: MADCTL \ pixel direction control
  52. hex: 3A constant: COLMOD \ color mode
  53. \ Display rotation constants
  54. hex: 80 constant: CTL_MY
  55. hex: 40 constant: CTL_MX
  56. hex: 20 constant: CTL_MV
  57. \ hex: 08 constant: CTL_BGR
  58. exception: EST7735
  59. \ Display dimensions in landscape mode
  60. 160 constant: WIDTH
  61. 128 constant: HEIGHT
  62. \ Check result of SPI write
  63. : cWrt ( code -- | EST7735 )
  64. 255 <> if
  65. EST7735 throw
  66. then
  67. ;
  68. \ Write an 8 bit command to the display via SPI
  69. : wCmd ( cmd -- | EST7735 )
  70. DC GPIO_LOW gpio-write
  71. CS GPIO_LOW gpio-write
  72. BUS spi-send8
  73. cWrt
  74. CS GPIO_HIGH gpio-write
  75. ;
  76. \ Write 8 bit data to the display via SPI
  77. : w8 ( data -- | EST7735 )
  78. DC GPIO_HIGH gpio-write
  79. CS GPIO_LOW gpio-write
  80. BUS spi-send8
  81. cWrt
  82. CS GPIO_HIGH gpio-write
  83. ;
  84. \ Write 16 bit data to the display via SPI
  85. : w16 ( data -- | EST7735 )
  86. DC GPIO_HIGH gpio-write
  87. CS GPIO_LOW gpio-write
  88. dup
  89. 8 rshift BUS spi-send8
  90. cWrt
  91. hex: FF and BUS spi-send8
  92. cWrt
  93. CS GPIO_HIGH gpio-write
  94. ;
  95. \ Initialize the SPI interface and the display controller
  96. : initLCD ( -- | EST7735 )
  97. \ Initilize GPIO pins
  98. DC GPIO_OUT gpio-mode
  99. CS GPIO_OUT gpio-mode
  100. DC GPIO_LOW gpio-write
  101. CS GPIO_HIGH gpio-write
  102. \ Setup SPI interface
  103. TRUE 1 TRUE 2 10 16 lshift swap 65535 and or 0 BUS
  104. spi-init 1 <> if
  105. EST7735 throw
  106. then
  107. \ Initialize the display controller for operation
  108. SWRST wCmd
  109. 200 ms
  110. SLPOUT wCmd
  111. 500 ms
  112. \ Set 16 bit color
  113. COLMOD wCmd
  114. 100 ms
  115. hex: 05 w8
  116. 100 ms
  117. MADCTL wCmd
  118. \ Must add CTL_BGR for Sainsmart display
  119. CTL_MY CTL_MV or w8
  120. 100 ms
  121. DISPON wCmd
  122. 200 ms
  123. ;
  124. \ Temp variables
  125. variable: _wx0_
  126. variable: _wy0_
  127. variable: _wx1_
  128. variable: _wy1_
  129. \ Sets a rectangular display window into which pixel data is written
  130. \ Values should be set into variable above before call
  131. : setWin ( -- )
  132. CASET wCmd
  133. _wx0_ @ w16
  134. _wx1_ @ w16
  135. RASET wCmd
  136. _wy0_ @ w16
  137. _wy1_ @ w16
  138. RAMWR wCmd
  139. ;
  140. \ Graphic Functions for the ST7735 65K Color LCD Controller
  141. \ Written for PunyForth
  142. \ By: Craig A. Lindley
  143. \ Last Update: 01/21/2017
  144. \ Must have ST7735 loaded
  145. \ Temp variables
  146. variable: _w_
  147. variable: _h_
  148. \ Draw a pixel on the display
  149. : pixel ( x y color -- )
  150. >r
  151. dup _wy0_ ! _wy1_ !
  152. dup _wx0_ ! _wx1_ !
  153. setWin
  154. r>
  155. w16 ;
  156. \ Fill a rectangle on the display
  157. : fillRect ( x0 y0 x1 y1 color -- )
  158. >r
  159. _wy1_ ! _wx1_ ! _wy0_ ! _wx0_ !
  160. _wx1_ @ _wx0_ @ - 1+ _w_ !
  161. _wy1_ @ _wy0_ @ - 1+ _h_ !
  162. setWin
  163. r>
  164. _w_ @ _h_ @ * 0
  165. do
  166. dup w16
  167. loop
  168. drop ;
  169. \ Draw horizontal line of length with color
  170. : hLine ( x y len color -- )
  171. >r ( x y len color -- x y len )
  172. >r ( x y len -- x y )
  173. over over ( x y -- x y x y )
  174. swap ( x y x y -- x y y x )
  175. r> ( x y y x --- x y y x len )
  176. + ( x y y x len -- x y y x+len )
  177. swap ( x y y x+len -- x y x+len y )
  178. r> ( x y x+len y -- x y x+len y color )
  179. fillRect ( x y x+len y color -- )
  180. ;
  181. \ Draw vertical line of length with color
  182. : vLine ( x y len color -- )
  183. >r ( x y len color -- x y len )
  184. over ( x y len -- x y len y )
  185. + ( x y len y -- x y y+len )
  186. >r ( x y y+len -- x y )
  187. over ( x y -- x y x )
  188. r> ( x y x -- x y x y+len )
  189. r> ( x y x y+len -- x y x y+len color )
  190. fillRect ( x y x y+len color -- )
  191. ;
  192. \ Text Functions for the ST7735 65K Color LCD Controller
  193. \ Written for PunyForth
  194. \ By: Craig A. Lindley
  195. \ Last Update: 01/21/2017
  196. 5 constant: FW
  197. 7 constant: FH
  198. \ 5x7 font for characters 0x20 .. 0x7E
  199. create: FNT
  200. hex: 00 c, hex: 00 c, hex: 00 c, hex: 00 c, hex: 00 c, \ space
  201. hex: 00 c, hex: 00 c, hex: 5F c, hex: 00 c, hex: 00 c, \ !
  202. hex: 00 c, hex: 07 c, hex: 00 c, hex: 07 c, hex: 00 c, \ "
  203. hex: 14 c, hex: 7F c, hex: 14 c, hex: 7F c, hex: 14 c, \ #
  204. hex: 24 c, hex: 2A c, hex: 7F c, hex: 2A c, hex: 12 c, \ $
  205. hex: 23 c, hex: 13 c, hex: 08 c, hex: 64 c, hex: 62 c, \ %
  206. hex: 36 c, hex: 49 c, hex: 56 c, hex: 20 c, hex: 50 c, \ &
  207. hex: 00 c, hex: 08 c, hex: 07 c, hex: 03 c, hex: 00 c, \ '
  208. hex: 00 c, hex: 1C c, hex: 22 c, hex: 41 c, hex: 00 c, \ (
  209. hex: 00 c, hex: 41 c, hex: 22 c, hex: 1C c, hex: 00 c, \ )
  210. hex: 2A c, hex: 1C c, hex: 7F c, hex: 1C c, hex: 2A c, \ *
  211. hex: 08 c, hex: 08 c, hex: 3E c, hex: 08 c, hex: 08 c, \ +
  212. hex: 00 c, hex: 80 c, hex: 70 c, hex: 30 c, hex: 00 c, \ ,
  213. hex: 08 c, hex: 08 c, hex: 08 c, hex: 08 c, hex: 08 c, \ -
  214. hex: 00 c, hex: 00 c, hex: 60 c, hex: 60 c, hex: 00 c, \ .
  215. hex: 20 c, hex: 10 c, hex: 08 c, hex: 04 c, hex: 02 c, \ /
  216. hex: 3E c, hex: 51 c, hex: 49 c, hex: 45 c, hex: 3E c, \ 0
  217. hex: 00 c, hex: 42 c, hex: 7F c, hex: 40 c, hex: 00 c, \ 1
  218. hex: 72 c, hex: 49 c, hex: 49 c, hex: 49 c, hex: 46 c, \ 2
  219. hex: 21 c, hex: 41 c, hex: 49 c, hex: 4D c, hex: 33 c, \ 3
  220. hex: 18 c, hex: 14 c, hex: 12 c, hex: 7F c, hex: 10 c, \ 4
  221. hex: 27 c, hex: 45 c, hex: 45 c, hex: 45 c, hex: 39 c, \ 5
  222. hex: 3C c, hex: 4A c, hex: 49 c, hex: 49 c, hex: 31 c, \ 6
  223. hex: 41 c, hex: 21 c, hex: 11 c, hex: 09 c, hex: 07 c, \ 7
  224. hex: 36 c, hex: 49 c, hex: 49 c, hex: 49 c, hex: 36 c, \ 8
  225. hex: 46 c, hex: 49 c, hex: 49 c, hex: 29 c, hex: 1E c, \ 9
  226. hex: 00 c, hex: 00 c, hex: 14 c, hex: 00 c, hex: 00 c, \ :
  227. hex: 00 c, hex: 40 c, hex: 34 c, hex: 00 c, hex: 00 c, \ ;
  228. hex: 00 c, hex: 08 c, hex: 14 c, hex: 22 c, hex: 41 c, \ <
  229. hex: 14 c, hex: 14 c, hex: 14 c, hex: 14 c, hex: 14 c, \ =
  230. hex: 00 c, hex: 41 c, hex: 22 c, hex: 14 c, hex: 08 c, \ >
  231. hex: 02 c, hex: 01 c, hex: 59 c, hex: 09 c, hex: 06 c, \ ?
  232. hex: 3E c, hex: 41 c, hex: 5D c, hex: 59 c, hex: 4E c, \ @
  233. hex: 7C c, hex: 12 c, hex: 11 c, hex: 12 c, hex: 7C c, \ A
  234. hex: 7F c, hex: 49 c, hex: 49 c, hex: 49 c, hex: 36 c, \ B
  235. hex: 3E c, hex: 41 c, hex: 41 c, hex: 41 c, hex: 22 c, \ C
  236. hex: 7F c, hex: 41 c, hex: 41 c, hex: 41 c, hex: 3E c, \ D
  237. hex: 7F c, hex: 49 c, hex: 49 c, hex: 49 c, hex: 41 c, \ E
  238. hex: 7F c, hex: 09 c, hex: 09 c, hex: 09 c, hex: 01 c, \ F
  239. hex: 3E c, hex: 41 c, hex: 41 c, hex: 51 c, hex: 73 c, \ G
  240. hex: 7F c, hex: 08 c, hex: 08 c, hex: 08 c, hex: 7F c, \ H
  241. hex: 00 c, hex: 41 c, hex: 7F c, hex: 41 c, hex: 00 c, \ I
  242. hex: 20 c, hex: 40 c, hex: 41 c, hex: 3F c, hex: 01 c, \ J
  243. hex: 7F c, hex: 08 c, hex: 14 c, hex: 22 c, hex: 41 c, \ K
  244. hex: 7F c, hex: 40 c, hex: 40 c, hex: 40 c, hex: 40 c, \ L
  245. hex: 7F c, hex: 02 c, hex: 1C c, hex: 02 c, hex: 7F c, \ M
  246. hex: 7F c, hex: 04 c, hex: 08 c, hex: 10 c, hex: 7F c, \ N
  247. hex: 3E c, hex: 41 c, hex: 41 c, hex: 41 c, hex: 3E c, \ O
  248. hex: 7F c, hex: 09 c, hex: 09 c, hex: 09 c, hex: 06 c, \ P
  249. hex: 3E c, hex: 41 c, hex: 51 c, hex: 21 c, hex: 5E c, \ Q
  250. hex: 7F c, hex: 09 c, hex: 19 c, hex: 29 c, hex: 46 c, \ R
  251. hex: 26 c, hex: 49 c, hex: 49 c, hex: 49 c, hex: 32 c, \ S
  252. hex: 03 c, hex: 01 c, hex: 7F c, hex: 01 c, hex: 03 c, \ T
  253. hex: 3F c, hex: 40 c, hex: 40 c, hex: 40 c, hex: 3F c, \ U
  254. hex: 1F c, hex: 20 c, hex: 40 c, hex: 20 c, hex: 1F c, \ V
  255. hex: 3F c, hex: 40 c, hex: 38 c, hex: 40 c, hex: 3F c, \ W
  256. hex: 63 c, hex: 14 c, hex: 08 c, hex: 14 c, hex: 63 c, \ X
  257. hex: 03 c, hex: 04 c, hex: 78 c, hex: 04 c, hex: 03 c, \ Y
  258. (*
  259. hex: 61 c, hex: 59 c, hex: 49 c, hex: 4D c, hex: 43 c, \ Z \ Z unused
  260. hex: 00 c, hex: 7F c, hex: 41 c, hex: 41 c, hex: 41 c, \ [
  261. hex: 02 c, hex: 04 c, hex: 08 c, hex: 10 c, hex: 20 c, \ \
  262. hex: 00 c, hex: 41 c, hex: 41 c, hex: 41 c, hex: 7F c, \ ]
  263. hex: 04 c, hex: 02 c, hex: 01 c, hex: 02 c, hex: 04 c, \ ^
  264. hex: 40 c, hex: 40 c, hex: 40 c, hex: 40 c, hex: 40 c, \ _
  265. hex: 00 c, hex: 03 c, hex: 07 c, hex: 08 c, hex: 00 c, \ `
  266. hex: 20 c, hex: 54 c, hex: 54 c, hex: 78 c, hex: 40 c, \ a
  267. hex: 7F c, hex: 28 c, hex: 44 c, hex: 44 c, hex: 38 c, \ b
  268. hex: 38 c, hex: 44 c, hex: 44 c, hex: 44 c, hex: 28 c, \ c
  269. hex: 38 c, hex: 44 c, hex: 44 c, hex: 28 c, hex: 7F c, \ d
  270. hex: 38 c, hex: 54 c, hex: 54 c, hex: 54 c, hex: 18 c, \ e
  271. hex: 00 c, hex: 08 c, hex: 7E c, hex: 09 c, hex: 02 c, \ f
  272. hex: 18 c, hex: A4 c, hex: A4 c, hex: 9C c, hex: 78 c, \ g
  273. hex: 7F c, hex: 08 c, hex: 04 c, hex: 04 c, hex: 78 c, \ h
  274. hex: 00 c, hex: 44 c, hex: 7D c, hex: 40 c, hex: 00 c, \ i
  275. hex: 20 c, hex: 40 c, hex: 40 c, hex: 3D c, hex: 00 c, \ j
  276. hex: 7F c, hex: 10 c, hex: 28 c, hex: 44 c, hex: 00 c, \ k
  277. hex: 00 c, hex: 41 c, hex: 7F c, hex: 40 c, hex: 00 c, \ l
  278. hex: 7C c, hex: 04 c, hex: 78 c, hex: 04 c, hex: 78 c, \ m
  279. hex: 7C c, hex: 08 c, hex: 04 c, hex: 04 c, hex: 78 c, \ n
  280. hex: 38 c, hex: 44 c, hex: 44 c, hex: 44 c, hex: 38 c, \ o
  281. hex: FC c, hex: 18 c, hex: 24 c, hex: 24 c, hex: 18 c, \ p
  282. hex: 18 c, hex: 24 c, hex: 24 c, hex: 18 c, hex: FC c, \ q
  283. hex: 7C c, hex: 08 c, hex: 04 c, hex: 04 c, hex: 08 c, \ r
  284. hex: 48 c, hex: 54 c, hex: 54 c, hex: 54 c, hex: 24 c, \ s
  285. hex: 04 c, hex: 04 c, hex: 3F c, hex: 44 c, hex: 24 c, \ t
  286. hex: 3C c, hex: 40 c, hex: 40 c, hex: 20 c, hex: 7C c, \ u
  287. hex: 1C c, hex: 20 c, hex: 40 c, hex: 20 c, hex: 1C c, \ v
  288. hex: 3C c, hex: 40 c, hex: 30 c, hex: 40 c, hex: 3C c, \ w
  289. hex: 44 c, hex: 28 c, hex: 10 c, hex: 28 c, hex: 44 c, \ x
  290. hex: 4C c, hex: 90 c, hex: 90 c, hex: 90 c, hex: 7C c, \ y
  291. hex: 44 c, hex: 64 c, hex: 54 c, hex: 4C c, hex: 44 c, \ z
  292. *)
  293. \ Foreground and background color storage
  294. WHT init-variable: fgC
  295. BLK init-variable: bgC
  296. \ Set the text's foreground color
  297. : setFG ( color -- )
  298. fgC !
  299. ;
  300. \ Set the text's background color
  301. : setBG ( color -- )
  302. bgC !
  303. ;
  304. 1 init-variable: _sz_
  305. \ Set the size of the text
  306. : setSize ( size -- )
  307. _sz_ !
  308. ;
  309. \ A variation on fillRect
  310. : fr ( x y width height color -- )
  311. >r ( x y width height color -- x y width height )
  312. rot ( x y width height -- x width height y )
  313. dup ( x width height y -- x width height y y )
  314. rot ( x width height y y -- x width y y height )
  315. + ( x width y y height -- x width y y+height )
  316. >r ( x width y y+height -- x width y )
  317. -rot ( x width y -- y x width )
  318. over ( y x width -- y x width x )
  319. + ( y x width x -- y x x+width )
  320. >r ( y x width+x -- y x )
  321. swap ( y x -- x y )
  322. r> ( x y -- x y x+width )
  323. r> ( x y x+width -- x y x+width y+height )
  324. r> ( x y x+width y+height -- x y x+width y+height color )
  325. fillRect ( x y x+width y+height color -- )
  326. ;
  327. variable: _c_
  328. \ Print a character from the font
  329. : pChr ( x y c -- )
  330. \ For this app convert LC chars to UC chars
  331. dup ( x y c -- x y c c )
  332. hex: 61 ( x y c c -- x y c c x61 )
  333. swap ( x y c c x61 -- x y c x61 c )
  334. hex: 7A ( x y c x61 c -- x y c x61 c x7A )
  335. between? ( x y c x61 c x7A -- x y c f )
  336. if
  337. hex: DF and
  338. then
  339. \ Calculate offset of char data in font
  340. hex: 20 - FW * ( x y c -- x y offset )
  341. FW 1+ 0 \ For each column
  342. do
  343. dup ( x y offset -- x y offset offset )
  344. FNT + i + c@ ( x y offset offset -- x y offset c )
  345. i 5 = \ Add a blank final column between characters
  346. if
  347. drop 0
  348. then
  349. 8 0 \ For each row
  350. do
  351. dup ( x y offset c -- x y offset c c )
  352. 1 i lshift ( x y offset c c -- x y offset c c mask )
  353. and ( x y offset c c mask -- x y offset c f )
  354. if
  355. fgC @ ( x y offset c -- x y offset c color )
  356. else
  357. bgC @ ( x y offset c -- x y offset c color )
  358. then
  359. _c_ ! ( x y offset c color -- x y offset c )
  360. 2over ( x y offset c -- x y offset c x y )
  361. swap ( x y offset c x y -- x y offset c y x )
  362. _sz_ @ 1 =
  363. if \ No scaling ?
  364. j + ( x y offset c y x -- x y offset c y x+j )
  365. swap ( x y offset c y x+j -- x y offset c x+j y )
  366. i + ( x y offset c x+j y -- x y offset c x+j y+i )
  367. _c_ @ ( x y offset c x+j y+i -- x y offset c x+j y+i color )
  368. pixel ( x y offset c x+j y+i color -- x y offset c )
  369. else \ Scaling
  370. _sz_ @ dup ( x y offset c y x -- x y offset c y x size size )
  371. j * ( x y offset c y x size size -- x y offset c y x size size*j )
  372. swap ( x y offset c y x size size*j -- x y offset c y x size*j size )
  373. i * ( x y offset c y x size*j size -- x y offset c y x size*j size*i )
  374. rot rot ( x y offset c y x size*j size*i -- x y offset c y size*i x size*j )
  375. + ( x y offset c y size*i x size*j -- x y offset c y size*i x+size*j )
  376. rot rot ( x y offset c y size*i x+size*j -- x y offset c x+size*j y size*i )
  377. + ( x y offset c x+size*j y size*i -- x y offset c x+size*j y+size*i )
  378. _sz_ @ dup ( x y offset c x+size*j y+size*i -- x y offset c x+size*j y+size*i size size )
  379. _c_ @ ( ... x+size*j y+size*i size size -- ... x+size*j y+size*i size size color )
  380. fr ( ... x+size*j y+size*i size size color -- x y offset c )
  381. then
  382. loop
  383. drop
  384. loop
  385. 3drop
  386. ;
  387. \ Print zero terminated string onto display at specified position
  388. \ with current text size and foreground and background colors
  389. : pStr ( x y addr -- )
  390. begin
  391. dup ( x y addr -- x y addr addr )
  392. c@ dup ( x y addr addr -- x y addr c c )
  393. 0 <> ( x y addr c c -- x y addr c f )
  394. while
  395. >r ( x y addr c -- x y addr )
  396. 3dup ( x y addr -- x y addr x y addr )
  397. -rot ( x y addr x y addr -- x y addr addr x y )
  398. r> ( x y addr addr x y -- x y addr addr x y c )
  399. pChr ( x y addr addr x y c -- x y addr addr )
  400. drop ( x y addr addr -- x y addr )
  401. 1+ ( x y addr -- x y addr+1 )
  402. rot ( x y addr+1 -- y addr+1 x )
  403. FW 1+ _sz_ @ * + ( y addr+1 x -- y addr+1 x' )
  404. -rot ( y addr+1 x' -- 'x y addr+1 )
  405. repeat
  406. 4drop
  407. ;
  408. \ Print a horizontally centered text string
  409. : pCStr ( y addr -- )
  410. dup ( y addr -- y addr addr )
  411. strlen ( y addr addr -- y addr len )
  412. FW 1+ _sz_ @ * * ( y addr len -- y addr pixelcount )
  413. WIDTH ( y addr pixelcount -- y addr pixelcount width )
  414. swap ( y addr pixelcount width -- y addr width pixelcount )
  415. - ( y addr width pixelcount -- y addr width-pixelcount )
  416. 2 / ( y addr width-pixelcount -- y addr x )
  417. rot rot ( y addr x -- x y addr )
  418. pStr
  419. ;
  420. \ NTP - Network Time Protocol Access
  421. \ Written for PunyForth
  422. \ By: Craig A. Lindley
  423. \ Last Update: 01/21/2017
  424. \ Program Constants
  425. 123 constant: NTP_PRT \ Port to send NTP requests to
  426. 48 constant: PK_SZ \ NTP time stamp in first 48 bytes of message
  427. \ Buffer for UDP packets
  428. PK_SZ byte-array: pBuf
  429. \ NTP server host
  430. str: "time.nist.gov" constant: NTP_SRV
  431. \ Send an NTP request packet and read response packet
  432. : getTime ( -- secondsSince1970 | 0 )
  433. \ Clear all bytes of the packet buffer
  434. PK_SZ 0
  435. do
  436. 0 i pBuf c!
  437. loop
  438. \ Initialize values needed to form NTP request
  439. hex: E3 0 pBuf c! \ LI, Version, Mode
  440. hex: 06 2 pBuf c! \ Polling interval
  441. hex: EC 3 pBuf c! \ Peer clock precision
  442. hex: 31 12 pBuf c!
  443. hex: 4E 13 pBuf c!
  444. hex: 31 14 pBuf c!
  445. hex: 34 15 pBuf c!
  446. \ Send the UDP packet containing the NTP request
  447. \ Make connection to NTP server
  448. NTP_PRT NTP_SRV UDP netcon-connect
  449. \ Send the NTP packet
  450. dup 0 pBuf PK_SZ netcon-send-buf
  451. \ Read response into buffer
  452. dup
  453. PK_SZ 0 pBuf netcon-read ( -- netcon bytesRead )
  454. swap ( netcon bytesRead -- bytesRead netcon )
  455. \ Terminate the connection
  456. netcon-dispose ( bytesRead netcon -- bytesRead )
  457. PK_SZ =
  458. if
  459. \ Assemble the response into time value
  460. 40 pBuf c@ 24 lshift
  461. 41 pBuf c@ 16 lshift or
  462. 42 pBuf c@ 8 lshift or
  463. 43 pBuf c@ or
  464. 2208988800 - \ SECS_TO_1970
  465. else
  466. 0
  467. then
  468. ;
  469. \ Time Library
  470. \ Based on Arduino Time library by Michael Margolis & Paul Stoffregen
  471. \ Written for PunyForth
  472. \ By: Craig A. Lindley
  473. \ Last Update: 01/21/2017
  474. \ Program constants
  475. 60 constant: SPM
  476. SPM 60 * constant: SPH
  477. SPH 24 * constant: SPD
  478. 600 constant: syncInt \ NTP time refresh interval in seconds
  479. \ Program variables
  480. variable: sysTime \ System time
  481. variable: prevMS
  482. variable: nextSync
  483. variable: cacheTime
  484. \ Time element structure - holds time and date
  485. struct
  486. cell field: .second
  487. cell field: .minute
  488. cell field: .hour
  489. cell field: .wday \ Day of week, sunday is day 1
  490. cell field: .day
  491. cell field: .month
  492. cell field: .year
  493. constant: timeElements
  494. \ Create a new time elements object
  495. : newTimeElements: ( "name" -- )
  496. timeElements create: allot
  497. ;
  498. \ Instantiate timeElements object for current time
  499. newTimeElements: time
  500. \ Instantiate timeElements object for use with makeTime
  501. newTimeElements: newTime
  502. (*
  503. str: "Year: " constant: yStr
  504. str: "Mon: " constant: monStr
  505. str: "Day: " constant: dStr
  506. str: "WDay: " constant: wdStr
  507. str: "Hour: " constant: hStr
  508. str: "Min: " constant: minStr
  509. str: "Sec: " constant: sStr
  510. \ Show time elements object
  511. : showTE ( tm -- )
  512. yStr type dup .year @ . space
  513. monStr type dup .month @ . space
  514. dStr type dup .day @ . space
  515. wdStr type dup .wday @ . space
  516. hStr type dup .hour @ . space
  517. minStr type dup .minute @ . space
  518. sStr type .second @ . cr cr
  519. ;
  520. *)
  521. \ Initialized byte array creator
  522. : byteArray ( N .. 1 number "name" -- ) ( index -- value )
  523. create:
  524. 0 do c, loop
  525. does> + c@
  526. ;
  527. \ Array of days in each month
  528. 31 30 31 30 31 31 30 31 30 31 28 31 12 byteArray MONTHDAYS
  529. \ Leap year calc expects argument as years offset from 1970
  530. : leapYear? ( year -- f )
  531. 1970 + ( year -- year+1970 )
  532. dup dup ( year' -- year' year' year' )
  533. 4 % 0= ( year year year -- year year f )
  534. swap ( year year f -- year f year )
  535. 100 % 0<> ( year f year -- year f f )
  536. and ( year f f -- year f )
  537. swap ( year f -- f year )
  538. 400 % 0= ( f year -- f f )
  539. or ( f f -- f )
  540. ;
  541. variable: _year_
  542. variable: _mon_
  543. variable: _monLen_
  544. variable: _days_
  545. variable: _exit_
  546. \ Breakup the seconds since 1970 into individual time elements
  547. : breakTime ( timeSecs -- )
  548. dup ( timeSecs -- timeSecs timeSecs )
  549. 60 % time .second ! ( timeSecs timeSecs -- timeSecs )
  550. 60 / ( timeSecs -- timeMins )
  551. dup ( timeMins -- timeMins timeMins )
  552. 60 % time .minute ! ( timeMins timeMins -- timeMins )
  553. 60 / ( timeMins -- timeHours )
  554. dup ( timeHours -- timeHours timeHours )
  555. 24 % time .hour ! ( timeHours timeHours -- timeHours )
  556. 24 / ( timeHours -- timeDays )
  557. dup ( timeDays -- timeDays timeDays )
  558. 4 + 7 % 1+ time .wday ! \ Sunday is day 1
  559. 0 _year_ ! ( timeDays -- )
  560. 0 _days_ !
  561. begin
  562. dup ( timeDays -- timeDays timeDays )
  563. _year_ @ leapYear?
  564. if
  565. 366 _days_ +!
  566. else
  567. 365 _days_ +!
  568. then
  569. _days_ @ > ( timeDays timeDays -- timeDays f )
  570. while
  571. 1 _year_ +!
  572. repeat ( timeDays -- )
  573. _year_ @ dup time .year ! ( timeDays -- timeDays year )
  574. leapYear? ( timeDays year -- timeDays f )
  575. if
  576. 366 negate _days_ +!
  577. else
  578. 365 negate _days_ +!
  579. then
  580. _days_ @ - \ Time is now days in this year starting at 0
  581. 0 _days_ ! ( -- timeDays )
  582. 0 _mon_ !
  583. 0 _monLen_ !
  584. FALSE _exit_ !
  585. begin
  586. _mon_ @ 12 < _exit_ @ 0= and
  587. while
  588. _mon_ @ 1 = \ Feb ?
  589. if
  590. _year_ @ leapYear?
  591. if
  592. 29 _monLen_ !
  593. else
  594. 28 _monLen_ !
  595. then
  596. else
  597. _mon_ @ MONTHDAYS _monLen_ !
  598. then
  599. dup ( timeDays -- timeDays timeDays )
  600. _monLen_ @ >=
  601. if
  602. _monLen_ @ -
  603. else
  604. TRUE _exit_ !
  605. then
  606. 1 _mon_ +!
  607. repeat
  608. _mon_ @ time .month !
  609. 1+ time .day !
  610. ;
  611. \ Convert newTime timeElements object into seconds since 1970
  612. \ NOTE: Year is offset from 1970
  613. : makeTime ( -- timeSecs )
  614. \ Seconds from 1970 till 1 jan 00:00:00 of the given year
  615. newTime .year @ ( -- year )
  616. dup ( year -- year year )
  617. 365 * ( year year -- year daysInYears )
  618. SPD * ( year daysInYears -- year secsInYears )
  619. over ( year secsInYears -- year secsInYears year )
  620. 0
  621. do ( year secsInYears year 0 -- year secsInYears )
  622. i leapYear?
  623. if
  624. SPD +
  625. then
  626. loop
  627. \ Add days for this year, months start from 1
  628. newTime .month @ ( year secsInYears -- year secsInYears month )
  629. dup ( year secsInYears month -- year secsInYears month month )
  630. 1 <>
  631. if
  632. 1
  633. do ( year secsInYears month 1 -- year secsInYears )
  634. swap dup ( year secsInYears -- secsInYears year year )
  635. leapYear? ( secsInYears year year -- secsInYears year f )
  636. i 2 = and \ Feb in a leap year?
  637. if
  638. swap ( secsInYears year -- year secsInYears )
  639. 29 SPD * +
  640. else
  641. swap ( secsInYears year -- year secsInYears )
  642. i 1- MONTHDAYS
  643. SPD * +
  644. then
  645. loop
  646. else
  647. drop
  648. then
  649. nip
  650. newTime .day @ 1- SPD * +
  651. newTime .hour @ SPH * +
  652. newTime .minute @ SPM * +
  653. newTime .second @ +
  654. ;
  655. \ Return the current system time syncing with NTP as appropriate
  656. : now ( -- sysTime )
  657. \ Calculate number of seconds since last call to now
  658. begin
  659. ms@ prevMS @ - abs 1000 >=
  660. while
  661. 1 sysTime +! \ Advance system time by one second
  662. 1000 prevMS +!
  663. repeat
  664. \ Is it time to sync with NTP ?
  665. nextSync @ sysTime @ <=
  666. if
  667. getTime ( -- ntpTime )
  668. dup
  669. sysTime !
  670. syncInt +
  671. nextSync !
  672. ms@ prevMS !
  673. then
  674. sysTime @
  675. ;
  676. \ Check and possibly refresh time cache
  677. : refreshCache ( timeSecs -- )
  678. dup dup ( timeSecs -- timeSecs timeSecs timeSecs )
  679. cacheTime @ <> ( timeSecs timeSecs timeSecs -- timeSecs timeSecs f )
  680. if
  681. breakTime ( timeSecs timeSecs -- timeSecs )
  682. cacheTime ! ( timeSecs -- )
  683. else
  684. 2drop ( timeSecs timeSecs -- )
  685. then
  686. ;
  687. \ Given time in seconds since 1970 return hour
  688. : hour_t ( timeSecs -- hour )
  689. refreshCache ( timeSecs -- )
  690. time .hour @ ( -- hour )
  691. ;
  692. (*
  693. \ Return the now hour
  694. : hour ( -- hour )
  695. now hour_t
  696. ;
  697. *)
  698. \ Given time in seconds since 1970 return hour in 12 hour format
  699. : hourFormat12_t ( timeSecs -- hour12 )
  700. refreshCache ( timeSecs -- )
  701. time .hour @ dup ( -- hour hour )
  702. 0= ( hour hour -- hour f )
  703. if
  704. drop ( hour -- )
  705. 12 ( -- 12 )
  706. else ( -- hour )
  707. dup ( hour -- hour hour )
  708. 12 > ( hour hour -- hour f )
  709. if
  710. 12 -
  711. then
  712. then
  713. ;
  714. (*
  715. \ Return now hour in 12 hour format
  716. : hourFormat12 ( -- hour12 )
  717. now hourFormat12_t
  718. ;
  719. *)
  720. \ Given time in seconds since 1970 return PM status
  721. : isPM_t ( timeSecs -- f )
  722. refreshCache
  723. time .hour @ 12 >=
  724. ;
  725. (*
  726. \ Determine if now time is PM
  727. : isPM ( -- f )
  728. now isPM_t
  729. ;
  730. *)
  731. \ Given time in seconds since 1970 return AM status
  732. : isAM_t ( timeSecs -- f )
  733. refreshCache
  734. time .hour @ 12 <
  735. ;
  736. (*
  737. \ Determine if now time is AM
  738. : isAM ( -- f )
  739. now isAM_t
  740. ;
  741. *)
  742. \ Given time in seconds since 1970 return minute
  743. : minute_t ( timeSecs -- minute )
  744. refreshCache
  745. time .minute @
  746. ;
  747. (*
  748. \ Return the now minute
  749. : minute ( -- minute )
  750. now minute_t
  751. ;
  752. *)
  753. \ Given time in seconds since 1970 return second
  754. : second_t ( timeSecs -- second )
  755. refreshCache
  756. time .second @
  757. ;
  758. (*
  759. \ Return the now second
  760. : second ( -- second )
  761. now second_t
  762. ;
  763. *)
  764. \ Given time in seconds since 1970 return day
  765. : day_t ( timeSecs -- day )
  766. refreshCache
  767. time .day @
  768. ;
  769. (*
  770. \ Return the now day
  771. : day ( -- day )
  772. now day_t
  773. ;
  774. *)
  775. \ Given time in seconds since 1970 return the week day with Sun as day 1
  776. : weekDay_t ( timeSecs -- weekDay )
  777. refreshCache
  778. time .wday @
  779. ;
  780. (*
  781. \ Return the now week day with Sun as day 1
  782. : weekDay ( -- weekDay )
  783. now weekDay_t
  784. ;
  785. *)
  786. \ Given time in seconds since 1970 return month
  787. : month_t ( timeSecs -- month )
  788. refreshCache
  789. time .month @
  790. ;
  791. (*
  792. \ Return the now month
  793. : month ( -- month )
  794. now month_t
  795. ;
  796. *)
  797. \ Given time in seconds since 1970 return year in full 4 digit format
  798. : year_t ( timeSecs -- year )
  799. refreshCache
  800. time .year @ 1970 +
  801. ;
  802. (*
  803. \ Return the now year in full 4 digit format
  804. : year ( -- year )
  805. now year_t
  806. ;
  807. *)
  808. (*
  809. Test cases for breakTime and makeTime from Arduino program
  810. ALL SUCCESSFUL
  811. time_t: 1484340438 - Year: 47, Mon: 1, Day: 13, Hour: 20, Min: 47, Sec: 18
  812. time_t: 1525094490 - Year: 48, Mon: 4, Day: 30, Hour: 13, Min: 21, Sec: 30
  813. time_t: 1561177080 - Year: 49, Mon: 6, Day: 22, Hour: 4, Min: 18, Sec: 0
  814. time_t: 1603973175 - Year: 50, Mon: 10, Day: 29, Hour: 12, Min: 6, Sec: 15
  815. time_t: 68166375 - Year: 2, Mon: 2, Day: 28, Hour: 23, Min: 6, Sec: 15
  816. *)
  817. \ Time Zone and Daylight Savings Time Library
  818. \ Based on Arduino Timezone library by Jack Christensen
  819. \ Written for PunyForth
  820. \ By: Craig A. Lindley
  821. \ Last Update: 01/21/2017
  822. \ Structure for describing a time change rule
  823. struct
  824. cell field: .wk \ last = 0 first second third fourth
  825. cell field: .dow \ Sun = 1 .. Sat
  826. cell field: .mon \ Jan = 1 .. Dec
  827. cell field: .hr \ 0 .. 23
  828. cell field: .off \ Offset from UTC in minutes
  829. constant: TCR
  830. \ Time change rule object creator
  831. : newTCR: ( "name" -- addrTCR )
  832. TCR create: allot
  833. ;
  834. \ Structure for describing a title and two time change rules
  835. struct
  836. cell field: .name
  837. cell field: .dstTCR
  838. cell field: .stdTCR
  839. constant: TZ
  840. \ Time zone object creator
  841. : newTZ: ( "name" -- addrTZ )
  842. TZ create: allot
  843. ;
  844. \ Program variables
  845. variable: dstUTC \ DST start for given/current year, given in UTC
  846. variable: stdUTC \ STD start for given/current year, given in UTC
  847. variable: dstLoc \ DST start for given/current year, given in local time
  848. variable: stdLoc \ STD start for given/current year, given in local time
  849. variable: theTZ \ Variable holding the current TZ object
  850. \ Temp vars
  851. variable: _y_
  852. variable: _t_
  853. variable: _m_
  854. variable: _w_
  855. \ Convert a time change rule (TCR) to a time_t value for given year
  856. : toTime_t ( TCR year -- time_t )
  857. _y_ ! ( TCR year -- TCR )
  858. dup .mon @ _m_ !
  859. dup .wk @ _w_ ! ( -- TCR )
  860. _w_ @ 0= \ Last week ?
  861. if
  862. 1 _m_ +!
  863. _m_ @ 12 >
  864. if
  865. 1 _m_ !
  866. 1 _y_ +!
  867. then
  868. 1 _w_ !
  869. then
  870. dup .hr @
  871. newTime .hour !
  872. 0 newTime .minute !
  873. 0 newTime .second !
  874. 1 newTime .day !
  875. _m_ @
  876. newTime .month !
  877. _y_ @ 1970 -
  878. newTime .year !
  879. makeTime _t_ ! ( -- TCR )
  880. 7 _w_ @ 1- * ( TCR -- TCR f1 )
  881. over ( TCR f1 -- TCR f1 TCR )
  882. .dow @ ( TCR f1 TCR -- TCR f1 DOW )
  883. _t_ @ weekDay_t ( TCR f1 DOW -- TCR f1 DOW WD )
  884. - ( TCR f1 DOW WD -- TCR f1 DOW-WD )
  885. 7 + ( TCR f1 DOW-WD -- TCR f1 DOW-WD+7 )
  886. 7 % ( TCR f1 DOW-WD+7 -- TCR f1 DOW-WD+7%7 )
  887. + ( TCR f1 DOW-WD+7%7 -- TCR DOW-WD+7%7+f1 )
  888. SPD * ( TCR DOW-WD+7%7+f1 -- TCR DOW-WD+7%7+f1*SPD )
  889. _t_ +! ( TCR DOW-WD+7%7+f1*SPD -- TCR )
  890. .wk @ 0= ( TCR -- f )
  891. if
  892. -7 SPD * _t_ +!
  893. then
  894. _t_ @
  895. ;
  896. \ Calculate the DST and standard time change points for the given
  897. \ given year as local and UTC time_t values.
  898. : calcTC ( year -- )
  899. dup ( year -- year year )
  900. >r ( year year -- year )
  901. theTZ @ .dstTCR @
  902. swap ( year -- TCR year )
  903. toTime_t dstLoc ! ( TCR year -- )
  904. r> ( -- year )
  905. theTZ @ .stdTCR @
  906. swap ( year -- TCR year )
  907. toTime_t stdLoc ! ( TCR year -- )
  908. dstLoc @
  909. theTZ @ .stdTCR @
  910. .off @
  911. SPM *
  912. -
  913. dstUTC !
  914. stdLoc @
  915. theTZ @ .dstTCR @
  916. .off @
  917. SPM *
  918. -
  919. stdUTC !
  920. ;
  921. \ Determine whether the given UTC time_t is within the DST interval
  922. \ or the Standard time interval
  923. : utcIsDST ( utc -- f )
  924. dup ( utc -- utc utc )
  925. year_t ( utc utc -- utc utc_yr )
  926. dstUTC @ ( utc utc_yr -- utc utc_yr utc_dst )
  927. year_t ( utc utc_yr utc_dst -- utc utc_yr dst_yr )
  928. over ( utc utc_yr dst_yr -- utc utc_yr dst_yr utc_yr )
  929. <> ( utc utc_yr dst_yr utc_yr -- utc utc_yr f )
  930. if
  931. calcTC
  932. else
  933. drop
  934. then ( -- utc )
  935. dup ( utc -- utc utc )
  936. stdUTC @
  937. dstUTC @ >
  938. if \ Northern hemisphere
  939. dstUTC @ >= ( utc utc -- utc f )
  940. swap ( utc f -- f utc )
  941. stdUTC @ <
  942. and
  943. else \ Southern hemisphere
  944. stdUTC @ >= ( utc utc -- utc f )
  945. swap ( utc f -- f utc )
  946. dstUTC @ <
  947. and 0=
  948. then
  949. ;
  950. \ Convert the given UTC time to local time, standard or
  951. \ daylight time, as appropriate
  952. : toLocal ( utc -- time_t )
  953. dup ( utc -- utc utc )
  954. year_t ( utc utc -- utc utc_yr )
  955. dstUTC @ ( utc utc_yr -- utc utc_yr utc_dst )
  956. year_t ( utc utc_yr utc_dst -- utc utc_yr dst_yr )
  957. over ( utc utc_yr dst_yr -- utc utc_yr dst_yr utc_yr )
  958. <> ( utc utc_yr dst_yr utc_yr -- utc utc_yr f )
  959. if
  960. calcTC ( utc utc_yr -- utc )
  961. else
  962. drop
  963. then ( -- utc )
  964. dup ( utc -- utc utc )
  965. utcIsDST ( utc utc -- utc f )
  966. if
  967. theTZ @ .dstTCR @
  968. .off @
  969. SPM *
  970. +
  971. else
  972. theTZ @ .stdTCR @
  973. .off @
  974. SPM *
  975. +
  976. then
  977. ;
  978. \ Set the timezone in preparation for time conversion
  979. : setTZ ( tz -- )
  980. \ Store tz into global variable
  981. theTZ !
  982. \ Clear all local variables for new calculation
  983. 0 dstLoc !
  984. 0 stdLoc !
  985. 0 dstUTC !
  986. 0 stdUTC !
  987. ;
  988. \ World Clock App
  989. \ Written for PunyForth
  990. \ By: Craig A. Lindley
  991. \ Last Update: 01/21/2017
  992. \ Set TRUE for 12 hour format; FALSE for 24 hour format
  993. TRUE constant: 12HF
  994. \ BEGIN TIME CHANGE RULE DEFINITIONS
  995. (*
  996. Australia Eastern Time Zone (Sydney, Melbourne)
  997. TTimeChangeRule aEDT = {"AEDT", First, Sun, Oct, 2, 660}; //UTC + 11 hours
  998. TimeChangeRule aEST = {"AEST", First, Sun, Apr, 3, 600}; //UTC + 10 hours
  999. Timezone ausET(aEDT, aEST);
  1000. *)
  1001. \ Create TCR for daylight saving time
  1002. newTCR: aEDT
  1003. \ Initialize rule
  1004. 1 aEDT .wk ! \ First week
  1005. 1 aEDT .dow ! \ Sun
  1006. 10 aEDT .mon ! \ Oct
  1007. 2 aEDT .hr ! \ 2 PM
  1008. 660 aEDT .off ! \ TZ offset 11 hours
  1009. \ Create TCR for standard time
  1010. newTCR: aEST
  1011. \ Initialize rule
  1012. 1 aEST .wk ! \ First week
  1013. 1 aEST .dow ! \ Sun
  1014. 4 aEST .mon ! \ Apr
  1015. 3 aEST .hr ! \ 3 PM
  1016. 600 aEST .off ! \ TZ offset 10 hours
  1017. \ Create TZ object to hold TCRs
  1018. newTZ: ausET
  1019. str: "Sydney" ausET .name !
  1020. aEDT ausET .dstTCR !
  1021. aEST ausET .stdTCR !
  1022. (* CURRENTLY NOT USED
  1023. //Central European Time (Frankfurt, Paris)
  1024. TimeChangeRule CEST = {"CEST", Last, Sun, Mar, 2, 120}; //Central European Summer Time
  1025. TimeChangeRule CET = {"CET ", Last, Sun, Oct, 3, 60}; //Central European Standard Timezone CE(CEST, CET);
  1026. \ Create TCR for daylight saving time
  1027. newTCR: CEST
  1028. \ Initialize rule
  1029. 0 CEST .wk ! \ Last week
  1030. 1 CEST .dow ! \ Sun
  1031. 3 CEST .mon ! \ Mar
  1032. 2 CEST .hr ! \ 2 PM
  1033. 120 CEST .off ! \ TZ offset 2 hours
  1034. \ Create TCR for standard time
  1035. newTCR: CET
  1036. \ Initialize rule
  1037. 0 CET .wk ! \ Last week
  1038. 1 CET .dow ! \ Sun
  1039. 10 CET .mon ! \ Oct
  1040. 3 CET .hr ! \ 3 PM
  1041. 60 CET .off ! \ TZ offset 1 hours
  1042. \ Create TZ object to hold TCRs
  1043. newTZ: CE
  1044. str: "Frankfurt" CE .name !
  1045. CEST CE .dstTCR !
  1046. CET CE .stdTCR !
  1047. *)
  1048. (*
  1049. //United Kingdom (London, Belfast)
  1050. TimeChangeRule BST = {"BST", Last, Sun, Mar, 1, 60}; //British Summer Time
  1051. TimeChangeRule GMT = {"GMT", Last, Sun, Oct, 2, 0}; //Standard Time
  1052. Timezone UK(BST, GMT);
  1053. *)
  1054. \ Create TCR for daylight saving time
  1055. newTCR: BST
  1056. \ Initialize rule
  1057. 0 BST .wk ! \ Last week
  1058. 1 BST .dow ! \ Sun
  1059. 3 BST .mon ! \ Mar
  1060. 1 BST .hr ! \ 1 PM
  1061. 60 BST .off ! \ TZ offset 1 hours
  1062. \ Create TCR for standard time
  1063. newTCR: GMT
  1064. \ Initialize rule
  1065. 0 GMT .wk ! \ First week
  1066. 1 GMT .dow ! \ Sun
  1067. 10 GMT .mon ! \ Oct
  1068. 2 GMT .hr ! \ 2 PM
  1069. 0 GMT .off ! \ TZ offset 1 hours
  1070. \ Create TZ object to hold TCRs
  1071. newTZ: UK
  1072. str: "London" UK .name !
  1073. BST UK .dstTCR !
  1074. GMT UK .stdTCR !
  1075. (*
  1076. //US Eastern Time Zone (New York, Detroit)
  1077. TimeChangeRule usEDT = {"EDT", Second, Sun, Mar, 2, -240};
  1078. TimeChangeRule usEST = {"EST", First, Sun, Nov, 2, -300};
  1079. Timezone usET(usEDT, usEST);
  1080. *)
  1081. \ Create TCR for daylight saving time
  1082. newTCR: usEDT
  1083. \ Initialize rule
  1084. 2 usEDT .wk ! \ Second week
  1085. 1 usEDT .dow ! \ Sun
  1086. 3 usEDT .mon ! \ Mar
  1087. 2 usEDT .hr ! \ 2 PM
  1088. -240 usEDT .off ! \ TZ offset -4 hours
  1089. \ Create TCR for standard time
  1090. newTCR: usEST
  1091. \ Initialize rule
  1092. 1 usEST .wk ! \ First week
  1093. 1 usEST .dow ! \ Sun
  1094. 11 usEST .mon ! \ Nov
  1095. 2 usEST .hr ! \ 2 PM
  1096. -300 usEST .off ! \ TZ offset -5 hours
  1097. \ Create TZ object to hold TCRs
  1098. newTZ: usET
  1099. str: "New York" usET .name !
  1100. usEDT usET .dstTCR !
  1101. usEST usET .stdTCR !
  1102. (* CURRENTLY NOT USED
  1103. //US Central Time Zone (Chicago, Houston)
  1104. TimeChangeRule usCDT = {"CDT", Second, Sun, Mar, 2, -300};
  1105. TimeChangeRule usCST = {"CST", First, Sun, Nov, 2, -360};
  1106. Timezone usCT(usCDT, usCST);
  1107. \ Create TCR for daylight saving time
  1108. newTCR: usCDT
  1109. \ Initialize rule
  1110. 2 usCDT .wk ! \ Second week
  1111. 1 usCDT .dow ! \ Sun
  1112. 3 usCDT .mon ! \ Mar
  1113. 2 usCDT .hr ! \ 2 PM
  1114. -300 usCDT .off ! \ TZ offset -5 hours
  1115. \ Create TCR for standard time
  1116. newTCR: usCST
  1117. \ Initialize rule
  1118. 1 usCST .wk ! \ First week
  1119. 1 usCST .dow ! \ Sun
  1120. 11 usCST .mon ! \ Nov
  1121. 2 usCST .hr ! \ 2 PM
  1122. -360 usCST .off ! \ TZ offset -6 hours
  1123. \ Create TZ object to hold TCRs
  1124. newTZ: usCT
  1125. str: "Houston" usCT .name !
  1126. usCDT usCT .dstTCR !
  1127. usCST usCT .stdTCR !
  1128. *)
  1129. (*
  1130. //US Mountain Time Zone (Denver, Salt Lake City)
  1131. TimeChangeRule usMDT = {"MDT", Second, Sun, Mar, 2, -360};
  1132. TimeChangeRule usMST = {"MST", First, Sun, Nov, 2, -420};
  1133. Timezone usMT(usMDT, usMST);
  1134. *)
  1135. \ Create TCR for daylight savings time
  1136. newTCR: usMDT
  1137. \ Initialize rule
  1138. 2 usMDT .wk ! \ Second week
  1139. 1 usMDT .dow ! \ Sun
  1140. 3 usMDT .mon ! \ Mar
  1141. 2 usMDT .hr ! \ 2 PM
  1142. -360 usMDT .off ! \ TZ offset -6 hours
  1143. \ Create TCR for standard time
  1144. newTCR: usMST
  1145. \ Initialize rule
  1146. 1 usMST .wk ! \ First week
  1147. 1 usMST .dow ! \ Sun
  1148. 11 usMST .mon ! \ Nov
  1149. 2 usMST .hr ! \ 2 PM
  1150. -420 usMST .off ! \ TZ offset -7 hours
  1151. \ Create TZ object to hold TCRs
  1152. newTZ: usMT
  1153. str: "Denver" usMT .name !
  1154. usMDT usMT .dstTCR !
  1155. usMST usMT .stdTCR !
  1156. (* CURRENTLY NOT USED
  1157. //Arizona is US Mountain Time Zone but does not use DST
  1158. Timezone usAZ(usMST, usMST);
  1159. \ Create TZ object to hold TCRs
  1160. newTZ: usAZ
  1161. str: "Phoenix" usAZ .name !
  1162. usMST usAZ .dstTCR !
  1163. usMST usAZ .stdTCR !
  1164. *)
  1165. (*
  1166. //US Pacific Time Zone (Las Vegas, Los Angeles)
  1167. TimeChangeRule usPDT = {"PDT", Second, Sun, Mar, 2, -420};
  1168. TimeChangeRule usPST = {"PST", First, Sun, Nov, 2, -480};
  1169. Timezone usPT(usPDT, usPST);
  1170. *)
  1171. \ Create TCR for daylight savings time
  1172. newTCR: usPDT
  1173. \ Initialize rule
  1174. 2 usPDT .wk ! \ Second week
  1175. 1 usPDT .dow ! \ Sun
  1176. 3 usPDT .mon ! \ Mar
  1177. 2 usPDT .hr ! \ 2 PM
  1178. -420 usPDT .off ! \ TZ offset -7 hours
  1179. \ Create TCR for standard time
  1180. newTCR: usPST
  1181. \ Initialize rule
  1182. 1 usPST .wk ! \ First week
  1183. 1 usPST .dow ! \ Sun
  1184. 11 usPST .mon ! \ Nov
  1185. 2 usPST .hr ! \ 2 PM
  1186. -480 usPST .off ! \ TZ offset -8 hours
  1187. \ Create TZ object to hold TCRs
  1188. newTZ: usPT
  1189. str: "Los Angeles" usPT .name !
  1190. usPDT usPT .dstTCR !
  1191. usPST usPT .stdTCR !
  1192. \ END TIME CHANGE RULE DEFINITIONS
  1193. \ Format buffer
  1194. 20 buffer: fbuf
  1195. variable: i
  1196. \ Copy a string into format buffer
  1197. : cat ( sAddr -- )
  1198. begin
  1199. dup ( sAddr -- sAddr sAddr )
  1200. c@ ( sAddr sAddr -- sAddr c )
  1201. dup ( sAddr c -- sAddr c c )
  1202. 0 ( sAddr c c -- sAddr c c 0 )
  1203. <> ( sAddr c c 0 -- sAddr c f )
  1204. while
  1205. i @ fbuf + c! ( sAddr c -- sAddr )
  1206. 1 i +!
  1207. 1+ ( sAddr -- sAddr+1 )
  1208. repeat
  1209. i @ fbuf + c! ( sAddr c -- sAddr )
  1210. drop
  1211. ;
  1212. 5 buffer: nbuf
  1213. variable: j
  1214. variable: i1
  1215. \ Integer to string conversion
  1216. \ Can only do positive numbers with less than 5 digits
  1217. : i2s ( n -- )
  1218. 0 i1 !
  1219. begin
  1220. dup ( n -- n n )
  1221. 10 % ( n n -- n n%10 )
  1222. 48 + ( n n%10 -- n n%10+48 )
  1223. i1 @ nbuf + c! ( n n%10+48 -- n )
  1224. 1 i1 +!
  1225. 10 / ( n -- n/10 )
  1226. dup ( n/10 -- n/10 n/10 )
  1227. 0 <= ( n/10 n/10 -- n/10 f )
  1228. until
  1229. drop
  1230. 0 i1 @ nbuf + c!
  1231. \ Now reverse the characters in the string
  1232. i1 @ 1- j !
  1233. 0 i1 !
  1234. begin
  1235. i1 @ nbuf + c@ ( -- nbuf[i] )
  1236. j @ nbuf + c@ ( nbuf[i] -- nbuf[i] nbuf[j] )
  1237. i1 @ nbuf + c! ( nbuf[i] nbuf[j] -- nbuf[i] )
  1238. j @ nbuf + c! ( nbuf[i] -- )
  1239. 1 i1 +!
  1240. -1 j +!
  1241. i1 @ j @ >
  1242. until
  1243. ;
  1244. \ String array creator
  1245. : sa: ( strN .. str1 number "name" -- ) ( index -- addr of string )
  1246. create:
  1247. 0 do , loop
  1248. does> swap cells + @
  1249. ;
  1250. \ Months string array
  1251. str: "Dec" str: "Nov" str: "Oct" str: "Sep"
  1252. str: "Aug" str: "Jul" str: "Jun" str: "May"
  1253. str: "Apr" str: "Mar" str: "Feb" str: "Jan"
  1254. str: ""
  1255. 13 sa: MON
  1256. \ Days string array
  1257. str: "Sat" str: "Fri" str: "Thu" str: "Wed"
  1258. str: "Tue" str: "Mon" str: "Sun" str: ""
  1259. 8 sa: DOW
  1260. \ Am - Pm string array
  1261. str: "PM" str: "AM"
  1262. 2 sa: AMPM
  1263. \ Display time and date. Assumes theTZ set before call
  1264. : dtd
  1265. \ Clear the dynamic area of the screen
  1266. 2 14 WIDTH 3 - HEIGHT 15 - BLK fillRect
  1267. \ Print using larger text
  1268. 2 _sz_ !
  1269. \ Print the name of the city
  1270. 20 theTZ @ .name @ pCStr
  1271. \ Get the UTC time and convert it to local time
  1272. now toLocal >r
  1273. \ Print day of the week
  1274. 41 r@ weekDay_t DOW pCStr
  1275. \ Initialize format buffer index
  1276. 0 i !
  1277. \ Format date string like: Wed Jan 18, 2017
  1278. r@ month_t MON cat str: " " cat
  1279. r@ day_t i2s nbuf cat str: ", " cat
  1280. r@ year_t i2s nbuf cat
  1281. \ Print the centered date line
  1282. 62 fbuf pCStr
  1283. \ Initialize format buffer index
  1284. 0 i !
  1285. \ Format the time string like: 9:59 AM
  1286. r@
  1287. 12HF
  1288. if
  1289. hourFormat12_t
  1290. else
  1291. hour_t
  1292. then
  1293. i2s nbuf cat
  1294. str: ":" cat
  1295. r@ minute_t i2s nbuf
  1296. \ If minutes single digit 0..9 add leading zero to string
  1297. dup strlen 1 =
  1298. if
  1299. str: "0" cat
  1300. then
  1301. cat
  1302. str: " " cat
  1303. r@ isAM_t
  1304. if
  1305. 0 AMPM
  1306. else
  1307. 1 AMPM
  1308. then
  1309. cat
  1310. \ Print the centered time line
  1311. 3 _sz_ ! \ Print large text
  1312. 85 fbuf pCStr
  1313. \ Clean up
  1314. r> drop
  1315. ;
  1316. variable: tz
  1317. \ Run the world clock app
  1318. : wc
  1319. \ Initialize the LCD controller
  1320. initLCD
  1321. \ Clear the LCD to black
  1322. 0 0 WIDTH 1- HEIGHT 1- BLK fillRect
  1323. \ Draw display frame
  1324. 0 0 WIDTH YEL hLine
  1325. 0 HEIGHT 1- WIDTH YEL hLine
  1326. 0 1 HEIGHT 2 - YEL vLine
  1327. WIDTH 1- 1 HEIGHT 2 - YEL vLine
  1328. GRN setFG
  1329. \ Draw fixed text
  1330. 5 str: "World Clock" pCStr
  1331. 116 str: "Craig A. Lindley" pCStr
  1332. begin
  1333. tz @
  1334. case
  1335. 0 of ausET setTZ endof
  1336. 1 of UK setTZ endof
  1337. 2 of usET setTZ endof
  1338. 3 of usMT setTZ endof
  1339. 4 of usPT setTZ endof
  1340. endcase
  1341. \ Print the time and data for selected time zone
  1342. dtd
  1343. 1 tz +!
  1344. tz @ 4 >
  1345. if
  1346. 0 tz !
  1347. then
  1348. \ Wait 30 seconds
  1349. 30000 ms
  1350. again
  1351. ;
  1352. wc