Обьединенные цвета Бенеттона

Форум пользователей пакета Maple

Модератор: Admin

Markiyan Hirnyk
Сообщения: 1366
Зарегистрирован: Вс дек 04, 2011 11:07 pm

Обьединенные цвета Бенеттона

Сообщение Markiyan Hirnyk » Пт янв 06, 2012 1:43 pm

Пусть задано разбиение плоского многоугольника на закрашенные многоугольники.
Известны координаты вершин и цвет каждой части разбиения, например, таким образом:
>with(plottools): with(plots):
>display(polygon([[.12, 1.28], [3.07, 4.54], [3.41, 1.69]]), color = red,
thickness = 2, view = [-1 .. 5, -1 .. 5]);
Требуется составить Maple процедуру, обьединяющую многоугольники одинакового цвета с общим ребром
(если общих ребер несколько, то изымается только одно из них). Например, для заданного разбиения
мы должны получить два зеленые, один красный, один желтый, один синий и один фиолетовый многоугольники.
Изображение

Kitonum
Сообщения: 2084
Зарегистрирован: Ср дек 31, 2008 1:55 pm
Откуда: г. Пенза

Сообщение Kitonum » Пт янв 06, 2012 9:03 pm

Уважаемый г-н Markiyan Hirnyk! Я примерно представляю как написать такую процедуру. Только хотелось бы узнать источник этой задачи. Сообщите пожалуйста!

Markiyan Hirnyk
Сообщения: 1366
Зарегистрирован: Вс дек 04, 2011 11:07 pm

Сообщение Markiyan Hirnyk » Пт янв 06, 2012 9:34 pm

Kitonum писал(а):Уважаемый г-н Markiyan Hirnyk! Я примерно представляю как написать такую процедуру. Только хотелось бы узнать источник этой задачи. Сообщите пожалуйста!
Она была поставлена на на одном из форумов по математическим системам и не получила адекватный ответ. Я также имею идею, но мне не хватает техники и времени.

Kitonum
Сообщения: 2084
Зарегистрирован: Ср дек 31, 2008 1:55 pm
Откуда: г. Пенза

Сообщение Kitonum » Пт янв 06, 2012 9:55 pm

Markiyan Hirnyk писал(а):
Kitonum писал(а):Уважаемый г-н Markiyan Hirnyk! Я примерно представляю как написать такую процедуру. Только хотелось бы узнать источник этой задачи. Сообщите пожалуйста!
Она была поставлена на на одном из форумов по математическим системам и не получила адекватный ответ. Я также имею идею, но мне не хватает техники и времени.

Приведите, пожалуйста, конкретную ссылку на этот форум!

Markiyan Hirnyk
Сообщения: 1366
Зарегистрирован: Вс дек 04, 2011 11:07 pm

Ссылки

Сообщение Markiyan Hirnyk » Пт янв 06, 2012 10:00 pm

Kitonum писал(а):Приведите, пожалуйста, конкретную ссылку на этот форум!

http://forum.exponenta.ru/viewtopic.php?t=11409
http://www.mapleprimes.com/questions/12 ... f-Benetton

Kitonum
Сообщения: 2084
Зарегистрирован: Ср дек 31, 2008 1:55 pm
Откуда: г. Пенза

Сообщение Kitonum » Сб янв 07, 2012 1:44 pm

Код процедуры:

DelBar := proc (L)
local M, P, P1, P2, P3, P4, P5;
M := seq(plottools:-polygon(L[i, 2], linestyle = 7, color = L[i, 1]), i = 1 .. nops(L));
P := seq(op([seq(plottools:-line(L[i, 2, j], L[i, 2, j+1], color = black, thickness = 3), j = 1 .. nops(L[i, 2])-1), plottools:-line(L[i, 2, nops(L[i, 2])], L[i, 2, 1], color = black, thickness = 3)]), i = 1 .. nops(L));

P1 := [seq(op([seq([L[i, 1], {L[i, 2, j], L[i, 2, j+1]}], j = 1 .. nops(L[i, 2])-1), [L[i, 1], {L[i, 2, 1], L[i, 2, nops(L[i, 2])]}]]), i = 1 .. nops(L))];
P2 := convert(`minus`(convert(P1, set), convert(ListTools[FindRepetitions](P1), set)), list);
P3 := seq(plottools:-line(op(P2[i, 2]), color = black, thickness = 3), i = 1 .. nops(P2));
P4 := ListTools[FindRepetitions](P1);
P5 := seq(plottools:-line(op(P4[i, 2]), color = P4[i, 1], thickness = 3), i = 1 .. nops(P4));

print(plots:-display(M, P, scaling = constrained, axes = none));
plots:-display(M, P3, P5, scaling = constrained, axes = none)
end proc:


Пример работы:

DelBar([[red, [[0, 0], [1, 1], [2, 1], [3, 0]]], [blue, [[0, 0], [0, 1], [1, 3], [1, 2], [1, 1]]], [green, [[1, 3], [3, 2], [2, 2], [1, 2]]], [green, [[2, 2], [3, 2], [3, 0], [2, 1]]], [red, [[1, 1], [1, 2], [2, 2], [2, 1]]]])

Изображение

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

Kitonum
Сообщения: 2084
Зарегистрирован: Ср дек 31, 2008 1:55 pm
Откуда: г. Пенза

Сообщение Kitonum » Пн янв 09, 2012 11:19 am

Немного улучшил предыдущую прогу. Теперь не обязательно при задании многоугольников указывать все вершины на его границе.

restart;
DelBar := proc (L)
local M, P, P1, P2, P3, P4, P5, Check, i, j;

M := seq(plottools:-polygon(L[i, 2], linestyle = 7, color = L[i, 1]), i = 1 .. nops(L));
P := seq(op([seq(plottools:-line(L[i, 2, j], L[i, 2, j+1], color = black, thickness = 3), j = 1 .. nops(L[i, 2])-1), plottools:-line(L[i, 2, nops(L[i, 2])], L[i, 2, 1], color = black, thickness = 3)]), i = 1 .. nops(L));
P1 := [seq(op([seq([L[i, 1], [L[i, 2, j], L[i, 2, j+1]]], j = 1 .. nops(L[i, 2])-1), [L[i, 1], [L[i, 2, nops(L[i, 2])], L[i, 2, 1]]]]), i = 1 .. nops(L))];

Check := proc (A, B, C)
if C <> A and C <> B and (C[1]-A[1])*(B[2]-A[2])-(C[2]-A[2])*(B[1]-A[1]) = 0 and sign(C[1]-A[1]) = sign(B[1]-C[1]) and sign(C[2]-A[2]) = sign(B[2]-C[2]) then true else false end if end proc;

for i while i <= nops(P1) do
for j while j <= nops(P1) do
if Check(P1[i, 2, 1], P1[i, 2, 2], P1[j, 2, 1]) and not Check(P1[i, 2, 1], P1[i, 2, 2], P1[j, 2, 2]) then P1 := subsop(i = op([[P1[i, 1], [P1[i, 2, 1], P1[j, 2, 1]]], [P1[i, 1], [P1[j, 2, 1], P1[i, 2, 2]]]]), P1) end if; if not Check(P1[i, 2, 1], P1[i, 2, 2], P1[j, 2, 1]) and Check(P1[i, 2, 1], P1[i, 2, 2], P1[j, 2, 2]) then P1 := subsop(i = op([[P1[i, 1], [P1[i, 2, 1], P1[j, 2, 2]]], [P1[i, 1], [P1[j, 2, 2], P1[i, 2, 2]]]]), P1) end if end do end do;

P1 := [seq([P1[i, 1], convert(P1[i, 2], set)], i = 1 .. nops(P1))];
P2 := convert(`minus`(convert(P1, set), convert(ListTools[FindRepetitions](P1), set)), list);
P3 := seq(plottools:-line(op(P2[i, 2]), color = black, thickness = 3), i = 1 .. nops(P2));
P4 := ListTools[FindRepetitions](P1);
P5 := seq(plottools:-line(op(P4[i, 2]), color = P4[i, 1], thickness = 3), i = 1 .. nops(P4));

print(plots:-display(M, P, scaling = constrained, axes = none));
plots:-display(M, P3, P5, scaling = constrained, axes = none);

end proc:


Пример:

DelBar([[red, [[0, 0], [0, 2], [2, 2], [2, 1], [3, 1], [3, 2], [4, 2], [4, 0]]], [green, [[0, 2], [0, 6], [3, 6], [3, 4], [2, 4], [2, 5], [1, 5], [1, 3], [2, 3], [2, 2]]], [blue, [[1, 3], [1, 5], [2, 5], [2, 3]]], [red, [[3, 2], [3, 6], [5, 6], [5, 2]]], [green, [[2, 1], [2, 4], [3, 4], [3, 1]]], [yellow, [[4, 0], [4, 2], [5, 2], [5, 0]]]]);

Изображение

Markiyan Hirnyk
Сообщения: 1366
Зарегистрирован: Вс дек 04, 2011 11:07 pm

Спасибо

Сообщение Markiyan Hirnyk » Пн янв 09, 2012 2:36 pm

Хорошая работа! Спасибо Вам. Комментарии к коду были бы полезны. Целесообразно также представлять параметры процедуры как в команде polygon, т. е. цвет указывать в конце. Для полноты ответа требуется еще вариант кода, обьединяющий многоугольники одинакового цвета только по одному общему ребру.

Kitonum
Сообщения: 2084
Зарегистрирован: Ср дек 31, 2008 1:55 pm
Откуда: г. Пенза

Re: Спасибо

Сообщение Kitonum » Ср янв 11, 2012 1:44 pm

Markiyan Hirnyk писал(а):... Комментарии к коду были бы полезны. Целесообразно также представлять параметры процедуры как в команде polygon, т. е. цвет указывать в конце. Для полноты ответа требуется еще вариант кода, обьединяющий многоугольники одинакового цвета только по одному общему ребру.

Вариант предыдущего кода с учётом всех 3 пожеланий:

restart:
DelBar3:=proc(L, C) #` L - list of polygons, C - list of colors`
local M,P,P1,P2,P3,P4,P5,Check,i,j,Q,P0,p;
uses plottools, plots;

if nops(L)<>nops(C) then error "Sizes L and C should be equal" fi;

M:=seq(polygon(L[s],linestyle=7,color=C[s]),s=1..nops(L)); #` Specifying of filled polygons`
P:=seq(op([seq(line(L[i,j],L[i,j+1],color=black,thickness=3),j=1..nops(L[i] )-1),line(L[i,nops(L[i] )],L[i,1],color=black,thickness=3)]),i=1..nops(L)); # Specifying of all edges as segments
P1:=[seq(op([seq([C[i], [L[i,j],L[i,j+1]]],j=1..nops(L[i] )-1),[C[i],[L[i,nops(L[i] )],L[i,1]]]]),i=1..nops(L))]; #` Specifying of all edges as lists by pairs `[color,list of coordinates]

Check:=proc(A,B,C) #` Procedure checking Is point C between points A and B`
if C<>A and C<>B and (C[1]-A[1]) (B[2]-A[2])-(C[2]-A[2]) (B[1]-A[1])=0 and sign(C[1]-A[1])=sign(B[1]-C[1]) and sign(C[2]-A[2])=sign(B[2]-C[2]) then true else false; fi;
end proc;

#` Partition of the edges , on which vertices of other polygons lie `
for i from 1 while i<=nops(P1) do for j from 1 while j<=nops(P1) do if Check(P1[i,2,1],P1[i,2,2],P1[j,2,1] ) and not Check(P1[i,2,1],P1[i,2,2],P1[j,2,2] )then P1:=subsop(i=op([[P1[i,1],[P1[i,2,1], P1[j,2,1]]], [P1[i,1],[P1[j,2,1], P1[i,2,2]]]]), P1); fi; if not Check(P1[i,2,1],P1[i,2,2],P1[j,2,1] ) and Check(P1[i,2,1],P1[i,2,2],P1[j,2,2] )then P1:=subsop(i=op([[P1[i,1],[P1[i,2,1], P1[j,2,2]]], [P1[i,1],[P1[j,2,2], P1[i,2,2]]]]), P1); fi;
od; od;

#` Finding and deleting joint edges of adjacent polygons of the same color `
P1:=[seq([P1[i,1],convert(P1[i,2],set)],i=1..nops(P1))]:
P2:=ListTools[FindRepetitions](P1);
P0:=P2;
Q:=[op({seq(P2[i,1],i=1..nops(P2))})];

while nops(Q)>0 do for p in P2 while nops(P2)>0 do if p[1]=Q[1] then Q:=subsop(1=NULL,Q); P2:=convert({op(P2)} minus {p},list); fi; if nops(Q)=0 then break; fi; od; od;

P2:=convert(convert(P0,set) minus convert(P2,set),list);
P3:=convert(convert(P1,set) minus convert(P2,set),list);
P4:=seq(line(op(P3[i,2]),color=black,thickness=3),i=1..nops(P3)); P5:=seq(line(op(P2[i,2]),color=P2[i,1],thickness=3),i=1..nops(P2));

#` All the constructions`
print( display(M,P,scaling=constrained,axes=none));
display(M,P4,P5,scaling=constrained,axes=none)

end proc:


Пример работы:

DelBar3([[[2, 0], [2, 1], [3, 1], [3, 2], [4, 2], [4, 0]], [[0, 2], [0, 6], [3, 6], [3, 4], [2, 4], [2, 5], [1, 5], [1, 3], [2, 3], [2, 2]], [[1, 3], [1, 5], [2, 5], [2, 3]], [[3, 2], [3, 6], [5, 6], [5, 2]], [[0, 0], [0, 2], [2, 2], [2, 0]], [[2, 1], [2, 4], [3, 4], [3, 1]], [[4, 0], [4, 2], [5, 2], [5, 0]]], [red, green, blue, red, red, green, yellow]);
Изображение

Markiyan Hirnyk
Сообщения: 1366
Зарегистрирован: Вс дек 04, 2011 11:07 pm

Вариант

Сообщение Markiyan Hirnyk » Ср янв 11, 2012 9:22 pm

Kitonum писал(а):Вариант предыдущего кода с учётом всех 3 пожеланий:
Спасибо. К сожалению, это не тот результат. Во первых, нужны многоугольники в формате команды polygon. Нарисовать их уже легко. Во вторых, в примере 4 в MaplePrimes окончательный результат, т. е.
красный восьмимиугольник с двумя совпадающими ребрами и синий пятиугольник с двумя совпадающими ребрами не получен.

Kitonum
Сообщения: 2084
Зарегистрирован: Ср дек 31, 2008 1:55 pm
Откуда: г. Пенза

Re: Вариант

Сообщение Kitonum » Ср янв 11, 2012 10:40 pm

Markiyan Hirnyk писал(а):...К сожалению, это не тот результат.Во первых, нужны многоугольники в формате команды polygon. Нарисовать их уже легко.

В каком смысле "нужны" и зачем?

Markiyan Hirnyk писал(а):... Во вторых, в примере 4 в MaplePrimes окончательный результат, т. е.
красный восьмимиугольник с двумя совпадающими ребрами и синий пятиугольник с двумя совпадающими ребрами не получен...


Странное заявление! Вы же сами писали

Markiyan Hirnyk писал(а):... Для полноты ответа требуется еще вариант кода, обьединяющий многоугольники одинакового цвета только по одному общему ребру...


В примере 4 получен результат

Изображение

Было 3 красных многоугольника с 3 общими рёбрами. Одно ребро исчезло, т.е. 2 многоугольника объединились! Аналогично, было 4 синих многоугольника с 4 общими рёбрами, одно ребро стёрто...
Кроме того, ещё в своём первом посте Вы писали: "если общих ребер несколько, то изымается только одно из них"

Markiyan Hirnyk
Сообщения: 1366
Зарегистрирован: Вс дек 04, 2011 11:07 pm

Ответ

Сообщение Markiyan Hirnyk » Чт янв 12, 2012 11:40 am

Прошу извинения за недостаточно четкую формулировку вопроса. Уточняю: в процессе обьединения у любых двух соседних многоугольников одинакового цвета изымается только одно общее ребро. Многоугольники, а не картинки, требовались в постановке вопроса.

Kitonum
Сообщения: 2084
Зарегистрирован: Ср дек 31, 2008 1:55 pm
Откуда: г. Пенза

Re: Ответ

Сообщение Kitonum » Чт янв 12, 2012 9:21 pm

Markiyan Hirnyk писал(а):Прошу извинения за недостаточно четкую формулировку вопроса. Уточняю: в процессе обьединения у любых двух соседних многоугольников одинакового цвета изымается только одно общее ребро. Многоугольники, а не картинки, требовались в постановке вопроса.

Комментариев и продолжения не будет!