home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 19 / CD_ASCQ_19_010295.iso / dos / prg / pas / ktools / source / ocalend.pas < prev    next >
Pascal/Delphi Source File  |  1994-11-16  |  11KB  |  455 lines
  1. Unit OCalend;
  2. { calendrier }
  3. { K.B., novembre 1994 }
  4.  
  5. {$IFDEF debug}
  6.  {$A+,B-,D+,E-,F-,I+,L+,N-,R+,S+,V-,W+,X+}
  7. {$ELSE}
  8.  {$A+,B-,D-,E-,F-,I+,L-,N-,R-,S-,V-,W+,X+}
  9. {$ENDIF}
  10.  
  11. INTERFACE
  12.  
  13. Uses Dos, UDrivers, UTextScr,
  14.      OTableau, OChamp,
  15.      OGenView, OTxtView;
  16.  
  17. Const
  18.  NbrMaxJours =365;
  19.  TabJours:Array[0..6] of String[8]=
  20.    ('Dimanche','Lundi','Mardi','Mercredi','Jeudi','Vendredi','Samedi');
  21.  TabMois :Array[1..12] of String[10]=
  22.    ('Janvier','Février','Mars','Avril','Mai','Juin','Juillet',
  23.    'Août','Septembre','Octobre','Novembre','Décembre');
  24.  
  25. Function CalcCodeJour(J,M,A:Word):Word;
  26. { nombre de jours depuis le début du calendrier }
  27.  
  28. Function NbJoursAn(A:Word):Word;
  29. { nombre de jours de l'année }
  30.  
  31. Function NbJoursMois(M,A:Word):Word;
  32. { nombre de jours du mois }
  33.  
  34. Function NumJour(J,M,A:Word):Word;
  35. { numéro du jour dans l'année }
  36.  
  37. Function CalcPaques(A:Word):Integer;
  38. { numéro du jour de Pâques }
  39.  
  40. Function DonneNomFichier(A:Word):String;
  41. { nom du fichier associé à l'année }
  42.  
  43. Function MakeCal(A:Word):PStrTab;
  44. { initialisation des données de l'année,
  45.   création d'un nouveau fichier si nécessaire }
  46.  
  47. Type
  48.  PCalendWin=^TCalendWin;
  49.  TCalendWin=object(TWindow)
  50.   TabEvent : PStrTab;
  51.   Champ : PChamp;
  52.   SelJ,SelM,SelA:Integer;
  53.   ChangeHeader:Boolean;
  54.   Constructor Init;
  55.   Destructor Done; virtual;
  56.   Procedure DrawInterior; virtual;
  57.   Procedure BackGround; virtual;
  58.   Procedure HandleEvent(var Event:TEvent); virtual;
  59.   Procedure NewYear(n:Integer);
  60.   Procedure NewMonth(n:Integer);
  61.   Procedure NewDay(n:Integer);
  62.   Procedure ToDay;
  63.   Function  NumDay(P:TPoint):Integer;
  64.   Procedure WriteEvent;
  65.   Procedure InitEd;
  66.   Procedure DoneEd;
  67.   Procedure DrawHeader;
  68.   End;
  69.  
  70. IMPLEMENTATION
  71.  
  72. Function CalcCodeJour(J,M,A:Word):Word;
  73. Var Na:Real;
  74. Begin
  75.  if M<3
  76.     then begin
  77.           Na:=(A-1)/100;
  78.           CalcCodeJour:=365*A+J+31*(M-1)+Trunc(Na*25)-Trunc(3/4*(Int(Na)+1));
  79.          end
  80.     else CalcCodeJour:=365*A+J+31*(M-1)-Trunc(0.4*M+2.3)+Trunc(A/4)
  81.                        -Trunc(3/4*(Int(A/100)+1));
  82. End;
  83.  
  84. Function NbJoursAn(A:Word):Word;
  85. Begin
  86.  NbJoursAn:=CalcCodeJour(1,1,A+1)-CalcCodeJour(1,1,A);
  87. End;
  88.  
  89. Function NbJoursMois(M,A:Word):Word;
  90. Begin
  91.  NbJoursMois:=CalcCodeJour(1,M+1,A)-CalcCodeJour(1,M,A);
  92. End;
  93.  
  94. Function NumJour(J,M,A:Word):Word;
  95. Begin
  96.  NumJour:=CalcCodeJour(J,M,A)-CalcCodeJour(1,1,A)+1;
  97. End;
  98.  
  99. Function CalcPaques(A:Word):Integer;
  100. { calcul de la date de Pâques selon la méthode de Spender Jones }
  101. Var R01,R02,R03,R04,R05,R06,R07,R08,R09,R10,R11,R12 :Integer;
  102. Begin
  103.  R01:=A mod 19;
  104.  R02:=A div 100;
  105.  R03:=A mod 100;
  106.  R04:=R02 div 4;
  107.  R05:=R02 mod 4;
  108.  R06:=(8+R02) div 25;
  109.  R07:=(1+R02-R06) div 3;
  110.  R08:=15+19*R01+R02-R04-R07;
  111.  R08:=R08 mod 30;
  112.  R09:=R03 div 4;
  113.  R10:=R03 mod 4;
  114.  R11:=32+2*(R05+R09)-R08-R10;
  115.  R11:=R11 mod 7;
  116.  R12:=(R01+11*R08+22*R11) div 451;
  117.  CalcPaques:=NumJour(21,3,A)+R08+R11-7*R12+1;
  118. End;
  119.  
  120. Function DonneNomFichier(A:Word):String;
  121. Var s:String;
  122. Begin
  123.  Str(a,s);
  124.  DonneNomFichier:=s+'.CLD';
  125. End;
  126.  
  127. Function MakeCal(A:Word):PStrTab;
  128. Var i:Word;
  129.     Paques:Integer;
  130.     Nf:String;
  131.     TabEvent:PStrTab;
  132. Begin
  133.  Nf:=FSearch(DonneNomFichier(A),'');
  134.  if Nf=''
  135.     then begin   { fichier absent }
  136.           Nf:=DonneNomFichier(A);
  137.           TabEvent:=New(PStrTab,Init(366,5));
  138.           For i:=0 to NbrMaxJours do
  139.            TabEvent^.AjouterLigne('');
  140.           with TabEvent^ do
  141.            begin
  142.             ChangerLigne(1,'Nouvel an');
  143.             ChangerLigne(8-(CalcCodeJour(1,1,A) mod 7),'Epiphanie');
  144.             ChangerLigne(NumJour(1,5,A),'Fête du travail');
  145.             ChangerLigne(NumJour(8,5,A),'Victoire 1945');
  146.             i:=7-(CalcCodeJour(8,5,A) mod 7);
  147.             if i<>7
  148.                then ChangerLigne(1+NumJour(8,5,A)+i,'Fête Jeanne d''Arc');
  149.             ChangerLigne(NumJour(14,7,A),'Fête nationale');
  150.             ChangerLigne(NumJour(15,8,A),'Assomption');
  151.             ChangerLigne(NumJour(1,11,A),'Toussaint');
  152.             ChangerLigne(NumJour(11,11,A),'Armistice 1918');
  153.             ChangerLigne(NumJour(25,12,A),'Noël');
  154.             Paques:=CalcPaques(A);
  155.             ChangerLigne(Paques-42,'Carême');
  156.             ChangerLigne(Paques-7,'Rameaux');
  157.             ChangerLigne(Paques,'Pâcques');
  158.             ChangerLigne(Paques+1,'Lundi de Pâcques');
  159.             ChangerLigne(Paques+39,'Ascension');
  160.             ChangerLigne(Paques+49,'Pentecôte');
  161.             ChangerLigne(Paques+50,'Lundi de Pentecôte');
  162.             ChangerLigne(Paques+63,'Fête Dieu');
  163.            end;
  164.          end
  165.     else TabEvent:=New(PStrTab,Load(Nf));
  166.  MakeCal:=TabEvent;
  167. End;
  168.  
  169. { objet TCalendWin }
  170.  
  171. Constructor TCalendWin.Init;
  172. Var w1,w2,w3,w4 : Word;
  173. Begin
  174.  TWindow.Init(2,2,36,19,'');
  175.  Ident:='CALWIN';
  176.  ChangeHeader:=true;
  177.  Champ:=nil;
  178.  GetDate(w1,w2,w3,w4);
  179.  SelA:=w1;
  180.  SelM:=w2;
  181.  SelJ:=w3;
  182.  TabEvent:=MakeCal(SelA);
  183. End;
  184.  
  185. Destructor TCalendWin.Done;
  186. Begin
  187.  if Champ<>nil
  188.     then dispose(Champ,Done);
  189.  dispose(TabEvent,Done);
  190.  TWindow.Done;
  191. End;
  192.  
  193. Procedure TCalendWin.ToDay;
  194. Var w1,w2,w3,w4:Word;
  195. Begin
  196.  GetDate(w1,w2,w3,w4);
  197.  if w1<>SelA
  198.     then NewYear(w1);
  199.  SelA:=w1;
  200.  SelM:=w2;
  201.  SelJ:=w3;
  202.  ChangeHeader:=true;
  203. End;
  204.  
  205. Procedure TCalendWin.DrawHeader;
  206. Var S : String;
  207.     x,y : Byte;
  208. Begin
  209.  Str(SelA,S);
  210.  S:=TabMois[SelM]+' '+S;
  211.  while length(S)<Largeur do S:=' '+S+' ';
  212.  if length(S)>Largeur then dec(S[0]);
  213.  Ecrire(S,1,1,0);
  214.  For x:=0 to 6 do
  215.   For y:=0 to 5 do Ecrire('    ',1+5*x,5+2*y,0);
  216.  ChangeHeader:=false;
  217. End;
  218.  
  219. Procedure TCalendWin.DrawInterior;
  220. Var x,y,c:Byte;
  221.     I,J1:Word;
  222.     S:String;
  223. Begin
  224.  c:=0;
  225.  { nom du mois }
  226.  if ChangeHeader
  227.     then DrawHeader;
  228.  J1:=CalcCodeJour(1,SelM,SelA);
  229.  x:=1+5*(J1 mod 7);
  230.  y:=5;
  231.  For i:=1 to NbJoursMois(SelM,SelA) do
  232.   begin
  233.    str(i,S);
  234.    if length(S)=1 then S:=' '+S;
  235.    S:=' '+S+' ';
  236.    if i=SelJ
  237.       then c:=1;
  238.    Ecrire(S,x,y,c);
  239.    if i=SelJ
  240.       then begin
  241.             c:=0;
  242.             WriteEvent;
  243.            end;
  244.    inc(x,5);
  245.    if x>34
  246.       then begin
  247.             x:=1;
  248.             inc(y,2);
  249.            end;
  250.   end;
  251. End;
  252.  
  253. Procedure TCalendWin.BackGround;
  254. Var i,j,c:Byte;
  255. Begin
  256.  TWindow.BackGround;
  257.  c:=0;
  258.  { jours de la semaine }
  259.  Ecrire(SDS,0,2,c);
  260.  For i:=0 to 6 do Ecrire(THS+THS+THS+THS+TTS,1+5*i,2,c);
  261.  Ecrire(SGS,35,2,c);
  262.  For i:=0 to 6 do Ecrire(TVS+' '+copy(TabJours[i],1,2)+' ',5*i,3,c);
  263.  Ecrire(TVS,35,3,c);
  264.  { numéros des jours }
  265.  Ecrire(SDS,0,4,c);
  266.  For i:=0 to 6 do Ecrire(THS+THS+THS+THS+CrS,1+5*i,4,c);
  267.  Ecrire(SGS,35,4,c);
  268.  For j:=1 to 6 do
  269.   begin
  270.    For i:=0 to 6 do Ecrire(TVS+'    ',5*i,3+2*j,c);
  271.    Ecrire(TVS,35,3+2*j,c);
  272.    Ecrire(SDS,0,4+2*j,c);
  273.    For i:=0 to 6 do Ecrire(THS+THS+THS+THS+CrS,1+5*i,4+2*j,c);
  274.    Ecrire(SGS,35,4+2*j,c);
  275.   end;
  276.  For i:=1 to 6 do Ecrire(TIS,5*i,16,c);
  277. End;
  278.  
  279. Procedure TCalendWin.NewMonth(n:Integer);
  280. Begin
  281.  ChangeHeader:=true;
  282.  SelM:=SelM+n;
  283.  if SelM<=0
  284.     then begin
  285.           repeat
  286.            dec(SelA);
  287.            SelM:=12+SelM;
  288.           until SelM>0;
  289.           NewYear(SelA);
  290.          end;
  291.  if SelM>12
  292.     then begin
  293.           repeat
  294.            inc(SelA);
  295.            SelM:=SelM-12;
  296.           until SelM<=12;
  297.           NewYear(SelA);
  298.          end;
  299. End;
  300.  
  301. Procedure TCalendWin.NewYear(n:Integer);
  302. Var P:TPoint;
  303.     S:String;
  304. Begin
  305.  dispose(TabEvent,Done);
  306.  TabEvent:=MakeCal(n);
  307.  DrawHeader;
  308. End;
  309.  
  310. Procedure TCalendWin.NewDay(n:Integer);
  311. Begin
  312.  SelJ:=SelJ+n;
  313.  if SelJ<=0
  314.     then begin
  315.           NewMonth(-1);
  316.           SelJ:=NbJoursMois(SelM,SelA)+SelJ;
  317.          end;
  318.  if SelJ>NbJoursMois(SelM,SelA)
  319.     then begin
  320.           SelJ:=SelJ-NbJoursMois(SelM,SelA);
  321.           NewMonth(1);
  322.          end;
  323. End;
  324.  
  325. Procedure TCalendWin.InitEd;
  326. Var WS : String;
  327.     P  : TPoint;
  328. Begin
  329.  WS:=TabEvent^.Ligne(NumJour(SelJ,SelM,SelA));
  330.  Champ:=New(PChamp,Init(WS,80,Largeur));
  331.  Ecrire(Champ^.GetDrawString,1,17,0);
  332.  MakeGlobal(Origin,P);
  333.  SetCursorPos(P.X+Champ^.XScr,P.Y+17);
  334.  SetCursorType(NormalCursor);
  335. End;
  336.  
  337. Procedure TCalendWin.DoneEd;
  338. Begin
  339.  SetCursorType(BlankCursor);
  340.  WriteEvent;
  341.  dispose(Champ,Done);
  342.  Champ:=nil;
  343. End;
  344.  
  345. Procedure TCalendWin.WriteEvent;
  346. Var S : String;
  347. Begin
  348.  S:=TabEvent^.Ligne(NumJour(SelJ,SelM,SelA));
  349.  Ajuste(S,Largeur);
  350.  Ecrire(S,1,17,0);
  351. End;
  352.  
  353. Function TCalendWin.NumDay(P:TPoint):Integer;
  354. Begin
  355.  NumDay:=0;
  356.  if (P.X mod 5 = 0) or (P.Y mod 2 = 0)
  357.     then exit;
  358.  NumDay:=(P.X div 5) + 7*((P.Y-4) div 2) - (CalcCodeJour(1,SelM,SelA) mod 7)+1;
  359. End;
  360.  
  361. Procedure TCalendWin.HandleEvent(var Event:TEvent);
  362. Var r : Word;
  363.     P : TPoint;
  364.     n : Integer;
  365. Begin
  366.  if (Event.What=evKeyDown) and (Champ<>nil)
  367.     then begin
  368.           r:=Champ^.Exec(Event.KeyCode);
  369.           if r=Ret
  370.              then begin
  371.                    TabEvent^.ChangerLigne(NumJour(SelJ,SelM,SelA),
  372.                                         Champ^.Renvoi);
  373.                    PTextApp(Application)^.Patience('Sauvegarde en cours ...');
  374.                    TabEvent^.Save(DonneNomFichier(SelA));
  375.                    PTextApp(Application)^.FinPatience;
  376.                   end;
  377.           if (r=Ret) or (r=Echap)
  378.              then DoneEd
  379.              else begin
  380.                    Ecrire(Champ^.GetDrawString,1,17,0);
  381.                    MakeGlobal(Origin,P);
  382.                    SetCursorPos(P.X+Champ^.XScr,P.Y+17);
  383.                   end;
  384.           if Event.KeyCode<>AltX
  385.              then Event.What:=evNothing;
  386.          end;
  387.  TWindow.HandleEvent(Event);
  388.  case Event.What of
  389.   evCommand :
  390.     case Event.Command of
  391.      cmSave : TabEvent^.Save(DonneNomFichier(SelA));
  392.      else exit;
  393.      end;
  394.   evMouseLUp :
  395.    begin
  396.     if Etat and stSelected=0
  397.        then exit;
  398.     MakeLocal(Origin,P);
  399.     P.X:=MouseX-P.X;
  400.     P.Y:=MouseY-P.Y;
  401.     if MouseInView
  402.        then begin
  403.              if P.Y=17
  404.                 then begin
  405.                       InitEd;
  406.                       exit;
  407.                      end;
  408.              if Champ<>nil
  409.                 then DoneEd;
  410.              if P.Y=0
  411.                 then NewMonth(-1)
  412.                 else if P.Y=2
  413.                         then NewMonth(1)
  414.                         else if P.Y>4
  415.                                 then begin
  416.                                       n:=NumDay(P);
  417.                                       if (n>0) and (n<=NbJoursMois(SelM,SelA))
  418.                                          then NewDay(n-SelJ)
  419.                                          else exit;
  420.                                      end
  421.                                 else exit;
  422.             end
  423.        else exit;
  424.    end;
  425.   evKeyDown :
  426.    begin
  427.     if Etat and stSelected=0
  428.        then exit;
  429.     case Event.KeyCode of
  430.      CsRg : NewDay(1);
  431.      CsLf : NewDay(-1);
  432.      CsUp : NewDay(-7);
  433.      CsDn : NewDay(7);
  434.      PgDn : NewMonth(1);
  435.      PgUp : NewMonth(-1);
  436.      Home : ToDay;
  437.      AltS : TabEvent^.Save(DonneNomFichier(SelA));
  438.      Inser: InitEd;
  439.      Ret  : InitEd;
  440.      else exit;
  441.      end;
  442.    end;
  443.   else exit;
  444.   end;
  445.  if SelJ>NbJoursMois(SelM,SelA)
  446.     then SelJ:=NbJoursMois(SelM,SelA);
  447.  if Champ=nil
  448.     then DrawInterior;
  449.  Event.What:=evNothing;
  450. End;
  451.  
  452. END.
  453.  
  454. {                        Fin du fichier OCalend.Pas                         }
  455.