[Virtual Pascal] Virtual Pascal et Delphi

[Roland Chastain]

Bonjour !

Je m'intéresse depuis quelque temps à la programmation Win32 que j'ai essayée, avec VP d'un côté, avec Delphi de l'autre. Maintenant j'essaie de fondre les deux versions de mes programmes dans un seul fichier.

Je n'ai pas trouvé comment compiler un fichier PAS avec Delphi ; en revanche j'ai constaté que Virtual Pascal compile les fichiers DPR.

Je vous propose un programme qui affiche la date de Pâques pour l'année courante (à partir d'une table contenant les années 1900 à 2199). La compilation a été testée avec Virtual Pascal 2.1 et Delphi 6.

La seule partie du code que j'ai dédoublée est relative à l'année courante. Virtual Pascal ne reconnaissant pas, apparemment, le type SystemTime, j'ai bricolé ce que j'ai pu provisoirement.

Autre chose que je n'ai pas trouvée, l'équivalent Delphi du $IfDef VPascal ou du $IfDef FPC. J'ai vu comment on pouvait indiquer une version de Delphi mais pas l'environnement Delphi en général.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
// PAQUES.DPR
// Delphi 6, Free Pascal 2.6, Virtual Pascal 2.1
 
program Paques;
 
{$IFDEF VPASCAL}
  {&PMTYPE PM}
{$ELSE}
  {$APPTYPE GUI}
{$ENDIF}
 
uses
  Windows, Messages, SysUtils;
 
{$I Paques.inc}
{$I Couleurs.inc}
 
var
  t: tSystemTime;
  c: array[0..99] of char;
 
procedure MainPaint(hWindow: HWND; ps: TPaintStruct);
 
  function f(s: string): string;
  var
    temp: string;
  begin
    temp := Copy(s, 1, 1);
    if temp = 'M' then temp := 'mars' else temp := 'avril';
    temp := Copy(s, 2, 2) + ' ' + temp;
    f := temp;
  end;
 
var
  NewFont, OldFont: hFont;
  s: string;
  r: tRect;
 
begin
  NewFont := CreateFont(20,
                        0,0,0,
                        FW_LIGHT,
                        0,0,0,
                        DEFAULT_CHARSET,
                        0,0,0,0,
                        'Courier New');
 
  OldFont := SelectObject(ps.hdc, NewFont);
 
  SetTextColor(ps.hdc, White);
  SetBkMode(ps.hdc, Transparent);
 
  GetLocalTime(t);
 
  s := 'En '
     + IntToStr(t.wYear)
     + ', le dimanche de Pâques est le '
     + f(DateDePaques[t.wYear])
     + '.'
     ;
 
  StrPCopy(c, s);
  SetRect(r, 10, 10, 640-20, 300-20);
  DrawText(ps.hdc, c, StrLen(c), r, DT_LEFT);
  DeleteObject(SelectObject(ps.hdc, OldFont));
end;
 
procedure MainDestroy(hWindow: HWND);
begin
  PostQuitMessage(0);
end;
 
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                     LParam: LPARAM): LRESULT; stdcall; export;
var
  ps: TPaintStruct;
begin
  MainWndProc := 0;
  case Msg of
    WM_PAINT: begin
                BeginPaint(hWindow, ps);
                MainPaint(hWindow, ps);
                EndPaint(hWindow, ps);
              end;
    WM_DESTROY: MainDestroy(hWindow);
  else begin
         MainWndProc := DefWindowProc(hWindow, Msg, wParam, lParam);
         Exit;
       end;
  end;
end;
 
var
  wc: TWndClass;
  hWindow: HWND;
  Msg: TMsg;
 
begin
  wc.lpszClassName := 'GenericAppClass';
  wc.lpfnWndProc := @MainWndProc;
  wc.style := CS_VREDRAW or CS_HREDRAW;
  wc.hInstance := hInstance;
  wc.hIcon := LoadIcon(0, IDI_APPLICATION);
  wc.hCursor := LoadCursor(0, IDC_ARROW);
  wc.hbrBackground := CreateSolidBrush(RoyalBlue);
  wc.lpszMenuName := nil;
  wc.cbClsExtra := 0;
  wc.cbWndExtra := 0;
  RegisterClass(wc);
  hWindow := CreateWindowEx(WS_EX_OVERLAPPEDWINDOW,
                            wc.lpszClassName,
                            'Date de Pâques',
                            WS_OVERLAPPEDWINDOW,
                            10,
                            10,
                            640+16,
                            300+38,
                            0,
                            0,
                            hInstance,
                            nil);
  ShowWindow(hWindow, CmdShow);
  UpDateWindow(hWindow);
  while GetMessage(Msg, 0, 0, 0) do
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
  Halt(Msg.wParam);
end.

[Alcatîz]

Bonjour,

Le type TSystemTime est défini ainsi dans la RTL de Virtual Pascal :

Code :

1
2
3
4
5
6
7
8
9
10
11
  PSystemTime = ^TSystemTime;
  TSystemTime = record
    wYear:         SmallWord;
    wMonth:        SmallWord;
    wDayOfWeek:    SmallWord;
    wDay:          SmallWord;
    wHour:         SmallWord;
    wMinute:       SmallWord;
    wSecond:       SmallWord;
    wMilliseconds: SmallWord;
  end;

Et j'ai trouvé cette remarque dans l'aide de Delphi 7 :

Use TSystemTime to represent SYSTEMTIME values when making Windows 32 API function calls.

Ceci pourrait peut-être t'aider ?

Pour une directive genre $IFDEF Delphi, je n'ai rien trouvé non plus.

[Roland Chastain]

Envoyé par Alcatîz

Ceci pourrait peut-être t'aider ?

Cela résout parfaitement le problème. Merci pour l'indication.

J'ai écrit un petit programme en mode console pour essayer la chose, et effectivement ça fonctionne aussi avec Delphi et FreePascal sans qu'on ait à changer quoi que ce soit.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
 
{ Delphi 6 - Free Pascal 2.6 - Virtual Pascal 2.1 }
 
program HeureLocale; {.DPR }
 
{$IFDEF VPASCAL}
  {&PMTYPE VIO}
{$ELSE}
  {$APPTYPE CONSOLE}
{$ENDIF}
 
uses
  Windows, SysUtils;
 
var
  t: tSystemTime;
 
const
  NomDuJour: array[0..6] of string = ('dimanche',
                                      'lundi',
                                      'mardi',
                                      'mercredi',
                                      'jeudi',
                                      'vendredi',
                                      'samedi');
 
  NomDuMois: array[1..12] of string = ('janvier',
                                       'f'#130'vrier',
                                       'mars',
                                       'avril',
                                       'mai',
                                       'juin',
                                       'juillet',
                                       'ao'#150't',
                                       'septembre',
                                       'octobre',
                                       'novembre',
                                       'd'#130'cembre');
 
begin
  GetLocalTime(t);
 
  WriteLn(NomDuJour[ t.wDayOfWeek ]
          + ' ' +
          IntToStr( t.wDay )
          + ' ' +
          NomDuMois[ t.wMonth ]
          + ' ' +
          IntToStr( t.wYear )
          );
 
  ReadLn;
end.

[Roland Chastain]

Bonjour !

Je continue mes recherches sur un style de programmation compatible avec les principaux compilateurs Pascal. Je trouve l'idée très intéressante et si je propose ici mes exemples, ce n'est pas que je prétende avoir quelque chose de neuf à proposer, mais c'est plutôt pour recueillir les connaissances des uns et des autres.

Voici un essai d'adaptation de l'exemple GENERIC.DPR de Delphi 1. (J'ai téléchargé Delphi 1 sur ce site.) J'ai refait le fichier "res", et remplacé les endroits du code qui ne passaient pas. Malheureusement, je n'ai pas réussi à compiler avec Free Pascal : pour certaines erreurs j'avais une solution mais pas pour toutes. Si vous y arrivez, faites-le moi savoir.

L'archive ci-jointe (9 Ko) contient l'exécutable, le code et les ressources.

[Roland Chastain]

Bonsoir !

Voici un programme dans lequel j'ai voulu réunir quelques connaissances sur la ligne de commande.

Le programme s'utilise en faisant glisser au moyen de la souris un fichier texte sur l'exécutable. Une copie du fichier est produite, dans laquelle toutes les majuscules ont été remplacées... par des minuscules.

Le programme s'exécute sans ouvrir de console. Aucune unité n'a été déclarée, et le code se compile aussi bien avec TP7 (exécutable incroyablement petit par rapport aux autres !) qu'avec Delphi XE2. (Toutefois avec TP7 je n'ai pas trouvé comment empêcher la console de s'ouvrir.)

Pour éviter un avertissement de Delphi XE2 concernant la fonction Chr(), j'ai écrit une procédure de remplacement :

Code :

1
2
3
const
  alphabet_min: string = 'abcdefghijklmnopqrstuvwxyz';
  alphabet_maj: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';

Cela m'a rappelé de très justes observations qui m'avaient été faites sur ce sujet de la portabilité et de l'avantage d'employer des caractères entre guillemets plutôt que des codes.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
 
program Minuscules;
 
{$IfDef FPC}
{$AppType Gui}
{$EndIf}
 
{$IfDef Ver140}{$AppType Gui}{$EndIf}
{$IfDef Ver150}{$AppType Gui}{$EndIf}
{$IfDef Ver230}{$AppType Gui}{$EndIf}
 
{$IfDef VPascal}
{&PmType Pm}
{$Endif}
 
{$R Icone}
 
{$I Min.inc}
{$I Extract.inc}
 
var
  sPath: string; { 'C:\Atelier\Pascal\Minuscules\Sample.pas' }
  sDir : string; { 'C:\Atelier\Pascal\Minuscules\'           }
  sName: string; { 'Sample'                                  }
  sExt : string; { '.pas'                                    }
 
procedure FileProc(const nf1, nf2: string);
var
  t1, t2: text;
  s: string;
begin
  Assign(t1, nf1);
  Assign(t2, nf2);
  Reset(t1);
  Rewrite(t2);
  while not Eof(t1) do
  begin
    ReadLn(t1, s);
    Min(s);
    WriteLn(t2, s);
  end;
  Close(t1);
  Close(t2);
end;
 
begin
  if ParamCount > 0 then
  begin
    sPath := ParamStr(1);
    Extract(sPath, sDir, sName, sExt);
    FileProc(sDir + sName + sExt, sDir + sName);
  end;
end.

[Roland Chastain]

Bonjour !

Je vous propose un nouvel exemple de code utilisant l'API win32. Comme dans l'exemple précédent, le programme affiche la date de Pâques pour l'année courante mais cette fois il va la lire directement dans le fichier texte que j'ai laissé tel quel.

J'ai refait aussi l'interface. A la place d'une fenêtre j'ai mis une simple boîte de message.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
 
program Easter;
 
{ Affiche la date de Pâques pour l'année courante, au moyen de la
  procédure MessageBox() de l'API win32. La date est tirée d'une table
  contenant les années 1900 à 2199.
  Compilation testée : Virtual Pascal 2.1, Delphi 6. }
 
{$IFDEF VPASCAL}
{$PMTYPE PM}
{$ELSE}
{$APPTYPE GUI}
{$ENDIF}
 
{$R delphi}
 
uses
  windows,{$IFDEF VPASCAL} strings,{$ELSE} sysutils,{$ENDIF} estr_tbl;
 
procedure ShowMessage(aMsg: string);
const
  ttl: pAnsiChar = '';
var
  msg: array[0..79] of char;
begin
  StrPCopy(msg, aMsg);
  MessageBox(0, msg, ttl, MB_OK);
end;
 
const
  s1 = 'En ';
  s2 = ', le dimanche de Pâques est le ';
  s3 = '.';
 
var
  t: tSystemTime;
  s: string;
 
begin
  GetLocalTime(t);
  Str(t.wYear, s);
  s := s1 + s + s2 + reader.EasterDate(t.wYear) + s3;
  ShowMessage(s);
end.

Envoyé par Roland Chastain

Je n'ai pas trouvé comment compiler un fichier PAS avec Delphi

Avec Delphi 6 on peut, en passant par le menu "Ouvrir un projet" et en choisissant l'option "projet Pascal".

[Roland Chastain]

Pour ma procédure ShowMessage, je viens de trouver une variante qui me permet de ne pas utiliser l'unité Strings.

Code :

1
2
3
4
5
6
7
procedure ShowMessage(msg: string);
const
  ttl: pAnsiChar = '';
begin
  msg := Concat(msg, #0);
  MessageBox(0, pAnsiChar(@msg[1]), ttl, MB_OK);
end;

J'ai trouvé la solution dans ce message.

[Paul TOTH]

Envoyé par Roland Chastain

Pour ma procédure ShowMessage, je viens de trouver une variante qui me permet de ne pas utiliser l'unité Strings.

Code :

J'ai trouvé la solution dans ce message.

alors Concat() existe, mais c'est tout simplement l'addition de strings

msg := msg + #0;

note que sous Delphi les strings sont des pointeurs qui possèdent déjà un #0 terminal (je ne sais pas si c'est le cas sous VP), tu peux donc tout simplement transtyper un string en PChar : PChar(msg).

et pour ttl, tu dois pouvoir passer "nil" à la place...oui la chaîne '' en dur qui sera traitée comme un PChar (par Delphi en tout cas)

[Roland Chastain]

Merci Paul pour ces indications.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
program ShowMessage2;
 
{$IFDEF VPASCAL}
{&PMTYPE PM}
{$ELSE}
{$APPTYPE GUI}
{$ENDIF}
 
uses
  windows;
 
procedure ShowMessage(msg: string);
begin
  {$IFDEF VPASCAL}
  msg := msg + Chr(0);
  MessageBox(0, pAnsiChar(@msg[1]), '', MB_OK);
  {$ELSE}
  MessageBox(0, pAnsiChar(msg), '', MB_OK);
  {$ENDIF}
end;
 
var
  s: string;
 
begin
  s := 'Bonjour!';
  ShowMessage(s);
end.

[Roland Chastain]

J'ai écrit un petit programme pour mémoriser les principales fonctions de l'unité Strings.

Ces fonctions (pardon si vous le savez déjà) sont disponibles dans Delphi. Il n'y a que le nom de l'unité qui soit différent. Au lieu de dédoubler la déclaration des unités, j'ai ajouté un alias dans les options de mon projet Delphi : Strings=SysUtils;

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
{ D'après "La programmation Win32 en Virtual Pascal avec OWL" par Alcatîz. }
{ Compilateurs utilisés : VP 2.1, Delphi 6. }
 
{$IFDEF VPASCAL}{&PMTYPE VIO}{$ELSE}{$APPTYPE CONSOLE}{$ENDIF}
 
uses
  Strings;
 
procedure Traitement(p: pChar);
begin
end;
 
var
  chaine, chaine2: array[0..10] of char;
  pChaine: pChar;
  caractere: char;
  adresse: pChar;
  string1: string;
 
begin
{ Equivalences remarquables. }
  pChaine := chaine;
  pChaine := @chaine;
  pChaine := 'ab';
  caractere := chaine[6];
  caractere := pChaine[6];
  Traitement(chaine);
  Traitement(pChaine);
  Traitement('ab');
{ Fonctions de l'unité Strings/SysUtils. }
  StrCopy(chaine, 'abc');
  WriteLn(chaine);                               // abc
  chaine[2] := Chr(0);
  WriteLn(chaine);                               // ab
  WriteLn(StrLen(chaine));                       // 2
  StrCopy(chaine2, chaine);
  WriteLn(chaine2);                              // ab
  StrCopy(chaine2, chaine);
  WriteLn(chaine2);                              // ab
  WriteLn(StrComp(chaine,chaine2));              // 0
  StrCopy(chaine2, 'aB');
  WriteLn(chaine2);                              // aB
  WriteLn(chaine);                               // ab
  WriteLn(StrComp(chaine,chaine2));              // 32
  WriteLn(StrIComp(chaine,chaine2));             // 0
  WriteLn(StrPos(chaine,'b'));                   // b
  adresse := StrPos(chaine,'a');
  WriteLn(adresse-chaine);                       // 0
  StrCat(chaine,chaine2);
  WriteLn(chaine);                               // abaB
  StrLCat(chaine,'cccccccccc',SizeOf(chaine)-1);
  WriteLn(chaine);                               // abaBcccccc
  string1 := StrPas(chaine);
  WriteLn(string1);                              // abaBcccccc
  string1 := 'ab';
  StrPCopy(chaine, string1);
  WriteLn(chaine);                               // ab
  ReadLn;
end.

[Roland Chastain]

En ce Mercredi-Saint, je vous propose une version retravaillée de mon programme "date de Pâques".

J'ai ajouté une fonction qui renvoie une date relative au jour de Pâques d'une année donnée. Les arguments de la fonction sont l'année et la différence de jours. Cela permet de connaître, par exemple, la date du mercredi des Cendres (46 jours avant Pâques).

La partie interface est réutilisable : il suffit de mettre ce que vous voulez à la place de l'unité u_paques.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
 
program p_Paques;
 
{ Date de Pâques pour l'année courante.
 
  Virtual Pascal 2.1, Delphi 6, FreePascal 2.6.2. }
 
 
{$IFDEF VPASCAL}
{&PMTYPE PM}
uses
  windows, strings, couleurs, u_paques;
{$ELSE}
{$APPTYPE GUI}
uses
  windows, messages, sysutils, couleurs, u_paques;
{$ENDIF}
 
{$IFDEF VPASCAL}
function currentyear: word;
var
  t: tsystemtime;
begin
  getlocaltime(t);
  result := t.wyear;
end;
{$ENDIF}
 
procedure mainpaint(hw: hwnd; ps: tpaintstruct);
var
  s: string;
  c: array[0..255] of char;
  newfont, oldfont: hfont;
  r: trect;
  y: word;
 
begin
  y := currentyear;
 
  s := 'Cendres   : ' + f_chaine(f_relativepaques(y, -46)) + #13
     + 'Pâques    : ' + f_chaine(f_relativepaques(y,   0)) + #13
     + 'Ascension : ' + f_chaine(f_relativepaques(y, +39)) + #13
     + 'Pentecôte : ' + f_chaine(f_relativepaques(y, +49));
 
  setbkmode(ps.hdc, transparent);
  //setbkcolor(ps.hdc, black);
  settextcolor(ps.hdc, snow);
 
  newfont := createfont(20, 0,0,0,
                        fw_normal, 0,0,0,
                        default_charset, 0,0,0,0,
                        'courier');
 
  oldfont := selectobject(ps.hdc, newfont);
 
  getclientrect(hw, r);
  inc(r.left, 10);
  inc(r.top, 10);
  inc(r.right, 10);
  inc(r.bottom, 10);
 
  strpcopy(c, s);
  drawtext(ps.hdc, c, strlen(c), r, dt_left);
 
  deleteobject(selectobject(ps.hdc, oldfont));
end;
 
procedure maindestroy(hw: hwnd);
begin
  postquitmessage(0);
end;
 
function mainwndproc(hw: hwnd; msg: uint; wp: wparam; lp: lparam): lresult; stdcall; export;
var
  ps: tpaintstruct;
begin
  result := 0;
  case msg of
    wm_paint: begin
                beginpaint(hw, ps);
                mainpaint(hw, ps);
                endpaint(hw, ps);
              end;
    wm_destroy: maindestroy(hw);
  else begin
         result := defwindowproc(hw, msg, wp, lp);
         exit;
       end;
  end;
end;
 
var
  wc: twndclass;
  hw: hwnd;
  msg: tmsg;
 
begin
  wc.lpszclassname := 'app_win32';
  wc.lpfnwndproc   := @mainwndproc;
  wc.style         := cs_vredraw or cs_hredraw;
  wc.hinstance     := hinstance;
  wc.hicon         := loadicon(0, idi_application);
  wc.hcursor       := loadcursor(0, idc_arrow);
  //wc.hbrbackground := getstockobject(black_brush);
  wc.hbrbackground := createsolidbrush(darkindigo);
  wc.lpszmenuname  := nil;
  wc.cbclsextra    := 0;
  wc.cbwndextra    := 0;
  registerclass(wc);
  hw := createwindowex(ws_ex_toolwindow,
                       wc.lpszclassname,
                       'Date de Pâques pour l''année courante',
                       ws_visible or ws_clipsiblings or ws_clipchildren or ws_overlappedwindow,
                       0,
                       0,
                       594,
                       420,
                       0,
                       0,
                       hinstance,
                       nil);
  showwindow(hw, cmdshow);
  updatewindow(hw);
  while getmessage(msg, 0, 0, 0) do
  begin
    translatemessage(msg);
    dispatchmessage(msg);
  end;
  halt(msg.wparam);
end.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
 
unit u_Paques;
 
interface
 
type
  t_Date = record
             s, j, m, a: word;
           end;
 
{ s = jour de la semaine = 1..7
  j = jour du mois       = 1..31
  m = mois               = 1..12
  a = année              = 1900..2199 }
 
function f_Paques(a: word): t_Date;
function f_RelativePaques(a: word; d: integer): t_Date;
function f_Chaine(d: t_Date): string;
 
implementation
 
const
  DIMANCHE = 1;
  LUNDI = 2;
  MARDI = 3;
  MERCREDI = 4;
  JEUDI = 5;
  VENDREDI = 6;
  SAMEDI = 7;
 
  NOMSDESJOURS: array[DIMANCHE..SAMEDI]of string = ('dimanche', 'lundi', 'mardi', 'mercredi',
  'jeudi', 'vendredi', 'samedi');
 
  JANVIER = 1;
  FEVRIER = 2;
  MARS = 3;
  AVRIL = 4;
  MAI = 5;
  JUIN = 6;
  JUILLET = 7;
  AOUT = 8;
  SEPTEMBRE = 9;
  OCTOBRE = 10;
  NOVEMBRE = 11;
  DECEMBRE = 12;
 
  NOMSDESMOIS: array[JANVIER..DECEMBRE]of string = ('janvier', 'février', 'mars', 'avril', 'mai',
  'juin', 'juillet', 'août', 'septembre', 'octobre', 'novembre', 'décembre');
 
  PAQUES: array[0..299]of word = (
{ Date du dimanche de Pâques de 1900 à 2199 }
    46,38,30,43,34,54,46,31,50,42,
    27,47,38,23,43,35,54,39,31,51,
    35,27,47,32,51,43,35,48,39,31,
    51,36,27,47,32,52,43,28,48,40,
    24,44,36,56,40,32,52,37,28,48,
    40,25,44,36,49,41,32,52,37,29,
    48,33,53,45,29,49,41,26,45,37,
    29,42,33,53,45,30,49,41,26,46,
    37,50,42,34,53,38,30,50,34,26,
    46,31,50,42,34,47,38,30,43,35,
    54,46,31,51,42,27,47,39,23,43,
    35,55,39,31,51,36,27,47,32,52,
    43,35,48,40,31,51,36,28,47,32,
    52,44,28,48,40,25,44,36,56,41,
    32,52,37,29,48,40,25,45,36,49,
    41,33,52,37,29,49,33,53,45,30,
    49,41,26,46,37,29,42,34,53,45,
    30,50,41,26,46,38,50,42,34,54,
    38,30,50,35,26,46,31,51,42,34,
    47,39,30,43,35,55,46,31,51,43,
    28,48,40,25,44,36,49,41,32,52,
    37,29,48,33,53,45,29,49,41,26,
    45,37,29,42,33,53,45,30,49,41,
    26,46,37,50,42,34,53,38,30,50,
    34,26,46,31,50,42,34,47,38,30,
    43,35,54,46,31,51,42,27,47,39,
    23,43,35,55,39,31,51,36,27,47,
    32,52,43,35,48,40,31,51,36,28,
    47,32,52,44,28,48,40,25,44,36,
    56,41,32,52,37,29,48,40,25,45);
 
function f_Paques(a: word): t_Date;
{ Fonction qui renvoie la date de Pâques, pour une année comprise entre 1900 et 2199. La date est
  extraite d'une table. }
begin
  if a < 1900 then a := 1900;
  if a > 2199 then a := 2199;
 
  result.s := DIMANCHE;
 
  if PAQUES[a-1900] < 32 then
  begin
    result.j := PAQUES[a-1900];
    result.m := MARS;
  end else
  begin
    result.j := PAQUES[a-1900] - 31;
    result.m := AVRIL;
  end;
 
  result.a := a;
end;
 
{const
  N: array[1..12]of word = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);}
 
type
  t_NombreJours = array[boolean, 1..12]of word;
 
const
  N: t_NombreJours = (
    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
    (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31));
 
function Bissext(a: word): boolean;
{ Fonction pour savoir si une année est bissextile. }
begin
  result := ((a mod 4=0) and not((a mod 100=0) and not(a mod 400=0)));
end;
 
function f_RelativePaques(a: word; d: integer): t_Date;
{ Calcule une date relative à la date de Pâques, pour une année comprise entre 1900 et 2199. Le
  paramètre d est la différence de jours. }
var
  p: t_Date;
  vs, vj, vm, va: word;
 {vn: array[1..12]of word;}
  b: boolean;
  i: integer;
begin
  if a < 1900 then a := 1900;
  if a > 2199 then a := 2199;
 
  p := f_Paques(a);
 
  vs := p.s;
  vj := p.j;
  vm := p.m;
  va := p.a;
 
 {for i := 1 to 12 do
    vn[i] := N[i];
 
  if Bissext(a) then
    Inc(vn[FEVRIER]);}
 
  b := Bissext(a);
 
  if d < 0 then i := -1 else i := +1;
 
  while Abs(d) > 0 do
  begin
    Dec(d, i);
 
    Inc(vs, i);
 
    if vs = 0 then
      vs := SAMEDI;
 
    if vs = 8 then
      vs := DIMANCHE;
 
    Inc(vj, i);
 
    if vj = 0 then
    begin
      Dec(vm);
      if vm = 0 then
      begin
        Dec(va);
        vm := DECEMBRE;
      end;
     {vj := vn[vm];}
      vj := N[b, vm];
    end;
 
   {if vj > vn[vm] then}
    if vj > N[b, vm] then
    begin
      Inc(vm);
      if vm = 13 then
      begin
        Inc(va);
        vm := JANVIER;
      end;
      vj := 1;
    end;
 
  end;
 
  result.s := vs;
  result.j := vj;
  result.m := vm;
  result.a := va;
end;
 
function IntToStr(i: word): string;
begin
  Str(i, result);
end;
 
function f_Chaine(d: t_Date): string;
begin
  result := NOMSDESJOURS[d.s] + ' ' + IntToStr(d.j) + ' ' + NOMSDESMOIS[d.m] + ' ' + IntToStr(d.a);
end;
 
end.

[droggo]

Boa,

Pour le nombre de jours par mois, au lieu de

Code :

1
2
const
  N: array[1..12]of word = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

et plus loin

Code :

1
2
  if Bissext(a) then
    Inc(vn[FEVRIER]);

j'aurais plutôt fait

Code :

1
2
3
4
5
const
  N: array[boolean][1..12]of word = ( 
                                      (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31),
                                      (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) 
                                     );

et adapter le code.

Et bien entendu, en pratique j'aurais déclaré un type, puis une constante de ce type (toujours anticiper qu'on puisse devoir passer des données en paramètre, et c'est bien plus simple avec un type déclaré).

[Roland Chastain]

Merci droggo pour le coup d'œil et pour l'idée. J'ai fait la modification.