home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / database / cal32.lbr / CAL.PZS / CAL.PAS
Encoding:
Pascal/Delphi Source File  |  1988-04-25  |  12.8 KB  |  630 lines
  1. program CAL;
  2.  
  3. { Calender version 3.2  }
  4. { for all terminals     }
  5.  
  6. {    by Howard Dutton      }
  7.  
  8. { GENIE ADDRESS: H.DUTTON  }
  9.  
  10. label
  11.   Start,Exit;
  12.  
  13. type
  14.   Str14  = String[14];
  15.   Str80  = String[80];
  16.   Str255 = String[255];
  17.   Messages = record
  18.     Short: String[20];
  19.     Long:  String[200];
  20.   end;
  21.  
  22. var
  23.   Finished,PrintOut,H19:   Boolean;
  24.   M,D,Y:                   Real;
  25.   TS:                      Str255;
  26.   Ch:                      Char;
  27.   L,L1,L2,MS,
  28.   CDay,Count:              Integer;
  29.   Message: array[1..31] of Messages;
  30.   F:                       Text;
  31.  
  32.   FN:                      Str14;
  33.  
  34.   Screen: array[1..24] of  Str80;
  35.  
  36. const
  37.   MonthStr: array[1..12] of string[10] =
  38.   ('January','Febuary','March','April','May','June','July',
  39.    'August','September','October','November','December');
  40.  
  41. procedure Bell;
  42. begin
  43.   Write(#7);
  44. end;
  45.  
  46. procedure GOn;
  47. begin
  48.   if H19 then
  49.     write(#27'F');
  50. end;
  51.  
  52. procedure GOff;
  53. begin
  54.   if H19 then
  55.     write(#27'G');
  56. end;
  57.  
  58. procedure CurOn;
  59. begin
  60.   if H19 then
  61.     write(#27'y5');
  62. end;
  63.  
  64. procedure CurOff;
  65. begin
  66.   if H19 then
  67.     write(#27'x5');
  68. end;
  69.  
  70. procedure BlkCur;
  71. begin
  72.   if H19 then
  73.     write(#27'x4');
  74. end;
  75.  
  76. procedure UlCur;
  77. begin
  78.   if H19 then
  79.     write(#27'y4');
  80. end;
  81.  
  82. function Exist(FN: str14): boolean;
  83. var
  84.   F: file;
  85. begin
  86.   Assign(F,FN);
  87.   {$I-} reset(F); {$I+}
  88.   Exist:= (IOResult = 0);
  89. end;
  90.  
  91. function Julian(M,D,Y: real): real;
  92. var
  93.   A: real;
  94. begin
  95.   if (M=1) or (M=2) then
  96.   begin
  97.     Y:=Y-1;
  98.     M:=M+12;
  99.   end;
  100.   A:=int(Y/100);
  101.   A:=2-A+int(A/4);
  102.   A:=A+int(365.25*Y);
  103.   A:=A+int(30.6001*(M+1));
  104.   Julian:=A+D+1720994.5;
  105. end;
  106.  
  107. function DayOfWeek(DOW: integer): integer;
  108. begin
  109.   DayOfWeek:=Round(frac((Julian(M,DOW,Y)+1.5)/7.0)*7.0);
  110. end;
  111.  
  112. procedure Center(S: str80);
  113. var
  114.   L: integer;
  115. begin
  116.   for L:=1 to 39-(ord(S[0]) div 2) do write(' ');
  117.   write(S);
  118. end;
  119.  
  120. function StringOf(N: byte; C: char): str80;
  121. var
  122.   L: byte;
  123.   S: str80;
  124. begin
  125.   S:='';
  126.   for L:=1 to N do S:=S+C;
  127.   StringOf:=S;
  128. end;
  129.  
  130. function DiM(M,Y: real): integer;
  131. const
  132.   Days: array[1..12] of byte =
  133.   (31,28,31,30,31,30,31,31,30,31,30,31);
  134. begin
  135.   if (Y/4=trunc(Y) div 4) and (M=2) then
  136.     DiM:=DAYS[trunc(M)]+1
  137.   else
  138.     DiM:=DAYS[trunc(M)];
  139. end;
  140.  
  141. procedure GotoDay(Day,OX,OY: integer);
  142. var
  143.   Temp: Integer;
  144. begin
  145.   Temp:=Day+MS-1;
  146.   gotoxy((Temp mod 7)*11+3+OX,(Temp div 7)*3+4+OY);
  147. end;
  148.  
  149. procedure PutInDay(Day,OX,OY: integer; var S: Str255);
  150. var
  151.   Temp,
  152.   Xp,Yp: Integer;
  153. begin
  154.   Temp:=Day+MS-1;
  155.   Xp:=(Temp mod 7)*11+3+OX;
  156.   Yp:=(Temp div 7)*3+4+OY;
  157.   for Temp:=1 to Ord(S[0]) do
  158.     Screen[Yp][Xp+Pred(Temp)]:=S[Temp];
  159. end;
  160.  
  161. function CenterStr(var S: str255): str255;
  162. var
  163.   L: integer;
  164.   S1: str80;
  165. begin
  166.   S1:='';
  167.   for L:=1 to 39-(ord(S[0]) div 2) do S1:=S1+' ';
  168.   S1:=S1+S;
  169.   CenterStr:=S1;
  170. end;
  171.  
  172. procedure MakeCal;
  173. var
  174.   NumberOfWeeks: Integer;
  175.   DaysInMonth: Integer;
  176. begin
  177.   NumberOfWeeks:=Trunc((DiM(M,Y)/7.0)+(DayOfWeek(1))/7.0)+1;
  178.   str(Y:4:0,TS);
  179.   TS:='calender for '+MonthStr[trunc(M)]+' '+TS;
  180.   TS:=CenterStr(TS);
  181.   Screen[1]:=TS;
  182.   Screen[2]:='';
  183.   Screen[3]:='    Sunday     Monday    Tuesday    Wensday    Thursday    Friday    Saturday  ';
  184.   if PrintOut or (not H19) then
  185.     Screen[4]:=' |----------+----------+----------+----------+----------+----------+----------|'
  186.   else
  187.     Screen[4]:=' faaaaaaaaaasaaaaaaaaaasaaaaaaaaaasaaaaaaaaaasaaaaaaaaaasaaaaaaaaaasaaaaaaaaaac';
  188.   Count:=0;
  189.   for L:=1 to NumberOfWeeks do
  190.   begin
  191.     for L1:=1 to 2 do
  192.     begin
  193.       if PrintOut or (not H19) then
  194.         Screen[5+Count]:=' |          |          |          |          |          |          |          |'
  195.       else
  196.         Screen[5+Count]:=' `          `          `          `          `          `          `          `';
  197.       Count:=Count+1;
  198.     end;
  199.     if L< NumberOfWeeks then
  200.     begin
  201.       if PrintOut or (not H19) then
  202.         Screen[5+Count]:=' |----------+----------+----------+----------+----------+----------+----------|'
  203.       else
  204.         Screen[5+Count]:=' vaaaaaaaaaabaaaaaaaaaabaaaaaaaaaabaaaaaaaaaabaaaaaaaaaabaaaaaaaaaabaaaaaaaaaat';
  205.       Count:=Count+1;
  206.     end;
  207.   end;
  208.   if PrintOut or (not H19) then
  209.     Screen[5+Count]:=' |----------+----------+----------+----------+----------+----------+----------|'
  210.   else
  211.     Screen[5+Count]:=' eaaaaaaaaaauaaaaaaaaaauaaaaaaaaaauaaaaaaaaaauaaaaaaaaaauaaaaaaaaaauaaaaaaaaaad';
  212.   Count:=Count+1;
  213.   for L:=Count+5 to 24 do
  214.   Screen[L]:='';
  215. end;
  216.  
  217. procedure ShowCal;
  218. var
  219.   L:           Integer;
  220.   CDay:        Integer;
  221. begin
  222.   PrintOut:=False;
  223.   MakeCal;
  224.   clrscr;
  225.   for L:=1 to 3 do writeln(Screen[L]);
  226.   GOn; for L:=4 to 4+Count+1 do writeln(Screen[L]); GOff;
  227.   L1:=DiM(M,Y);
  228.   for L:=1 to L1 do
  229.   begin
  230.     GotoDay(L,0,0);
  231.     write(L:2);
  232.     if Message[L].Long<>'' then
  233.     begin
  234.       GOn;
  235.       if not H19 then
  236.         write('---&')
  237.       else
  238.         write('aaak');
  239.       GOff;
  240.     end;
  241.     GotoDay(L,0,1);
  242.     write(copy(Message[L].Short,1,10));
  243.     GotoDay(L,0,2);
  244.     write(copy(Message[L].Short,11,20));
  245.   end;
  246.   gotoxy(1,24);
  247.   clreol;
  248.   if not H19 then
  249.     write('E-edit note / B-edit brief / D-delete day / P-Print / R-to restart / X-to exit')
  250.   else
  251.     write(' f1 notes / f2 brief / f3 delete day / f4 restart cal / f5 print cal / wh exit');
  252. end;
  253.  
  254. procedure printcal;
  255. var
  256.   L,DaysInMonth: Integer;
  257. begin
  258.   PrintOut:=True;
  259.   MakeCal;
  260.   DaysInMonth:=DiM(M,Y);
  261.   for L:=1 to DaysInMonth do
  262.   begin
  263.     str(L:2,TS);
  264.     PutInDay(L,0,0,TS);
  265.     TS:=Copy(Message[L].Short,1,10);
  266.     PutInDay(L,0,1,TS);
  267.     TS:=Copy(Message[L].Short,11,20);
  268.     PutInDay(L,0,2,TS);
  269.   end;
  270.   writeln(lst);
  271.   writeln(lst);
  272.   writeln(lst);
  273.   writeln(lst,Screen[1]);
  274.   writeln(lst,Screen[2]);
  275.   GOn;
  276.   for L:=4 to 4+Count+1 do
  277.     writeln(lst,Screen[L]);
  278.   GOff;
  279.   writeln(lst);
  280. end;
  281.  
  282. procedure MoveLeft;
  283. begin
  284.   if CDay>1 then
  285.     CDay:=CDay-1 else Bell;
  286. end;
  287.  
  288. procedure MoveRight;
  289. begin
  290.   if CDay<Dim(M,Y) then
  291.     CDay:=CDay+1 else Bell;
  292. end;
  293.  
  294. procedure MoveUp;
  295. begin
  296.   if CDay-7>0 then
  297.     CDay:=CDay-7 else Bell;
  298. end;
  299.  
  300. procedure MoveDown;
  301. begin
  302.   if CDay+7<=Dim(M,Y) then
  303.     CDay:=CDay+7 else Bell;
  304. end;
  305.  
  306. procedure GetDate;
  307. var
  308.   Finished: boolean;
  309.   N,X,Y,YOfs: integer;
  310. begin
  311.   GotoDay(CDay,0,0);
  312.   LowVideo;
  313.   write(CDay:2);
  314.   HighVideo;
  315.   CurOn;
  316.   if Pred(CDay+MS) div 7 < 3 then YOfs:=11 else YOfs:=1;
  317.   gotoxy(19,4+YOfs);
  318.   GOn;
  319.   if not H19 then
  320.     write('|',StringOf(40,'-'),'|')
  321.   else
  322.     write('f',StringOf(40,'a'),'c');
  323.   for L:=1 to 5 do
  324.   begin
  325.     gotoxy(19,4+L+YOfs);
  326.     if not H19 then
  327.       write('|',StringOf(40,' '),'|')
  328.     else
  329.       write('`',StringOf(40,' '),'`');
  330.   end;
  331.   gotoxy(19,5+L+YOfs);
  332.   if not H19 then
  333.     write('|',StringOf(40,'-'),'|')
  334.   else
  335.     write('e',StringOf(40,'a'),'d');
  336.   GOff;
  337.   gotoxy(20,5+YOfs);
  338.   write(Copy(Message[CDay].Long,1,40));
  339.   gotoxy(20,6+YOfs);
  340.   write(Copy(Message[CDay].Long,41,40));
  341.   gotoxy(20,7+YOfs);
  342.   write(Copy(Message[CDay].Long,81,40));
  343.   gotoxy(20,8+YOfs);
  344.   write(Copy(Message[CDay].Long,121,40));
  345.   gotoxy(20,9+YOfs);
  346.   write(Copy(Message[CDay].Long,161,40));
  347.   gotoxy(20,5+YOfs);
  348.   X:=20;
  349.   Y:=5;
  350.   TS:=Message[CDay].Long;
  351.   while Ord(TS[0])<200 do TS:=TS+' ';
  352.   N:=0;
  353.   gotoxy(1,24);
  354.   clreol;
  355.   center('press <RET> to exit');
  356.   Finished:=False;
  357.   repeat
  358.     gotoxy(X+(N mod 40),Y+(N div 40)+YOfs);
  359.     read(kbd,Ch);
  360.     if Ch in [' '..'~'] then
  361.       if N<200 then
  362.       begin
  363.         write(Ch);
  364.         N:=N+1;
  365.         TS[N]:=Ch;
  366.       end else Bell;
  367.     if (Ch=#8) or (Ch=#127) then
  368.     begin
  369.       if N>0 then
  370.       begin
  371.         TS[N]:=' ';
  372.         N:=N-1;
  373.         gotoxy(X+(N mod 40),Y+(N div 40)+YOfs);
  374.         write(' '#8);
  375.       end else Bell;
  376.     end;
  377.     if Ch=^E then
  378.       if N>39 then
  379.         N:=N-40;
  380.     if Ch=^X then
  381.       if N<160 then
  382.         N:=N+40;
  383.     if Ch=^S then
  384.       if N>0 then
  385.         N:=N-1;
  386.     if Ch=^D then
  387.       if N<199 then
  388.         N:=N+1;
  389.     if Ch=#13 then Finished:=True;
  390.   until Finished;
  391.   Ch:=#0;
  392.   while TS[Ord(TS[0])]=#32 do TS[0]:=Chr(Ord(TS[0])-1);
  393.   Message[CDay].Long:=TS;
  394.   CurOff;
  395. end;
  396.  
  397. procedure GetNote;
  398. var
  399.   Finished: boolean;
  400.   N,X,Y: integer;
  401. begin
  402.   CurOn;
  403.   GotoDay(CDay,0,1);
  404.   write(Copy(Message[CDay].Short,1,10));
  405.   GotoDay(CDay,0,2);
  406.   write(Copy(Message[CDay].Short,11,10));
  407.   GotoDay(CDay,0,1);
  408.   L2:=trunc(Pred(Trunc(CDay+MS)));
  409.   X:=(L2 mod 7)*11+3;
  410.   Y:=(L2 div 7)*3+5;
  411.   TS:=Message[CDay].Short;
  412.   while TS[0]<#20 do TS:=TS+' ';
  413.   N:=0;
  414.   gotoxy(1,24);
  415.   clreol;
  416.   center('press <RET> to exit');
  417.   Finished:=False;
  418.   repeat
  419.     gotoxy(X+(N mod 10),Y+(N div 10));
  420.     read(kbd,Ch);
  421.     if Ch in [' '..'~'] then
  422.       if N<20 then
  423.       begin
  424.         write(Ch);
  425.         N:=N+1;
  426.         TS[N]:=Ch;
  427.       end else Bell;
  428.     if (Ch=#8) or (Ch=#127) then
  429.     begin
  430.       if N>0 then
  431.       begin
  432.         TS[N]:=' ';
  433.         N:=N-1;
  434.         gotoxy(X+(N mod 10),Y+(N div 10));
  435.         write(' '#8);
  436.       end else Bell;
  437.     end;
  438.     if Ch=^E then
  439.       if N>9 then
  440.         N:=N-10;
  441.     if Ch=^X then
  442.       if N<9 then
  443.         N:=N+10;
  444.     if Ch=^S then
  445.       if N>0 then
  446.         N:=N-1;
  447.     if Ch=^D then
  448.       if N<19 then
  449.         N:=N+1;
  450.     if Ch=#13 then Finished:=True;
  451.   until Finished;
  452.   while TS[Ord(TS[0])]=#32 do TS[0]:=Chr(Ord(TS[0])-1);
  453.   Message[CDay].Short:=TS;
  454.   CurOff;
  455.   gotoxy(1,24);
  456.   clreol;
  457.   if not H19 then
  458.     write('E-edit note / B-edit brief / D-delete day / P-Print / R-to restart / X-to exit')
  459.   else
  460.     write(' f1 notes / f2 brief / f3 delete day / f4 restart cal / f5 print cal / wh exit');
  461.   Ch:=#0;
  462. end;
  463.  
  464. procedure EraseDay;
  465. begin
  466.   CurOn;
  467.   gotoxy(1,23);
  468.   clreol;
  469.   str(CDay:2,TS);
  470.   TS:='erase '+MonthStr[trunc(M)]+' '+TS+' (Y/N) ? ';
  471.   center(TS);
  472.   repeat read(kbd,Ch); Ch:=UpCase(Ch); until Ch in ['Y','N'];
  473.   if Ch='Y' then
  474.   begin
  475.     Message[CDay].Short:='';
  476.     Message[CDay].Long:='';
  477.   end;
  478.   CurOff;
  479.   ShowCal;
  480. end;
  481.  
  482. procedure Save;
  483. label
  484.   Exit;
  485. begin
  486.   L2:=0;
  487.   ReWrite(F);
  488.   for L:=1 to Dim(M,Y) do
  489.   begin
  490.     if Message[L].Short<>'' then
  491.     begin
  492.       str(L:2,TS);
  493.       TS:=TS+Message[L].Short+Message[L].Long;
  494.       {$I-} writeln(F,TS); {$I+}
  495.       if IOResult<>0 then
  496.       begin
  497.         gotoxy(1,23);
  498.         clreol;
  499.         LowVideo;
  500.         center('ERROR: out of disk space.');
  501.         HighVideo;
  502.         delay(4000);
  503.         erase(F);
  504.         Finished:=True;
  505.         goto Exit;
  506.       end;
  507.       L2:=1;
  508.     end;
  509.   end;
  510.   close(F);
  511.   if L2=0 then Erase(F);
  512. Exit:
  513. end;
  514.  
  515. begin
  516. Start:
  517.   H19:=True;
  518.   CrtInit;
  519.   ClrScr;
  520.   delay(20);
  521.   writeln;
  522.   writeln;
  523.   center('CALANDER V3');
  524.   for L:=1 to 31 do
  525.   begin
  526.     Message[L].Short:='';
  527.     Message[L].Long:='';
  528.   end;
  529.   repeat
  530.     repeat
  531.       clreol;
  532.       gotoxy(26,6);
  533.       write('Use what date (MM DD YY) ? ');
  534.       readln(M,D,Y);
  535.       Y:=Y+1900;
  536.     until (Y>1980) and (Y<2080);
  537.   until (trunc(M) in [1..12]) and (trunc(D) in [1..DiM(M,Y)]);
  538.   CurOff;
  539.   str(Y:4:0,TS);
  540.   FN:=Copy(MonthStr[trunc(M)],1,3)+copy(TS,3,2)+'.CAL';
  541.   assign(F,FN);
  542.   if not exist(FN) then
  543.   begin
  544.     {$I-} rewrite(F); {$I+}
  545.     if IOResult<>0 then
  546.     begin
  547.       gotoxy(1,23);
  548.       clreol;
  549.       LowVideo;
  550.       center('ERROR: no disk space');
  551.       HighVideo;
  552.       Delay(4000);
  553.       goto Exit;
  554.     end else close(F);
  555.   end;
  556.   reset(F);
  557.   while not eof(F) do
  558.   begin
  559.     readln(F,TS);
  560.     val(copy(TS,1,2),L,L1);
  561.     if L1<>0 then val(copy(TS,2,1),L,L1);
  562.     Message[L].Short:=copy(TS,3,20);
  563.     Message[L].Long :=copy(TS,23,255);
  564.   end;
  565.   MS:=DayOfWeek(1);
  566.   ShowCal;
  567.   CDay:=Trunc(D);
  568.   Finished:=False;
  569.   repeat
  570.     GotoDay(CDay,0,0);
  571.     LowVideo;
  572.     write(CDay:2);
  573.     HighVideo;
  574.     GotoDay(CDay,0,0);
  575.     read(kbd,Ch);
  576.     write(CDay:2);
  577.     case Ch of
  578.       ^S: MoveLeft;
  579.       ^D: MoveRight;
  580.       ^E: MoveUp;
  581.       ^X: MoveDown;
  582.     end;
  583.     if not H19 then
  584.     begin
  585.       if Ch='E' then
  586.       begin
  587.         GetDate;
  588.         ShowCal;
  589.       end;
  590.       if Ch='B' then
  591.       GetNote;
  592.       if Ch='D' then EraseDay;
  593.       if Ch='R' then
  594.       begin
  595.         Save;
  596.         goto Start;
  597.       end;
  598.       if Ch='P' then PrintCal;
  599.       if Ch='X' then Finished:=True;
  600.     end
  601.     else
  602.     begin
  603.       if Ch=^[ then
  604.       begin
  605.         read(kbd,Ch);
  606.         if Ch='S' then
  607.         begin
  608.           GetDate;
  609.           ShowCal;
  610.         end;
  611.         if Ch='T' then
  612.           GetNote;
  613.         if Ch='U' then EraseDay;
  614.         if Ch='V' then
  615.         begin
  616.           Save;
  617.           goto Start;
  618.         end;
  619.         if Ch='W' then PrintCal;
  620.         if Ch='R' then Finished:=True;
  621.       end;
  622.     end;
  623.   until Finished;
  624.   Save;
  625. Exit:
  626.   ClrScr;
  627.   CrtExit;
  628.   delay(30);
  629. end.
  630.