%%HP: T(3)A(D)F(.);
@ by Kevin Jessup.
DIR
  CURR
    \<< DATE CAL
    \>>
  \<-Y
    \<< 'year' 1 STO- GENCAL
    \>>
  Y\->
    \<< 'year' 1 STO+ GENCAL
    \>>
  \<-M
    \<<
      IF month 1 - DUP 1 <
      THEN DROP 12 'year' 1 STO-
      END 'month' STO GENCAL
    \>>
  M\->
    \<<
      IF month 1 + DUP 12 >
      THEN DROP 1 'year' 1 STO+
      END 'month' STO GENCAL
    \>>
  PCAL
    \<< PICT RCL PR1 DROP
    \>>
  CAL
    \<< EXPDT JFIX 'year' STO 'month' STO 'day' STO GENCAL
    \>>
  DOW
    \<< DATE SDOW
    \>>
  SDOW
    \<< 0 TSTR 1 3 SUB
    \>>
  RDOW
    \<< SDOW DOWL SWAP POS 1 -
    \>>
  LPYR
    \<< \-> y
      \<< y 4 MOD NOT y 100 MOD AND y 400 MOD NOT OR
      \>>
    \>>
  ALMDATE?
    \<<
      IF DUP FINDALARM DUP
      THEN RCLALARM 1 GET ==
      ELSE DROP 0
      END
    \>>
  MOY { "JANUARY" "FEBRUARY" "MARCH" "APRIL" "MAY" "JUNE" "JULY"
      "AUGUST" "SEPTEMBER" "OCTOBER" "NOVEMBER" "DECEMBER" }
  DIM { 31 28 31 30 31 30 31 31 30 31 30 31 }
  DOWL { "SUN" "MON" "TUE" "WED" "THU" "FRI" "SAT" }
  GENCAL
    \<< { # 0h # 0h } PVIEW MONTHBOX MOY month GET " " + year \->STR + 1
      \->GROB DUP SIZE DROP # 83h SWAP - # 2h / # 2h 2 \->LIST PICT SWAP
      ROT REPL FILLDAYS 7 FREEZE
    \>>
  FILLDAYS
    \<< 1 month year JFIX CPSDT RDOW 0 1 DIM month GET
      IF month 2 == year LPYR AND
      THEN 1 +
      END
      FOR d PICT 3 PICK R\->B # 12h * # 6h + 3 PICK R\->B # 8h * # 10h + 2
        \->LIST d \->STR d month year JFIX CPSDT
        IF ALMDATE?
        THEN 1 CHR +
        END 1 \->GROB REPL SWAP
        IF 1 + DUP 6 >
        THEN DROP 0 SWAP 1 + SWAP
        END SWAP
      NEXT DROP2
    \>>
  MONTHBOX
    \<< # 83h # 3Eh BLANK PICT STO
      { # 2h # 0h } { # 80h # 0h } LINE
      { # 2h # 0h } { # 2h # 3Dh } LINE
      { # 80h # 0h } { # 80h # 3Dh } LINE # Eh 1 7
      START # 2h OVER 2 \->LIST OVER # 80h SWAP 2 \->LIST LINE # 8h +
      NEXT DROP # 14h 1 6
      START DUP # Fh 2 \->LIST OVER # 3Eh 2 \->LIST LINE # 12h +
      NEXT DROP # 5h 1 7
      FOR i DUP # 8h 2 \->LIST DOWL i GET 1 3 SUB 1 \->GROB PICT 3 ROLLD REPL
        # 12h +
      NEXT DROP
    \>>
  CPSDT
    \<< 10000 / SWAP IP + 100 / SWAP IP +
    \>>
  EXPDT
    \<< DUP IP SWAP FP 100 * DUP IP SWAP FP 10000 *
    \>>
  JFIX
    \<<
      IF -42 FC?
      THEN 3 ROLLD SWAP 3 ROLL
      END
    \>>
  day 19
  year 1990
  month 10
  PPAR { (-6.5,-3.1) (6.5,3.2) X 0 (0,0) FUNCTION Y }
END