UTILIT.PAS 8.09 KB
Newer Older
1
2
3
4
5
6
7
8
9
10

Unit Utilit;   {dclarations gnrales hors interface cran clavier, adapt de Amanan1}

{=============================================================================}

INTERFACE

USES Dos;

type
11
12
13
14
15
 BChai4      = string[4];
 BChai5      = string[5];
 BEnsemble   = set of byte;
 BPrecis1    = double;
 Bprecis2    = double;
16
17

const
18
19
20
 BJour_An    = 365;
 BLong       : array[1..12] of integer  =(31,28,31,30,31,30,31,31,30,31,30,31);
 BSMois      : array[1..12] of string[4]=('janv','fevr','mars','avri','mai ','juin',
21
                                        'juil','aout','sept','octo','nove','dece');
22
23
 BTresNegatif= -1e+20;
 BTresPositif= 1e+20;
24
25

var
26
27
28
29
30
31
32
33
 BNom          : string;
 BNom1         : string;
 BNom2         : string;
 BMauv         : boolean;
 BCode         : integer;
 BCode1        : integer;
 BCode2        : integer;
 BCode3        : integer;
34
35
 Ax            : integer;
 Ay            : integer;
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

procedure B_Datation (var Zou:text);
function  B_MaxExt(ZR1,ZR2:Extended):Extended;
function  B_MinExt(ZR1,ZR2:Extended):Extended;
function  B_Max (ZR1,ZR2:Bprecis2):Bprecis2;
function  B_Min (ZR1,ZR2:Bprecis2):Bprecis2;
function  B_MaxIn (ZI1,ZI2:integer):integer;
function  B_MinIn (ZI1,ZI2:integer):integer;
function  B_MaxLongInt (ZD1,ZD2:Longint):longint;
function  B_MinLongInt (ZD1,ZD2:longint):longint;
function  B_MaxDouble (ZD1,ZD2:Bprecis1) :Bprecis1;
function  B_MinDouble (ZD1,ZD2:Bprecis1) :Bprecis1;
function  B_Longmois (ZAn,ZMois:integer):integer;
function  B_DateClaire (ZAnnee,ZQuant:integer):BChai5; {date en clair  partir du quantieme}
function  B_Quantieme (Zjour,Zmois,ZAnnee:integer):integer;
function  B_QuantiemeNonBiss(ZDate:longint):integer;
function  B_Tjour (ZAn,ZMois,ZJour:longint):longint;
function  B_Date (ZRang:longint):string;
54
55
56
57
58
59

{============================================================================}

IMPLEMENTATION


60
procedure B_Datation(var Zou:text);
61
62
63
64
65
66
67
68
69
70
71
 var XHeure,XMinute,XSeconde,XSec100,XAnnee,XMois,XJour,XJour_Semaine: word;
 begin
  getdate(XAnnee,XMois,XJour,XJour_Semaine);
  gettime(XHeure,XMinute,XSeconde,XSec100);
  writeln(Zou);
  writeln(Zou,'le  ',XJour,'-',XMois,'-',XAnnee,' a  ',XHeure,'H',XMinute,'mn',XSeconde,'''',XSec100,'''','''');
 end;

{----------------------------------------------------------------------------}

{----------------------------------------------------------------------------}
72
73
function  B_MaxExt(ZR1,ZR2:Extended):Extended;
 begin if ZR1>ZR2 then B_MaxExt:=ZR1 else B_MaxExt:=ZR2; end;
74

75
76
function  B_MinExt(ZR1,ZR2:Extended):Extended;
 begin if ZR1<ZR2 then B_MinExt:=ZR1 else  B_MinExt:=ZR2; end;
77

78
79
function  B_Max(ZR1,ZR2:Bprecis2):Bprecis2;
 begin if ZR1>ZR2 then B_Max:=ZR1 else B_Max:=ZR2; end;
80

81
82
function  B_Min(ZR1,ZR2:Bprecis2):Bprecis2;
 begin if ZR1<ZR2 then B_Min:=ZR1 else  B_Min:=ZR2; end;
83

84
85
function  B_MaxIn(ZI1,ZI2:integer):integer;
 begin if ZI1>ZI2 then B_Maxin:=ZI1 else  B_Maxin:=ZI2; end;
86

87
88
function  B_MinIn(ZI1,ZI2:integer):integer;
 begin if ZI1<ZI2 then B_MinIn:=ZI1 else  B_MinIn:=ZI2; end;
89

90
91
function  B_MaxLongInt(ZD1,ZD2:Longint):longint;
 begin if ZD2>ZD1 then B_MaxLongInt:=ZD2 else B_MaxLongInt:=ZD1; end;
92

93
94
function  B_MinLongInt(ZD1,ZD2:longint):longint;
 begin if ZD2<ZD1 then B_MinLongInt:=ZD2 else B_MinLongInt:=ZD1; end;
95

96
97
function  B_MaxDouble (ZD1,ZD2:Bprecis1) :Bprecis1;
 begin if ZD2>ZD1 then B_MaxDouble :=ZD2 else B_MaxDouble :=ZD1; end;
98

99
100
function  B_MinDouble (ZD1,ZD2:Bprecis1) :Bprecis1;
 begin if ZD2<ZD1 then B_MinDouble :=ZD2 else B_MinDouble :=ZD1; end;
101
102
103

{----------------------------------------------------------------------------}

104
105
106
107
108
function B_Longmois(ZAn,ZMois:integer):integer;
{donne le nombre de jours du mois Mois de l'annee An, en tenant compte pour }
{fvrier du caractre bissextile ou non de l'anne. Une anne est bissextile}
{si elle est multiple de 4 et non divisible par 100, ou bien si elle est    }
{multiple de 400.                                                           }
109
110
 var XL : integer;
 begin
111
112
113
114
115
116
117
  XL:=BLong[ZMois];
  {if (ZMois=2) and ((ZAn mod 4) = 0) then XL:=XL+1;}
  if (ZMois=2) and
     ((Zan mod 4) = 0) and
     (((Zan mod 100) <> 0) or ((Zan mod 400) = 0)) then
   XL:=XL+1;
  B_LongMois:=XL;
118
119
120
121
 end;

{----------------------------------------------------------------------------}

122
123
124
function B_DateClaire(ZAnnee,ZQuant:integer):BChai5;
{---Calcul de la date en format jj.mm  partir du quantime annuel, pour ---}
{---anne bissextile ou non.                                             ---}
125
126
 var
  XS,Xi:integer;
127
  XC   :BChai5;
128
129
130
 begin
  XS:=0;Xi:=0;
  repeat
131
   Xi:=Xi+1; XS:=XS+B_LongMois(Zannee,Xi);
132
  until XS>=ZQuant;
133
134
  str((ZQuant-XS+B_LongMois(ZAnnee,Xi)+Xi/100):5:2,XC); if XC[1]=' ' then XC[1]:='0';
  B_DateClaire:=XC;
135
136
137
138
 end;

{----------------------------------------------------------------------------}

139
140
141
function B_Quantieme(Zjour,Zmois,ZAnnee:integer): integer;
{--calcul du quantime  partir du jour, du mois et de l'anne, pour une --}
{--anne bissextile ou non.                                              --}
142
143
144
 var Xi,XS:integer;
 begin
  Xs:=0;
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
  for Xi:=1 to ZMois-1 do Xs:=XS+B_LongMois(ZAnnee,Xi);
  B_Quantieme:=XS+Zjour;
 end;

{----------------------------------------------------------------------------}

function B_QuantiemeNonBiss(ZDate:longint) : integer;
{--en fonction du nombre de jours ZDate couls depuis le 31/12/1599,   --}
{--calcule la date jj/mm/aaaa et donne le quantime de jj/mm/2001, c'est--}
{-- dire pour le mme jour et le mme mois d'une anne non bissextile  --}
 var
  XChaineDate: string;
  XJour      : integer;
  XMois      : integer;
  XCode      : integer;
 begin
  XChaineDate:=B_Date(ZDate);
  val(copy(XChaineDate,1,2),XJour,XCode);
  val(copy(XChaineDate,4,2),XMois,XCode);
  B_QuantiemeNonBiss:=B_Quantieme(XJour,XMois,2001);
165
166
167
168
 end;

{----------------------------------------------------------------------------}

169
170
171
172
173
function B_Tjour(ZAn,ZMois,ZJour:longint):longint;
{calcul du nombre de jours couls depuis le 31/12/1599 (nombre = 0),  --}
{partir de l'anne, du mois et du jour. le calcul est valable  partir  --}
{01/01/1600 (nombre = 1).                                               --}
{--obsolte--Calcule le numero du jour compt depuis le 31/12/1899 (1er jour).
174
175
 An est entr en anne sur 4 chiffres. Le calcul est  valable de 1901  2099.
 Remarquer que 1900 n'est pas bissextile}
176
{--obsolte--corrig 2000}
177
178
179
180
 const
  XN: array[1..12] of integer = (0,31,59,90,120,151,181,212,243,273,304,334);
 var XDeb: longint;
 begin
181
182
183
184
185
186
187
188
189
190
191
192
  ZAn:=Zan-1600;
  {XDeb:= XN[ZMois]+Zjour+1+ZAn*365+ ((ZAn-1) div 4);}
  XDeb:= XN[ZMois]+Zjour+ZAn*365
         + (B_maxin(0,ZAn-1)) div 4
         - (B_maxin(0,Zan-1)) div 100
         + (B_maxin(0,Zan-1)) div 400;
  if Zan>0 then
   XDeb:=Xdeb+1;
  if ((ZAn mod 4) = 0) and (ZMois > 2) then
   if ( ((Zan mod 100)<>0) or((Zan mod 400)=0) ) then
    XDeb:=XDeb+1;
  B_Tjour := XDeb;
193
194
195
196
197
 end;

{----------------------------------------------------------------------------}


198
199
200
201
202
function B_Date(ZRang:longint):string;
{--calcul de la date en clair  partir du nombre de jours couls depuis --}
{--le 31/12/1599 (nombre = 0).                                           --}
{--obsolte--calcul de la date en clair  partir du jour compt depuis le 31/12/1899.}
{--obsolte--Le calcul est valable  partir de 1901.}
203

204
{--obsolte--corrig 2000}
205
206
207

 var
  Xi,Xj,Xk    :integer;
208
  XDat        :Bprecis2;
209
210
211
212
213
214
215
  XS1,XS2,XS3 : string[4];
  XDuree      :longint;

{- - - - - - - - - - - - - - - - - - - - - - - -}

 function XNombjour(Zi:integer):integer;
  begin
216
217
218
   {if (Zi mod 4)=0 then XNombjour:=366}
   if ((Zi mod 4)=0) and (((Zi mod 100)<>0)or((Zi mod 400)=0)) then
    XNombjour:=366
219
220
221
222
223
224
   else XNombjour:=365;
  end;

{- - - - - - - - - - - - - - - - - - - - - - - -}

 begin
225
226
227
  {Xi:=1899;}
  Xi:=1599;
  XDuree:= 0;
228
229
230
231
  while XDuree< ZRang do
   begin
    Xi:=Xi+1; XDuree:=XDuree+XNombjour(Xi);
   end;
232
233
  XDuree:=XDuree-XNombjour(Xi);
  Xj:=0;
234
235
  while XDuree<ZRang do
   begin
236
    Xj:=Xj+1; XDuree:=XDuree+B_Longmois(Xi,Xj);
237
   end;
238
  XDuree:=XDuree-B_Longmois(Xi,Xj);
239
240
241
242
243
244
245
246
  Xk:=ZRang-XDuree;
  str(Xk,XS1);
  if Xk<10 then
   XS1:='0'+XS1;
  str(Xj,XS2);
  if Xj<10 then
   XS2:='0'+XS2;
  str(Xi:4,XS3);
247
  B_Date:=XS1+'/'+XS2+'/'+XS3;
248
249
250
251
252
253
 end;

{============================================================================}

BEGIN
END.
254