home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / clock.seq < prev    next >
Encoding:
Text File  |  1990-04-19  |  7.6 KB  |  196 lines
  1. \  MYCLOCK.BLK   a visual clock program                11Nov87jgm
  2.  
  3. \                      November 1987
  4.  
  5. \                       J.G. Modrow
  6. \                     6320 Menlo Drive
  7. \                    San Jose, CA 95120
  8.  
  9. \                     (408) 997-3530
  10.  
  11.  
  12. \       shows a digital clock, hh:mm:ss at the top of the
  13. \       screen abd mm/dd/yy under it, both in roman numerals.
  14.  
  15. \       Mid screen is a bar graph display showing Hours in
  16. \       15 minute intervals, minutes, seconds, month in 5
  17. \       day intervals, days, years MOD 50.
  18.  
  19. \ 10/19/89 TJZ
  20. \ Use the following DOS command line to compile CLOCK.SEQ into the
  21. \ CLOCK.COM program file:
  22. \
  23. \       C:> TCOM CLOCK /OPT /NOINIT <Enter>
  24. \
  25.  
  26. \ cons, vars, arrays, strings
  27.  
  28. CREATE R-UNITS  ,"     I   II  III IV  V   VI  VII VIIIIX  "
  29. CREATE R-TENS   ,"        X  XX XXX  XL   L  LX LXXLXXX  XC"
  30. CREATE R-HUNDS  ,"     C   CC  CCC CD  D   DC  DCC DCCCCM  "
  31. CREATE R-THOUS  ,"        M  MM MMM  M?   ?  ?M ?MM?MMM  ??"
  32.  
  33. VARIABLE LAST-SEC       VARIABLE LAST-MIN \ last time displayed
  34. VARIABLE LAST-HR        VARIABLE LAST-DAY
  35. VARIABLE LAST-MO        VARIABLE LAST-YR
  36.  
  37. \  CREATE MONTHS   " JanFebMarAprMayJunJulAugSepOctNovDec"
  38.  
  39. \  : .MONTH        ( mo -- ) \ print month
  40. \      3 * MONTHS +  3 TYPE SPACE  ;
  41.  
  42.  
  43. \  print Roman Numeral clock
  44.  
  45. : .R-NUM        ( adr n -- )  4 * + ( 3 fix for F-PC) 1 +  4 TYPE ; \ n = 0..9
  46.  
  47. : .R-TU         ( n -- ) \ n = 0..99, prints roman numerals
  48.     100 MOD 10 /MOD R-TENS SWAP .R-NUM R-UNITS SWAP .R-NUM ;
  49.  
  50. : .R-TH         ( n -- ) \ n = 0..9999, prints 1000s & 100S
  51.     100 / 10 /MOD R-THOUS SWAP .R-NUM R-HUNDS SWAP .R-NUM ;
  52.  
  53. : .=            ( n -- )     1- FOR 205 EMIT NEXT ;
  54.  
  55. : ?SEC          ( -- h m s f ) \ f = true if sec changed.
  56.         GETTIME  256 / >R  256 /MOD SWAP  R>
  57.         DUP LAST-SEC @ <>  ;
  58.  
  59. : .R-TIME       ( h m s f -- ) \ print digital time in roman #s
  60.         IF    27 1 AT  DUP LAST-SEC !   \ save sec
  61.               ROT  .R-TU 186 EMIT SWAP  \ print hrs:
  62.               .R-TU 186 EMIT .R-TU      \ print min:sec
  63.         ELSE  2DROP DROP
  64.         THEN  ;
  65.  
  66. : CLOCK-BOX     ( -- ) \ draws box around roman digital clock.
  67.         DARK  cursor-off 26 0 AT        \ top line
  68.         201 EMIT 8 .= 203 EMIT 8 .= 203 EMIT 8 .= 187 EMIT
  69.         26 1 AT  186 EMIT 8 SPACES      \ time boxes
  70.         186 EMIT 8 SPACES 186 EMIT 8 SPACES 186 EMIT
  71.         26 2 AT                         \ middle line
  72.         204 EMIT 8 .= 206 EMIT 8 .= 206 EMIT 8 .= 185 EMIT
  73.         26 3 AT  186 EMIT 8 SPACES      \ date boxes
  74.         186 EMIT 8 SPACES 186 EMIT 8 SPACES 186 EMIT
  75.         26 4 AT                         \ bottom line
  76.         200 EMIT 8 .= 202 EMIT 8 .= 202 EMIT 8 .= 188 EMIT  ;
  77.  
  78. : ?DAY          ( -- yr day mo f ) \ f = true if day changed.
  79.         GETDATE  SPLIT  OVER LAST-DAY @  <>  ;
  80.  
  81. : .R-DATE       ( yr day mo f -- ) \ prints date in roman #s.
  82.         IF    OVER LAST-DAY !           \ update current day
  83.               27 3 AT  .R-TU  186 EMIT  \ print month
  84.               .R-TU  186 EMIT .R-TU     \ print day & year
  85.         ELSE  2DROP DROP
  86.         THEN  ;
  87.  
  88. \  print bar graph clock
  89.  
  90. : BAR-HEADER    ( -- )          \ prints header lines for bar graph clk
  91.         5 10 AT         0 12 FOR DUP 5 .R 1+    NEXT DROP CR
  92.         9 SPACES ." |"    11 FOR ." ....|"      NEXT CR
  93.         ." Hour"  CR    ." Mins" CR     ." Secs"  CR
  94.         9 SPACES ." |"    11 FOR ." ....|"      NEXT CR
  95.         ." Month" CR    ." Day " CR     ." Year"  CR
  96.         9 SPACES ." |"    11 FOR ." ''''|"      NEXT CR
  97.         5 SPACES        0 12 FOR DUP 5 .R  5 +  NEXT DROP CR
  98.        12 SPACES ." Written by  J. G. Modrow,"
  99.        ."   November 1987  <ESC> to Quit"   ;
  100.  
  101. : .BAR  ( chr r n -- ) \ prints chr at position n, row r.
  102.         9 +  SWAP AT  EMIT  ;
  103.  
  104. : .NEW-BAR      ( chr r n -- ) \ prints bar to position n, at row r.
  105.         9 ROT AT  1+ FOR DUP EMIT NEXT DROP  ;
  106.  
  107. : ?CLR-BAR      ( r f -- ) \ erases bar  if true.
  108.         IF 9 SWAP AT 61 SPACES  ELSE DROP  THEN  ;
  109.  
  110. : .B-SEC        ( s -- ) \ prints current seconds on bar
  111.         14 OVER 0= ?CLR-BAR     \ erase if secs = 0
  112.         177 14 ROT .BAR   ;     \ print seconds bar
  113.  
  114. : .B-MIN        ( m -- ) \ prints minutes bar
  115.         DUP   LAST-MIN @ <>             \ print minute?
  116.         IF    DUP LAST-MIN !            \ update current minute
  117.               13 OVER 0= ?CLR-BAR       \ erase if mins = 0
  118.               178 13 ROT .BAR           \ print mins, 12 hr clk
  119.         ELSE  DROP
  120.         THEN  ;
  121.  
  122. : .B-HOUR       ( h m -- ) \ prints hours bar
  123.         12 /  SWAP 12 MOD  5 *  +       \ calc hours position
  124.         DUP   LAST-HR @ <>              \ print hour?
  125.         IF    DUP LAST-HR !             \ update current hour
  126.               12 OVER 0= ?CLR-BAR       \ erase if hrs = 0
  127.               219 12 ROT .BAR           \ print hrs
  128.         ELSE  DROP
  129.         THEN  ;
  130.  
  131. : .B-TIME       ( h m s f -- ) \ prints current time on bar
  132.         IF    .B-SEC   DUP              \ print seconds bar
  133.               .B-MIN  .B-HOUR           \ print min, hr bars
  134.         ELSE  2DROP DROP
  135.         THEN  ;
  136.  
  137. : .NEW-TIME     ( h m s f -- ) \ initializes time bars.
  138.         DROP 177 14 ROT .NEW-BAR        \ seconds
  139.         DUP  178 13 ROT .NEW-BAR        \ minutes
  140.         12 /  SWAP 12 MOD  5 *  +
  141.              219 12 ROT .NEW-BAR  ;     \ hours
  142.  
  143. : .B-DAY        ( day -- ) \ prints current day bar
  144.         17 OVER 1 = ?CLR-BAR    \ erase if day = 1
  145.         178 17 ROT .BAR   ;     \ print days bar
  146.  
  147. : .B-MONTH      ( day mo -- ) \ prints current month bar
  148.         5 * SWAP 29 MIN 6 / +           \ calc month position
  149.         DUP   LAST-MO @ <>              \ print month?
  150.         IF    DUP LAST-MO !             \ update current month
  151.               16 OVER 1 = ?CLR-BAR      \ erase if month = 1
  152.               219 16 ROT .BAR           \ print month bar
  153.         ELSE  DROP
  154.         THEN  ;
  155.  
  156. : .B-YEAR       ( yr -- ) \ prints current year MOD 50
  157.         50 MOD  DUP LAST-YR @ <>        \ 0..50 range, new year?
  158.         IF    DUP LAST-YR !             \ update current year
  159.               18 OVER 0= ?CLR-BAR       \ erase if yr ends in 0
  160.               177 18 ROT .BAR           \ print year
  161.         ELSE  DROP
  162.         THEN  ;
  163.  
  164. : .NEW-DATE     ( yr day mo f -- ) \ initializes date bars.
  165.         DROP  5 *  OVER 29 MIN 6 /  +
  166.                219 16 ROT .NEW-BAR      \ month
  167.                178 17 ROT .NEW-BAR      \ day
  168.         50 MOD 177 18 ROT .NEW-BAR  ;   \ year
  169.  
  170. : .B-DATE       ( yr day mo f -- ) \ prints date in roman #s.
  171.         IF    OVER .B-DAY  .B-MONTH     \ print day&month bars
  172.               .B-YEAR                   \ print year MOD 50
  173.         ELSE  2DROP DROP
  174.         THEN  ;
  175.  
  176. \  Combine Roman Numeral and Bar Graph clocks
  177.  
  178. : TIC/TOK       ( -- ) \ Roman & bar graph digital clock
  179.                 DECIMAL                         \ always select decimal
  180.                 INIT-CURSOR                     \ get intial cursor shape
  181.                 DOSIO_INIT                      \ init EMIT, TYPE & SPACES
  182.                 LAST-SEC ON  LAST-MIN ON  LAST-HR ON
  183.                 LAST-DAY ON  LAST-MO  ON  LAST-YR ON
  184.                 CLOCK-BOX    BAR-HEADER
  185.                 ?SEC .NEW-TIME  ?DAY .NEW-DATE
  186.                 BEGIN  ?SEC  4DUP .R-TIME  .B-TIME
  187.                        ?DAY  4DUP .R-DATE  .B-DATE
  188.                        KEY?     IF      KEY
  189.                                         27 =
  190.                                         IF      DROP CURSOR-ON
  191.                                                 0 21 AT ABORT
  192.                                         THEN
  193.                                 THEN
  194.                 AGAIN  ;
  195.  
  196.