|
Program Tris; { $Id: gplprog.pt,v 1.2 2002/09/07 15:40:47 peter Exp 2010/02/14 13:11:28 peter Exp $ This file is part of Tris Application Copyright (c) 2010 by Phi Gioco del Tris This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {**** Programma compilato con Free Pascal ****} {$R risorsetris.res} {$apptype gui} uses windows, graph, winmouse, dos; type arrstr = array of char; zona = (vuota, croce, cerchio); campo = array[1..3,1..3] of zona; time = record h, min, sec, s100 : word; end; partita = record punti : array[croce..cerchio]of byte; match : campo; turno, t1 : byte; turni : Qword; end; bit8 = string[8]; lettera = array[1..12] of array[1..12] of byte; const G1 : integer = VGA; G2 : integer = 2; Salv = 'tris\salv.tris'; Titolo : pchar = 'Tris v1.2'; function tempo : time; begin gettime(tempo.h,tempo.min,tempo.sec,tempo.s100); end; var icona : hicon; ch : lettera; I, J : longword; K, V, W, l1, l2, lz1, lz2 : byte; cont : longword; col, dim : byte; s : string[150]; S8 : bit8; function str (R : real; A, B : byte):string; begin system.str(R:A:B,str); end; function strpc (S:string):Pchar; begin strpc := nil; strpc := @S; end; Function ExtractIcon(hInst: HINST; lpszExeFileName :LPCSTR ; nIconIndex : UINT):HICON; stdcall;external 'shell32.dll' name 'ExtractIconA'; function let(C:char;B:byte):bit8;external 'phi immgrd' name'lettera'; procedure carica(C : byte);external 'phi immgrd' name 'carica'; function letf(C : char) : lettera;external 'phi immgrd' name 'letteratipo'; procedure writeln(X,Y : word;S:string); begin for I := 1 to length(S) do for J := 0 to 7 do begin S8 := let(S[i],J); for K := 1 to 8 do for V := 1 to dim do for W := 1 to dim do if S8[K]='1' then putpixel(X+(I-1)*9+j*dim-1+v,y+(8-K)*dim+w,col); end; end; procedure linea(x,y,x2,y2:word;dim:byte); begin cont := 0; for cont := 0 to dim do begin line(x+cont,y,x2+cont,y2); line(x-cont,y,x2-cont,y2); line(x,y+cont,x2,y2+cont); line(x,y-cont,x2,y2-cont); end; end; procedure rettsmus(const x1,y1,x2,y2 : word); begin line(x1,(y1+6),x1,(y2-6)); line((x1+6),y1,(x2-6),y1); line(x2,(y1+6),x2,(y2-6)); line((x1+6),y2,(x2-6),y2); arc((x2-6),(y1+6),0,90,6); arc((x1+6),(y1+6),90,180,6); arc((x1+6),(y2-6),180,270,6); arc((x2-6),(y2-6),270,360,6); end; var win, chiudi, pieno : boolean; wins : zona; F : file of partita; M : partita; t : time; pc : byte; b, x, y : longint; R : searchRec; procedure camp; begin setcolor(0); for I := 1 to 150 do begin setrgbpalette(0,150-I,150-I,150-I); rectangle(200-I,235-I,199+I,235+I); end; for I := 1 to 50 do begin setrgbpalette(0,100-I,100-I,100-I); rectangle(470-I,151-I,530+I,150+I); end; for I := 1 to 26 do begin setrgbpalette(0,100-I,100-I,100-I); rectangle(445-I,376-I,555+I,375+I); end; setcolor(15); linea(150,85,150,384,1); linea(250,85,250,384,1); linea(50,185,350,185,1); linea(50,285,350,285,1); linea(420,140,580,140,1); linea(500,101,500,201,1); dim := 2; col := 15; writeln(451,110,'X'); writeln(533,110,'0'); dim := 1; writeln(425,355,'E'' il turno di:'); settextstyle(0,0,2); outtextxy(451,160,str(M.punti[croce],1,0)); outtextxy(533,160,str(M.punti[cerchio],1,0)); if M.turno = 1 then outtextxy(490,380,'X') else outtextxy(490,380,'0'); setcolor(0); for I := 1 to 11 do begin if (I mod 3) = 0 then setrgbpalette(0,0,0,0) else setrgbpalette(0,128+(I div 10)*I*3,64+(I div 10)*I*3,0); rectangle(50-I,85-I,349+I,384+I); end; for I := 1 to 10 do begin if (I mod 3) = 0 then setrgbpalette(0,0,0,0) else setrgbpalette(0,128+(I div 10)*I*3,64+(I div 8)*I*3,0); rectangle(420-I,101-I,580+I,200+I); end; for I := 1 to 10 do begin if (I mod 3) = 0 then setrgbpalette(0,0,0,0) else setrgbpalette(0,128+(I div 10)*I*3,64+(I div 8)*I*3,0); rectangle(420-I,350-I,580+I,400+I); end; setrgbpalette(0,0,0,0); setcolor(15); for I := 1 to 3 do for J := 1 to 3 do begin if M.match[I,J]=croce then begin linea(I*100-40,j*100-5,40+I*100,75+j*100,2); linea(I*100-40,75+j*100,40+I*100,j*100-5,2); end; if M.match[I,J]=cerchio then for cont := 1 to 5 do circle(I*100,35+j*100,35+cont) end; end; procedure ntime; begin t := tempo; bar3d(554,464,636,478,3,true); bar(556,466,634,476); col := 4;dim := 1; writeln(560,467,concat(str(t.h,2,0),':',str(t.min,2,0),':',str(t.sec,2,0))); end; procedure mouse (var x,y : longint); begin repeat getmousestate(x,y,b); sleep(15); ntime; until b = 0; repeat getmousestate(x,y,b); sleep(15); ntime; until b = 1; end; procedure tasto; var O : byte; begin setcolor(4); O := 0; repeat mouse(x,y); if (y>9) and (y<30) and (x>=500) and(x<630) then begin chiudi := true; O := 1; end; if (y>39) and (y<60) and (x>=500) and(x<630) then halt(0); if (x>50) and (x < 350) and (y>85) and (y < 384) then if M.match[(x+50)div 100,(y+15) div 100] = vuota then begin O := 1; if M.turno = 1 then M.match[(x+50)div 100,(y+15) div 100]:= croce else M.match[(x+50)div 100,(y+15) div 100] := cerchio; end; if (x>555) and (x < 636) and (y>462) and (y < 478) then exec('orologio.exe',''); until O = 1; end; BEGIN randomize;col := 0; dim := 1; pc := 0; icona := extracticon(hinstance,'Tris.exe',0); graph.icon := icona; windowtitle := Titolo; carica(1); Assign(F,Salv); findfirst(salv,anyfile,R); if DosError= 0 then if MessageBox(parentWindow,'Vuoi caricare la partita salvata','Tris',MB_IconQuestion Or MB_YesNo)=IdYes then begin reset(F); read(F,M); close(F); pc := 1; end; if pc <> 1 then MessageBox(parentWindow,'Estrazione 1'#176' giocatore','Tris',MB_IconQuestion); initgraph(G1,G2,''); setcolor(0); for I := 1 to 558 do begin setrgbpalette(0,200-(I*160)div 500,200-(I*160)div 600,210); setcolor(0); line(1,I,I,1); line(1,1116-I,1116-I,1); end; icona:=extracticon(hinstance,'phi immgrd.dll',0); drawicon(windc,5,445,icona); drawicon(bitmapdc,5,445,icona); for I:= 0 to 4 do begin ch:=letf(titolo[i]); for l1 := 1 to 12 do for l2 := 1 to 12 do if (ch[l1,l2]<>0)then for lz1 := 1 to 2 do for lz2 := 1 to 2 do begin setrgbpalette(0,100+(ch[l1,l2]*150 div 255),20,20); putpixel(160+(i-1)*20+l1*2+lz1-1,10+l2*2+lz2-1,0); end; end; for I := 0 to 9 do begin setrgbpalette(0,250-(I div 5)*I*20,250-(I div 5)*I*20,250-(I div 5)*I*20); rettsmus(500-I,19-I,620+I,20+I); end; writeln(500,16,'SALVA E CHIUDI'); for I := 0 to 9 do begin setrgbpalette(0,250-(I div 5)*I*20,250-(I div 5)*I*20,250-(I div 5)*I*20); rettsmus(500-I,49-I,620+I,50+I); end; writeln(510,46,'CHIUDI'); camp; if (pc=1) then begin if M.turno = 1 then S := 'Tocca al Giocatore "croce"' else S:= 'Tocca al Giocatore "cherchio"'; S[0]:=#32; MessageBox(parentWindow,@S,'Tris',MB_IconQuestion Or MB_oK); end else begin if (random(2) = 1) then M.turno := 1 else M.turno := 0; M.t1 := M.turno; M.turni := 0; if M.turno = 1 then MessageBox(GraphWindow,'Inizia il Giocatore "croce"','Tris',MB_IconQuestion Or MB_oK) else MessageBox(GraphWindow,'Inizia il Giocatore "cherchio"','Tris',MB_IconQuestion Or MB_oK); end; repeat wins := vuota; repeat camp; tasto; camp; if M.turno = 0 then inc(M.turno) else M.turno := 0; for I := 1 to 3 do if ((M.match[I,1] = M.match[I,2]) and (M.match[I,1] = M.match[I,3])) then if M.match[I,1] <> vuota then wins := M.match[I,1]; for I := 1 to 3 do if ((M.match[1,I] = M.match[2,I]) and (M.match[1,I] = M.match[3,I])) then if M.match[1,I] <> vuota then wins := M.match[1,I]; if ((M.match[1,1] = M.match[2,2])and(M.match[2,2] = M.match[3,3])) or ((M.match[1,3] = M.match[2,2])and(M.match[2,2] = M.match[3,1])) then if M.match[2,2] <> vuota then wins := M.match[2,2]; pieno := true; for I := 1 to 3 do for J := 1 to 3 do if (M.match[I,J] = vuota) then pieno := false; until (wins<>vuota) or chiudi or pieno; if wins <> vuota then inc(M.punti[wins]); if not(chiudi) then begin for I := 1 to 3 do for J := 1 to 3 do M.match[I,J] := vuota; inc(M.turni); beep(200,200); if (M.turni mod 2) = 0 then M.turno := M.t1 else if M.t1 = 0 then M.turno:=1 else M.turno := 0; camp; if (M.punti[croce] = 5)and(M.punti[cerchio] = 5) then if M.turno = 1 then MessageBox(parentWindow,'Tocca al Giocatore "croce"','Tris',MB_IconQuestion Or MB_oK) else MessageBox(parentWindow,'Tocca al Giocatore "cherchio"','Tris',MB_IconQuestion Or MB_oK); end; sleep(50); for wins := croce to cerchio do if M.punti[wins] = 3 then begin sleep(50); setcolor(0); for I := 1 to 150 do begin setrgbpalette(0,200-I,200-I,250-I); rectangle(200-I,235-I,199+I,235+I); end; setcolor(2); settextstyle(0,0,4); if wins = cerchio then outtextxy(90,140,'CERCHIO') else outtextxy(115,140,'CROCE'); outtextxy(115,200,'VINCE'); outtextxy(130,260,'!!!!'); win := true; beep(310,150); sleep(20); beep(310,150); sleep(20); sleep(150); beep(210,105); sleep(20); beep(208,100); beep(206,1); sleep(3000); end; until win or chiudi; if chiudi then begin rewrite(F); write(F,M); close(F); end else if pc = 1 then erase(F); END.
|
|
