Теория графов., Раскраска карты минимальным кол_вом цветов Опции

[-StrangerFX-]

Программа раскрашивания карты минимальным количеством цветов.

Исходные данные:

- Список регионов с указанием соседей каждого региона.

Выходные данные:

- Список регионов с приписанными им цветами.
- Общее число использованных цветов.

Требованния к фунуциональности:

- Эфективность решения.
- Наглядный вывод результата(раскраска карты).
- Опционально редактор карт(с возможностью рисовать мышью).

Вопрос следуюший, как сделать редактор карт с возможностью рисования мышью и удомным для пользователя меню.

[volvo]

Ну, это смотря какими средствами тебе можно пользоваться, смотря какой компилятор, опять же... ООП? Встроенный ASM? Внешние процедуры на ассемблере?

[Гость]

Ну, это смотря какими средствами тебе можно пользоваться, смотря какой компилятор, опять же... ООП? Встроенный ASM? Внешние процедуры на ассемблере?

Была мысль использовать ООП но с реализацией не задалось, так-как я знаю только основы Паскаля. А вобше эта работа курсовик, пользоватся можно всем (ООП,ASM). Правда на серьезную реализацию времени нет, 10 мая сдача работы а пока только оболочка и меню готовы. Если можеш помоги.

[volvo]

Нет, до 10-го мая я ничего серьезного сделать не успею, а что-то недоделанное выкладывать не буду... Надо было раньше обращаться. Чего тянул?

[Гость]

Нет, до 10-го мая я ничего серьезного сделать не успею, а что-то недоделанное выкладывать не буду... Надо было раньше обращаться. Чего тянул?

Я курсовик 26 апреля взял. А можно все сделать но только на Graph'e?

[Гость]

Да кстати 10 мая промежуточная сдача, основная будет 25-27 мая.

[Lapp]

Гость, ты много всего перечислил, и не совсем понятно, насколько тебя волнует основной алгоритм - процесс раскрашивания. Если волнует, то могу помочь с этим. Задача очень любопытная, меня заинтересовало уже то, что проблема четырех красок как раз не так давно была решена теоретически (с помощью компьютера, это как бы наглядный пример, как комп помогает в чистой математике), и захотелось самому прикоснуться..

Я тут набросал прогу, которая производит правильную (то есть соседние области - разноцветные) раскраску, не гарантируя минимальности количества цветов. Основной принцип - рекуррентная окраска областей. Написано без ООП, да и вообще довольно просто. Надеюсь, разберешься. А уж минимальность обеспечивай сам.. (можешь задавать вопросы)

const
  Nx=100;                           {максимальное число областей}

var
  N,                                {реальное число областей}
  i,j:integer;
  Col:array[1..Nx]of byte;          {массив цветов}
  Nn:array[1..Nx]of byte;           {сколько соседей у каждой области}
  Nei:array[1..Nx,1..Nx]of byte;    {массив соседей}
  Trace:array[1..Nx]of boolean;     {для отметки пройденных областей}
  Empty:set of byte;                {для очистки списка цветов}
  f:text;

const
  MaxCol:byte=0;

function Paint(m:byte):byte;
var
  i:integer;
  Used:set of byte;
begin
  Used:=Empty;                       {очищаем список использованных цветов}
  if Col[m]=0 then begin             {если область еще не покрашена..}
    Trace[m]:=false;                 {отмечаем пройденные области}
    for i:=1 to Nn[m] do if Trace[Nei[m,i]] then Include(Used,Paint(Nei[m,i]));   {опрашиваем цвета соседей}
    i:=1;
    while i in Used do Inc(i);       {выбираем первый цвет из свободных}
    if i>MaxCol then MaxCol:=i;      {запоминаем максимальный цвет (несущественно)}
    Col[m]:=i;                       {заполняем массив цветов областей}
    Paint:=i;
    Trace[m]:=true                   {необязательно}
  end
  else Paint:=Col[m]                 {если область уже покращена, просто возвращаем ее цвет}
end;

begin
  for i:=0 to 255 do Exclude(Empty,i);
  for i:=1 to Nx do begin
    Col[i]:=0;
    Trace[i]:=true
  end;
                                     {формат данных:}
                                     {число строк равно чилу областей}
                                     {первое число в строке - количество соседей области}
                                     {затем перечисляются соседи}
                                     {пустых строк не должно быть ни внутри, ни в конце}
  Assign(f,'reg_nei.dat');
  Reset(f);
  N:=0;
  while not EoF(f) do begin
    Inc(N);
    Read(f,Nn[N]);
    for i:=1 to Nn[N] do Read(f,Nei[N,i]);
    ReadLn(f)
  end;
  Close(f);

  Paint(1);                           {красим область 1}
  WriteLn('MaxCol = ',MaxCol);
  for i:=1 to N do Write('  ',Col[i]);
  WriteLn;
  ReadLn;
end.

А вот пример файла с областями, reg_nei.dat

Код

5 2 3 4 5 6
3 1 3 6
3 1 2 4
3 1 3 5
3 1 4 6
3 1 5 2

Это расположение представляет собой пятилепестковую ромашку . На нем (и на более простых) я проверял прогу. Вроде, не врет..

[strangerfx]

Попробовал сделать основную программу для раскраски карты:

Вот код: (Показать/Скрыть)

{$D+}
uses crt;
type gh=array[1..20] of string;
	 map=record
		   land:string;
		   col:byte;
		   sos:gh;
		   color:byte;
		 end;
	 mapptr=^mappt;
	 mappt=record
			 dat:map;
			 next:mapptr;
		   end;

var fmap:file of map;
	first:mapptr;
	mp:map;
	q,n:integer;
	mas:array[1..50] of pointer;

procedure upcase(var s:string);
var g:char;
	i,h:integer;
begin
  h:=length(s);
  for i:=1 to h do begin
   g:=s[i];
   if g<>' ' then case ord(g) of
		   97..122: s[i]:=chr(ord(g)-32);
		   160..175: s[i]:=chr(ord(g)-32);
		   224..239: s[i]:=chr(ord(g)-80);
		  end;
		end;
end;

procedure Create_file;
var i,j:integer;
	mp:map;
begin
  write('Введите количество стран в регионе -> ');
  readln(n);
  for j:=1 to n do
	begin
	  write('Введите страну №',j,' -> ');
	  readln(mp.land);
	  upcase(mp.land);
	  write('Введите количество соседей -> ');
	  readln(mp.col);
	  for i:=1 to mp.col do
		begin
		  write('Введите соседа №',i,' ');
		  readln(mp.sos[i]);
		  upcase(mp.sos[i]);
		end;
	  mp.color:=0;
	  clrscr;
	  reset(fmap);
	  i:=filesize(fmap);
	  seek(fmap,i);
	  write(fmap,mp);
	  close(fmap);
	end;
end;

procedure Create_list(var first:mapptr);
var tec,tec1,pred:mapptr;
begin
  reset(fmap);
  first:=nil;
  while not eof(fmap) do
	begin
	  new(tec);
	  read(fmap,tec^.dat);
	  tec^.next:=nil;
	  if first=nil
		then
		  first:=tec
		else
		  begin
			tec1:=first;
			pred:=nil;
			while (tec1<>nil) and
			(tec^.dat.col>tec1^.dat.col) do
			  begin
				pred:=tec1;
				tec1:=tec1^.next;
			  end;
			if tec1=first
			  then
				begin
				  tec^.next:=first;
				  first:=tec;
				end
			  else
				begin
				  tec^.next:=pred^.next;
				  pred^.next:=tec;
				end;
		  end;
	end;
end;

procedure Move_list(first:mapptr);
var i:integer;
	tec:mapptr;
begin
  clrscr;
  fillchar(mas,sizeof(mas),0);
  tec:=first;
  i:=0;
  while tec<>nil do
	begin
	  with tec^.dat do
		begin
		  inc(i);
		  mas[i]:=tec;
		end;
	  tec:=tec^.next;
	end;
  q:=i;
  readln;
end;

procedure clin(var mas:array of string);
var i:byte;
begin
  for i:=1 to 20 do
	 mas[i]:='';
end;

procedure rasshet;
var tec:mapptr;
	x,i,j,k,b:integer;
	g:byte;
	mas_s:array[1..20] of string;
begin
  tec:=mas[q];
  g:=1;
  with tec^.dat do
	begin
	  tec^.dat.color:=g;
	  x:=1;
	  mas_s[x]:=tec^.dat.land;
	end;
  while x<>q do
	begin
	  inc(g);
	  for i:=1 to q-1 do
		begin
		  tec:=mas[i];
		  with tec^.dat do
			begin
			  if tec^.dat.color=0
				then
				  begin
					b:=0;
					for j:=1 to x do
					  begin
						for k:=1 to tec^.dat.col do
						  begin
							if mas_s[j]=tec^.dat.sos[k]
							  then
								inc(b);
						  end;
					  end;
					if b=0
					  then
						begin
						  tec^.dat.color:=g;
						  inc(x);
						  mas_s[x]:=tec^.dat.land;
						end;
				  end;
			end;
		end;
	  clin(mas_s);
	end;
end;

procedure Mov_list(first:mapptr);
var tec:mapptr;
begin
  clrscr;
  tec:=first;
  while tec<>nil do
	begin
	  with tec^.dat do
		begin
		  writeln(land,' ',col,' ',color);
		end;
	  tec:=tec^.next;
	end;
  readln;
end;

begin
  assign(fmap,'map.dat');
 { create_file;}
  create_list(first);
  move_list(first);
  rasshet;
  mov_list(first);
end.

но она не работает. В чем проблема?

[volvo]

Во-первых, что значит "не работает"? Вылетает, или не выполняет того, что требуется?

Ну, и на всякий случай присоедини твой файл map.dat... Чтоб можно было прогнать при таких же данных...

[strangerfx]

Провел поиск багов и получил следующее: (Показать/Скрыть)

{$D+}
uses crt;
type gh=array[1..20] of string;
	 map=record
		   land:string;
		   col:byte;
		   sos:gh;
		   color:byte;
		 end;
	 mapptr=^mappt;
	 mappt=record
			 dat:map;
			 next:mapptr;
		   end;

var fmap:file of map;
	first:mapptr;
	mp:map;
	q,n:integer;
	mas:array[1..50] of pointer;

procedure upcase(var s:string);
var g:char;
	i,h:integer;
begin
  h:=length(s);
  for i:=1 to h do begin
   g:=s[i];
   if g<>' ' then case ord(g) of
		   97..122: s[i]:=chr(ord(g)-32);
		   160..175: s[i]:=chr(ord(g)-32);
		   224..239: s[i]:=chr(ord(g)-80);
		  end;
		end;
end;

procedure Create_file;
var i,j:integer;
	mp:map;
begin
  clrscr;
  write('Введите количество стран в регионе -> ');
  readln(n);
  for j:=1 to n do
	begin
	  write('Введите страну №',j,' -> ');
	  readln(mp.land);
	  upcase(mp.land);
	  write('Введите количество соседей -> ');
	  readln(mp.col);
	  for i:=1 to mp.col do
		begin
		  write('Введите соседа №',i,' ');
		  readln(mp.sos[i]);
		  upcase(mp.sos[i]);
		end;
	  mp.color:=0;
	  clrscr;
	  reset(fmap);
	  i:=filesize(fmap);
	  seek(fmap,i);
	  write(fmap,mp);
	  close(fmap);
	end;
end;

procedure Create_list(var first:mapptr);
var tec,tec1,pred:mapptr;
begin
  reset(fmap);
  first:=nil;
  while not eof(fmap) do
	begin
	  new(tec);
	  read(fmap,tec^.dat);
	  tec^.next:=nil;
	  if first=nil
		then
		  first:=tec
		else
		  begin
			tec1:=first;
			pred:=nil;
			while (tec1<>nil) and
			(tec^.dat.col>tec1^.dat.col) do
			  begin
				pred:=tec1;
				tec1:=tec1^.next;
			  end;
			if tec1=first
			  then
				begin
				  tec^.next:=first;
				  first:=tec;
				end
			  else
				begin
				  tec^.next:=pred^.next;
				  pred^.next:=tec;
				end;
		  end;
	end;
end;

procedure Move_list(first:mapptr);
var i:integer;
	tec:mapptr;
begin
  clrscr;
  fillchar(mas,sizeof(mas),0);
  tec:=first;
  i:=0;
  while tec<>nil do
	begin
	  with tec^.dat do
		begin
		  inc(i);
		  mas[i]:=tec;
		end;
	  tec:=tec^.next;
	end;
  q:=i;
  readln;
end;

procedure rasshet;
var tec:mapptr;
	x,i,j,k,b:integer;
	g:byte;
	mas_s:array[1..20] of string;
begin
  tec:=mas[q];
  g:=1;
  with tec^.dat do
	begin
	  tec^.dat.color:=g;
	  x:=1;
	  mas_s[x]:=tec^.dat.land;
	end;
  while x<>q do
	begin
	  writeln('x= ',x,' q= ',q);
	  readln;
	  for i:=1 to q-1 do
		begin
		  tec:=mas[i];
		  with tec^.dat do
			begin
			  if tec^.dat.color=0
				then
				  begin
					b:=0;
					writeln(land);
					for j:=1 to x do
					  begin
						for k:=1 to tec^.dat.col do
						  begin
							writeln('mas_s[j] = ',mas_s[j],' tec^.dat.sos[k] = ',tec^.dat.sos[k]);
							if mas_s[j]=tec^.dat.sos[k]
							  then
								inc(b);
						  end;
					  end;
					writeln('b= ',b);
					if (b=0) and (tec^.dat.color=0)
					  then
						begin
						  tec^.dat.color:=g;
						  writeln(tec^.dat.land,' ',tec^.dat.color);
						  readln;
						  inc(x);
						  mas_s[x]:=tec^.dat.land;
						end;
				  end;
			end;
		end;
	  inc(g);
	  for i:=1 to 20 do mas_s[i]:='';
	end;
end;

procedure Mov_list(first:mapptr);
var tec:mapptr;
begin
  clrscr;
  tec:=first;
  while tec<>nil do
	begin
	  with tec^.dat do
		begin
		  writeln(land,' ',col,' ',color);
		end;
	  tec:=tec^.next;
	end;
  readln;
end;

begin
  assign(fmap,'map.dat');
  {create_file;}
  create_list(first);
  move_list(first);
  rasshet;
  mov_list(first);
end.

.
Теперь все работает . Осталось только все в графическом
виде представить.

[Lapp]

Теперь все работает . Осталось только все в графическом
виде представить.

Немного странная манера: попросить о помощи, а потом даже не замечать постов с той самой помощью.
И если уж постишь свою прогу (кстати, без единого комментария), то по крайней мере прилагай файл данных, как просил тебя volvo, или хотя бы опиши его формат. Или ты считаешь мы должны просто распечатать, повестить твое бессмертное творение на стену и восхищаться?..

[strangerfx]

Немного странная манера: попросить о помощи, а потом даже не замечать постов с той самой помощью.
И если уж постишь свою прогу (кстати, без единого комментария), то по крайней мере прилагай файл данных, как просил тебя volvo, или хотя бы опиши его формат. Или ты считаешь мы должны просто распечатать, повестить твое бессмертное творение на стену и восхищаться?..

1. За помощь спасибо(кстати я ее всегда замечаю), но рекурентное решение задачи неподходит по условию написания работы (обязательно использование списков и/или деревьев).
2. Я бы приложил фаил если бы знал как это сделать.
3. Коментариев к проге неписал по причине нехватки времени, и распечатывать ее совершенно необязательно!.
4. Вопрос: где можно скачать TPU фаил для работы с мышью?

[Lapp]

> 1. За помощь спасибо(кстати я ее всегда замечаю),
Я не зрение твое имел в виду. Замечать - значит "реагировать". Игнорировать в разговоре = не замечать. Или я неправильно трактую русский язык? Спасибо, вытянуте клещами, звучит странновато.. но ничего, принимаю.

> но рекурентное решение задачи неподходит по условию написания
> работы (обязательно использование списков и/или деревьев).
Неплохо было бы это упомянуть с самого начала..

> 2. Я бы приложил фаил если бы знал как это сделать.
Кнопочки "Browse" и "Добавить файл" настолько малозаметны?.. Ну, в таком случае можно было бы спросить..

> 3. Коментариев к проге неписал по причине нехватки времени,
Комментарии - твой личный вопрос, но только пока ты не показываешь прогу другим. Простая вежливость требует писать их, если ты передаешь программу, особенно с целью поиска ошибок. Не верю, что на написание нескольких слов уходит много времени. В качестве примера можешь посмотреть мой код (выше).

> и распечатывать ее совершенно необязательно!.
Но что тогда с ней делать? Никакого вопроса с ней задано не было..

> 4. Вопрос: где можно скачать TPU фаил для работы с мышью?
Это отдельный вопрос, отдельная тема..

[strangerfx]

> 1. За помощь спасибо(кстати я ее всегда замечаю),
Я не зрение твое имел в виду. Замечать - значит "реагировать". Игнорировать в разговоре = не замечать. Или я неправильно трактую русский язык? Спасибо, вытянуте клещами, звучит странновато.. но ничего, принимаю.

> но рекурентное решение задачи неподходит по условию написания
> работы (обязательно использование списков и/или деревьев).
Неплохо было бы это упомянуть с самого начала..

> 2. Я бы приложил фаил если бы знал как это сделать.
Кнопочки "Browse" и "Добавить файл" настолько малозаметны?.. Ну, в таком случае можно было бы спросить..

> 3. Коментариев к проге неписал по причине нехватки времени,
Комментарии - твой личный вопрос, но только пока ты не показываешь прогу другим. Простая вежливость требует писать их, если ты передаешь программу, особенно с целью поиска ошибок. Не верю, что на написание нескольких слов уходит много времени. В качестве примера можешь посмотреть мой код (выше).

> и распечатывать ее совершенно необязательно!.
Но что тогда с ней делать? Никакого вопроса с ней задано не было..

> 4. Вопрос: где можно скачать TPU фаил для работы с мышью?
Это отдельный вопрос, отдельная тема..

>1 Критиковать других каждый может, "Игнорировать в разговоре = не замечать" странная формула помоему , твои код я просмотрел и кое что из него подчерпнул для себя, но не больше.
>2 Без коментариев.
>3 Код моей программы ненастолько сложен для человека разбирающегося в Pascal, я считаю что именно такие люди отвечают здесь на вопросы.
>4 Вопрос неотдельный, если бы ты посмотрел требования к функциональности программы то заметил бы следующее - Опционально редактор карт(с возможностью рисовать мышью)., а это означает что мыш надо сначала подключить .
Вопрос по теме: Как создать меню на ООП и подключить к нему мою программу?