Ханойская башня (не реализация!), Переделка проги...в игру Опции

[Needhelp]

 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. 

Как переделать реализацию алгоритма в игру? Что надо подправить и.т.д?
То есть в данном случае "игра" сама передвигает диски, а мне нужно чтобы ей управлял польз-ь...

Сообщение отредактировано: Needhelp - 11.04.2007 16:51

[Needhelp]

Значит игру переделал. Теперь либо управление пользователь.... либо автоматически...
+Добавил задержки (как ты советовал)....
По 1му недочету...
Отдельно в "юнит" .... никогда этого не делал
По 2му недочету...
Что-нибудь постараюсь придумать...
По 3 му...
Тоже что и по 2му...

П/с Репу тебе поднял, спасибо!!!... За помощь в этом не легком труде))

Сообщение отредактировано: Needhelp - 23.04.2007 18:35

[Lapp]

Первые впечатления от нового варианта:

Добавил задержки (как ты советовал)....

- а куда подевались вызовы GetDate и GetTime?.. И юнит DOS отсутствует в uses..

[Needhelp]

Первые впечатления от нового варианта:

- а куда подевались вызовы GetDate и GetTime?.. И юнит DOS отсутствует в uses..

Извиняюсь.... не тот вариант...

Сообщение отредактировано: Needhelp - 23.04.2007 18:28

[Lapp]

Извиняюсь.... не тот вариант...

В этом тоже не без огрехов.. подредактируй (ты можешь при редактировании поста убрать файл и заменить на новый)

Еще одно - забыл тогда сказать: зачем дублировать стандартную функцию UpCase?

Попробуй сделать юнит. Правила такие:
- сделай новый файл, его название должно строго соответствовать названию юнита.
- вместо program Name пиши unit Name
- имя, например, Hanoi_U (соответственно, файл Hanoi_U.pas)
- после строчки unit идет строка interface
- после нее идут переменные, константы как обычно
- потом идут точные копии заголовков процедур, которые ты туда перемещаешь - один за другим
- потом идет слово implementation
- потом идут сами процедуры (тоже с заголовками)
- самого тела может и не быть, просто begin end. Но можешь там разместить инициализацию, если требуется.

Для примера я разбросал твой проект по трем файлам: головной, юнит Tools и юнит Hanoi_U. Советую тебе в юните Tools держать полезные часто используемые вещи. В юнит Hanoi_U я перенес пока только три процедурки. Ты можешь перенести еще. Только вместе с ними переноси и переменные и константы, которые нужно - они тоже будут доступны для использования в основной программе.

Смотри, как это получилось..
Файл Tools.pas :

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.

Файл Hanoi_U.pas (кстати, обрати внимание на форматирование текста здесь - рекомендую использовать такой стиль) :

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.

Файл Hanoi.pas :

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.

Добавлено через 2 мин.
Борландовская среда очень хорошо приспособлена для работы с юнитами, ты это увидишь. Переход между окнами - клавиша F6. Зайди в меню Window и поиграй с разными расположениями окон..
Успехов!