ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/MISCPAS.ZIP/DATES.PAS

Pascal/Delphi Source File | 1992-06-23 | 42.6 KB | 1,310 lines

PROGRAM dates(input,output);
  { Bruce Hillyer.  Keeps a list of memos.  Displays appropriate calendars.
    Written for Turbo Pascal. }

  {$i zString.tur} { include null-terminated string routines }

  CONST
    yearBase   = 1900; { add to 0..99 to get year }
    memoMax    = 200;  { number of memos the program can hold }
    display    = 12;   { number of memo lines to show under the calendar - 1 }
    statusLine = 10;   { line for printing status }
    promptLine = 11;
    memoLine   = 12;
    memoFileNm = '\dates.mem';  { file name to store memos, in root }

  TYPE
    dayType   = 1..31;
    monthType = 1..12;
    yearType  = 100..10000;

    dateType = RECORD
                 day : dayType;
                 month : monthType;
                 year : yearType
               END;

    memoType = RECORD
                 startDate : dateType;
                 endDate : dateType;
                 comment : zString
               END;

    memoArrayType = ARRAY[0..memoMax] OF memoType; { 0 is not used }

VAR
  { date-handling global constants }
  monthName   : ARRAY[monthType] OF STRING[10]; { month names }
  monthLen    : ARRAY[monthType] OF INTEGER;  { length of month names in chrs }
  monthSize   : ARRAY[monthType] OF INTEGER;  { days per month }
  monthOffset : ARRAY[monthType] OF INTEGER;  { days before 1st of the month }
  dayName     : ARRAY[dayType] OF STRING[10];   { day names }
  dayLen      : ARRAY[dayType] OF INTEGER;    { length of day names in chrs }
  today       : dateType;
  tomorrow    : dateType;

  { variables }
  memoFile    : FILE OF memoType;
  memoArray   : memoArrayType;
  nMemo       : INTEGER;
  finish      : BOOLEAN;
  currentLine : INTEGER;
  currentDate : dateType;
  showingDate : dateType;
  command     : zString;
  pos         : zStringSub;




PROCEDURE pause;
  BEGIN GotoXY(1,25);
        ClrEol;
        Write(output,'  (press return to continue)');
        WHILE NOT Keypressed DO { nothing }
  END; { pause }





{ ----------------------- date handling --------------------------- }

PROCEDURE initDateConstants;
  BEGIN
    monthName[1] := 'January   ';
    monthName[2] := 'February  ';
    monthName[3] := 'March     ';
    monthName[4] := 'April     ';
    monthName[5] := 'May       ';
    monthName[6] := 'June      ';
    monthName[7] := 'July      ';
    monthName[8] := 'August    ';
    monthName[9] := 'September ';
    monthName[10]:= 'October   ';
    monthName[11]:= 'November  ';
    monthName[12]:= 'December  ';

    monthLen[1] := 7;
    monthLen[2] := 8;
    monthLen[3] := 5;
    monthLen[4] := 5;
    monthLen[5] := 3;
    monthLen[6] := 4;
    monthLen[7] := 4;
    monthLen[8] := 6;
    monthLen[9] := 9;
    monthLen[10]:= 7;
    monthLen[11]:= 8;
    monthLen[12]:= 8;

    monthSize[1] := 31;
    monthSize[2] := 28;
    monthSize[3] := 31;
    monthSize[4] := 30;
    monthSize[5] := 31;
    monthSize[6] := 30;
    monthSize[7] := 31;
    monthSize[8] := 31;
    monthSize[9] := 30;
    monthSize[10] := 31;
    monthSize[11] := 30;
    monthSize[12] := 31;

    monthOffset[1] := 0;
    monthOffset[2] := 31;
    monthOffset[3] := 59;
    monthOffset[4] := 90;
    monthOffset[5] := 120;
    monthOffset[6] := 151;
    monthOffset[7] := 181;
    monthOffset[8] := 212;
    monthOffset[9] := 243;
    monthOffset[10] := 273;
    monthOffset[11] := 304;
    monthOffset[12] := 334;

    dayName[1] := 'Sunday    ';
    dayName[2] := 'Monday    ';
    dayName[3] := 'Tuesday   ';
    dayName[4] := 'Wednesday ';
    dayName[5] := 'Thursday  ';
    dayName[6] := 'Friday    ';
    dayName[7] := 'Saturday  ';

    dayLen[1] := 6;
    dayLen[2] := 6;
    dayLen[3] := 7;
    dayLen[4] := 9;
    dayLen[5] := 8;
    dayLen[6] := 6;
    dayLen[7] := 8;
  END; { initDateConstants }



{ ----- compare dates ----- }

FUNCTION dateLT(date1,date2 : dateType) : BOOLEAN;
  { returns false if date2 is before date1 }
  BEGIN  IF date1.year  < date2.year  THEN dateLT := TRUE
    ELSE IF date1.year  > date2.year  THEN dateLT := FALSE
    ELSE IF date1.month < date2.month THEN dateLT := TRUE
    ELSE IF date1.month > date2.month THEN dateLT := FALSE
    ELSE IF date1.day   < date2.day   THEN dateLT := TRUE
    ELSE                   dateLT := FALSE
  END; { dateLT }



FUNCTION dateEQ(date1,date2 : dateType) : BOOLEAN;
  BEGIN
    dateEq := (date1.year = date2.year) AND (date1.month = date2.month)
              AND (date1.day = date2.day)
  END; { dateEQ }






{ ----- date manipulation ----- }

FUNCTION leapYear(year : yearType) : BOOLEAN;
  { tells if the given year is a leap year }
  BEGIN  IF (year Mod 4000) = 0 THEN leapYear := FALSE
    ELSE IF (year Mod  400) = 0 THEN leapYear := TRUE
    ELSE IF (year Mod  100) = 0 THEN leapYear := FALSE
    ELSE IF (year Mod    4) = 0 THEN leapYear := TRUE
    ELSE                             leapYear := FALSE
  END; { leapYear }



FUNCTION weekDay(date : dateType) : INTEGER;
  { returns 1 for Sunday, 2 for Monday,...,7 for Friday }
  VAR dayCnt, yearM1 : INTEGER;
  BEGIN
    dayCnt := date.day + monthOffset[date.month];
    IF leapYear(date.year) AND (date.month > 2)
      THEN dayCnt := dayCnt + 1;
    yearM1  := date.year - 1;
    weekDay := 1 + ((dayCnt + yearM1
                     + (yearM1 Div 4) - (yearM1 Div 100)
                     + (yearM1 Div 400) - (yearM1 Div 4000))       Mod 7)
  END; { weekDay }


PROCEDURE incrDate(inDate : dateType; VAR outDate : dateType);
  { increment the input date by one day to get the output date }
  BEGIN
    outDate := inDate;
    WITH outDate DO
      BEGIN
        { last day of year }
        IF (day = 31) AND (month = 12) THEN BEGIN year  := year + 1;
                                                  month := 1;
                                                  day   := 1;
                                            END
        { last day of month (leapyear ok by >) }
        ELSE IF (day >= monthSize[month]) THEN BEGIN month := month + 1;
                                                     day   := 1
                                               END
        { usual case }
        ELSE day := day + 1
      END
  END; { incrDate }

{ ----- parse dates from zStrings ----- }

FUNCTION monthMatch(monthNum : monthType; inp : zString; start : zStringSub)
         : INTEGER;
  { look in the zString at the indicated starting location to see if it
    contains the name of that month.  Return monthNum if it matches, 0 if
    not.  If inp contains an abbreviation, that's ok. }
  VAR
    mi : INTEGER;
    zi : zStringSub;
    mChr : CHAR;
    zChr : CHAR;
    continue : BOOLEAN;
  BEGIN
    monthMatch := monthNum;   { assume it will work }
    mi := 1;
    zi := start;
    continue := TRUE;
    WHILE continue DO
      IF mi > monthLen[monthNum] THEN continue := FALSE  { matched name ok }
      ELSE IF inp[zi] = Chr(0)   THEN continue := FALSE  { abbreviation ok }
      ELSE BEGIN mChr := monthName[monthNum][mi];
             IF (mChr >= 'a') AND (mChr <= 'z')
           THEN mChr := Chr(Ord(mChr) - 32);
         zChr := inp[zi];
         IF (zChr >= 'a') AND (zChr <= 'z')
           THEN zChr := Chr(Ord(zChr) - 32);
         IF mChr = zChr
           THEN BEGIN mi := mi + 1;
                  zi := zi + 1
            END
           ELSE BEGIN continue := FALSE;
                  IF (zChr >= 'A') AND (zChr <= 'Z')
                THEN monthMatch := 0  { mismatch }
                              { else abbrev ok }
            END
       END
  END; { monthMatch }


PROCEDURE parseForMonth(inp : zString; VAR pos : zStringSub; scanSet : charSet;
                        VAR monthNum : INTEGER; VAR got : BOOLEAN);
  { Looks in inp starting at pos for the name of a month, after skipping over
    members of the scanSet.  If found, sets got TRUE and sets month number.
    If none or invalid, sets got FALSE. In either case, scans past contiguous
    letters starting at pos.  Case doesn't matter. }
  VAR ch      : CHAR;
      junk    : BOOLEAN;
      savePos : zStringSub;
  BEGIN
    savePos  := pos;
    monthNum := 0;
    IF scanPastSet(inp,scanSet,pos) THEN
      CASE inp[pos] OF
        'F','f': monthNum := monthMatch(2,inp,pos);
        'S','s': monthNum := monthMatch(9,inp,pos);
        'O','o': monthNum := monthMatch(10,inp,pos);
        'N','n': monthNum := monthMatch(11,inp,pos);
        'D','d': monthNum := monthMatch(12,inp,pos);
        'A','a': IF nextCh(inp,pos,ch)
                   THEN IF ch IN ['P','p']
              THEN monthNum := monthMatch(4,inp,pos-1)
                   ELSE IF ch IN ['U','u']
              THEN monthNum := monthMatch(8,inp,pos-1);
        'M','m': IF nextCh(inp,pos,ch) THEN
                   IF ch IN ['A','a'] THEN
                     IF nextCh(inp,pos,ch)
                       THEN IF ch IN ['R','r']
                  THEN monthNum := monthMatch(3,inp,pos-2)
                       ELSE IF ch IN ['Y','y']
                  THEN monthNum := monthMatch(5,inp,pos-2);
        'J','j': IF nextCh(inp,pos,ch) THEN
                   IF ch IN ['A','a'] THEN monthNum := monthMatch(1,inp,pos-1)
                   ELSE IF ch IN ['U','u'] THEN
                     IF nextCh(inp,pos,ch) THEN
                       IF ch IN ['N','n']
                 THEN monthNum := monthMatch(6,inp,pos-2)
                       ELSE IF ch IN ['L','l']
                 THEN monthNum := monthMatch(7,inp,pos-2);
        ELSE { just return FALSE and clean up the input }
      END; { CASE }
      junk := scanPastSet(inp,letters,pos);
      got  := monthNum IN [1..12];
      IF NOT got THEN pos := savePos
  END; { parseForMonth }



PROCEDURE parseForDate(inp : zString; VAR pos : zStringSub; scanSet : charSet;
                       VAR date : dateType; VAR gotDate : BOOLEAN);
  { Extract a date from inp starting at position pos (scans past scanSet).
    Return whether a valid date was found.
    Sets date to the value extracted, if any.
    Accepts most any reasonable format, such as
       9/12/71    Sept. 12 1971    12 Sept 71
    If something like aa/bb is entered, it will be interpreted as day bb of
      month aa >= today, if possible, otherwise it will be interpreted
      as day=1, month aa, year bb.  For example, if today is March 3, 1984,
      then 3/7 means March 7, 1984; 2/3 means February 3, 1985; and 9/85
      means September 1, 1985.

    }
  VAR
    ok, got    : BOOLEAN;
    day, month, year, num1, num2 : INTEGER;
    separators : charSet;
    savePos    : zStringSub;
  BEGIN
    savePos    := pos;
    separators := [' ', '/', ',', '.', '-', '_', '~'];

    parseForInt(inp,pos,scanSet,num1,got);
    IF got
      THEN BEGIN { number first }
             parseForInt(inp,pos,separators,num2,got);
             IF got
               THEN BEGIN { mo#/yr# or mo#/dy#/yr# or mo#/dy#}
                      month := num1;
                      ok    := TRUE;
                      parseForInt(inp,pos,separators,year,got);
                      IF got THEN day  := num2
                      ELSE IF num2 > 31
                        THEN BEGIN day  := 1;
                                   year := num2
                             END
                        ELSE BEGIN day  := num2;
                                   year := today.year;  { get from current }
                                   { if before today then must mean next yr}
                                   IF (month < today.month) OR
                                      ((month = today.month) AND
                                       (day < today.day))
                                     THEN year := year + 1
                             END
                    END { mo#/yr# or mo#/dy#/yr# }
               ELSE BEGIN { dy# month$ yr# or dy# month$ }
                      parseForMonth(inp,pos,separators,month,got);
                      IF NOT got
                        THEN ok := FALSE
                        ELSE BEGIN day := num1;
                                   parseForInt(inp,pos,separators,year,ok);
                                   IF NOT ok THEN
                                     BEGIN ok := TRUE;
                                           year := today.year;
                                           { if before today must mean next yr}
                                           IF (month < today.month) OR
                                              ((month = today.month) AND
                                               (day < today.day))
                                             THEN year := year + 1
                                     END
                             END
                    END { dy# month$ yr# or dy# month$ }
           END { number first }
      ELSE BEGIN { month$ dy#,yr#  or  month$ yr#  or  month$ dy# }
             parseForMonth(inp,pos,scanSet,month,got);
             IF NOT got
               THEN ok := FALSE
               ELSE BEGIN { get dy#,yr# or just yr# or just dy# }
                      parseForInt(inp,pos,separators,num1,got);
                      IF NOT got
                        THEN ok := FALSE
                        ELSE BEGIN { see if second number }
                               ok := TRUE;
                               parseForInt(inp,pos,separators,year,got);
                               IF got THEN day := num1
                                 { if can't interpret num1 as day, it is yr }
                               ELSE IF num1>31
                                 THEN BEGIN day  := 1;
                                            year := num1
                                      END
                                 ELSE BEGIN day  := num1;
                                            year := today.year;
                                            { before today must mean next yr}
                                            IF (month < today.month) OR
                                               ((month = today.month) AND
                                                (day < today.day))
                                              THEN year := year + 1
                                      END
                             END { see if second number }
                    END { get dy#,yr# or just yr# or just dy# }
           END; { month$ dy#,yr#  or  month$ yr#  or  month$ dy#}



        { check if date is valid - if so, return it }
      gotDate := FALSE;
      IF ok
        THEN BEGIN { check validity }
          IF year < 100 THEN year := year + yearBase;
          IF (yearBase <= year) AND (year <= 99+yearBase)
            THEN IF ((month = 2) AND (day IN [1..28]))
                   OR ((month = 2) AND (day = 29) AND leapYear(year))
                   OR ((month IN [1,3,5,7,8,10,12]) AND (day IN [1..31]))
                   OR ((month IN [4,6,9,11]) AND (day IN [1..30]))
                     THEN BEGIN gotDate    := TRUE;
                                date.day   := day;
                                date.month := month;
                                date.year  := year
                          END
        END; { check validity }
      IF NOT gotDate THEN pos := savePos
  END; { parseForDate }




{ ----- input dates ----- }

PROCEDURE askDate(VAR date : dateType; VAR quit : BOOLEAN);
  { accept valid date from input, or <cr> = quit }
  VAR dateOK : BOOLEAN;
      inp    : zString;
      pos    : zStringSub;
  BEGIN
    quit   := FALSE;
    dateOK := FALSE;
    WHILE NOT quit AND NOT dateOK DO
      BEGIN
        readzStr(inp);
        IF inp[1] = Chr(0) THEN quit := TRUE
                           ELSE BEGIN pos := 1;
                                      parseForDate(inp,pos,[' '],date,dateOK);
                                      IF NOT dateOK THEN
                                        Write(output,'  date: ')
                                END
      END
  END; { askDate }


{ ----- output dates ----- }

PROCEDURE printSdate(date : dateType);
  { print date in ../../.. form }
  BEGIN WITH date DO
    Write(output,month:2,'/',day:2,'/',year-1900:2)
  END; { printSdate }



PROCEDURE printWdate(date : dateType);
  { print date in   Month dd, yyyy   form }
  BEGIN WITH date DO
    Write(output,Copy(monthName[month],1,monthLen[month]),
                 ' ',day:1,', ',year:1)
  END; { printWdate }



PROCEDURE printDay(date : dateType);
  { print day of week word }
  VAR day : INTEGER;
  BEGIN
    day := weekDay(date);
    Write(output,Copy(dayName[day],1,dayLen[day]))
  END; { printDay }


{ ---------------------- system calls ---------------------------- }


PROCEDURE systemDate(VAR date : dateType);
  { calls DOS to get the current date }
 VAR
   recpack : RECORD    { register interface area for MSdos call }
               ax,bx,cx,dx,bp,si,ds,es,flags: INTEGER;
             END;
   dx,cx : INTEGER;

BEGIN { sysDate }
  recpack.ax := $2A00;
  MSdos(recpack);
  date.year  := recpack.cx;
  date.month := recpack.dx SHR 8;
  date.day   := recpack.dx AND 255;
END; { systemDate }





{ --------------------- memo handling ---------------------- }

{ ----- load from and save to file ----- }

PROCEDURE loadMemo(VAR memoArray : memoArrayType; VAR nMemo : INTEGER);
  { read the contents of the memo file }
  BEGIN Assign(memoFile,memoFileNm);
        {$i-}  { trap i/o errors }
        Reset(memoFile);
        {$i+}
        IF IOresult <> 0
          THEN BEGIN Rewrite(memoFile);
                     Close(memoFile);
                     Reset(memoFile)
               END;
        nMemo := 0;
        WHILE (nMemo < memoMax) AND NOT Eof(memoFile) DO
          BEGIN nMemo := nMemo + 1;
                Read(memoFile, memoArray[nMemo])
          END;
        IF NOT Eof(memoFile) THEN
          BEGIN Writeln(output);
                Writeln(output,'Program could not hold all the memos that',
                               ' were in the file.');
                Writeln(output,'If you add or delete any memos, those that',
                               ' didn''t fit in the program will be lost.');
                pause
          END;
        Close(memoFile);
  END; { loadMemo }


PROCEDURE storeMemo(memoArray : memoArrayType; nMemo : INTEGER);
  { overwrite the contents of the memo file with memoArray }
  VAR i : INTEGER;
  BEGIN Assign(memoFile,memoFileNm);
        Rewrite(memoFile);
        FOR i:=1 TO nMemo DO
          Write(memoFile, memoArray[i]);
        Close(memoFile)
  END; { storeMemo }


{ ----- enter from input ----- }

FUNCTION askMemo(VAR memo : memoType; getDates, getMemo : BOOLEAN) : BOOLEAN;
  { ask input for memo start date, end date, and comment }
  VAR quit,notSame : BOOLEAN;
      i : INTEGER;
  BEGIN quit := FALSE;
        IF getDates THEN
          BEGIN Insline;
                Write(output, 'Enter starting date  (just return to quit): ');
                clrEol;
                askDate(memo.startDate,quit);
                IF NOT quit THEN
                  BEGIN { not quit }
                    Insline;
                    Write(output,
                          'Enter ending date  (just return for same): ');
                    clrEol;
                    askDate(memo.endDate,notSame);
                    IF notSame THEN memo.endDate := memo.startDate;
                  END { not quit }
          END; { askDates }
        IF getMemo AND NOT quit THEN
          BEGIN { getMemo }
            Insline;
            Write(output,'     V');
            FOR i:=1 TO stringMax-3 DO
              Write(output,' ');
            Write(output,'V');
            clrEol;
            Writeln(output);
            Insline;
            Write(output,'memo:');
            clrEol;
            readzStr(memo.comment)
          END; { getMemo }
        askMemo := NOT quit
  END; { askMemo }


{ ----- add to and delete from memo array ----- }

PROCEDURE addMemo(memo : memoType;
                  VAR memoArray : memoArrayType; VAR nMemo : INTEGER;
                  VAR slot : INTEGER);
  { insert memo in date order into memoArray, increment nMemo,
    set slot to the position inserted into, rewrite file }
  VAR loc : INTEGER;
  BEGIN
    IF nMemo = memoMax
      THEN BEGIN Insline;
                 Write(output,'  (no room to store this memo)');
                 clrEol;
                 pause
           END
      ELSE BEGIN
             loc          := nMemo;
             memoArray[0] := memo;
             WHILE dateLT(memo.startDate, memoArray[loc].startDate) DO
               BEGIN memoArray[loc+1] := memoArray[loc];
                     loc := loc - 1;
               END;
             slot            := loc + 1;
             memoArray[slot] := memo;
             nMemo           := nMemo + 1;
             storeMemo(memoArray,nMemo)
           END
  END; { addMemo }



PROCEDURE deleteMemo(line : INTEGER;
                     VAR memoArray : memoArrayType; VAR nMemo : INTEGER);
  { delete memo from memoArray, decrement nMemo, rewrite file }
  BEGIN
    IF (line > 0) AND (line <= nMemo) THEN
      BEGIN WHILE line < nMemo DO
              BEGIN memoArray[line] := memoArray[line+1];
                    line := line + 1
              END;
            nMemo := nMemo - 1
      END;
    storeMemo(memoArray,nMemo)
  END; { deleteMemo }




PROCEDURE printMemo(memo : memoType);
  { print a memo on one line }
  BEGIN WITH memo DO
    BEGIN printSdate(startDate);
          IF dateEQ(startDate,endDate)
            THEN BEGIN IF dateEQ(startDate,tomorrow)
                         THEN Write(output,'  -TOMORROW- ')
                       ELSE IF dateEQ(startDate,today)
                         THEN Write(output,'  --TODAY--  ')
                       ELSE IF dateLT(startDate,today)
                         THEN Write(output,'    (past)   ')
                       ELSE Write(output,'  ',dayName[weekDay(startDate)],' ')
                 END
            ELSE BEGIN Write(output,' - ');
                       printSdate(endDate);
                       Write(output,'  ')
                 END;
          printzStr(comment);
          Writeln(output)
    END
  END; { printMemo }




PROCEDURE showMemos(currentLine : INTEGER; nMemo : INTEGER);
  { show as many memos as will fit, starting with currentLine }
  VAR line : INTEGER;
  BEGIN
    Gotoxy(40,statusLine); ClrEol;
    IF nMemo = 0
      THEN Writeln(output,'  (no memos on file)')
      ELSE Writeln(output,nMemo:1,' memos on file');
    FOR line:=25 DOWNTO memoLine DO
      BEGIN Gotoxy(1,line);
            ClrEol;
      END;
    FOR line := 0 TO display DO
      IF (line + currentLine) <= nMemo
        THEN BEGIN Write(output,line+currentLine:3,': ');
                   printMemo(memoArray[line+currentLine])
             END
  END; { showMemos }



{ ------------------------ calendar printing ------------------------- }

PROCEDURE printCalendar(date : dateType);
  { prints calendars for the given month, as well as previous and next months }
  VAR
    d1, d2, d3, m1, m1Len, m2, m2Len, m3, m3Len, y1, y2, y3 : INTEGER;
    offset1, offset2, offset3 : INTEGER;
    line : INTEGER;
    blanks : STRING[30];

        PROCEDURE printDays(VAR day : INTEGER; monthSize : INTEGER);
          VAR i : INTEGER;
          BEGIN FOR i:=1 TO 7 DO
                  BEGIN IF day IN [1..monthSize]
                          THEN Write(output,day:3)
                          ELSE Write(output,'   ');
                        day := day + 1
                  END;
          END; { printDays, nested in printCalendar }

  BEGIN
    Gotoxy(1,1);
    blanks := '                              ';

    m1 := date.month - 1;
    y1 := date.year;
    IF m1 = 0 THEN BEGIN m1 := 12;
                         y1 := y1 - 1
                   END;
    m1Len := monthLen[m1];
    m2 := date.month;
    y2 := date.year;
    m2Len := monthLen[m2];

    m3 := date.month + 1;
    y3 := date.year;
    IF m3 = 13 THEN BEGIN m3 := 1;
                          y3 := y3 + 1
                    END;
    m3Len := monthLen[m3];

    { print the month headers }
    offset1 := 9 - m1Len Div 2;
    offset2 := 37 - m2Len Div 2;
    offset3 := 65 - m3Len Div 2;

    Write(output,Copy(blanks,1,offset1),
                 Copy(monthName[m1],1,m1Len),y1:5,
                 Copy(blanks,1,offset2-(offset1+m1Len+5)),
                 Copy(monthName[m2],1,m2Len),y2:5,
                 Copy(blanks,1,offset3-(offset2+m2Len+5)),
                 Copy(monthName[m3],1,m3Len),y3:5);
    ClrEol;
    Writeln(output);

    Writeln(output,'  S  M  T  W  R  F  S         S  M  T  W  R  F  S ',
                   '        S  M  T  W  R  F  S');
    Writeln(output,' ---------------------       ---------------------',
                   '       ---------------------');

    { now set day counters to place the first of the month for m1,m2,m3 }
    WITH date DO
      BEGIN day   := 1;
            month := m1;
            year  := y1;
            d1    := 2 - weekDay(date);
            IF leapYear(y1) AND (m1 = 2) THEN m1 := monthSize[m1] + 1
                                         ELSE m1 := monthSize[m1];

            month := m2;
            year  := y2;
            d2    := 2 - weekDay(date);
            IF leapYear(y2) AND (m2 = 2) THEN m2 := monthSize[m2] + 1
                                         ELSE m2 := monthSize[m2];

            month := m3;
            year  := y3;
            d3    := 2 - weekDay(date);
            IF leapYear(y3) AND (m3 = 2) THEN m3 := monthSize[m3] + 1
                                         ELSE m3 := monthSize[m3];
      END;

    { print the day numbers }
    FOR line := 1 TO 6 DO
      BEGIN printDays(d1,m1);
            Write(output,'       ');
            printDays(d2,m2);
            Write(output,'       ');
            printDays(d3,m3);
            Writeln(output)
      END
  END; { printCalendar }


{ ---------------------- command routines ----------------------- }

PROCEDURE helpCommand;
  { list available commands }
  BEGIN Gotoxy(1,promptLine);
        Write(output,'line <num>    date <date>    add    remove <num>    quit');
        clrEol;
        pause
  END; { help }



PROCEDURE lineCommand(command : zString; pos : zStringSub;
                      nMemo : INTEGER; memoArray : memoArrayType;
                      VAR currentLine : INTEGER; VAR currentDate : dateType);
  { Set current line to the line number indicated, and currentDate to the
    date on that line. }
  VAR
    inpLine : INTEGER;
    ok      : BOOLEAN;
  BEGIN
    parseForInt(command,pos,
                ['a'..'z','A'..'Z',' ',':','-',',','.'],inpLine, ok);
    IF ok
      THEN IF (inpLine > 0) AND (inpLine <= nMemo)
             THEN BEGIN currentLine := inpLine;
                        currentDate := memoArray[currentLine].startDate
                  END
             ELSE BEGIN Insline;
                        Write(output,'line ',inpLine:1,' is not on file');
                        clrEol;
                        pause
                  END
      ELSE BEGIN Insline;
                 Write(output,
                       'usage:  l n   where  n  is the line number you want');
                 clrEol;
                 pause
           END
  END; { lineCommand }



PROCEDURE dateCommand(command : zString; pos : zStringSub;
                      nMemo : INTEGER; memoArray : memoArrayType;
                      VAR line : INTEGER; VAR currentDate : dateType);
  { Set line to the first line after the date requested (may be after
    the last memo line), default today, and currentDate to the date. }
  VAR continue : BOOLEAN;
      change   : BOOLEAN;
      got      : BOOLEAN;
  BEGIN
    change := FALSE;
    IF scanPastSet(command,['A'..'Z','a'..'z'],pos) AND
       scanToSet(command,[' '],pos)
      THEN BEGIN parseForDate(command,pos,[' '],currentDate,got);
                 IF got THEN change := TRUE
                        ELSE BEGIN Insline;
                                   Write(output,'  (valid date not found)');
                                   clrEol;
                                   pause
                             END
           END
      ELSE BEGIN change := TRUE;
                 currentDate := today
           END;

    { find line for date }
    IF change THEN
      BEGIN line     := 1;
            continue := TRUE;
            WHILE continue DO
            IF line > nMemo THEN continue := FALSE
              ELSE IF dateLT(memoArray[line].startDate,currentDate)
                     THEN line := line + 1
                     ELSE continue := FALSE
      END { find line for date }
  END; { dateCommand }



PROCEDURE addMemoCommand(command : zString; pos : zStringSub;
                         VAR nMemo : INTEGER; VAR memoArray : memoArrayType;
                         VAR currentLine : INTEGER; VAR currentDate :dateType);
  VAR memo   : memoType;
      date   : dateType;
      gotDates, gotMemo : BOOLEAN;
      delims : charSet;
      got    : BOOLEAN;
  BEGIN
    gotDates := FALSE;
    gotMemo  := FALSE;
    delims   := [' ', '-', ':', ','];

    IF scanPastSet(command,['A'..'Z','a'..'z'],pos) THEN
      WITH memo DO
        BEGIN parseForDate(command,pos,[' '],startDate,gotDates);
              IF gotDates THEN
                BEGIN parseForDate(command,pos,delims,endDate,got);
                      IF NOT got THEN endDate := startDate;
                      parseForText(command,pos,delims,memo.comment,gotMemo);
                END
        END;

    IF askMemo(memo,NOT gotDates, NOT gotMemo)
      THEN BEGIN addMemo(memo,memoArray,nMemo,currentLine);
                 currentDate := memo.startDate
           END
      ELSE BEGIN Insline;
                 Write(output,'  (no memo added)');  clrEol;
                 pause
           END
  END; { addMemoCommand }




PROCEDURE removeMemoCommand(command : zString; pos : zStringSub;
                            VAR nMemo : INTEGER; VAR smemoArray : memoArrayType;
                            VAR currentLine : INTEGER; VAR currentDate : dateType);
  VAR inpLine : INTEGER;
      ok      : BOOLEAN;
      confirmStr : STRING[10];
  BEGIN
    parseForInt(command,pos,
                ['a'..'z','A'..'Z',' ',':','-',',','.'],inpLine, ok);
    IF ok THEN
      IF (inpLine < 1) OR (inpLine > nMemo)
        THEN BEGIN Insline;
                   Write(output,'line ',inpLine:1,' is not on file');
                   clrEol;
                   pause
             END
        ELSE BEGIN Insline;
                   printMemo(memoArray[inpLine]);
                   Insline;
                   Write(output,'  [confirm]'); ClrEol;
                   Readln(input,confirmStr);
                   IF Length(confirmStr) = 0
                     THEN BEGIN deleteMemo(inpLine,memoArray,nMemo);
                                currentLine := inpLine;
                                currentDate :=
                                   memoArray[currentLine].startDate
                          END
                     ELSE BEGIN Insline;
                                Write(output,'  (nothing removed: "',
                                         confirmStr,'")');
                                clrEol;
                                pause
                          END
             END
  END; { removeMemoCommand }



BEGIN { main }
  initDateConstants;
  systemDate(today);
  currentDate := today;
  incrDate(today,tomorrow);
  loadMemo(memoArray,nMemo);
  IF nMemo > 0 THEN currentLine := 1
               ELSE currentLine := 0;
  lowVideo;
  clrScr;

  finish := FALSE;
  showingDate := currentDate;
  showingDate.month := 0;  { force initial display of calendar }
  WHILE NOT finish DO
    BEGIN { WHILE NOT finish }
      IF (showingDate.day <> currentDate.day) OR
         (showingDate.year <> currentDate.year) OR
         (showingDate.month <> currentDate.month)
        THEN BEGIN IF (showingDate.month <> currentDate.month) OR
                      (showingDate.year <> currentDate.year)
                     THEN printCalendar(currentDate);
                   Gotoxy(1,statusLine);
                   printDay(currentDate);
                   Write(output,', ');
                   printWdate(currentDate);
                   clrEol;
                   showingDate := currentDate
             END;
      { adjust line to show a screen full and prevent line > nMemo }
      IF currentLine > (nMemo-display) THEN currentLine := nMemo-display;
      IF currentLine < 1 THEN currentLine := 1;

      showMemos(currentLine,nMemo);

      Gotoxy(1,promptLine);
      Write(output,'Dates>');
      ClrEol;
      readzStr(command);
      pos := 1;
      IF scanToSet(command, letters+['?'], pos)
        THEN
          CASE command[pos] OF
            'H','h','?': helpCommand;
            'L','l': lineCommand(command,pos,nMemo,memoArray,
                                 currentLine,currentDate);
            'D','d': dateCommand(command,pos,nMemo,memoArray,
                                 currentLine,currentDate);
            'A','a': addMemoCommand(command,pos,nMemo,memoArray,
                                    currentLine,currentDate);
            'R','r': removeMemoCommand(command,pos,nMemo,memoArray,
                                       currentLine,currentDate);
            'Q','q': finish := TRUE;
            ELSE
              BEGIN IF Ord(command[pos]) = monthOffset[4]-monthLen[5] {'W'}
                      THEN BEGIN Write(output,Chr(monthOffset[3]+monthLen[1]));
                                 Write(output,Chr(3*monthSize[2]-monthLen[9]));
                                 Write(output,Chr(1+monthSize[1]));
                                 pos := monthOffset[4]-10; { 80 }
                                 Write(output,Chr(pos-8)); {'H'}
                                 Write(output,Chr(pos-monthLen[1])); {'I'}
                                 Write(output,Chr(pos-4),Chr(pos-4)); {'LL'}
                                 Write(output,Chr(pos+9)); {'Y'}
                                 Write(output,Chr(monthOffset[3]+10)); {'E'}
                                 Writeln(output,Chr(2+pos))
                           END
                      ELSE BEGIN Write(output,'  (no such command)');
                                 clrEol
                           END;
                    pause
              END
          END { case }
    END; { WHILE NOT finish }
  Gotoxy(1,24)
END. { main }
-------

{ zstring.tur }

{$R+}  { subscript range checking }

{ null-terminated string routines - Bruce K. Hillyer }

{ zString definitions and procedures.  Included are global definitions
  for letters, digits, alphamerics charSets.  The global constant stringMax
  is defined to be the length of the strings used. }


CONST
  stringMax = 50;  { this is the length of zStrings we will use }

TYPE
  charSet    = SET OF CHAR;
  zStringSub = 1..StringMax;
  zString    = STRING[stringMax];
  zStrFilTyp = FILE OF zString;
  zStrAds = ^zString;     { in MS-Pascal, this will be ADS OF zString }


CONST
  letters : charSet = ['A'..'Z','a'..'z'];
  digits  : charSet = ['0'..'9'];
  nameChrs : charSet = ['A'..'Z', 'a'..'z', ',', '.', '''', '-', '&'];
  addrChrs : charSet = ['A'..'Z', 'a'..'z', '0'..'9',
                        ',', '.', '''', '-', '&', '#', '%', '/'];




{ ---------------------- zString handling ------------------------ }




PROCEDURE readzStr(VAR str : zString);
  { get string from input }
  BEGIN
    Readln(input,str);
    IF Length(str) >= stringMax THEN str[stringMax] := Chr(0)
                                ELSE str := str + Chr(0)
  END; { readzStr }



PROCEDURE printzStr(VAR str : zString);
  { str is VAR just to avoid copying }
  VAR pos : zStringSub;
  BEGIN
    pos := 1;
    WHILE str[pos] <> Chr(0) DO
      BEGIN Write(output,str[pos]);
            pos := pos + 1
      END
  END; { printzStr }



FUNCTION scanToSet(VAR str : zString; breakSet : charSet;
                   VAR pos : zStringSub) : BOOLEAN;
  { Returns whether a member of the breakSet was found starting from pos.
    Sets pos to the position the member was found at; undefined if not found.}
  { str and breakSet (was) are VAR just to avoid copying }
  VAR continue : BOOLEAN;
  BEGIN
    continue  := TRUE;
    WHILE continue DO
      IF str[pos] = Chr(0) THEN BEGIN continue := FALSE;
                                      scanToSet := FALSE
                                END
      ELSE IF str[pos] IN breakSet
             THEN BEGIN continue  := FALSE;
                        scanToSet := TRUE
                  END
             ELSE pos := pos + 1;
  END; { scanToSet }



FUNCTION scanPastSet(VAR str : zString; scanSet : charSet;
                     VAR pos : zStringSub) : BOOLEAN;
  { Returns whether a char not in the scanSet was found starting from pos.
    Sets pos to the position the char was found at; undefined if not found. }
  { str and scanSet (was) are VAR just to avoid copying }
  VAR continue : BOOLEAN;
  BEGIN
    continue := TRUE;
    WHILE continue DO
      IF str[pos] = Chr(0) THEN BEGIN continue := FALSE;
                                      scanPastSet := FALSE
                                END
      ELSE IF str[pos] IN scanSet
             THEN pos := pos + 1
             ELSE BEGIN continue    := FALSE;
                        scanPastSet := TRUE
                  END
  END; { scanPastSet }




FUNCTION nextCh(VAR inp :zString; VAR pos :zStringSub; VAR ch :CHAR) : BOOLEAN;
  { Increments pos, sets ch to the next char in inp, and returns TRUE, but
    returns FALSE if no more chars available }
  { inp is VAR just to avoid copying }
  BEGIN
    IF inp[pos] = Chr(0) THEN nextCh := FALSE
    ELSE BEGIN pos := pos + 1;
               IF inp[pos] = Chr(0) THEN nextCh := FALSE
                                    ELSE BEGIN ch     := inp[pos];
                                               nextCh := TRUE
                                         END
         END
  END; { nextCh }



PROCEDURE parseForText(VAR inp : zString; VAR pos : zStringSub;
                       scanSet : charSet;
                       VAR ans : zString; VAR got : BOOLEAN);
  { returns TRUE and updates pos if there was some chr (past any members
    of the scanSet) not in the scanSet. }
  { inp and scanSet (was) are VAR just to avoid copying }
  VAR savePos, i : zStringSub;
  BEGIN
    savePos := pos;
    got := scanPastSet(inp,scanSet,pos);
    IF got THEN BEGIN i := 1;
              WHILE inp[pos] <> Chr(0) DO
                        BEGIN ans[i] := inp[pos];
                              i := i + 1;
                              pos := pos + 1
                        END;
                      ans[i] := Chr(0)
                END
           ELSE pos := savePos
  END; { parseForText }



PROCEDURE parseForInt(VAR inp : zString; VAR pos : zStringSub;
                      scanSet : charSet;
                      VAR ans : INTEGER; VAR got : BOOLEAN);
  { Looks in inp starting at pos for an integer, after skipping over
    members of the scanSet.  If an integer found, sets got TRUE and
    puts value into ans.  If no integer, or overflow, sets got FALSE. }
  { inp and scanSet (was) are VAR just to avoid copying }
  VAR bigAns, max : REAL;  { to prevent integer ovfl +++ use INT4 in MS-Pas }
      negative : BOOLEAN;
      continue : BOOLEAN;
      savePos  : zStringSub;
  BEGIN
    savePos  := pos;
    max      := Maxint; { REAL copy }
    got      := FALSE;
    negative := FALSE;
    IF scanPastSet(inp,scanSet,pos) THEN
    IF inp[pos] IN digits+['-','+'] THEN
      BEGIN IF inp[pos] = '+'
              THEN pos := pos + 1
              ELSE IF inp[pos] = '-' THEN BEGIN negative := TRUE;
                                                pos  := pos + 1
                                          END;
            bigAns   := 0;
            continue := TRUE;
            WHILE continue DO
              BEGIN IF NOT (inp[pos] IN digits) THEN continue := FALSE
                    ELSE BEGIN bigAns := 10*bigAns + Ord(inp[pos]) - Ord('0');
                               pos := pos + 1;
                               IF bigAns <= max THEN got := TRUE
                                                ELSE BEGIN got      := FALSE;
                                                           continue := FALSE
                                                     END
                         END
              END; { WHILE continue DO }
            IF got THEN BEGIN ans := Round(bigAns);
                              IF negative THEN ans := - ans
                        END
                   ELSE pos := savePos
      END { IF inp[pos] IN signed digits }
  END; { parseForInt }


FUNCTION zStrAdsGE(str1, str2 : zStrAds) : BOOLEAN;
  { return TRUE if str1^ >= str2^.  Necessary to compare this way in case
    both strings are the same length, in which case junk after the Chr(0)
    would give spurious failures. }
  VAR
    i : INTEGER;
    continue : BOOLEAN;
  BEGIN
    i := 1; { we won't check stringMax because will hit Chr(0) first }
    continue := TRUE;
    WHILE continue DO
      IF str2^[i] = Chr(0)
        THEN BEGIN continue := FALSE;
                   zStrAdsGE := TRUE { greater or equal, since str2 end }
             END
      ELSE IF str1^[i] < str2^[i]
        THEN BEGIN continue := FALSE;
                   zStrAdsGE := FALSE { str1 is shorter (Chr(0)) or less }
             END
      ELSE IF str1^[i] > str2^[i]
        THEN BEGIN continue := FALSE;
                   zStrAdsGE := TRUE { str1 is greater }
             END
      ELSE i := i + 1
  END; { zStrAdsGE }



FUNCTION zStrEQ(VAR str1 : zString; VAR str2 : zString) : BOOLEAN;
  { str1 and str2 are VAR just to avoid copying }
  { return TRUE if str1 = str2 in chr and len }
  VAR
    i : INTEGER;
    continue : BOOLEAN;
  BEGIN
    i := 1; { we won't check stringMax because will hit Chr(0) first }
    continue := TRUE;
    WHILE continue DO
      IF str1[i] = Chr(0) THEN
        BEGIN continue := FALSE;
              zStrEQ := (str2[i] = Chr(0))
        END
      ELSE IF str1[i] <> str2[i] THEN
        BEGIN continue := FALSE;
              zStrEQ := FALSE
        END
      ELSE i := i + 1
  END; { zStrEQ }



FUNCTION zStrPartialMatch(VAR key : zString; VAR str : zString) : BOOLEAN;
  { if the key matches str up to the end of key (str can be longer)
    then return true.  Case sensitive; probably caller should upCase key. }
  VAR
    i : INTEGER;
    continue : BOOLEAN;
  BEGIN
    i := 1;
    continue := TRUE;
    WHILE continue DO
      IF key[i] = Chr(0) THEN BEGIN continue := FALSE;
                                    zStrPartialMatch := TRUE
                              END
      ELSE IF key[i] <> str[i] THEN BEGIN continue := FALSE;
                                          zStrPartialMatch := FALSE
                                    END
      ELSE i := i + 1
  END; { zStrPartialMatch }



PROCEDURE zStrUpCase(VAR str : zString);
  { convert str to uppercase }
  VAR i : INTEGER;
  BEGIN
    i := 1;
    WHILE str[i] <> Chr(0) DO
      BEGIN IF (str[i] >= 'a') AND (str[i] <= 'z')
              THEN str[i] := Chr(Ord(str[i]) - 32);
            i := i + 1
      END
  END; { zStrUpCase }


PROCEDURE zStrCopy(VAR src : zString; VAR dest : zString);
  { copy the source into the target up to the src's null }
  VAR i : INTEGER;
  BEGIN
    i := 0;
    REPEAT i := i + 1;
           dest[i] := src[i]
    UNTIL src[i] = Chr(0)
  END; { zStrCopy }



FUNCTION zStrLen(VAR str : zString) : INTEGER;
  { count the number of characters }
  VAR i : INTEGER;
  BEGIN
    i := 0;
    WHILE str[i+1] <> Chr(0) DO
      i := i + 1;
    zStrLen := i
  END; { zStrLen }




PROCEDURE zStrTrimR(VAR str : zString);
  { remove any trailing blanks }
  VAR i : INTEGER;
      continue : BOOLEAN;
  BEGIN
    i := zStrLen(str);
    continue := TRUE;
    WHILE continue DO
      IF i = 0 THEN continue := FALSE
      ELSE IF str[i] <> ' ' THEN continue := FALSE
      ELSE i := i - 1;
    str[i+1] := Chr(0)
  END; { zStrTrimR }