home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol229 / apc-date.lbr / DATE4.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1982-05-25  |  6.2 KB  |  248 lines
  1. PROGRAM DATE;
  2. CONST
  3.     Esc = #27;
  4. TYPE
  5.   MONTHTYPE = (JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC);
  6.   DOWTYPE = (SUN,MON,TUE,WED,THU,FRI,SAT);
  7.   YEARTYPE = 1583..9999;
  8.   StringType = STRING[80];
  9. VAR
  10.   CH : CHAR;
  11.   YEAR : YEARTYPE;
  12.   MONTH : MONTHTYPE;
  13.   DAY_OF_WEEK : DOWTYPE;
  14.  
  15.  
  16. PROCEDURE GetTime;
  17. TYPE
  18.     RegsType = RECORD
  19.                    AX,BX,CX,DX,BP,
  20.                    SI,DI,DS,ES,Flags : INTEGER;
  21.                END;
  22.     TimeType = RECORD
  23.                    Year    : BYTE;
  24.                    Mon_DOW : BYTE;
  25.                    Day     : BYTE;
  26.                    Hour    : BYTE;
  27.                    Mins    : BYTE;
  28.                    Secs    : BYTE;
  29.                END;
  30.  
  31. VAR
  32.     Regs    : RegsType;
  33.     TimeBuf : TimeType;
  34.  
  35. FUNCTION Get_Nibble(N : BYTE) : BYTE;
  36. BEGIN
  37.     Get_Nibble := N AND $F;
  38. END;
  39.  
  40. FUNCTION Get_BCD(N : BYTE) : BYTE;
  41. VAR
  42.     Temp : BYTE;
  43.  
  44. BEGIN
  45.     Temp := (N SHR 4 ) * 10;
  46.     Get_BCD := Temp + (N AND $F);
  47. END;
  48.  
  49. BEGIN
  50.  
  51.     Regs.DX := Ofs(TimeBuf);
  52.     Regs.DS := Seg(TimeBuf);
  53.     Regs.CX := 0;
  54.     INTR(220,Regs);
  55.  
  56.     Year        := Get_BCD(TimeBuf.Year) + 1900;
  57.     Month       := MonthType(Get_Nibble(TimeBuf.Mon_DOW SHR 4)-1);
  58.     Day_Of_Week := DOWType(Get_Nibble(TimeBuf.Mon_DOW) - 1);
  59.  
  60. {
  61. WITH TimeBuf DO BEGIN
  62.         WRITELN('Year  ',Get_BCD(Year));
  63.         WRITELN('Month ',Get_Nibble(Mon_DOW SHR 4));
  64.         WRITELN('DOW   ',Get_Nibble(Mon_DOW));
  65.         WRITELN('Day   ',Get_BCD(Day));
  66.         WRITELN('Hours ',Get_BCD(Hour));
  67.         WRITELN('Mins  ',Get_BCD(Mins));
  68.         WRITELN('Secs  ',Get_BCD(Secs));
  69. END;
  70. HALT;
  71. }
  72. END;
  73.  
  74. PROCEDURE PRINT_MONTH(MONTH : MONTHTYPE;
  75.                   YEAR : YEARTYPE;
  76.                   VAR DAY_OF_WEEK : DOWTYPE);
  77. CONST
  78.   SPACE = ' ';
  79.   SPACE6 = '      ';
  80. VAR
  81.   X : DOWTYPE;
  82.   J : INTEGER;
  83.   ROW : INTEGER;
  84.   DAY_OF_MONTH, DAYS_IN_MONTH : INTEGER;
  85.   NEW_MONTH : BOOLEAN;
  86.  
  87. PROCEDURE INIT_MONTH;
  88. BEGIN
  89.   CASE MONTH OF
  90.     JAN,MAR,MAY,JUL,AUG,OCT,DEC   : DAYS_IN_MONTH := 31;
  91.     APR,JUN,SEP,NOV               : DAYS_IN_MONTH := 30;
  92.     FEB : BEGIN
  93.            DAYS_IN_MONTH := 28;
  94.            IF YEAR MOD 4 = 0
  95.            THEN IF YEAR MOD 100 <> 0 THEN DAYS_IN_MONTH := 29
  96.            ELSE IF YEAR MOD 400 = 0 THEN DAYS_IN_MONTH := 29;
  97.           END; { BEGIN }
  98.     END; { CASE }
  99. END; { INIT_MONTH }
  100.  
  101. PROCEDURE DO_START;
  102. BEGIN
  103.   GOTOXY(16,6);
  104.   DAY_OF_MONTH := 1;
  105.   FOR X := SUN TO SAT DO
  106.     IF X < DAY_OF_WEEK THEN WRITE(SPACE6)
  107.     ELSE BEGIN
  108.       WRITE(DAY_OF_MONTH:5,SPACE);
  109.       DAY_OF_MONTH := DAY_OF_MONTH + 1;
  110.       END; { ELSE BEGIN }
  111.   WRITELN;
  112. END; { DO_START }
  113.  
  114. PROCEDURE DO_MIDDLE;
  115. BEGIN
  116.   GOTOXY(16,ROW);
  117.   FOR X := SUN TO SAT DO
  118.     IF DAY_OF_MONTH <= DAYS_IN_MONTH THEN BEGIN
  119.       WRITE(DAY_OF_MONTH:5,SPACE);
  120.       DAY_OF_MONTH := DAY_OF_MONTH + 1;
  121.       END; { THEN BEGIN }
  122.   ROW := ROW + 3;       (* SKIP 3 SCREEN LINES *)
  123. END; { DO_MIDDLE }
  124.  
  125. PROCEDURE DO_HEADER;
  126. BEGIN
  127.     GOTOXY(34,2);
  128.     NormVideo;
  129.     CASE MONTH OF
  130.         JAN : WRITE('JANUARY');
  131.         FEB : WRITE('FEBRUARY');
  132.         MAR : WRITE('MARCH');
  133.         APR : WRITE('APRIL');
  134.         MAY : WRITE('MAY');
  135.         JUN : WRITE('JUNE');
  136.         JUL : WRITE('JULY');
  137.         AUG : WRITE('AUGUST');
  138.         SEP : WRITE('SEPTEMBER');
  139.         OCT : WRITE('OCTOBER');
  140.         NOV : WRITE('NOVEMBER');
  141.         DEC : WRITE('DECEMBER');
  142.     END; { CASE }
  143.     WRITE(YEAR:5);
  144.     LowVideo;
  145.     GOTOXY(15,4);  (* CURSOR 1 PLACE BEFORE Reverse *)
  146.     WRITELN(ESC,'[7m','SUN':6,'MON':6,'TUE':6,'WED':6,'THU':6,'FRI':6,'SAT':6,
  147.        '   ',ESC,'[1m');
  148. END; { DO_HEADER }
  149.  
  150. BEGIN { PRINT_MONTH }
  151.   ROW := 8;     (* FOR SCREEN LINE *)
  152.   NEW_MONTH := TRUE;
  153.   INIT_MONTH;
  154.   ClrScr;
  155.   DO_HEADER;
  156.   NormVideo;
  157.   FOR J := 1 TO 6 DO BEGIN
  158.     IF NEW_MONTH THEN DO_START ELSE DO_MIDDLE;
  159.     NEW_MONTH := FALSE;
  160.   END; { DO BEGIN }
  161.   LowVideo;
  162. END; { PRINT_MONTH }
  163.  
  164. PROCEDURE ToUpper(VAR S : StringType);
  165. VAR
  166.   X : INTEGER;
  167.  
  168. BEGIN
  169.     FOR X := 1 TO LENGTH(S) DO S[X] := UPCASE(S[X]);
  170. END; { ToUpper }
  171.  
  172. PROCEDURE GET_MONTH;
  173. TYPE
  174.     MonListType = STRING[36];
  175.  
  176. CONST
  177.     MonList : MonListType = 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
  178.  
  179. VAR
  180.   M : StringType;
  181.   X : BYTE;
  182.  
  183. BEGIN { GET_MONTH }
  184.     REPEAT
  185.         GOTOXY(0,21); ClrEol;
  186.         WRITE('Month: '); READLN(M);
  187.         M := COPY(M,1,3);
  188.         ToUpper(M);
  189.         X := POS(M,MonList);
  190.     UNTIL X <> 0;
  191.     Month := MonthType((X - 1) DIV 3);
  192.     REPEAT
  193.         GOTOXY(0,22); ClrEol;
  194.         WRITE('Year: '); READLN(YEAR);
  195.         IF (YEAR >= 0) AND (YEAR < 100) THEN YEAR := YEAR + 1900;
  196.     UNTIL (YEAR >= 1583) AND (YEAR <= 9999);
  197. END; { GET_MONTH }
  198.  
  199. PROCEDURE GET_DOW(Y : YEARTYPE; M : MONTHTYPE);
  200. VAR
  201.   X,CENTURY,YEAR,MONTH,DAY : INTEGER;
  202. BEGIN
  203.     YEAR  := Y;
  204.     MONTH := ORD(M) + 1;
  205.     DAY   := 1;
  206.     MONTH := MONTH - 2;
  207.     IF MONTH < 1 THEN BEGIN
  208.         MONTH := MONTH + 12;
  209.         YEAR := YEAR - 1;
  210.     END; { THEN BEGIN }
  211.     CENTURY := YEAR DIV 100;
  212.     YEAR    := YEAR MOD 100;
  213.     X       := ((26*MONTH-2) DIV 10 + DAY + YEAR + YEAR DIV 4 + CENTURY DIV 4
  214.                  - (CENTURY * 2)) MOD 7;
  215.     Day_Of_Week := DOWType(X);
  216. END; { GET_DOW }
  217.  
  218. BEGIN { MAIN }
  219.     LowVideo; WRITELN('Calendar version 3.0'); WRITELN;
  220.     GetTime;
  221.     REPEAT
  222.         REPEAT
  223.             Get_DOW(YEAR,MONTH);
  224.             PRINT_MONTH(MONTH,YEAR,DAY_OF_WEEK);
  225.             GOTOXY(0,23); WRITE('<--[ , ]--> , Q(uit, N(ew ');
  226.             REPEAT
  227.                 READ(KBD,CH);
  228.                 CH := UPCASE(CH);
  229.             UNTIL CH IN ['Q','N',#29,#8,#19,#12,#4];
  230.             CASE CH OF
  231.                 'Q'    : HALT;
  232.                 #29,#8,#19 : IF MONTH = JAN THEN BEGIN
  233.                              MONTH := DEC;
  234.                              YEAR := YEAR - 1;
  235.                          END
  236.                          ELSE MONTH := PRED(MONTH);
  237.                 #12,#4 : IF MONTH = DEC THEN BEGIN
  238.                              MONTH := JAN;
  239.                              YEAR := YEAR + 1;
  240.                          END
  241.                          ELSE MONTH := SUCC(MONTH);
  242.             END; { CASE }
  243.         UNTIL CH = 'N';
  244.         Get_Month;
  245.         Get_DOW(Year,Month);
  246.     UNTIL FALSE;
  247. END. { MAIN }
  248.