home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MADTRB15.ZIP / CALNDR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-07-27  |  15.1 KB  |  500 lines
  1. Program Calendar;
  2. {$C-}
  3.  
  4. Type TWeek  = Array[0..6]  of Byte;
  5.      TMonth = Array[1..6]  of TWeek;
  6.      TYear  = Array[1..12] of TMonth;
  7.  
  8.      MonthArray = Array[1..12] of String[9];
  9.  
  10.      String3    = String[3];
  11.      String4    = String[4];
  12.      String5    = String[5];
  13.      String65   = String[65];
  14.      String255  = String[255];
  15.  
  16. Const
  17.  
  18.   MonthName : MonthArray =('January','February','March','April',
  19.   'May','June','July','August','September','October','November','December');
  20.  
  21. Var  SYSLST     : Text;
  22.      Table      : TYear;
  23.  
  24. Type   WriteBigParam = String[11];
  25.        PrintBigParam = String[22];
  26.  
  27. Fontarray = Array[33..95] of Array[1..7] of Byte;
  28.  
  29. Const
  30.  
  31. FontTable : Fontarray = ((04,04,04,04,00,00,04),
  32.                          (10,10,10,00,00,00,00),
  33.                          (10,10,31,10,31,10,10),
  34.                          (04,15,20,14,05,30,04),
  35.                          (25,25,02,04,08,19,19),
  36.                          (04,10,10,12,21,18,11),
  37.                          (02,04,08,00,00,00,00),
  38.                          (02,04,08,08,08,04,02),
  39.                          (08,04,02,02,02,04,08),
  40.                          (00,04,21,14,21,04,00),
  41.                          (00,04,04,31,04,04,00),
  42.                          (00,00,00,00,08,08,16),
  43.                          (00,00,00,31,00,00,00),
  44.                          (00,00,00,00,00,24,24),
  45.                          (01,01,02,04,08,16,16),
  46.                          (14,17,17,17,17,17,14),
  47.                          (04,12,20,04,04,04,31),
  48.                          (14,17,01,02,12,16,31),
  49.                          (30,01,02,04,02,01,30),
  50.                          (02,06,10,18,31,02,02),
  51.                          (31,16,30,01,01,17,14),
  52.                          (07,08,16,30,17,17,14),
  53.                          (31,01,02,04,08,08,08),
  54.                          (14,17,17,14,17,17,14),
  55.                          (14,17,17,15,01,02,28),
  56.                          (00,00,04,00,00,00,04),
  57.                          (00,00,08,00,08,08,16),
  58.                          (03,04,08,16,08,04,03),
  59.                          (00,00,31,00,31,00,00),
  60.                          (24,04,02,01,02,04,24),
  61.                          (14,17,01,02,04,00,04),
  62.                          (14,17,23,21,23,16,14),
  63.                          (14,17,17,31,17,17,17),
  64.                          (30,17,17,30,17,17,30),
  65.                          (14,17,16,16,16,17,14),
  66.                          (28,18,17,17,17,18,28),
  67.                          (31,16,16,30,16,16,31),
  68.                          (31,16,16,30,16,16,16),
  69.                          (14,17,16,19,17,17,15),
  70.                          (17,17,17,31,17,17,17),
  71.                          (14,04,04,04,04,04,14),
  72.                          (07,02,02,02,02,18,12),
  73.                          (17,18,20,24,20,18,17),
  74.                          (16,16,16,16,16,16,31),
  75.                          (17,27,21,21,17,17,17),
  76.                          (17,25,25,21,19,19,17),
  77.                          (14,17,17,17,17,17,14),
  78.                          (30,17,17,30,16,16,16),
  79.                          (14,17,17,17,21,18,13),
  80.                          (30,17,17,30,20,18,17),
  81.                          (15,16,16,13,01,01,30),
  82.                          (31,04,04,04,04,04,04),
  83.                          (17,17,17,17,17,17,14),
  84.                          (17,17,17,10,10,04,04),
  85.                          (17,17,17,21,21,27,17),
  86.                          (17,17,10,04,10,17,17),
  87.                          (17,17,17,14,04,04,04),
  88.                          (31,01,02,04,08,16,31),
  89.                          (28,16,16,16,16,16,28),
  90.                          (16,16,08,04,02,01,01),
  91.                          (03,01,01,01,01,01,03),
  92.                          (14,17,00,00,00,00,00),
  93.                          (00,00,00,00,00,00,31));
  94.  
  95. Procedure WriteBig(Input : WriteBigParam);
  96. Var a,b,c,d :Byte;
  97. Begin
  98.      for a:=1 to 7 Do
  99.        Begin
  100.          for b:=1 to Length(input) Do
  101.              Begin
  102.                   c:=Ord(Input[b]);
  103.                   if c>95 Then c:=c-32;
  104.                   for d:=0 to 4 Do
  105.                       If (FontTable[c,a] and (16 shr d)) <> 0 Then
  106.                          Write(chr(c)) Else Write(' ');
  107.                       Write('  ');
  108.              End;
  109.          Writeln
  110.          End
  111. End;
  112.  
  113. Procedure PrintBig(Input : PrintBigParam);
  114. Var a,b,c,d :Byte;
  115. Begin
  116.      for a:=1 to 7 Do
  117.        Begin
  118.          for b:=1 to Length(input) Do
  119.              Begin
  120.                   c:=Ord(Input[b]);
  121.                   if c>95 Then c:=c-32;
  122.                   for d:=0 to 4 Do
  123.                       If (FontTable[c,a] and (16 shr d)) <> 0 Then
  124.                          Write(LST,chr(c)) Else Write(LST,' ');
  125.                       Write(LST,'  ');
  126.              End;
  127.          Writeln
  128.          End
  129. End;
  130.  
  131. Type BuildBigParam=String[5];
  132.  
  133. Function BuildBig(ch : Char; l : Byte) : BuildBigParam;
  134. Var c,d : Byte;
  135.     x   : BuildBigParam;
  136. Begin
  137.     x:='';
  138.      c:=Ord(ch);
  139.      if c>95 Then c:=c-32;
  140.      for d:=0 to 4 Do
  141.          If (FontTable[c,l] and (16 shr d))<>0 Then x:=x+chr(c) Else x:=x+' ';
  142.      BuildBig:=x
  143. End;
  144.  
  145. Function LeapYear(Year:Integer):Byte;
  146. Begin
  147.      If (((Year Mod 400)=0) Or (((Year Mod 4)=0) And ((Year Mod 100)<>0))) Then
  148.      LeapYear:=1 Else LeapYear:=0;
  149. End;
  150.  
  151. Function DayOfYear(Year, Month, Day : Integer) : Integer;
  152. Begin
  153.      DayOfYear:=Trunc(Int(3055.0*(Month+2.0)/100.0)
  154.                -Int((Month+10.0)/13.0)*2-91
  155.                +(LeapYear(Year)*Int((Month+10.0)/13.0)
  156.                +Day));
  157. End;
  158.  
  159. Function RealMod(x:Real;y:Integer):Integer;   {-------------------------}
  160. Begin                                         {Turbo MOD operator only  }
  161.      RealMod:=Trunc(x-Int(x/y)*y+0.5);        {works with Integer values}
  162. End;                                          { This is same operation  }
  163.                                               {For real argument.       }
  164.                                               {-------------------------}
  165.  
  166. Function RealDay(Year,Month,Day : Integer) : Real;
  167. Begin
  168.      RealDay:=DayOfYear(Year,Month,Day)
  169.              +((Year-1)*365.0)
  170.              +Int((Year-1)/4)
  171.              -Int((Year-1)/100)
  172.              +Int((Year-1)/400);
  173. End;
  174.  
  175. Function DayOfWeek(Year,Month,Day : Integer) : Integer;
  176. Begin                                                       {0 is Sunday}
  177.      DayOfWeek:=RealMod(RealDay(Year,Month,Day),7)
  178. End;
  179.  
  180. Procedure GetMonthDay(Year, DayOfYear : Integer; Var Month,Day : Integer);
  181. Var
  182.     Temp : Integer;
  183.     Leap : Byte;
  184. Begin
  185.      Leap:=LeapYear(Year);
  186.      Temp:=Trunc(DayOfYear+Int((305+DayOfYear-Leap)/365)*(2-Leap));
  187.      Month:=Trunc(Int(((Temp+91.0)*100.0)/3055.0)-2.0);
  188.      Day:=Trunc(Temp+30.0-Int((Month*3056.0)/100.0));
  189. End;
  190.  
  191. Function DupString(Str:String255; Size: Integer) : String255;
  192. Var s: String255;
  193.     x: Byte;
  194. Begin
  195.      s:='';
  196.      Repeat    s:=s+Str  Until Length(s) >= Size;
  197.      DupString := Copy(s,1,Size)
  198. End;
  199.  
  200. Function RightString(Str: String255; Size: Byte) : String255;
  201. Begin
  202.      If Length(Str)>Size Then
  203.         RightString:=Copy(Str,1+Length(Str)-Size,Size)
  204.      Else
  205.         RightString:=DupString(' ',Size-Length(Str))+Str
  206. End;
  207.  
  208. Function Center(s : String255; size : Byte) : String255 ;
  209. Var x : integer;
  210. Begin
  211.     x:=size-Length(s);
  212.     x:=trunc(x/2);
  213.     Center:=DupString(' ',x)+s+DupString(' ',size-Length(s)-x);
  214. End;
  215.  
  216. Procedure BuildCalendar(Year:Integer);
  217. Var  x,Month,Week,Day   :   Integer;
  218. Begin
  219.      FillChar(Table,504,0);
  220.      For Month:=1 to 12 Do
  221.       Begin
  222.        Day:=DayOfWeek(Year,Month,1);
  223.        Week:=1;
  224.        For x:=1 to DayOfYear(Year,Month+1,1) - DayOfYear(Year,Month,1) Do
  225.          Begin
  226.          Table[Month,Week,Day]:=x;
  227.          Day:=(Day+1) Mod 7;
  228.          If Day=0 Then Week:=Succ(Week);
  229.          End;
  230.       End;
  231. End;
  232.  
  233. Procedure PrintCalendar(Year : Integer; up:Byte);
  234. Var  x,Month,Week,Day   :   Integer;
  235.      yname              :   String4;
  236. Begin
  237.      Month:=1;
  238.      Str(Year:4,yname);
  239. Repeat
  240.      For x:= 0 to Up-1 Do
  241.          Write  (SYSLST,Center(MonthName[Month+x]+' '+yname,29),'   ');
  242.      Writeln(SYSLST);
  243.      For x:= 0 to Up-1 Do  Write(SYSLST,' Sun Mon Tue Wed Thu Fri Sat    ');
  244.      Writeln(SYSLST);
  245.      Writeln(SYSLST);
  246.      For week:=1 to 6 Do
  247.        Begin
  248.          For x:=0 to Up-1 Do
  249.            Begin
  250.                 For day:=0 to 6 Do
  251.                    If Table[Month+x,week,day]=0 then Write(SYSLST,'    ')
  252.                        Else Write(SYSLST,Table[Month+x,week,day]:4);
  253.                 Write(SYSLST,'    ');
  254.            End;
  255.          Writeln(SYSLST);
  256.        End;
  257.      Month:=Month+Up;
  258.      Writeln(SYSLST);
  259. Until Month>12;
  260. Writeln(SYSLST,#12);             {Top of Page}
  261. End;
  262.  
  263. {------------Procedures for Block Character Calendar------------------------}
  264.  
  265. Procedure PrintHeader(Year: Integer; Month:Byte);
  266. Var mname,prtstr : string255;
  267.     yname        : String4;
  268.     x,line       : Byte;
  269. Begin
  270.      mname:=MonthName[Month];
  271.      str(Year:4,yname);
  272.      mname:=mname+' '+yname;
  273.      for line:=1 to 7 Do
  274.         Begin
  275.         prtstr:=BuildBig(mname[1],line);
  276.         for x:=2 to Length(mname) Do
  277.              Begin
  278.                   prtstr:=prtstr+'  '+BuildBig(mname[x],line);
  279.              End;
  280.         Writeln(SYSLST,Center(prtstr,127));
  281.         End
  282. End;
  283.  
  284. Procedure PrintDividerLine;
  285. Begin
  286.      Write(SYSLST,'|');
  287.      Writeln(SYSLST,DupString('-----------------|',126));
  288. End;
  289.  
  290. Procedure PrintDayNames;
  291. Begin
  292.      Write  (SYSLST,'|     Sunday      ');
  293.      Write  (SYSLST,'|     Monday      ');
  294.      Write  (SYSLST,'|     Tuesday     ');
  295.      Write  (SYSLST,'|    Wednesday    ');
  296.      Write  (SYSLST,'|    Thursday     ');
  297.      Write  (SYSLST,'|     Friday      ');
  298.      Writeln(SYSLST,'|    Saturday     |');
  299. End;
  300.  
  301. Function BuildBigNumber(Num, line : Byte) : String255;
  302. Var b   : Byte;
  303.     x   : String5;
  304.     y   : String255;
  305. Begin
  306.      If Num=0 Then y:='' Else
  307.         Begin
  308.            str(Num:5,x);
  309.            Repeat if x[1]=' ' then delete(x,1,1);     until x[1]<>' ';
  310.            y:=BuildBig(x[1],line);
  311.            For b:=2 to length(x) Do y:=y+'  '+BuildBig(x[b],line);
  312.         End;
  313.      BuildBigNumber:=y
  314. End;
  315.  
  316. Function MkStr(n : Integer) :String3;
  317. Var s : String3;
  318. Begin
  319.      Str(n:3,s);
  320.      If n < 10  Then MkStr:=s[3] Else
  321.      If n < 100 Then MkStr:=s[2]+s[3] Else
  322.                      MkStr:=s;
  323. End;
  324.  
  325. Procedure PrintaWeek(Year : Integer; Month,week : Byte);
  326. Var x,line: Byte;
  327. Begin
  328.   for line:=1 to 7 Do
  329.    Begin
  330.     Write(SYSLST,'|');
  331.     for x:=0 to 6 Do
  332.        Write(SYSLST,Center(BuildBigNumber(Table[Month,week,x],line),17),'|');
  333.     Writeln(SYSLST);
  334.    End;
  335.  
  336.   Write(SYSLST,'|');
  337.   For x:=0 to 6 Do
  338.    If Table[Month,Week,x]=0 Then Write(SYSLST,Center('',17),'|')
  339.        Else
  340.     Write(SYSLST,
  341.      Center('('+MkStr(DayOfYear(Year,Month,Table[Month,Week,x]))+')',17),'|');
  342.  
  343.    Writeln(SYSLST)
  344. End;
  345.  
  346. Procedure PrintMonth(Year,Month:Integer);
  347. Var x : Byte;
  348. Begin
  349.      PrintHeader(Year,month);
  350.      PrintDividerLine;
  351.      PrintDayNames;
  352.      PrintDividerLine;
  353.      For x:=1 to 6 Do
  354.         Begin
  355.            If Table[Month,x,0]<>Table[Month,x,6] Then
  356.               Begin
  357.                 PrintaWeek(Year,Month,x);
  358.                 PrintDividerLine
  359.               End
  360.         End;
  361.      Writeln(SYSLST,#12);
  362. end;
  363.  
  364. Procedure PrintYear(Year : Integer;Month,Format : Byte);
  365. Var x : Integer;
  366. Begin
  367.      BuildCalendar(Year);
  368.  
  369.      If Format>0 Then PrintCalendar(Year,Format) Else
  370.           If Month=0 Then For x:=1 to 12 Do PrintMonth(Year,x)
  371.               Else PrintMonth(Year,Month);
  372. End;
  373.  
  374. Procedure Quit;
  375. Begin
  376.      Close(SYSLST);
  377.      HALT
  378. End;
  379.  
  380. Var  OutputFile : String65;
  381.  
  382. Procedure NewFile;
  383. Var  x: Integer;
  384. Begin
  385.      Close(SYSLST);
  386.      Assign(SYSLST,OutputFile);
  387. {$I-}
  388.      ReWrite(SYSLST);
  389. {$I+}
  390.      x:=IOResult;
  391.      If x<>0 Then
  392.         Begin
  393.              Writeln('Filename=',OutputFile,'  File Error=',x);
  394.              Halt
  395.         End;
  396. End;
  397.  
  398.         {---------------- Main Program Block --------------}
  399.  
  400. Var  ErrCode,Format,x,y,Month,Week,Day,Year   :   Integer;
  401.      c                                        : String255;
  402.  
  403. Begin
  404.  
  405. ClrSCr;
  406. WriteBig(' Calendar ');
  407. Writeln;
  408. Writeln;
  409.  
  410.  {Default Parameter Values}
  411.  
  412.          OutputFile:='OUT:'; Year:=1985; Month:=0; Format:=2;
  413.  
  414. Assign(SYSLST,OutputFile);
  415. ReWrite(SYSLST);
  416.  
  417. If ParamCount=0 then Begin Writeln('No parameters supplied - See CALNDR.DOC');
  418.                            HALT End;
  419.  
  420. For x:=1 To ParamCount Do
  421.     Begin
  422.         c:=ParamStr(x);
  423.         Writeln('Processing Param # ',x,' -->',c,'<--');
  424.         Case UpCase(c[1]) of
  425.  
  426.           'M'  :   Begin
  427.                         Delete(c,1,1);
  428.                         Val(c,Month,ErrCode);
  429.                         If ErrCode<>0 Then
  430.                            Begin
  431.                               Writeln('Invalid Month -->',c,'<');
  432.                               Quit
  433.                            End
  434.                  Else   If (Month>12) or (Month<0) Then
  435.                            Begin
  436.                               Writeln('Invalid Month (Must be 0 thru 12)');
  437.                               Quit
  438.                            End;
  439.                    End;
  440.  
  441.           'F'  :   Begin
  442.                       Delete(c,1,1);
  443.                       Val(c,Format,ErrCode);
  444.                       If ErrCode<>0 Then
  445.                          Begin
  446.                             Writeln('Invalid Format Param -->',c,'<');
  447.                             Quit
  448.                          End
  449.                  Else If (Format>4) or (Format<0) Then
  450.                          Begin
  451.                             Writeln('Invalid Format Param (Must be 0 thru 4)');
  452.                             Quit
  453.                          End;
  454.                    End;
  455.  
  456.           'Y'  :   Begin
  457.                         Delete(c,1,1);
  458.                         Val(c,Year,ErrCode);
  459.                         If ErrCode<>0 Then
  460.                            Begin
  461.                               Writeln('Invalid Year -->',c,'<');
  462.                               Quit
  463.                            End
  464.                   Else  If Year < 0 Then
  465.                            Begin
  466.                               Writeln('Invalid Year -->',c,'<');
  467.                               Quit
  468.                            End;
  469.                         PrintYear(Year,Month,Format);
  470.                    End;
  471.  
  472.           'P'  :   Begin
  473.                         Delete(c,1,1);
  474.                         y:=1;
  475.                         Repeat
  476.                            If c[y]='^' Then
  477.                               Begin
  478.                                   Write(SYSLST,Chr(Byte(c[y+1])-$40));
  479.                                   y:=succ(y)
  480.                               End
  481.                             Else
  482.                               Write(SYSLST,c[y]);
  483.                             y:=succ(y);
  484.                         Until y>Length(c);
  485.                    End;
  486.  
  487.           'O'  :   Begin
  488.                         Delete(c,1,1);
  489.                         OutputFile:=c;
  490.                         NewFile
  491.                    End;
  492.  
  493.           Else     Writeln('Unknown Param Type -->',c,'<-- Ignored');
  494.  
  495.           End;     {--- CASE ---}
  496.     End;
  497.  
  498. Close(SYSLST);
  499.  
  500. End.