a very very basic contour finder :)

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
Muttonhead
Posts: 130
Joined: May 28, 2009 20:07

a very very basic contour finder :)

Postby Muttonhead » Jul 02, 2015 20:23

inspired by some threads...

Code: Select all

type vector
  x as single
  y as single
end type

declare function FindNext (source as vector, byref dest as vector) as integer

screenres 640,480,32

dim shared as integer scrw,scrh
screeninfo scrw,scrh

dim shared as uinteger background,border,foundcolor,pixel,prevpixel,nextpixel
background=&HFFFFFFFF
border=&HFFFF0000
foundcolor=&HFF008800
dim shared as vector destoffsets(7)
destoffsets(0).x=0
destoffsets(0).y=-1
destoffsets(1).x=1
destoffsets(1).y=-1
destoffsets(2).x=1
destoffsets(2).y=0
destoffsets(3).x=1
destoffsets(3).y=1
destoffsets(4).x=0
destoffsets(4).y=1
destoffsets(5).x=-1
destoffsets(5).y=1
destoffsets(6).x=-1
destoffsets(6).y=0
destoffsets(7).x=-1
destoffsets(7).y=-1

dim shared as uinteger destcolors(7)

'1.***
bload "horse.bmp"
locate(1,1)
print "original shape... press key"
sleep

'2.***
for y as integer=0 to 599
  for x as integer=0 to 799
    if x>0 then prevpixel=point(x-1,y) else prevpixel=background
    if x<799 then nextpixel=point(x+1,y) else nextpixel=background
    pixel=point(x,y)
    if prevpixel=background or nextpixel=background then
      if pixel<>background then pset(x,y),border
    end if
  next x
next y
for x as integer=0 to 799
  for y as integer=0 to 599
    if x>0 then prevpixel=point(x,y-1) else prevpixel=background
    if x<799 then nextpixel=point(x,y+1) else nextpixel=background
    pixel=point(x,y)
    if prevpixel=background or nextpixel=background then
      if pixel<>background then pset(x,y),border
    end if
  next y
next x

locate(1,1)
print "highlight outer pixel of shape... press key"
sleep



'3.***
dim as integer exitloop,findstatus,direction
dim as vector startpos,nextpos
direction=0
startpos.x=96
startpos.y=120

exitloop=0
do
  sleep 10
  pset(startpos.x,startpos.y),foundcolor
  locate (1,1)
  print startpos.x,startpos.y,"tracing the line"
  findstatus=FindNext (startpos,nextpos)
  if findstatus>-1 then
    swap startpos,nextpos
  else
    exitloop=1
  end if

loop until exitloop
beep

'******************************************************************************
'******************************************************************************
'******************************************************************************
function FindNext (source as vector, byref dest as vector) as integer
  dim as vector tmp
  dim as integer count,found,startsearch
  for i as integer=0 to 7
    tmp.x=source.x + destoffsets(i).x
    tmp.y=source.y + destoffsets(i).y
    if (tmp.x>=0) and (tmp.x<scrw) and (tmp.y>=0) and (tmp.y<scrh) then
      destcolors(i)=point(tmp.x,tmp.y)
      if destcolors(i)=background then startsearch=i
    else
      destcolors(i)=background
    end if
  next i

  count=startsearch
  found=-1
  do
    count = (count+1) mod 8
    if destcolors(count)=border then
      found=count
      dest.x=source.x + destoffsets(count).x
      dest.y=source.y + destoffsets(count).y
    end if
  loop until (found>-1) or (count=startsearch)
  function=found
end function


and the horse:

Image

Muttonhead
Tourist Trap
Posts: 2880
Joined: Jun 02, 2015 16:24

Re: a very very basic contour finder :)

Postby Tourist Trap » Jul 02, 2015 20:59

Impressive, it finds also capshole contours (i've tried with an other picture). But I fail to figure out how it works..
dodicat
Posts: 6547
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: a very very basic contour finder :)

Postby dodicat » Jul 03, 2015 0:17

Yea nice Muttonhead.

Here's an alternative, just outline the horse.

Code: Select all

Function Filter(Byref tim As Uinteger Pointer,_
    byval rad As Single,_
    byval destroy As Integer=1,_
    byval fade As Integer=0) As Uinteger Pointer
    #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
    If fade<0 Then fade=0:If fade>100 Then fade=100
    Type p2
        As Integer x,y
        As Uinteger col
    End Type
    #macro ppoint(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    (colour)=*pixel
    #endmacro
    #macro ppset(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    *pixel=(colour)
    #endmacro
    #macro average()
    ar=0:ag=0:ab=0:inc=0
    xmin=x:If xmin>rad Then xmin=rad
    xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
    ymin=y:If ymin>rad Then ymin=rad
    ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
    For y1 As Integer=-ymin To ymax
        For x1 As Integer=-xmin To xmax
            inc=inc+1
            ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
            ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
            ab=ab+(NewPoints(x+x1,y+y1).col And 255)
        Next x1
    Next y1
    If fade=0 Then
        averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
    Else
        averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
    End If
    #endmacro
    Dim As Single fd=map(0,100,fade,1,0)
    Dim As Integer _x,_y
    Imageinfo tim,_x,_y
    Dim  As Uinteger Pointer im=Imagecreate(_x,_y)
    Dim As Integer pitch
    Dim  As Any Pointer row
    Dim As Uinteger Pointer pixel
    Dim As Uinteger col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As Integer=0 To (_y)-1
        For x As Integer=0 To (_x)-1
            ppoint(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Uinteger averagecolour
    Dim As Integer ar,ag,ab
    Dim As Integer xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As Integer=0 To _y-1
        For x As Integer=0 To _x-1 
            average()
            ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
        Next x
    Next y
    If destroy Then Imagedestroy tim: tim = 0
    Function= im
End Function

Sub GetSize(bmp As String,byref x as integer,byref y as integer,byref b as integer=0) 'get bitmap width/height/ colour resolution
    Open bmp For Binary access read As #1
    Get #1, 19, X
    Get #1, 23, Y
    get #1, 29, b
    Close #1
End sub

'=========================================
screen 19,32
dim as integer w,h
'step 1 get the bitmap dimensions
GetSize("horse.bmp",w,h)

dim as any ptr im=imagecreate(w,h)
'Step 2
'load bitmap to image
bload "horse.bmp",im
'Step 3
'filter image (Blur to one pixel thick)
im=filter(im,1)
put(0,0),im,pset
draw string(20,500),"Press a key"
sleep

color ,rgb(255,255,255)
cls
'Step 4
'pset (or perhaps save), what is not black or white.
for y as integer=0 to h-1
    for x as integer=0 to w-1
        var p=point(x,y,im)
        if p<>rgb(255,255,255) and p<>rgb(0,0,0) then pset(x,y),rgb(0,0,0)
    next x
next y
draw string(20,500),"Done",0
sleep
imagedestroy im
 
BasicCoder2
Posts: 3558
Joined: Jan 01, 2009 7:03
Location: Australia

Re: a very very basic contour finder :)

Postby BasicCoder2 » Jul 03, 2015 3:34

Code: Select all

screenres 640,480,32

dim as any ptr horse,temp
horse = imagecreate(640,480)
temp  = imagecreate(640,480)
bload "horse.bmp",horse
bload "horse.bmp",temp
put (0,0),horse,pset            'place on display
put (1,0),horse,xor             'xor x shifted version onto display
put temp,(0,1),horse,xor    'xor  y shifted version onto temp
put (0,0),temp,or               'or shifted versions together onto display

sleep


Of course the original reason to traverse a blob was to reduce the data set OR for contour analysis which would output not the outline of the horse but rather that is was a horse and not a rabbit or some other silhouette.
Muttonhead
Posts: 130
Joined: May 28, 2009 20:07

Re: a very very basic contour finder :)

Postby Muttonhead » Jul 03, 2015 12:00

second trial:

a black shape and a bug on the waltz, no inner outline nor outer inline

Code: Select all

#include "fbgfx.bi"

'some types
type vector
  x as single
  y as single
end type


type crawldata
  searchstate   as integer'0=stop searching, 1=search for firstpos, 2= search newpos in contour
  foundnew      as integer'0 no newpos, 1 found newpos
  incontour     as integer'is 1 when currentpos is in the contour
  currentpos    as vector 'its the current position of the crawler
  newpos        as vector 'new position for search shape / of the contour / current position when stop

  firstpos      as vector 'contains the first discovered position of the contour, entrypoint in contour, check when contour is closed
end type

type ContourCrawler
  private:
  'positions of surrounding pixels
  'screen coordinate system
  '  7 0 1
  '
  '  6 x 2   x=current position
  '
  '  5 4 3 
  viewoffset(7) as vector'contains the position offsets of all 8 surrounding pixels
  scolor        as uinteger'shape color
  ccolor        as uinteger'contour color
  bcolor        as uinteger'background color
  cd            as crawldata 
  initpos       as vector
  initdir       as integer
  scrwidth      as integer
  scrheight     as integer
  public:
  declare constructor
  declare function crawl (currentpos as vector) as crawldata
  declare sub InitCrawler(shapecolor as uinteger, contourcolor as uinteger, backgroundcolor as uinteger, direction as integer=2)
end type

constructor ContourCrawler
  viewoffset(0).x=0
  viewoffset(0).y=-1
  viewoffset(1).x=1
  viewoffset(1).y=-1
  viewoffset(2).x=1
  viewoffset(2).y=0
  viewoffset(3).x=1
  viewoffset(3).y=1
  viewoffset(4).x=0
  viewoffset(4).y=1
  viewoffset(5).x=-1
  viewoffset(5).y=1
  viewoffset(6).x=-1
  viewoffset(6).y=0
  viewoffset(7).x=-1
  viewoffset(7).y=-1
  scolor=&H000000
  ccolor=&H00AA00
  bcolor=&HFFFFFF
  initpos.x=0
  initpos.y=0
  initdir=0
  cd.searchstate=0
  cd.foundnew=0
  cd.incontour=0
  cd.newpos.x=0
  cd.newpos.y=0
  cd.newpos.x=-1
  cd.newpos.y=-1
  cd.firstpos.x=-1
  cd.firstpos.y=-1
  screeninfo scrwidth,scrheight
end constructor


function ContourCrawler.crawl(currentpos as vector) as crawldata
  dim as uinteger currentcolor,tmpcolor
  dim as vector tmppos
  dim as integer found,search
  cd.currentpos=currentpos
  currentcolor=point(cd.currentpos.x,cd.currentpos.y) and &HFFFFFF
 
  select case currentcolor
    case bcolor
      cd.searchstate=1'searching for first contact
      cd.foundnew=0'a contour point was not found
      cd.incontour=0'we're not in a shape   
      cd.newpos.x=cd.currentpos.x + viewoffset(initdir).x'set new search position
      cd.newpos.y=cd.currentpos.y + viewoffset(initdir).y

  case scolor
    'next stuff happens only while first contact
    if cd.searchstate=1 then
      cd.foundnew=1'a contour point was found   
      cd.searchstate=2          'set to contoursearch mode
      cd.firstpos=cd.currentpos 'save firstpos of contour
      cd.incontour=1            'we're in a shape   
    end if

    'search for a point outside of the shape
    search=-1
    do
      search+=1
      tmppos.x=cd.currentpos.x + viewoffset(search).x
      tmppos.y=cd.currentpos.y + viewoffset(search).y
      if (tmppos.x>=0) and (tmppos.x<scrwidth) and (tmppos.y>=0) and (tmppos.y<scrheight) then _
        tmpcolor=(point(tmppos.x,tmppos.y) and &HFFFFFF)       
    loop until tmpcolor=bcolor
   
    'search clockwise for a pixel inside of the shape
    found=-1
    do
      search = (search+1) mod 8
      tmppos.x=cd.currentpos.x + viewoffset(search).x
      tmppos.y=cd.currentpos.y + viewoffset(search).y     
      if (tmppos.x>=0) and (tmppos.x<scrwidth) and (tmppos.y>=0) and (tmppos.y<scrheight) then _
        tmpcolor=(point(tmppos.x,tmppos.y) and &HFFFFFF)
    loop until (tmpcolor=scolor) or (tmpcolor=ccolor)
   
    if (tmppos.x<>cd.firstpos.x) or (tmppos.y<>cd.firstpos.y) then
      cd.newpos=tmppos
      cd.searchstate=2'search contour
      cd.foundnew=1'a contour point was found
      cd.incontour=1'we're in a shape     
    else
      cd.newpos=cd.currentpos
      cd.searchstate=0'stop search
      cd.foundnew=0'a contour point was not found
      cd.incontour=1'we're in a shape   
    end if
  end select
  function=cd
end function


sub ContourCrawler.InitCrawler (shapecolor as uinteger, contourcolor as uinteger, backgroundcolor as uinteger, direction as integer=2)
  scolor=shapecolor
  ccolor=contourcolor
  bcolor=backgroundcolor
  initdir=direction
end sub

'******************************************************************************
'******************************************************************************
'******************************************************************************

screenres 800,600,32

dim as ContourCrawler crawl

dim as FB.Image ptr horse=imagecreate(640,480)
bload "horse.bmp",horse
dim as uinteger scol,ccol,bcol
scol=&H000000'shape color
ccol=&HFF0000'contour color
bcol=&HFFFFFF'background color
dim as vector anypos
anypos.x=40
anypos.y=260

put(30,30),horse,PSET
crawl.InitCrawler scol,ccol,bcol,2'2 means search in right direction

dim as crawldata dat

do
  dat=crawl.crawl(anypos)
  if dat.incontour then
    pset(anypos.x, anypos.y),ccol
    locate (1,1)
    print anypos.x,anypos.y
  end if 
  anypos=dat.newpos
 sleep 5
loop until dat.searchstate=0
beep

sleep
imagedestroy horse


Mutton
BasicCoder2
Posts: 3558
Joined: Jan 01, 2009 7:03
Location: Australia

Re: a very very basic contour finder :)

Postby BasicCoder2 » Jul 03, 2015 13:42

When testing an algorithm it is wise to try it on lots of random examples to see if there are any problems.

Code: Select all

screenres 800,600,32

dim as ContourCrawler crawl

dim as FB.Image ptr horse=imagecreate(640,480)
line horse,(0,0)-(639,479),rgb(255,255,255),bf
line horse,(143,83)-(293,231),rgb(0,0,0),bf
line horse,(294,232)-(455,370),rgb(0,0,0),bf
'bload "horse.bmp",horse
Muttonhead
Posts: 130
Joined: May 28, 2009 20:07

Re: a very very basic contour finder :)

Postby Muttonhead » Jul 03, 2015 14:25

hey, its in progress. there are some known problems, other problems will appear. Its an approach, nothing more :)
Last but not least, it depends on the requirements.

to your example: what is it? one or two closed shapes.

Mutton
Roland Chastain
Posts: 859
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: a very very basic contour finder :)

Postby Roland Chastain » Jul 03, 2015 14:42

Very nice, Muttonhead.

I like guys when you use french words: contour, silhouette...
Muttonhead
Posts: 130
Joined: May 28, 2009 20:07

Re: a very very basic contour finder :)

Postby Muttonhead » Jul 10, 2015 18:24

final

Code: Select all

#include "fbgfx.bi"

'some types
type vector
  x as single
  y as single
end type


type crawlmessage
  searchstate   as integer'0=stop searching, 1=search for firstpos, 2= search newpos in contour
  incontour     as integer'is 1 when currentpos is in the contour
   
  firstpos      as vector 'first discovered position of the contour, reference for contour close check
  prepos        as vector 'predecessor
  currentpos    as vector 'current position of the crawler
  newpos        as vector 'new found point in contour

end type

type ContourCrawler
  private:
  'positions of surrounding pixels
  'clock wise
  '  7 0 1
  '  6 x 2  x=current position
  '  5 4 3
  '
  'look up table for all 8 surrounding pixels
  offset(7)  as vector'contains the position offsets of all 8 surrounding pixels clockwise

  'short time color memory
  colormem(7)   as uinteger'contains the colors of surrounding pixels
 
  'colors
  c_color       as uinteger'contour color
  ch_color      as uinteger'contour color hightlighted
  b_color       as uinteger'background color
 
  'states
  searchstate   as integer'0=stop searching, 1=search for firstpos, 2= search newpos in contour
  incontour     as integer'is 1 when currentpos is in the contour
 
  'directions
  predir        as integer'direction of predecessor seen from current positition
  newdir        as integer'direction of new found contour position seen from current positition
  olddir        as integer'newdir of previous crawl "old newdir" ;)

  'positions
  firstpos      as vector 'first discovered position of the contour, reference for contour close check
  preprepos     as vector 'pre-predecessor
  prepos        as vector 'predecessor
  currentpos    as vector 'current position of the crawler
  newpos        as vector 'new found point in contour
 
  'init stuff
  initdir       as integer
  scrwidth      as integer
  scrheight     as integer
  public:
  declare constructor
  declare function crawl (currentpos as vector) as crawlmessage
  declare sub InitCrawler(contourcolor as uinteger, conturhighlightcolor as uinteger, backgroundcolor as uinteger, direction as integer=2)
end type

constructor ContourCrawler
  offset(0).x=0
  offset(0).y=-1
  offset(1).x=1
  offset(1).y=-1
  offset(2).x=1
  offset(2).y=0
  offset(3).x=1
  offset(3).y=1
  offset(4).x=0
  offset(4).y=1
  offset(5).x=-1
  offset(5).y=1
  offset(6).x=-1
  offset(6).y=0
  offset(7).x=-1
  offset(7).y=-1

  c_color=&H000000
  ch_color=&H00AA00
  b_color=&HFFFFFF
  initdir=0
  searchstate=0
  incontour=0
  firstpos.x=-1
  firstpos.y=-1
  preprepos.x=-1
  preprepos.y=-1
  prepos.x=-1
  prepos.y=-1
  currentpos.x=-1
  currentpos.y=-1
  newpos.x=-1
  newpos.y=-1
  screeninfo scrwidth,scrheight
end constructor


function ContourCrawler.crawl(currentpos as vector) as crawlmessage
  dim as integer found,counter,tmpdir,gapsize
  dim as uinteger currentcolor,tmpcolor
  dim as vector tmppos
  dim as crawlmessage cm

  currentpos=currentpos
  currentcolor=point(currentpos.x,currentpos.y) and &HFFFFFF

  select case currentcolor
   
    case b_color  ' we're outside of a contour

      searchstate=1'searching for first contact
      incontour=0'we're not in a contour
      newpos.x=currentpos.x + offset(initdir).x'set new search position
      newpos.y=currentpos.y + offset(initdir).y

    case c_color,ch_color' we're on a contour, its the first contact or we are in searching contour mode

'Step 0:
      'next stuff happens only on first entry in a contour
      if searchstate=1 then
        incontour=1        'we're in a contour !!!!!!!
        searchstate=2      'set to contour search mode
        firstpos=currentpos'save firstpos of contour
      end if
 
'Step 1:
      'copy all colors of the surrounding pixels of current point in colormem
      for i as integer=0 to 7
        tmppos.x=currentpos.x + offset(i).x
        tmppos.y=currentpos.y + offset(i).y
        if (tmppos.x>=0) and (tmppos.x<scrwidth) and (tmppos.y>=0) and (tmppos.y<scrheight) then
         
          'to prevent problems that can occure when pre-predecessor position is set in colormem we change it to background
          'its no loss on information cause this position was detected before as contour point
          if (tmppos.x=preprepos.x) and (tmppos.y=preprepos.y) then
            colormem(i)=b_color
          else
            colormem(i)=(point(tmppos.x,tmppos.y) and &HFFFFFF)
          end if

        else
          colormem(i)=b_color
        end if
      next i
     
'Step 2:
      'direction of prepos seen from currentpos, start position for searching new contour point
      predir=0
      for i as integer=0 to 7
        tmppos.x=currentpos.x + offset(i).x
        tmppos.y=currentpos.y + offset(i).y
        if (tmppos.x=prepos.x) and (tmppos.y=prepos.y) then predir=i
      next i

'Step 3:
      'search clockwise(!!!) for a point outside of contour
      found=0
      counter=0
      gapsize=0
      for i as integer=1 to 7
        counter= (predir+i) mod 8
        if i=1 then
          if  colormem(counter)=b_color then found=1 else found=2
        else
          if  colormem(counter)<>b_color then found=2
        end if

        if found=1 then gapsize +=1
      next i

'Step 4:
      'optimize stuff ??

'Step 5:
      'final new position
      newdir=(predir + gapsize + 1) mod 8
      tmppos.x=currentpos.x + offset(newdir).x
      tmppos.y=currentpos.y + offset(newdir).y
 
      if (tmppos.x<>firstpos.x) or (tmppos.y<>firstpos.y) then
        newpos=tmppos
        searchstate=2'search contour
        incontour=1'we're in a shape
      else
        newpos=currentpos
        searchstate=0'stop search
        incontour=1'we're in a shape
      end if
     
  end select

  preprepos=prepos
  prepos=currentpos
 
  'prepare message
  cm.searchstate   =searchstate
  cm.incontour     =incontour
  cm.firstpos      =firstpos
  cm.prepos        =prepos
  cm.currentpos    =currentpos
  cm.newpos        =newpos

  'locate (1,1)
  'print currentpos.x,currentpos.y,prepos.x,prepos.y,preprepos.x,preprepos.y
  'print gapsize,predir,newdir
  'sleep 10

  function=cm
end function


sub ContourCrawler.InitCrawler (contourcolor as uinteger, conturhighlightcolor as uinteger, backgroundcolor as uinteger, direction as integer=2)
  c_color=contourcolor
  ch_color=conturhighlightcolor
  b_color=backgroundcolor
  initdir=direction
end sub

'******************************************************************************
'******************************************************************************
'******************************************************************************

screenres 800,600,32

dim as ContourCrawler crawl

dim as FB.Image ptr horse=imagecreate(640,480)
'bload "horse2.bmp",horse

line horse,(0,0)-(639,479),rgb(255,255,255),bf
line horse,(143,83)-(293,231),rgb(0,0,0),bf
line horse,(294,232)-(455,370),rgb(0,0,0),bf

dim as uinteger scol,ccol,bcol
scol=&H000000'shape color
ccol=&HFF0000'contour color highlighted
bcol=&HFFFFFF'background color
dim as vector anypos
anypos.x=35
anypos.y=260

put(30,30),horse,PSET
crawl.InitCrawler scol,ccol,bcol,2'2 means start search to right
dim as crawlmessage msg

do
  msg=crawl.crawl(anypos)
  if msg.incontour then
    pset(anypos.x, anypos.y),ccol
  end if
  anypos=msg.newpos
loop until msg.searchstate=0


imagedestroy horse

'paint (250,120),ccol,ccol'food fill proof test
sleep


Mutton
Tourist Trap
Posts: 2880
Joined: Jun 02, 2015 16:24

Re: a very very basic contour finder :)

Postby Tourist Trap » Jul 10, 2015 18:43

Looks great!

But I obtain only two squares. When editing line 233 to bload the horse, I've also to comment the boxes. And that still wont really work. So how should be the expected image to get the contour from? What background color for example? All of that seems to influe, true?
BasicCoder2
Posts: 3558
Joined: Jan 01, 2009 7:03
Location: Australia

Re: a very very basic contour finder :)

Postby BasicCoder2 » Jul 10, 2015 20:14

Muttonhead wrote:... to your example: what is it? one or two closed shapes.

It is one closed shape as you can see below.
It has to do with how many neighboring pixels you want to consider as being connected to the current pixel.
The code below assumes a background of black while searching for the first pixel in a blob of any color but black.
In other code the whole image can be made up of connected blobs of color and all blob outlines are extracted. In other words blobs within blobs as you would get with the shapes B or O as apposed to the shapes L or T. There are issues like one blob merging with another blob (fbHorse and its base) or one blob breaking into two blobs or even requiring two blobs like the character : and ; and so on..
These outlines could be used to determine what shape the blob is. Is it a square, a circle, a triangle or something complicated like a horse or less complicated like the outline of a character.
The particular purpose in my other post,
viewtopic.php?f=8&t=23705
was simply to enable someone with a silhouette like the horse to have its outline automatically turned into a list of coordinates in a set of data statements. I imagine doing it manually would be tiresome and time consuming. Reducing the actual number of coordinates I thought was also a good idea thus the data reduction challenge.


Code: Select all

'THIS ASSUMES A 480x480 image.
screenres 480,480,32

dim shared as any ptr image1,image2
image1 = imagecreate(480,480) 'blob image with black background
image2 = imagecreate(480,480) 'save image of blob's outline


dim shared as integer xp(10000)  'save contour coordinates
dim shared as integer yp(10000)
dim shared as integer count      'count number of coordinates

sub TraverseBlob(x as integer, y as integer,image2 as any ptr,c as uinteger,image as any ptr)
   
    dim as integer ox,oy,sx,sy,direction,cc

    direction = 0
    ox = x
    oy = y
    sx = x
    sy = y
    cc = point(x,y,image)  'color to draw outline
    xp(count)=x
    yp(count)=y
    count = count + 1
   
    do
 
        select case as const direction

        'EAST
        case 0
        if point(x+1,y-1,image) = c then
            direction = 3 'north
        else
            if point(x+1,y,image) <> c then
                direction = 1 'south
            end if
        end if
        x = x + 1
 
        'SOUTH 
        case 1
        if point(x,y+1,image) = c then
            direction = 0 'east
        else
            if point(x-1,y+1,image) <> c then
                direction = 2 'west
            end if
        end if
        y = y + 1

        'WEST
        case 2
        if point(x-2,y,image) = c then
            direction = 1 'south
        else
            if point(x-2,y-1,image) <> c then
                direction = 3 'north
            end if
        end if
        x = x - 1

        'NORTH
        case 3
            if point(x-1,y-2,image) = c then
                direction = 2 'west
            else
                if point(x,y-2,image) <> c then
                    direction = 0 'east
            end if
        end if
        y = y - 1
        end select

        pset image2,(x,y),rgb(255,255,255)  'draw outline
       
        xp(count)=x
        yp(count)=y
        count = count + 1
       
        ox = x
        oy = y

       
    loop until sx = x and sy = y
   
end sub

'bload "fbHorse.bmp",image1  'replace with this with your own 480x480 image
'bload "blocks1.bmp",image1
line image1,(0,0)-(479,479),rgb(0,0,0),bf
line image1,(70,70)-(200,200),rgb(255,0,0),bf
line image1,(201,201)-(300,300),rgb(255,0,0),bf
line image1,(100,80)-(300,80),rgb(255,0,0)
line image1,(40,301)-(199,388),rgb(255,0,0),bf
put (0,0),image1
locate 2,2
print "tap space bar to continue ..."
sleep

dim as integer blobFound = 0
'scans image array to find blob
for j as integer = 1 to 478
    for i as integer = 1 to 478
        if blobFound = 0 then
            if point(i,j,image1) <> rgb(0,0,0) then
                blobFound = 1
                'traverseBlob (x,y,destination,colorOfBlob,source)
                traverseBlob(i,j,image2,point(i,j,image1),image1)
                cls
                put (0,0), image2 'show outline
            end if
        end if
    next i
next j

print "number of points =";count
if count<>0 then
    for i as integer = 1 to count-1
        line (xp(i-1),yp(i-1))-(xp(i),yp(i)),rgb(255,255,0)
    next i
end if


sleep
Muttonhead
Posts: 130
Joined: May 28, 2009 20:07

Re: a very very basic contour finder :)

Postby Muttonhead » Jul 10, 2015 21:31

you need more than 4 connected pixels:

Code: Select all

#include "fbgfx.bi"

'some types
type vector
  x as single
  y as single
end type


type crawlmessage
  searchstate   as integer'0=stop searching, 1=search for firstpos, 2= search newpos in contour
  incontour     as integer'is 1 when currentpos is in the contour
   
  firstpos      as vector 'first discovered position of the contour, reference for contour close check
  prepos        as vector 'predecessor
  currentpos    as vector 'current position of the crawler
  newpos        as vector 'new found point in contour

end type

type ContourCrawler
  private:
  'positions of surrounding pixels
  'clock wise
  '    0
  '  3 x 1  x=current position
  '    2
  '
  'look up table for all 8 surrounding pixels
  offset(3)  as vector'contains the position offsets of all 8 surrounding pixels clockwise

  'short time color memory
  colormem(3)   as uinteger'contains the colors of surrounding pixels
 
  'colors
  c_color       as uinteger'contour color
  ch_color      as uinteger'contour color hightlighted
  b_color       as uinteger'background color
 
  'states
  searchstate   as integer'0=stop searching, 1=search for firstpos, 2= search newpos in contour
  incontour     as integer'is 1 when currentpos is in the contour
 
  'directions
  predir        as integer'direction of predecessor seen from current positition
  newdir        as integer'direction of new found contour position seen from current positition
  olddir        as integer'newdir of previous crawl "old newdir" ;)

  'positions
  firstpos      as vector 'first discovered position of the contour, reference for contour close check
  preprepos     as vector 'pre-predecessor
  prepos        as vector 'predecessor
  currentpos    as vector 'current position of the crawler
  newpos        as vector 'new found point in contour
 
  'init stuff
  initdir       as integer
  scrwidth      as integer
  scrheight     as integer
  public:
  declare constructor
  declare function crawl (currentpos as vector) as crawlmessage
  declare sub InitCrawler(contourcolor as uinteger, conturhighlightcolor as uinteger, backgroundcolor as uinteger, direction as integer=2)
end type

constructor ContourCrawler
  offset(0).x=0
  offset(0).y=-1
  offset(1).x=1
  offset(1).y=0
  offset(2).x=0
  offset(2).y=1
  offset(3).x=-1
  offset(3).y=0

  c_color=&H000000
  ch_color=&H00AA00
  b_color=&HFFFFFF
  initdir=0
  searchstate=0
  incontour=0
  firstpos.x=-1
  firstpos.y=-1
  preprepos.x=-1
  preprepos.y=-1
  prepos.x=-1
  prepos.y=-1
  currentpos.x=-1
  currentpos.y=-1
  newpos.x=-1
  newpos.y=-1
  screeninfo scrwidth,scrheight
end constructor


function ContourCrawler.crawl(currentpos as vector) as crawlmessage
  dim as integer found,counter,tmpdir,gapsize
  dim as uinteger currentcolor,tmpcolor
  dim as vector tmppos
  dim as crawlmessage cm

  currentpos=currentpos
  currentcolor=point(currentpos.x,currentpos.y) and &HFFFFFF

  select case currentcolor
   
    case b_color  ' we're outside of a contour

      searchstate=1'searching for first contact
      incontour=0'we're not in a contour
      newpos.x=currentpos.x + offset(initdir).x'set new search position
      newpos.y=currentpos.y + offset(initdir).y

    case c_color,ch_color' we're on a contour, its the first contact or we are in searching contour mode

'Step 0:
      'next stuff happens only on first entry in a contour
      if searchstate=1 then
        incontour=1        'we're in a contour !!!!!!!
        searchstate=2      'set to contour search mode
        firstpos=currentpos'save firstpos of contour
      end if
 
'Step 1:
      'copy all colors of the surrounding pixels of current point in colormem
      for i as integer=0 to 3
        tmppos.x=currentpos.x + offset(i).x
        tmppos.y=currentpos.y + offset(i).y
        if (tmppos.x>=0) and (tmppos.x<scrwidth) and (tmppos.y>=0) and (tmppos.y<scrheight) then
         
          'to prevent problems that can occure when pre-predecessor position is set in colormem we change it to background
          'its no loss on information cause this position was detected before as contour point
          if (tmppos.x=preprepos.x) and (tmppos.y=preprepos.y) then
            colormem(i)=b_color
          else
            colormem(i)=(point(tmppos.x,tmppos.y) and &HFFFFFF)
          end if

        else
          colormem(i)=b_color
        end if
      next i
     
'Step 2:
      'direction of prepos seen from currentpos, start position for searching new contour point
      predir=0
      for i as integer=0 to 3
        tmppos.x=currentpos.x + offset(i).x
        tmppos.y=currentpos.y + offset(i).y
        if (tmppos.x=prepos.x) and (tmppos.y=prepos.y) then predir=i
      next i

'Step 3:
      'search clockwise(!!!) for a point outside of contour
      found=0
      counter=0
      gapsize=0
      for i as integer=1 to 3
        counter= (predir+i) mod 4
        if i=1 then
          if  colormem(counter)=b_color then found=1 else found=2
        else
          if  colormem(counter)<>b_color then found=2
        end if

        if found=1 then gapsize +=1
      next i

'Step 4:
      'optimize stuff ??

'Step 5:
      'final new position
      newdir=(predir + gapsize + 1) mod 4
      tmppos.x=currentpos.x + offset(newdir).x
      tmppos.y=currentpos.y + offset(newdir).y
 
      if (tmppos.x<>firstpos.x) or (tmppos.y<>firstpos.y) then
        newpos=tmppos
        searchstate=2'search contour
        incontour=1'we're in a shape
      else
        newpos=currentpos
        searchstate=0'stop search
        incontour=1'we're in a shape
      end if
     
  end select

  preprepos=prepos
  prepos=currentpos
 
  'prepare message
  cm.searchstate   =searchstate
  cm.incontour     =incontour
  cm.firstpos      =firstpos
  cm.prepos        =prepos
  cm.currentpos    =currentpos
  cm.newpos        =newpos

'locate (1,1)
'print currentpos.x,currentpos.y,prepos.x,prepos.y,preprepos.x,preprepos.y
'print gapsize,predir,newdir
'sleep

  function=cm
end function


sub ContourCrawler.InitCrawler (contourcolor as uinteger, conturhighlightcolor as uinteger, backgroundcolor as uinteger, direction as integer=2)
  c_color=contourcolor
  ch_color=conturhighlightcolor
  b_color=backgroundcolor
  initdir=direction
end sub

'******************************************************************************
'******************************************************************************
'******************************************************************************

screenres 800,600,32

dim as ContourCrawler crawl

dim as FB.Image ptr horse=imagecreate(640,480)
'bload "horse.bmp",horse

line horse,(0,0)-(639,479),rgb(255,255,255),bf
line horse,(143,83)-(293,231),rgb(0,0,0),bf
line horse,(294,232)-(455,370),rgb(0,0,0),bf

dim as uinteger scol,ccol,bcol
scol=&H000000'shape color
ccol=&HFF0000'contour color highlighted
bcol=&HFFFFFF'background color
dim as vector anypos
anypos.x=35
anypos.y=260

put(30,30),horse,PSET
crawl.InitCrawler scol,ccol,bcol,1'1 means start search to right
dim as crawlmessage msg

do
  msg=crawl.crawl(anypos)
  if msg.incontour then
    pset(anypos.x, anypos.y),ccol
  end if
  anypos=msg.newpos
loop until msg.searchstate=0


imagedestroy horse
beep
sleep


nearly the same code, with four connected pixels: it dont detect the second square.

but your right, to describe a form in this way, its a lot in information

what about this:
https://en.wikipedia.org/wiki/Marching_squares
sorry if this hint is old, didnt follow the whole stuff

Mutton
BasicCoder2
Posts: 3558
Joined: Jan 01, 2009 7:03
Location: Australia

Re: a very very basic contour finder :)

Postby BasicCoder2 » Jul 10, 2015 23:29

Muttonhead wrote:you need more than 4 connected pixels: ... nearly the same code, with four connected pixels: it don't detect the second square.


If you want all the blobs outlined, connected or not, you need to search the whole image, there are silhouettes that are composed of disconnected blobs and blobs within blobs.

With regards to a computer recognition system I was interested in, when two corners touch like this you may not want to detect them as ONE shape.
Do you see two discs or one "shape" when you run the example below?
The fbHorse is recognized as a horse because you break the blob into blob components like parts of the legs, the head, tail and so on all with constrained spatial relationships.

Code: Select all

screenres 640,480,32

circle (100,100),50,rgb(255,255,255),,,,f
circle (100,199),50,rgb(255,255,255),,,,f

sleep
grindstone
Posts: 726
Joined: May 05, 2015 5:35
Location: Germany

Re: a very very basic contour finder :)

Postby grindstone » Jul 19, 2015 8:24

I took the best (I hope) of all the snippets that have been posted to this subject (especially the outline creation by "blob shifting" I find simply ingenious) and merged them to a contour scanner that can handle shapes with multiple outlines:

Code: Select all

Dim As UInteger w,h,x,y,count
Dim As String shapedata

ScreenRes 640,480,32

Dim As Any Ptr horse,temp,t2
horse = ImageCreate(640,480)
temp  = ImageCreate(640,480)
t2  = ImageCreate(640,480,RGBA(0,0,0,255))
BLoad "horse2.bmp",horse
BLoad "horse2.bmp",temp
Put (0,0),horse,PSet            'place on display
Put (1,0),horse,Xor             'xor x shifted version onto display
Put temp,(0,1),horse,Xor    'xor y shifted version onto temp
Put temp,(0,0),t2,Or         'reset alpha channel
Put (0,0),temp,Or               'or shifted versions together onto display

BSave ExePath + "\horseOutline.bmp",0

BLoad ExePath + "\horseOutline.bmp",temp 'load the outline image
ImageInfo temp,w,h 'get image dimensions
Color RGB(255,255,255)

Cls
Put (0,0),temp,PSet 'draw outline image on screen
Locate 3,40
Print "TRAVERSING"
'create outline data file
Open ExePath + "\oTdata.txt" For Output As #1
Do
    'scan for line starting point from the top to the bottom
    ' and from the left to the right
    For y = 2 To h-1
        For x = 2 To w-1 'scan line
            If POINT (x,y,temp) <> RGBA(0,0,0,255) Then
                Exit For,For 'line found
            EndIf
        Next
    Next
    If (x = w) And (y = h) Then 'no line found => end scanning
        Exit Do
    EndIf
    Print #1,x 'line starting point
    Print #1,y
    Do 'traverse line
        PSet (x,y),RGB(255,0,0) 'set pixel on screen for control
        PSet temp,(x,y),RGBA(0,0,0,255) 'delete scanned pixel
        If POINT (x+1,y,temp) <> RGBA(0,0,0,255) Then 'right
            x += 1
            shapedata += Chr(50)
        ElseIf POINT (x-1,y,temp) <> RGBA(0,0,0,255) Then 'left
            x -= 1
            shapedata += Chr(51)
        ElseIf POINT (x,y+1,temp) <> RGBA(0,0,0,255) Then 'up
            y += 1
            shapedata += Chr(48)
        ElseIf POINT (x,y-1,temp) <> RGBA(0,0,0,255) Then 'down
            y -= 1
            shapedata += Chr(49)
        ElseIf (Point (x+1,y+1,temp) <> RGBA(0,0,0,255)) Then 'right/up
            x += 1
            y += 1
            shapedata += Chr(55)
        ElseIf (Point (x-1,y+1,temp) <> RGBA(0,0,0,255)) Then 'left/up
            x -= 1
            y += 1
            shapedata += Chr(54)
        ElseIf (Point (x+1,y-1,temp) <> RGBA(0,0,0,255)) Then 'left/down
            x += 1
            y -= 1
            shapedata += Chr(53)
        ElseIf (Point (x-1,y-1,temp) <> RGBA(0,0,0,255)) Then 'right/down
            x -= 1
            y -= 1
            shapedata += Chr(52)
        Else 'line ended
            Print #1, shapedata
            shapedata = ""
            Exit Do 'search for next line
        EndIf
        Sleep 1
    Loop
Loop
Close
Locate 3,40
Print "          "

ImageDestroy horse
ImageDestroy temp

'draw image outline from the saved file
Locate 3,40
Print "DRAWING FROM FILE"
Open ExePath + "\oTdata.txt" For Input As #1
Do
    Input #1, x, y 'starting point
    PSet(x,y),RGB(0,255,0)

    Input #1, shapedata
    If Len(shapedata) = 0 Then 'single point
        Continue Do
    EndIf
    For count = 0 To Len(shapedata) - 1
        Select Case shapedata[count] - 48
            Case 0 'down
                y += 1
            Case 1 'up
                y -= 1
            Case 2 'right
                x += 1
            Case 3 'left
                x -= 1
            Case 4 'left/up
                x -= 1
                y -= 1
            Case 5 'right/up
                x += 1
                y -= 1
            Case 6 'left/down
                x -= 1
                y += 1
            Case 7 'right/down
                x += 1
                y += 1
        End Select
        PSet(x,y),RGB(0,255,0)
        Locate 31,40
        Print "^"
        Locate 30,30
        Print Mid(shapedata,count-10,20)
        Sleep 100
    Next
Loop Until Eof(1)
Close

Sleep

horse2.bmp (You see the gap in the bottom line has been closed)
Image

Regards
grindstone
Last edited by grindstone on Jul 19, 2015 10:18, edited 1 time in total.
BasicCoder2
Posts: 3558
Joined: Jan 01, 2009 7:03
Location: Australia

Re: a very very basic contour finder :)

Postby BasicCoder2 » Jul 19, 2015 9:14

grindstone,
For some reason your program displays the outline and then freezes with a red line horizontal line at top of display and the output TRAVERSING but nothing seems to be happening.

I haven't had time to figure out your code yet but I guess you scan for lines instead of blobs and then trace them with another color which would then act as a flag that it has already been traced when the scan hits it again.

Yes I thought I was ingenious when I thought to use shifted bitmaps :)
Try it with any color image and you will get colored outlines.
.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest