{APPOINTMENT/SCHEDULE CALENDER }
{ BY MANNY JUAN 08/15/83       }

PROGRAM calendar;

TYPE
  month = ARRAY[1..9] OF CHAR;
  weekday = (sun,mon,tue,wed,thu,fri,sat);
  dstr = STRING[256];
  
VAR
  yorn: STRING[1];
  listout,
  more_txt: boolean;
  infile: STRING[16];
  fin: FILE OF char;
  ch: char;
  wstr: STRING[133];
  day,
  di, {index}
  dw, {text width in day cell}
  max_lines, {lines of msgs per day}
  curr_lines, {temp max_lines}
  yymm,yy,mm,
  start_of_week,
  week, {curr week}
  no_of_weeks, {no. of weeks}
  base, {days since year started}
  i,j,
  start_of_month,
  1s: integer; {line length}
  day_in_month: ARRAY[1..12] OF integer;
  
  dashes,blanks: STRING;
  month_name: ARRAY[1..12] OF month;
  leap_year: boolean;
  txt: dstr;
  word: STRING[32];
  schedule: ARRAY[-5..37] OF dstr;
  wk_day: weekday;
  day_of_week: ARRAY [weekday] OF STRING;
  
PROCEDURE init;
BEGIN
  blanks := '                 ';
  blanks := blanks+blanks;
  dashes := '-----------------';
  dashes := dashes+dashes;
  month_name[01] := 'January';
  month_name[02] := 'February';
  month_name[03] := 'March';
  month_name[04] := 'April';
  month_name[05] := 'May';
  month_name[06] := 'June';
  month_name[07] := 'July';
  month_name[08] := 'August';
  month_name[09] := 'September';
  month_name[10] := 'October';
  month_name[11] := 'November';
  month_name[12] := 'December';
  
  days_in_month[01] := 31;
  days_in_month[02] := 28;
  days_in_month[03] := 31;
  days_in_month[04] := 30;
  days_in_month[05] := 31;
  days_in_month[06] := 30;
  days_in_month[07] := 31;
  days_in_month[08] := 31;
  days_in_month[09] := 30;
  days_in_month[10] := 31;
  days_in_month[11] := 30;
  days_in_month[12] := 31;
  
  day_of_week[sun] := 'Sunday';
  day_of_week[mon] := 'Monday';
  day_of_week[tue] := 'Tuesday';
  day_of_week[wed] := 'Wednesday';
  day_of_week[thu] := 'Thursday';
  day_of_week[fri] := 'Friday';
  day_of_week[sat] := 'Saturday';
END;

PROCEDURE error(msg:STRING);

VAR dummy: ARRAY[1..16] OF char;
BEGIN
  writeln;
  writeln;
  writeln('---',msg);
  call(0,dummy,dummy);
END;

PROCEDURE shave(VAR str:STRING;l:integer);

VAR k: integer;
BEGIN
  k := length(str)-l;
  str := copy(str,l+1,k);
END;

PROCEDURE getrec;

PROCEDURE get_text;

PROCEDURE getch;
BEGIN
  read(fin;ch);
  IF (ch=chr(1ah))
    THEN more_txt := false;
  write(ch);
END {getch};

BEGIN {get_text}
  txt := '';
  getch;
  i := 0;
  WHILE (more_txt AND NOT (ch=chr(0dh))) DO
    BEGIN
      IF (ch=chr(09h))
        THEN ch := ' ';
      txt :=txt+ch;
      getch
    END;
  IF (NOT(more_txt))
    THEN
      txt := ' '
    ELSE
      IF (ch = chr(0dh))
        THEN getch;
END;

BEGIN {getrec}
  get_text;
  txt :=txt+' ';
  WHILE (more_txt AND (txt=' ')) DO
    get_text;
    
 {get first word}
  IF (more_txt)
    THEN
      BEGIN
        WHILE (copy(txt,1,1)=' ') DO
          shave(txt,1);
        i :=pos(' ',txt);
        word := copy(txt,1,i-1;
   {word:=upcase(word) ;}
       END
     ELSE
       word := ' ';
END;

PROCEDURE segleft (VAR txt:dstr;tw:integer);

VAR
  outx: dstr;
  wrd,pad,txtseg: STRING[32];
  i,text_left: integer;
  currtw: integer;
  
PROCEDURE getwd;

VAR
  i,j: integer;
Begin
  wrd := ' ';
  IF (txt>'')
    THEN
      BEGIN
        WHILE (copy(txt,1,1)=' ') DO
          shave( txt, 1);
        i := pos(' ',txt);
        IF NOT (i<currtw)
          THEN
            BEGIN
              i := currtw;
              wrd := copy(txt,1,i)+' ';
            END
          ELSE
            wrd := copy(txt,1,i);
        shave(txt,i);
      END;
END;

BEGIN
  txt := txt+' ';
  pad := '                ';
  outx := '';
  txtseg := '';
  text_left := tw+1;
  currtw := tw;
  getwd;
  currtw := tw-2;
  WHILE (wrd>'') DO
    BEGIN
      WHILE ((wrd>'')
            AND (NOT (text_left < length (wrd)))) DO
        BEGIN
          txtseg := txtseg+wrd;
          text_left := text_left-length(wrd);
          getwd;
        END;
      IF (txtseg>' ')
        THEN
          BEGIN
            i := length(txtseg);
            WHILE (copy(txtseg,i,1)=' ')
              DO
              i := i-1;
            txtseg := copy(txtseg,1,i);
          END
          
      txtseg := txtseg+pad;
      txt := copy (txtseg,1,tw);
      
      outx := outx+txtseg;
      txtseg := '  ';
      text_left := tw-1;
    END;
  txt := outx;
END; {segleft}

PROCEDURE get_infile;

VAR
  i,j: integer;
BEGIN
  yymm := 0;
  i := pos(':',infile);
  IF (i=0)
    THEN j := 1
    ELSE j := 3;
  FOR i:=1 TO 4 DO
    BEGIN
      ch := copy(infile,i+j,1);
      yymm := 10*yymm+ord(ch)-ord('0')
    END
  yy := yymm DIV 100;
  mm := yymm - 100*yy;
  IF ((yy<1) OR (yy>99) OR (mm<1) OR (mm>12))
    THEN
      BEGIN
        writeln('Filename must be of format xyymm.ttt');
        writeln('  where x is any letter,');
        writeln('  yymm is a 4-digit number for year and month,');
        writeln('       (like 8402 for February 1984) ');
        writeln('  and ttt is a valid file type.');
        writeln;
        error('Please correct and re-do');
      END;
END:

PROCEDURE get_day;

VAR
  ch: char;
BEGIN
  day := 0;
  ch := copy(txt,1,1);
  WHILE (ch IN ['0'..'9']) DO
    BEGIN
      day := 10*day + ord(ch) - ord('0');
      shave(txt,1);
      ch := copy(txt,1,1);
    END;
  shave(txt,1);
END;

PROCEDURE get_schedules;
BEGIN
  max_lines := 0;
  getrec;
  more_txt := true;
  WHILE (more_txt) DO
    BEGIN
      get_day;
      IF ((day<1) OR (day>days_in_month[mm]))
        THEN
          BEGIN
            write('*** Invalid day, text will ');
            writeln('not be included in calendar');
          END
        ELSE
          BEGIN
            segleft (txt,dw);
            schedule[day] := schedule[day]+txt;
            curr_lines := length(schedule[day]) DIV dw;
            IF (curr_lines>max_lines)
              THEN
                max_lines := curr_lines;
          END;
      getrec;
    END;
    
  IF (max_lines>15)
    THEN max_lines := 15;
    
END;

PROCEDURE underline;

VAR i: integer;
BEGIN
  write('|');
  FOR i:=1 TO 6 DO
    BEGIN
      write(copy(dashes,1,dw));
      write('+');
    END;
  write(copy(dashes,1,dw));
  writeln('|');
END;

PROCEDURE set_up_calendar;
BEGIN
  IF (yy MOD 4 = 0)
    THEN
      BEGIN
        days_in_month[02] := 29;
        leap_year := true
      END
    ELSE
      BEGIN
        days_in_month[02] := 28;
        leap_year := false
      END;
      
  base := 0;
  FOR i:=1 TO mm-1 DO
    base := base+days_in_month[i];
    
  start_of_month := yy + (yy DIV 4) + base + 1;
  IF (leap_year)
    THEN
      start_of_month := start_of_month-1;
      
  start_of_month := start_of_month MOD 7;
  start_of_week := 1-start_of_month;
  
  no_of_weeks := (days_in_month[mm] = start_of_month) DIV 7;
  IF ((days_in_month[mm] + start_of_month) MOD 7 > 0)
    THEN
      no_of_weeks := no_of_weeks+1;
END;

PROCEDURE print_calendar:
BEGIN
  IF (listout)
    THEN
      BEGIN
        system(nocons);
        system(list);
      END;
  writeln;
  writeln(1900+yy,month_name[mm]:10);
  writeln;
  underline;
  write('|');
  FOR wk_day:=sun TO sat DO
    BEGIN
      wstr := day_of_week[wk_day]+blanks;
      wstr := copy(wstr,1,dw);
      write(wstr);
      write('|');
    END;
  writeln;
  
  underline;
  
  FOR week:=1 TO no_of_weeks DO
    BEGIN
      write('|');
      day := start_of_week;
      FOR wk_day:=sun TO sat DO
        BEGIN
          IF ((day<1) OR (day>days_in_month[mm]))
            THEN
              write(copy(blanks,1,dw))
            ELSE
              BEGIN
                write(copy(blanks,1,dw-3));
                write(day:3);
              END;
          write('|');
          day := day+1;
        END;{FOR}
        
      writeln;
      
      FOR j:=1 TO max_lines DO
        BEGIN
          write('|');
          day := start_of_week;
          FOR wk_day:=sun TO sat DO
            BEGIN
               schedule[day] := schedule[day]+copy(blanks,1,dw);
               write(copy(schedule[day],1,dw));
               write('|');
               shave(schedule[day],dw);
               day := day+1;
             END;
           writeln;
         END;
         
       underline;
       start_of_week := start_of_week+7;
     END;
   writeln;
   writeln('Source: ',infile);
   write(chr(0ch));
   IF (listout)
     THEN
       BEGIN
         system(cons);
         system(nolist);
       END;
 END;
 
 BEGIN {calendar}
   init;
   
   write('Enter Input File Name ==> ');
   readln(infile);
   infile := infile+copy(blanks,1,14-length(infile));
   writeln;
   writeln;
   
   write('Output to Printer? (y/n) ==> ');
   readln(yorn);
   writeln;
   IF (upcase(yorn)='Y')
     THEN listout := true
     ELSE listout := false;
     
   REPEAT
     writeln;
     write('Enter width of display line ==> ');
     readln(ls);
   UNTIL ((ls>0) AND (ls<133));
   dw := ls DIV 7 - 1;
   writeln;
   
   get_infile;
   reset(fin,infile,binary,256);
   
   FOR i:=-5 TO 37 DO
     schedule[i] := '';
     
   get_schedules;
   
   set_up_calendar;
   
   print_calendar;
   
   close(fin);
 END.