Virtual Pascal et Delphi

Version imprimable

1 pièce(s) jointe(s)

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.

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 :

Citation:

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. :(

Citation:

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.

16/09/2012, 14h19
Roland Chastain

1 pièce(s) jointe(s)

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. ;)

1 pièce(s) jointe(s)

Minuscules

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.

1 pièce(s) jointe(s)

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.
Citation:

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

12/02/2013, 23h46
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.
13/02/2013, 09h24
Paul TOTH
Citation:
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:

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

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.

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.

2 pièce(s) jointe(s)

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.

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é).

:)

28/03/2013, 02h22
Roland Chastain

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

1 pièce(s) jointe(s)

Bonjour !

Voici un programme qui joue un chant de Noël.

J'ai utilisé une procédure faisant appel à l'unité MMSystem.

La compilation a été testée avec Virtual Pascal et avec Delphi 7.

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
 
program Adeste;
 
{$IFDEF VPASCAL}{&PMTYPE VIO}{&USE32+}{$ELSE}{$APPTYPE CONSOLE}{$ENDIF}
 
uses
  Son, Frequences;
 
const
  re  =  2;
  mi  =  4;
  fa  =  6;
  sol =  7;
  la  =  9;
  si  = 11;
  ut  = 12;
  re8 = 14;
 
type
  note = record
    n: integer;
    d: integer;
    v: integer;
  end;
 
const
  notes: array[1..68]of note = (
    (n: sol; d: 2; v: 2),
    (n: sol; d: 4; v: 2),
    (n:  re; d: 2; v: 2),
    (n: sol; d: 2; v: 2),
    (n:  la; d: 4; v: 2),
    (n:  re; d: 4; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  ut; d: 2; v: 2),
    (n:  si; d: 4; v: 2),
    (n:  la; d: 2; v: 2),
    (n:   0; d: 1; v: 0),
    (n: sol; d: 1; v: 2),
    (n: sol; d: 4; v: 2),
    (n:  fa; d: 1; v: 2),
    (n:   0; d: 1; v: 0),
    (n:  mi; d: 2; v: 2),
    (n:  fa; d: 2; v: 2),
    (n: sol; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  fa; d: 4; v: 2),
    (n:  mi; d: 3; v: 2),
    (n:  re; d: 1; v: 2),
    (n:  re; d: 6; v: 2),
    (n:   0; d: 2; v: 0),
    (n: re8; d: 4; v: 2),
    (n:  ut; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  ut; d: 4; v: 2),
    (n:  si; d: 4; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n: sol; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  fa; d: 4; v: 2),
    (n:  re; d: 1; v: 2),
    (n:   0; d: 1; v: 0),
    (n: sol; d: 2; v: 1),
    (n: sol; d: 2; v: 1),
    (n:  fa; d: 2; v: 1),
    (n: sol; d: 2; v: 1),
    (n:  la; d: 2; v: 1),
    (n: sol; d: 4; v: 1),
    (n:  re; d: 1; v: 1),
    (n:   0; d: 1; v: 0),
    (n:  si; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  ut; d: 2; v: 2),
    (n:  si; d: 4; v: 2),
    (n:  la; d: 1; v: 2),
    (n:   0; d: 1; v: 0),
    (n:  si; d: 2; v: 3),
    (n:  ut; d: 2; v: 3),
    (n:  si; d: 1; v: 3),
    (n:   0; d: 1; v: 0),
    (n:  la; d: 2; v: 3),
    (n: sol; d: 2; v: 3),
    (n:  fa; d: 4; v: 3),
    (n: sol; d: 2; v: 3),
    (n:  ut; d: 2; v: 3),
    (n:  si; d: 4; v: 3),
    (n:  la; d: 3; v: 3),
    (n: sol; d: 1; v: 2),
    (n: sol; d: 8; v: 2)
  );
 
var
  i: integer;
 
begin
  for i := Low(notes) to High(notes) do
    with notes[i] do
      Jouer(f[n], 200 * d, 30 * v);
end.

1 pièce(s) jointe(s)

Voici une version MIDI. :)

Non seulement les possibilités sont supérieures (choix de l'instrument, polyphonie), mais le code sur lequel le programme est bâti est plus simple (comparé à la procédure utilisée dans le programme précédent) !

Je ne savais pas que c'était aussi facile de faire du MIDI.

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
 
unit Midi;
 
{&USE32+}
 
interface
 
type
  tMidiInstrument = (midiAcousticGrandPiano, midiBrightAcousticPiano,
                     midiElectricGrandPiano, midiHonkyTonkPiano,
                     midiRhodesPiano, midiChorusedPiano, midiHarpsichord,
                     midiClavinet, midiCelesta, midiGlockenspiel,
                     midiMusicBox, midiVibraphone, midiMarimba, midiXylophone,
                     midiTubularBells, midiDulcimer, midiHammondOrgan,
                     midiPercussiveOrgan, midiRockOrgan, midiChurchOrgan,
                     midiReedOrgan, midiAccordion, midiHarmonica,
                     midiTangoAccordion, midiAcousticGuitarNylon,
                     midiAcousticGuitarSteel, midiElectricGuitarJazz,
                     midiElectricGuitarClean, midiElectricGuitarMuted,
                     midiOverdrivenGuitar, midiDistortionGuitar,
                     midiGuitarHarmonics, midiAcousticBass, midiElectricBassFinger,
                     midiElectricBassPick, midiFretlessBass, midiSlapBass1,
                     midiSlapBass2, midiSynthBass1, midiSynthBass2, midiViolin,
                     midiViola, midiCello, midiContrabass, midiTremoloStrings,
                     midiPizzicatoStrings, midiOrchestralHarp, midiTimpani,
                     midiStringEnsemble1, midiStringEnsemble2, midiSynthStrings1,
                     midiSynthStrings2, midiChoirAahs, midiVoiceOohs,
                     midiSynthVoice, midiOrchestraHit, midiTrumpet, midiTrombone,
                     midiTuba, midiMutedTrumpet, midiFrenchHorn, midiBrassSection,
                     midiSynthBrass1, midiSynthBrass2, midiSopranoSax, midiAltoSax,
                     midiTenorSax, midiBaritoneSax, midiOboe, midiEnglishHorn,
                     midiBassoon, midiClarinet, midiPiccolo, midiFlute,
                     midiRecorder, midiPanFlute, midiBottleBlow, midiShakuhachi,
                     midiWhistle, midiOcarina, midiLead1Square,
                     midiLead2Sawtooth, midiLead3CalliopeLead, midiLead4ChiffLead,
                     midiLead5Charang, midiLead6Voice, midiLead7Fifths,
                     midiLead8BrassLead, midiPad1NewAge, midiPad2Warm,
                     midiPad3Polysynth, midiPad4Choir, midiPad5Bowed,
                     midiPad6Metallic, midiPad7Halo, midiPad8Sweep, midiEmpty0,
                     midiEmpty1, midiEmpty2, midiEmpty3, midiEmpty4, midiEmpty5,
                     midiEmpty6, midiEmpty7, midiEmpty8, midiEmpty9, midiEmpty10,
                     midiEmpty11, midiEmpty12, midiEmpty13, midiEmpty14,
                     midiEmpty15, midiEmpty16, midiEmpty17, midiEmpty18,
                     midiEmpty19, midiEmpty20, midiEmpty21, midiEmpty22,
                     midiEmpty23, midiGuitarFretNoise, midiBreathNoise,
                     midiSeashore, midiBirdTweet, midiTelephoneRing,
                     midiHelicopter, midiApplause, midiGunshot);
 
procedure MidiInit;
procedure SetCurrentInstrument(CurrentInstrument: tMidiInstrument);
procedure NoteOn(NewNote, NewIntensity: byte);
procedure NoteOff(NewNote, NewIntensity: byte);
procedure SetPlaybackVolume(PlaybackVolume: cardinal);
 
implementation
 
uses
  MMSystem;
 
const
  MIDI_NOTE_ON = $90;
  MIDI_NOTE_OFF = $80;
  MIDI_CHANGE_INSTRUMENT = $C0;
  MIDI_DEVICE = 0;
  MIDI_VEL = 108;
 
var
  mo: hMidiOut;
 
procedure MidiInit;
begin
  MidiOutOpen(@mo, MIDI_DEVICE, 0, 0, CALLBACK_NULL);
  SetPlaybackVolume(65535);
end;
 
function MidiEncodeMessage(Msg, Param1, Param2: integer): integer;
begin
  result := Msg + (Param1 shl 8) + (Param2 shl 16);
end;
 
procedure SetCurrentInstrument(CurrentInstrument: tMidiInstrument);
begin
  MidiOutShortMsg(mo, MidiEncodeMessage(MIDI_CHANGE_INSTRUMENT, Ord(CurrentInstrument), 0));
end;
 
procedure NoteOn(NewNote, NewIntensity: byte);
begin
  MidiOutShortMsg(mo, MidiEncodeMessage(MIDI_NOTE_ON, NewNote, NewIntensity));
end;
 
procedure NoteOff(NewNote, NewIntensity: byte);
begin
  MidiOutShortMsg(mo, MidiEncodeMessage(MIDI_NOTE_OFF, NewNote, NewIntensity));
end;
 
procedure SetPlaybackVolume(PlaybackVolume: cardinal);
begin
  MidiOutSetVolume(mo, PlaybackVolume);
end;
 
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
 
program Adeste;
 
{$IFDEF VPASCAL}{&PMTYPE VIO}{&USE32+}{$ELSE}{$APPTYPE CONSOLE}{$ENDIF}
 
uses
  Midi, Windows;
 
(*
 Each musical pitch of a chord is expressed as a MIDI note number (middle C is
 note number 60, so D# above middle C is #61, etc).
*)
 
const
  re  = 62;
  mi  = 64;
  fa  = 66; (* fa dièse *)
  sol = 67;
  la  = 69;
  si  = 71;
  ut  = 72;
  re8 = 74;
 
type
  note = record
    n: byte;    (* Note *)
    d: integer; (* Durée *)
    v: byte;    (* Volume *)
  end;
 
const
  notes: array[1..68]of note = (
    (n: sol; d: 2; v: 2),
    (n: sol; d: 4; v: 2),
    (n:  re; d: 2; v: 2),
    (n: sol; d: 2; v: 2),
    (n:  la; d: 4; v: 2),
    (n:  re; d: 4; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  ut; d: 2; v: 2),
    (n:  si; d: 4; v: 2),
    (n:  la; d: 2; v: 2),
    (n:   0; d: 1; v: 0),
    (n: sol; d: 1; v: 2),
    (n: sol; d: 4; v: 2),
    (n:  fa; d: 1; v: 2),
    (n:   0; d: 1; v: 0),
    (n:  mi; d: 2; v: 2),
    (n:  fa; d: 2; v: 2),
    (n: sol; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  fa; d: 4; v: 2),
    (n:  mi; d: 3; v: 2),
    (n:  re; d: 1; v: 2),
    (n:  re; d: 6; v: 2),
    (n:   0; d: 2; v: 0),
    (n: re8; d: 4; v: 2),
    (n:  ut; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  ut; d: 4; v: 2),
    (n:  si; d: 4; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n: sol; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  fa; d: 4; v: 2),
    (n:  re; d: 1; v: 2),
    (n:   0; d: 1; v: 0),
    (n: sol; d: 2; v: 1),
    (n: sol; d: 2; v: 1),
    (n:  fa; d: 2; v: 1),
    (n: sol; d: 2; v: 1),
    (n:  la; d: 2; v: 1),
    (n: sol; d: 4; v: 1),
    (n:  re; d: 1; v: 1),
    (n:   0; d: 1; v: 0),
    (n:  si; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  la; d: 2; v: 2),
    (n:  si; d: 2; v: 2),
    (n:  ut; d: 2; v: 2),
    (n:  si; d: 4; v: 2),
    (n:  la; d: 1; v: 2),
    (n:   0; d: 1; v: 0),
    (n:  si; d: 2; v: 3),
    (n:  ut; d: 2; v: 3),
    (n:  si; d: 1; v: 3),
    (n:   0; d: 1; v: 0),
    (n:  la; d: 2; v: 3),
    (n: sol; d: 2; v: 3),
    (n:  fa; d: 4; v: 3),
    (n: sol; d: 2; v: 3),
    (n:  ut; d: 2; v: 3),
    (n:  si; d: 4; v: 3),
    (n:  la; d: 3; v: 3),
    (n: sol; d: 1; v: 2),
    (n: sol; d: 8; v: 2)
  );
 
procedure Jouer(const n: byte; const d: integer; const v: byte);
begin
  NoteOn(n, v);
  Sleep(d);
  NoteOff(n, v);
end;
 
var
  i: integer;
 
begin
  MidiInit;
  SetCurrentInstrument(midiTrumpet);
  for i := Low(notes) to High(notes) do
    with notes[i] do
      if n = 0 then
        Sleep(200 * d)
      else
        Jouer(n, 200 * d, 67 + 20 * v);
end.

25/12/2013, 09h11
Alcatîz

Bonjour Roland,

Citation:

Envoyé par Roland Chastain

Je ne savais pas que c'était aussi facile de faire du MIDI.

En effet ! :king:

Avec les flocons en Lazarus et la musique en Delphi, c'est Noël en Pascal ! :bravo:

1 pièce(s) jointe(s)

Démineur API Win32

Bonjour !

Je vous propose une traduction en Pascal du Démineur en C de CGi.

Le programme peut être compilé avec Delphi, FreePascal et Virtual Pascal.

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
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
 
{ Traduction en Pascal du démineur en C de "CGi" :
  http://chgi.developpez.com/wincode/demineur/
  Compilation testée : Delphi 7, Free Pascal 2.6.4, Virtual Pascal 2.1.
}
 
program Mines;
 
{$IFDEF VPASCAL}
  {$PMTYPE PM}
  {$H+}
{$ELSE}
  {$APPTYPE GUI}
  {$IFDEF FPC}
    {$MODE DELPHI}
  {$ENDIF}
  {$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}
 
uses
  Messages, Windows, SysUtils;
 
{$R MINES.RES}
 
const
  LARGEUR      = 32;
  COLONNES     =  8;
  LIGNES       =  8;
  NOMBRE_MINES =  8;
 
  IDM_QUIT  = 101;
  IDM_NEW   = 102;
  IDM_ABOUT = 103;
 
  VAL_MINE   = $00000100;
  VAL_VOILE  = $00010000;
  VAL_REVELE = $FFFEFFFF;
  VAL_NOMBRE = $0000000F;
 
type
  tTableau = array[0..LIGNES - 1, 0..COLONNES - 1]of integer;
 
var
  hFenetre: HWND;
  hMenu, hSousMenu: tHandle;
  tableau: tTableau;
  fin: boolean;
 
function Demine(var aTableau: tTableau; const y, x: integer): boolean;
var
  void: boolean;
begin
  if (aTableau[y, x] and VAL_VOILE) > 0 then
    aTableau[y, x] := aTableau[y, x] and VAL_REVELE
  else
  begin
    Result := FALSE;
    exit;
  end;
  if (aTableau[y, x] and VAL_MINE) > 0 then
  begin
    Result := TRUE;
    exit;
  end;
  if (aTableau[y, x] and VAL_NOMBRE) > 0 then
  begin
    Result := FALSE;
    exit;
  end;
  if (y > 0) and (x > 0) then
    void := Demine(aTableau, y - 1, x - 1);
  if (y > 0) then
    void := Demine(aTableau, y - 1, x);
  if (y > 0) and (x < COLONNES - 1) then
    void := Demine(aTableau, y - 1, x + 1);
  if (x > 0) then
    void := Demine(aTableau, y, x - 1);
  if (x < COLONNES - 1) then
    void := Demine(aTableau, y, x + 1);
  if (y < LIGNES - 1) and (x > 0) then
    void := Demine(aTableau, y + 1, x - 1);
  if (y < LIGNES - 1) then
    void := Demine(aTableau, y + 1, x);
  if (y < LIGNES - 1) and (x < COLONNES - 1) then
    void := Demine(aTableau, y + 1, x + 1);
  Result := FALSE;
end;
 
procedure Montre(var aTableau: tTableau);
var
  x, y: integer;
begin
  for y := 0 to  LIGNES - 1 do
    for x := 0 to COLONNES - 1 do
      aTableau[y, x] := aTableau[y, x] and VAL_REVELE;
end;
 
function Verifie(const aTableau: tTableau): boolean;
var
  x, y: integer;
begin
  Result := TRUE;
  for y := 0 to LIGNES - 1 do
    for x := 0 to COLONNES - 1 do
      if ((aTableau[y, x] and VAL_VOILE) > 0) and
         ((aTableau[y, x] and VAL_MINE) = 0) then
           Result := FALSE;
end;
 
procedure Initialise(var aTableau: tTableau);
var
  x, y: integer;
  xMine, yMine: integer;
begin
  for y := 0 to LIGNES - 1 do
    for x := 0 to COLONNES - 1 do
      aTableau[y, x] := 0;
  x := 0;
  while x < NOMBRE_MINES do
  begin
    xMine := Random(COLONNES);
    yMine := Random(LIGNES);
    if (aTableau[yMine, xMine] and VAL_MINE) = 0 then
    begin
      aTableau[yMine, xMine] := VAL_MINE;
      Inc(x);
    end;
  end;
  for y := 0 to LIGNES - 1 do
    for x := 0 to COLONNES - 1 do
    begin
      if (aTableau[y, x] and VAL_MINE) > 0 then
      begin
        if (y > 0) and (x > 0) then
          Inc(aTableau[y - 1, x - 1]);
        if (y > 0) then
          Inc(aTableau[y - 1, x]);
        if (y > 0) and (x < COLONNES - 1) then
          Inc(aTableau[y - 1, x + 1]);
        if (x > 0) then
          Inc(aTableau[y, x - 1]);
        if (x < COLONNES - 1) then
          Inc(aTableau[y, x + 1]);
        if (y < LIGNES - 1) and (x > 0) then
          Inc(aTableau[y + 1, x - 1]);
        if (y < LIGNES - 1) then
          Inc(aTableau[y + 1, x]);
        if (y < LIGNES - 1) and (x < COLONNES - 1) then
          Inc(aTableau[y + 1, x + 1]);
      end;
      aTableau[y, x] := aTableau[y, x] or VAL_VOILE;
    end;
  fin := FALSE;
end;
 
function WndProc(hWnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  x, y, xMouse, yMouse: integer;
  oldPen, newPen: HPEN;
  DC, auxDC: HDC;
  hBmp: HBITMAP;
  ps: tPaintStruct;
  r1, r2: tRect;
  hBsh: HBRUSH;
  s: string;
begin
  case msg of
    WM_CREATE:
      begin
        Randomize;
        Initialise(tableau);
        Result := 0;
        exit;
      end;
    WM_COMMAND:
      case LoWord(wParam) of
        IDM_QUIT: PostMessage(hWnd, WM_CLOSE, 0, 0);
        IDM_NEW:
          begin
            Initialise(tableau);
            InvalidateRect(hWnd, nil, FALSE);
          end;
        IDM_ABOUT: MessageBox(0, 'Démineur par CGi.'#10'Version Pascal par Roland Chastain.', 'Mines', MB_OK);
      end;
    WM_LBUTTONUP:
      begin
        xMouse := LoWord(lParam);
        yMouse := HiWord(lParam);
        x := xMouse div LARGEUR;
        y := yMouse div LARGEUR;
        InvalidateRect(hWnd, nil, FALSE);
        if fin then
        begin
          Result := 0;
          exit;
        end;
        if Demine(tableau, y, x) then
        begin
          Montre(tableau);
          MessageBox(0, 'Vous avez perdu !', 'Mines', MB_OK);
          fin := TRUE;
        end else
          if Verifie(tableau) then
          begin
            MessageBox(0, 'Vous avez gagné !', 'Mines', MB_OK);
            fin := TRUE;
          end;
        Result := 0;
        exit;
      end;
    WM_KEYDOWN:
      begin
        if wParam = VK_ESCAPE then
        begin
          PostQuitMessage(0);
          Result := 0;
          Exit;
        end;
      end;
    WM_DESTROY:
      begin
        PostQuitMessage(0);
        Result := 0;
        Exit;
      end;
    WM_PAINT:
    begin
      hBsh := CreateSolidBrush($D0D0D0);
      newPen := CreatePen(PS_SOLID, 1, $303030);
      GetClientRect(hWnd, r1);
      DC := BeginPaint(hFenetre, ps);
 
      auxDC := CreateCompatibleDC(DC);
      hBmp := CreateCompatibleBitmap(DC, r1.right, r1.bottom);
      SelectObject(auxDC, hBmp);
      oldPen := SelectObject(auxDC, newPen);
 
      FillRect(auxDC, r1, CreateSolidBrush($C0C0C0));
 
      for y := 0 to LIGNES - 1 do
        for x := 0 to COLONNES - 1 do
        begin
          r2.left := x * LARGEUR + 1;
          r2.right := x * LARGEUR + LARGEUR;
          r2.top := y * LARGEUR + 1;
          r2.bottom := y * LARGEUR + LARGEUR;
 
          Rectangle
          (
            auxDC,
            r2.left,
            r2.top,
            r2.right,
            r2.bottom
          );
 
          SetTextColor(auxDC, 0);
          if (tableau[y, x] and VAL_MINE) > 0 then
            DrawText(auxDC, 'M', 1, r2, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
 
          if (tableau[y, x] > 0) and (tableau[y, x] < 9) then
          begin
            Str(tableau[y, x], s);
            case tableau[y, x] of
              1: SetTextColor(auxDC, $FF0000);
              2: SetTextColor(auxDC, $008F00);
              3: SetTextColor(auxDC, $0000FF);
            else SetTextColor(auxDC, $FF00FF);
            end;
            DrawText(auxDC, pChar(s), 1, r2, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
          end;
 
          if (tableau[y, x] and VAL_VOILE) > 0 then
          begin
            Inc(r2.left);
            Dec(r2.right);
            Inc(r2.top);
            Dec(r2.bottom);
            FillRect(auxDC, r2, hBsh);
          end;
 
        end;
 
      BitBlt(DC, 0, 0, r1.right, r1.bottom, auxDC, 0, 0, SRCCOPY);
 
      DeleteDC(auxDC);
      DeleteObject(hBmp);
      EndPaint(hFenetre, ps);
      DeleteObject(hBsh);
      SelectObject(DC, oldPen);
      DeleteObject(newPen);
      Result := 0;
      Exit;
    end;
  end;
  Result := DefWindowProc(hWnd, msg, wParam, lParam);
end;
 
procedure ClientResize(aHandle: HWND; aWidth, aHeight: integer);
var
  cr, wr: TRect;
  d: TPoint;
begin
  GetClientRect(aHandle, cr);
  GetWindowRect(aHandle, wr);
  d.x := (wr.right - wr.left) - cr.right;
  d.y := (wr.bottom - wr.top) - cr.bottom;
  MoveWindow(aHandle, wr.left, wr.top, aWidth + d.x, aHeight + d.y, true);
end;
 
const
  APPNAME = 'Mines';
 
var
  wc: tWndClass;
  msg: tMsg;
 
begin
  Randomize;
 
  wc.Style := CS_VREDRAW or CS_HREDRAW;
  wc.lpfnWndProc := @WndProc;
  wc.cbClsExtra := 0;
  wc.cbWndExtra := 0;
  wc.hInstance := hInstance;
  wc.hIcon := LoadIcon(hInstance, MakeIntResource(1));
  wc.hCursor := LoadCursor({hInstance}0, IDC_ARROW);
  wc.hbrBackground := CreateSolidBrush($C0C0C0);
  wc.lpszMenuName := nil;
  wc.lpszClassName:= APPNAME;
  RegisterClass(wc);
 
  hSousMenu := CreateMenu;
  AppendMenu(hSousMenu, MF_STRING, IDM_NEW, 'Nouvelle Partie');
  AppendMenu(hSousMenu, MF_STRING, IDM_ABOUT, 'A Propos');
  AppendMenu(hSousMenu, MF_STRING, IDM_QUIT, 'Quitter');
  hMenu := CreateMenu;
  AppendMenu(hMenu, MF_POPUP, hSousMenu, 'Fichier');
 
  hFenetre := CreateWindow
  (
    APPNAME,
    'Mines',
    WS_SYSMENU or WS_CAPTION or WS_MINIMIZEBOX,
    integer(CW_USEDEFAULT),
    integer(CW_USEDEFAULT),
    LARGEUR * COLONNES + 1 + 2 * GetSystemMetrics(sm_CXFrame),
    LARGEUR * LIGNES + 1 + GetSystemMetrics(sm_CYCaption) + GetSystemMetrics(sm_CYMenu) + 2 * GetSystemMetrics(sm_CYFrame),
    0,
    hMenu,
    HInstance,
    nil
  );
  ShowWindow(hFenetre, CMDSHOW);
  UpdateWindow(hFenetre);
 
  ClientResize(hFenetre, LARGEUR * COLONNES + 1, LARGEUR * LIGNES + 1);
 
  while msg.message <> WM_QUIT do
  begin
    if PeekMessage(msg, 0, 0, 0, PM_REMOVE) then
    begin
      TranslateMessage(msg);
      DispatchMessage(msg);
    end;
  end;
  ExitProcess(msg.wParam);
end.

L'exécutable ci-joint a été compilé avec Delphi 7. Sa taille est de 9 Ko ! :)

25/01/2014, 14h41
Alcatîz

Bravo, bel exemple de programme Windows sans surcouche ! :bravo:
27/01/2014, 11h02
Roland Chastain

Citation:

Envoyé par Alcatîz

Bravo, bel exemple de programme Windows sans surcouche ! :bravo:

Merci pour vos encouragements, maître Alcatîz ! :)
27/01/2014, 19h27
Roland Chastain

En retravaillant le Démineur, j'ai cherché à résoudre un problème auquel je me suis plusieurs fois attaqué sans succès, à savoir de déterminer les dimensions d'une fenêtre (les paramètres à passer à CreateWindow()) en fonction de la taille souhaitée du rectangle client.

Jusqu'à présent la seule solution que j'ai trouvée est de déterminer de façon empirique la différence en largeur et en hauteur. La méthode est fastidieuse et peut-être peu fiable. J'ai cherché à comparer les valeurs que j'obtenais avec les résultats renvoyés par GetSystemMetrics() : je n'ai jamais trouvé la bonne combinaison.

Là j'ai tenté autre chose, à savoir de retailler la fenêtre à l'exécution avec MoveWindow() jusqu'à avoir le rectangle client que je souhaite. Ce que j'ai fait ne fonctionne pas : la fenêtre disparaît. :aie:

Connaîtriez-vous la bonne façon d'utiliser cette fonction ?
27/01/2014, 19h55
Alcatîz
Pour calculer la hauteur d'une fenêtre classique, il faut ajouter à la hauteur de la zone client désirée :
- GetSystemMetrics(sm_CYCaption) = la hauteur de la barre de titre ;
- GetSystemMetrics(sm_CYMenu) = la hauteur de la barre de menu éventuelle ;
- 2 * GetSystemMetrics(sm_CYFrame) = la hauteur de la bordure.
Et pour la largeur :
- GetSystemMetrics(sm_CXVScroll) = la largeur de l'ascenseur vertical éventuel ;
- 2 * GetSystemMetrics(sm_CXFrame) = la largeur de la bordure.
27/01/2014, 21h42
Roland Chastain

Merci Alcatîz ! :ccool: