home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TPPROC19.ZIP / APPOINT.PAS next >
Encoding:
Pascal/Delphi Source File  |  1985-09-06  |  9.4 KB  |  458 lines
  1.  
  2. {APPOINTMENT/SCHEDULE CALENDER }
  3. { BY MANNY JUAN 08/15/83       }
  4.  
  5. PROGRAM calendar;
  6.  
  7. TYPE
  8.   month = ARRAY[1..9] OF CHAR;
  9.   weekday = (sun,mon,tue,wed,thu,fri,sat);
  10.   dstr = STRING[256];
  11.   
  12. VAR
  13.   yorn: STRING[1];
  14.   listout,
  15.   more_txt: boolean;
  16.   infile: STRING[16];
  17.   fin: FILE OF char;
  18.   ch: char;
  19.   wstr: STRING[133];
  20.   day,
  21.   di, {index}
  22.   dw, {text width in day cell}
  23.   max_lines, {lines of msgs per day}
  24.   curr_lines, {temp max_lines}
  25.   yymm,yy,mm,
  26.   start_of_week,
  27.   week, {curr week}
  28.   no_of_weeks, {no. of weeks}
  29.   base, {days since year started}
  30.   i,j,
  31.   start_of_month,
  32.   1s: integer; {line length}
  33.   day_in_month: ARRAY[1..12] OF integer;
  34.   
  35.   dashes,blanks: STRING;
  36.   month_name: ARRAY[1..12] OF month;
  37.   leap_year: boolean;
  38.   txt: dstr;
  39.   word: STRING[32];
  40.   schedule: ARRAY[-5..37] OF dstr;
  41.   wk_day: weekday;
  42.   day_of_week: ARRAY [weekday] OF STRING;
  43.   
  44. PROCEDURE init;
  45. BEGIN
  46.   blanks := '                 ';
  47.   blanks := blanks+blanks;
  48.   dashes := '-----------------';
  49.   dashes := dashes+dashes;
  50.   month_name[01] := 'January';
  51.   month_name[02] := 'February';
  52.   month_name[03] := 'March';
  53.   month_name[04] := 'April';
  54.   month_name[05] := 'May';
  55.   month_name[06] := 'June';
  56.   month_name[07] := 'July';
  57.   month_name[08] := 'August';
  58.   month_name[09] := 'September';
  59.   month_name[10] := 'October';
  60.   month_name[11] := 'November';
  61.   month_name[12] := 'December';
  62.   
  63.   days_in_month[01] := 31;
  64.   days_in_month[02] := 28;
  65.   days_in_month[03] := 31;
  66.   days_in_month[04] := 30;
  67.   days_in_month[05] := 31;
  68.   days_in_month[06] := 30;
  69.   days_in_month[07] := 31;
  70.   days_in_month[08] := 31;
  71.   days_in_month[09] := 30;
  72.   days_in_month[10] := 31;
  73.   days_in_month[11] := 30;
  74.   days_in_month[12] := 31;
  75.   
  76.   day_of_week[sun] := 'Sunday';
  77.   day_of_week[mon] := 'Monday';
  78.   day_of_week[tue] := 'Tuesday';
  79.   day_of_week[wed] := 'Wednesday';
  80.   day_of_week[thu] := 'Thursday';
  81.   day_of_week[fri] := 'Friday';
  82.   day_of_week[sat] := 'Saturday';
  83. END;
  84.  
  85. PROCEDURE error(msg:STRING);
  86.  
  87. VAR dummy: ARRAY[1..16] OF char;
  88. BEGIN
  89.   writeln;
  90.   writeln;
  91.   writeln('---',msg);
  92.   call(0,dummy,dummy);
  93. END;
  94.  
  95. PROCEDURE shave(VAR str:STRING;l:integer);
  96.  
  97. VAR k: integer;
  98. BEGIN
  99.   k := length(str)-l;
  100.   str := copy(str,l+1,k);
  101. END;
  102.  
  103. PROCEDURE getrec;
  104.  
  105. PROCEDURE get_text;
  106.  
  107. PROCEDURE getch;
  108. BEGIN
  109.   read(fin;ch);
  110.   IF (ch=chr(1ah))
  111.     THEN more_txt := false;
  112.   write(ch);
  113. END {getch};
  114.  
  115. BEGIN {get_text}
  116.   txt := '';
  117.   getch;
  118.   i := 0;
  119.   WHILE (more_txt AND NOT (ch=chr(0dh))) DO
  120.     BEGIN
  121.       IF (ch=chr(09h))
  122.         THEN ch := ' ';
  123.       txt :=txt+ch;
  124.       getch
  125.     END;
  126.   IF (NOT(more_txt))
  127.     THEN
  128.       txt := ' '
  129.     ELSE
  130.       IF (ch = chr(0dh))
  131.         THEN getch;
  132. END;
  133.  
  134. BEGIN {getrec}
  135.   get_text;
  136.   txt :=txt+' ';
  137.   WHILE (more_txt AND (txt=' ')) DO
  138.     get_text;
  139.     
  140.  {get first word}
  141.   IF (more_txt)
  142.     THEN
  143.       BEGIN
  144.         WHILE (copy(txt,1,1)=' ') DO
  145.           shave(txt,1);
  146.         i :=pos(' ',txt);
  147.         word := copy(txt,1,i-1;
  148.    {word:=upcase(word) ;}
  149.        END
  150.      ELSE
  151.        word := ' ';
  152. END;
  153.  
  154. PROCEDURE segleft (VAR txt:dstr;tw:integer);
  155.  
  156. VAR
  157.   outx: dstr;
  158.   wrd,pad,txtseg: STRING[32];
  159.   i,text_left: integer;
  160.   currtw: integer;
  161.   
  162. PROCEDURE getwd;
  163.  
  164. VAR
  165.   i,j: integer;
  166. Begin
  167.   wrd := ' ';
  168.   IF (txt>'')
  169.     THEN
  170.       BEGIN
  171.         WHILE (copy(txt,1,1)=' ') DO
  172.           shave( txt, 1);
  173.         i := pos(' ',txt);
  174.         IF NOT (i<currtw)
  175.           THEN
  176.             BEGIN
  177.               i := currtw;
  178.               wrd := copy(txt,1,i)+' ';
  179.             END
  180.           ELSE
  181.             wrd := copy(txt,1,i);
  182.         shave(txt,i);
  183.       END;
  184. END;
  185.  
  186. BEGIN
  187.   txt := txt+' ';
  188.   pad := '                ';
  189.   outx := '';
  190.   txtseg := '';
  191.   text_left := tw+1;
  192.   currtw := tw;
  193.   getwd;
  194.   currtw := tw-2;
  195.   WHILE (wrd>'') DO
  196.     BEGIN
  197.       WHILE ((wrd>'')
  198.             AND (NOT (text_left < length (wrd)))) DO
  199.         BEGIN
  200.           txtseg := txtseg+wrd;
  201.           text_left := text_left-length(wrd);
  202.           getwd;
  203.         END;
  204.       IF (txtseg>' ')
  205.         THEN
  206.           BEGIN
  207.             i := length(txtseg);
  208.             WHILE (copy(txtseg,i,1)=' ')
  209.               DO
  210.               i := i-1;
  211.             txtseg := copy(txtseg,1,i);
  212.           END
  213.           
  214.       txtseg := txtseg+pad;
  215.       txt := copy (txtseg,1,tw);
  216.       
  217.       outx := outx+txtseg;
  218.       txtseg := '  ';
  219.       text_left := tw-1;
  220.     END;
  221.   txt := outx;
  222. END; {segleft}
  223.  
  224. PROCEDURE get_infile;
  225.  
  226. VAR
  227.   i,j: integer;
  228. BEGIN
  229.   yymm := 0;
  230.   i := pos(':',infile);
  231.   IF (i=0)
  232.     THEN j := 1
  233.     ELSE j := 3;
  234.   FOR i:=1 TO 4 DO
  235.     BEGIN
  236.       ch := copy(infile,i+j,1);
  237.       yymm := 10*yymm+ord(ch)-ord('0')
  238.     END
  239.   yy := yymm DIV 100;
  240.   mm := yymm - 100*yy;
  241.   IF ((yy<1) OR (yy>99) OR (mm<1) OR (mm>12))
  242.     THEN
  243.       BEGIN
  244.         writeln('Filename must be of format xyymm.ttt');
  245.         writeln('  where x is any letter,');
  246.         writeln('  yymm is a 4-digit number for year and month,');
  247.         writeln('       (like 8402 for February 1984) ');
  248.         writeln('  and ttt is a valid file type.');
  249.         writeln;
  250.         error('Please correct and re-do');
  251.       END;
  252. END:
  253.  
  254. PROCEDURE get_day;
  255.  
  256. VAR
  257.   ch: char;
  258. BEGIN
  259.   day := 0;
  260.   ch := copy(txt,1,1);
  261.   WHILE (ch IN ['0'..'9']) DO
  262.     BEGIN
  263.       day := 10*day + ord(ch) - ord('0');
  264.       shave(txt,1);
  265.       ch := copy(txt,1,1);
  266.     END;
  267.   shave(txt,1);
  268. END;
  269.  
  270. PROCEDURE get_schedules;
  271. BEGIN
  272.   max_lines := 0;
  273.   getrec;
  274.   more_txt := true;
  275.   WHILE (more_txt) DO
  276.     BEGIN
  277.       get_day;
  278.       IF ((day<1) OR (day>days_in_month[mm]))
  279.         THEN
  280.           BEGIN
  281.             write('*** Invalid day, text will ');
  282.             writeln('not be included in calendar');
  283.           END
  284.         ELSE
  285.           BEGIN
  286.             segleft (txt,dw);
  287.             schedule[day] := schedule[day]+txt;
  288.             curr_lines := length(schedule[day]) DIV dw;
  289.             IF (curr_lines>max_lines)
  290.               THEN
  291.                 max_lines := curr_lines;
  292.           END;
  293.       getrec;
  294.     END;
  295.     
  296.   IF (max_lines>15)
  297.     THEN max_lines := 15;
  298.     
  299. END;
  300.  
  301. PROCEDURE underline;
  302.  
  303. VAR i: integer;
  304. BEGIN
  305.   write('|');
  306.   FOR i:=1 TO 6 DO
  307.     BEGIN
  308.       write(copy(dashes,1,dw));
  309.       write('+');
  310.     END;
  311.   write(copy(dashes,1,dw));
  312.   writeln('|');
  313. END;
  314.  
  315. PROCEDURE set_up_calendar;
  316. BEGIN
  317.   IF (yy MOD 4 = 0)
  318.     THEN
  319.       BEGIN
  320.         days_in_month[02] := 29;
  321.         leap_year := true
  322.       END
  323.     ELSE
  324.       BEGIN
  325.         days_in_month[02] := 28;
  326.         leap_year := false
  327.       END;
  328.       
  329.   base := 0;
  330.   FOR i:=1 TO mm-1 DO
  331.     base := base+days_in_month[i];
  332.     
  333.   start_of_month := yy + (yy DIV 4) + base + 1;
  334.   IF (leap_year)
  335.     THEN
  336.       start_of_month := start_of_month-1;
  337.       
  338.   start_of_month := start_of_month MOD 7;
  339.   start_of_week := 1-start_of_month;
  340.   
  341.   no_of_weeks := (days_in_month[mm] = start_of_month) DIV 7;
  342.   IF ((days_in_month[mm] + start_of_month) MOD 7 > 0)
  343.     THEN
  344.       no_of_weeks := no_of_weeks+1;
  345. END;
  346.  
  347. PROCEDURE print_calendar:
  348. BEGIN
  349.   IF (listout)
  350.     THEN
  351.       BEGIN
  352.         system(nocons);
  353.         system(list);
  354.       END;
  355.   writeln;
  356.   writeln(1900+yy,month_name[mm]:10);
  357.   writeln;
  358.   underline;
  359.   write('|');
  360.   FOR wk_day:=sun TO sat DO
  361.     BEGIN
  362.       wstr := day_of_week[wk_day]+blanks;
  363.       wstr := copy(wstr,1,dw);
  364.       write(wstr);
  365.       write('|');
  366.     END;
  367.   writeln;
  368.   
  369.   underline;
  370.   
  371.   FOR week:=1 TO no_of_weeks DO
  372.     BEGIN
  373.       write('|');
  374.       day := start_of_week;
  375.       FOR wk_day:=sun TO sat DO
  376.         BEGIN
  377.           IF ((day<1) OR (day>days_in_month[mm]))
  378.             THEN
  379.               write(copy(blanks,1,dw))
  380.             ELSE
  381.               BEGIN
  382.                 write(copy(blanks,1,dw-3));
  383.                 write(day:3);
  384.               END;
  385.           write('|');
  386.           day := day+1;
  387.         END;{FOR}
  388.         
  389.       writeln;
  390.       
  391.       FOR j:=1 TO max_lines DO
  392.         BEGIN
  393.           write('|');
  394.           day := start_of_week;
  395.           FOR wk_day:=sun TO sat DO
  396.             BEGIN
  397.                schedule[day] := schedule[day]+copy(blanks,1,dw);
  398.                write(copy(schedule[day],1,dw));
  399.                write('|');
  400.                shave(schedule[day],dw);
  401.                day := day+1;
  402.              END;
  403.            writeln;
  404.          END;
  405.          
  406.        underline;
  407.        start_of_week := start_of_week+7;
  408.      END;
  409.    writeln;
  410.    writeln('Source: ',infile);
  411.    write(chr(0ch));
  412.    IF (listout)
  413.      THEN
  414.        BEGIN
  415.          system(cons);
  416.          system(nolist);
  417.        END;
  418.  END;
  419.  
  420.  BEGIN {calendar}
  421.    init;
  422.    
  423.    write('Enter Input File Name ==> ');
  424.    readln(infile);
  425.    infile := infile+copy(blanks,1,14-length(infile));
  426.    writeln;
  427.    writeln;
  428.    
  429.    write('Output to Printer? (y/n) ==> ');
  430.    readln(yorn);
  431.    writeln;
  432.    IF (upcase(yorn)='Y')
  433.      THEN listout := true
  434.      ELSE listout := false;
  435.      
  436.    REPEAT
  437.      writeln;
  438.      write('Enter width of display line ==> ');
  439.      readln(ls);
  440.    UNTIL ((ls>0) AND (ls<133));
  441.    dw := ls DIV 7 - 1;
  442.    writeln;
  443.    
  444.    get_infile;
  445.    reset(fin,infile,binary,256);
  446.    
  447.    FOR i:=-5 TO 37 DO
  448.      schedule[i] := '';
  449.      
  450.    get_schedules;
  451.    
  452.    set_up_calendar;
  453.    
  454.    print_calendar;
  455.    
  456.    close(fin);
  457.  END.
  458.