Задачка

← →
Кот-трахкун © (2004-04-22 20:52) [0]

Принесла одна малая (14 лет). Чешу репу над ней уже третий день.
Вот задачка:
Есть листбокс. В нем по вертикали расположено следующее:
1
1
1
0
0
0

Нужно переместить все единички по порядку вниз.
Типа "111000", "110100", "110010", "110001", "101100", "101010", "101001", "100110", "100101", "100011", "011100", "011010" и так до тех пор. пока все единички не окажутся внизу.
Решение должно быть наглядным. Т.е. с применением Sleep(100) и Application.ProcessMessages, чтоб было видно, как единички перемещаются.
Я уже перепробовал все: while, repeat, for, forfor, forforfor и сочетания вышеприведенного. Но так ничего толкового и не добился.
Пока в списке было две единички (110000), то с перемещением проблем не было. Но когда их больше - ничего не получается.
(смущенно озираясь): Ну как вам задачка?

Кот-трахкун. Затейник.
(aka AL2002)

← →
Anatoly Podgoretsky © (2004-04-22 20:56) [1]

Только вместо ListBox для визуализации лучше применить 6 штук TLabel

← →
Gero © (2004-04-22 20:59) [2]

> Только вместо ListBox для визуализации лучше применить 6
> штук TLabel

TForm.Canvas"a будет достаточно.

А это классическая задача на все возможные перестановки.

← →
Nous Mellon © (2004-04-22 21:01) [3]

> TForm.Canvas"a будет достаточно.

Ты эта Подгорецкому что-ли советуешь? :)

← →
Jack128 © (2004-04-22 21:02) [4]

for i := 0 to 2 do
for j := 2 - i to 4 - i do
begin
ListBox1.Items[j] := "0";
ListBox1.Items[j + 1] := "1";
ListBox1.Refresh;
Sleep(1000);
end;

← →
Gero © (2004-04-22 21:03) [5]

> Ты эта Подгорецкому что-ли советуешь? :)

А это разве ему надо?

← →
Nous Mellon © (2004-04-22 21:07) [6]

> А это разве ему надо?

Так это был ответ на его пост.
Ну вы, блин, даете (с)
:)

← →
Anatoly Podgoretsky © (2004-04-22 22:04) [7]

От автора требуется разъяснение, мне кажется что можно переставлять только пары 10 -> 01

← →
Anatoly Podgoretsky © (2004-04-22 22:06) [8]

А про визуализацию, можно и на PaintBox отрисовывать все итерации, их все равно не более 36, в виде вертикальных столбиков.

На мой взгляд задача визуально похожа на пузырьковую сортировку, крайний правый 1 падает вниз до предела.

← →
Yanis © (2004-04-22 22:14) [9]

Хватит трепаться :) Это вам не ... Хотя.
Как всё - таки задачу то решить(не "с помощью чего", а "как", код всмысле :))?

← →
Jack128 © (2004-04-22 23:05) [10]

> На мой взгляд задача визуально похожа на пузырьковую сортировку,
> крайний правый 1 падает вниз до предела.
нет, потому что после того как он упал, он вдруг снова наверх лезет :-)

> 111000", "110100", "110010", "110001", "101100", "101010",
> "101001

А полный перебор я вроде написал, но у меня перебирается не в том порядке в каком коту нужно.. :-(

← →
Jack128 © (2004-04-22 23:14) [11]

Вот еще вариант. вроде работает нормально(правда визуально выглядит не так как дано в задании, но это мелочи)

procedure PolniyPerebor(s: string; sl: TStringList); var i, j: integer; Temp: TStringList; begin sl.Clear; if Length(s) = 1 then sl.Add(s) else begin Temp := TStringList.Create; try PolniyPerebor(copy(s, 1, Length(s) - 1), Temp); for i := 0 to Temp.Count - 1 do begin for j := 1 to Length(Temp[i]) do sl.add(copy(Temp[i], 1, j - 1) + s[Length(s)] + copy(Temp[i], j, Length(Temp[i]))); sl.add(Temp[i] + s[length(s)]); end; finally Temp.Free; end; end; end; function SortProc(List: TStringList; Index1, Index2: Integer): Integer; var i, j: Integer; begin i := StrToInt(List[Index1]); j := StrToInt(List[Index2]); Result := j - i; end; procedure TForm1.Button2Click(Sender: TObject); var sl: TStringList; i, j: integer; begin sl := TStringList.Create; try PolniyPerebor("111000", sl); // Удаляем дубликаты for i := 0 to sl.Count - 1 do for j := i + 1 to sl.Count - 1 do while (j < sl.Count) and (sl[i] = sl[j]) do sl.Delete(j); //-------------------------------------------------------------- sl.CustomSort(SortProc); listbox1.Items.Assign(sl); finally sl.Free; end; end;

← →
Gero © (2004-04-22 23:21) [12]

Задача неясна тем, что
> Нужно переместить все единички по порядку вниз
несоответствует
> Типа "111000", "110100", "110010", "110001", "101100", "101010",
> "101001", "100110", "100101", "100011", "011100", "011010"

← →
Кот-трахкун © (2004-04-22 23:28) [13]

Жек, пасиба, но типа немнога не таво... :(

Передвигать нуна командой Move (желательно), т.к. пример должен быть наглядным.

Мне тут Анатолий намекнул про рекурсию. Папробавать нада. Завтря, навена.

Может, завтра, со свежей башки чо-та мяукнеца.

Пасиба. :)

← →
Jack128 © (2004-04-22 23:28) [14]

> Gero © (22.04.04 23:21)
именно. Мой первый код "перемещает все единички по порядку вниз" , а второй перемещает их так как в примере написано..В общем завтра придет ал и все объяснит(я надеюсь)

← →
Mihey © (2004-04-22 23:59) [15]

Вот мой код. Вроде всё по заданию. На форме кнопчак и 6 TEdit с названиями LabelX, чтобы было непонятней.

procedure TmainForm.btnSortClick(Sender: TObject); label HereWeGoAgain; const N = 6; var a: array [1..6] of Byte; i, k: Integer; function IsDone(ar: array of Byte): Boolean; var t: Integer; begin Result := True; for t := N-1 downto 1 do begin If ((a[t] = 1) and (a[t+1] = 0)) then Result := False; end; end; begin for i := 1 to N do begin a[i] := StrToInt(TEdit(mainForm.FindComponent("Label" + IntToStr(i))).Text); end; If IsDone(a) then begin ShowMessage("Good!"); Exit; end; HereWeGoAgain: while not IsDone(a) do begin for i := N-1 downto 1 do begin If ((a[i] = 1) and (a[i+1] = 0)) then begin a[i] := 0; a[i+1] := 1; for k := 1 to N do begin TEdit(mainForm.FindComponent("Label" + IntToStr(k))).Text := IntToStr(a[k]); end; Application.ProcessMessages; Sleep(500); goto HereWeGoAgain; end; end; end; ShowMessage("Hmmm! Good!"); end;

← →
Anatoly Podgoretsky © (2004-04-23 00:46) [16]

Jack128 © (22.04.04 23:28) [14]
Что я могу объяснить, это кот пусть объясняет, как именно надо перемещать, а то не все ясно с условием перемещения.
Все по порядку вниз, это обмен пар, но замечание ТИПА и пример не подверждают это.

← →
Кот-трахкун © (2004-04-23 20:52) [17]

Надо было тему назвать не "Задачка", а "Задачка с тремя офигевшими".
Имею в виду, конечно, себя, а не вас, о Джек №128, Анатолий и всех остальных, которых я не знаю.

> а то не все ясно с условием перемещения.
> Все по порядку вниз, это обмен пар, но замечание ТИПА и
> пример не подверждают это.

Возможно, мой вопрос кажется заданным в весьма свободной литературной форме, и использует выражения, традиционно не свойственные суровому и краткому лексикону настоящего программера;)
Тем не менее, если вглядеться, можно ясно уловить смысл моего вопроса. Надеюсь, что кто-то из читающих этот топик
опытных мастеров приоткроет мне тайну личных и годами отточенных манипуляций с листбоксами и их методами, ибо скупая информация из книжки "Delphi 5 для профессионалов" ограничивается какой-то отмазкой по этому поводу.

> Mihey © (22.04.04 23:59) [15]

Mihey, при чем здесь шесть TEditов с кнопчаком?!
Вникнитесь в мою проблему. Есть ListBox. Есть шесть строчек "111000" (сокращенно LB111).
А теперь внимание! Мы двигаем третью по счету единичку на одну позицию вниз и получаем "110100". Не колеблясь, мы продолжаем двигать эту едииничку в самый низ списка. Вдруг - оригинальный ход - с последней строчки мы перемещаем эту единичку на четвертую позицию в списке, то есть - на одну больше, чем было изначально.
Улавливаете? Следите за моими руками.
Единичка под номером два ПЕРЕМЕЩАЕТСЯ! Следом за единичкой №3, которую мы пнули под зад на одну позицию вниз, единичка №2 тоже соскакивает под нашим чутким руководством на одну позицию ниже. Чтобы не свершилось насилие, единичка №3 спригивает вниз еще на одну позицию, дабы избежать надругательства со стороны номера второго.
Милиция, протокол, свидетели.
Как видим, жизнь в листбоксе бурлит и эволюция катится все-таки куда-то. Те, кто понял, могут остановится на этом месте и дальше не читать.

ЗЫ
Привет McSimmу. Почему он, подлец, не делает новые дайджесты?
Я хоть и не разбрасываюсь горстями лингвистического бисера по станицам этого форума, но все же почитываю его иногда. В оффлайне.

Тем, кто дочитал до этого места.
Как вы еще не поняли, единички в этом листбоксе, мягко говоря, должны перетекать в самый низ списка. Другими словами - мы, перемещая единички, факультативно перебираем все комбинации с тремя неизвестными. Брут-форс, ептыть.
ВВС, клонирование, стелсы, космические станции, которые бороздят просторы Атлантического океана... неужели в наш век не придуман алгоритм такого простого, на первый взгляд, перемещения?
Удивительно, но факт. Как по мне. А вам так не кажется?

2 Кот-трахкун:

Бессмысленная фигня, тем не менее, офигенно простая в реализации. Цтой очередной. Счастья вам, живите хорошо.

Бессмысленная. Согласен. Но отнюдь не фигня.
Внимательно прочитайте мой предыдущий постинг.

За пожелание спасибо.

> Кот-трахкун

Если Вы сами написали весь алгоритм, то в чем проблема?
В ListBox"e итемы перемещаются процедурой Items.Move.

To Кот-трахкун: ну так я не понял, вот такой метод тебе подойдёт ?

procedure TForm1.Button1Click(Sender: TObject);
Var Steps,I,X:Integer;
B:Boolean;
begin
X:=0;
For I:=0 to ListBox1.Items.Count - 1 do //Узнаём количество единичек в списке
IF ListBox1.Items[I] = "1" then Inc(X);
IF X = 0 then exit;
//Узнаём количество проходов
Steps := ListBox1.Items.Count - X;
//Начинаем пошаговую перестановку
For I := 1 to Steps do
begin
B := False; //Если B = false то значит ещё не втречен ни один 0
For X := ListBox1.Items.Count - 1 downto 0 do
begin
IF ListBox1.Items[X] <> "1" then B := True;
IF (ListBox1.Items[X] = "1") and B then
begin
ListBox1.Items.Move(X, X+1);
Sleep(1000);
Refresh;
end;
end;
end;
end;

Универсальный вроде... и задачу выполняет, правда двигает единички по принципу, "за один проход каждая на шаг вниз, потом следущих проход по кругу"

2 Кот-Трахкун:

Ок, еле впетрил, что тебе надо. Дубль 2. Кидаем на форму TListBox с названием ListBox и кнопчак, которому пишем в обработку:

procedure TmainForm.btnSortClick(Sender: TObject);
var Coord: array [1..3] of Byte;
WorkWith: Byte;
Stators: array [1..3] of Byte;
Stators222: array [1..3] of Byte;
s: Boolean;

procedure OutArray;
var q: Integer;
begin
ListBox.Items.Clear;
for q := 1 to 6 do
If (q <> Coord[1]) and (q <> Coord[2]) and (q <> Coord[3]) then
ListBox.Items.Add("0") else ListBox.Items.Add("1");
end;

function DoMove(What: Byte; Show: Boolean): Boolean;
begin
// True = достигли кончиты
Result := False;
If Coord[What] < 6 then
begin
Coord[What] := Coord[What] + 1;
If Show then
begin
OutArray;
Application.ProcessMessages;
Sleep(2000);
end;
end
else Result := True;
end;

begin
// We have 6
Coord[1] := 1;
Coord[2] := 2;
Coord[3] := 3;

// Работаем с третьим
WorkWith := 3;

while (coord[1] <> 4) and (coord[2] <> 5) and (coord[3] <> 6) do
begin
Stators222[1] := Coord[1];
Stators222[2] := Coord[2];
Stators222[3] := Coord[3];
while (coord[2] <> 5) and (coord[3] <> 6) do
begin
Stators[1] := Coord[1];
Stators[2] := Coord[2];
Stators[3] := Coord[3];
s := False;
While not s do
begin
s := DoMove(WorkWith, True);
end;
Coord[1] := Stators[1];
Coord[2] := Stators[2];
Coord[3] := Stators[3];
DoMove(WorkWith, False);
WorkWith := WorkWith-1;
DoMove(WorkWith, True);
WorkWith := WorkWith+1;
end;
// с первой
Coord[1] := Stators222[1];
Coord[2] := Stators222[2];
Coord[3] := Stators222[3];
DoMove(WorkWith, False);
WorkWith := WorkWith-1;
DoMove(WorkWith, False);
WorkWith := WorkWith-1;
DoMove(WorkWith, True);
WorkWith := WorkWith+2;
end;

ShowMessage("I""m a big bad niggar!");
end;

Компилим, жмём буттон, всё колкой идёт. Проверь сам. За отстутсвие Items.Move чур не винить - это легко сделать в процедуре Move. Ну что, то это или не то???????

В догонку. Sleep убавь до 500, а то заснёшь...

VID, я проливаю водопады слез, но твой код не работает. :(

Mihey, я офигел. Твой пример заработал.
По прошествии Sleep(50000) мы с монитором на пару тацевали джигу. Танцевали на протяжении примерно 150000 миллисекунд.

Теперь мне осталось чесать репу, как теперь суда втулить метод Move вместо генерации единичек-ноликов.

А кнопку я так и назвал - Mihey (procedure TForm1.MiheyClick(Sender: TObject);)
в честь одного оченно умного чела (не буду показывать пальцем, кого).

Сенькьсь.

Є(0.0)Э

Задачка Найти похожие ветки