USES Crt, Graph; TYPE Matriz=Array[0..21,0..11] Of Integer; Tipopeca=Array[0..3,0..3] Of Integer; TName=string[8]; TMenu=record punkt:array[0..20]of string; {массив пунктов меню} Count:integer;{количество} Activ:integer; {активность} Height:integer; {высота} end; TFileRec=record Name:TName; TLines:word; end; TRecDem=record Name:byte; kod:char; end; VAR save_dem:File of TRecDem; rec:TRecDem; F:File of TFileRec; Work:TFileRec; MainMenu,Option:TMenu; Q:String; key:char; Old,Score:LongInt; Lines,t:word; x_menu,y_menu,Speed,NumNex,Prox,A,I,J,level,index,Graphdriver,Graphmode,Bant:Integer; Field, Field1, Field2 : Matriz; Next,Pecai, Pecal, Pecaf, Pecat, Pecao, Pecas, Peca2,Figura: Tipopeca; x,y,Con,Num,size,save_speed,save_str:byte; Activ,Fim, Turn, Game,Right,Left,Top,Novapeca,Demo_save,Demo_load: Boolean; {****************************************************************************} Procedure PainMenu;forward; Procedure PainPunkt(MainMenu:TMenu;index:integer;Activ:boolean);forward; Procedure CreatFigurField; Begin Randomize; For I:= 0 To 3 Do For J:= 0 To 3 Do Begin Pecai [I, J] := 0; Pecao [I, J] := 0; Pecal [I, J] := 0; Pecaf [I, J] := 0; Pecat [I, J] := 0; Pecas [I, J] := 0; Peca2 [I, J] := 0; End; For I:= 0 To 3 Do Pecai [2, I] := 1; For I:= 1 To 3 Do Pecal [2, I] := 1; Pecal [1, 3] := 1; For I:= 1 To 3 Do Pecaf [2, I] := 1; Pecaf [1, 1] := 1; For I:= 0 To 1 Do Pecas [I, 1] := 1; For I:= 1 To 2 Do Pecas [I, 2] := 1; For I:= 0 To 1 Do Peca2 [I, 2] := 1; For I:= 1 To 2 Do Peca2 [I, 1] := 1; For I:= 1 To 3 Do Pecat [2, I] := 1; Pecat [1, 2] := 1; For I:= 1 To 2 Do Pecao [1, I] := 1; For I:= 1 To 2 Do Pecao [2, I] := 1; {**********CreatField****************} For I:= 1 To 20 Do For J:= 1 To 10 Do Field [I, J] := 0; For I:= 1 To 21 Do Field [I, 0] := 1; For I:= 1 To 21 Do Field [I, 11] := 1; For J:= 0 To 11 Do Field [21, J] := 1; SetBkColor (black);{Cvet fona} SetColor (White);{Cvet ramki} Line (214, 25, 214, 425); {left Line} Line (415, 25, 415, 425); {right line} Line (215, 425, 414, 425); {nignyaa line} End; Procedure Botao(Col, Lin, Col1, Lin1: Integer); {graphika} Begin SetFillStyle (1, 7); {cvet camogo kvadratika figyrki, bez akontovki i t.d.} Bar (col, Lin, Col1, Lin1); SetColor (15); {{cvet figyrok megdu kvadratami vverhu i left} { SetLineStyle (1, 1, 1);} Line (Col, Lin, Col1, Lin); Line (Col, Lin, Col, Lin1); Line (Col, Lin+ 1, Col1, Lin+ 1); Line (Col+ 1, Lin, Col+ 1, Lin1); Line (Col, Lin+ 2, Col1, Lin+ 2); Line (Col+ 2, Lin, Col+ 2, Lin1); SetColor (8);{cvet figyrok megdu kvadratami vnizu i right} Line (Col, Lin1, Col1, Lin1); Line (Col+ 1, Lin1- 1, Col1, Lin1- 1); Line (Col+ 2, Lin1- 2, Col1, Lin1- 2); Line (Col1, Lin, Col1, Lin1); Line (Col1- 1, Lin+ 1, Col1- 1, Lin1); Line (Col1- 2, Lin+ 2, Col1- 2, Lin1); SetColor (7); {cvet liniy v uglah figurki} Line (Col, Lin, Col+ 2, Lin+ 2); Line (Col1, Lin1, Col1- 2, Lin1- 2); End; Procedure Pain; Var i,j:byte; Strin:string[5]; Begin For i:= 1 To 20 Do For j:= 1 To 10 Do Begin If Field [i,j] = 0 Then Begin SetFillStyle (1,black); {cvet fona v zone igri} Bar ( (j-1) * 20+215, (i-1) * 20+ 25, (j-1) * 20+ 19+ 215, (i-1) * 20+ 19+ 25); End Else If Field[i,j] <> Field2[i,j] Then Begin Botao ( (j-1) * 20+215, (i-1) * 20+ 25, (j-1) * 20+234, (i-1) * 20+ 44); End; End; End; Procedure Best; Var Strin:string[8]; k:word; Begin k:=200; SetFillStyle(1,black); Bar(440,200,650,400); SetColor(Green); OutTextXY(445,k,' ***The Best Result*** '); SetColor(Red); Seek(F,0); While (not Eof(F)) do Begin k:=k+15; Read(F,Work); With Work do begin OutTextXY(500,k, Name); Str(TLines, Strin); OutTextXY(610,k,Strin) end; end; End; Procedure Infa; Var Strin:string[5]; Begin If Old<>Score Then Begin SetFillStyle(1,black); Old:=Score; Bar (1, 1, 100, 98); SetColor (White); OutTextXY (520, 85, 'Next'); Str (Score, Strin); OutTextXY (5,10,'Score:'+ Strin); Str (Lines, Strin); OutTextXY (5,30,'Lines:'+ Strin); Str (Speed, Strin); OutTextXY (5,50,'Speed:'+ Strin); Str (Level, Strin); OutTextXY (5,70,'Level:'+ Strin); End End; Procedure PainNext; var i,j:byte; Begin For i:= 0 To 3 Do For j:= 0 To 3 Do Begin If Next [i,j] = 0 Then Begin SetFillStyle (1, Black); Bar ( (J- 1) * 20+ 515, (I- 1) * 20+ 25, (J- 1) * 20+ 19+ 515, (I- 1) * 20+ 19+ 25); End Else Begin Botao( (J- 1) * 20+ 515, (I- 1) * 20+ 25, (J- 1) * 20+ 19+ 515, (I- 1) * 20+ 19+ 25); End; End; End; Procedure Sorteia; {vibor figuri} Begin if Demo_load then begin Seek(save_dem,t); read(save_dem,rec); NumNex:=rec.Name; end else Numnex:= Random (7); if demo_save then begin rec.Name:=Numnex; rec.kod:='+'; write(save_dem,rec); end; If Numnex= 0 Then Next:= Pecal{l figura ugol vlevo} Else If Numnex= 1 Then Next:= Pecaf{f figura ugol napravo} Else If Numnex= 2 Then Next:= Pecai {i figura palka} Else If Numnex= 3 Then Next:= Pecao {o figura kvadrat} Else If Numnex= 4 Then Next:= Pecas {s figura krivaya napravo} Else If Numnex= 5 Then Next:= Peca2 {2 figura krivaya nalevo} Else If Numnex= 6 Then Next:= Pecat;{t figura fuck} End; Procedure LinesDelete; Var Aux:word; Cima:Matriz; i,j,k,Lin:byte; Begin Aux:= Lines; For I:= 20 Downto 1 Do Begin k:=0; For J:= 1 To 10 Do If Field [I, J] = 1 Then k:=k+1; If k=10 Then Begin For J:= 1 To 10 Do Begin Field [I, J] := 0; End; Inc (Lines, 1); For Lin:= 1 To (I- 1) Do For J:= 1 To 10 Do Begin Cima [Lin, J] := Field [Lin, J]; Field [Lin, J] := 0; End; For Lin:= 2 To I Do For J:= 1 To 10 Do Field [Lin, J] := Cima [Lin- 1, J]; End; End; Score:= Score + ( (Lines- Aux) * 30); End; Procedure MoveDemo; Var Pecagira:Tipopeca; i,j:byte; Begin key:=rec.kod; If Ord(key)=77 Then Begin {strelka right} If Right= True Then Begin Inc (x,1); {dvigenie figuri v right na 1} Inc (Con, 1); If Con< 4 Then dec(y,1); If Con>= 4 Then Begin Con:= 0; Dec(x,1); End; End; End Else If Ord(key)=75 Then Begin {strelka left} If Left= True Then Begin Dec (x, 1); {dvigenie figuri v left na 1} Inc (Con, 1); If Con< 4 Then Dec (y,1); If Con>= 4 Then Begin Con:= 0; Inc (x, 1); End; End; End Else If Ord(key)=72 Then Begin {strelka vverh} If Top=True Then Begin Inc (Con, 1); If Con< 24 Then Dec (y,1); If Con>= 2 Then Con:= 0; Pecagira:=Figura; If (Num= 0) Or (Num= 1) Or (Num= 6) Then Begin For I:= 1 To 3 Do Begin Figura [3, I] := Pecagira [I, 1]; Figura [2, I] := Pecagira [I, 2]; Figura [1, I] := Pecagira [I, 3]; End; End Else If (Num= 4) Or (Num= 5) Then Begin If Turn= True Then Begin For I:= 0 To 3 Do Begin Figura [3, I] := Pecagira [I, 0]; Figura [2, I] := Pecagira [I, 1]; Figura [1, I] := Pecagira [I, 2]; Figura [0, I] := Pecagira [I, 3]; Turn:= False; End; End Else If Turn= False Then Begin If Num= 4 Then Figura:= Pecas;{s} If Num= 5 Then Figura:= Peca2;{2} Turn:= True; End; End Else If Num= 2 Then Begin For i:= 0 To 3 Do For j:= 0 To 3 Do Figura [i,j] := Pecagira [j,i]; End; End; End; If Ord(key)=80 Then Speed:=0 {ctrelka vniz} End; Procedure Move; Var Pecagira:Tipopeca; i,j:byte; Begin If KeyPressed Then Begin key:=ReadKey; if demo_save then begin rec.kod:=key; rec.Name:=Num; Write(save_dem,rec); end; If Ord(key)=77 Then Begin {strelka right} If Right= True Then Begin Inc (x,1); {dvigenie figuri v right na 1} Inc (Con, 1); If Con< 4 Then dec(y,1); If Con>= 4 Then Begin Con:= 0; Dec(x,1); End; End; End Else If Ord(key)=75 Then Begin {strelka left} If Left= True Then Begin Dec (x, 1); {dvigenie figuri v left na 1} Inc (Con, 1); If Con< 4 Then Dec (y,1); If Con>= 4 Then Begin Con:= 0; Inc (x, 1); End; End; End Else If Ord(key)=72 Then Begin {strelka vverh} If Top=True Then Begin Inc (Con, 1); If Con< 2 Then Dec (y,1); If Con>= 2 Then Con:= 0; Pecagira:=Figura; If (Num= 0) Or (Num= 1) Or (Num= 6) Then Begin For I:= 1 To 3 Do Begin Figura [3, I] := Pecagira [I, 1]; Figura [2, I] := Pecagira [I, 2]; Figura [1, I] := Pecagira [I, 3]; End; End Else If (Num= 4) Or (Num= 5) Then Begin If Turn= True Then Begin For I:= 0 To 3 Do Begin Figura [3, I] := Pecagira [I, 0]; Figura [2, I] := Pecagira [I, 1]; Figura [1, I] := Pecagira [I, 2]; Figura [0, I] := Pecagira [I, 3]; Turn:= False; End; End Else If Turn= False Then Begin If Num= 4 Then Figura:= Pecas;{s} If Num= 5 Then Figura:= Peca2;{2} Turn:= True; End; End Else If Num= 2 Then Begin For i:= 0 To 3 Do For j:= 0 To 3 Do Figura [i,j] := Pecagira [j,i]; End; End; End; If Ord(key)=80 Then Speed:=0 {ctrelka vniz} End else if demo_save then begin rec.kod:='0'; rec.Name:=Num; Write(save_dem,rec); end; End; {***********************************FILE*************************************} Procedure InitFile; var k:byte; Begin Assign(F,'rec.dat'); {$I-} Reset(F); {$I+} if IOResult<>0 then begin Rewrite(F); for k:=0 to 6 do begin Seek(F,k); Work.TLines:=0; Work.Name:=' '; Write(F,Work); end; end; End; {****************************************************************************} Procedure Options; var k,k1:word; c,d,str:byte; Begin Randomize; cleardevice; SetBKColor(blue); TextColor(red); OutTextXY(200, 20,'********OPTIONS********'); Option.Punkt[0]:='Speed'; Option.Punkt[1]:='Level'; Option.Height:=60; Option.Count:=2; for c:=0 to Option.Count-1 do PainPunkt(Option,c,c=Option.Activ); k:=300; k1:=300; c:=save_speed; str:=save_str; if c>0 then for d:=1 to c do begin SetFillStyle(1,yellow); Bar(k,97,k+15,112); k:=k+30; end; if str>0 then for d:=1 to str do begin SetFillStyle(1,yellow); Bar(k1,134,k1+15,149); k1:=k1+30 end; repeat key:=readkey; if ord(key)=80 then Begin PainPunkt(Option,option.Activ,false); if Option.Activ<>Option.Count-1 then inc(Option.Activ) else Option.Activ:=0; PainPunkt(Option,Option.Activ,true); End; if ord(key)=72 then Begin PainPunkt(Option,Option.Activ,false); if Option.Activ<>0 then dec(Option.Activ) else Option.Activ:=Option.Count-1; PainPunkt(Option,Option.Activ,true); End; if ord(key)=77 then Begin if c<5 then begin if Option.Activ=0 then begin SetFillStyle(1,yellow); Bar(k,97,k+15,112); k:=k+30; inc(c) end; end; if str<5 then begin if Option.Activ<>0 then begin SetFillStyle(1,yellow); Bar(k1,134,k1+15,149); k1:=k1+30; inc(str); end; end; end; if ord(key)=75 then Begin if c>1 then begin if Option.Activ=0 then begin k:=k-30; SetFillStyle(1,blue); Bar(k,97,k+15,112); dec(c) end; end; if str>0 then begin if Option.Activ<>0 then begin k1:=k1-30; SetFillStyle(1,blue); Bar(k1,134,k1+15,149); dec(str); end; end; End; until key=#27; save_speed:=c; save_str:=str; End; {***********************************AlgoritmGame*****************************} Procedure Igra; Begin InitFile; CreatFigurField; if save_str>0 then for i:=1 to save_str do for j:=1 to 10 do Field[21-i,j]:=Random(2); Pain; Best; if Demo_load then t:=0; Sorteia; if Demo_load then inc(t); Old:= 0; Con:= 0; Score:=0; Lines:= 0; Fim:= False; Game:= True; key:='0'; Repeat Speed:=20000 div save_speed; level:= 1; {uroven'} Inc (Score,10);{uvelichivaet score} Speed:= Speed-((Lines Div 2)*100); level:= level+ (Score Div 1000); Novapeca:= False; Figura:= Next; Num:= Numnex; Sorteia; if Demo_load then inc(t); Turn:= True; x:=4;{chtob figuri poyavlyalis' poceredine po gorizontali} y:=0;{chtob figuri poyavlyalis' poceredine po vertekali} PainNext; Repeat Delay(Speed); {Eto zadergka poleta} if Demo_load then begin Seek(save_dem,t); read(save_dem,rec); if rec.kod<>'0' then MoveDemo; Inc(t); Seek(save_dem,t); Read(save_dem,rec); if rec.kod<>'0' then MoveDemo; inc(t); end else begin Move; Move; end; If y= Bant+ 1 Then Con:= 0; Left:=True; Right:=True; Top:= True; Field2:= Field; LinesDelete; Field1:= Field; For I:= 0 To 2 Do For J:= 0 To 2 Do Begin If (Num= 4) Or (Num= 5) Then If Field [I+y,J+x] = 1 Then Top:= False; End; For I:= 1 To 3 Do For J:= 1 To 3 Do Begin If (Num= 6) Or (Num= 0) Or (Num= 1) Then If Field [I+y,J+x] = 1 Then Top:= False; End; For I:= 0 To 3 Do For J:= 0 To 3 Do If Novapeca= False Then Begin If Num= 3 Then Top:= False; If Num= 2 Then If Field [I+y,J+x] = 1 Then Top:= False; If Field [I+y,J+x] <> 1 Then Begin Field [I+y,J+x] := Figura [I, J]; If (Field [I+y,J+x+ 1] ) + (Figura [I, J] ) = 2 Then Right:=False; If (Field1[I+y,J+x-1] ) + (Figura [I, J] ) = 2 Then Left:=False; If (Field [I+y+1,J+x] ) + (Figura [I, J] ) = 2 Then Begin For I:= 0 To 3 Do For J:= 0 To 3 Do If Field [I+y,J+x] <> 1 Then Field [I+y,J+x] := Figura [I, J]; Infa; Pain; Novapeca:= True; End; End; End; If Novapeca= False Then Begin Infa; Pain; For I:= 0 To 3 Do For J:= 0 To 3 Do If Field1 [I+y,J+x] <> 1 Then Field [I+y,J+x] := 0; Bant:=y; Inc (y,1); End; If KeyPressed then Begin key:=ReadKey; if Demo_save then begin rec.kod:=key; rec.Name:=num; Write(save_dem,rec); end; End; { if Demo_load then begin Seek(save_dem,t); Read(save_dem,rec); key:=rec.kod; inc(t); end; } If Ord(key)=27 then Fim:=True; Until (Novapeca= True) Or (Fim= True); For J:= 4 To 6 Do If Field [1, J] = 1 Then Game:= False; Until (Game= False) Or (Fim= True); if Fim=False then begin for i:=0 to 4 do begin Seek(F,i); Read(F,Work); if Work.TLines0 then dec(MainMenu.Activ) else MainMenu.Activ:=MainMenu.Count-1; PainPunkt(MainMenu,MainMenu.Activ,true); end; #80:begin PainPunkt(MainMenu,MainMenu.Activ,false); if MainMenu.Activ<>MainMenu.Count-1 then inc(MainMenu.Activ) else MainMenu.Activ:=0; PainPunkt(MainMenu,MainMenu.Activ,true); end; #13:case MainMenu.Activ of 0:Igra; 1:begin Options; PainMenu end; 2: begin Assign(save_dem,'demo.sav'); Rewrite(save_dem); Demo_save:=true; Igra; end; 3: begin Demo_load:=True; Assign(save_dem,'demo.save'); {$I-} Reset(save_dem); {$I+} if IOResult<>0 then begin SetFillStyle(1,yellow); TextColor(black); Bar(200,150,450,350); OutTextXY(230,170,'File demo not exist!!!'); Demo_load:=False; repeat key:=readkey; until ord(key)=27; PainMenu; end else Igra; end; 4: break; end end; until 1<>1; end; {***************************OsnovnoyAlgoritm*********************************} BEGIN DetectGraph (Graphdriver, Graphmode); InitGraph (Graphdriver, Graphmode, 'C:\BP\BGI'); Demo_save:=False; Demo_load:=False; Save_Speed:=1; Save_str:=0; InitMenu; PainMenu; MainMenuRun; CloseGraph END.