Program FLAG; uses crt,graph,rusfont,menu_1_1; type PCircle = ^TCircle; Tcircle = object x,y,Radius,rradius : integer; color:byte; visible:boolean; Constructor Init(ix,iy:integer; iRadius:integer; icolor: byte); procedure Show; procedure hide; procedure drag(step:integer;ch:char;nomer1:pcircle); procedure MoveTo(xnew,ynew:integer); function isvisible:boolean; end; var driver,i,mode:integer; p1,p2,p3:pcircle; Ch:char; score:integer; t:boolean; buf:string; procedure igrpole; begin setbkcolor(blue); bar(0,0,640,480); setcolor(darkgray); setfillstyle(solidfill,4); bar(120,6,276,162); setfillstyle(solidfill,15); bar(276,6,432,162); setfillstyle(solidfill,15); bar(432,6,588,162); setfillstyle(solidfill,1); bar(276,162,432,318); setfillstyle(solidfill,15); bar(120,162,276,318); setfillstyle(solidfill,15); bar(432,162,588,318); setfillstyle(solidfill,2); bar(432,318,588,474); setfillstyle(solidfill,15); bar(120,318,276,474); setfillstyle(solidfill,15); bar(276,318,432,474); setcolor(darkgray); for i:=157 to 167 do line(120,i,276,i); for i:=427 to 437 do line(i,6,i,162); for i:=313 to 323 do line(120,i,432,i); line(120,6,588,6); line(120,6,120,474); line(120,474,588,474); line(588,6,588,474); line(276,6,276,474); line(432,6,432,474); line(120,162,588,162); line(120,318,588,318); setcolor(getbkcolor); end; constructor Tcircle.init; begin x:=ix; y:=iy; radius:=iradius; color:=icolor; visible:=false; end; procedure help; begin setcolor(blue); bar(0,0,640,480); outtextxy (300,50,'ПОМОЩЬ'); setcolor(blue); outtextxy(300,120,'Жанр игры - Логическая задача'); setcolor(black); outtextxy(300,150,'Управление:'); setcolor(black); outtextxy(300,180,'Стрелка Вверх - Движение всех шариков вверх'); outtextxy(301,210,'Стрелка Вверх - Движение всех шариков вверх'); outtextxy(302,240,'Стрелка Вверх - Движение всех шариков вверх'); outtextxy(303,270,'Стрелка Вверх - Движение всех шариков вверх'); outtextxy(300,300,'Задача:Поставить каждый шарик на позицию с его цветом'); readkey; end; function Tcircle.IsVisible; begin IsVisible:=visible; end; procedure Tcircle.show; var tempcolor:byte; begin tempcolor:=getcolor; setcolor(color); setfillstyle(solidfill,color); fillellipse(x,y,radius,radius); visible:=true; setcolor(tempcolor); end; function check_1(p1, p2: pcircle; X, y1, y2: integer): boolean; begin check_1:= ((p1^.x <> X) or (p1^.y <> y1)) or ((p2^.x <> X) or (p2^.y <> y2)) end; function check_2(p1, p2: pcircle; X, y1, y2: integer): boolean; begin check_2 := check_1(p1, p2, X, y1, y2) and check_1(p1, p2, X, y2, y1); end; function check_3(p1, p2: pcircle; x1, x2, Y: integer): boolean; begin check_3 := ((p1^.x <> X1) or (p1^.y <> y)) or ((p2^.x <> X2) or (p2^.y <> y)) end; function check_4(p1, p2: pcircle; x1, x2, Y: integer): boolean; begin check_4 := check_3(p1, p2, X1, X2, y) and check_3(p1, p2, X2, X1, y); end; procedure Tcircle.Hide; var tempColor:byte; begin tempColor:=color; color:=getpixel(x+radius+5,y+radius+5); setfillstyle(solidfill,color); show; visible:=false; color:=TempColor; end; procedure pomosh; begin setbkcolor(blue); setcolor(blue); bar(0,0,118,20); settextstyle(0,0,1); settextjustify(0,1); outtextxy(2,5,'Ходы:'); str(score,buf); setcolor(red); outtextxy(50,5,buf); end; procedure score_table(score:word); type stroka=record name:string[10]; scor:word; end; var l:array [1..5] of stroka; fin,fout:text; i,j,pr,cod,count:integer; buf:string; key:char; begin cleardevice; setfillstyle(1,lightgray); bar(120,30,600,400); settextstyle(0,0,3); setcolor(blue); outtextxy(340,40,'Лучшие Игроки'); assign(fin,'best.txt'); {$I-} reset(fin); {$I+} i:=0; while not eof(fin) do begin inc(i); readln(fin,buf); pr:=pos(' ',buf); l[i].name:=copy(buf,1,pr); buf:=copy(buf,pr+1,length(buf)-pr); val(buf,l[i].scor,cod); end; close(fin); for i:=1 to 5 do for j:=i+1 to 5 do if l[i].scor>l[j].scor then begin buf:=l[i].name; pr:=l[i].scor; l[i].name:=l[j].name; l[i].scor:=l[j].scor; l[j].name:=buf; l[j].scor:=pr; end; if scorel[j].scor then begin buf:=l[i].name; pr:=l[i].scor; l[i].name:=l[j].name; l[i].scor:=l[j].scor; l[j].name:=buf; l[j].scor:=pr; end; assign(fout,'temp.txt'); rewrite(fout); for i:=1 to 5 do writeln(fout,l[i].name,' ',l[i].scor); erase(fin); rename(fout,'best.txt'); close(fout); end; setcolor(black); for i:=1 to 5 do begin outtextxy(270,i*30+70,l[i].name); str(l[i].scor,buf); outtextxy(460,i*30+70,buf); end; readkey; end; procedure Tcircle.Drag(Step:integer;ch:char;nomer1:pcircle); var nomer2,nomer3:pcircle; const centr1x=198; centr2x=354; centr3x=510; centr1y=84; centr2y=240; centr3y=396; begin if nomer1=p1 then begin nomer2:=p2; nomer3:=p3; end else if nomer1=p2 then begin nomer2:=p1; nomer3:=p3; end else if nomer1=p3 then begin nomer2:=p1; nomer3:=p2; end; Case Ord(Ch) of 72:if (x<>198) and (y<>84) and ((x<>354) or (y<>396)) and check_2(p1, p2, centr2x, centr1y, centr2y) and check_2(p1, p2, centr3x, centr1y, centr2y) and check_2(p1, p3, centr2x, centr1y, centr2y) and check_2(p1, p3, centr3x, centr1y, centr2y) and check_2(p3, p2, centr2x, centr1y, centr2y) and check_2(p3, p2, centr3x, centr1y, centr2y) then {Конец проверки красного и зеленого шарика на позиции 510} MoveTo(x, y-Step); {Up} 75:if (x<>198) and ((x<>510) or (y<>84)) and check_4(p1, p2, centr1x, centr2x, centr1y) and check_4(p1, p2, centr1x, centr2x, centr2y) and check_4(p1, p2, centr1x, centr2x, centr3y) and check_4(p1, p3, centr1x, centr2x, centr1y) and check_4(p1, p3, centr1x, centr2x, centr2y) and check_4(p3, p2, centr3x, centr1y, centr2y) and check_4(p1, p3, centr1x, centr2x, centr3y) and check_4(p3, p2, centr1x, centr2x, centr1y) and check_4(p3, p2, centr1x, centr2x, centr2y) and check_4(p3, p2, centr1x, centr2x, centr3y) then MoveTo(x-Step, y); {Left} 77:if (x<>510) and ((x<>354) or (y<>84)) and check_4(p1, p2, centr1x, centr2x, centr1y) and check_4(p1, p2, centr3x, centr2x, centr2y) and check_4(p1, p2, centr3x, centr2x, centr3y) and check_4(p1, p3, centr1x, centr2x, centr1y) and check_4(p1, p3, centr3x, centr2x, centr2y) and check_4(p1, p3, centr3x, centr2y, centr3y) and check_4(p3, p2, centr1x, centr2x, centr1y) and check_4(p3, p2, centr3x, centr2x, centr2y) and check_4(p3, p2, centr3x, centr2x, centr3y) then MoveTo(x+Step, y); {Right} 80:if (x<>198) and (y<>396) and ((x<>354) or (y<>240)) and check_2(p1, p2, centr2x, centr1y, centr2y) and check_2(p1, p2, centr3x, centr2y, centr3y) and check_2(p1, p3, centr2x, centr1y, centr2y) and check_2(p1, p3, centr3x, centr2y, centr3y) and check_2(p3, p2, centr2x, centr1y, centr2y) and check_2(p3, p2, centr3x, centr2y, centr3y) then {Конец проверки красного и зеленого шарика на позиции 510} MoveTo(x, y+Step); {Down} end; { case} end; procedure Tcircle.MoveTo(xnew,ynew:integer); var Flag:boolean; begin Flag:=IsVisible; if Flag then Hide; x:=xnew; y:=ynew; if Flag then Show; end; begin driver:=vga; mode:=2; initgraph(driver,mode,'c:\bp\bgi'); m:=init(237,193); setcolor(white); add('Играть',100,m); add('Посмотреть правила',200,m); add('Таблица результатов',300,m); add('Выход',400,m); showmenu; repeat cod:=choice(m); case cod of 100: begin score:=0; t:=false; begin igrpole; new(p1,init(198,84,38,10)); new(p2,init(354,240,38,9)); new(p3,init(510,396,38,12)); p1^.show; p2^.show; p3^.show; repeat ch:=readkey; if ord(ch)=0 then begin ch:=readkey; score:=score+1; pomosh; case ord(ch) of 72: if (p1^.y=240) and (p1^.x=510) then begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p1); end else if (p2^.y=240) and (p2^.x=510) then begin p2^.drag(156,ch,p1); p1^.drag(156,ch,p2); p3^.drag(156,ch,p1); end else if (p3^.y=240) and (p3^.x=510) then begin p3^.drag(156,ch,p3); p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); end else begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); end; 75:if ((p1^.x=354) and (p1^.y=240)) or ((p1^.x=354) and (p1^.y=396)) then begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); end else if ((p2^.x=354) and (p2^.y=240)) or ((p2^.x=354) and (p2^.y=396)) then begin p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); p1^.drag(156,ch,p1); end else if ((p3^.x=354) and (p3^.y=240)) or ((p3^.x=354) and (p3^.y=396)) then begin p3^.drag(156,ch,p3); p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); end else begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); end; 77:if p1^.x=354 then begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); end else if p2^.x=354 then begin p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); p1^.drag(156,ch,p1); end else if p3^.x=354 then begin p3^.drag(156,ch,p3); p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); end else begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); end; 80:if p1^.y=240 then begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); end else if p2^.y=240 then begin p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); p1^.drag(156,ch,p1); end else if p3^.y=240 then begin p3^.drag(156 ,ch,p3); p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); end else begin p1^.drag(156,ch,p1); p2^.drag(156,ch,p2); p3^.drag(156,ch,p3); end; end; end; until (((p1^.x=510) and (p1^.y=396)) and ((p2^.x=354) and (p2^.y=240)) and ((p3^.x=198) and (p3^.y=84))) or (ord(ch)=27); end; score_table(score); cleardevice; showmenu; settextjustify(1,1); settextstyle(0,0,1); outtextxy(320,117,'ШАРИКИ'); outtextxy(320,446,'Автор: Апарин Олег, 3АСУ-1ДС-145, 2007'); score:=0; end; 200: begin help; cleardevice; showmenu; settextstyle(0,0,1); settextjustify(1,1); outtextxy(320,117,'ШАРИКИ'); outtextxy(320,446,'Автор: Апарин Олег, 3АСУ-1ДС-145, 2007'); end; 300: begin score_table(score); cleardevice; showmenu; settextjustify(1,1); settextstyle(0,0,1); outtextxy(320,117,'ШАРИКИ'); outtextxy(320,446,'Автор: Апарин Олег, 3АСУ-1ДС-145, 2007'); end; 400: begin done(m) end; end; until cod=400; closegraph; end.