program calendar (input, output, entryfile);

  {**************************************************************}
  {                                                              }
  { Copyright (c) 1988, 1989      Bob Schor                      }
  {                               Eye and Ear Institute          }
  {                               203 Lothrop Street             }
  {                               Pittsburgh, PA   15213         }
  {                                                              }
  { All rights reserved.  May not be copied without this notice. }
  {                                                              }
  {**************************************************************}

  { maintain daily calendar file, REMIND.REM }

  { information stored in reminder files (.REM), in the format
   Date <tab> information }

  { Version 8.12 -- first incarnation, after REMIND, REMEMB v 8.12 }
  { Version 9.1 -- bug fixes, default dates, multiple passes }
  { Version 9.2 -- in-memory sorted linked list maintained }

CONST
  version = 'CALEND    Version 9.2';
  namelength = 10;
  remindname = 'REMIND.REM';
  tempname   = 'REMIND.TMP';
  infosize = 64;    { size of entry information, less date }
  datesize  = 16;   { space reserved for date }
  monthsize = 3;
  tab = 11B;
TYPE
  nametype = PACKED ARRAY [1 .. namelength] OF char;
  infoindextype = 1 .. infosize;
  infolengthtype = 0 .. infosize;
  infotype = PACKED ARRAY [infoindextype] OF char;
  monthindextype = 1 .. monthsize;
  monthnametype = PACKED ARRAY [monthindextype] OF char;
  datetype = RECORD
	       day, month, year : integer
	     END;
  entrylink = ^entrytype;
  entrytype = RECORD
		next : entrylink;
		date : datetype;
		info : infotype
	      END;
  answerset = SET OF char;
VAR
  entryfile : text;
  entrylist : entrylink;
  defaultdate, desireddate : datetype;
  filechanged : boolean;

  PROCEDURE timestamp (VAR day, month, year,
		       hour, minute, second : integer); EXTERNAL;

  FUNCTION uppercase (letter : char) : char;

   BEGIN   { uppercase }
     IF ('a' <= letter) AND (letter <= 'z')
      THEN uppercase := chr(ord(letter) - ord('a') + ord('A'))
      ELSE uppercase := letter
   END;

  FUNCTION legalanswer (possibleanswers : answerset) : char;

  VAR
    answer : char;

    PROCEDURE informoferror;

    VAR
      answer : char;
      commabelongshere : boolean;

     BEGIN   { informoferror }
       write ('Error -- legal answers are ');
       IF ' ' IN possibleanswers
	THEN
	 BEGIN
	   write ('[space]');
	   commabelongshere := true
	 END
	ELSE commabelongshere := false;
       FOR answer := succ(' ') TO 'Z' DO
       IF answer IN possibleanswers
	THEN
	 BEGIN
	   IF commabelongshere
	    THEN write (', ');
	   commabelongshere := true;
	   write (answer:1)
	 END;
       write (' :  ')
     END;

   BEGIN  { legalanswer }
      REPEAT
       IF eoln
	THEN
	 BEGIN
	   readln;
	   answer := ' '
	 END
	ELSE readln (answer);
       answer := uppercase(answer);
       IF NOT (answer IN possibleanswers)
	THEN informoferror
      UNTIL answer IN possibleanswers;
     legalanswer := answer
   END;

  PROCEDURE initialize;

  VAR
    hour, minute, second : integer;

   BEGIN   { initialize }
     writeln;
     writeln (version);
     writeln;
     writeln ('Update calendar file, ', remindname);
     writeln;
     writeln ('When viewing old notices, type <Return> to keep them, ',
	      'K to delete');
     writeln;
     WITH defaultdate DO timestamp (day, month, year, hour, minute, second);
     entrylist := NIL;
     filechanged := false
   END;

  FUNCTION monthis (testmonth : monthnametype) : integer;

    FUNCTION match (matchmonth : monthnametype) : boolean;

      FUNCTION charmatch (index : monthindextype) : boolean;

       BEGIN   { charmatch }
	 charmatch := (uppercase (matchmonth[index]) =
		       uppercase (testmonth[index]))
       END;

     BEGIN   { match }
       match := charmatch (1) AND charmatch (2) AND charmatch(3)
     END;

   BEGIN   { monthis }
     IF match ('Jan')
      THEN monthis := 1
      ELSE
      IF match ('Feb')
       THEN monthis := 2
       ELSE
       IF match ('Mar')
	THEN monthis := 3
	ELSE
	IF match ('Apr')
	 THEN monthis := 4
	 ELSE
	 IF match ('May')
	  THEN monthis := 5
	  ELSE
	  IF match ('Jun')
	   THEN monthis := 6
	   ELSE
	   IF match ('Jul')
	    THEN monthis := 7
	    ELSE
	    IF match ('Aug')
	     THEN monthis := 8
	     ELSE
	     IF match ('Sep')
	      THEN monthis := 9
	      ELSE
	      IF match ('Oct')
	       THEN monthis := 10
	       ELSE
	       IF match ('Nov')
		THEN monthis := 11
		ELSE
		IF match ('Dec')
		 THEN monthis := 12
		 ELSE monthis := 0
   END;

  FUNCTION baddate (date : datetype) : boolean;

    FUNCTION outofbounds (test, low, high : integer) : boolean;

     BEGIN   { outofbounds }
       outofbounds := (test < low) OR (test > high)
     END;

   BEGIN   { baddate }
     WITH date DO
     IF outofbounds (month, 1, 12) OR outofbounds (year, 0, 99)
      THEN baddate := true
      ELSE
      CASE month OF
	9, 4, 6, 11 : baddate := outofbounds (day,
					      1, 30);  { 30 days hath sept }
	2 :
	IF (year MOD 4) = 0
	 THEN baddate := outofbounds (day, 1, 29)
	 ELSE baddate := outofbounds (day, 1, 28);
	1, 3, 5, 7, 8, 10, 12 : baddate := outofbounds (day, 1, 31)
       END
   END;

  PROCEDURE writedate (VAR where : text;
		       date : datetype);

    PROCEDURE writemonth (month : integer);

     BEGIN  { writemonth }
       IF month IN [1 .. 12]
	THEN
	CASE month OF
	  1 : write (where, 'Jan');
	  2 : write (where, 'Feb');
	  3 : write (where, 'Mar');
	  4 : write (where, 'Apr');
	  5 : write (where, 'May');
	  6 : write (where, 'Jun');
	  7 : write (where, 'Jul');
	  8 : write (where, 'Aug');
	  9 : write (where, 'Sep');
	  10 : write (where, 'Oct');
	  11 : write (where, 'Nov');
	  12 : write (where, 'Dec')
	 END
	ELSE write (where, '???')
     END;

    PROCEDURE writeyear (twodigityear : integer);

     BEGIN   { writeyear }
       IF (twodigityear < 10)
	THEN write (where, '0', twodigityear:1)
	ELSE write (where, twodigityear:2)
     END;

   BEGIN   { writedate }
     WITH date DO
      BEGIN
	write (where, day:2, '-');
	writemonth (month);
	write (where, '-');
	writeyear (year MOD 100);
	write (where, chr(tab))
      END
   END;

  FUNCTION lengthof (info : infotype) : infolengthtype;

    FUNCTION lof (length : infolengthtype) : infolengthtype;

     BEGIN   { lof }
       IF length = 0
	THEN lof := length
	ELSE
	IF info[length] <> ' '
	 THEN lof := length
	 ELSE lof := lof (pred(length))
     END;

   BEGIN   { lengthof }
     lengthof := lof (infosize)
   END;

  PROCEDURE buildentrylist;

  VAR
    newentry : entrylink;

    FUNCTION readable (VAR filearg : text;
		       filename : nametype) : boolean;

    VAR
      filelength : integer;

     BEGIN   { readable }
       reset (filearg, filename, '.REM', filelength);
       readable := (filelength <> 0) AND (filelength <> -1)
     END;

    PROCEDURE catchinitialentry (filename : nametype);

    VAR
      trialdays : integer;
      remaininginfo : infotype;
      ofcourse : boolean;

     BEGIN   { catchinitialentry }
       read (entryfile, trialdays);
       IF entryfile^ = '-'
	THEN ofcourse := readable (entryfile, filename)
	ELSE readln (entryfile, remaininginfo);
     END;

    PROCEDURE obtain (VAR date : datetype; VAR info : infotype);

    VAR
      dash : char;
      monthstring : monthnametype;

     BEGIN   { obtain }
       WITH date DO
	BEGIN
	  read (entryfile, day, dash, monthstring, dash, year);
	  month := monthis (monthstring)
	END;
       read (entryfile, dash);       { skip terminator }
       readln (entryfile, info)
     END;

    PROCEDURE writeerror (date : datetype; info : infotype);

     BEGIN   { writeerror }
       writeln (' *** Error in date format, entry in ', remindname, ' ***');
       writedate (output, date);
       writeln (info:lengthof(info));
       writeln (' *** Please correct with editor ***')
     END;

   BEGIN   { buildentrylist }
     IF readable (entryfile, remindname)
      THEN
       BEGIN
	 catchinitialentry (remindname);
	 WHILE NOT eof (entryfile) DO
	  BEGIN
	    new (newentry);
	    WITH newentry^ DO
	     BEGIN
	       next := entrylist;
	       obtain (date, info);
	       IF baddate (date)
		THEN
		 BEGIN
		   writeerror (date, info);
		   dispose (newentry)
		 END
		ELSE entrylist := newentry
	     END
	  END;
	 close (entryfile)
       END
   END;

  FUNCTION legaldateentered (VAR date : datetype) : boolean;

    FUNCTION parsedate (VAR date : datetype) : boolean;

    VAR
      dateentry : infotype;
      length : infolengthtype;
      index : infolengthtype;
      oksofar : boolean;

      FUNCTION numberinentry (valuesofar : integer) : integer;

	FUNCTION numeric (letter : char) : boolean;

	 BEGIN   { numeric }
	   numeric := letter IN ['0' .. '9']
	 END;

       BEGIN   { numberinentry }
	 IF index > length
	  THEN numberinentry := valuesofar
	  ELSE
	  IF numeric (dateentry[index])
	   THEN
	    BEGIN
	      valuesofar := 10*valuesofar + ord(dateentry[index]) - ord('0');
	      index := succ(index);
	      numberinentry := numberinentry (valuesofar)
	    END
	   ELSE numberinentry := valuesofar
       END;

      PROCEDURE parseday (VAR day : integer);

       BEGIN   { parseday }
	 day := numberinentry (0);
	 IF day = 0
	  THEN oksofar := false
	  ELSE
	  IF index > length
	   THEN oksofar := true
	   ELSE oksofar := dateentry[index] = '-'
       END;

      PROCEDURE parsemonth (VAR month : integer);

      VAR
	monthstring : monthnametype;
	mindex : monthindextype;

       BEGIN   { parsemonth }
	 index := succ(index);   { skip dash }
	 IF index > length
	  THEN month := defaultdate.month
	  ELSE
	   BEGIN
	     FOR mindex := 1 TO monthsize DO monthstring[mindex] :=
	     dateentry[pred(mindex+index)];
	     index := index + monthsize;
	     month := monthis (monthstring)
	   END;
	 IF month = 0
	  THEN oksofar := false
	  ELSE
	  IF index > length
	   THEN oksofar := true
	   ELSE oksofar := dateentry[index] = '-'
       END;

      PROCEDURE parseyear (VAR year : integer);

       BEGIN   { parseyear }
	 index := succ(index);   { skip dash }
	 IF index > length
	  THEN year := defaultdate.year MOD 100
	  ELSE
	   BEGIN
	     year := numberinentry (0);
	     IF year = 0
	      THEN oksofar := false
	   END
       END;

     BEGIN   { parsedate }
       readln (dateentry);
       length := lengthof (dateentry);
       IF length = 0
	THEN
	 BEGIN
	   date := defaultdate;
	   parsedate := false
	 END
	ELSE
	WITH date DO
	 BEGIN
	   index := 1;
	   oksofar := true;
	   parseday (day);
	   IF oksofar
	    THEN parsemonth (month);
	   IF oksofar
	    THEN parseyear (year);
	   IF (NOT oksofar) OR baddate (date)
	    THEN
	     BEGIN
	       writeln ('Error in entering date, "', dateentry:length, '"');
	       write ('Please re-enter date, using format dd-mmm-yy -- ');
	       parsedate := parsedate (date)
	     END
	    ELSE parsedate := true
	 END
     END;

   BEGIN   { legaldateentered }
     write ('Enter date for calendar entry (null if done) -- ');
     legaldateentered := parsedate (date);
     defaultdate := date
   END;

  PROCEDURE checkoldentries;

  VAR
    thisentry : entrylink;

    FUNCTION samedate (date1, date2 : datetype) : boolean;

     BEGIN   { samedate }
       samedate := ((date1.day = date2.day) AND
		    (date1.month = date2.month) AND
		    (date1.year = date2.year))
     END;

    FUNCTION checktokeep (entry : entrylink) : entrylink;

      FUNCTION delete (entry : entrylink) : entrylink;

      VAR
	previous : entrylink;

       BEGIN   { delete }
	 WITH entry^ DO
	 IF entry = entrylist
	  THEN
	   BEGIN
	     entrylist := next;
	     dispose (entry);
	     delete := entrylist
	   END
	  ELSE
	   BEGIN
	     previous := entrylist;
	     WHILE previous^.next <> entry DO previous := previous^.next;
	     previous^.next := entry^.next;
	     dispose (entry);
	     delete := previous^.next
	   END;
	 filechanged := true
       END;

     BEGIN   { checktokeep }
       WITH entry^ DO
	BEGIN
	  writedate (output, date);
	  write (info:lengthof(info), ' ':3);
	  CASE legalanswer (['K', ' ']) OF
	    'K' : checktokeep := delete (entry);
	    ' ' : checktokeep := next
	   END
	END
     END;

   BEGIN   { checkoldentries }
     thisentry := entrylist;
     WHILE thisentry <> NIL DO
     WITH thisentry^ DO
      BEGIN
	IF samedate (date, desireddate)
	 THEN thisentry := checktokeep (thisentry)
	 ELSE thisentry := next
      END
   END;

  PROCEDURE addnewentries;

  VAR
    newinfo : infotype;

    PROCEDURE getnewinfo;

     BEGIN   { getnewinfo }
       write (chr(tab), chr(tab));
       readln (newinfo)
     END;

    PROCEDURE enterintolist (newdate : datetype; newinfo : infotype);

    VAR
      newentry : entrylink;

      FUNCTION position (newdate : datetype) : entrylink;

      VAR
	newentry, entry, previous : entrylink;

	FUNCTION earlier (thisdate : datetype; entry : entrylink) : boolean;

	  FUNCTION precedes (date1, date2 : datetype) : boolean;

	   BEGIN   { precedes }
	     IF date1.year < date2.year
	      THEN precedes := true
	      ELSE
	      IF date1.year > date2.year
	       THEN precedes := false
	       ELSE
	       IF date1.month < date2.month
		THEN precedes := true
		ELSE
		IF date1.month > date2.month
		 THEN precedes := false
		 ELSE precedes := date1.day < date2.day
	   END;

	 BEGIN   { earlier }
	   IF entry = NIL
	    THEN earlier := false
	    ELSE earlier := precedes (thisdate, entry^.date)
	 END;

       BEGIN   { position }
	 new (newentry);
	 IF entrylist = NIL
	  THEN
	   BEGIN
	     newentry^.next := NIL;
	     entrylist := newentry
	   END
	  ELSE
	   BEGIN
	     previous := NIL;
	     entry := entrylist;
	     WHILE earlier (newdate, entry) DO
	      BEGIN
		previous := entry;
		entry := entry^.next
	      END;
	     IF previous = NIL
	      THEN entrylist := newentry
	      ELSE previous^.next := newentry;
	     newentry^.next := entry
	   END;
	 position := newentry
       END;

     BEGIN   { enterintolist }
       newentry := position (newdate);
       WITH newentry^ DO
	BEGIN
	  date := newdate;
	  info := newinfo
	END;
       filechanged := true
     END;

   BEGIN   { addnewentries }
     writeln;
     writeln ('Enter new entries for this date, ending with null line');
     writeln;
     getnewinfo;
     WHILE lengthof(newinfo) > 0 DO
      BEGIN
	enterintolist (desireddate, newinfo);
	getnewinfo
      END
   END;

  PROCEDURE updatefile;

    PROCEDURE outputlist (entry : entrylink);

     BEGIN   { outputlist }
       WHILE entry <> NIL DO
       WITH entry^ DO
	BEGIN
	  writedate (entryfile, date);
	  writeln (entryfile, info:lengthof(info));
	  entry := next
	END
     END;

    FUNCTION reversed (entry : entrylink) : entrylink;

    VAR
      zeroth, first, second : entrylink;

     BEGIN   { reversed }
       IF entry = NIL
	THEN reversed := NIL
	ELSE
	 BEGIN
	   zeroth := NIL;
	   first := entry;
	   second := first^.next;
	   WHILE second <> NIL DO
	    BEGIN
	      first^.next := zeroth;
	      zeroth := first;
	      first := second;
	      second := first^.next
	    END;
	   first^.next := zeroth;
	   reversed := first
	 END
     END;

   BEGIN   { update }
     IF filechanged
      THEN
       BEGIN
	 rewrite (entryfile, tempname);
	 entrylist := reversed (entrylist);
	 outputlist (entrylist);
	 rename (entryfile, remindname);
	 close (entryfile)
       END
   END;

 BEGIN   { calendar }
   initialize;
   buildentrylist;
   WHILE legaldateentered (desireddate) DO
    BEGIN
      checkoldentries;
      addnewentries
    END;
   updatefile
 END.