Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECO_CAL.PAS

Pascal/Delphi Source File | 1992-06-08 | 10.4 KB | 315 lines

(*
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   ECO_CAL was Conceived, Designed and Written      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   by Floor A.C. Naaijkens for                      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (C) MCMXCII BY EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
*)
{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}

unit eco_cal;


interface


  procedure calendaraction;



implementation




  procedure calendaraction;
  const
    maxyear = 2150;
    minyear = 1850;

    c_72_spaties = '                                    ' +
                   '                                    ';
    c_8_spaties  = '        ';      c_wo  = '   WO   ';
    c_zo         = '   ZO   ';      c_do  = '   DO   ';
    c_ma         = '   MA   ';      c_vr  = '   VR   ';
    c_di         = '   DI   ';      c_za  = '   ZA   ';

    c_jan        = ' JANUARI  ';    c_jul = '   JULI   ';
    c_feb        = ' FEBRUARI ';    c_aug = ' AUGUSTUS ';
    c_mrt        = '  MAART   ';    c_sep = 'SEPTEMBER ';
    c_apr        = '  APRIL   ';    c_okt = ' OKTOBER  ';
    c_mei        = '   MEI    ';    c_nov = ' NOVEMBER ';
    c_jun        = '   JUNI   ';    c_dec = ' DECEMBER ';


  type
    t_c2  = packed array [1.. 2] of char;
    t_c3  = packed array [1.. 3] of char;
    t_c7  = packed array [1.. 7] of char;
    t_c8  = packed array [1.. 8] of char;
    t_c10 = packed array [1..10] of char;
    t_c32 = packed array [1..32] of char;
    t_c72 = packed array [1..72] of char;

    t_maandinfo  = packed record
      voorloopspaties,
      naloopspaties   : t_c3;
      weekdagen       : packed array [0..5] of t_c3;
    end;

    t_maandkop   = packed record
      voorloopspaties    :  t_c7;
      maandnaam          : t_c10;
      naloopspaties      :  t_c7;
    end;

    t_mogelijkheid = 1..4;
    t_regel = packed record
      weekdag                : t_c8;
      case t_mogelijkheid of
        1: ( regel_totaal    : t_c72);
        2: ( voorloop        : t_c32;
             jaartal         : t_c8;
             naloop          : t_c32
           );
        3: ( kopregel        : packed array [1..3] of t_maandkop);
        4: ( maandinfo       : packed array [1..3] of t_maandinfo);
    end;

    t_e_maand = (
      e_jan, e_feb, e_mrt, e_apr, e_mei, e_jun,
      e_jul, e_aug, e_sep, e_okt, e_nov, e_dec
    );


  var
    sunweekstart : boolean;
    kalender     :    text;
    kwartaal     : integer;
    jaar         : integer;

    (*
     * fuctie dagfactor is een oude bekende. deze functie is onder andere
     * gebruikt in het programma datum --> weekdag conversie
     * uit de 6502 kenner nr. 53. dit betrof toen een versie in c.
     *
     * het algoritme is afkomstig uit de programma rom van een ti 58
     * rekenmachine.
     *
     * dagfactor berekent bij de ingevoerde dag, maand en jaar een dagnummer.
     * dit dagnummer is uniek. door het dagnummer modulo 7 te nemen, krijgen
     * we een getal dat de dag in de week aangeeft. hierbij krijgt de zondag
     * de waarde nul. door voor de deling 1 van het dagnummer af te trekken,
     * wordt er voor gezorgd dat de week begint op maandag.
     *
     * de datum wordt in waarde- (value) parameters doorgegeven, de dag in
     * de week wordt als referentie- (reference) parameter teruggegeven dit wil
     * zeggen dat bij de aanroep het startadres van de parameter doorgegeven
     * wordt. deze variabele kan dus door dagfactor gewijzigd worden.
     *
     * als functieresultaat wordt doorgegeven of de ingevoerde datum bestaat
     * en of het jaartal in het vastgestelde gebied ligt.
     *)




    function dagfactor(
      p_dag         :   integer;
      p_maand       : t_e_maand;
      p_jaar        :   integer;
      var p_weekdag :   integer
    ): boolean;

    var
      factor        : integer;
      parameters_ok : boolean;
      klad          : integer;

    begin
      parameters_ok := (p_jaar >= minyear) and (p_jaar <= maxyear);
      if parameters_ok then case p_maand of
        e_jan,e_mrt,e_mei,e_jul,e_aug,e_okt,e_dec :
          parameters_ok := (p_dag >= 1) and (p_dag <= 31);
        e_apr,e_jun,e_sep,e_nov :
          parameters_ok := (p_dag >= 1) and (p_dag <= 30);
        e_feb :
          if (
            (p_jaar mod 4 = 0) and
            (( p_jaar mod 100 <> 0) or ( p_jaar mod 400 = 0))
          ) then parameters_ok := (p_dag >= 1) and (p_dag <= 29) else
            parameters_ok := (p_dag >= 1) and (p_dag <= 28);
      end;

      if parameters_ok then begin
        klad := p_jaar - 1985 ;
        factor := 365 * klad - 4 + p_dag + 31 * (ord(p_maand) - ord(e_jan));
        if p_maand <= e_feb then begin
          factor := factor +
            (p_jaar - 1) div 4 - 3 * ((p_jaar - 1) div 100 + 1) div 4
        end else begin
          factor := factor -
            (4 * (ord(p_maand) - ord(e_jan) + 1) + 23) div 10 +
            p_jaar div 4 - 3 * (p_jaar div 100 + 1) div 4
        end;
        if sunweekstart then p_weekdag := (factor{ - 1}) mod 7 else
          p_weekdag := (factor - 1) mod 7; { monday  day 0 }
      end;
      dagfactor := parameters_ok;
    end;




    procedure jaartal(p_jaar : integer);
    var
      regel : t_regel;
      i     : integer;

    begin
      if (p_jaar < minyear) or (p_jaar > maxyear) then begin
        writeln('Year wrong', p_jaar);
      end else with regel do begin
        weekdag := c_8_spaties;
        regel_totaal := c_72_spaties;
        for i := 3 downto 0 do begin
          jaartal[2 * i + 1] := chr((p_jaar mod 10) + ord('0'));
          p_jaar := p_jaar div 10;
        end;
        writeln(weekdag, regel_totaal);
        writeln(kalender, weekdag,regel_totaal);
      end;
    end;




    procedure kopregel(p_kwartaal : integer);
    var
      regel : t_regel;

    begin
      writeln;  writeln(kalender);
      writeln;  writeln(kalender);
      if (p_kwartaal < 1) or (p_kwartaal > 4) then begin
        writeln('Quarterly wrong ',p_kwartaal);
      end else with regel do begin
        weekdag      := c_8_spaties;
        regel_totaal := c_72_spaties;
        case p_kwartaal of
          1: begin
            kopregel[1].maandnaam := c_jan;
            kopregel[2].maandnaam := c_feb;
            kopregel[3].maandnaam := c_mrt
          end;
          2: begin
            kopregel[1].maandnaam := c_apr;
            kopregel[2].maandnaam := c_mei;
            kopregel[3].maandnaam := c_jun
          end;
          3: begin
            kopregel[1].maandnaam := c_jul;
            kopregel[2].maandnaam := c_aug;
            kopregel[3].maandnaam := c_sep
          end;
          4: begin
            kopregel[1].maandnaam := c_okt;
            kopregel[2].maandnaam := c_nov;
            kopregel[3].maandnaam := c_dec
          end;
        end;
        writeln(weekdag,regel_totaal);
        writeln(kalender,weekdag,regel_totaal)
      end;
      writeln; writeln(kalender)
    end;




    procedure dataregels(p_kwartaal, p_jaar: integer);
    var
      startdagen     : array [1..3] of integer;
      maanden        : array [1..3] of t_e_maand;
      i,j,k,i_weekdag: integer;
      dag            : integer;
      regel          : t_regel;

    begin
      if (p_kwartaal >= 0) and (p_kwartaal <= 4) then begin
        case p_kwartaal of
          1: maanden[1] := e_jan;
          2: maanden[1] := e_apr;
          3: maanden[1] := e_jul;
          4: maanden[1] := e_okt;
        end;
        maanden[2] := succ(maanden[1]); maanden[3] := succ(maanden[2]);
        for i:= 1 to 3 do if not dagfactor(1,maanden[i],p_jaar,i_weekdag) then begin
          writeln(kalender, 'error'); halt;
        end else startdagen[i] := 1 - i_weekdag;
        with regel do for k := 0 to 6 do begin
          regel_totaal := c_72_spaties;
          if sunweekstart then case k of
            0: weekdag := c_zo;
            1: weekdag := c_ma;
            2: weekdag := c_di;
            3: weekdag := c_wo;
            4: weekdag := c_do;
            5: weekdag := c_vr;
            6: weekdag := c_za
          end else case k of
            0: weekdag := c_ma;
            1: weekdag := c_di;
            2: weekdag := c_wo;
            3: weekdag := c_do;
            4: weekdag := c_vr;
            5: weekdag := c_za;
            6: weekdag := c_zo
          end;
          for j := 1 to 3 do for i := 0 to 5 do begin
            dag := startdagen[j] + 7 * i + k;
            if dagfactor(dag,maanden[j],p_jaar,i_weekdag) then begin
              maandinfo[j].weekdagen[i,3] := chr(dag mod 10 + ord('0'));
              if dag >= 10 then maandinfo[j].weekdagen[i, 2] :=
                chr(dag div 10 + ord('0'));
            end;
          end;
          writeln(weekdag,regel_totaal);
          writeln(kalender,weekdag,regel_totaal);
       end;
      end;
    end; { dataregels }


  begin
    sunweekstart := true;
    assign(kalender, 'KALENDER.LIS');
    rewrite(kalender);
    repeat
      write('Geef een jaartal j: ',minyear,' <= j <= ',maxyear,' : ');
      readln(jaar);
    until (jaar >= minyear) and (jaar <= maxyear);
    jaartal(jaar);
    for kwartaal := 1 to 4 do begin
      kopregel(kwartaal); dataregels(kwartaal, jaar)
    end;
    close(kalender)
  end; { proc action }



end. { unit }