program Hantower(INPUT,OUTPUT);
uses crt,graph;
var
gd,gm:integer;
er:integer;
n:integer;
i:integer;
A:ARRAY[1..10]OF INTEGER;
abc:array[1..3]of integer;
x,y:array[1..3]of integer;
procedure stolb;
begin
SETCOLOR(14);
OUTTEXTXY(230,20,' HANOISKAYA BASHNYA ');
line(100,400,100,100);
line(300,400,300,100);
line(500,400,500,100);
LINE(0,400,640,400);
end;
procedure draw(h:integer);
begin
for i:=h downto 1 do
begin
setfillstyle(1,A[i]);
bar(x[1]-i*10,y[1]-20,x[1]+i*10,y[1]);
y[1]:=y[1]-20;
end;
abc[1]:=y[1];
abc[2]:=400;
abc[3]:=400;
STOLB;
readln;
end;
procedure disk(h,f,t:integer);
begin
stolb;
setfillstyle(1,0);
bar(x[f]-h*10,abc[f],x[f]+h*10,abc[f]+20);
abc[f]:=abc[f]+20;
setfillstyle(1,A[H]);
bar(x[t]-h*10,abc[t],x[t]+h*10,abc[t]-20);
abc[t]:=abc[t]-20;
stolb;
DELAY(33000);
end;
procedure tow(h:integer;f,t, v:integer);
begin
if h=1 then disk (h,f,t)
else
begin
tow (h-1,f,v,t);
disk(h,f,t);
tow(h-1,v,t,f);
end;
end;
begin
CLRSCR;
x[1]:=100;x[2]:=300;x[3]:=500;
y[1]:=400;y[2]:=y[1];y[3]:=y[1];
writeln(' vvedite kolichestvo diskov ');
readln(n);
FOR I:=1 TO N DO
A[I]:=I;
gd:=detect;
initgraph(gd,gm,'G:\');
er:=graphresult;
stolb;
draw(n);
tow(n,1,3,2);
readln;
closegraph;
end.
а в чем собственно заключаться игра?
http://forum.pascal.net.ru/index.php?showtopic=9254 тут написано ... жалко там алгоритмы, а не игра!
Может кто скажет?
Или у кого игра УЖЕ есть... написанная на Pascal?!
Переделывать не обязательно. Это я из-за своей "программерской" не опытности думал, что так будет проще . Тут одна "загвостка" есть ...как игру 3D сделать? Чем отличается описание для 2D (дисков) от 3D?
Спасибо!
Диски в аксонометрической проекции...то что надо! Крутить не надо))
А время+желание конечно есть. У меня "курсовик" на эту темку... Как говорится "Куда деваться?!" ... Пока начну писать по твоей схеме... обо всем буду сообщать ЗДЕСЬ!
А насчет аватарки, ты прав. Какой же крутой 3D-программер без 3D аватара)))
Вот...код проги...работает в 2D... Как бы 3D из этого всего "слепить"=)))
Спасибо!
Прикрепленные файлы
hanoie7.pas ( 10.28 килобайт )
Кол-во скачиваний: 409
uses DOS;
TimeFactor = 5000; {убрать совсем}
WaitTime = 3; {время задержки в сотых долях сек }
function Time:LongInt;
var
m,d,h,mi,s,s1:word;
l:LongInt;
begin
GetDate(h,m,d,mi); GetTime(h,mi,s,s1); {выдает время в сотых долях сек}
l:=d;
Time:=(((l*24+h)*60+mi)*60+s)*100+s1
end;
procedure Wait (t:LongInt); {параметр - сотые секунды}
begin
t:=Time+t;
repeat until Time>=t
end;
Значит игру переделал. Теперь либо управление пользователь.... либо автоматически...
+Добавил задержки (как ты советовал)....
По 1му недочету...
Отдельно в "юнит" .... никогда этого не делал
По 2му недочету...
Что-нибудь постараюсь придумать...
По 3 му...
Тоже что и по 2му...
П/с Репу тебе поднял, спасибо!!!... За помощь в этом не легком труде))
Прикрепленные файлы
BASNA007.PAS ( 10.61 килобайт )
Кол-во скачиваний: 356
Первые впечатления от нового варианта:
unit Tools;
interface
uses DOS;
function Time:LongInt;
procedure Wait (t:LongInt);
implementation
function Time:LongInt;
var
m,d,h,mi,s,s1:word;
l:LongInt;
begin
GetDate(h,m,d,mi); GetTime(h,mi,s,s1);
l:=d;
Time:=(((l*24+h)*60+mi)*60+s)*100+s1
end;
procedure Wait (t:LongInt);
begin
t:=Time+t;
repeat until Time>=t
end;
begin
end.
unit Hanoi_U;
interface
uses CRT,Tools;
CONST
FirstLine = 1;
ShiftLine = 5;
BaseLine = 17;
ErrorLine = 20;
MessageLine = 21;
PromptLine = 22;
LastLine = 22;
LeftMargin = 2;
MessageColumn = 33;
RightMargin = 77;
distance = 25;
TYPE
TLine = FirstLine..LastLine;
TColumn = LeftMargin..RightMargin;
VAR
WhiteChar : char;
GrayChar : char;
z: integer;
procedure Position (Line: TLine; Column: TColumn);
procedure MoveHorizontal (StartColumn,EndColumn: TColumn; Width: integer);
procedure MoveVertical (Column: TColumn; StartLine, EndLine: TLine; Width: integer);
implementation
procedure Position (Line: TLine; Column: TColumn);
begin
GotoXY (Column+1,Line+1);
end;
procedure MoveHorizontal (StartColumn,EndColumn: TColumn; Width: integer);
var
col: TColumn;
begin
col := StartColumn;
while col<>EndColumn do begin
if col<EndColumn then begin
Position (ShiftLine,col) ; write (' ');
Position (ShiftLine,col+Width); write (WhiteChar);
col:= col+1
end
else begin
Position (ShiftLine,col-1) ; write (WhiteChar);
Position (ShiftLine,col+Width-1); write (' ');
col:= col-1
end;
Wait (z)
end
end;
procedure MoveVertical (Column: TColumn;
StartLine, EndLine: TLine; Width: integer);
var
c : integer;
r : TLine;
v : integer;
begin
if EndLine>StartLine then v:= 1 else v:= -1;
r := StartLine;
while r <> EndLine do begin
Position (r,Column);
for c:= 1 to Width do write (' ');
Position (r+v,Column);
for c:= 1 to Width do write (WhiteChar);
r := r+v;
Wait (2*z)
end
end;
begin
GrayChar := chr(177);
WhiteChar := chr(219);
end.
PROGRAM HANOI;
Uses Crt,Tools,Hanoi_U;
CONST
Disks = 9;
TYPE
TDiskNumber = 1..Disks;
TDiskCount = 0..Disks;
TTowerNumber = 1..3;
TDiskPtr = ^TDisk;
TTowerPtr = ^TTower;
TDisk = record
nbr : TDiskNumber;
nxt : TDiskPtr;
Line : TLine
end;
TTower = record
nbr : TTowerNumber;
top : TDiskPtr
end;
VAR
t1,t2,t3 : TTowerPtr;
x : TDiskPtr;
Number,StepNbr : integer;
Help,
Automatic : boolean;
Bell : char;
procedure InitGlobals;
begin
Bell := chr( 7);
end;
procedure HelpText;
const margin = ' ';
begin
Position (ShiftLine,LeftMargin);
writeln;
writeln (margin,'Move all disks from tower 1 to tower 3');
writeln;
writeln;
writeln (margin,'These are the rules of the game :');
writeln;
writeln (margin,'Only 1 disk may be moved at a time.');
writeln (margin,'Never place a larger disk on top of a smaller one.')
end;
procedure ClearHelpText;
const LineCount = 8;
var r : TLine;
begin
for r := ShiftLine to ShiftLine+LineCount do begin
Position (r,LeftMargin);
ClrEol;
end;
end;
function UpperCase(c:char):char;
begin
if c in ['a'..'z']
then UpperCase := chr(ord©+ord('A')-ord('a'))
else UpperCase := c
end;
function GetKey: char;
var c : char;
begin
c:= ReadKey;
if c in [' '..'~'] then write ©;
GetKey := UpperCase ©
end;
function GetStepCount (n: TDiskNumber): integer;
begin
if n=1 then GetStepCount := 1
else GetStepCount := 2*GetStepCount(n-1) + 1
end;
function DiskColumn (t: TTowerNumber; b: integer): TColumn;
begin
DiskColumn := LeftMargin + (t-1)*distance + ((distance-b) div 2)
end;
function CharacterValue (c: char): integer;
begin
if c in ['0'..'9']
then CharacterValue := ord©-ord('0')
else CharacterValue := -1
end;
function Again : boolean;
var c : char;
begin
repeat
Position (PromptLine,MessageColumn);
write ('again? (Y/N) : '); ClrEol;
c := GetKey
until (c in ['Y','N']);
Again := c ='Y'
end;
procedure LiftUp (twr: TTowerNumber; dsk: TDiskNumber; Line: TLine);
var Width,StartCol,EndCol : integer;
begin
Width := 2*dsk+1;
StartCol := DiskColumn (twr,Width);
EndCol := DiskColumn (2,Width);
MoveVertical (StartCol,Line,ShiftLine,Width);
MoveHorizontal (StartCol,EndCol,Width)
end;
procedure PutDown (twr: TTowerNumber; dsk: TDiskNumber; Line: TLine);
var Width,StartCol,EndCol : integer;
begin
Width := 2*dsk+1;
StartCol := DiskColumn (2,Width);
EndCol := DiskColumn (twr,Width);
MoveHorizontal (StartCol,EndCol,Width);
MoveVertical (EndCol,ShiftLine,Line,Width)
end;
procedure MoveDisk (src,dst: TTowerPtr);
var x,y : TDiskPtr;
begin
{Wait (z);}
x := src^.top;
y := x^.nxt;
src^.top := y;
LiftUp (src^.nbr,x^.nbr,x^.Line);
x^.nxt := dst^.top;
dst^.top := x;
if x^.nxt<>nil
then x^.Line := x^.nxt^.Line-1
else x^.Line := BaseLine-1;
PutDown (dst^.nbr,x^.nbr,x^.Line);
Wait (z);
end;
procedure ReBuild(k: TDiskCount; src, tmp, dst: TTowerPtr);
begin
if k>0 then
begin
ReBuild (k-1,src,dst,tmp);
StepNbr := StepNbr+1;
Position (MessageLine,MessageColumn); write ('step : ',StepNbr:3);
Position (PromptLine,MessageColumn);
write ('from ',src^.nbr:1,' to ',dst^.nbr:1);
MoveDisk (src,dst);
ReBuild (k-1,tmp,src,dst)
end
end;
procedure Interactive (from, temp, dest: TTowerPtr);
var k,a : integer;
src,dst : TTowerNumber;
towers : array[TTowerNumber] of TTowerPtr;
ok : boolean;
function KeyOK (t:integer): boolean;
begin KeyOK := t in [1,2,3] end;
function TowerOK (top: TDiskPtr): boolean;
begin
if top=nil
then TowerOK := true
else if top^.nxt=nil
then TowerOK := true
else TowerOK := top^.nbr < top^.nxt^.nbr
end;
begin
towers[1] := from;
towers[2] := temp;
towers[3] := dest;
k := 0;
repeat
k := k+1;
Position (MessageLine,MessageColumn); write ('step : ',k);
Position (PromptLine,MessageColumn); write ('from ');
repeat
Position (PromptLine,MessageColumn+5); ClrEol;
a := CharacterValue (GetKey);
if not KeyOK (a)
then
begin
ok := false;
Position (ErrorLine,MessageColumn);
write (Bell); ClrEol;
end
else
begin
ok := towers[a]^.top<>nil;
if not ok then
begin
Position (ErrorLine,MessageColumn);
write (Bell,'There is no disk at <',a:1,'> !'); ClrEol;
end
end
until ok;
Position (ErrorLine,MessageColumn); ClrEol;
Position (PromptLine,MessageColumn+5); write (a:1,' to ');
src := a;
repeat
Position (PromptLine,MessageColumn+10); ClrEol;
a := CharacterValue (GetKey);
if not KeyOK (a) then write (Bell);
until KeyOK (a);
Position (PromptLine,MessageColumn+10); write (a:1); ClrEol;
dst := a;
if src=dst then
begin
Position (ErrorLine,MessageColumn);
write (Bell,'It''s there already!'); ClrEol;
k:= k-1
end
else
begin
MoveDisk (towers[src],towers[dst]);
if not TowerOK(towers[dst]^.top) then
begin
Position (ErrorLine,MessageColumn); write (Bell,'Not allowed');
Wait (z);
MoveDisk (towers[dst],towers[src]);
Position (ErrorLine,MessageColumn); ClrEol;
end
end
until (from^.top=nil) and (temp^.top=nil);
Position (ErrorLine,MessageColumn);
write ('WELL DONE !'); ClrEol;
end;
procedure MainDialog (temp : boolean;
var n: integer; var t1,t2,t3: TTowerPtr; var auto: boolean);
var resp : char;
z1 : integer;
r : TLine;
k : TColumn;
t : TTowerNumber;
procedure InitDisks;
var s : TDiskNumber;
Width : integer;
Line : TLine;
Column : TColumn;
begin
z := 0;
new (t1); t1^.nbr := 1; t1^.top := nil;
new (t2); t2^.nbr := 2; t2^.top := nil;
new (t3); t3^.nbr := 3; t3^.top := nil;
for s := n downto 1 do
begin
new (x);
with x^ do
begin
nbr := s;
nxt := t1^.top;
t1^.top := x;
Width := 2*s+1;
Line := (BaseLine-1)-n+s;
Column := DiskColumn (1,Width);
MoveVertical (Column,Line-1,Line,Width);
end
end
end;
begin
ClrScr;
Position (FirstLine,LeftMargin+29); write ('TOWERS OF HANOI');
Position (BaseLine,LeftMargin);
for k:= LeftMargin to RightMargin do write (GrayChar);
for t:= 1 to 3 do
begin
Position (BaseLine+1,DiskColumn(t,3));
write ('<',t:1,'>')
end;
if temp then HelpText;
repeat
Position (PromptLine,LeftMargin);
write ('Automatic or User play? (A or U): '); ClrEol;
resp := GetKey;
until resp in ['A','U'];
auto := resp='A';
if temp then ClearHelpText;
repeat
Position (PromptLine,LeftMargin);
write ('Number of disks ','? (1-',Disks:1,') : ');ClrEol;
n:= CharacterValue(GetKey);
until (n>=1) and (n<=Disks);
Position (FirstLine,LeftMargin);
write (n:1,' Disks');
InitDisks;
Position (FirstLine,RightMargin-15);
write (GetStepCount(n):3,' steps needed');
if auto then
begin
repeat
Position (PromptLine,LeftMargin);
write ('speed ','? (1-9) : '); ClrEol;
z1:= CharacterValue(GetKey)
until (z1>=1) and (z1<=9);
Position (ErrorLine,MessageColumn);
write ('speed : ',z1:3); ClrEol;
z:= 9-z1;
StepNbr := 0;
Wait (z)
end
else z := 2;
Position (PromptLine,LeftMargin); ClrEol;
end;
BEGIN
InitGlobals;
Help := true;
repeat
MainDialog (Help,Number,t1,t2,t3,Automatic);
Help := false;
if Automatic
then ReBuild (Number,t1,t2,t3)
else Interactive (t1,t2,t3)
until not Again
END.
"Визуализацию надо сделать более функциональной"....В unit'e Hanoi_U как я понял вот это и осуществить...
Сначало визуализацию буду делать.... потом управление...
Такой план ...пятилетки)))
Все понято...значит с управления...начинаю...
Думаю выкладывать не надо...Пока во мне есть идеи и творческие силы))
По поводу Управления...
А вот если управление сделать так...сначала подводим указатель откуда будем перемещать(жмем допустим Enter), потом подводим куда...И оно пошло передвигаться???
Да...понятно
Но это все сделать надо))(это тоже понятно)...при моей структуре программы это довольно проблематично((..Тем более для меня верхом было создание 123 управления...а такое...это что-то на грани с фантастикой (пока))...
Тут такой вопрос "созрел"...На сколько важно это управление (стрел-ми)??
Сегодня на консультации ... На все мои вопросы были получены "+" ответы... Допустим, Управление "123" устроит... "Ага"... Дисков у меня до 9... "Ого"=)) В общем все
Плохо что тема закончилась...Мне всё то же самое нужно только диски тягать мышкой помогите а?
Сделал вот так...
Driver := Detect;
InitGraph(Driver, Mode, '');
if GraphResult < 0 then
Halt(1);
Help := true;
repeat
MainDialog (Help,Number,t1,t2,t3,Automatic);
Help := false;
if Automatic
then ReBuild (Number,t1,t2,t3)
else Interactive (t1,t2,t3)
until not Again;
CloseGraph;
END.
- Может я чего не допонимаю?
Разобрался прописал DirectVideo:=false;
Но теперь фоны накладываются друг на друга..
Карау! завтра показывать а с 3d какая-то....
ВСЕ!!!
Курсовую сдал на ОТЛИЧНО!!! Lapp Большущие СПАСИБО! За ту помощь и поддержку,которую ты оказывал мне в теме=)) В будущем может кому-то тоже понадобится программа Берите , разбирайтесь...
П/с Разработку 3D оставляю следующим поколениям =)))