program CAL87; (* written in TURBO PASCAL Jul '85 & renewed Jan '87
                  by Doug Cox, for the Osborne 1 & VIXEN only *)

(** Adapted for Access/Actrix computers 1-25-87 by Dog Star
Codeworks.  Note for Actrix version:  Doug's program provides a
very nice way to keep a personal appointment calendar.  The only
suggestion I might make is that some steps might be taken in the
direction of providing more space for notes.  Numerous approaches
are possible for anyone willing to undertake such a project. 
Some sort of windowing might be nice, especially if you can pull
this off without calling any machine specific procedures.  For
this version I have eliminated the original's machine dependency
(it wrote directly to video memory instead of the console -- not
possible on the Actrix), and fixed some bugs.  Since the
resultant program can be installed on any CP/M computer, Turbo's
general installation packet is also included in case you want to
run this program on something other than an Actrix.  I also
modified the program to support Perfect Writer's commands for
lateral movement, for those of you who use PW (myself included),
which means that the four main Actrix cursor keys are enabled.

After you've installed it, you may rename the program anything
you like, but the installation program is looking for
AXCAL87.COM, so if you want to install it, it will have to be
called this.  To run in an MS-DOS environment, just use
CAL87IBM.COM and don't bother with installation.  So far as I
know, the program is now pretty much bugless, but I haven't
tested exhaustively.  Any questions or problems, contact me via
snailmail at:

		 Dog Star Codeworks
		 P.O. Box 361011
		 Milpitas, CA  95035-1011
**)
	
type
  Month= 1..12; Days= 1..7; Rows= 1..24;
  TotalRows= 1..32; TotalCols= 1..128;
var
  entry: array [Month, Days, Rows] of String[10];
  mon: Month;
  mo: String[3];
  yrs: String[4];
  note: String[10];
  ch, nextCh: Char;
  year, yr, code: integer;
  p, x, y: integer;
  fileName: String[13];
  fv: Text;
  SaveIt: Boolean;

procedure Lines;
begin
  for y:= 1 to 4 do begin
    for x:= 1 to 76 do begin
	gotoxy(x,y*5); write(#95);
	end;
  end;
  for y:= 1 to 24 do begin
    for x:= 1 to 6 do begin
	gotoxy(x*11,y);
	write(#124);
    end;
  end;
end;

procedure Months;
  label B;
  var spaces, len, lYear, col: integer;
begin
  if (year mod 4 = 0) and (year <> 2000) then lYear:= 1 else lYear:= 0;
  if SaveIt then begin GotoXY(1,1); lowvideo; write (' S '); normvideo; end;
  GotoXY(1,3); writeln ('(RETURN to quit)');
B:GotoXY(1,2); write ('MONTH: '); read (mo);
  for x:= 1 to 3 do mo[x]:= UpCase(mo[x]);
  GotoXY(1,2); write ('          |     ');
  GotoXY(1,3); write ('          |     ');
  if mo = '' then Exit; (* Exit is a Goto End in Turbo 3.0 *)
  if Copy(mo,1,3) = 'JAN' then
    begin mon:= 1; spaces:= 2; len:= 31; end
  else if Copy(mo,1,3) = 'FEB' then
    begin mon:= 2; spaces:= 5; len:= 28+lYear; end
  else if Copy(mo,1,3) = 'MAR' then
    begin mon:= 3; spaces:= 5+lYear; len:= 31; end
  else if Copy(mo,1,3) = 'APR' then
    begin mon:= 4; spaces:= 1+lYear; len:= 30; end
  else if Copy(mo,1,3) = 'MAY' then
    begin mon:= 5; spaces:= 3+lYear; len:= 31; end
  else if Copy(mo,1,3) = 'JUN' then
    begin mon:= 6; spaces:= 6+lYear; len:= 30; end
  else if Copy(mo,1,3) = 'JUL' then
    begin mon:= 7; spaces:= 1+lYear; len:= 31; end
  else if Copy(mo,1,3) = 'AUG' then
    begin mon:= 8; spaces:= 4+lYear; len:= 31; end
  else if Copy(mo,1,3) = 'SEP' then
    begin mon:= 9; spaces:= 0+lYear; len:= 30; end
  else if Copy(mo,1,3) = 'OCT' then
    begin mon:= 10; spaces:= 2+lYear; len:= 31; end
  else if Copy(mo,1,3) = 'NOV' then
    begin mon:= 11; spaces:= 5+lYear; len:= 30; end
  else if Copy(mo,1,3) = 'DEC' then
    begin mon:= 12; spaces:= 0+lYear; len:= 31; end
  else Goto B;
  yr:= year - 1985;
  if year > 2000 then spaces:= spaces - 1;
  spaces:= ((spaces + Trunc(yr div 4)) + yr) mod 7;
  for x:= 1 to 7 do
  begin
    	col := (x+spaces)*11-2;
	if (col < 80) then begin
		GotoXY(col, 1);
		if (spaces+x) <= 7 then write(x);
	end;
    GotoXY((x*11)-2, 6); write(7+x-spaces);
    GotoXY((x*11)-2, 11); write(14+x-spaces);
    GotoXY((x*11)-2, 16); write(21+x-spaces);
  end;
  y:= 28-spaces;
  for x:= 1 to (len-y) do
  begin
    y:= y+1;
    col := x*11-2;
    if (col < 80) then begin GotoXY(col, 21); write (y); end;
  end;
  y:= 35-spaces;
  if y < len then
    for x:= 1 to (len-y) do
    begin
      y := y + 1;
      col := x*11-5;
      if (col < 80) then begin
		GotoXY(col, 21);
		write (y,'/');
		end;
    end;
  for x:= 1 to 7 do
    for y:= 1 to 24 do
      if entry[mon,x,y] <> '' then
        begin GotoXY((x*11)-10, y); write (entry[mon,x,y]); end;
end;

procedure Entries;
  const Len= 10; Blanks= '          ';
begin
  GotoXY(1,1); lowvideo; write (Copy(mo,1,3)); normvideo;
  p:= 0; x:= 1; y:= 2;
  repeat
    GotoXY(((x*11)-10)+p, y); read (Kbd, ch);
    case ch of
      #32..#126: if p < Len then
                 begin
                   if p > Length(entry[mon,x,y]) then
         Insert (Copy(Blanks, 1, p-Length(entry[mon,x,y])), entry[mon,x,y],1);
                  p:= p+1;
                  Delete (entry[mon,x,y], p, 1);
                  Insert (ch, entry[mon,x,y],p);
                  write (Copy(entry[mon,x,y], p, Len));
                end;
      ^D   : if p < Len then p:= p+1
             else if x < 7 then begin x:= x+1; p:= 0; end;
      ^S   : if p > 0 then p:= p-1
             else if x > 1 then begin x:= x-1; p:= 9; end;
      ^E   : if y > 1 then begin y:= y-1; p:= 0; end;
      ^X,^M: begin if y < 24 then y:= y+1; p:= 0; end;
      ^F   : if x < 7 then begin x:= x+1; p:= 0; end;
      ^A,#2: if (p= 0) and (x > 1) then x:= x-1 else p:= 0;
      ^C,#14 : begin if y < 20 then y:= y+5 else y:= 24; p:= 0; end;
      ^R,#16 : begin if y > 5 then y:= y-5 else y:= 1; p:= 0; end;
      ^Y   : begin
               Delete (entry[mon,x,y], 1,Len);
               GotoXY((x*11)-10, y); write (Blanks);
               p:= 0;
             end;
      ^G   : if p < Length(entry[mon,x,y]) then
             begin
               Delete(entry[mon,x,y], p+1, 1);
               write (Copy(entry[mon,x,y], p+1, Len), ' ');
             end;
#127, ^H   : if p > 0 then
             begin
               Delete(entry[mon,x,y], p, 1);
               write
               (^H, Copy(entry[mon,x,y], p, Length(entry[mon,x,y])-p+1),' ');
               p:= p-1;
             end;
      ^Q   : begin
               read (Kbd, nextCh); nextCh:= UpCase(nextCh);
               case nextCh of
                'S',^S: begin x:= 1; p:= 0; end;
                'D',^D: begin x:= 7; p:= 0; end;
                'E',^E: begin y:= 1; p:= 0; end;
                'X',^X: begin y:= 24; p:= 0; end;
               end;
             end;
    end;
  until (ch= ^K) or (ch= ^[);
  if not SaveIt then
  begin
    GotoXY(1,1); lowvideo; write ('Save (Y/N)? '); normvideo;
    read (Kbd, ch);
    if UpCase(ch) <> 'N' then SaveIt:= True;
  end;
end;

procedure Save;
begin
  Assign (fv,fileName); Rewrite (fv);
  for mon:= 1 to 12 do
    for x:= 1 to 7 do
      for y:= 1 to 24 do
        if entry[mon,x,y] <> '' then
        begin
          writeln (fv, mon, ' ',x,' ',y);
          writeln (fv, entry[mon,x,y]);
        end;
  Close (fv);
end;

begin (* MAIN PART *)
  SaveIt:= False;
  for mon:= 1 to 12 do
  for x:= 1 to 7 do
      for y:= 1 to 24 do
        entry[mon,x,y]:= '';
  yrs:= '';
  yrs:= yrs + ParamStr(1); (* Turbo Pascal 3.0 for command line parameter *)
  if Length(yrs) = 2 then yrs:= '19' + yrs;
  if yrs = '' then begin year:= 1987; Str(year, yrs); end
  else Val(yrs, year, code);
  fileName:= 'AXCAL'+Copy(yrs,3,2)+'.DTA';
  Assign (fv, fileName);
  {$I-} Reset (fv) {$I+};
  if IOresult = 0 then
    while not Eof (fv) do
    begin
      readln (fv, mon,x,y); readln (fv, note);
      entry[mon,x,y]:= note;
    end;
  repeat
    ClrScr;
    write
('    SUN        MON        TUE        WED        THU        FRI        SAT');
    Lines;
    Months;
    if mo <> '' then Entries;
  until mo= '';
  ClrScr;
  if SaveIt then
  begin
    {lowvideo;} write (' Saving ',fileName); {normvideo;} Save; ClrScr;
  end;
end.