UTILIT.PAS

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

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

INTERFACE

USES Dos;

type
 BChai4      = string[4];
 BChai5      = string[5];
 BEnsemble   = set of byte;
 BPrecis1    = double;
 Bprecis2    = double;

const
 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',
                                        'juil','aout','sept','octo','nove','dece');
 BTresNegatif= -1e+20;
 BTresPositif= 1e+20;

var
 BNom          : string;
 BNom1         : string;
 BNom2         : string;
 BMauv         : boolean;
 BCode         : integer;
 BCode1        : integer;
 BCode2        : integer;
 BCode3        : integer;
 Ax            : integer;
 Ay            : integer;

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;

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

IMPLEMENTATION


procedure B_Datation(var Zou:text);
 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;

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

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

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

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

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

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

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

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

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

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

function  B_MinDouble (ZD1,ZD2:Bprecis1) :Bprecis1;
 begin if ZD2<ZD1 then B_MinDouble :=ZD2 else B_MinDouble :=ZD1; end;

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

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.                                                           }
 var XL : integer;
 begin
  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;
 end;

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

function B_DateClaire(ZAnnee,ZQuant:integer):BChai5;
{---Calcul de la date en format jj.mm  partir du quantime annuel, pour ---}
{---anne bissextile ou non.                                             ---}
 var
  XS,Xi:integer;
  XC   :BChai5;
 begin
  XS:=0;Xi:=0;
  repeat
   Xi:=Xi+1; XS:=XS+B_LongMois(Zannee,Xi);
  until XS>=ZQuant;
  str((ZQuant-XS+B_LongMois(ZAnnee,Xi)+Xi/100):5:2,XC); if XC[1]=' ' then XC[1]:='0';
  B_DateClaire:=XC;
 end;

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

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.                                              --}
 var Xi,XS:integer;
 begin
  Xs:=0;
  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);
 end;

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

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).
 An est entr en anne sur 4 chiffres. Le calcul est  valable de 1901  2099.
 Remarquer que 1900 n'est pas bissextile}
{--obsolte--corrig 2000}
 const
  XN: array[1..12] of integer = (0,31,59,90,120,151,181,212,243,273,304,334);
 var XDeb: longint;
 begin
  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;
 end;

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


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.}

{--obsolte--corrig 2000}

 var
  Xi,Xj,Xk    :integer;
  XDat        :Bprecis2;
  XS1,XS2,XS3 : string[4];
  XDuree      :longint;

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

 function XNombjour(Zi:integer):integer;
  begin
   {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
   else XNombjour:=365;
  end;

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

 begin
  {Xi:=1899;}
  Xi:=1599;
  XDuree:= 0;
  while XDuree< ZRang do
   begin
    Xi:=Xi+1; XDuree:=XDuree+XNombjour(Xi);
   end;
  XDuree:=XDuree-XNombjour(Xi);
  Xj:=0;
  while XDuree<ZRang do
   begin
    Xj:=Xj+1; XDuree:=XDuree+B_Longmois(Xi,Xj);
   end;
  XDuree:=XDuree-B_Longmois(Xi,Xj);
  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);
  B_Date:=XS1+'/'+XS2+'/'+XS3;
 end;

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

BEGIN
END.