VPF::Реализация алгоритма прореживание изображения

MaDRuS

Дата 2.10.2006, 16:15 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 7
Регистрация: 2.10.2006

Репутация: нет
Всего: нет

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

Zero

Дата 2.10.2006, 17:17 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 2169
Регистрация: 23.10.2004
Где: Россия, г. Рязань

Репутация: нет
Всего: 24

Ну самое примитивное это так:
в цикле пробегаешся по пикселям, и проверяешь каждый пиксель, если его цвет серый с наклонностью белого, то присваиваешь белый, иначе чёрный.
В DRKB я где то видал пример...

Это сообщение отредактировал(а) Zero - 2.10.2006, 17:18

maxim1000

Дата 2.10.2006, 18:19 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник
Сообщений: 3334
Регистрация: 11.1.2003
Где: Киев

Репутация: нет
Всего: 110

http://cgm.cs.mcgill.ca/~godfried/teaching...r/skeleton.html
только там есть случаи, когда алгоритм не работает
если будут проблемы - будем обсуждать...

--------------------

qqq

MaDRuS

Дата 3.10.2006, 12:23 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 7
Регистрация: 2.10.2006

Репутация: нет
Всего: нет

<Ну самое примитивное это так:
<в цикле пробегаешся по пикселям, и проверяешь каждый пиксель, если его цвет серый с
<наклонностью белого, то присваиваешь белый, иначе чёрный.
<В DRKB я где то видал пример...

Какой серый цвет ? Изображение монохромное (ч\б) . В ДРКБ что то не нашел ничего подобного

Zero

Дата 3.10.2006, 18:05 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 2169
Регистрация: 23.10.2004
Где: Россия, г. Рязань

Репутация: нет
Всего: 24

Цитата(MaDRuS @ 3.10.2006, 13:23

)

Изображение монохромное (ч\б)

Так стоп, кажется я не так понял задание... smile

Цитата(MaDRuS @ 2.10.2006, 17:15

)

выделение скелета бинарного изображения

Что означает скилет???

MaDRuS

Дата 4.10.2006, 16:16 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 7
Регистрация: 2.10.2006

Репутация: нет
Всего: нет

Например линия, шириной 5 пикселей и какой то длиной -> ее скелетом должна быть линия шириной в 1 пиксель по координатам середины первоначальной. Вот только одной линией не обойтись, надо хотя бы распознавание скелета буковок сделать

Agnazar

Дата 26.11.2007, 00:59 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 9
Регистрация: 25.11.2007

Репутация: нет
Всего: нет

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

Agnazar

Дата 26.11.2007, 10:41 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 9
Регистрация: 25.11.2007

Репутация: нет
Всего: нет

Кажется сам алгоритм проверки верен в основном, но работает довольно паршивенько...
Интересна сама траектория прохода еще... В зависимости от того как проходишь по экрану, выдает разные результаты. smile

Это сообщение отредактировал(а) Agnazar - 2.12.2007, 19:57

Agnazar

Дата 2.12.2007, 19:52 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 9
Регистрация: 25.11.2007

Репутация: нет
Всего: нет

Код


program laba01;
uses crt,graph;
const n=20;
var mas: array[1..n,1..n] of char;
    m1: text;
    xx,yy,k,x,y,a,b,c,d,i,e: integer;
    var gd,gm: integer;



procedure makmas;
begin
Assign(m1, 'e:\pict2.txt');  { Standard output }
Reset(m1);
for y:=1 to n do
  begin
   for x:=1 to n do
   read(m1,mas[y,x]);
   readln(m1);
  end;
close(m1);
end;

procedure drawmas;
begin
clrscr;
for yy:=1 to n do
   for xx:=1 to n do
     begin if mas[yy,xx]='8' then putpixel(xx,yy,red);
           if mas[yy,xx]='-' then putpixel(xx,yy,white);
           if mas[yy,xx]='*' then putpixel(xx,yy,green);

     end;
end;

procedure calca;
var xx,yy: integer;
begin
for yy:=1 to n do
   for xx:=1 to n do
     begin if mas[yy,xx]='*' then mas[yy,xx]:='-';

     end;

end;

function checkone(y1: integer; x1: integer): integer;
var coun: integer;
begin
  coun:=0;
  if mas[y1-1,x1  ]<>'-' then coun:=coun+1;
  if mas[y1-1,x1+1]<>'-' then coun:=coun+1;
  if mas[y1  ,x1+1]<>'-' then coun:=coun+1;
  if mas[y1+1,x1+1]<>'-' then coun:=coun+1;
  if mas[y1+1,x1  ]<>'-' then coun:=coun+1;
  if mas[y1+1,x1-1]<>'-' then coun:=coun+1;
  if mas[y1  ,x1-1]<>'-' then coun:=coun+1;
  if mas[y1-1,x1-1]<>'-' then coun:=coun+1;
  if (coun>=2) and (coun<=6) then checkone:=1 else checkone:=0;
end;

function checktwo(y2: integer; x2: integer): integer;
var coun1: integer;
begin
  coun1:=0;
  if (mas[y2-1,x2  ]='-') and (mas[y2-1,x2+1]='8') then coun1:=coun1+1;
  if (mas[y2-1,x2+1]='-') and (mas[y2  ,x2+1]='8') then coun1:=coun1+1;
  if (mas[y2  ,x2+1]='-') and (mas[y2+1,x2+1]='8') then coun1:=coun1+1;
  if (mas[y2+1,x2+1]='-') and (mas[y2+1,x2  ]='8') then coun1:=coun1+1;
  if (mas[y2+1,x2  ]='-') and (mas[y2+1,x2-1]='8') then coun1:=coun1+1;
  if (mas[y2+1,x2-1]='-') and (mas[y2  ,x2-1]='8') then coun1:=coun1+1;
  if (mas[y2  ,x2-1]='-') and (mas[y2-1,x2-1]='8') then coun1:=coun1+1;
  if (mas[y2-1,x2-1]='-') and (mas[y2-1,x2  ]='8') then coun1:=coun1+1;
  if coun1=1 then checktwo:=1 else checktwo:=0;
end;


function checkthr(y3: integer; x3: integer): integer;
var coun2: integer;
begin
  checkthr:=0;
  coun2:=0;

  if(mas[y3-1, x3] <> '-') then
  begin
    if (mas[y3-2,x3  ]='-') and (mas[y3-2,x3+1]='8') then coun2:=coun2+1;
    if (mas[y3-2,x3+1]='-') and (mas[y3-1,x3+1]='8') then coun2:=coun2+1;
    if (mas[y3-1,x3+1]='-') and (mas[y3  ,x3+1]='8') then coun2:=coun2+1;
    if (mas[y3  ,x3+1]='-') and (mas[y3  ,x3  ]='8') then coun2:=coun2+1;
    if (mas[y3  ,x3  ]='-') and (mas[y3  ,x3-1]='8') then coun2:=coun2+1;
    if (mas[y3  ,x3-1]='-') and (mas[y3-1,x3-1]='8') then coun2:=coun2+1;
    if (mas[y3-1,x3-1]='-') and (mas[y3-2,x3-1]='8') then coun2:=coun2+1;
    if (mas[y3-2,x3-1]='-') and (mas[y3-2,x3  ]='8') then coun2:=coun2+1;
  end;
  if (coun2<>1) or ((mas[y3-1,x3]='-') and (mas[y3,x3+1]='-') and (mas[y3,x3-1]='-')) then checkthr:=1;
end;


function checkfor(y4: integer; x4: integer): integer;
var coun3: integer;
begin
  checkfor:=0;
  coun3:=0;
  if(mas[y4, x4 + 1] <> '-') then
  begin
    if (mas[y4-1,x4+1]='-') and (mas[y4-1,x4+2]='8') then coun3:=coun3+1;
    if (mas[y4-1,x4+2]='-') and (mas[y4  ,x4+2]='8') then coun3:=coun3+1;
    if (mas[y4  ,x4+2]='-') and (mas[y4+1,x4+2]='8') then coun3:=coun3+1;
    if (mas[y4+1,x4+2]='-') and (mas[y4+1,x4+1]='8') then coun3:=coun3+1;
    if (mas[y4+1,x4+1]='-') and (mas[y4+1,x4  ]='8') then coun3:=coun3+1;
    if (mas[y4+1,x4  ]='-') and (mas[y4  ,x4  ]='8') then coun3:=coun3+1;
    if (mas[y4  ,x4  ]='-') and (mas[y4-1,x4  ]='8') then coun3:=coun3+1;
    if (mas[y4-1,x4  ]='-') and (mas[y4-1,x4+1]='8') then coun3:=coun3+1;
  end;
  if (coun3<>1) or ((mas[y4-1,x4]='-') and (mas[y4,x4+1]='-') and (mas[y4+1,x4]='-')) then checkfor:=1;
end;

procedure checkf(y0: integer; x0: integer);
var f1,f2,f3,f4: integer;
begin
  f1:=checkone(y0,x0);
  f2:=checktwo(y0,x0);
  f3:=checkthr(y0,x0);
  f4:=checkfor(y0,x0);
  if (f1=1) and (f2=1) and (f3=1) and (f4=1) then
  begin
    mas[y0,x0]:='*';
  end;
end;


begin
clrscr;
makmas;

Gd := Detect;
InitGraph(Gd, Gm, '');
if GraphResult <> grOk then
  Halt(1);

drawmas;
readln;
   a:=2; b:=2; c:=n-2; d:=n-2; e:=1;
for i:=1 to 15 do
 begin
    for y:=a to c do
     begin
      for x:=b to d do
       if mas[y,x]='8' then checkf(y,x);
     end;

 drawmas;
 calca;
 delay(200);

end;

drawmas;
Readln;
CloseGraph;
end.

Добавлено через 2 минуты и 18 секунд
Это я реализовал алгоритм Хилдича. Картинка берется из внешнего файла. Файл текстовый. Там матрица n*n.
Только корявенько работает все же.
Пример файла 20*20

Код


--------------------
--------------------
--------------------
--------------------
---8888888888-------
---8888888888-------
---8888888888-------
---88--88888--------
----8--8888---------
-------888----------
-------888----------
-------888----------
---8888888----------
---88888888---------
---88--888888-------
---88--888888-------
---8888888-8888-----
---8888888--888-----
--------------------
--------------------

Agnazar

Дата 25.5.2008, 10:02 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 9
Регистрация: 25.11.2007

Репутация: нет
Всего: нет

Привожу два отлично работающих алгоритма
Первый(реализована идея из книги Павлидиса):

Код


program gafar;
uses crt,graph, F_mouse;
const bk=black;
var a,gm, gd, er: integer;
    symus: char;


 procedure check(i,j: integer; var sign: boolean);
   var p: array[0..7] of integer;
     begin

      p[0]:=getpixel(i  ,j-1);
      p[1]:=getpixel(i+1,j-1);
      p[2]:=getpixel(i+1,j  );
      p[3]:=getpixel(i+1,j+1);
      p[4]:=getpixel(i  ,j+1);
      p[5]:=getpixel(i-1,j+1);
      p[6]:=getpixel(i-1,j  );
      p[7]:=getpixel(i-1,j-1);

       {Checking linking}
      if (p[7]<>bk)and(p[6]=bk)and(p[0]=bk) then exit;
      if (p[5]<>bk)and(p[6]=bk)and(p[4]=bk) then exit;
      if (p[1]<>bk)and(p[0]=bk)and(p[2]=bk) then exit;
      if (p[3]<>bk)and(p[4]=bk)and(p[2]=bk) then exit;


       {Checking root}
      if p[6]<>bk then if (p[7]=bk)and(p[0]=bk)and(p[4]=bk)and(p[5]=bk) then exit;
      if p[0]<>bk then if (p[7]=bk)and(p[6]=bk)and(p[2]=bk)and(p[1]=bk) then exit;
      if p[4]<>bk then if (p[5]=bk)and(p[6]=bk)and(p[2]=bk)and(p[3]=bk) then exit;
      if p[2]<>bk then if (p[0]=bk)and(p[4]=bk)and(p[1]=bk)and(p[3]=bk) then exit;


      putpixel(i,j,bk);
      sign:=true;
     end;

 procedure Tracing;
 var sign:boolean;
 x,y,met:integer;
 begin
      HideMouse;
      setviewport(80,80,260,260,true);

      met:=5;
      repeat
       sign:=false;
       met:=met+1;
       y:=met;
        repeat
         y:=y+1;
         x:=met;
         repeat
          x:=x+1;
          if (getpixel(x,y)<>bk)and
             ((getpixel(x-1,y)=bk)or(getpixel(x+1,y)=bk)) then
              begin
               check(x,y,sign);
               x:=x+1;
              end;
         until x=260-80-met;
        until y=260-60-met;
       x:=met;
        repeat
         x:=x+1;
         y:=met;
          repeat
           y:=y+1;
           if (getpixel(x,y)<>bk)and
              ((getpixel(x,y-1)=bk)or(getpixel(x,y+1)=bk) )then
                begin
                 check(x,y,sign);
                 y:=y+1;
                end;
          until y=260-60-met;
        until x=260-80-met;
      until sign=false;
      ShowMouse;
      delay(300);
 end;

 procedure drawingpili;
  begin
   setbkcolor(black);
   ClearDevice;
   setcolor(Yellow);
   settextstyle(0,horizdir,1);
   outtextxy(120,20,'Program was made by Trefilov Aleksey, 3-36-1 gr.');
   setcolor(white);
   settextstyle(0,horizdir,20);
   outtextxy(100,100,symus);
   outtextxy(420,100,symus);
   setcolor(blue);
   rectangle(80,80,260,280);
   rectangle(77,77,263,283);
   setcolor(red);
   rectangle(400,80,580,280);
   rectangle(397,77,583,283);
   setcolor(white);
  end;


  procedure nalozh;
   var xx,yy: integer;
   begin
    HideMouse;
    setviewport(0,0,getmaxx,getmaxy,true);
    for yy:=100 to 270 do
      for xx:=100 to 240 do
        if getpixel(xx,yy)<>bk then
            begin putpixel(xx+320,yy,magenta); a:=1; end;
    ShowMouse;
   end;

  procedure drawbut;
   var buX, buY: integer;
        ch: char;
   begin
     ch:='A';
     for buY:=0 to 1 do
      for buX:=0 to 9 do
        begin
          setcolor(green);
          rectangle(40+buX*60,320+buy*60,80+buX*60,360+buy*60);
          setcolor(cyan);
          settextstyle(0,horizdir,3);
          outtextXY(50+buX*60,330+buy*60,ch);
          inc(ch);
        end;

   end;

  procedure mousecont;
   var xm,ym,k,buX,buY:Integer;
       ch: char;
   begin
    repeat
     getMouseState(k,xm,ym);
     if (k=1) and (LeftButton<>0) and (MouseIn(80,80,260,260)=true)then Tracing;
     if (k=1) and (LeftButton<>0) and (MouseIn(400,80,580,260)=true)then Nalozh;

      for buY:=0 to 1 do
       for buX:=0 to 9 do
        begin
         if (k=1)
          and (LeftButton<>0)
           and (MouseIn(40+buX*60,320+buy*60,80+buX*60,360+buy*60)=true)then
             begin
              ch:=chr(65+buy*10+buX);
              symus:=ch;
              drawingpili;
              drawbut;
              mousecont;
             end;
        end;
    until KeyPressed;
   end;



begin
gd:=detect; a:=0;
initgraph(gd,gm,'');
er:=graphresult;
if er=grok then

  begin
   InitMouse;
   ShowMouse;
   symus:='A';
   drawingpili;
   drawbut;
   mousecont;
  end;
  closegraph;

end.

В общем тут моя прога... с мышкой. Щелкаем по левому окошку - прореживает изображение, по правому - накладывает скелет на исходное. Выбор символа осуществляется из палитры снизу. Ну это в общем демонстративная прога такая =) Пользуйтесь!

Добавлено через 4 минуты и 25 секунд
А вот еще один нашел... Методом лесного пожара. Оч компактный код)

Код


Program Sceleton;
Uses CRT, Graph, QUEUE;
Const  n = 200;                                               {  n - размеры изображения   }
           c0 = 0;           {  цвет фона }
           c1 = 15;         {  цвет объекта }
           c2 = 7;           {  цвет закраски объекта при движении волны }
           c3 = 8;           {  цвет выделенного скелета }
           z: Array[1..2, 0..3] Of Integer=((-1, 0, 1, 0),     x}    { матрица смещений }
                                                               ( 0,-1, 0, 1));    y}
Var h1, h2 :u;                       { начало и конец очереди }
        x, y, d :Integer;             { рабочие переменные }
{$I GrInit}

Function Poisk (Var x, y, d :Integer) :Boolean;   {Ф-я поиска нач. точки контура}
{ При вызове ф-ции x,y – координаты начала поиска.
 Если точка контура найдена, ф-ция возвращает:
         TRUE,
         x,y – координаты точки контура,
        d=0, если   это точка внешнего контура;
        d=1, если   это точка внутреннего контура.
  Иначе - FALSE. }
Var a, b, i :Integer;
Begin  
 Poisk := True;
 For b := y To n-2 Do               {Циклы 
    For a:=x To n-2 Do                      сканирования изображения }
      If GetPixel (a, b) = c1 Then            {Если найдена точка объекта, 
         For i := 0 To 1 Do                           то просматриваем пред. и посл. точки.
            If GetPixel (a+z[1, 2*i], b+z[2, 2*i]) = c0  Если точка контура найдена, 
               Then  Begin x := a;   y := b;   d := i;   Exit;    End;          вывод рез-тов }
 Poisk := False;          {   Больше новых контурных точек на изображении нет }
End;

Procedure Kontur ( xn, yn, d :Integer);              {Прохождение контура фигуры}
Var   x, y, a, b :Integer;
Begin
  x := xn;    y := yn;                                                {    Начинаем с точки (xn,yn)   }
 Repeat                                                      { Цикл прохождения контура фигуры}
    Repeat                                 { Цикл просмотра окрестности точки контура }
        d := (d+1) Mod 4;             {Вычисление  направления на следующего соседа
        a := x + z[1, d];     b := y + z[2, d];                                           и его координат }
    Until GetPixel (a, b) < > c0;      { Если это точка контура, то выход из цикла }
     x := a;    y := b;        { Координаты конт. точки становятся текущими }
     PushQ (h1, h2, a, b);                                                       { Занесение их в очередь }
     PutPixel (x, y, c2);                              {Закраска конт. точки на изображении }
     d := (d + 2) Mod 4;        { Формир-е направления на поиск след. конт. точки }
 Until (x = xn) And (y = yn);      {При достижении нач. точки контура – выход }
End;

Procedure Scelet;                        { Выделение скелета }
Var    i, a, b, p, x, y  :Integer;
Begin
 Repeat                                { Цикл распространения волны }
     PopQ (h1, x, y);                    { Взяли текущ.  точку фронта волны из очереди }
     p := 0;                           { p -  признак нахождения след. точки фронта волны }
     For i:=0 To 3 Do Begin                                     { Цикл просмотра 4-х соседей }
            a := x + z[1, i];   b := y + z[2, i];               {Вычисление координат соседа}
            If GetPixel (a, b) = c1 Then Begin         {Если сосед не помечен,
                  PushQ (h1, h2, a, b);                            запись  его координат в очередь, 
                  PutPixel (a, b, c2);                                   пометка  и
                  p := 1;                                                                установка признака  }
            End;
     End;
     If p = 0 Then PutPixel (x, y, c3);  { Закраска  точки скелета на изображении }
  Until EmptyQ ( h1 );                                   { Выход из цикла, если очередь пуста }
End;

Begin
  GrInit;                                                             { Вывод 
  SetTextJustify(CenterText, CenterText);                      изображения
  SetTextStyle(0,0,18);  OutTextXY(100,100,'E');                          на экран }
  h1 := Nil;    h2 := Nil;                                                     { Вначале очередь пуста }
  x := 1; y := 1;           {Уст-ка начальных координат поиска контурной. точки }
  While Poisk (x, y, d) Do  Kontur (x, y, d);          {  Выделение контура объекта }
  Scelet;                                                                   {  Выделение скелета  объекта }
  ReadKey;      CloseGraph;
End.

Это сообщение отредактировал(а) Agnazar - 25.5.2008, 10:04

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Object Pascal: кроссплатформенные технологии \| Следующая тема »