program BoulesBillard_mX4_3_2; //http://www.delphibasics.info/home/delphibasicsprojects/billiardsindelphi //interface #locs:1360 //#sign: max: MAXBOX8: 01/05/2017 18:48:44 //#tech:.10perf: 0:0:2.430 threads: 2 192.168.80.1 18:48:44 4.2.5.10 {uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Menus, ExtCtrls,variables ; } Const BILLARD_BITMAP = 'billard2.bmp'; const xa=45; xb=53; xc=255; xcp=267; xdp=277; ycp=32; yjp=268; xd=289; xe=498; xf=505; yb=46; ya=53; yl=250; yk=255; x1=36; x2=515; y1=23; y2=277; xt1=30; xt2=272; xt3=514; yt1=30; yt2=20; yt4=270; yt5=280; rtrou2=500; rboule= 9; {rayon des boules} kralentissement= 0.967;//0.992; kforce=1.7; {single coefficient correcteur pour les vitesses} {utilisé pour tricher sur la puissance du pc 0.5} type tboule = record couleur:tcolor; {'rouge','jaune','blanche','noire'} x,y,xold,yold,vx,vy,xpre,ypre:single; {position et vitesse} etat,etatpre:integer; {0:sortie , 1:en jeu, 3:en cours de sortie} end; tjoueur = record couleur:tcolor; {rouge,jaune ou noir au début} bonus:boolean; {true si le joueur a droit à un coup en plus} first:tcolor; {numéro de la première boule touchée à chaque tour; initialisé à 0} nom:string; rentrees:boolean; {toutes les boules rentrées} end; var bleu:boolean; boutonvalide:boolean; mainpre:integer; runion:trect; table:tbitmap; {table de yahoo 552*302 pixels} bmptravail:tbitmap; {bmp ou les modifs sont effectuées vérifier l'utilité....} boule:array[1..16] of tboule; {cf déclaration dans boules.pas} {variables pour la canne} phasecanne:boolean; {true<->la canne est affichée} recalccan: boolean; //find second position ro : array[1..6] OF single; { longueurs éléments de la canne } nom1,nom2:string; {noms des 2 joueurs} sin1, cos1 : Single; { relatifs à l'angle de la canne } Force : Single; { force du coup de canne } {variables propres aux règles} main:integer; {joueur qui a la main} nvtour:boolean; {true qd on commence un nveau tour} {initialisé qd on frappe avec la canne} faute:integer; {nature de la faute donnée par l'entier} jr:array[1..2]of tjoueur; casse:boolean; {false tt que le cassage n'est pas réalisé} rejoue:boolean; vites:integer; procedure nouvelle_position(n:integer); forward;{calcule tout } procedure collision(n1,n2 :integer); forward; {calcul des vitesses après chocs} procedure bande(n:integer); forward; procedure trou(n:integer); forward; procedure ralentir(n:integer); forward; procedure replacer_blanche(x,y:integer); forward; function test_collision2(n1,n2:integer):boolean; forward; function test_collision(n1,n2:integer):boolean; forward; function distance(n1,n2:integer):single; forward; function inv(m:integer):integer; forward; {utilisé pour savoir qui n'a pas la main} //Cygwin\Billiards\zone_de_jeu.pa procedure afficher_boule(n:integer); forward; procedure effacer_boule(n:integer); forward; procedure efface_tout; forward; //Cygwin\Billiards\CANNE.PAS File loaded procedure calculcanne(wx, wy : integer); forward; //onmousemove! PROCEDURE effacecanne(paintbox:tpaintbox); forward; PROCEDURE afficher_canne(cax, cay : single; paintbox:tpaintbox); forward; type Tform4 = TForm; //TForm1 = class(TForm) var MainMenu1: TMainMenu; Fichier1: TMenuItem; N1: TMenuItem; Quitter1, Recalc, Recalc2: TMenuItem; PaintBox1: TPaintBox; Nouvellepartie1: TMenuItem; Panel1: TPanel; {nom1} Panel2: TPanel; {nom2} Panel3: TPanel; Timer1: TTimer; {animation des boules} Timer2: TTimer; Timer3: TTimer; rejouercoup1: TMenuItem; VitesseJeu2: TMenuItem; N11: TMenuItem; N21: TMenuItem; N51: TMenuItem; N41: TMenuItem; N31: TMenuItem; SpeedButton1: TSpeedButton; procedure TForm1Quitter1Click(Sender: TObject); forward; procedure TForm1FormCreate(Sender: TObject); forward; procedure TForm1PaintBox1Paint(Sender: TObject); forward; procedure TForm1initialisation; forward; procedure TForm1FormClose(Sender: TObject; var Action: TCloseAction); forward; procedure TForm1PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); forward; procedure TForm1Nouvellepartie1Click(Sender: TObject); forward; procedure TForm1noms_joueurs; forward; procedure TForm1Timer1Timer(Sender: TObject); forward; procedure TForm1Button2Click(Sender: TObject); forward; procedure TForm1Button3Click(Sender: TObject); forward; procedure TForm1Timer2Timer(Sender: TObject); forward; procedure TForm1PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); forward; procedure TForm1messages; forward; procedure TForm1Timer3Timer(Sender: TObject); forward; procedure TForm1rejouercoup1Click(Sender: TObject); forward; procedure TForm1VitesseJeu1Click(Sender: TObject); forward; procedure TForm1N11Click(Sender: TObject); forward; procedure TForm1N21Click(Sender: TObject); forward; procedure TForm1N31Click(Sender: TObject); forward; procedure TForm1N41Click(Sender: TObject); forward; procedure TForm1N51Click(Sender: TObject);forward; procedure TForm1SpeedButton1Click(Sender: TObject); forward; // private { Déclarations privées } // public { Déclarations publiques } function TForm1etat_jeu:boolean; forward; //end; procedure chgt_joueur; forward; procedure animfin; forward; //implementation var msgfin:string; form4: TForm4; form2: TForm; const bande_gauche= 35; {abscisse de la bande gauche} bande_droite= 515; {abscisse de la bande droite} decalagex=76; {table n'est pas en 0,0} decalagey=41; {utilisé dans affichade bmptravail} var acanne : Single; { angle de la canne en radians } Rcanne : Trect; { rectangle image de la canne } Bmpcanne : Tbitmap; { sauvegarde zone sous la canne } { gestion du viseur } Rviseur : array[1..3] of Trect; { rectangle image du viseur } Bmpviseur : array[1..3] of Tbitmap; { sauvegarde zone sous le viseur } Visz : array[1..3] of integer; { taille du viseur 4, db selon option } flagcanne:boolean; {si image de la canne est créée} procedure calculcanne(wx, wy : integer); var dx, dy : integer; { centre de la rotation position boule blanche } sdx, sdy : single; { centre de la rotation pour les calculs } begin sdx := boule[1].x- wx +decalagex; sdy := -boule[1].y + wy -decalagey; {attention au moins} dx := round(sdx); dy := round(sdy); IF dx = 0 then begin { protection division par zéro du calcul arc tangente } { canne : angle en radians } if dy > 0 then acanne := pi/2 else acanne := -pi/2; end else begin IF dx > 0 then begin acanne := arctan(sdy/sdx); IF acanne < 0 then acanne := pi+pi+acanne; end else acanne := pi+arctan(sdy/sdx); end; { distance souris/centre et calcul de la force } sin1 := sin(acanne); cos1 := -cos(acanne); sdx := abs(sdx); sdy := abs(sdy); IF sdx < 0.0001 then sdx := 0.0001; { évite overflow 0x0 réels } IF sdy < 0.0001 then sdy := 0.0001; force := (sqrt(sdx*sdx+sdy*sdy) - rboule) / 6; IF force > 28 then force := 28; IF force < 1 then force := 1; end; { efface canne et viseurs } PROCEDURE effacecanne(paintbox:tpaintbox); Var i : integer; r : trect; begin IF Flagcanne then begin { efface canne } with paintbox.canvas do begin r := rect(0,0, bmpcanne.width, bmpcanne.height); copyrect(rcanne, bmpcanne.canvas, r); bmpcanne.free; rcanne := rect(0,0,0,0); { efface viseurs } for i := 1 to 3 do begin r := rect(0,0, bmpviseur[i].width, bmpviseur[i].height); copyrect(rviseur[i], bmpviseur[i].canvas, r); bmpviseur[i].free; rviseur[i] := rect(0,0,0,0); end; flagcanne := false; end; end; end; { affiche la canne } PROCEDURE afficher_canne(cax, cay : single;paintbox:tpaintbox); { caa angle en radians } VAR i : integer; px : array[1..6] OF integer; { points de la canne } py : array[1..6] OF integer; vix : array[1..3] of integer; viy : array[1..3] of integer; { points du viseur } r : Trect; wvf : single; BEGIN {IF Iviseur = 0 then visz[1] := db else }visz[1] := 2; {iviseur pour l'option} Visz[2] := 4; Visz[3] := 2; if not rejoue then {évite des bugs d'affichage du au paintbox} effacecanne(paintbox); { et viseurs } rejoue:=false; For i := 1 TO 6 DO begin px[i] := round(cax+ round(ro[i]*cos1)); py[i] := round(cay+ round(ro[i]*sin1)); end; For i := 1 TO 3 do begin wvf := i; vix[i] := trunc(cax - round(force*5*wvf*cos1) - visz[i] div 2); viy[i] := trunc(cay - round(force*5*wvf*sin1) - visz[i] div 2); end; { sauvegarde des zones sous canne et sous viseur } rcanne.left := min(px[1], px[6])-4; rcanne.top := min(py[1], py[6])-4; rcanne.right := max(px[1], px[6])+4; rcanne.bottom := max(py[1], py[6])+4; Bmpcanne := Tbitmap.create; Bmpcanne.width := rcanne.right - rcanne.left; Bmpcanne.height := rcanne.bottom - rcanne.top; r := rect(0,0,bmpcanne.width, bmpcanne.height); Bmpcanne.canvas.copyrect(r, paintbox.canvas, rcanne); For i := 1 to 3 do begin rviseur[i].left := vix[i]; rviseur[i].top := viy[i]; rviseur[i].right := vix[i]+visz[i]; rviseur[i].bottom := viy[i]+visz[i]; Bmpviseur[i] := Tbitmap.create; Bmpviseur[i].width := visz[i]; Bmpviseur[i].height := visz[i]; r := rect(0,0,visz[i],visz[i]); Bmpviseur[i].canvas.copyrect(r, paintbox.canvas, rviseur[i]); end; With Paintbox.Canvas do Begin Pen.mode := pmCopy; Pen.width := 3; Pen.color := clblack; Moveto(px[4], py[4]); Lineto(px[6], py[6]); Pen.color := clmaroon; Moveto(px[4], py[4]); lineto(px[5], py[5]); Pen.color := clolive; Moveto(px[2], py[2]); Lineto(px[4], py[4]); Pen.width := 1; Moveto(px[5], py[5]); Lineto(px[4], py[4]); Pen.color := clwhite; Moveto(px[1], py[1]); Lineto(px[3], py[3]); Pen.color := clyellow; Moveto(px[2], py[2]); Lineto(px[4], py[4]); Pixels[px[1], py[1]]:= clblack; Pixels[px[2], py[2]] := clsilver; { viseurs} pen.color := clwhite; for i := 1 TO 3 do Ellipse(vix[i], viy[i], vix[i]+visz[i], viy[i]+visz[i]); end; flagcanne := true; end; procedure afficher_boule(n:integer); var xx,yy:integer; {il faut bien des entiers pour la fonction ellipse} r:trect; begin if boule[n].etat=0 then exit else begin with bmptravail.canvas do begin pen.color := boule[n].couleur; brush.color:= boule[n].couleur; xx:=trunc(boule[n].x); yy:=trunc(boule[n].y); ellipse(xx-rboule,yy-rboule,xx+rboule,yy+rboule); r:=rect(xx-rboule,yy-rboule,xx+rboule,yy+rboule); unionrect(runion,runion,r); end; end; end; procedure effacer_boule(n:integer); var r:trect; xx,yy:integer; begin if boule[n].etat<>0 then with bmptravail.Canvas do begin xx:=trunc(boule[n].xold); yy:=trunc(boule[n].yold); r:=rect(xx - rboule,yy - rboule,xx + rboule,yy + rboule); copyrect(r,table.Canvas,r); end; if boule[n].etat=2 then boule[n].etat:=0 {on efface une dernière fois la boule rentrée} end; procedure efface_tout; var i,xx,yy:integer; r:trect; begin runion:=rect(0,0,0,0); for i:=1 to 16 do begin if boule[i].etat<>0 then begin xx:=trunc(boule[i].xold); yy:=trunc(boule[i].yold); r:=rect(xx - rboule,yy - rboule,xx + rboule,yy + rboule); bmptravail.Canvas.CopyRect(r,table.Canvas,r); unionrect(runion,runion,r); if boule[i].etat=2 then boule[i].etat:=0; {on efface une dernière fois la boule rentrée} end; end end; procedure nouvelle_position(n:integer); var i,j:integer; begin boule[n].xold := boule[n].x; boule[n].yold := boule[n].y; for i:=1 to 16 do if boule[i].etat<>0 then begin bande(i);trou(i); for j:=i+1 to 16 do begin if boule[j].etat<>0 then begin if test_collision(i,j) then begin collision(i,j); {si collision on assigne la couleur de la premiére boule touchée} if casse then begin if (i=1) and (jr[main].first=clblue) then jr[main].first:=boule[j].couleur; if (j=1) and (jr[main].first=clblue) then jr[main].first:=boule[i].couleur; end else casse:=true; end; end; end; boule[n].x:=boule[n].xold+boule[n].vx; boule[n].y:=boule[n].yold+boule[n].vy; end; ralentir(n); end; function test_collision(n1,n2:integer):boolean; {renvoie vrai s'il y collision entre les deux boules, sinon renvoie non} var dx,dy,dx2,dy2:single; begin dx:=(boule[n1].x+boule[n1].vx-boule[n2].x-boule[n2].vx); {ecart sur x entre les 2 boules} dy:=(boule[n1].y+boule[n1].vy-boule[n2].y-boule[n2].vy);{ecart sur y} dx2:=(boule[n1].x-boule[n2].x); dy2:=(boule[n1].y-boule[n2].y); if ((dx*dx+dy*dy)<={390}324) and ((dx2*dx2+dy2*dy2)>=320) {formule de pythagore} then result:=true else result:=false; end; function test_collision2(n1,n2:integer):boolean; {renvoie vrai s'il y collision entre les deux boules, sinon renvoie non} var dx,dy:single; begin dx:=(boule[n1].x-boule[n2].x); {ecart sur x entre les 2 boules} dy:=(boule[n1].y-boule[n2].y); {acart sur y} if (dx*dx+dy*dy)<={390}320 {formule de pythagore} then result:=true else result:=false; end; procedure collision(n1,n2 :integer); var dy,dx,v1x,v1y,v2x,v2y,a,stock:single; begin if test_collision2(n1,n2) then begin stock:=boule[n1].vx; boule[n1].vx:=boule[n2].vx*3/4+stock*1/4; boule[n2].vx:=stock*3/4+boule[n2].vx*1/4; stock:=boule[n1].vy; boule[n1].vy:=boule[n2].vy*3/4+stock*1/4; boule[n2].vy:=stock*3/4+boule[n2].vy*1/4 end; if test_collision(n1,n2) then dx:=(boule[n1].x+boule[n1].vx-boule[n2].x-boule[n2].vx); {idem} dy:=(boule[n1].y+boule[n1].vy-boule[n2].y-boule[n2].vy); {idem} a:=arctan(dy/(dx+0.00000001)); {angle formé par l'axe passant par les centres des boules et l'axe x} v1x:=boule[n1].vx; {0.000000001 pour enlever la division par 0} v2x:=boule[n2].vx; v1y:=boule[n1].vy; v2y:=boule[n2].vy; {nouvelles vitesses données par les relations simplificatrices des chocs entre boules} boule[n1].vx:=(v2x*cos(a)+v2y*sin(a))*cos(a)+(v1x*sin(a)-v1y*cos(a))*sin(a) ; boule[n1].vy:=(v2x*cos(a)+v2y*sin(a))*sin(a)+(-v1x*sin(a)+v1y*cos(a))*cos(a) ; boule[n2].vx:=(v1x*cos(a)+v1y*sin(a))*cos(a)+(v2x*sin(a)-v2y*cos(a))*sin(a) ; boule[n2].vy:=(v1x*cos(a)+v1y*sin(a))*sin(a)+(-v2x*sin(a)+v2y*cos(a))*cos(a) ; end; procedure bande(n:integer); var a,xx,yy:single; begin xx:=boule[n].x+boule[n].vx; yy:=boule[n].y+boule[n].vy; {bandes horizontales} if (( (xx>=xb) and (xx<=xc) ) or ( (xx>=xd) and (xx<=xe) )) and ( (yy<=yb) or (yy>=yk) ) then boule[n].vy:=-boule[n].vy; {bandes verticales} if ( (yy>=ya) and (yy<=yl) and ( (xx<=xa) or (xx>=xf) ) ) or ( (((xx>=xc) and (xx<=xcp)) or ((xx>=xdp) and (xx<=xd))) and ((yy<=ycp) or (yy>=yjp)) ) then boule[n].vx:=-boule[n].vx; {droites à 45 degré montantes} if ( (xx+yy<=xc+yb) and (xx>=xc) and (yy>=ycp) ) or ( (xx+yy>=xd+yk) and (xx<=xd) and (yy<=yjp) ) or ( (xx+yy<=xa+yl) and (yy>=yl) ) or ( (xx+yy>=xb+yk) and (xx<=xb) ) or ( (xx+yy<=xe+yb) and (xx>=xe) ) or ( (xx+yy>=xf+ya) and (yy<=ya) ) then begin a:=boule[n].vx; boule[n].vx:=-boule[n].vy; boule[n].vy:=-a; exit end; {droites à 45 degrés descendantes} if ( (xx-xd>=yy-yb) and (xx<=xd) and (yy>=ycp) ) or ( (xx-xc<=yy-yk) and (xx>=xc) and (yy<=yjp) ) or ( (xx-xa<=yy-ya) and (yy<=ya) ) or ( (xx-xb>=yy-yb) and (xx<=xb) ) or ( (xx-xe<=yy-yk) and (xx>=xe) ) or ( (xx-xf>=yy-yl) and (yy>=yl) ) then begin a:=boule[n].vx; boule[n].vx:=boule[n].vy; boule[n].vy:=a; exit end; end; procedure trou(n:integer); var pasmain:integer; {numéro du joueur qui n'a pas la main} begin {disparition des boules} if ((boule[n].y<=y1)or(boule[n].y>=y2)or(boule[n].x<=x1)or(boule[n].x>=x2)) then begin boule[n].etat:=2; boule[n].vx:=0; boule[n].vy:=0; {règles} if (n=1) and (faute<>-3) and (faute<>4) then faute:=1; if (n>=3) and (faute<>-3) and (faute<>4) then begin if (jr[main].couleur=clblue) then {assigne des couleurs aux joueurs} begin {jr[main].rentrees:=1;} faute:=-2; jr[main].couleur:=boule[n].couleur; pasmain:=inv(main); if jr[main].couleur=clred then jr[pasmain].couleur:=clyellow else jr[pasmain].couleur:=clred end else if boule[n].couleur=jr[main].couleur then begin faute:=-1-3*random(5); {éventuellemant écrasé si boules adverses rentrées ensuite} {jr[main].rentrees:=jr[main].rentrees+1;} end else begin if jr[main].rentrees=false then faute:=3; pasmain:=inv(main); {jr[pasmain].rentrees:=jr[pasmain].rentrees+1;} end; end; if n=2 then begin {boule noire!} if jr[main].rentrees=true then faute:=-3 else faute:=4; end; end; {effet donné par les bordures des trous, permet aussi à une boule de ne pas s'arreter dans le vide} {trou 1} if (((boule[n].x-xt1)*(boule[n].x-xt1)+(boule[n].y-yt1)*(boule[n].y-yt1))<=rtrou2) then begin boule[n].vy:=boule[n].vy-0.0007; boule[n].vx:=boule[n].vx-0.0007 end; {trou 2} if (((boule[n].x-xt2)*(boule[n].x-xt2)+(boule[n].y-yt2)*(boule[n].y-yt2))<=rtrou2) then boule[n].vy:=boule[n].vy-0.0007; {trou 3} if (((boule[n].x-xt3)*(boule[n].x-xt3)+(boule[n].y-yt1)*(boule[n].y-yt1))<=rtrou2) then begin boule[n].vy:=boule[n].vy-0.0007; boule[n].vx:=boule[n].vx+0.0007 end; {trou 4} if (((boule[n].x-xt1)*(boule[n].x-xt1)+(boule[n].y-yt4)*(boule[n].y-yt4))<=rtrou2) then begin boule[n].vy:=boule[n].vy+0.0007; boule[n].vx:=boule[n].vx-0.0007 end; {trou 5} if (((boule[n].x-xt2)*(boule[n].x-xt2)+(boule[n].y-yt5)*(boule[n].y-yt5))<=rtrou2) then boule[n].vy:=boule[n].vy+0.0007; {trou 6} if (((boule[n].x-xt3)*(boule[n].x-xt3)+(boule[n].y-yt4)*(boule[n].y-yt4))<=rtrou2) then begin boule[n].vy:=boule[n].vy+0.0007; boule[n].vx:=boule[n].vx+0.0007 end; end; procedure ralentir(n:integer); begin boule[n].vx:=boule[n].vx*kralentissement; boule[n].vy:=boule[n].vy*kralentissement; if abs(boule[n].vx)<0.01 then boule[n].vx:=0; if abs(boule[n].vy)<0.01 then boule[n].vy:=0; {autre essai infructueux : cette fois ci on soustrait au lieu de multiplier par un nombre : a:=arctan(boule[n].vy/boule[n].vx); boule[n].vx:=boule[n].vx-kralentissement*cos(a); boule[n].vy:=boule[n].vy-kralentissement*sin(a);} end; procedure replacer_blanche(x,y:integer); var contact:boolean; i:integer; d,dmin:single; {distances} begin contact:=false; dmin:=1000; {distance minimale} for i:=2 to 16 do begin d:=sqrt((x-boule[i].x)*(x-boule[i].x)+(y-boule[i].y)*(y-boule[i].y)); if dmin>d then dmin:=d; end; if dmin<=2*rboule then contact:= true; {évite le chevauchement avec une autre boule} {petite tricherie pour pas que la boule ne tombe pas ds le trou} if (x>45+rboule) and (x<=154) and (y>45+rboule) and (y<250-rboule) and not contact then begin boule[1].etat:=1; boule[1].x:=x; boule[1].y:=y; end; end; function distance(n1,n2:integer):single; begin result:=sqrt((boule[n1].x-boule[n2].x)*(boule[n1].x-boule[n2].x)+(boule[n1].y-boule[n2].y)*(boule[n1].y-boule[n2].y)) end; function inv(m:integer):integer; {utilisé pour savoir qui n'a pas la main} begin if m=1 then result:=2 else result:=1; end; //*********** form builder ***********************************************33 var boulcouleur:array[1..16] of tcolor; //=(clRed, clGreen, clYellow, clBlue, clWhite, clGray, clFuchsia, clTeal, clNavy, clMaroon, clLime, clOlive, clPurple, clSilver, clAqua, clBlack); xinitial:array[1..16] of integer; //=({154,404,382,404,404,426,426,448,448,360,382,426,426,448,448,448);} {154,406,385,406,406,427,427,448,448,364,385,427,427,448,448,448);} //real 154,412,394,412,430,430,448,448,448,376,394,412,430,430,448,448); yinitial:array[1..16] of integer; //=({150,150,139,128,172,139,183,128,172,150,161,117,161,106,150,194);} //real 150,150,160,130,180,140,150,170,110,150,140,170,160,120,130,190); xanim:array[1..16] of integer; //=(154,412,154,197,240,283,326,369,412,154,197,240,283,326,369,412); yanim:array[1..16] of integer; //=(150,150,90,90,90,90,90,90,90,210,210,210,210,210,210,210); {distance entre 2 centres d'une même ligne ou d'une même rangée fixée à 22 pixels} procedure InitDataArrays; begin boulcouleur[1]:= clRed; boulcouleur[2]:= clGreen; boulcouleur[3]:= clYellow; boulcouleur[4]:= clBlue; boulcouleur[5]:= clwhite; boulcouleur[6]:= clGray; boulcouleur[7]:= clFuchsia; boulcouleur[8]:= clteal; boulcouleur[9]:= clNavy; boulcouleur[10]:= clmaroon; boulcouleur[11]:= cllime; boulcouleur[12]:= clOlive; boulcouleur[13]:= clPurple; boulcouleur[14]:= clsilver; boulcouleur[15]:= claqua; boulcouleur[16]:= clblack; //real 154,412,394,412,430,430,448,448,448,376,394,412,430,430,448,448); xinitial[1]:= 154; xinitial[2]:= 412; xinitial[3]:= 394; xinitial[4]:= 412; xinitial[5]:= 430; xinitial[6]:= 430; xinitial[7]:= 448; xinitial[8]:= 448; xinitial[9]:= 448; xinitial[10]:= 376; xinitial[11]:= 394; xinitial[12]:= 412; xinitial[13]:= 430; xinitial[14]:= 430; xinitial[15]:= 448; xinitial[16]:= 448; // //real 150,150,160,130,180,140,150,170,110,150,140,170,160,120,130,190); yinitial[1]:= 150; yinitial[2]:= 150; yinitial[3]:= 160; yinitial[4]:= 130; yinitial[5]:= 180; yinitial[6]:= 140; yinitial[7]:= 150; yinitial[8]:= 170; yinitial[9]:= 110; yinitial[10]:= 150; yinitial[11]:= 140; yinitial[12]:= 170; yinitial[13]:= 160; yinitial[14]:= 120; yinitial[15]:= 130; yinitial[16]:= 190; // //=(154,412,154,197,240,283,326,369,412,154,197,240,283,326,369,412); xanim[1]:= 154; xanim[2]:= 412; xanim[3]:= 154; xanim[4]:= 197; xanim[5]:= 240; xanim[6]:= 283; xanim[7]:= 326; xanim[8]:= 369; xanim[9]:= 412; xanim[10]:= 154; xanim[11]:= 197; xanim[12]:= 240; xanim[13]:= 283; xanim[14]:= 326; xanim[15]:= 369; xanim[16]:= 412; ////=(150,150,90,90,90,90,90,90,90,210,210,210,210,210,210,210); xanim[1]:= 150; yanim[2]:= 150; yanim[3]:= 90; yanim[4]:= 90; yanim[5]:= 90; yanim[6]:= 90; yanim[7]:= 90; yanim[8]:= 90; yanim[9]:= 90; yanim[10]:= 210; yanim[11]:= 210; yanim[12]:= 210; yanim[13]:= 210; yanim[14]:= 210; yanim[15]:= 210; yanim[16]:= 210; end; procedure TForm1Quitter1Click(Sender: TObject); begin form4.close; end; procedure TForm1FormCreate(Sender: TObject); begin sleep(500); phasecanne:=false; TForm1initialisation; timer2.enabled:=true; end; procedure tform1initialisation; var i:integer; begin bmptravail:=tbitmap.create; table:=tbitmap.Create; table.LoadFromFile(Exepath+BILLARD_BITMAP); bmptravail.width:=paintbox1.Width; bmptravail.height:=paintbox1.height; bmptravail.assign(table); {copie l'un dans l'autre} for i:=1 to 16 do begin boule[i].x:= xinitial[i]; {boules prêtes au départ} boule[i].y:= yinitial[i]; boule[i].vx:=0; boule[i].vy:=0; boule[i].etat:=1; {1 <-> boule sur la table} if i=1 then boule[i].couleur:=clwhite; if i=2 then boule[i].couleur:=clblack; if (i>2) and (i<10) then boule[i].couleur:=clred; if (i>9) then boule[i].couleur:=clyellow; afficher_boule(i); end; { dimensions de la canne } ro[1]:= rboule*2; ro[2]:= rboule*3; ro[3]:= rboule*13; ro[4]:= rboule*15; ro[5]:= rboule*20; ro[6] := rboule*20+3; if not timer2.enabled then {ie si premier lancement} {---------------------------------------------} form4.Repaint; nvtour:=true; //vites:= 6; set on main jr[1].couleur:=clblue; jr[2].couleur:=clblue; jr[1].bonus:=false; jr[2].bonus:=false; jr[1].first:=clblue; jr[2].first:=0; jr[1].nom:=nom1; jr[2].nom:=nom2; jr[1].rentrees:=false; jr[2].rentrees:=false; main:=1; mainpre:=1; {on donne la main au joueur 1} casse:=false; panel3.Caption:='Lancer une nouvelle partie'; timer3.Enabled:=false; end; procedure tform1noms_joueurs; begin //nom1:=form2.edit1.text; //nom2:=form2.edit2.text; nom1:= 'max'; nom2:= 'moritz'; {form4.}Panel1.Font.Color:=jr[1].couleur; {form4.}Panel2.Font.Color:=jr[2].couleur; if main=1 then begin panel1.Font.style := [fsBold,fsUnderline]; {on souligne le nom du joueur qui a la main} panel2.Font.style := [fsBold]; end else begin panel2.Font.style := [fsBold,fsUnderline]; {on souligne le nom du joueur qui a la main} panel1.Font.style := [fsBold]; end; {form1.}Panel1.Caption:=nom1; {form1.}Panel2.Caption:=nom2; //if not flagcanne then //recalccan:= false; //if phasecanne then //afficher_canne(boule[1].x +decalagex, boule[1].y +decalagey,paintbox1 ); //} end; procedure TForm1PaintBox1Paint(Sender: TObject); begin PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); {faut afficher manuellement car paintbox} end; procedure TForm1FormClose(Sender: TObject; var Action: TCloseAction); begin table.free; bmptravail.free; //bmpcanne.Free; timer1.free; timer2.free; timer3.free; action:= caFree; writeln('Billard form free and Close..') writeln('Close and 3 timer objects free..') // timer free!! end; procedure TForm1Close(Sender: TObject); begin form4.close; //---> quitter end; function tform1etat_jeu:boolean; var i:integer; begin result:=true; {true si boules toutes à l'arrêt} for i:=1 to 16 do if (boule[i].vx<>0) or (boule[i].vy<>0) then result:=false; end; //check canne procedure TForm1PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); begin if phasecanne and (boule[1].etat<>0) then begin {si boule blanche sortie mouseclick prend le relais} //move the canne behind force calculcanne(y, x ); afficher_canne(boule[1].x +decalagex, boule[1].y +decalagey,paintbox1); end; if recalccan then if phasecanne and (boule[1].etat<>0) then begin {si boule blanche sortie mouseclick prend le relais} //move the canne behind force calculcanne(x, y); afficher_canne(boule[1].x +decalagex, boule[1].y +decalagey,paintbox1); end; //panel1.Caption:=inttostr(x-decalagex); //panel2.caption:=inttostr(y-decalagey); //} end; procedure TForm1RecalcCanne(sender: TObject); begin recalccan:= not recalccan; recalc2.checked:= Not recalc2.checked; end; procedure TForm1Nouvellepartie1Click(Sender: TObject); begin timer2.enabled:=false; phasecanne:=false; recalccan:= false; table.free; bmptravail.free; //if form2.ShowModal=mrok then begin TForm1initialisation; rejoue:=true; {évite bug d'affichage} //end; timer2.enabled:=true; {normalement le prgm attend la fermeture de form2} PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); {réaffiche tte la table} end; procedure TForm1Timer1Timer(Sender: TObject); var i,j:integer; {boucle avec j si trop lent} r:trect; {parce qu'il y a un décalage par rapport au paintbox} begin for j:=1 to vites do begin for i:=1 to 16 do begin nouvelle_position(i); end; efface_tout; {pour que les calculs ne perturbent pas l'affichage} for i:=1 to 16 do begin afficher_boule(i); end; {PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); } r:=rect(runion.left+decalagex,runion.top+decalagey,runion.Right+decalagex, runion.Bottom+decalagey); paintbox1.Canvas.CopyRect(r,bmptravail.Canvas,runion); end; //if not phasecanne then //afficher_canne(boule[1].x +decalagex, boule[1].y +decalagey,paintbox1 ); end; procedure TForm1Button2Click(Sender: TObject); var i:integer; begin for i:=1 to 16 do begin boule[i].vx:=1-random(3); boule[i].vy:=1-random(3); end; end; procedure TForm1Button3Click(Sender: TObject); begin TForm1initialisation; end; procedure TForm1Timer2Timer(Sender: TObject); begin jr[1].nom:=nom1; jr[2].nom:=nom2; TForm1noms_joueurs; if not TForm1etat_jeu then begin {au moins une boule en mouvement} timer1.enabled:=true; phasecanne:=false; {sûrement inutile dans la version finale} end else begin {boules à l'arrêt on commence un nv tour} timer1.Enabled:=false; //end //if not form2.visible then phasecanne:=true; phasecanne:=true; {évite bug d'affichage avec la fenêtre des noms de joueurs} if not nvtour then begin if (faute=-3) or (faute=4) then begin if faute=-3 then begin msgfin:=(jr[main].nom+' gagne'); end else begin msgfin:=(jr[inv(main)].nom+' gagne'); end; animfin; end else if jr[main].rentrees=false then begin if jr[main].first=clblue then faute:=2 {evite de refaire le test à chaque collision} else if (jr[main].couleur<>clblue) and (faute<>-2) and (jr[main].first<>jr[main].couleur) then faute:=5; if (jr[main].first=clblack) and (jr[main].rentrees=false) then faute:=6; if faute<=-1 then jr[main].bonus:=true; if faute>=1 then jr[main].bonus:=false; {une faute implique la perte du bonus} end; chgt_joueur; TForm1messages; {messages après chgt_joueur pour la cohérence des messages} {----------------------règles--------------------------} if (not casse) or (faute>=1) then jr[main].bonus:=true; {------------------------------------------------------} jr[main].first:=clblue; nvtour:=true; {nvtour effectif qd on a changé de joueur} faute:=0; end; end; //*) end; procedure TForm1PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i,pasmain:integer; begin if (boule[3].etat=0) and (boule[4].etat=0) and (boule[5].etat=0) and (boule[6].etat=0) and (boule[7].etat=0) and (boule[8].etat=0) and (boule[9].etat=0) then begin if jr[main].couleur=clred then jr[main].rentrees:=true end; if (boule[10].etat=0) and (boule[11].etat=0) and (boule[12].etat=0) and (boule[13].etat=0) and (boule[14].etat=0) and (boule[15].etat=0) and (boule[16].etat=0) then begin if jr[main].couleur=clyellow then jr[main].rentrees:=true end; if phasecanne then if boule[1].etat<>0 then begin {on met la blanche en mouvement} phasecanne:=false; {pour pas que la canne s'efface automatiquement} boule[1].vx:= -force*cos1*Kforce; boule[1].vy:= -force*sin1*kforce; for i:=1 to 16 do begin boule[i].etatpre:=boule[i].etat; boule[i].xpre:=boule[i].x; boule[i].ypre:=boule[i].y; end; effacecanne(paintbox1); nvtour:=false; end else begin {remise en place de la blanche} replacer_blanche(x-decalagex,y-decalagey); afficher_boule(1); PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); {réaffiche tte la table} end; end; procedure tform1messages; var i:integer; s:string; begin case faute of -3: s:='!!!!!!! GAGNE !!!!!!!'; -2: s:='!!!!!!!!! Première boule rentrée !!!!!!!!!'; -1: s:='Joli Coup !'; -4: s:='Bien Joué'; -7: s:='Pas Mal !!!'; -10: s:='Bravo'; -13: s:='Waouh !'; 0: s:=''; 1: s:='Faute! Veuillez replacer la boule blanche dans lazone de gauche'; 2: s:='Faute! Vous n'+chr(658)+'avez touché aucune boule'; 3: s:='Faute! Boule adverse empochée * 2 coups pour '+jr[main].nom; 4: s:='PERDU...vous avez rentré la boule noire; '+jr[inv(main)].nom+' gagne la partie'; 5: s:='Faute! Boule adverse touchée'; 6: s:='Faute! Boule noire touchée en premier'; end; {il en faut un pour le case} panel3.Caption:=s; end; procedure chgt_joueur; begin mainpre:=main; if not jr[main].bonus then begin if main=1 then main:=2 else main:=1; end else jr[main].bonus:=false; {bonus utilisé} //if not flagcanne then afficher_canne(boule[1].x +decalagex, boule[1].y +decalagey,paintbox1 ); end; procedure animfin; var i:integer ; begin bmptravail.assign(table); {form1.}PaintBox1.Canvas.Draw(decalagex,decalagey,table); bmptravail.Canvas.Font.Color:=clblue; bmptravail.Canvas.Font.Size:=24; bmptravail.Canvas.Font.Name:='Comic sans ms'; for i:=1 to 16 do begin boule[i].x:=xanim[i]; {boules prêtes au départ} boule[i].y:=yanim[i]; boule[i].vx:=0; boule[i].vy:=0; boule[i].etat:=1; {1 <-> boule sur la table} boule[i].couleur:=boulcouleur[i]; afficher_boule(i); end; phasecanne:=false; {form1.}timer3.Enabled:=true; //if phasecanne then {à ce point c'est celui qui a rentré la noire qui a la main} end; procedure TForm1Timer3Timer(Sender: TObject); var i:integer; begin bmptravail.Canvas.brush.color:=$2D6D2B; for i:=1 to 16 do begin boule[i].vx:=1-random(3); boule[i].vy:=1-random(3); end; bmptravail.Canvas.TextOut(180,125,msgfin); paintbox1.Canvas.Draw(decalagex,decalagey,bmptravail); end; procedure TForm1rejouercoup1Click(Sender: TObject); var i:integer; begin if (timer3.enabled=false) and TForm1etat_jeu then begin rejoue:=true; bleu:=true; {form1.}timer3.Enabled:=false; main:=mainpre; panel3.caption:='Rejouez votre coup!!!'; for i:=1 to 16 do begin if boule[i].etatpre=0 then bleu:=false; effacer_boule(i); if i=1 then boule[i].couleur:=clwhite; if i=2 then boule[i].couleur:=clblack; if (i>2) and (i<10) then boule[i].couleur:=clred; if (i>9) then boule[i].couleur:=clyellow; boule[i].etat:=boule[i].etatpre; boule[i].vx:=0; boule[i].vy:=0; boule[i].x:=boule[i].xpre; boule[i].y:=boule[i].ypre; end; for i:=1 to 16 do afficher_boule(i); PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); form4.Repaint; if bleu=true then begin jr[main].couleur:=clblue; jr[inv(main)].couleur:=clblue end end; end; procedure TForm1VitesseJeu1Click(Sender: TObject); begin rejoue:=false; end; procedure TForm1N11Click(Sender: TObject); begin vites:=1; end; procedure TForm1N21Click(Sender: TObject); begin vites:=2; end; procedure TForm1N31Click(Sender: TObject); begin vites:=3; end; procedure TForm1N41Click(Sender: TObject); begin vites:=4; end; procedure TForm1N51Click(Sender: TObject); begin vites:=5; end; procedure TForm1SpeedButton1Click(Sender: TObject); var i:integer; begin if (timer3.enabled=false) and TForm1etat_jeu then begin rejoue:=true; bleu:=true; {form1.}timer3.Enabled:=false; main:=mainpre; panel3.caption:='Rejouez votre coup!!!'; for i:=1 to 16 do begin if boule[i].etatpre=0 then bleu:=false; effacer_boule(i); if i=1 then boule[i].couleur:=clwhite; if i=2 then boule[i].couleur:=clblack; if (i>2) and (i<10) then boule[i].couleur:=clred; if (i>9) then boule[i].couleur:=clyellow; boule[i].etat:=boule[i].etatpre; boule[i].vx:=0; boule[i].vy:=0; boule[i].x:=boule[i].xpre; boule[i].y:=boule[i].ypre; end; for i:=1 to 16 do afficher_boule(i); PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); form4.Repaint; if bleu=true then begin jr[main].couleur:=clblue; jr[inv(main)].couleur:=clblue end end; end; procedure LoadBitmapRes; begin if not fileExists(exepath+BILLARD_BITMAP) then begin wGetX2('http://www.kleiner.ch/kleiner/images/billard2.bmp', exepath+BILLARD_BITMAP); ShowmessageBig('BITMAP billard2.bmp downloaded..., please confirm!') end; end; //******************** form builder ***************************************3 procedure BuildBillard_Form; begin Form4:= TForm4.create(self) with form4 do begin Left := 70 Top := 131 Position := poScreenCenter AutoSize := True //update; BorderIcons := [biSystemMenu, biMinimize] BorderStyle := bsSingle Caption := 'Billard maXbox4_2' ClientHeight := 459 ClientWidth := 705 formstyle:= fsstayontop; Color := clBlack Font.Charset := DEFAULT_CHARSET Font.Color := clWindowText Font.Height := -11 Font.Name := 'MS Sans Serif' Font.Style := [] Icon.LoadFromResourceName(HInstance, 'NEWPERLDATA'); //Iconload cursor:= crHandPoint; Menu := MainMenu1 OldCreateOrder := False OnClose := @Tform1FormClose OnCreate := @Tform1FormCreate PixelsPerInch := 96 //doublebuffered:= true; see at the end Show; //TextHeight := 13 end; //Tform1FormCreate(self) PaintBox1:= TPaintBox.create(self) with paintbox1 do begin parent:= form4; Left := 0 Top := 26 Width := 705 Height := 384 Color := clBlack Font.Charset := ANSI_CHARSET Font.Color := clWindowText Font.Height := -28 Font.Name := 'Arial Black' Font.Style := [] ParentColor := False ParentFont := False //doublebuffered OnMouseDown := @Tform1PaintBox1MouseDown OnMouseMove := @TForm1PaintBox1MouseMove OnPaint := @TForm1PaintBox1Paint end; SpeedButton1:= TSpeedButton.create(self) with speedbutton1 do begin parent:= form4; Left := 546 Top := 426 Width := 150 Height := 22 Caption := 'Remplacer la Blanche' //Flat := True Font.Charset := DEFAULT_CHARSET Font.Color := clRed Font.Height := -12 Font.Name := 'MS Sans Serif' Font.Style := [fsBold] ParentFont := False OnClick := @Tform1SpeedButton1Click end; Panel1:= TPanel.create(self) with panel1 do begin parent:= form4; Left := 117 Top := 0 Width := 163 Height := 20 Caption := 'Panel1' Color := clBlack Font.Charset := ANSI_CHARSET Font.Color := clWindowText Font.Height := -12 Font.Name := 'Arial' Font.Style := [fsBold] ParentFont := False TabOrder := 0 end; Panel2:= TPanel.create(self) with panel2 do begin parent:= form4; Left := 400 Top := 0 Width := 161 Height := 20 Caption := 'Panel2' Color := clBlack Font.Charset := ANSI_CHARSET Font.Color := clWindowText Font.Height := -12 Font.Name := 'Arial' Font.Style := [fsBold] ParentFont := False TabOrder := 1 end; Panel3:= TPanel.create(self) with panel3 do begin parent:= form4; Left := 152 Top := 418 Width := 385 Height := 40 Color := clBlack Font.Charset := ANSI_CHARSET Font.Color := clWhite Font.Height := -12 Font.Name := 'Tahoma' Font.Style := [fsBold] ParentFont := False TabOrder := 2 end; MainMenu1:= TMainMenu.create(form4) //Left := 144 //Top := 432 Fichier1:= TMenuItem.create(form4) with fichier1 do begin Caption := 'Main' mainmenu1.items.add(fichier1) end; Nouvellepartie1:= TMenuItem.create(form4) with Nouvellepartie1 do begin parent:= fichier1 fichier1.add(Nouvellepartie1) Caption := 'New game' OnClick := @TForm1Nouvellepartie1Click end; rejouercoup1:= TMenuItem.create(form4) with rejouercoup1 do begin parent:= fichier1 fichier1.add(rejouercoup1) Caption := 'Rejouer coup' OnClick := @TForm1rejouercoup1Click end; Quitter1:= TMenuItem.create(form4) with quitter1 do begin parent:= fichier1 fichier1.add(Quitter1) Caption := 'Exit' OnClick := @Tform1Quitter1Click end; //end {object VitesseJeu2: TMenuItem Caption := 'Game speed' object N11: TMenuItem Caption := '1' OnClick := N11Click end object N21: TMenuItem Caption := '2' OnClick := N21Click end object N31: TMenuItem Caption := '3' OnClick := N31Click end object N41: TMenuItem Caption := '4' OnClick := N41Click end object N51: TMenuItem Caption := '5' OnClick := N51Click end end } N1:= TMenuItem.create(form4) with n1 do begin Caption := 'About' mainmenu1.items.add(n1) end;// } //end} Recalc:= TMenuItem.create(form4) with recalc do begin parent:= fichier1 Caption := 'Recalc' mainmenu1.items.add(recalc) // OnClick := @Tform1RecalcCanne end; recalc2:= TMenuItem.create(form4) with recalc2 do begin //parent:= fichier1 recalc.add(recalc2) checked:= false; Caption := 'Recalc Canne Pos' OnClick := @Tform1RecalcCanne; end; Timer1:= TTimer.create(self); with timer1 do begin Enabled := False Interval := 10 OnTimer := @tform1Timer1Timer //Left := 24 //Top := 432 end; Timer2:= TTimer.create(self) with timer2 do begin Enabled := False Interval := 100 OnTimer := @tform1Timer2Timer //Left := 64 //Top := 432 end; Timer3:= TTimer.create(self) with timer3 do begin Enabled := False Interval := 20 OnTimer := @tform1Timer3Timer //Left := 104 //Top := 432 end; //Tform1FormCreate(self) end; //******************form builder end****************************** procedure TMyObjectShiftRightTest; var TicksStart: int64; StartLeftValue: integer; EndLeftValue: integer; NewLeftValue: integer; LeftValueDif: integer; RemainingTicks: int64; FadeTime: integer; begin StartLeftValue := Self.Left; EndLeftValue := Self.Left + Self.Width; LeftValueDif := EndLeftValue - StartLeftValue; TicksStart := GetTickCount(); RemainingTicks := FadeTime; // Fade Time is a constants that dermines how long the // slide off the screen should take while RemainingTicks > 0 do begin NewLeftValue := (LeftValueDif * (FadeTime - RemainingTicks)) div FadeTime; Self.Left := Max(StartLeftValue, NewLeftValue); Self.Parent.Repaint; Self.Repaint; RemainingTicks := FadeTime - int64(GetTickCount - TicksStart); end; if Self.Left < EndLeftValue then Self.Left := EndLeftValue; Self.Parent.Repaint; Self.Repaint; end; begin //@main processMessagesOFF; LoadBitmapRes; InitDataArrays; //kforce=1.7; //kralentissement= 0.967;//0.992; vites:= 6; BuildBillard_Form; Tform1FormCreate(self) println(uptime) end. Doc: ref: kralentissement:single=0.992; kralentissement= 0.974;//0.992; form: unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Menus, ExtCtrls, StdCtrls, zone_de_jeu, canne, noms, variables,boules, Buttons ; type TForm1 = class(TForm) MainMenu1: TMainMenu; Fichier1: TMenuItem; N1: TMenuItem; Quitter1: TMenuItem; PaintBox1: TPaintBox; Nouvellepartie1: TMenuItem; Panel1: TPanel; {nom1} Panel2: TPanel; {nom2} Panel3: TPanel; Timer1: TTimer; {animation des boules} Timer2: TTimer; Timer3: TTimer; rejouercoup1: TMenuItem; VitesseJeu2: TMenuItem; N11: TMenuItem; N21: TMenuItem; N51: TMenuItem; N41: TMenuItem; N31: TMenuItem; SpeedButton1: TSpeedButton; procedure Quitter1Click(Sender: TObject); procedure FormCreate(Sender: TObject); procedure PaintBox1Paint(Sender: TObject); procedure initialisation; procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Nouvellepartie1Click(Sender: TObject); procedure noms_joueurs; procedure Timer1Timer(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure Timer2Timer(Sender: TObject); procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure messages; procedure Timer3Timer(Sender: TObject); procedure rejouercoup1Click(Sender: TObject); procedure VitesseJeu1Click(Sender: TObject); procedure N11Click(Sender: TObject); procedure N21Click(Sender: TObject); procedure N31Click(Sender: TObject); procedure N41Click(Sender: TObject); procedure N51Click(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); private { Déclarations privées } public { Déclarations publiques } function etat_jeu:boolean; end; procedure chgt_joueur; procedure animfin; var Form1: TForm1; implementation var msgfin:string; //{$R *.dfm} procedure TForm1.Quitter1Click(Sender: TObject); begin close; end; procedure TForm1.FormCreate(Sender: TObject); begin sleep(500); phasecanne:=false; initialisation; timer2.enabled:=true; end; procedure tform1.initialisation; var i:integer; begin bmptravail:=tbitmap.create; table:=tbitmap.Create; table.LoadFromFile('billard2.bmp'); bmptravail.width:=paintbox1.Width; bmptravail.height:=paintbox1.height; bmptravail.assign(table); {copie l'un dans l'autre} for i:=1 to 16 do begin boule[i].x:= xinitial[i]; {boules prêtes au départ} boule[i].y:= yinitial[i]; boule[i].vx:=0; boule[i].vy:=0; boule[i].etat:=1; {1 <-> boule sur la table} if i=1 then boule[i].couleur:=clwhite; if i=2 then boule[i].couleur:=clblack; if (i>2) and (i<10) then boule[i].couleur:=clred; if (i>9) then boule[i].couleur:=clyellow; afficher_boule(i); end; { dimensions de la canne } ro[1]:= rboule*2; ro[2]:= rboule*3; ro[3]:= rboule*13; ro[4]:= rboule*15; ro[5]:= rboule*20; ro[6] := rboule*20+3; if not timer2.enabled then {ie si premier lancement} {---------------------------------------------} form1.Repaint; nvtour:=true; vites:=3; jr[1].couleur:=clblue; jr[2].couleur:=clblue; jr[1].bonus:=false; jr[2].bonus:=false; jr[1].first:=clblue; jr[2].first:=0; jr[1].nom:=nom1; jr[2].nom:=nom2; jr[1].rentrees:=false; jr[2].rentrees:=false; main:=1; mainpre:=1; {on donne la main au joueur 1} casse:=false; panel3.Caption:='Lancer une nouvelle partie'; timer3.Enabled:=false; end; procedure tform1.noms_joueurs; begin nom1:=form2.edit1.text; nom2:=form2.edit2.text; form1.Panel1.Font.Color:=jr[1].couleur; form1.Panel2.Font.Color:=jr[2].couleur; if main=1 then begin panel1.Font.style := [fsBold,fsUnderline]; {on souligne le nom du joueur qui a la main} panel2.Font.style := [fsBold]; end else begin panel2.Font.style := [fsBold,fsUnderline]; {on souligne le nom du joueur qui a la main} panel1.Font.style := [fsBold]; end; form1.Panel1.Caption:=nom1; form1.Panel2.Caption:=nom2; end; procedure TForm1.PaintBox1Paint(Sender: TObject); begin PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); {faut afficher manuellement car paintbox} end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin table.free; bmptravail.free; end; function tform1.etat_jeu:boolean; var i:integer; begin result:=true; {true si boules toutes à l'arrêt} for i:=1 to 16 do if (boule[i].vx<>0) or (boule[i].vy<>0) then result:=false; end; procedure TForm1.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if phasecanne and (boule[1].etat<>0) then begin {si boule blanche sortie mouseclick prend le relais} calculcanne(x, y ); afficher_canne(boule[1].x +decalagex, boule[1].y +decalagey,paintbox1 ); end; {panel1.Caption:=inttostr(x-decalagex); panel2.caption:=inttostr(y-decalagey); } end; procedure TForm1.Nouvellepartie1Click(Sender: TObject); begin timer2.enabled:=false; phasecanne:=false; if form2.ShowModal=mrok then begin initialisation; rejoue:=true; {évite bug d'affichage} end; timer2.enabled:=true; {normalement le prgm attend la fermeture de form2} PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); {réaffiche tte la table} end; procedure TForm1.Timer1Timer(Sender: TObject); var i,j:integer; {boucle avec j si trop lent} r:trect; {parce qu'il y a un décalage par rapport au paintbox} begin for j:=1 to vites do begin for i:=1 to 16 do begin nouvelle_position(i); end; efface_tout; {pour que les calculs ne perturbent pas l'affichage} for i:=1 to 16 do begin afficher_boule(i); end; {PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); } r:=rect(runion.left+decalagex,runion.top+decalagey,runion.Right+decalagex,runion.Bottom+decalagey); paintbox1.Canvas.CopyRect(r,bmptravail.Canvas,runion); end; end; procedure TForm1.Button2Click(Sender: TObject); var i:integer; begin for i:=1 to 16 do begin boule[i].vx:=1-random(3); boule[i].vy:=1-random(3); end; end; procedure TForm1.Button3Click(Sender: TObject); begin initialisation; end; procedure TForm1.Timer2Timer(Sender: TObject); begin jr[1].nom:=nom1;jr[2].nom:=nom2; noms_joueurs; if not etat_jeu then {au moins une boule en mouvement} begin timer1.enabled:=true; phasecanne:=false; {sûrement inutile dans la version finale} end else {boules à l'arrêt on commence un nv tour} begin timer1.Enabled:=false; if not form2.visible then phasecanne:=true; {évite bug d'affichage avec la fenêtre des noms de joueurs} if not nvtour then begin if (faute=-3) or (faute=4) then begin if faute=-3 then begin msgfin:=(jr[main].nom+' gagne'); end else begin msgfin:=(jr[inv(main)].nom+' gagne'); end; animfin; end else if jr[main].rentrees=false then begin if jr[main].first=clblue then faute:=2 {evite de refaire le test à chaque collision} else if (jr[main].couleur<>clblue) and (faute<>-2) and (jr[main].first<>jr[main].couleur) then faute:=5; if (jr[main].first=clblack) and (jr[main].rentrees=false) then faute:=6; if faute<=-1 then jr[main].bonus:=true; if faute>=1 then jr[main].bonus:=false; {une faute implique la perte du bonus} end; chgt_joueur; messages; {messages après chgt_joueur pour la cohérence des messages} {----------------------règles--------------------------} if (not casse) or (faute>=1) then jr[main].bonus:=true; {------------------------------------------------------} jr[main].first:=clblue; nvtour:=true; {nvtour effectif qd on a changé de joueur} faute:=0; end; end; end; procedure TForm1.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i,pasmain:integer; begin if (boule[3].etat=0) and (boule[4].etat=0) and (boule[5].etat=0) and (boule[6].etat=0) and (boule[7].etat=0) and (boule[8].etat=0) and (boule[9].etat=0) then begin if jr[main].couleur=clred then jr[main].rentrees:=true end; if (boule[10].etat=0) and (boule[11].etat=0) and (boule[12].etat=0) and (boule[13].etat=0) and (boule[14].etat=0) and (boule[15].etat=0) and (boule[16].etat=0) then begin if jr[main].couleur=clyellow then jr[main].rentrees:=true end; if phasecanne then if boule[1].etat<>0 then begin {on met la blanche en mouvement} phasecanne:=false; {pour pas que la canne s'efface automatiquement} boule[1].vx:= -force*cos1*Kforce; boule[1].vy:= -force*sin1*kforce; for i:=1 to 16 do begin boule[i].etatpre:=boule[i].etat; boule[i].xpre:=boule[i].x; boule[i].ypre:=boule[i].y; end; effacecanne(paintbox1); nvtour:=false; end else {remise en place de la blanche} begin replacer_blanche(x-decalagex,y-decalagey); afficher_boule(1); PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); {réaffiche tte la table} end; end; procedure tform1.messages; var i:integer; s:string; begin case faute of -3: s:='!!!!!!! GAGNE !!!!!!!'; -2: s:='!!!!!!!!! Première boule rentrée !!!!!!!!!'; -1: s:='Joli Coup !'; -4: s:='Bien Joué'; -7: s:='Pas Mal !!!'; -10: s:='Bravo'; -13: s:='Waouh !'; 0: s:=''; 1: s:='Faute! Veuillez replacer la boule blanche dans la zone de gauche'; 2: s:='Faute! Vous n'+char(658)+'avez touché aucune boule'; 3: s:='Faute! Boule adverse empochée * 2 coups pour '+jr[main].nom; 4: s:='PERDU...vous avez rentré la boule noire; '+jr[inv(main)].nom+' gagne la partie'; 5: s:='Faute! Boule adverse touchée'; 6: s:='Faute! Boule noire touchée en premier'; end; {il en faut un pour le case} panel3.Caption:=s; end; procedure chgt_joueur; begin mainpre:=main; if not jr[main].bonus then begin if main=1 then main:=2 else main:=1; end else jr[main].bonus:=false; {bonus utilisé} end; procedure animfin; var i:integer ; begin bmptravail.assign(table); form1.PaintBox1.Canvas.Draw(decalagex,decalagey,table); bmptravail.Canvas.Font.Color:=clblue; bmptravail.Canvas.Font.Size:=24; bmptravail.Canvas.Font.Name:='Comic sans ms'; for i:=1 to 16 do begin boule[i].x:=xanim[i]; {boules prêtes au départ} boule[i].y:=yanim[i]; boule[i].vx:=0; boule[i].vy:=0; boule[i].etat:=1; {1 <-> boule sur la table} boule[i].couleur:=boulcouleur[i]; afficher_boule(i); end; phasecanne:=false; form1.timer3.Enabled:=true; {à ce point c'est celui qui a rentré la noire qui a la main} end; procedure TForm1.Timer3Timer(Sender: TObject); var i:integer; begin bmptravail.Canvas.brush.color:=$2D6D2B; for i:=1 to 16 do begin boule[i].vx:=1-random(3); boule[i].vy:=1-random(3); end; bmptravail.Canvas.TextOut(180,125,msgfin); paintbox1.Canvas.Draw(decalagex,decalagey,bmptravail); end; procedure TForm1.rejouercoup1Click(Sender: TObject); var i:integer; begin if (timer3.enabled=false) and etat_jeu then begin rejoue:=true; bleu:=true; form1.timer3.Enabled:=false; main:=mainpre; panel3.caption:='Rejouez votre coup!!!'; for i:=1 to 16 do begin if boule[i].etatpre=0 then bleu:=false; effacer_boule(i); if i=1 then boule[i].couleur:=clwhite; if i=2 then boule[i].couleur:=clblack; if (i>2) and (i<10) then boule[i].couleur:=clred; if (i>9) then boule[i].couleur:=clyellow; boule[i].etat:=boule[i].etatpre; boule[i].vx:=0; boule[i].vy:=0; boule[i].x:=boule[i].xpre; boule[i].y:=boule[i].ypre; end; for i:=1 to 16 do afficher_boule(i); PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); form1.Repaint; if bleu=true then begin jr[main].couleur:=clblue; jr[inv(main)].couleur:=clblue end end; end; procedure TForm1.VitesseJeu1Click(Sender: TObject); begin rejoue:=false; end; procedure TForm1.N11Click(Sender: TObject); begin vites:=1; end; procedure TForm1.N21Click(Sender: TObject); begin vites:=2; end; procedure TForm1.N31Click(Sender: TObject); begin vites:=3; end; procedure TForm1.N41Click(Sender: TObject); begin vites:=4; end; procedure TForm1.N51Click(Sender: TObject); begin vites:=5; end; procedure TForm1.SpeedButton1Click(Sender: TObject); var i:integer; begin if (timer3.enabled=false) and etat_jeu then begin rejoue:=true; bleu:=true; form1.timer3.Enabled:=false; main:=mainpre; panel3.caption:='Rejouez votre coup!!!'; for i:=1 to 16 do begin if boule[i].etatpre=0 then bleu:=false; effacer_boule(i); if i=1 then boule[i].couleur:=clwhite; if i=2 then boule[i].couleur:=clblack; if (i>2) and (i<10) then boule[i].couleur:=clred; if (i>9) then boule[i].couleur:=clyellow; boule[i].etat:=boule[i].etatpre; boule[i].vx:=0; boule[i].vy:=0; boule[i].x:=boule[i].xpre; boule[i].y:=boule[i].ypre; end; for i:=1 to 16 do afficher_boule(i); PaintBox1.Canvas.Draw(decalagex,decalagey,bmptravail); form1.Repaint; if bleu=true then begin jr[main].couleur:=clblue; jr[inv(main)].couleur:=clblue end end; end; end. //main app pro form program Billard; uses Forms, Unit1 in 'Unit1.pas' {Form1}, zone_de_jeu in 'zone_de_jeu.pas', Boules in 'Boules.pas', variables in 'variables.pas', canne in 'CANNE.PAS', Noms in 'Noms.pas' {Form2}, splash in 'splash.pas' {Form4}; //{$R *.res} var form4:tform4; begin Application.Initialize; Form4 := Tform4.create(application); Form4.Show; // affichage de la fiche Form4.Update; // force la fiche à se dessiner complètement try Form4.Close; Application.CreateForm(TForm1, Form1); Application.CreateForm(TForm2, Form2); finally Form4.Release;// libération de la mémoire end; Application.CreateForm(TForm4, Form4); Application.Run; end. As you probably know, a double buffer normally involves creating an off-screen memory buffer the same size as the visual component. Writing/drawing is performed on this buffer and when complete, the entire buffer is "swapped" so that it is now painted on the visual component. (Note: "swapping" may consist of simply changing the address a pointer points to, or may actually involve copying a chunk of memory such as using BitBlt, memcpy etc) Therefore a reasonable amount of memory allocated to support this process for each component it is enabled for. If your application has many windows or and/or components there would be a not insignificant amount of memory allocated. If you do not require smooth visual updates/scrolling, why waste this memory? Of course there is also an argument that today most computers have plenty of memory to spare, so why worry. However I still don't see this as a reason to default to enabling Double Buffering if you don't need it. If manually setting DoubleBuffered to true is a pain for you, you could always create your own custom control/component that inherits from the built-in control, and sets DoubleBuffered (and other properties) to your required defaults. On a modern OS which does desktop compositing double buffering may actually decrease performance. Rendering is performed into an off-screen bitmap anyway, so using double buffering leads to an extra copying for no benefit at all on those systems. So unless the VCL is smart enough to ignore the double buffering in that case (don't know whether it does, would need to check) it may actually be better to not set it unconditionally.