home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / calendar / calndr.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-07-01  |  8.4 KB  |  315 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.  
  25. {$IWriteBig.INC}
  26.  
  27. {$ICalFuncs.INC}
  28.  
  29. {$IStrFuncs.INC}
  30.  
  31. Procedure BuildCalendar(Year:Integer);
  32. Var  x,Month,Week,Day   :   Integer;
  33. Begin
  34.      FillChar(Table,504,0);
  35.      For Month:=1 to 12 Do
  36.       Begin
  37.        Day:=DayOfWeek(Year,Month,1);
  38.        Week:=1;
  39.        For x:=1 to DayOfYear(Year,Month+1,1) - DayOfYear(Year,Month,1) Do
  40.          Begin
  41.          Table[Month,Week,Day]:=x;
  42.          Day:=(Day+1) Mod 7;
  43.          If Day=0 Then Week:=Succ(Week);
  44.          End;
  45.       End;
  46. End;
  47.  
  48. Procedure PrintCalendar(Year : Integer; up:Byte);
  49. Var  x,Month,Week,Day   :   Integer;
  50.      yname              :   String4;
  51. Begin
  52.      Month:=1;
  53.      Str(Year:4,yname);
  54. Repeat
  55.      For x:= 0 to Up-1 Do
  56.          Write  (SYSLST,Center(MonthName[Month+x]+' '+yname,29),'   ');
  57.      Writeln(SYSLST);
  58.      For x:= 0 to Up-1 Do  Write(SYSLST,' Sun Mon Tue Wed Thu Fri Sat    ');
  59.      Writeln(SYSLST);
  60.      Writeln(SYSLST);
  61.      For week:=1 to 6 Do
  62.        Begin
  63.          For x:=0 to Up-1 Do
  64.            Begin
  65.                 For day:=0 to 6 Do
  66.                    If Table[Month+x,week,day]=0 then Write(SYSLST,'    ')
  67.                        Else Write(SYSLST,Table[Month+x,week,day]:4);
  68.                 Write(SYSLST,'    ');
  69.            End;
  70.          Writeln(SYSLST);
  71.        End;
  72.      Month:=Month+Up;
  73.      Writeln(SYSLST);
  74. Until Month>12;
  75. Writeln(SYSLST,#12);             {Top of Page}
  76. End;
  77.  
  78. {------------Procedures for Block Character Calendar------------------------}
  79.  
  80. Procedure PrintHeader(Year: Integer; Month:Byte);
  81. Var mname,prtstr : string255;
  82.     yname        : String4;
  83.     x,line       : Byte;
  84. Begin
  85.      mname:=MonthName[Month];
  86.      str(Year:4,yname);
  87.      mname:=mname+' '+yname;
  88.      for line:=1 to 7 Do
  89.         Begin
  90.         prtstr:=BuildBig(mname[1],line);
  91.         for x:=2 to Length(mname) Do
  92.              Begin
  93.                   prtstr:=prtstr+'  '+BuildBig(mname[x],line);
  94.              End;
  95.         Writeln(SYSLST,Center(prtstr,127));
  96.         End
  97. End;
  98.  
  99. Procedure PrintDividerLine;
  100. Begin
  101.      Write(SYSLST,'|');
  102.      Writeln(SYSLST,DupString('-----------------|',126));
  103. End;
  104.  
  105. Procedure PrintDayNames;
  106. Begin
  107.      Write  (SYSLST,'|     Sunday      ');
  108.      Write  (SYSLST,'|     Monday      ');
  109.      Write  (SYSLST,'|     Tuesday     ');
  110.      Write  (SYSLST,'|    Wednesday    ');
  111.      Write  (SYSLST,'|    Thursday     ');
  112.      Write  (SYSLST,'|     Friday      ');
  113.      Writeln(SYSLST,'|    Saturday     |');
  114. End;
  115.  
  116. Function BuildBigNumber(Num, line : Byte) : String255;
  117. Var b   : Byte;
  118.     x   : String5;
  119.     y   : String255;
  120. Begin
  121.      If Num=0 Then y:='' Else
  122.         Begin
  123.            str(Num:5,x);
  124.            Repeat if x[1]=' ' then delete(x,1,1);     until x[1]<>' ';
  125.            y:=BuildBig(x[1],line);
  126.            For b:=2 to length(x) Do y:=y+'  '+BuildBig(x[b],line);
  127.         End;
  128.      BuildBigNumber:=y
  129. End;
  130.  
  131. Function MkStr(n : Integer) :String3;
  132. Var s : String3;
  133. Begin
  134.      Str(n:3,s);
  135.      If n < 10  Then MkStr:=s[3] Else
  136.      If n < 100 Then MkStr:=s[2]+s[3] Else
  137.                      MkStr:=s;
  138. End;
  139.  
  140. Procedure PrintaWeek(Year : Integer; Month,week : Byte);
  141. Var x,line: Byte;
  142. Begin
  143.   for line:=1 to 7 Do
  144.    Begin
  145.     Write(SYSLST,'|');
  146.     for x:=0 to 6 Do
  147.        Write(SYSLST,Center(BuildBigNumber(Table[Month,week,x],line),17),'|');
  148.     Writeln(SYSLST);
  149.    End;
  150.  
  151.   Write(SYSLST,'|');
  152.   For x:=0 to 6 Do
  153.    If Table[Month,Week,x]=0 Then Write(SYSLST,Center('',17),'|')
  154.        Else
  155.     Write(SYSLST,
  156.      Center('('+MkStr(DayOfYear(Year,Month,Table[Month,Week,x]))+')',17),'|');
  157.  
  158.    Writeln(SYSLST)
  159. End;
  160.  
  161. Procedure PrintMonth(Year,Month:Integer);
  162. Var x : Byte;
  163. Begin
  164.      PrintHeader(Year,month);
  165.      PrintDividerLine;
  166.      PrintDayNames;
  167.      PrintDividerLine;
  168.      For x:=1 to 6 Do
  169.         Begin
  170.            If Table[Month,x,0]<>Table[Month,x,6] Then
  171.               Begin
  172.                 PrintaWeek(Year,Month,x);
  173.                 PrintDividerLine
  174.               End
  175.         End;
  176.      Writeln(SYSLST,#12);
  177. end;
  178.  
  179. Procedure PrintYear(Year : Integer;Month,Format : Byte);
  180. Var x : Integer;
  181. Begin
  182.      BuildCalendar(Year);
  183.  
  184.      If Format>0 Then PrintCalendar(Year,Format) Else
  185.           If Month=0 Then For x:=1 to 12 Do PrintMonth(Year,x)
  186.               Else PrintMonth(Year,Month);
  187. End;
  188.  
  189. Procedure Quit;
  190. Begin
  191.      Close(SYSLST);
  192.      HALT
  193. End;
  194.  
  195. Var  OutputFile : String65;
  196.  
  197. Procedure NewFile;
  198. Var  x: Integer;
  199. Begin
  200.      Close(SYSLST);
  201.      Assign(SYSLST,OutputFile);
  202. {$I-}
  203.      ReWrite(SYSLST);
  204. {$I+}
  205.      x:=IOResult;
  206.      If x<>0 Then
  207.         Begin
  208.              Writeln('Filename=',OutputFile,'  File Error=',x);
  209.              Halt
  210.         End;
  211. End;
  212.  
  213.         {---------------- Main Program Block --------------}
  214.  
  215. Var  ErrCode,Format,x,y,Month,Week,Day,Year   :   Integer;
  216.      c                                        : String255;
  217.  
  218. Begin
  219.  
  220. ClrSCr;
  221. WriteBig(' Calendar ');
  222. Writeln;
  223. Writeln;
  224.  
  225.  {Default Parameter Values}
  226.  
  227.          OutputFile:='OUT:'; Year:=1985; Month:=0; Format:=2;
  228.  
  229. Assign(SYSLST,OutputFile);
  230. ReWrite(SYSLST);
  231.  
  232. If ParamCount=0 then Begin Writeln('No parameters supplied - See CALNDR.DOC');
  233.                            HALT End;
  234.  
  235. For x:=1 To ParamCount Do
  236.     Begin
  237.         c:=ParamStr(x);
  238.         Writeln('Processing Param # ',x,' -->',c,'<--');
  239.         Case UpCase(c[1]) of
  240.  
  241.           'M'  :   Begin
  242.                         Delete(c,1,1);
  243.                         Val(c,Month,ErrCode);
  244.                         If ErrCode<>0 Then
  245.                            Begin
  246.                               Writeln('Invalid Month -->',c,'<');
  247.                               Quit
  248.                            End
  249.                  Else   If (Month>12) or (Month<0) Then
  250.                            Begin
  251.                               Writeln('Invalid Month (Must be 0 thru 12)');
  252.                               Quit
  253.                            End;
  254.                    End;
  255.  
  256.           'F'  :   Begin
  257.                       Delete(c,1,1);
  258.                       Val(c,Format,ErrCode);
  259.                       If ErrCode<>0 Then
  260.                          Begin
  261.                             Writeln('Invalid Format Param -->',c,'<');
  262.                             Quit
  263.                          End
  264.                  Else If (Format>4) or (Format<0) Then
  265.                          Begin
  266.                             Writeln('Invalid Format Param (Must be 0 thru 4)');
  267.                             Quit
  268.                          End;
  269.                    End;
  270.  
  271.           'Y'  :   Begin
  272.                         Delete(c,1,1);
  273.                         Val(c,Year,ErrCode);
  274.                         If ErrCode<>0 Then
  275.                            Begin
  276.                               Writeln('Invalid Year -->',c,'<');
  277.                               Quit
  278.                            End
  279.                   Else  If Year < 0 Then
  280.                            Begin
  281.                               Writeln('Invalid Year -->',c,'<');
  282.                               Quit
  283.                            End;
  284.                         PrintYear(Year,Month,Format);
  285.                    End;
  286.  
  287.           'P'  :   Begin
  288.                         Delete(c,1,1);
  289.                         y:=1;
  290.                         Repeat
  291.                            If c[y]='^' Then
  292.                               Begin
  293.                                   Write(SYSLST,Chr(Byte(c[y+1])-$40));
  294.                                   y:=succ(y)
  295.                               End
  296.                             Else
  297.                               Write(SYSLST,c[y]);
  298.                             y:=succ(y);
  299.                         Until y>Length(c);
  300.                    End;
  301.  
  302.           'O'  :   Begin
  303.                         Delete(c,1,1);
  304.                         OutputFile:=c;
  305.                         NewFile
  306.                    End;
  307.  
  308.           Else     Writeln('Unknown Param Type -->',c,'<-- Ignored');
  309.  
  310.           End;     {--- CASE ---}
  311.     End;
  312.  
  313. Close(SYSLST);
  314.  
  315. End.