UTILIT.PAS 7.04 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

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;
48
function  B_Longmois (ZMois:integer):integer;
49
function  B_DateClaire (ZQuant:integer):BChai5; {date en clair  partir du quantieme}
50
function  B_Quantieme (Zjour,Zmois:integer):integer;
51
52
53
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
function B_Longmois(ZMois:integer):integer;
105
{donne le nombre de jours du mois en anne de 365 jours                     }
106
107
 var XL : integer;
 begin
108
  B_LongMois:=BLong[ZMois];
109
110
111
112
 end;

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

113
function B_DateClaire(ZQuant:integer):BChai5;
114
115
{---Calcul de la date en format jj.mm  partir du quantime annuel, pour ---}
{---anne bissextile ou non.                                             ---}
116
117
 var
  XS,Xi:integer;
118
  XC   :BChai5;
119
120
121
 begin
  XS:=0;Xi:=0;
  repeat
122
   Xi:=Xi+1; XS:=XS+B_LongMois(Xi);
123
  until XS>=ZQuant;
124
  str((ZQuant-XS+B_LongMois(Xi)+Xi/100):5:2,XC); if XC[1]=' ' then XC[1]:='0';
125
  B_DateClaire:=XC;
126
127
128
129
 end;

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

130
function B_Quantieme(Zjour,Zmois:integer): integer;
131
132
{--calcul du quantime  partir du jour, du mois et de l'anne, pour une --}
{--anne bissextile ou non.                                              --}
133
134
135
 var Xi,XS:integer;
 begin
  Xs:=0;
136
  for Xi:=1 to ZMois-1 do Xs:=XS+B_LongMois(Xi);
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
  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);
155
  B_QuantiemeNonBiss:=B_Quantieme(XJour,XMois);
156
157
158
159
 end;

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

160
function B_Tjour(ZAn,ZMois,ZJour:longint):longint;
161
{calcul du nombre de jours couls depuis le 01/01/0000 (nombre = 1),  --}
162
{partir de l'anne, du mois et du jour. le calcul est valable  partir  --}
163
{en anne non bissextiles                                               --}
164
165
166
 const
  XN: array[1..12] of integer = (0,31,59,90,120,151,181,212,243,273,304,334);
 begin
167
  B_Tjour := XN[ZMois]+Zjour+ZAn*365;
168
169
170
171
172
 end;

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


173
174
175
176
177
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.}
178

179
{--obsolte--corrig 2000}
180
181
182

 var
  Xi,Xj,Xk    :integer;
183
  XDat        :Bprecis2;
184
185
186
187
188
189
190
  XS1,XS2,XS3 : string[4];
  XDuree      :longint;

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

 function XNombjour(Zi:integer):integer;
  begin
191
192
193
   {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
194
195
196
197
198
199
   else XNombjour:=365;
  end;

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

 begin
200
201
202
  {Xi:=1899;}
  Xi:=1599;
  XDuree:= 0;
203
204
205
206
  while XDuree< ZRang do
   begin
    Xi:=Xi+1; XDuree:=XDuree+XNombjour(Xi);
   end;
207
208
  XDuree:=XDuree-XNombjour(Xi);
  Xj:=0;
209
210
  while XDuree<ZRang do
   begin
211
    Xj:=Xj+1; XDuree:=XDuree+B_Longmois(Xj);
212
   end;
213
  XDuree:=XDuree-B_Longmois(Xj);
214
215
216
217
218
219
220
221
  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);
222
  B_Date:=XS1+'/'+XS2+'/'+XS3;
223
224
225
226
227
228
 end;

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

BEGIN
END.
229