/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. 

  2. 

  3. \ Misc Forth Utilities
    4. 

  4. \ Written for PunyForth
    5. 

  5. \ By: Craig A. Lindley and others
    6. 

  6. \ Last Update: 01/21/2017
    7. 

  7. 

  8. \ (* Surround multiline comments with these *)
    9. 

  9. : (* 
    10. 

  10.   begin  
    11. 

  11.       begin key [ char: * ] literal = until
    12. 

  12.       key [ char: ) ] literal =
    13. 

  13.       if
    14. 

  14.           exit
    15. 

  15.       then
    16. 

  16.   again
    17. 

  17. ; immediate
    18. 

  18. 

  19. \ Add missing functions
    20. 

  20. : negate -1 * ;
    21. 

  21. 

  22. : r@ ( -- n )
    23. 

  23.     r> r> dup >r swap >r ; 
    24. 

  24. ;
    25. 

  25. 

  26. \ ST7735 65K Color LCD Display Driver for the Adafruit 1.8" SPI LCD
    27. 

  27. \ Only supports landscape mode with LCD connector on right
    28. 

  28. \ Written for PunyForth
    29. 

  29. \ By: Craig A. Lindley
    30. 

  30. \ Last Update: 01/21/2017
    31. 

  31. \ Must have core and gpio modules loaded
    32. 

  32. 

  33. \ Define the wiring between the NodeMCU Amica and the LCD display
    34. 

  34. 14 constant: SCL  \ SCL D5
    35. 

  35. 13 constant: SDA  \ SDA D7
    36. 

  36.  2 constant: DC   \ DC  D4
    37. 

  37. 15 constant: CS   \ CS  D8
    38. 

  38. \ NOTE: the RESET and LITE signals on the LCD are tied to 3.3VDC
    39. 

  39. 

  40. \ SPI interface number
    41. 

  41. 1  constant: BUS  
    42. 

  42. 

  43. \ Define some 16 bit color values
    44. 

  44. hex: 0000 constant: BLK
    45. 

  45. hex: F800 constant: RED
    46. 

  46. hex: FFE0 constant: YEL
    47. 

  47. hex: 07E0 constant: GRN
    48. 

  48. hex: 001F constant: BLU
    49. 

  49. hex: 07FF constant: CYA
    50. 

  50. hex: F81F constant: MAG
    51. 

  51. hex: FFFF constant: WHT
    52. 

  52. 

  53. \ ST7735 commands
    54. 

  54. hex: 01 constant: SWRST   \ software reset
    55. 

  55. hex: 11 constant: SLPOUT  \ sleep out
    56. 

  56. hex: 29 constant: DISPON  \ display on
    57. 

  57. hex: 2A constant: CASET   \ column address set
    58. 

  58. hex: 2B constant: RASET   \ row address set
    59. 

  59. hex: 2C constant: RAMWR   \ RAM write
    60. 

  60. hex: 36 constant: MADCTL  \ pixel direction control
    61. 

  61. hex: 3A constant: COLMOD  \ color mode
    62. 

  62. 

  63. \ Display rotation constants
    64. 

  64. hex: 80 constant: CTL_MY
    65. 

  65. hex: 40 constant: CTL_MX
    66. 

  66. hex: 20 constant: CTL_MV
    67. 

  67. \ hex: 08 constant: CTL_BGR
    68. 

  68. 

  69. exception: EST7735
    70. 

  70. 

  71. \ Display dimensions in landscape mode
    72. 

  72. 160 constant: WIDTH
    73. 

  73. 128 constant: HEIGHT
    74. 

  74. 

  75. \ Check result of SPI write
    76. 

  76. : cWrt ( code -- | EST7735 )
    77. 

  77.     255 <> if 
    78. 

  78.         EST7735 throw 
    79. 

  79.     then
    80. 

  80. ;
    81. 

  81. 

  82. \ Write an 8 bit command to the display via SPI
    83. 

  83. : wCmd ( cmd -- | EST7735 )
    84. 

  84.     DC GPIO_LOW gpio-write
    85. 

  85.     CS GPIO_LOW gpio-write
    86. 

  86.     BUS spi-send8 
    87. 

  87.     cWrt
    88. 

  88.     CS GPIO_HIGH gpio-write 
    89. 

  89. ;
    90. 

  90. 

  91. \ Write 8 bit data to the display via SPI
    92. 

  92. : w8 ( data -- | EST7735 ) 
    93. 

  93.     DC GPIO_HIGH gpio-write
    94. 

  94.     CS GPIO_LOW gpio-write
    95. 

  95.     BUS spi-send8
    96. 

  96.     cWrt
    97. 

  97.     CS GPIO_HIGH gpio-write 
    98. 

  98. ;
    99. 

  99. 

  100. \ Write 16 bit data to the display via SPI
    101. 

  101. : w16 ( data -- | EST7735 ) 
    102. 

  102.     DC GPIO_HIGH gpio-write
    103. 

  103.     CS GPIO_LOW gpio-write
    104. 

  104.     dup
    105. 

  105.     8 rshift    BUS spi-send8
    106. 

  106.     cWrt 
    107. 

  107.     hex: FF and BUS spi-send8
    108. 

  108.     cWrt
    109. 

  109.     CS GPIO_HIGH gpio-write 
    110. 

  110. ;
    111. 

  111. 

  112. \ Initialize the SPI interface and the display controller
    113. 

  113. : initLCD ( -- | EST7735 )
    114. 

  114. 

  115.     \ Initilize GPIO pins
    116. 

  116.     DC GPIO_OUT  gpio-mode
    117. 

  117.     CS GPIO_OUT  gpio-mode
    118. 

  118.     DC GPIO_LOW  gpio-write
    119. 

  119.     CS GPIO_HIGH gpio-write
    120. 

  120. 

  121.     \ Setup SPI interface
    122. 

  122.     TRUE 1 TRUE 2 10 16 lshift swap 65535 and or 0 BUS 
    123. 

  123.     spi-init 1 <> if
    124. 

  124.         EST7735 throw
    125. 

  125.     then
    126. 

  126. 

  127.     \ Initialize the display controller for operation
    128. 

  128.     SWRST wCmd
    129. 

  129.     200 ms
    130. 

  130.     SLPOUT wCmd
    131. 

  131.     500 ms
    132. 

  132.     \ Set 16 bit color
    133. 

  133.     COLMOD  wCmd
    134. 

  134.     100 ms
    135. 

  135.     hex: 05 w8 
    136. 

  136.     100 ms
    137. 

  137.     MADCTL wCmd
    138. 

  138.     \ Must add CTL_BGR for Sainsmart display
    139. 

  139.     CTL_MY CTL_MV or w8
    140. 

  140.     100 ms
    141. 

  141.     DISPON wCmd 
    142. 

  142.     200 ms
    143. 

  143. ;
    144. 

  144. 

  145. \ Temp variables
    146. 

  146. variable: _wx0_
    147. 

  147. variable: _wy0_
    148. 

  148. variable: _wx1_
    149. 

  149. variable: _wy1_
    150. 

  150. 

  151. \ Sets a rectangular display window into which pixel data is written
    152. 

  152. \ Values should be set into variable above before call
    153. 

  153. : setWin ( -- )
    154. 

  154.     CASET wCmd
    155. 

  155.     _wx0_ @ w16
    156. 

  156.     _wx1_ @ w16
    157. 

  157.     RASET wCmd
    158. 

  158.     _wy0_ @ w16
    159. 

  159.     _wy1_ @ w16
    160. 

  160.     RAMWR wCmd 
    161. 

  161. ;
    162. 

  162. 

  163. \ Graphic Functions for the ST7735 65K Color LCD Controller
    164. 

  164. \ Written for PunyForth
    165. 

  165. \ By: Craig A. Lindley
    166. 

  166. \ Last Update: 01/21/2017
    167. 

  167. \ Must have ST7735 loaded
    168. 

  168. 

  169. \ Temp variables
    170. 

  170. variable: _w_
    171. 

  171. variable: _h_
    172. 

  172. 

  173. \ Draw a pixel on the display
    174. 

  174. : pixel ( x y color -- )
    175. 

  175.     >r
    176. 

  176.     dup _wy0_ ! _wy1_ !
    177. 

  177.     dup _wx0_ ! _wx1_ !
    178. 

  178.     setWin
    179. 

  179.     r>
    180. 

  180.     w16 ;
    181. 

  181. 

  182. 

  183. \ Fill a rectangle on the display
    184. 

  184. : fillRect ( x0 y0 x1 y1 color -- )
    185. 

  185.     >r
    186. 

  186.     _wy1_ ! _wx1_ ! _wy0_ ! _wx0_ !
    187. 

  187.     _wx1_ @ _wx0_ @ - 1+ _w_  !
    188. 

  188.     _wy1_ @ _wy0_ @ - 1+ _h_ !
    189. 

  189.     
    190. 

  190.     setWin
    191. 

  191.     r>
    192. 

  192.     _w_ @ _h_ @ * 0 
    193. 

  193.     do
    194. 

  194.         dup w16
    195. 

  195.     loop
    196. 

  196.     drop ;
    197. 

  197. 

  198. \ Draw horizontal line of length with color
    199. 

  199. : hLine		( x y len color -- )
    200. 

  200.     >r          ( x y len color -- x y len )
    201. 

  201.     >r          ( x y len -- x y )	
    202. 

  202.     over over	( x y -- x y x y )
    203. 

  203.     swap	( x y x y -- x y y x )
    204. 

  204.     r>		( x y y x --- x y y x len )
    205. 

  205.     +		( x y y x len -- x y y x+len )
    206. 

  206.     swap	( x y y x+len -- x y x+len y )
    207. 

  207.     r>          ( x y x+len y -- x y x+len y color )
    208. 

  208.     fillRect    ( x y x+len y color -- )
    209. 

  209. ;
    210. 

  210. 

  211. 

  212. \ Draw vertical line of length with color
    213. 

  213. : vLine		( x y len color -- )
    214. 

  214.     >r		( x y len color -- x y len )
    215. 

  215.     over	( x y len -- x y len y )
    216. 

  216.     +		( x y len y -- x y y+len )
    217. 

  217.     >r	        ( x y y+len -- x y )
    218. 

  218.     over	( x y -- x y x )
    219. 

  219.     r>          ( x y x -- x y x y+len )
    220. 

  220.     r>          ( x y x y+len -- x y x y+len color )
    221. 

  221.     fillRect    ( x y x y+len color -- )
    222. 

  222. ;
    223. 

  223. 

  224. \ Text Functions for the ST7735 65K Color LCD Controller
    225. 

  225. \ Written for PunyForth
    226. 

  226. \ By: Craig A. Lindley
    227. 

  227. \ Last Update: 01/21/2017
    228. 

  228. 

  229. 5 constant: FW
    230. 

  230. 7 constant: FH
    231. 

  231. 

  232. \ 5x7 font for characters 0x20 .. 0x7E
    233. 

  233. create: FNT
    234. 

  234. hex: 00  c, hex: 00  c, hex: 00  c, hex: 00  c, hex: 00  c, \ space
    235. 

  235. hex: 00  c, hex: 00  c, hex: 5F  c, hex: 00  c, hex: 00  c, \ !
    236. 

  236. hex: 00  c, hex: 07  c, hex: 00  c, hex: 07  c, hex: 00  c, \ "
    237. 

  237. hex: 14  c, hex: 7F  c, hex: 14  c, hex: 7F  c, hex: 14  c, \ #
    238. 

  238. hex: 24  c, hex: 2A  c, hex: 7F  c, hex: 2A  c, hex: 12  c, \ $
    239. 

  239. hex: 23  c, hex: 13  c, hex: 08  c, hex: 64  c, hex: 62  c, \ %
    240. 

  240. hex: 36  c, hex: 49  c, hex: 56  c, hex: 20  c, hex: 50  c, \ &
    241. 

  241. hex: 00  c, hex: 08  c, hex: 07  c, hex: 03  c, hex: 00  c, \ '
    242. 

  242. hex: 00  c, hex: 1C  c, hex: 22  c, hex: 41  c, hex: 00  c, \ (
    243. 

  243. hex: 00  c, hex: 41  c, hex: 22  c, hex: 1C  c, hex: 00  c, \ )
    244. 

  244. hex: 2A  c, hex: 1C  c, hex: 7F  c, hex: 1C  c, hex: 2A  c, \ *
    245. 

  245. hex: 08  c, hex: 08  c, hex: 3E  c, hex: 08  c, hex: 08  c, \ +
    246. 

  246. hex: 00  c, hex: 80  c, hex: 70  c, hex: 30  c, hex: 00  c, \ ,
    247. 

  247. hex: 08  c, hex: 08  c, hex: 08  c, hex: 08  c, hex: 08  c, \ -
    248. 

  248. hex: 00  c, hex: 00  c, hex: 60  c, hex: 60  c, hex: 00  c, \ .
    249. 

  249. hex: 20  c, hex: 10  c, hex: 08  c, hex: 04  c, hex: 02  c, \ /
    250. 

  250. hex: 3E  c, hex: 51  c, hex: 49  c, hex: 45  c, hex: 3E  c, \ 0
    251. 

  251. hex: 00  c, hex: 42  c, hex: 7F  c, hex: 40  c, hex: 00  c, \ 1
    252. 

  252. hex: 72  c, hex: 49  c, hex: 49  c, hex: 49  c, hex: 46  c, \ 2
    253. 

  253. hex: 21  c, hex: 41  c, hex: 49  c, hex: 4D  c, hex: 33  c, \ 3
    254. 

  254. hex: 18  c, hex: 14  c, hex: 12  c, hex: 7F  c, hex: 10  c, \ 4
    255. 

  255. hex: 27  c, hex: 45  c, hex: 45  c, hex: 45  c, hex: 39  c, \ 5
    256. 

  256. hex: 3C  c, hex: 4A  c, hex: 49  c, hex: 49  c, hex: 31  c, \ 6
    257. 

  257. hex: 41  c, hex: 21  c, hex: 11  c, hex: 09  c, hex: 07  c, \ 7
    258. 

  258. hex: 36  c, hex: 49  c, hex: 49  c, hex: 49  c, hex: 36  c, \ 8
    259. 

  259. hex: 46  c, hex: 49  c, hex: 49  c, hex: 29  c, hex: 1E  c, \ 9
    260. 

  260. hex: 00  c, hex: 00  c, hex: 14  c, hex: 00  c, hex: 00  c, \ :
    261. 

  261. hex: 00  c, hex: 40  c, hex: 34  c, hex: 00  c, hex: 00  c, \ ;
    262. 

  262. hex: 00  c, hex: 08  c, hex: 14  c, hex: 22  c, hex: 41  c, \ <
    263. 

  263. hex: 14  c, hex: 14  c, hex: 14  c, hex: 14  c, hex: 14  c, \ =
    264. 

  264. hex: 00  c, hex: 41  c, hex: 22  c, hex: 14  c, hex: 08  c, \ >
    265. 

  265. hex: 02  c, hex: 01  c, hex: 59  c, hex: 09  c, hex: 06  c, \ ?
    266. 

  266. hex: 3E  c, hex: 41  c, hex: 5D  c, hex: 59  c, hex: 4E  c, \ @
    267. 

  267. hex: 7C  c, hex: 12  c, hex: 11  c, hex: 12  c, hex: 7C  c, \ A
    268. 

  268. hex: 7F  c, hex: 49  c, hex: 49  c, hex: 49  c, hex: 36  c, \ B
    269. 

  269. hex: 3E  c, hex: 41  c, hex: 41  c, hex: 41  c, hex: 22  c, \ C
    270. 

  270. hex: 7F  c, hex: 41  c, hex: 41  c, hex: 41  c, hex: 3E  c, \ D
    271. 

  271. hex: 7F  c, hex: 49  c, hex: 49  c, hex: 49  c, hex: 41  c, \ E
    272. 

  272. hex: 7F  c, hex: 09  c, hex: 09  c, hex: 09  c, hex: 01  c, \ F
    273. 

  273. hex: 3E  c, hex: 41  c, hex: 41  c, hex: 51  c, hex: 73  c, \ G
    274. 

  274. hex: 7F  c, hex: 08  c, hex: 08  c, hex: 08  c, hex: 7F  c, \ H
    275. 

  275. hex: 00  c, hex: 41  c, hex: 7F  c, hex: 41  c, hex: 00  c, \ I
    276. 

  276. hex: 20  c, hex: 40  c, hex: 41  c, hex: 3F  c, hex: 01  c, \ J
    277. 

  277. hex: 7F  c, hex: 08  c, hex: 14  c, hex: 22  c, hex: 41  c, \ K
    278. 

  278. hex: 7F  c, hex: 40  c, hex: 40  c, hex: 40  c, hex: 40  c, \ L
    279. 

  279. hex: 7F  c, hex: 02  c, hex: 1C  c, hex: 02  c, hex: 7F  c, \ M
    280. 

  280. hex: 7F  c, hex: 04  c, hex: 08  c, hex: 10  c, hex: 7F  c, \ N
    281. 

  281. hex: 3E  c, hex: 41  c, hex: 41  c, hex: 41  c, hex: 3E  c, \ O
    282. 

  282. hex: 7F  c, hex: 09  c, hex: 09  c, hex: 09  c, hex: 06  c, \ P
    283. 

  283. hex: 3E  c, hex: 41  c, hex: 51  c, hex: 21  c, hex: 5E  c, \ Q
    284. 

  284. hex: 7F  c, hex: 09  c, hex: 19  c, hex: 29  c, hex: 46  c, \ R
    285. 

  285. hex: 26  c, hex: 49  c, hex: 49  c, hex: 49  c, hex: 32  c, \ S
    286. 

  286. hex: 03  c, hex: 01  c, hex: 7F  c, hex: 01  c, hex: 03  c, \ T
    287. 

  287. hex: 3F  c, hex: 40  c, hex: 40  c, hex: 40  c, hex: 3F  c, \ U
    288. 

  288. hex: 1F  c, hex: 20  c, hex: 40  c, hex: 20  c, hex: 1F  c, \ V
    289. 

  289. hex: 3F  c, hex: 40  c, hex: 38  c, hex: 40  c, hex: 3F  c, \ W
    290. 

  290. hex: 63  c, hex: 14  c, hex: 08  c, hex: 14  c, hex: 63  c, \ X
    291. 

  291. hex: 03  c, hex: 04  c, hex: 78  c, hex: 04  c, hex: 03  c, \ Y
    292. 

  292. 

  293. (*
    294. 

  294. hex: 61  c, hex: 59  c, hex: 49  c, hex: 4D  c, hex: 43  c, \ Z \ Z unused 
    295. 

  295. hex: 00  c, hex: 7F  c, hex: 41  c, hex: 41  c, hex: 41  c, \ [
    296. 

  296. hex: 02  c, hex: 04  c, hex: 08  c, hex: 10  c, hex: 20  c, \ \
    297. 

  297. hex: 00  c, hex: 41  c, hex: 41  c, hex: 41  c, hex: 7F  c, \ ]
    298. 

  298. hex: 04  c, hex: 02  c, hex: 01  c, hex: 02  c, hex: 04  c, \ ^
    299. 

  299. hex: 40  c, hex: 40  c, hex: 40  c, hex: 40  c, hex: 40  c, \ _
    300. 

  300. hex: 00  c, hex: 03  c, hex: 07  c, hex: 08  c, hex: 00  c, \ `
    301. 

  301. hex: 20  c, hex: 54  c, hex: 54  c, hex: 78  c, hex: 40  c, \ a
    302. 

  302. hex: 7F  c, hex: 28  c, hex: 44  c, hex: 44  c, hex: 38  c, \ b
    303. 

  303. hex: 38  c, hex: 44  c, hex: 44  c, hex: 44  c, hex: 28  c, \ c
    304. 

  304. hex: 38  c, hex: 44  c, hex: 44  c, hex: 28  c, hex: 7F  c, \ d
    305. 

  305. hex: 38  c, hex: 54  c, hex: 54  c, hex: 54  c, hex: 18  c, \ e
    306. 

  306. hex: 00  c, hex: 08  c, hex: 7E  c, hex: 09  c, hex: 02  c, \ f
    307. 

  307. hex: 18  c, hex: A4  c, hex: A4  c, hex: 9C  c, hex: 78  c, \ g
    308. 

  308. hex: 7F  c, hex: 08  c, hex: 04  c, hex: 04  c, hex: 78  c, \ h
    309. 

  309. hex: 00  c, hex: 44  c, hex: 7D  c, hex: 40  c, hex: 00  c, \ i
    310. 

  310. hex: 20  c, hex: 40  c, hex: 40  c, hex: 3D  c, hex: 00  c, \ j
    311. 

  311. hex: 7F  c, hex: 10  c, hex: 28  c, hex: 44  c, hex: 00  c, \ k
    312. 

  312. hex: 00  c, hex: 41  c, hex: 7F  c, hex: 40  c, hex: 00  c, \ l
    313. 

  313. hex: 7C  c, hex: 04  c, hex: 78  c, hex: 04  c, hex: 78  c, \ m
    314. 

  314. hex: 7C  c, hex: 08  c, hex: 04  c, hex: 04  c, hex: 78  c, \ n
    315. 

  315. hex: 38  c, hex: 44  c, hex: 44  c, hex: 44  c, hex: 38  c, \ o
    316. 

  316. hex: FC  c, hex: 18  c, hex: 24  c, hex: 24  c, hex: 18  c, \ p
    317. 

  317. hex: 18  c, hex: 24  c, hex: 24  c, hex: 18  c, hex: FC  c, \ q
    318. 

  318. hex: 7C  c, hex: 08  c, hex: 04  c, hex: 04  c, hex: 08  c, \ r
    319. 

  319. hex: 48  c, hex: 54  c, hex: 54  c, hex: 54  c, hex: 24  c, \ s
    320. 

  320. hex: 04  c, hex: 04  c, hex: 3F  c, hex: 44  c, hex: 24  c, \ t
    321. 

  321. hex: 3C  c, hex: 40  c, hex: 40  c, hex: 20  c, hex: 7C  c, \ u
    322. 

  322. hex: 1C  c, hex: 20  c, hex: 40  c, hex: 20  c, hex: 1C  c, \ v
    323. 

  323. hex: 3C  c, hex: 40  c, hex: 30  c, hex: 40  c, hex: 3C  c, \ w
    324. 

  324. hex: 44  c, hex: 28  c, hex: 10  c, hex: 28  c, hex: 44  c, \ x
    325. 

  325. hex: 4C  c, hex: 90  c, hex: 90  c, hex: 90  c, hex: 7C  c, \ y
    326. 

  326. hex: 44  c, hex: 64  c, hex: 54  c, hex: 4C  c, hex: 44  c, \ z
    327. 

  327. *)
    328. 

    329. 

  329. \ Foreground and background color storage
    330. 

  330. WHT init-variable: fgC
    331. 

  331. BLK init-variable: bgC
    332. 

    333. 

  333. \ Set the text's foreground color
    334. 

  334. : setFG	( color -- )
    335. 

  335.   fgC !
    336. 

  336. ;
    337. 

    338. 

  338. \ Set the text's background color
    339. 

  339. : setBG	( color -- )
    340. 

  340.   bgC !
    341. 

  341. ;
    342. 

    343. 

  343. 1 init-variable: _sz_
    344. 

    345. 

  345. \ Set the size of the text
    346. 

  346. : setSize	( size -- )
    347. 

  347.   _sz_ !
    348. 

  348. ;
    349. 

    350. 

  350. \ A variation on fillRect
    351. 

  351. : fr            ( x y width height color -- )
    352. 

  352.   >r            ( x y width height color -- x y width height )
    353. 

  353.   rot                 ( x y width height -- x width height y )
    354. 

  354.   dup                 ( x width height y -- x width height y y )
    355. 

  355.   rot               ( x width height y y -- x width y y height )
    356. 

  356.   +                 ( x width y y height -- x width y y+height )
    357. 

  357.   >r                ( x width y y+height -- x width y )
    358. 

  358.   -rot                       ( x width y -- y x width )
    359. 

  359.   over                       ( y x width -- y x width x )
    360. 

  360.   +                        ( y x width x -- y x x+width )
    361. 

  361.   >r                       ( y x width+x -- y x )
    362. 

  362.   swap                             ( y x -- x y )
    363. 

  363.   r>                               ( x y -- x y x+width )
    364. 

  364.   r>                       ( x y x+width -- x y x+width y+height )
    365. 

  365.   r>              ( x y x+width y+height -- x y x+width y+height color )
    366. 

  366.   fillRect  ( x y x+width y+height color -- )
    367. 

  367. ;
    368. 

    369. 

  369. variable: _c_
    370. 

    371. 

  371. \ Print a character from the font
    372. 

  372. : pChr		        ( x y c -- )
    373. 

    374. 

  374.   \ For this app convert LC chars to UC chars
    375. 

  375.   dup                   ( x y c -- x y c c )
    376. 

  376.   hex: 61	      ( x y c c -- x y c c x61 )
    377. 

  377.   swap            ( x y c c x61 -- x y c x61 c )
    378. 

  378.   hex: 7A         ( x y c x61 c -- x y c x61 c x7A )
    379. 

  379.   between?    ( x y c x61 c x7A -- x y c f )
    380. 

  380.   if
    381. 

  381.       hex: DF and
    382. 

  382.   then
    383. 

    384. 

  384.   \ Calculate offset of char data in font
    385. 

  385.   hex: 20 - FW *	                                 ( x y c -- x y offset )
    386. 

    387. 

  387.   FW 1+ 0		\ For each column
    388. 

  388.   do
    389. 

  389.       dup                                           ( x y offset -- x y offset offset )
    390. 

  390.       FNT + i + c@                           ( x y offset offset -- x y offset c )
    391. 

  391.       i 5 =		\ Add a blank final column between characters
    392. 

  392.       if
    393. 

  393.            drop 0    
    394. 

  394.       then
    395. 

  395.       8 0		\ For each row
    396. 

  396.       do
    397. 

  397.           dup                                      ( x y offset c -- x y offset c c ) 
    398. 

  398.           1 i lshift                             ( x y offset c c -- x y offset c c mask )
    399. 

  399.           and                               ( x y offset c c mask -- x y offset c f )
    400. 

  400.           if
    401. 

  401.               fgC @                                ( x y offset c -- x y offset c color )
    402. 

  402.           else
    403. 

  403.               bgC @                                ( x y offset c -- x y offset c color ) 
    404. 

  404.           then    
    405. 

  405.           _c_ !                              ( x y offset c color -- x y offset c )
    406. 

  406.           2over                                    ( x y offset c -- x y offset c x y )
    407. 

  407.           swap                                 ( x y offset c x y -- x y offset c y x )
    408. 

  408.           _sz_ @ 1 =             
    409. 

  409.           if  \ No scaling ?
    410. 

  410.               j +                              ( x y offset c y x -- x y offset c y x+j )
    411. 

  411.               swap                           ( x y offset c y x+j -- x y offset c x+j y )
    412. 

  412.               i +                            ( x y offset c x+j y -- x y offset c x+j y+i )
    413. 

  413.               _c_ @                        ( x y offset c x+j y+i -- x y offset c x+j y+i color )
    414. 

  414.               pixel                  ( x y offset c x+j y+i color -- x y offset c )
    415. 

  415.           else \ Scaling
    416. 

  416.               _sz_ @ dup                       ( x y offset c y x -- x y offset c y x size size )
    417. 

  417.               j *                    ( x y offset c y x size size -- x y offset c y x size size*j )
    418. 

  418.               swap                 ( x y offset c y x size size*j -- x y offset c y x size*j size )
    419. 

  419.               i *                  ( x y offset c y x size*j size -- x y offset c y x size*j size*i )
    420. 

  420.               rot rot            ( x y offset c y x size*j size*i --  x y offset c y size*i x size*j )
    421. 

  421.               +                  ( x y offset c y size*i x size*j -- x y offset c y size*i x+size*j )
    422. 

  422.               rot rot            ( x y offset c y size*i x+size*j -- x y offset c x+size*j y size*i )
    423. 

  423.               +                  ( x y offset c x+size*j y size*i -- x y offset c x+size*j y+size*i )
    424. 

  424.               _sz_ @ dup         ( x y offset c x+size*j y+size*i -- x y offset c x+size*j y+size*i size size )
    425. 

  425.               _c_ @             ( ... x+size*j y+size*i size size -- ... x+size*j y+size*i size size color )
    426. 

  426.               fr          ( ... x+size*j y+size*i size size color -- x y offset c )
    427. 

  427.           then 
    428. 

  428.       loop
    429. 

  429.       drop
    430. 

  430.   loop
    431. 

  431.   3drop
    432. 

  432. ;
    433. 

    434. 

  434. \ Print zero terminated string onto display at specified position 
    435. 

  435. \ with current text size and foreground and background colors
    436. 

  436. : pStr		                  ( x y addr -- )
    437. 

  437.   begin
    438. 

  438.       dup		          ( x y addr -- x y addr addr )
    439. 

  439.       c@ dup		     ( x y addr addr -- x y addr c c )
    440. 

  440.       0 <>		     ( x y addr c c  -- x y addr c f )
    441. 

  441.   while
    442. 

  442.       >r                     ( x y addr c    --  x y addr )
    443. 

  443.       3dup                        ( x y addr -- x y addr x y addr )
    444. 

  444.       -rot               ( x y addr x y addr -- x y addr addr x y )
    445. 

  445.       r>                 ( x y addr addr x y -- x y addr addr x y c ) 
    446. 

  446.       pChr             ( x y addr addr x y c -- x y addr addr )
    447. 

  447.       drop                   ( x y addr addr -- x y addr )
    448. 

  448.       1+                          ( x y addr -- x y addr+1 )
    449. 

  449.       rot                       ( x y addr+1 -- y addr+1 x )
    450. 

  450.       FW 1+ _sz_ @ * +          ( y addr+1 x -- y addr+1 x' )
    451. 

  451.       -rot                     ( y addr+1 x' -- 'x y addr+1 )
    452. 

  452.   repeat
    453. 

  453.   4drop
    454. 

  454. ;
    455. 

    456. 

  456. \ Print a horizontally centered text string
    457. 

  457. : pCStr                        ( y addr -- )
    458. 

  458.   dup                          ( y addr -- y addr addr )
    459. 

  459.   strlen                  ( y addr addr -- y addr len )
    460. 

  460.   FW 1+ _sz_ @ * *         ( y addr len -- y addr pixelcount )
    461. 

  461.   WIDTH             ( y addr pixelcount -- y addr pixelcount width )
    462. 

  462.   swap        ( y addr pixelcount width -- y addr width pixelcount )
    463. 

  463.   -           ( y addr width pixelcount -- y addr width-pixelcount )
    464. 

  464.   2 /         ( y addr width-pixelcount -- y addr x )
    465. 

  465.   rot rot                    ( y addr x -- x y addr )
    466. 

  466.   pStr
    467. 

  467. ;
    468. 

    469. 

  469. \ NTP - Network Time Protocol Access
    470. 

  470. \ Written for PunyForth
    471. 

  471. \ By: Craig A. Lindley
    472. 

  472. \ Last Update: 01/21/2017
    473. 

    474. 

  474. \ Program Constants
    475. 

  475. 123  constant: NTP_PRT \ Port to send NTP requests to
    476. 

  476. 48   constant: PK_SZ   \ NTP time stamp in first 48 bytes of message
    477. 

    478. 

  478. \ Buffer for UDP packets
    479. 

  479. PK_SZ byte-array: pBuf
    480. 

    481. 

  481. \ NTP server host
    482. 

  482. str: "time.nist.gov" constant: NTP_SRV
    483. 

    484. 

  484. \ Send an NTP request packet and read response packet
    485. 

  485. : getTime     ( -- secondsSince1970 | 0 )
    486. 

    487. 

  487.   \ Clear all bytes of the packet buffer
    488. 

  488.   PK_SZ 0
    489. 

  489.   do
    490. 

  490.       0 i pBuf c!
    491. 

  491.   loop
    492. 

    493. 

  493.   \ Initialize values needed to form NTP request
    494. 

  494.   hex: E3  0 pBuf c! \ LI, Version, Mode
    495. 

  495.   hex: 06  2 pBuf c! \ Polling interval
    496. 

  496.   hex: EC  3 pBuf c! \ Peer clock precision
    497. 

  497.   hex: 31 12 pBuf c!
    498. 

  498.   hex: 4E 13 pBuf c!
    499. 

  499.   hex: 31 14 pBuf c!
    500. 

  500.   hex: 34 15 pBuf c!
    501. 

  501.  
    502. 

  502.   \ Send the UDP packet containing the NTP request
    503. 

  503.   \ Make connection to NTP server
    504. 

  504.   NTP_PRT NTP_SRV UDP netcon-connect
    505. 

    506. 

  506.   \ Send the NTP packet
    507. 

  507.   dup 0 pBuf PK_SZ netcon-send-buf
    508. 

    509. 

  509.   \ Read response into buffer
    510. 

  510.   dup
    511. 

  511.   PK_SZ 0 pBuf netcon-read ( -- netcon bytesRead )
    512. 

  512.   
    513. 

  513.   swap                      ( netcon bytesRead -- bytesRead netcon )
    514. 

  514.   
    515. 

  515.   \ Terminate the connection
    516. 

  516.   netcon-dispose            ( bytesRead netcon -- bytesRead )
    517. 

    518. 

  518.   PK_SZ =
    519. 

  519.   if 
    520. 

  520.       \ Assemble the response into time value
    521. 

  521.       40 pBuf c@ 24 lshift
    522. 

  522.       41 pBuf c@ 16 lshift or
    523. 

  523.       42 pBuf c@  8 lshift or
    524. 

  524.       43 pBuf c@           or
    525. 

    526. 

  526.       2208988800 -	\ SECS_TO_1970         
    527. 

  527.   else
    528. 

  528.       0
    529. 

  529.   then
    530. 

  530. ;
    531. 

    532. 

    533. 

  533. \ Time Library
    534. 

  534. \ Based on Arduino Time library by Michael Margolis & Paul Stoffregen
    535. 

  535. \ Written for PunyForth
    536. 

  536. \ By: Craig A. Lindley
    537. 

  537. \ Last Update: 01/21/2017
    538. 

    539. 

  539. \ Program constants
    540. 

  540. 60       constant: SPM
    541. 

  541. SPM 60 * constant: SPH
    542. 

  542. SPH 24 * constant: SPD
    543. 

    544. 

  544. 600 constant: syncInt       \ NTP time refresh interval in seconds
    545. 

    546. 

  546. \ Program variables
    547. 

  547. variable: sysTime                \ System time
    548. 

  548. variable: prevMS
    549. 

  549. variable: nextSync
    550. 

  550. variable: cacheTime
    551. 

    552. 

  552. \ Time element structure - holds time and date
    553. 

  553. struct 
    554. 

  554.   cell field: .second 
    555. 

  555.   cell field: .minute
    556. 

  556.   cell field: .hour
    557. 

  557.   cell field: .wday \ Day of week, sunday is day 1
    558. 

  558.   cell field: .day
    559. 

  559.   cell field: .month
    560. 

  560.   cell field: .year
    561. 

  561. constant: timeElements
    562. 

    563. 

  563. \ Create a new time elements object
    564. 

  564. : newTimeElements: ( "name" -- ) 
    565. 

  565.   timeElements create: allot
    566. 

  566. ;
    567. 

    568. 

  568. \ Instantiate timeElements object for current time
    569. 

  569. newTimeElements: time
    570. 

    571. 

  571. \ Instantiate timeElements object for use with makeTime
    572. 

  572. newTimeElements: newTime
    573. 

    574. 

  574. (*
    575. 

  575. str: "Year: " constant: yStr
    576. 

  576. str: "Mon: "  constant: monStr
    577. 

  577. str: "Day: "  constant: dStr
    578. 

  578. str: "WDay: " constant: wdStr
    579. 

  579. str: "Hour: " constant: hStr
    580. 

  580. str: "Min: "  constant: minStr
    581. 

  581. str: "Sec: "  constant: sStr
    582. 

    583. 

    584. 

  584. \ Show time elements object
    585. 

  585. : showTE	( tm -- )
    586. 

  586.   yStr   type dup .year    @ . space
    587. 

  587.   monStr type dup .month   @ . space
    588. 

  588.   dStr   type dup .day     @ . space
    589. 

  589.   wdStr  type dup .wday    @ . space
    590. 

  590.   hStr   type dup .hour    @ . space
    591. 

  591.   minStr type dup .minute  @ . space
    592. 

  592.   sStr   type     .second  @ . cr cr
    593. 

  593. ;
    594. 

  594. *)
    595. 

    596. 

  596. \ Initialized byte array creator
    597. 

  597. : byteArray ( N .. 1 number "name" -- ) ( index -- value )
    598. 

  598.     create: 
    599. 

  599.         0 do c, loop 
    600. 

  600.     does> + c@
    601. 

  601. ;
    602. 

    603. 

  603. \ Array of days in each month
    604. 

  604. 31 30 31 30 31 31 30 31 30 31 28 31 12 byteArray MONTHDAYS
    605. 

    606. 

  606. \ Leap year calc expects argument as years offset from 1970
    607. 

  607. : leapYear?                   ( year -- f )
    608. 

  608.   1970 +                      ( year -- year+1970 ) 
    609. 

  609.   dup dup                    ( year' -- year' year' year' )
    610. 

  610.   4 % 0=            ( year year year -- year year f )
    611. 

  611.   swap                 ( year year f -- year f year )
    612. 

  612.   100 % 0<>            ( year f year -- year f f )
    613. 

  613.   and                     ( year f f -- year f )
    614. 

  614.   swap                      ( year f -- f year )
    615. 

  615.   400 % 0=                  ( f year -- f f )
    616. 

  616.   or                           ( f f -- f )
    617. 

  617. ;
    618. 

    619. 

  619. variable: _year_
    620. 

  620. variable: _mon_
    621. 

  621. variable: _monLen_
    622. 

  622. variable: _days_
    623. 

  623. variable: _exit_
    624. 

    625. 

  625. \ Breakup the seconds since 1970 into individual time elements
    626. 

  626. : breakTime  ( timeSecs -- )
    627. 

    628. 

  628.   dup                           ( timeSecs -- timeSecs timeSecs )  
    629. 

  629.   60 % time .second !  ( timeSecs timeSecs -- timeSecs )
    630. 

  630.   60 /                          ( timeSecs -- timeMins )
    631. 

  631.   dup                           ( timeMins -- timeMins timeMins )
    632. 

  632.   60 % time .minute !  ( timeMins timeMins -- timeMins )
    633. 

  633.   60 /                          ( timeMins -- timeHours )
    634. 

  634.   dup                          ( timeHours -- timeHours timeHours )
    635. 

  635.   24 % time .hour !  ( timeHours timeHours -- timeHours )
    636. 

  636.   24 /                         ( timeHours -- timeDays )
    637. 

  637.   dup                           ( timeDays -- timeDays timeDays )
    638. 

  638.   4 + 7 % 1+ time .wday ! \ Sunday is day 1
    639. 

  639.   
    640. 

  640.   0 _year_ !                    ( timeDays -- )
    641. 

  641.   0 _days_ !
    642. 

    643. 

  643.   begin
    644. 

  644.       dup                       ( timeDays -- timeDays timeDays )
    645. 

  645.       _year_ @ leapYear? 
    646. 

  646.       if 
    647. 

  647.           366 _days_ +!
    648. 

  648.       else
    649. 

  649.           365 _days_ +!
    650. 

  650.       then
    651. 

  651.       _days_ @ >       ( timeDays timeDays -- timeDays f )
    652. 

  652.   while
    653. 

  653.       1 _year_ +!
    654. 

  654.   repeat                        ( timeDays -- )
    655. 

  655.   _year_ @ dup time .year !     ( timeDays -- timeDays year )
    656. 

  656.   leapYear?                ( timeDays year -- timeDays f ) 
    657. 

  657.   if 
    658. 

  658.       366 negate _days_ +!
    659. 

  659.   else
    660. 

  660.       365 negate _days_ +!
    661. 

  661.   then
    662. 

  662.   _days_ @ -      \ Time is now days in this year starting at 0
    663. 

    664. 

  664.   0 _days_ !	  ( -- timeDays )
    665. 

  665.   0 _mon_ !
    666. 

  666.   0 _monLen_ !
    667. 

  667.   FALSE _exit_ !
    668. 

    669. 

  669.   begin
    670. 

  670.       _mon_ @ 12 < _exit_ @ 0= and
    671. 

  671.   while
    672. 

  672.       _mon_ @ 1 =        \ Feb ?
    673. 

  673.       if 
    674. 

  674.           _year_ @ leapYear?
    675. 

  675.           if
    676. 

  676.               29 _monLen_ !
    677. 

  677.           else
    678. 

  678.               28 _monLen_ !
    679. 

  679.           then
    680. 

  680.       else
    681. 

  681.           _mon_ @ MONTHDAYS _monLen_ !
    682. 

  682.       then
    683. 

  683.       dup                     ( timeDays -- timeDays timeDays )
    684. 

  684.       _monLen_ @ >=
    685. 

  685.       if
    686. 

  686.           _monLen_ @ -
    687. 

  687.       else
    688. 

  688.           TRUE _exit_ !
    689. 

  689.       then
    690. 

  690.       1 _mon_ +!
    691. 

  691.   repeat
    692. 

  692.   _mon_ @ time .month !
    693. 

  693.   1+ time .day !
    694. 

  694. ;
    695. 

    696. 

  696. \ Convert newTime timeElements object into seconds since 1970
    697. 

  697. \ NOTE: Year is offset from 1970
    698. 

  698. : makeTime		              ( -- timeSecs )
    699. 

  699.   \ Seconds from 1970 till 1 jan 00:00:00 of the given year
    700. 

  700.   newTime .year @	              ( -- year )
    701. 

  701.   dup			         ( year -- year year )
    702. 

  702.   365 *                     ( year year -- year daysInYears )
    703. 

  703.   SPD *     ( year daysInYears -- year secsInYears )
    704. 

  704.   over               ( year secsInYears -- year secsInYears year )
    705. 

  705.   0
    706. 

  706.   do          ( year secsInYears year 0 -- year secsInYears )
    707. 

  707.       i leapYear?
    708. 

  708.       if
    709. 

  709.           SPD +
    710. 

  710.       then
    711. 

  711.   loop
    712. 

    713. 

  713.   \ Add days for this year, months start from 1
    714. 

  714.   newTime .month @   ( year secsInYears -- year secsInYears month )
    715. 

  715.   dup                ( year secsInYears month -- year secsInYears month month )
    716. 

  716.   1 <>
    717. 

  717.   if
    718. 

  718.       1
    719. 

  719.       do         ( year secsInYears month 1 -- year secsInYears )
    720. 

  720.           swap dup       ( year secsInYears -- secsInYears year year )
    721. 

  721.           leapYear? ( secsInYears year year -- secsInYears year f )
    722. 

  722.           i 2 = and		\ Feb in a leap year?
    723. 

  723.           if
    724. 

  724.               swap       ( secsInYears year -- year secsInYears )
    725. 

  725.               29 SPD * +
    726. 

  726.           else
    727. 

  727.               swap       ( secsInYears year -- year secsInYears )
    728. 

  728.               i 1- MONTHDAYS 
    729. 

  729.               SPD * +
    730. 

  730.           then
    731. 

  731.       loop
    732. 

  732.   else
    733. 

  733.       drop      
    734. 

  734.   then
    735. 

  735.   nip
    736. 

    737. 

  737.   newTime .day    @ 1- SPD  * +
    738. 

  738.   newTime .hour   @    SPH * +
    739. 

  739.   newTime .minute @    SPM  * +  
    740. 

  740.   newTime .second @                    +
    741. 

  741. ;
    742. 

    743. 

  743. \ Return the current system time syncing with NTP as appropriate
    744. 

  744. : now			( -- sysTime )
    745. 

  745.   \ Calculate number of seconds since last call to now
    746. 

  746.   begin
    747. 

  747.     ms@ prevMS @ - abs 1000 >=
    748. 

  748.   while
    749. 

  749.     1 sysTime +!	\ Advance system time by one second
    750. 

  750.     1000 prevMS +!
    751. 

  751.   repeat
    752. 

    753. 

  753.   \ Is it time to sync with NTP ?
    754. 

  754.   nextSync @ sysTime @ <=
    755. 

  755.   if
    756. 

  756.       getTime	( -- ntpTime )
    757. 

  757.       dup
    758. 

  758.       sysTime !
    759. 

  759.       syncInt +
    760. 

  760.       nextSync !
    761. 

  761.       ms@ prevMS !
    762. 

  762.   then
    763. 

  763.   sysTime @ 
    764. 

  764. ;
    765. 

    766. 

  766. \ Check and possibly refresh time cache
    767. 

  767. : refreshCache   	                  ( timeSecs -- )
    768. 

  768.   dup dup		                  ( timeSecs -- timeSecs timeSecs timeSecs )
    769. 

  769.   cacheTime @ <>	( timeSecs timeSecs timeSecs -- timeSecs timeSecs f )
    770. 

  770.   if
    771. 

  771.       breakTime		         ( timeSecs timeSecs -- timeSecs )
    772. 

  772.       cacheTime !	                  ( timeSecs -- )
    773. 

  773.   else
    774. 

  774.       2drop			 ( timeSecs timeSecs -- )
    775. 

  775.   then
    776. 

  776. ;
    777. 

    778. 

  778. \ Given time in seconds since 1970 return hour
    779. 

  779. : hour_t	   ( timeSecs -- hour )
    780. 

  780.   refreshCache	   ( timeSecs -- )
    781. 

  781.   time .hour @              ( -- hour )
    782. 

  782. ;
    783. 

    784. 

  784. (*
    785. 

  785. \ Return the now hour
    786. 

  786. : hour			    ( -- hour )
    787. 

  787.   now hour_t
    788. 

  788. ;
    789. 

  789. *)
    790. 

    791. 

  791. \ Given time in seconds since 1970 return hour in 12 hour format
    792. 

  792. : hourFormat12_t    ( timeSecs -- hour12 )
    793. 

  793.   refreshCache	    ( timeSecs -- )
    794. 

  794.   time .hour @ dup           ( -- hour hour )
    795. 

  795.   0=               ( hour hour -- hour f )
    796. 

  796.   if
    797. 

  797.       drop              ( hour -- ) 
    798. 

  798.       12                     ( -- 12 )
    799. 

  799.   else                       ( -- hour )
    800. 

  800.       dup               ( hour -- hour hour )
    801. 

  801.       12 >         ( hour hour -- hour f )
    802. 

  802.       if
    803. 

  803.           12 -
    804. 

  804.       then
    805. 

  805.   then
    806. 

  806. ;
    807. 

    808. 

  808. (*
    809. 

  809. \ Return now hour in 12 hour format
    810. 

  810. : hourFormat12               ( -- hour12 )
    811. 

  811.   now hourFormat12_t
    812. 

  812. ;
    813. 

  813. *)
    814. 

    815. 

  815. \ Given time in seconds since 1970 return PM status
    816. 

  816. : isPM_t	    ( timeSecs -- f )
    817. 

  817.   refreshCache	    
    818. 

  818.   time .hour @ 12 >=
    819. 

  819. ;
    820. 

    821. 

  821. (*
    822. 

  822. \ Determine if now time is PM
    823. 

  823. : isPM			     ( -- f )
    824. 

  824.   now isPM_t
    825. 

  825. ;
    826. 

  826. *)
    827. 

    828. 

  828. \ Given time in seconds since 1970 return AM status
    829. 

  829. : isAM_t 	   ( timeSecs -- f )
    830. 

  830.   refreshCache	    
    831. 

  831.   time .hour @ 12 <
    832. 

  832. ;
    833. 

    834. 

  834. (*
    835. 

  835. \ Determine if now time is AM
    836. 

  836. : isAM			   ( -- f ) 
    837. 

  837.   now isAM_t
    838. 

  838. ;
    839. 

  839. *)
    840. 

    841. 

  841. \ Given time in seconds since 1970 return minute
    842. 

  842. : minute_t	   ( timeSecs -- minute )
    843. 

  843.   refreshCache
    844. 

  844.   time .minute @
    845. 

  845. ;
    846. 

    847. 

  847. (*
    848. 

  848. \ Return the now minute
    849. 

  849. : minute			 ( -- minute )
    850. 

  850.   now minute_t
    851. 

  851. ;
    852. 

  852. *)
    853. 

    854. 

  854. \ Given time in seconds since 1970 return second
    855. 

  855. : second_t	        ( timeSecs -- second )
    856. 

  856.   refreshCache
    857. 

  857.   time .second @
    858. 

  858. ;
    859. 

    860. 

  860. (*
    861. 

  861. \ Return the now second
    862. 

  862. : second			 ( -- second )
    863. 

  863.   now second_t
    864. 

  864. ;
    865. 

  865. *)
    866. 

    867. 

  867. \ Given time in seconds since 1970 return day
    868. 

  868. : day_t 		( timeSecs -- day )
    869. 

  869.   refreshCache
    870. 

  870.   time .day @
    871. 

  871. ;
    872. 

    873. 

  873. (*
    874. 

  874. \ Return the now day
    875. 

  875. : day 			         ( -- day )
    876. 

  876.   now day_t
    877. 

  877. ;
    878. 

  878. *)
    879. 

    880. 

  880. \ Given time in seconds since 1970 return the week day with Sun as day 1
    881. 

  881. : weekDay_t		( timeSecs -- weekDay )
    882. 

  882.   refreshCache
    883. 

  883.   time .wday @
    884. 

  884. ;
    885. 

    886. 

  886. (*
    887. 

  887. \ Return the now week day with Sun as day 1
    888. 

  888. : weekDay		 	 ( -- weekDay )
    889. 

  889.   now weekDay_t
    890. 

  890. ;
    891. 

  891. *)
    892. 

    893. 

  893. \ Given time in seconds since 1970 return month
    894. 

  894. : month_t		( timeSecs -- month )
    895. 

  895.   refreshCache
    896. 

  896.   time .month @
    897. 

  897. ;
    898. 

    899. 

  899. (*
    900. 

  900. \ Return the now month
    901. 

  901. : month				 ( -- month )
    902. 

  902.   now month_t
    903. 

  903. ;
    904. 

  904. *)
    905. 

    906. 

  906. \ Given time in seconds since 1970 return year in full 4 digit format
    907. 

  907. : year_t		( timeSecs -- year )
    908. 

  908.   refreshCache
    909. 

  909.   time .year @ 1970 +
    910. 

  910. ;
    911. 

    912. 

  912. (*
    913. 

  913. \ Return the now year in full 4 digit format
    914. 

  914. : year			 	 ( -- year )
    915. 

  915.   now year_t
    916. 

  916. ;
    917. 

  917. *)
    918. 

    919. 

  919. (*
    920. 

  920. Test cases for breakTime and makeTime from Arduino program
    921. 

  921. ALL SUCCESSFUL
    922. 

  922. time_t: 1484340438 - Year: 47, Mon:  1, Day: 13, Hour: 20, Min: 47, Sec: 18
    923. 

  923. time_t: 1525094490 - Year: 48, Mon:  4, Day: 30, Hour: 13, Min: 21, Sec: 30
    924. 

  924. time_t: 1561177080 - Year: 49, Mon:  6, Day: 22, Hour:  4, Min: 18, Sec: 0
    925. 

  925. time_t: 1603973175 - Year: 50, Mon: 10, Day: 29, Hour: 12, Min:  6, Sec: 15
    926. 

  926. time_t: 68166375   - Year:  2, Mon:  2, Day: 28, Hour: 23, Min:  6, Sec: 15
    927. 

  927. *)
    928. 

    929. 

  929. \ Time Zone and Daylight Savings Time Library
    930. 

  930. \ Based on Arduino Timezone library by Jack Christensen
    931. 

  931. \ Written for PunyForth
    932. 

  932. \ By: Craig A. Lindley
    933. 

  933. \ Last Update: 01/21/2017
    934. 

    935. 

  935. \ Structure for describing a time change rule
    936. 

  936. struct
    937. 

  937.     cell field: .wk	\ last = 0 first second third fourth
    938. 

  938.     cell field: .dow	\ Sun = 1 .. Sat
    939. 

  939.     cell field: .mon	\ Jan = 1 .. Dec
    940. 

  940.     cell field: .hr     \ 0 .. 23
    941. 

  941.     cell field: .off	\ Offset from UTC in minutes
    942. 

  942. constant: TCR
    943. 

    944. 

  944. \ Time change rule object creator
    945. 

  945. : newTCR:	( "name" -- addrTCR ) 
    946. 

  946.   TCR create: allot
    947. 

  947. ;
    948. 

    949. 

  949. \ Structure for describing a title and two time change rules
    950. 

  950. struct
    951. 

  951.     cell field: .name
    952. 

  952.     cell field: .dstTCR
    953. 

  953.     cell field: .stdTCR
    954. 

  954. constant: TZ
    955. 

    956. 

  956. \ Time zone object creator
    957. 

  957. : newTZ:	( "name" -- addrTZ )
    958. 

  958.   TZ create: allot
    959. 

  959. ;
    960. 

    961. 

  961. \ Program variables
    962. 

  962. variable: dstUTC	\ DST start for given/current year, given in UTC
    963. 

  963. variable: stdUTC	\ STD start for given/current year, given in UTC
    964. 

  964. variable: dstLoc	\ DST start for given/current year, given in local time
    965. 

  965. variable: stdLoc	\ STD start for given/current year, given in local time
    966. 

  966. variable: theTZ		\ Variable holding the current TZ object
    967. 

    968. 

  968. \ Temp vars
    969. 

  969. variable: _y_
    970. 

  970. variable: _t_
    971. 

  971. variable: _m_
    972. 

  972. variable: _w_
    973. 

    974. 

  974. \ Convert a time change rule (TCR) to a time_t value for given year
    975. 

  975. : toTime_t		( TCR year -- time_t )
    976. 

  976.   _y_ !			( TCR year -- TCR )
    977. 

  977.   dup .mon  @ _m_ !
    978. 

  978.   dup .wk @ _w_ !              ( -- TCR )
    979. 

    980. 

  980.   _w_ @ 0=		\ Last week ?
    981. 

  981.   if
    982. 

  982.       1 _m_ +!
    983. 

  983.       _m_ @ 12 >
    984. 

  984.       if
    985. 

  985.           1 _m_ !
    986. 

  986.           1 _y_ +!
    987. 

  987.       then
    988. 

  988.       1 _w_ !
    989. 

  989.   then
    990. 

  990.   dup .hr @ 
    991. 

  991.     newTime .hour   !
    992. 

  992.   0 newTime .minute !
    993. 

  993.   0 newTime .second !
    994. 

  994.   1 newTime .day    !
    995. 

  995.   _m_ @ 
    996. 

  996.     newTime .month  !
    997. 

  997.   _y_ @ 1970 -
    998. 

  998.     newTime .year   ! 
    999. 

  999.   makeTime _t_ !			   ( -- TCR )
    1000. 

  1000.   7 _w_ @ 1- *			       ( TCR -- TCR f1 )
    1001. 

  1001.   over				    ( TCR f1 -- TCR f1 TCR )
    1002. 

  1002.   .dow @			( TCR f1 TCR -- TCR f1 DOW )
    1003. 

  1003.   _t_ @ weekDay_t		( TCR f1 DOW -- TCR f1 DOW WD )
    1004. 

  1004.   - 			     ( TCR f1 DOW WD -- TCR f1 DOW-WD )
    1005. 

  1005.   7 +			     ( TCR f1 DOW-WD -- TCR f1 DOW-WD+7 ) 
    1006. 

  1006.   7 %			   ( TCR f1 DOW-WD+7 -- TCR f1 DOW-WD+7%7 )
    1007. 

  1007.   +			 ( TCR f1 DOW-WD+7%7 -- TCR DOW-WD+7%7+f1 ) 
    1008. 

  1008.   SPD *	                 ( TCR DOW-WD+7%7+f1 -- TCR DOW-WD+7%7+f1*SPD )
    1009. 

  1009.    _t_ +!	     ( TCR DOW-WD+7%7+f1*SPD -- TCR )
    1010. 

  1010.   .wk @ 0=			       ( TCR -- f )
    1011. 

  1011.   if
    1012. 

  1012.       -7 SPD * _t_ +!
    1013. 

  1013.   then
    1014. 

  1014.   _t_ @
    1015. 

  1015. ;
    1016. 

    1017. 

  1017. \ Calculate the DST and standard time change points for the given
    1018. 

  1018. \ given year as local and UTC time_t values.  
    1019. 

  1019. : calcTC 	            ( year -- )
    1020. 

  1020.   dup			    ( year -- year year )
    1021. 

  1021.   >r		       ( year year -- year )
    1022. 

  1022.   theTZ @ .dstTCR @ 
    1023. 

  1023.   swap		            ( year -- TCR year )
    1024. 

  1024.   toTime_t dstLoc !	( TCR year -- )
    1025. 

  1025.   r>			         ( -- year )
    1026. 

  1026.   theTZ @ .stdTCR @
    1027. 

  1027.   swap		            ( year -- TCR year )
    1028. 

  1028.   toTime_t stdLoc !	( TCR year -- )
    1029. 

    1030. 

  1030.   dstLoc @ 
    1031. 

  1031.   theTZ @ .stdTCR @
    1032. 

  1032.   .off @
    1033. 

  1033.   SPM *
    1034. 

  1034.   -
    1035. 

  1035.   dstUTC !
    1036. 

    1037. 

  1037.   stdLoc @ 
    1038. 

  1038.   theTZ @ .dstTCR @
    1039. 

  1039.   .off @
    1040. 

  1040.   SPM *
    1041. 

  1041.   -
    1042. 

  1042.   stdUTC !
    1043. 

  1043. ;
    1044. 

    1045. 

  1045. \ Determine whether the given UTC time_t is within the DST interval
    1046. 

  1046. \ or the Standard time interval
    1047. 

  1047. : utcIsDST	               ( utc -- f )
    1048. 

  1048.   dup		               ( utc -- utc utc )
    1049. 

  1049.   year_t		   ( utc utc -- utc utc_yr )
    1050. 

  1050.   dstUTC @	        ( utc utc_yr -- utc utc_yr utc_dst )
    1051. 

  1051.   year_t	( utc utc_yr utc_dst -- utc utc_yr dst_yr )
    1052. 

  1052.   over		 ( utc utc_yr dst_yr -- utc utc_yr dst_yr utc_yr )
    1053. 

  1053.   <> 	  ( utc utc_yr dst_yr utc_yr -- utc utc_yr f )
    1054. 

  1054.   if
    1055. 

  1055.       calcTC
    1056. 

  1056.   else
    1057. 

  1057.       drop
    1058. 

  1058.   then		                   ( -- utc )
    1059. 

  1059.   dup 			       ( utc -- utc utc )
    1060. 

  1060.   stdUTC @ 
    1061. 

  1061.   dstUTC @  >
    1062. 

  1062.   if		\ Northern hemisphere
    1063. 

  1063.       dstUTC @ >=	   ( utc utc -- utc f )
    1064. 

  1064.       swap		     ( utc f -- f utc )
    1065. 

  1065.       stdUTC @ <
    1066. 

  1066.       and
    1067. 

  1067.   else		\ Southern hemisphere
    1068. 

  1068.       stdUTC @ >=	   ( utc utc -- utc f )
    1069. 

  1069.       swap		     ( utc f -- f utc )
    1070. 

  1070.       dstUTC @ <
    1071. 

  1071.       and 0=
    1072. 

  1072.   then
    1073. 

  1073. ;
    1074. 

    1075. 

  1075. \ Convert the given UTC time to local time, standard or
    1076. 

  1076. \ daylight time, as appropriate
    1077. 

  1077. : toLocal		       ( utc -- time_t )
    1078. 

  1078.   dup		               ( utc -- utc utc )
    1079. 

  1079.   year_t		   ( utc utc -- utc utc_yr )
    1080. 

  1080.   dstUTC @	        ( utc utc_yr -- utc utc_yr utc_dst )
    1081. 

  1081.   year_t	( utc utc_yr utc_dst -- utc utc_yr dst_yr )
    1082. 

  1082.   over		 ( utc utc_yr dst_yr -- utc utc_yr dst_yr utc_yr )
    1083. 

  1083.   <> 	  ( utc utc_yr dst_yr utc_yr -- utc utc_yr f )
    1084. 

  1084.   if
    1085. 

  1085.       calcTC            ( utc utc_yr -- utc )
    1086. 

  1086.   else
    1087. 

  1087.       drop
    1088. 

  1088.   then		                   ( -- utc )
    1089. 

  1089.   dup 			       ( utc -- utc utc )
    1090. 

  1090.   utcIsDST		   ( utc utc -- utc f )
    1091. 

  1091.   if
    1092. 

  1092.       theTZ @ .dstTCR @
    1093. 

  1093.      .off @
    1094. 

  1094.       SPM *
    1095. 

  1095.       +
    1096. 

  1096.   else
    1097. 

  1097.       theTZ @ .stdTCR @
    1098. 

  1098.      .off @
    1099. 

  1099.       SPM *
    1100. 

  1100.       +
    1101. 

  1101.   then
    1102. 

  1102. ;
    1103. 

    1104. 

  1104. \ Set the timezone in preparation for time conversion
    1105. 

  1105. : setTZ			( tz -- )
    1106. 

    1107. 

  1107.   \ Store tz into global variable
    1108. 

  1108.   theTZ !
    1109. 

    1110. 

  1110.   \ Clear all local variables for new calculation
    1111. 

  1111.   0 dstLoc !
    1112. 

  1112.   0 stdLoc !
    1113. 

  1113.   0 dstUTC !
    1114. 

  1114.   0 stdUTC !
    1115. 

  1115. ;
    1116. 

    1117. 

  1117. \ World Clock App
    1118. 

  1118. \ Written for PunyForth
    1119. 

  1119. \ By: Craig A. Lindley
    1120. 

  1120. \ Last Update: 01/21/2017
    1121. 

    1122. 

  1122. \ Set TRUE for 12 hour format; FALSE for 24 hour format
    1123. 

  1123. TRUE constant: 12HF
    1124. 

    1125. 

  1125. \ BEGIN TIME CHANGE RULE DEFINITIONS
    1126. 

    1127. 

  1127. (*
    1128. 

  1128. Australia Eastern Time Zone (Sydney, Melbourne)
    1129. 

  1129. TTimeChangeRule aEDT = {"AEDT", First, Sun, Oct, 2, 660};    //UTC + 11 hours
    1130. 

  1130. TimeChangeRule aEST = {"AEST", First, Sun, Apr, 3, 600};    //UTC + 10 hours
    1131. 

  1131. Timezone ausET(aEDT, aEST);
    1132. 

  1132. *)
    1133. 

    1134. 

  1134. \ Create TCR for daylight saving time
    1135. 

  1135. newTCR: aEDT
    1136. 

    1137. 

  1137. \ Initialize rule
    1138. 

  1138.  1 aEDT .wk   ! \ First week
    1139. 

  1139.  1 aEDT .dow  ! \ Sun
    1140. 

  1140. 10 aEDT .mon  ! \ Oct
    1141. 

  1141.  2 aEDT .hr   ! \ 2 PM
    1142. 

  1142. 660 aEDT .off ! \ TZ offset 11 hours
    1143. 

    1144. 

  1144. \ Create TCR for standard time
    1145. 

  1145. newTCR: aEST
    1146. 

    1147. 

  1147. \ Initialize rule
    1148. 

  1148.  1 aEST .wk   ! \ First week
    1149. 

  1149.  1 aEST .dow  ! \ Sun
    1150. 

  1150.  4 aEST .mon  ! \ Apr
    1151. 

  1151.  3 aEST .hr   ! \ 3 PM
    1152. 

  1152. 600 aEST .off ! \ TZ offset 10 hours
    1153. 

    1154. 

  1154. \ Create TZ object to hold TCRs
    1155. 

  1155. newTZ: ausET
    1156. 

    1157. 

  1157. str: "Sydney" ausET .name !
    1158. 

  1158. aEDT ausET .dstTCR !
    1159. 

  1159. aEST ausET .stdTCR !
    1160. 

    1161. 

  1161. (* CURRENTLY NOT USED
    1162. 

  1162. //Central European Time (Frankfurt, Paris)
    1163. 

  1163. TimeChangeRule CEST = {"CEST", Last, Sun, Mar, 2, 120};     //Central European Summer Time
    1164. 

  1164. TimeChangeRule CET = {"CET ", Last, Sun, Oct, 3, 60};       //Central European Standard Timezone CE(CEST, CET);
    1165. 

    1166. 

  1166. \ Create TCR for daylight saving time
    1167. 

  1167. newTCR: CEST
    1168. 

    1169. 

  1169. \ Initialize rule
    1170. 

  1170.  0 CEST .wk   ! \ Last week
    1171. 

  1171.  1 CEST .dow  ! \ Sun
    1172. 

  1172.  3 CEST .mon  ! \ Mar
    1173. 

  1173.  2 CEST .hr   ! \ 2 PM
    1174. 

  1174. 120 CEST .off ! \ TZ offset 2 hours
    1175. 

    1176. 

  1176. \ Create TCR for standard time
    1177. 

  1177. newTCR: CET
    1178. 

    1179. 

  1179. \ Initialize rule
    1180. 

  1180.  0 CET .wk   ! \ Last week
    1181. 

  1181.  1 CET .dow  ! \ Sun
    1182. 

  1182. 10 CET .mon  ! \ Oct
    1183. 

  1183.  3 CET .hr   ! \ 3 PM
    1184. 

  1184. 60 CET .off  ! \ TZ offset 1 hours
    1185. 

    1186. 

  1186. \ Create TZ object to hold TCRs
    1187. 

  1187. newTZ: CE
    1188. 

    1189. 

  1189. str: "Frankfurt" CE .name !
    1190. 

  1190. CEST CE .dstTCR !
    1191. 

  1191. CET  CE .stdTCR !
    1192. 

  1192. *)
    1193. 

    1194. 

  1194. (*
    1195. 

  1195. //United Kingdom (London, Belfast)
    1196. 

  1196. TimeChangeRule BST = {"BST", Last, Sun, Mar, 1, 60};        //British Summer Time
    1197. 

  1197. TimeChangeRule GMT = {"GMT", Last, Sun, Oct, 2, 0};         //Standard Time
    1198. 

  1198. Timezone UK(BST, GMT);
    1199. 

  1199. *)
    1200. 

    1201. 

  1201. \ Create TCR for daylight saving time
    1202. 

  1202. newTCR: BST
    1203. 

    1204. 

  1204. \ Initialize rule
    1205. 

  1205.  0 BST .wk   ! \ Last week
    1206. 

  1206.  1 BST .dow  ! \ Sun
    1207. 

  1207.  3 BST .mon  ! \ Mar
    1208. 

  1208.  1 BST .hr   ! \ 1 PM
    1209. 

  1209. 60 BST .off  ! \ TZ offset 1 hours
    1210. 

    1211. 

  1211. \ Create TCR for standard time
    1212. 

  1212. newTCR: GMT
    1213. 

    1214. 

  1214. \ Initialize rule
    1215. 

  1215.  0 GMT .wk   ! \ First week
    1216. 

  1216.  1 GMT .dow  ! \ Sun
    1217. 

  1217. 10 GMT .mon  ! \ Oct
    1218. 

  1218.  2 GMT .hr   ! \ 2 PM
    1219. 

  1219.  0 GMT .off  ! \ TZ offset 1 hours
    1220. 

    1221. 

  1221. \ Create TZ object to hold TCRs
    1222. 

  1222. newTZ: UK
    1223. 

    1224. 

  1224. str: "London" UK .name !
    1225. 

  1225. BST UK .dstTCR !
    1226. 

  1226. GMT UK .stdTCR !
    1227. 

    1228. 

  1228. (*
    1229. 

  1229. //US Eastern Time Zone (New York, Detroit)
    1230. 

  1230. TimeChangeRule usEDT = {"EDT", Second, Sun, Mar, 2, -240};
    1231. 

  1231. TimeChangeRule usEST = {"EST", First, Sun, Nov, 2, -300};
    1232. 

  1232. Timezone usET(usEDT, usEST);
    1233. 

  1233. *)
    1234. 

    1235. 

  1235. \ Create TCR for daylight saving time
    1236. 

  1236. newTCR: usEDT
    1237. 

    1238. 

  1238. \ Initialize rule
    1239. 

  1239.  2 usEDT .wk    ! \ Second week
    1240. 

  1240.  1 usEDT .dow   ! \ Sun
    1241. 

  1241.  3 usEDT .mon   ! \ Mar
    1242. 

  1242.  2 usEDT .hr    ! \ 2 PM
    1243. 

  1243. -240 usEDT .off ! \ TZ offset -4 hours
    1244. 

    1245. 

  1245. \ Create TCR for standard time
    1246. 

  1246. newTCR: usEST
    1247. 

    1248. 

  1248. \ Initialize rule
    1249. 

  1249.  1 usEST .wk     ! \ First week
    1250. 

  1250.  1 usEST .dow    ! \ Sun
    1251. 

  1251. 11 usEST .mon    ! \ Nov
    1252. 

  1252.  2 usEST .hr     ! \ 2 PM
    1253. 

  1253. -300 usEST .off  ! \ TZ offset -5 hours
    1254. 

    1255. 

  1255. \ Create TZ object to hold TCRs
    1256. 

  1256. newTZ: usET
    1257. 

    1258. 

  1258. str: "New York" usET .name !
    1259. 

  1259. usEDT usET .dstTCR !
    1260. 

  1260. usEST usET .stdTCR !
    1261. 

    1262. 

  1262. (* CURRENTLY NOT USED
    1263. 

  1263. //US Central Time Zone (Chicago, Houston)
    1264. 

  1264. TimeChangeRule usCDT = {"CDT", Second, Sun, Mar, 2, -300};
    1265. 

  1265. TimeChangeRule usCST = {"CST", First, Sun, Nov, 2, -360};
    1266. 

  1266. Timezone usCT(usCDT, usCST);
    1267. 

    1268. 

  1268. \ Create TCR for daylight saving time
    1269. 

  1269. newTCR: usCDT
    1270. 

    1271. 

  1271. \ Initialize rule
    1272. 

  1272.  2 usCDT .wk    ! \ Second week
    1273. 

  1273.  1 usCDT .dow   ! \ Sun
    1274. 

  1274.  3 usCDT .mon   ! \ Mar
    1275. 

  1275.  2 usCDT .hr    ! \ 2 PM
    1276. 

  1276. -300 usCDT .off ! \ TZ offset -5 hours
    1277. 

    1278. 

  1278. \ Create TCR for standard time
    1279. 

  1279. newTCR: usCST
    1280. 

    1281. 

  1281. \ Initialize rule
    1282. 

  1282.  1 usCST .wk     ! \ First week
    1283. 

  1283.  1 usCST .dow    ! \ Sun
    1284. 

  1284. 11 usCST .mon    ! \ Nov
    1285. 

  1285.  2 usCST .hr     ! \ 2 PM
    1286. 

  1286. -360 usCST .off  ! \ TZ offset -6 hours
    1287. 

    1288. 

  1288. \ Create TZ object to hold TCRs
    1289. 

  1289. newTZ: usCT
    1290. 

    1291. 

  1291. str: "Houston" usCT .name !
    1292. 

  1292. usCDT usCT .dstTCR !
    1293. 

  1293. usCST usCT .stdTCR !
    1294. 

  1294. *)
    1295. 

  1295.  
    1296. 

  1296. (*
    1297. 

  1297. //US Mountain Time Zone (Denver, Salt Lake City)
    1298. 

  1298. TimeChangeRule usMDT = {"MDT", Second, Sun, Mar, 2, -360};
    1299. 

  1299. TimeChangeRule usMST = {"MST", First, Sun, Nov, 2, -420};
    1300. 

  1300. Timezone usMT(usMDT, usMST);
    1301. 

  1301. *)
    1302. 

    1303. 

  1303. \ Create TCR for daylight savings time
    1304. 

  1304. newTCR: usMDT
    1305. 

    1306. 

  1306. \ Initialize rule
    1307. 

  1307.  2 usMDT .wk    ! \ Second week
    1308. 

  1308.  1 usMDT .dow   ! \ Sun
    1309. 

  1309.  3 usMDT .mon   ! \ Mar
    1310. 

  1310.  2 usMDT .hr    ! \ 2 PM
    1311. 

  1311. -360 usMDT .off ! \ TZ offset -6 hours
    1312. 

    1313. 

  1313. \ Create TCR for standard time
    1314. 

  1314. newTCR: usMST
    1315. 

    1316. 

  1316. \ Initialize rule
    1317. 

  1317.  1 usMST .wk    ! \ First week
    1318. 

  1318.  1 usMST .dow   ! \ Sun
    1319. 

  1319. 11 usMST .mon   ! \ Nov
    1320. 

  1320.  2 usMST .hr    ! \ 2 PM
    1321. 

  1321. -420 usMST .off ! \ TZ offset -7 hours
    1322. 

    1323. 

  1323. \ Create TZ object to hold TCRs
    1324. 

  1324. newTZ: usMT
    1325. 

    1326. 

  1326. str: "Denver" usMT .name !
    1327. 

  1327. usMDT usMT .dstTCR !
    1328. 

  1328. usMST usMT .stdTCR !
    1329. 

    1330. 

  1330. (* CURRENTLY NOT USED
    1331. 

  1331. //Arizona is US Mountain Time Zone but does not use DST
    1332. 

  1332. Timezone usAZ(usMST, usMST);
    1333. 

    1334. 

  1334. \ Create TZ object to hold TCRs
    1335. 

  1335. newTZ: usAZ
    1336. 

    1337. 

  1337. str: "Phoenix" usAZ .name !
    1338. 

  1338. usMST usAZ .dstTCR !
    1339. 

  1339. usMST usAZ .stdTCR !
    1340. 

  1340. *)
    1341. 

    1342. 

  1342. (*
    1343. 

  1343. //US Pacific Time Zone (Las Vegas, Los Angeles)
    1344. 

  1344. TimeChangeRule usPDT = {"PDT", Second, Sun, Mar, 2, -420};
    1345. 

  1345. TimeChangeRule usPST = {"PST", First, Sun, Nov, 2, -480};
    1346. 

  1346. Timezone usPT(usPDT, usPST);
    1347. 

  1347. *)
    1348. 

    1349. 

  1349. \ Create TCR for daylight savings time
    1350. 

  1350. newTCR: usPDT
    1351. 

    1352. 

  1352. \ Initialize rule
    1353. 

  1353.  2 usPDT .wk    ! \ Second week
    1354. 

  1354.  1 usPDT .dow   ! \ Sun
    1355. 

  1355.  3 usPDT .mon   ! \ Mar
    1356. 

  1356.  2 usPDT .hr    ! \ 2 PM
    1357. 

  1357. -420 usPDT .off ! \ TZ offset -7 hours
    1358. 

    1359. 

  1359. \ Create TCR for standard time
    1360. 

  1360. newTCR: usPST
    1361. 

    1362. 

  1362. \ Initialize rule
    1363. 

  1363.  1 usPST .wk    ! \ First week
    1364. 

  1364.  1 usPST .dow   ! \ Sun
    1365. 

  1365. 11 usPST .mon   ! \ Nov
    1366. 

  1366.  2 usPST .hr    ! \ 2 PM
    1367. 

  1367. -480 usPST .off ! \ TZ offset -8 hours
    1368. 

    1369. 

  1369. \ Create TZ object to hold TCRs
    1370. 

  1370. newTZ: usPT
    1371. 

    1372. 

  1372. str: "Los Angeles" usPT .name !
    1373. 

  1373. usPDT usPT .dstTCR !
    1374. 

  1374. usPST usPT .stdTCR !
    1375. 

    1376. 

  1376. \ END TIME CHANGE RULE DEFINITIONS
    1377. 

    1378. 

  1378. \ Format buffer
    1379. 

  1379. 20 buffer: fbuf
    1380. 

  1380. variable: i
    1381. 

    1382. 

  1382. \ Copy a string into format buffer
    1383. 

  1383. : cat                 ( sAddr -- ) 
    1384. 

  1384.   begin
    1385. 

  1385.       dup             ( sAddr -- sAddr sAddr )
    1386. 

  1386.       c@        ( sAddr sAddr -- sAddr c )
    1387. 

  1387.       dup           ( sAddr c -- sAddr c c )
    1388. 

  1388.       0           ( sAddr c c -- sAddr c c 0 )
    1389. 

  1389.       <>        ( sAddr c c 0 -- sAddr c f )
    1390. 

  1390.   while
    1391. 

  1391.       i @ fbuf + c! ( sAddr c -- sAddr )
    1392. 

  1392.       1 i +!
    1393. 

  1393.       1+              ( sAddr -- sAddr+1 )
    1394. 

  1394.   repeat
    1395. 

  1395.   i @ fbuf + c!     ( sAddr c -- sAddr )
    1396. 

  1396.   drop
    1397. 

  1397. ;
    1398. 

    1399. 

  1399. 5 buffer: nbuf
    1400. 

  1400. variable: j
    1401. 

  1401. variable: i1
    1402. 

    1403. 

  1403. \ Integer to string conversion
    1404. 

  1404. \ Can only do positive numbers with less than 5 digits
    1405. 

  1405. : i2s		           ( n -- )
    1406. 

  1406.   0 i1 !
    1407. 

  1407.   begin
    1408. 

  1408.      dup	           ( n -- n n )
    1409. 

  1409.      10 %	         ( n n -- n n%10 )
    1410. 

  1410.      48 +	      ( n n%10 -- n n%10+48 ) 
    1411. 

  1411.      i1 @ nbuf + c! ( n n%10+48 -- n )
    1412. 

  1412.      1 i1 +!
    1413. 

  1413.      10 /		   ( n -- n/10 )
    1414. 

  1414.      dup                ( n/10 -- n/10 n/10 )
    1415. 

  1415.      0 <=	   ( n/10 n/10 -- n/10 f )
    1416. 

  1416.   until
    1417. 

  1417.   drop
    1418. 

  1418.   0 i1 @ nbuf + c!
    1419. 

    1420. 

  1420.   \ Now reverse the characters in the string
    1421. 

    1422. 

  1422.   i1 @ 1- j !
    1423. 

  1423.   0 i1 !
    1424. 

    1425. 

  1425.   begin
    1426. 

  1426.       i1 @ nbuf + c@	             ( -- nbuf[i] )
    1427. 

  1427.       j @ nbuf + c@          ( nbuf[i] -- nbuf[i] nbuf[j] )
    1428. 

  1428.       i1 @ nbuf + c! ( nbuf[i] nbuf[j] -- nbuf[i] )
    1429. 

  1429.       j @ nbuf + c!          ( nbuf[i] -- )
    1430. 

  1430.        1 i1 +!
    1431. 

  1431.       -1 j +!
    1432. 

  1432.        i1 @ j @ >
    1433. 

  1433.   until
    1434. 

  1434. ; 
    1435. 

    1436. 

  1436. \ String array creator
    1437. 

  1437. : sa: ( strN .. str1 number "name" -- ) ( index -- addr of string )
    1438. 

  1438.     create: 
    1439. 

  1439.         0 do , loop 
    1440. 

  1440.     does> swap cells + @
    1441. 

  1441. ;
    1442. 

    1443. 

  1443. \ Months string array
    1444. 

  1444. str: "Dec" str: "Nov" str: "Oct" str: "Sep"    
    1445. 

  1445. str: "Aug" str: "Jul" str: "Jun" str: "May"
    1446. 

  1446. str: "Apr" str: "Mar" str: "Feb" str: "Jan"
    1447. 

  1447. str: ""  
    1448. 

  1448. 13 sa: MON
    1449. 

    1450. 

  1450. \ Days string array
    1451. 

  1451. str: "Sat" str: "Fri" str: "Thu" str: "Wed" 
    1452. 

  1452. str: "Tue" str: "Mon" str: "Sun" str: ""  
    1453. 

  1453. 8 sa: DOW
    1454. 

    1455. 

  1455. \ Am - Pm string array
    1456. 

  1456. str: "PM" str: "AM"
    1457. 

  1457. 2 sa: AMPM
    1458. 

    1459. 

  1459. \ Display time and date. Assumes theTZ set before call
    1460. 

  1460. : dtd
    1461. 

    1462. 

  1462.   \ Clear the dynamic area of the screen
    1463. 

  1463.   2 14 WIDTH 3 - HEIGHT 15 - BLK fillRect
    1464. 

    1465. 

  1465.   \ Print using larger text
    1466. 

  1466.   2 _sz_ !
    1467. 

    1468. 

  1468.   \ Print the name of the city
    1469. 

  1469.   20 theTZ @ .name @ pCStr
    1470. 

    1471. 

  1471.   \ Get the UTC time and convert it to local time
    1472. 

  1472.   now toLocal >r   
    1473. 

    1474. 

  1474.   \ Print day of the week
    1475. 

  1475.   41 r@ weekDay_t DOW pCStr
    1476. 

  1476.    
    1477. 

  1477.   \ Initialize format buffer index
    1478. 

  1478.   0 i !
    1479. 

    1480. 

  1480.   \ Format date string like: Wed Jan 18, 2017
    1481. 

  1481.   r@ month_t   MON cat str: " " cat
    1482. 

  1482.   r@ day_t     i2s nbuf cat str: ", " cat
    1483. 

  1483.   r@ year_t    i2s nbuf cat
    1484. 

  1484.   \ Print the centered date line
    1485. 

  1485.   62 fbuf pCStr  
    1486. 

    1487. 

  1487.   \ Initialize format buffer index
    1488. 

  1488.   0 i !
    1489. 

    1490. 

  1490.   \ Format the time string like: 9:59 AM
    1491. 

  1491.   r@
    1492. 

  1492.   12HF
    1493. 

  1493.   if
    1494. 

  1494.       hourFormat12_t
    1495. 

  1495.   else
    1496. 

  1496.       hour_t
    1497. 

  1497.   then
    1498. 

  1498.   i2s nbuf cat
    1499. 

  1499.   str: ":" cat
    1500. 

  1500.   r@ minute_t i2s nbuf
    1501. 

  1501.   \ If minutes single digit 0..9 add leading zero to string 
    1502. 

  1502.   dup strlen 1 =
    1503. 

  1503.   if
    1504. 

  1504.       str: "0" cat
    1505. 

  1505.   then
    1506. 

  1506.   cat
    1507. 

  1507.   str: " " cat
    1508. 

  1508.   r@ isAM_t
    1509. 

  1509.   if
    1510. 

  1510.       0 AMPM
    1511. 

  1511.   else
    1512. 

  1512.       1 AMPM
    1513. 

  1513.   then
    1514. 

  1514.   cat
    1515. 

    1516. 

  1516.   \ Print the centered time line
    1517. 

  1517.   3 _sz_ !	\ Print large text
    1518. 

  1518.   85 fbuf pCStr  
    1519. 

  1519.  
    1520. 

  1520.   \ Clean up
    1521. 

  1521.   r> drop
    1522. 

  1522. ;
    1523. 

    1524. 

  1524. variable: tz
    1525. 

    1526. 

  1526. \ Run the world clock app
    1527. 

  1527. : wc
    1528. 

    1529. 

  1529.   \ Initialize the LCD controller
    1530. 

  1530.   initLCD
    1531. 

    1532. 

  1532.   \ Clear the LCD to black
    1533. 

  1533.   0 0 WIDTH 1- HEIGHT 1- BLK fillRect
    1534. 

    1535. 

  1535.   \ Draw display frame
    1536. 

  1536.   0    0      WIDTH     YEL hLine
    1537. 

  1537.   0 HEIGHT 1- WIDTH     YEL hLine
    1538. 

  1538.   0    1     HEIGHT 2 - YEL vLine
    1539. 

  1539.   WIDTH 1- 1 HEIGHT 2 - YEL vLine
    1540. 

    1541. 

  1541.   GRN setFG
    1542. 

    1543. 

  1543.   \ Draw fixed text
    1544. 

  1544.   5   str: "World Clock"      pCStr
    1545. 

  1545.   116 str: "Craig A. Lindley" pCStr
    1546. 

    1547. 

  1547.   begin
    1548. 

  1548.       tz @
    1549. 

  1549.       case
    1550. 

  1550.           0 of ausET setTZ endof
    1551. 

  1551.           1 of UK    setTZ endof
    1552. 

  1552.           2 of usET  setTZ endof
    1553. 

  1553.           3 of usMT  setTZ endof
    1554. 

  1554.           4 of usPT  setTZ endof
    1555. 

  1555.       endcase
    1556. 

  1556.       \ Print the time and data for selected time zone
    1557. 

  1557.       dtd
    1558. 

  1558.       1 tz +!
    1559. 

  1559.       tz @ 4 >
    1560. 

  1560.       if
    1561. 

  1561.             0 tz !
    1562. 

  1562.       then
    1563. 

  1563.       \ Wait 30 seconds
    1564. 

  1564.       30000 ms
    1565. 

  1565.   again
    1566. 

  1566. ;
    1567. 

    1568. 

  1568. wc
    1569.