Turbo Pascal Calendar Program

[Wintermute]

program calendar (input, output);

(**********************************************)
(**                                          **)
(**  input:  two integers "month"            **)
(**                     1 <="month"<=12      **)
(**                     0 <="year"           **)
(**           Each number is                 **)
(**           seaparated by a space.         **)
(**  output:  a one-page framed calendar for **)
(**           requested month or a yearly    **)
(**           calendar for requested year    **)
(**                                          **)
(**********************************************)

type
  days = (sun,mon,tues,wed,thur,fri,sat,endweek);
var
  dayname : days;
  year, month, firstday, lastdate, date : integer;
  choice : char;

procedure divider(length : integer);
var
  counter : integer;
begin
  write (lst,' ':3);
  write (lst,'|');
  counter := 2;
  while counter < length do
    begin
      write (lst,'-');
      counter := counter + 1;
    end;
  write (lst,'|');
  writeln (lst);
end; (*divider*)

procedure starline (length : integer);
var
  box, counter : integer;
begin
  write (lst,' ':3);
  counter := 2;
  write (lst,'|');
  while counter <= length do
    begin
      counter := counter + 1;
      for box := 1 to 9 do
        begin
          write (lst,'-');
          counter := counter + 1;
        end;
      if counter < length then
        write (lst,'+')
      else
        write (lst,'|');
      counter := counter + 1;
    end;
  writeln (lst);
end; (*starline*)

procedure staredges (length : integer);
begin
  writeln (lst, ' ':3, '|', '|':length-1);
end; (*staredges*)

procedure stardivide (totalsections, lengthofone : integer);
var
  counter : integer;
begin
  write (lst,'|':4);
  counter := 1;
  while counter <= totalsections do
    begin
      write (lst,' ':lengthofone-1, '|');
      counter := counter + 1;
    end;
  writeln (lst);
end; (*stardivide*)

procedure writetitles (month, year : integer);

  procedure monthtitle;
  begin
    write (lst,'|':4);
    case month of
      1 : write (lst,'January':35);
      2 : write (lst,'February':35);
      3 : write (lst,'March':35);
      4 : write (lst,'April':35);
      5 : write (lst,'May':35);
      6 : write (lst,'June':35);
      7 : write (lst,'July':35);
      8 : write (lst,'August':35);
      9 : write (lst,'September':35);
     10 : write (lst,'October':35);
     11 : write (lst,'November':35);
     12 : write (lst,'December':35);
    end;
    writeln (lst, year:6, '|':29);
  end; (*monthtitle*)

  procedure daytitle;
  var
    daymark : days;
  begin
    write (lst,'|':4);
    daymark := sun;
    while daymark <= sat do
      begin
        case daymark of
          sun  : write (lst,'   Sun   ');
          mon  : write (lst,'   Mon   ');
          tues : write (lst,'   Tues  ');
          wed  : write (lst,'   Wed   ');
          thur : write (lst,'   Thur  ');
          fri  : write (lst,'   Fri   ');
          sat  : write (lst,'   Sat   ');
        end;
        write (lst,'|');
        daymark := succ (daymark);
      end;
      writeln (lst);
    end; (*daytitle*)

begin (*writetitles*)
  writeln (lst);
  divider (71);
  staredges (71);
  monthtitle;
  staredges (71);
  divider (71);
  stardivide (7, 10);
  daytitle;
  stardivide (7, 10);
  starline (71);
end; (*writetitles*)

function realint (x : real) : real;
begin
  realint := x - (x - trunc (x));
end;

function dayweek (year : integer;
                  month : integer;
                  day : integer) : integer;

var
  cent, yr : integer;
  temp : integer;

begin
  if year < 100 then
    year := year + 1900;
  month := month - 2;
  if (month < 1)  or (month > 10) then
    begin
      month := month + 12;
      year := year - 1;
    end;
  cent := year div 100;
  yr := year mod 100;
  temp := (trunc (realint (2.6 * month - 0.2)) + day + yr + (yr div 4) +
          (cent div 4) - cent - cent) mod 7;
  if temp < 0 then
    temp := temp + 7;
  dayweek := temp + 1;
end; {dayweek}

function dayone (firstday : integer) : days;
begin
  case firstday of
    1 : dayone := sun;
    2 : dayone := mon;
    3 : dayone := tues;
    4 : dayone := wed;
    5 : dayone := thur;
    6 : dayone := fri;
    7 : dayone := sat;
  end;
end; (*dayone*)

function howmanydays (month : integer;
                      year : integer) : integer;
begin
  case month of
    1,3,5,7,8,10,12 : howmanydays := 31;
    4,6,9,11 : howmanydays := 30;
    2 : begin
          if ((year mod 4) = 0) and ((year mod 100) <> 0) or
          ((year mod 400) = 0) then
            howmanydays := 29
          else
            howmanydays := 28;
        end;
  end;
end; (*howmanydays*)

procedure write1line (var date : integer;
                          dayname : days;
                          lastdate : integer);

  procedure writedates;
  var
    daymark : days;
  begin
    write (lst,' ':3, '|');
    daymark := sun;
    if date = 1 then
      begin
        while daymark < dayname do
          begin
            write (lst,' ':9, '|');
            daymark := succ (daymark);
          end;
        repeat
          write (lst,' ':5, date:3, ' ', '|');
          date := date + 1;
          daymark := succ (daymark);
        until daymark = endweek;
      end
    else
      begin
        repeat
          write (lst,' ':5, date:3, ' ', '|');
          date := date + 1;
          daymark := succ (daymark);
        until (date > lastdate) or (daymark = endweek);
      end;
      while daymark < endweek do
        begin
          write (lst,' ':9, '|');
          daymark := succ (daymark);
        end;
    writeln (lst);
  end; (*writedates*)

begin (*write1line*)
  writedates;
  stardivide (7, 10);
  stardivide (7, 10);
  stardivide (7, 10);
  starline (71);
end; (*write1line*)

begin (*MAIN*)
  write ('Calendar for Month or Year (m/y): ');
  readln (choice);
  if (choice = 'm') or (choice = 'M') then
    begin
      writeln (' Print Month Calendar');
      writeln (' Enter month, year: ');
      read (month, year);
      firstday := dayweek (year, month, 1);
      write (lst,chr (12));
      writeln (lst); writeln (lst);
      if year > 0 then
        if (month >= 1) and (month <= 12) then
          begin
            writetitles (month, year);
            dayname := dayone (firstday);
            lastdate := howmanydays (month, year);
            date := 1;
            while date <= lastdate do
              write1line (date, dayname, lastdate);
          end
        else writeln (' month of year must be between 1 and 12')
      else writeln (' year must be a positive integer');
    end
  else if (choice = 'y') or (choice = 'Y') then
    begin
      writeln (' Print Year Calendar');
      writeln (' Enter year: ');
      read (year);
      if year > 0 then
        begin
          for month := 1 to 12 do
            begin
              write (lst,chr (12));
              firstday := dayweek (year, month, 1);
              writeln (lst); writeln (lst);
              writetitles (month, year);
              dayname := dayone (firstday);
              lastdate := howmanydays (month, year);
              date := 1;
              while date <= lastdate do
                write1line (date, dayname, lastdate);
            end;
        end
      else
        writeln (' year must be a positive integer');
    end
  else
    writeln ('You must enter m or y');
end.