Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2002.08.08;
Скачать: [xml.tar.bz2];

Вниз

По-моему интересная задачка для мастеров :)   Найти похожие ветки 

 
Cosinus   (2002-07-25 16:09) [0]

Уважаемые господа, позвольте Вам задать задачку, над которой я уже замучился думать, задам я ее в вольной форме, потому что так проще объяснить суть. Допустим, есть какой-либо количество пустых горшочков Ж:) (400, for example), расположенных, например по 100 в ряду (то бишь 4 ряда) и имеются 100 горошин, которые нужно разложить в горшочки следующим образом:
1) в горшочке может не быть горошины (что логично), но не может быть больше одной
2)в сумме четырех рядом стоящих(в ряду) горшочках не может быть двух горошин
3)конечное расположение должно полностью соответствовать слову "хаос"


 
Skier   (2002-07-25 16:11) [1]

>Cosinus
Кто-нибудь решит, а ты получишь медаль на
олимпиаде ! :)))


 
Cosinus   (2002-07-25 16:15) [2]

Какая медаль, работа такая специфическая. Помогите, будте любезны.


 
Skier   (2002-07-25 16:18) [3]

>Cosinus

> я уже замучился думать


А в чем основная проблема ?


 
Cosinus   (2002-07-25 16:20) [4]

Алгоритм - основная проблемма


 
Skier   (2002-07-25 16:22) [5]

>Cosinus
Жутко конкретный ответ ! :)


 
MBo   (2002-07-25 16:25) [6]

для небольшого заполнения работает быстро

place:array[0..399] of byte;

function possible:Boolean;
begin
row:=np mod 100;
inrow:=place[row]+place[row+100]+place[row+200]+place[row+300];
result:=(inrow<2) and (place[np]=0);
end;

randomize;
ngor:=100;
while ngor>0 do begin
np:=random(400);
if possible then begin
place[np]:=1;
dec(ngor);
end;
end;


 
Cosinus   (2002-07-25 16:31) [7]

Я не знаю, как конкретнее ответить.
Для простоты понимания могу сказать для чего это надо : есть четырехканальная анимационная машинка и 62-лампочный ряд. Лампочки подсоеденены по 15 (последовательно) - нужно создать подобие хаоса. Ну не получается написать программу, которая мне бы указала какие лампочки к какому каналу подсоединять. Вот, что я написал на скорую руку, но иногда это срабатывает, а иногда виснет на 95-98% (знаю почему, но не знаю, как исправить).
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Gauges, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
g1: TGauge;
Button3: TButton;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

type
matrix= array [0..63] of byte;
matrix1=array [0..5,0..63] of byte;
var
n,i,k,rnd:byte;
f:textfile;
matr:matrix;
matr1:matrix1;
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button2Click(Sender: TObject);
begin
form1.Close;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
for i:=0 to 63 do
begin
matr[i]:=0;
end;

for k:=1 to 4 do
begin
for i:=1 to 62 do
matr1[k,i]:=1;
end;
assignfile(f,"c:\random.txt");
rewrite(f);
randomize;
n:=0;
for k:=1 to 4 do
begin
while n<15 do
begin
rnd:=random(61)+1;
if (matr[rnd]=0) and (matr1[k,rnd-1]=1) and (matr1[k,rnd+1]=1) then
begin
matr[rnd]:=1;
write(f,rnd);
write(f," ");
inc(n);
matr1[k,rnd]:=0;
g1.progress:=g1.progress+1;
if g1.progress=98 then
begin
closefile(f);
halt(1);
end;
end;
end;
n:=0;
writeln(f," ");
end;
closefile(f);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
assignfile(f,"c:\random.txt");
append(f);
for k:=1 to 4 do
begin
for i:=1 to 62 do
begin
if matr1[k,i]=0 then
begin
write(f,"#");
end
else
begin
write(f,"0");
end;
{write(f,matr1[k,i]);}
write(f," ");
end;
writeln(f," ");
end;
closefile(f);
end;

end.


 
Skier   (2002-07-25 16:47) [8]

>Cosinus


const
RowCount = 100;
ColCount = 4;
var
N : Smallint;
Peas : array[1..ColCount,1..RowCount] of Byte;

function PeaCanBePlaced(const ARow : Byte) : Boolean;
var
ASum : Byte;
begin
ASum := Peas[1, ARow] + Peas[2, ARow] + Peas[3, ARow] +
Peas[4, ARow];
Result := (ASum < 2) or (ASum = 0);
end; //PeaCanBePlaced
var
ARow : Byte;
ACol : Byte;
begin
FillChar(Peas, SizeOf(Peas), 0);
N := 1;
while N <= RowCount*ColCount do begin
Randomize;
ARow := Random(RowCount);
ACol := Random(ColCount);
if PeaCanBePlaced(ARow) then Peas[ACol, ARow] := 1;
Inc(N);
end; //while


 
Skier   (2002-07-25 16:56) [9]

>Cosinus
Ойк ! Забыл про 1)
Ещё раз :)


const
RowCount = 100;
ColCount = 4;
var
N : Smallint;
Peas : array[1..ColCount,1..RowCount] of Byte;

function PeaCanBePlaced(const ACol, ARow : Byte) : Boolean;
var
ASum : Byte;
begin
ASum := Peas[1, ARow] + Peas[2, ARow] + Peas[3, ARow] +
Peas[4, ARow];
Result := (ASum < 2) and (Peas[ACol, ARow] = 0);
end; //PeaCanBePlaced
var
ARow : Byte;
ACol : Byte;
begin
FillChar(Peas, SizeOf(Peas), 0);
N := 1;
while N <= RowCount*ColCount do begin
Randomize;
ARow := Random(RowCount);
ACol := Random(ColCount);
if PeaCanBePlaced(ACol, ARow) then Peas[ACol, ARow] := 1;
Inc(N);
end; //while


 
Cosinus   (2002-07-25 16:57) [10]

>> skier >> Нет времени проверить, появилась более срочная работа, но на всякий случай, спасибо.


 
Skier   (2002-07-25 17:03) [11]

>Cosinus
А как же MBo !? (А ему спасибо !?)


 
Cosinus   (2002-07-25 17:17) [12]

>> Skier >> MBo >> Простите дедушку, склероз :) А если серьезно, то действительно забыл, что мне MBo отвечал - я подбегу к компу, быстро гляну и убегу решать совсем другие проблеммы - голова пухнет. Еще раз извините и спасибо Skier и MBo. Если что не будет получаться завтра спрошу.
С уважением, Владислав.



Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2002.08.08;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.59 MB
Время: 0.026 c
1-24121
Александр
2002-07-26 16:35
2002.08.08
Форма


1-24111
V.Turecky
2002-07-26 18:17
2002.08.08
Как программно изменить метку тома винчестера?


1-24082
URustam
2002-07-26 14:03
2002.08.08
Помогите!!!


1-24008
eruc
2002-07-28 18:14
2002.08.08
hints (при неактивной форме)


4-24282
IIS
2002-05-31 11:35
2002.08.08
Как програмно раздавать права на реестр?





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский