IPB
ЛогинПароль:

> 

Начальные контакты ТОЛЬКО через личку!!

> Построение цепочки домино
Денис Александрович
сообщение 10.06.2010 16:27
Сообщение #1





Группа: Пользователи
Сообщений: 1
Пол: Мужской

Репутация: -  0  +


имеется программа в которой при вводе чисел строится цепочка домино.
не подскажите как можно получить такую же цепочку домино, только с помощью строк а не массива!?

program domino;

uses Graph;

const
  MassLen = 7;

type
  tMass = array[1..2, 1..MassLen] of byte;

var
 grDriver: Integer;
 grMode: Integer;
 ErrCode: Integer;

 i,j: Integer;
 Mass, Sort, StartChain, SortMass: tMass;
 inputres, chain_form: boolean;


function IsInChain(Chain:tMass; len,num_elem:Integer):boolean;
var
  i:Integer;
  res: boolean;
begin
  res:=false;
  for i:=1 to len do
    if Chain[1,i] = num_elem
    then res:=true;
  IsInChain:=res;
end;

procedure MakeChain(Chain:tMass; len:Integer);
var
  i,j:Integer;
begin
  if (not chain_form)
  then
  begin

  if (len = 0)
  then begin
         for i:=1 to MassLen do
           begin
             Chain[1,1]:=i;
             Chain[2,1]:=1;
             MakeChain(Chain, len+1);
           end;
       end
  else
  if (len = MassLen)
  then begin
         chain_form:=true;
         for i:=1 to MassLen do
         begin
           Sort[1,i]:=Chain[1,i];
           Sort[2,i]:=Chain[2,i];
         end;
       end
  else
  begin
    for i:=1 to MassLen do
     if (not IsInChain(Chain,len,i))
     then begin
            if (Mass[Chain[2,1],Chain[1,1]] = Mass[1,i])
            then begin
                   for j:=len downto 1 do
                   begin
                     Chain[1,j+1]:=Chain[1,j];
                     Chain[2,j+1]:=Chain[2,j];
                   end;
                   Chain[1,1]:=i;
                   Chain[2,1]:=2;
                   MakeChain(Chain,len+1);
                 end
            else
            if (Mass[Chain[2,1],Chain[1,1]] = Mass[2,i])
            then begin
                   for j:=len downto 1 do
                   begin
                     Chain[1,j+1]:=Chain[1,j];
                     Chain[2,j+1]:=Chain[2,j];
                   end;
                   Chain[1,1]:=i;
                   Chain[2,1]:=1;
                   MakeChain(Chain,len+1);
                 end;

            if (Mass[3-Chain[2,len],Chain[1,len]] = Mass[1,i])
            then begin
                   Chain[1,len+1]:=i;
                   Chain[2,len+1]:=1;
                   MakeChain(Chain,len+1);
                 end
            else
            if (Mass[3-Chain[2,len],Chain[1,len]] = Mass[2,i])
            then begin
                   Chain[1,len+1]:=i;
                   Chain[2,len+1]:=2;
                   MakeChain(Chain,len+1);
                 end;
          end;


          end;
  end;
end;

function CheckDomino(num:Integer):boolean;
var
   res: boolean;
   i: Integer;
begin
  res:=false;
  for i:=1 to num-1 do
    if (((Mass[1,i] = Mass[1,num]) and (Mass[2,i] = Mass[2,num]))
     or ((Mass[1,i] = Mass[2,num]) and (Mass[2,i] = Mass[1,num])))
    then res:=true;
  CheckDomino:=res;

end;

procedure DrawDomino(x,y:Integer;i:Integer);
begin
  Rectangle(x,y,x+40,y+20);
  MoveTO(x+20,y);
  LineTO(x+20,y+20);
  case SortMass[1,i] of
  1:Circle(x+10,y+10,2);
  2:begin
      Circle(x+6,y+6,2);
      Circle(x+14,y+14,2);
    end;
  3:begin
      Circle(x+6,y+6,2);
      Circle(x+10,y+10,2);
      Circle(x+14,y+14,2);
    end;
  4:begin
      Circle(x+6,y+6,2);
      Circle(x+6,y+14,2);
      Circle(x+14,y+6,2);
      Circle(x+14,y+14,2);
    end;
  5:begin
      Circle(x+6,y+6,2);
      Circle(x+6,y+14,2);
      Circle(x+10,y+10,2);
      Circle(x+14,y+6,2);
      Circle(x+14,y+14,2);
    end;
  6:begin
      Circle(x+6,y+6,2);
      Circle(x+6,y+10,2);
      Circle(x+6,y+14,2);
      Circle(x+14,y+6,2);
      Circle(x+14,y+10,2);
      Circle(x+14,y+14,2);
    end;
  end;

  case SortMass[2,i] of
  1:Circle(x+10+20,y+10,2);
  2:begin
      Circle(x+6+20,y+6,2);
      Circle(x+14+20,y+14,2);
    end;
  3:begin
      Circle(x+6+20,y+6,2);
      Circle(x+10+20,y+10,2);
      Circle(x+14+20,y+14,2);
    end;
  4:begin
      Circle(x+6+20,y+6,2);
      Circle(x+6+20,y+14,2);
      Circle(x+14+20,y+6,2);
      Circle(x+14+20,y+14,2);
    end;
  5:begin
      Circle(x+6+20,y+6,2);
      Circle(x+6+20,y+14,2);
      Circle(x+10+20,y+10,2);
      Circle(x+14+20,y+6,2);
      Circle(x+14+20,y+14,2);
    end;
  6:begin
      Circle(x+6+20,y+6,2);
      Circle(x+6+20,y+10,2);
      Circle(x+6+20,y+14,2);
      Circle(x+14+20,y+6,2);
      Circle(x+14+20,y+10,2);
      Circle(x+14+20,y+14,2);
    end;
  end;
end;

begin
  WriteLn('Vvedite znacheniya 7 par domino');
  i:=1;
  while i <= MassLen do
  begin
    inputres:=true;
    while inputres do
    begin
      ReadLn(Mass[1,i]);
      if (Mass[1,i] <= 6) and (Mass[1,i] >= 0)
      then inputres:=false
      else WriteLn('Chislo dolgno bit menche 7 i bolshe ili ravno 0');
    end;
    inputres:=true;
    while inputres do
    begin
      ReadLn(Mass[2,i]);
      if (Mass[2,i] <= 6) and (Mass[2,i] >= 0)
      then inputres:=false
      else WriteLn('Chislo dolgno bit menche 7 i bolshe ili ravno 0');
    end;
    if (CheckDomino(i))
    then WriteLn('Takoe domino uge est')
    else i:=i+1;
  end;

  MakeChain(StartChain,0);
  if (chain_form)
  then
    for i:=1 to MassLen do
    begin
      if (Sort[2,i] = 1)
      then begin
             SortMass[1,i]:=Mass[1,Sort[1,i]];
             SortMass[2,i]:=Mass[2,Sort[1,i]];
           end
      else begin
             SortMass[2,i]:=Mass[1,Sort[1,i]];
             SortMass[1,i]:=Mass[2,Sort[1,i]];
           end;
    end;


 grDriver:=Vga;
 grMode:=VgaHi;
 InitGraph(grDriver,grMode,'d:\dvd2\borlpasc\bgi');
 ErrCode := GraphResult;
 if ErrCode = grOk then
 begin  { Do graphics }
   OutTextXY(20, 20, 'Dlya vihoda nagmite Enter');

   if (chain_form)
   then for i:=1 to MassLen do
          DrawDomino(40+45*i,40,i)
   else
     OutTextXY(20, 40, 'Chepochku sformirovat ne udalos');
   ReadLn;
   CloseGraph;
 end
 else
   Writeln('Graphics error:', GraphErrorMsg(ErrCode));
end.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

Сообщений в этой теме


 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 

- Текстовая версия 28.07.2025 6:33
Хостинг предоставлен компанией "Веб Сервис Центр" при поддержке компании "ДокЛаб"