Machine Vision

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Machine Vision

Post by BasicCoder2 »

@dodicat
(from viewtopic.php?p=285448#p285448)
Basiccoder2, under your geany picture I note blob stuff, blob area/perimeter, looks interesting, what is it all about?
Machine vision which is one of the things I have been interested in for a long time and have been playing with it again.

I posted this back in 2007.
viewtopic.php?t=8304&
The last time was 2011,
viewtopic.php?f=7&t=17989&
Last edited by BasicCoder2 on Sep 18, 2021 6:59, edited 10 times in total.
TJF
Posts: 3809
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Re: Machine Vision

Post by TJF »

BasicCoder2 wrote:This is one of my experimental robot bases which uses the laptop as its main "brain".
Nice, big brain.

A libpruio user sent me a video about his project:

https://www.youtube.com/watch?v=3cXCUmCWQHQ

That brain is a bit smaller, and - most important - capable of real-time controlling.
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Machine Vision

Post by BasicCoder2 »

@TJF
That utube is dated 2015 some time ago now and it is a bit blurry.
It just looks like a remote controlled robot?

My interest is in autonomous robots that control themselves in real time.
Using the webcam input and the escapi.dll my robot processes images in real time using FreeBASIC code.
The lower level uses the Arduino Mega development board.
Last edited by BasicCoder2 on Sep 18, 2021 6:58, edited 1 time in total.
TJF
Posts: 3809
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Re: Machine Vision

Post by TJF »

BasicCoder2 wrote:That utube is dated 2015 some time ago now and it is a bit blurry.
It just looks like a remote controlled robot?
Indeed, it looks blurry today; I haven't seen it for a while. (It was much better in the beginning.)

Yes, the robot gets controlled by an HTML user interface from a web browser, sending online webcam images via WLAN. The code is in Python.
BasicCoder2 wrote:My interest is in autonomous robots that control themselves in real time.
Using the webcam input and the escapi.dll my robot processes images in real time using FreeBASIC code.
The lower level uses the Arduino Mega development board.
libpruio - coded in FreeBASIC and PASM - is a hardware driver for TI AM335x CPUs, which include one ARMv7 and two PRUSS (programable real-time subsystem) cores. Using BeagleBone hardware, you wont need the Arduino any more. Instead you could do all coding in FreeBASIC. (Of course, the AM335x is 3V3.)
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Machine Vision

Post by dodicat »

Thanks basiccoder2.
Your first link code has a little error, line 200 should be next y, not next i.
If you use polygons to draw shapes then you have great control over them, the area, perimeter, centroid . .
Polygons draw circles, more than about 30 polygon sides to draw a circle shows as a near perfect circle, so blobs and shapes are easily created.
Maybe not much value to you, but the geometry of polygons is pretty easy.
Draw some shapes, try not to cross over sides.
I have commented out circulate (line 183), but that will rectify crossed lines in most cases if used.
For fun:

Code: Select all

#define alphablend 64 
#define OnTop 32

Type Point
      As Double x,y
End Type


Sub DrawCurve(a() As Point,ydisp As Integer=0,col As Ulong)
      Pset(a(Lbound(a)).x,a(Lbound(a)).y+ydisp),col
      For z As Integer=Lbound(a)+1 To Ubound(a)
            Line-(a(z).x,a(z).y+ydisp),col
      Next z
      Line(a(Ubound(a)).x,a(Ubound(a)).y)-(a(Lbound(a)).x,a(Lbound(a)).y),Rgb(50,50,50) 
End Sub

Function polygonarea(p() As Point,Byref perim As Double=0) As Double
      Dim As Double sum
      For i As Long =Lbound(p) To  Ubound(p)
            Var nxt=i+1
            If i=Ubound(p) Then nxt=Lbound(p)
            perim+=Sqr( (p(i).x-p(nxt).x)^2 +(p(i).y-p(nxt).y)^2     )
            sum+=p(i).x*p(nxt).y - p(nxt).x*p(i).y
      Next i
      Return abs(sum/2)
End Function



Sub fill(p() As Point,c As Ulong,im As Any Ptr=0)
      #define ub Ubound
      Dim As Long Sy=1e6,By=-1e6,i,j,y,k
      dim As Single a(Ub(p)+1,1),dx,dy
      For i =0 To Ub(p)
            a(i,0)=p(i).x
            a(i,1)=p(i).y
            If Sy>p(i).y Then Sy=p(i).y
            If By<p(i).y Then By=p(i).y
      Next i
      dim As Single xi(Ub(a,1)),S(Ub(a,1))
      a(Ub(a,1),0) = a(0,0)
      a(Ub(a,1),1) = a(0,1)
      For i=0 To Ub(a,1)-1
            dy=a(i+1,1)-a(i,1)
            dx=a(i+1,0)-a(i,0)
            If dy=0 Then S(i)=1
            If dx=0 Then S(i)=0
            If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
      Next i
      For y=Sy-1 To By+1
            k=0
            For i=0 To Ub(a,1)-1
                  If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
                  (a(i,1)>y Andalso a(i+1,1)<=y) Then
                  xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
                  k+=1
            End If
      Next i
      For j=0 To k-2
            For i=0 To k-2
                  If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
            Next i
      Next j
      For i = 0 To k - 2 Step 2
            Line im,(xi(i)+1,y)-(xi(i+1)+1-1,y),c
      Next i
Next y
End Sub

Sub lineto(x1 As Double,y1 As Double,x2 As Double,y2 As Double,L As Double,Byref ox As Double,Byref oy As Double)
      Var dx=x2-x1,dy=y2-y1
      ox=x1+dx*L
      oy=y1+dy*L
End Sub

sub circulate(p() as point)
 #macro Circlesort() 
 '  bubblesort
For p1 as long  = lbound(p) To ubound(p)-1
    For p2 as long  = p1 + 1 To ubound(p)
        if atan2(p(p1).y-c.y,p(p1).x-c.x)< atan2(p(p2).y-c.y,p(p2).x-c.x) then
            swap p(p1),p(p2)
            end if
         Next p2
    Next p1
 #endmacro
 dim as point C '--centroid of points
 dim as long counter
 for n as long=lbound(p) to ubound(p)
     counter+=1
     c.x+=p(n).x
     c.y+=p(n).y
 next n
 c.x=c.x/counter
 c.y=c.y/counter
 CircleSort()
end sub

Sub circumnavigate(s() As Point,Byref c As Long)
      Dim As Double a,b,t
      #define waitabit for n as long=1 to 1000000:next
      For n As Long=Lbound(s) To Ubound(s)
            a=s(n).x:b=s(n).y
            t=0
            Var nxt=n+1
            If n=Ubound(s) Then nxt=Lbound(s)
            Do
                  Var d=Sqr((a-s(nxt).x)^2+ (b-s(nxt).y)^2)
                  t=1/d
                  lineto(a,b,s(nxt).x,s(nxt).y,t,a,b)
                  c+=1
                  Circle(a,b),1,Rgb(Rnd*255,Rnd*255,Rnd*255),,,,f
                  waitabit
            Loop Until t>=1
      Next n
      c-=(ubound(s)-lbound(s)+1)\2
End Sub
start:
Redim As Point s(0)

Dim As Long xres,yres
Screeninfo xres,yres
Screenres .9*xres,.9*yres,32,,ALPHABLEND Or ONTOP 
Width .9*xres\8,.9*yres\16
windowtitle "Enter points with the mouse, the polygon is self closing, press esc to finish entries"
Dim As Integer mx,my,mb,flag1,counter,flag2
Dim As String key
Screencontrol 100,50,50

Do
      Getmouse mx,my,,mb
      key=Inkey
      
      Screenlock
      Cls
      '================= GRID =======================
      For x As Integer=0 To xres Step 50
            Line(x,0)-(x,yres),Rgba(255,255,255,100)
      Next x
      For y As Integer=0 To yres Step 50
            Line(0,y)-(xres,y),Rgba(255,255,255,100)
      Next y
      
      '============  Text ===========================
      Draw String(xres/3,20),"mouse " & mx &"   " & my
      
      
      '=======  mouse events ================================
      If mb=1 And flag1=0 Then
            flag1=1:counter+=1
            Redim Preserve s(1 To Ubound(s)+1)
            s(Ubound(s))=Type<Point>(mx,my)
      End If
      flag1=mb
      'deletion of points
      If mb=2 And flag2=0 Then
            flag2=1
            If counter>1 Then Redim Preserve s(1 To Ubound(s)-1):counter-=1
            If counter=1 Then Redim s(0):counter=0
      End If
      flag2=mb
      
      '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      '================== draw circles at the points ============
      If Ubound(s) Then Circle(s(1).x,s(1).y),3,,,,,f
      
      '==========  ====================
      If Ubound(s)>2 Then
            Dim As Double ox,oy
            lineto(s(2).x,s(2).y,s(1).x,s(1).y,1,ox,oy)
            lineto(s(Ubound(s)-1).x,s(Ubound(s)-1).y,s(Ubound(s)).x,s(Ubound(s)).y,1,ox,oy)
            
            DrawCurve(s(),,Rgb(200,0,0))
      End If
      For n As Integer=2 To Ubound(s)
            Circle (s(n).x,s(n).y),3,,,,,f
      Next n
      '=================================================
      Screenunlock
      Sleep 1,1
Loop Until key =Chr(27)
'circulate(s()) <---- optional
Cls
Locate 2
Dim As Double perim
Print "Area by formula "; polygonarea(s(),perim)

Redim Preserve s(0 To Ubound(s)-1)'for filler
fill(s(),Rgb(0,100,200))
Dim As Long c
For x As Long=0 To .9*xres
      For y As Long=0 To .9*yres
            If Point(x,y)=Rgb(0,100,200) Then c+=1
      Next y
Next x
Locate 3
Print "Area by pixels  "; c
Print "Perimeter by formula ";perim
Print "Press a key . . ."
Sleep
c=0
circumnavigate(s(),c)

Print "Perimeter by pixels  "; c
Print "Press a key . . ."
Sleep
Screen 0
Width 120,150
Print "type V2"
Print   "As integer x,y"
Print "End Type"
'====================================

Print " "
Print "X_values:"
Print " "
Print "DATA _"
'================

Dim As Integer ctr
For n As Integer=Lbound(s) To Ubound(s)
      ctr+=1
      If n<Ubound(s) Then Print Str(s(n).x);","; Else Print Str(s(n).x);
      If ctr Mod 16 =0 Then Print " _"+Chr(10);
Next n
ctr=0
Print " "
Print " "
Print "Y_values:"
Print " "
Print "DATA _"
For n As Integer=Lbound(s) To Ubound(s)
      ctr+=1
      If n<Ubound(s) Then Print Str(s(n).y);","; Else Print Str(s(n).y);
      If ctr Mod 16 =0 Then Print " _"+Chr(10);
Next n

Dim As Integer numpts=Ubound(s)-Lbound(s)+1

Print " "
Print " "
Print "'Number of points ";Ubound(s)-Lbound(s)+1
Print "screen 20"
Print "dim as v2 p(1 to ";numpts;")"
Print "for n as integer=lbound(p) to ubound(p)"
Print  "read p(n).x"
Print "next n"

Print "for n as integer=lbound(p) to ubound(p)"
Print "read p(n).y"
Print "next n"

Print "for n as integer=lbound(p) to ubound(p)"
Print  "circle(p(n).x,p(n).y),3,,,,,f"
Print "next n"
Print "sleep"
print
print "' these are the shape points to copy and paste if required"
print " ' press any key to continue, esc to end"
var g=input(1)
if asc(g)=27 then end
Sleep
cls
goto start:
End
 
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Machine Vision

Post by BasicCoder2 »

@dodicat
Your first link code has a little error, line 200 should be next y, not next i.
Thanks dodicat.
So no one actually ran the code back in 2007 to pick up the error or if they did they didn't report it!
Last edited by BasicCoder2 on Sep 18, 2021 6:58, edited 1 time in total.
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Machine Vision

Post by BasicCoder2 »

@dodicat
If you use polygons to draw shapes then you have great control over them, the area, perimeter, centroid . .
However it is not about drawing polygons. It is about extracting "blobs" from images for a visual recognition system. Examples in real life are bar codes, QR codes, optical character readers and as in the target example high contrast shapes like number plates, road signs and so on ...
Last edited by BasicCoder2 on Sep 15, 2021 22:44, edited 1 time in total.
marcov
Posts: 3455
Joined: Jun 16, 2005 9:45
Location: Netherlands
Contact:

Re: Machine Vision

Post by marcov »

I've done blobs in the past. Usually first create runs and then match them to form blobs. Typically the runs->blobs is the RDS.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Machine Vision

Post by dodicat »

My first attempt at blobs.

Code: Select all

#include "file.bi"
#define irange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
Type pt  'simulate 3D space
    As Long x,y,z
    As Byte done
    As Long xpos,ypos
End Type

Function closest(clr() As pt,v As Ulong) As Ulong
    Dim As Double res,distance
    #define dist(p1,p2) ((p1.x-p2.x)*(p1.x-p2.x) + (p1.y-p2.y)*(p1.y-p2.y) + (p1.z-p2.z)*(p1.z-p2.z))
    '#define dist(p1,p2) abs(p1.x-p2.x)+abs(p1.y-p2.y) + abs(p1.z-p2.z)
    Dim As pt pv=Type(Cptr(Ubyte Ptr,@v)[2],Cptr(Ubyte Ptr,@v)[1],Cptr(Ubyte Ptr,@v)[0])
    Dim As Double dt=1e15
    For n As Long=Lbound(clr) To Ubound(clr)
        If clr(n).done Then Continue For
        Var distance=dist(clr(n),pv)
        If dt> distance Then dt = distance:res=n 'catch the smallest
        nxt:
    Next n
    Return res
End Function

Sub getgroup(clr() As pt,a() As pt,num As Long,c As Ulong=Rgb(255,255,255))
    Redim a(1 To num)
    Dim As Long e
    For n As Long=1 To num
        e=closest(clr(),c)
        a(n)=clr(e)
        clr(e).done=1
    Next
End Sub

'unused
Function GetBmpSize(bmp As String,Byref w As Long,Byref h As Long) As Long
    Dim As Long f = Freefile()
    If Fileexists(bmp) Then
        Open bmp For Binary As #f
        Get #f, 19,w
        Get #f, 23,h
        Close #f
        Return w*h
    Else
        Print bmp; "  not found ... "
        Return 0
    End If
End Function

Function Filter(Byref tim As Ulong Pointer,_
    rad As Single,_
    destroy As Long=1,_
    fade As Long=0) As Ulong 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 Long x,y
        As Ulong col
    End Type
    #macro ppoint(_x,_y,colour)
    pixel=row+pitch*(_y)+4*(_x)
    (colour)=*pixel
    #endmacro
    #macro ppset(_x,_y,colour)
    pixel=row+pitch*(_y)+4*(_x)
    *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 Long=-ymin To ymax
        For x1 As Long=-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 Long _x,_y
    Imageinfo tim,_x,_y
    Dim  As Ulong Pointer im=Imagecreate(_x,_y)
    Dim As Long pitch
    Dim  As Any Pointer row
    Dim As Ulong Pointer pixel
    Dim As Ulong col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As Long=0 To (_y)-1
        For x As Long=0 To (_x)-1
            ppoint(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Ulong averagecolour
    Dim As Long ar,ag,ab
    Dim As Long xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As Long=0 To _y-1
        For x As Long=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 getcolours(i As Any Ptr, clr() As pt)
    Dim As Long ctr
    Dim As Long x,y
    Imageinfo i,x,y
    Redim clr(1 To x*y)
    For x As Long=0 To 1024-1
        For y As Long=0 To 768-1
            ctr+=1
            Var v=Point(x,y,i)
            clr(ctr)=Type(Cptr(Ubyte Ptr,@v)[2],Cptr(Ubyte Ptr,@v)[1],Cptr(Ubyte Ptr,@v)[0])
            clr(ctr).xpos=x
            clr(ctr).ypos=y
        Next
    Next
End Sub
Dim As String key
Screen 20,32


Do
    Randomize
    Dim As Any Ptr i=Imagecreate(1024,768,Rgb(0,0,0))
    For n As Long=1 To 5000
        Circle i,(irange(10,1000),irange(10,750)),2+Rnd*20,Rgb(Rnd*255,Rnd*255,Rnd*255),,,,f
    Next
    Circle i,(512,768\2),10,Rgb(255,255,255),,,,f
    Print "Filtering image . . ."
    i=filter(i,10)
    Put(0,0),i,Pset
    
    Redim As pt clr()
    Redim As pt a()
    getcolours(i,clr())
    Print "getting blobs (700 points) . . ."
    
    getgroup(clr(),a(),700)
    
    Print "where do think the brightest places are?  press a key"
    key=Input(1)
    For n As Long=Lbound(a) To Ubound(a)
        Pset(a(n).xpos,a(n).ypos),0
    Next
    Print "black blobbed press a key or esc to quit"
    key=""
    key=Input(1)
    If key=Chr(27) Then Exit Do
    Cls
    For n As Long=Lbound(clr) To Ubound(clr)
        clr(n).done=0
    Next
Loop


 
marcov
Posts: 3455
Joined: Jun 16, 2005 9:45
Location: Netherlands
Contact:

Re: Machine Vision

Post by marcov »

It should only be necessary to touch every pixel once, without any whole image storage.

Multiple passes are bad because parsing an image, and then starting at the beginning again is cache inefficient.

See e.g. https://www.researchgate.net/figure/Run ... _265922169
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Machine Vision

Post by dodicat »

I forgot to imagedestroy in my last code, will fix later.
Here character colour recognition, the blobs are more structured, but same method as previously.

Code: Select all


#define irange(f,l) Int(Rnd*(((l)+1)-(f))+(f))
Type pt  'simulate 3D space
    As Long x,y,z
    As Byte done
    As Long xpos,ypos
End Type

Function closest(clr() As pt,v As Ulong) As Ulong
    Dim As Double res,distance
    #define dist(p1,p2) ((p1.x-p2.x)*(p1.x-p2.x) + (p1.y-p2.y)*(p1.y-p2.y) + (p1.z-p2.z)*(p1.z-p2.z))
    '#define dist(p1,p2) abs(p1.x-p2.x)+abs(p1.y-p2.y) + abs(p1.z-p2.z)
    Dim As pt pv=Type(Cptr(Ubyte Ptr,@v)[2],Cptr(Ubyte Ptr,@v)[1],Cptr(Ubyte Ptr,@v)[0])
    Dim As Double dt=1e15
    For n As Long=Lbound(clr) To Ubound(clr)
        If clr(n).done Then Continue For
        Var distance=dist(clr(n),pv)
        If dt> distance Then dt = distance:res=n 'catch the smallest
        nxt:
    Next n
    Return res
End Function

Sub getgroup(clr() As pt,a() As pt,num As Long,c As Ulong=Rgb(255,255,255))
    Redim a(1 To num)
    Dim As Long e
    For n As Long=1 To num
        e=closest(clr(),c)
        a(n)=clr(e)
        clr(e).done=1
    Next
End Sub

Sub getcolours(i As Any Ptr, clr() As pt)
    Dim As Long ctr
    Dim As Long x,y
    Imageinfo i,x,y
    Redim clr(1 To x*y)
    For x As Long=0 To 1024-1
        For y As Long=0 To 768-1
            ctr+=1
            Var v=Point(x,y,i)
            clr(ctr)=Type(Cptr(Ubyte Ptr,@v)[2],Cptr(Ubyte Ptr,@v)[1],Cptr(Ubyte Ptr,@v)[0])
            clr(ctr).xpos=x
            clr(ctr).ypos=y
        Next
    Next
End Sub

Dim As String key
dim as ulong lc
Screen 20,32

dim as string s="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
Do
    Randomize
    Dim As Any Ptr i=Imagecreate(1024,768,Rgb(0,0,0))
   
    For n As Long=1 To 500
        dim as ulong colour=Rgb(Rnd*200,Rnd*200,Rnd*200)
        draw string i,(irange(10,1000),irange(10,750)),chr(s[irange(0,len(s)-1)]),colour
    Next
    
    Put(0,0),i,Pset
    
    Redim As pt clr()
    Redim As pt a()
    getcolours(i,clr())
    draw string(10,10), "getting blobs (500 points) . . ."
    lc=Rgb(100+Rnd*155,100*Rnd*155,100+Rnd*155)
    getgroup(clr(),a(),500,lc)
    
    draw string(10,25), "get letters near this colour and put the blobs 10 pixels to the right . . .  press a key",lc
    key=Input(1)
    For n As Long=Lbound(a) To Ubound(a)
        Pset(a(n).xpos+10,a(n).ypos),rgb(255,255,255)
    Next
    draw string(10,40), "blobbed, press a key or esc to quit"
    key=""
    key=Input(1)
    If key=Chr(27) Then Exit Do
    Cls
   
    imagedestroy i
Loop


 
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Machine Vision

Post by dodicat »

What happened to your post basiccoder2?
I was going to have a try at at text to string.
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Machine Vision

Post by BasicCoder2 »

@dodicat
In the past no one has really shown any interest in this kind of thing and I didn't want to clog up the forum with my waffling on about it. However if you are still interested the code below (which I have posted somewhere before) might be somewhere to start.

How it works is image1 is scanned top to bottom, left to right. When a non black pixel is found it takes it as a pixel in a blob. It then fills the blob with black pixels (so they will not be looked at again during the scan for more blobs) while it computes some blob descriptors. An issue with the current example is with the inner blobs you find in a P or B and so on are not recorded because the background color is black. That needs to be fixed. Blobs can contain blobs that can contain more blobs so that is part of describing a blob. Maybe not so important for printed characters however a face has a blob for the head, blobs for eyes, maybe two nostril blobs and a maybe a mouth blob.

There are issues with text with regards reading left to right, top to bottom, and recognizing the space between words. Some characters like % have three blobs spatially related to each other.

For some reason I can't get the code used to create the image below to work in the program below to fill in the inner blobs by having a color background and using paint to fill the outside with black pixels.
Image

The code example below doesn't do any recognizing of blobs which would require using an extracted blob description to compare with a list of descriptions for each blob type to be recognized.

The example also skips the issue of converting an actual image of a page of text taken by a camera into a binary form. If a page of text is scanned then usually a simple threshold function will be sufficient. If it is a photo of a page then shading can actually mean you need a variable threshold function like the one I used in the target example. However using these ideal binary images allows the exploration of ways to convert a blob into a description that can be used for character recognition.

Code: Select all

 
screenres 1280,600,32

'====================================
'Fonts  by MYSOFT.
'====================================
'http://www.freebasic.net/forum/viewtopic.php?f=2&t=23343&hilit=windows+api+font
'

#include "windows.bi"
#include "fbgfx.bi"

enum 
  FS_BOLD = 2
  FS_ITALIC = 4 
  FS_ANTIALIAS = 8
  FS_BLUR = 16+8
End enum

Sub DrawFont(byref BUFFER As Any Ptr=0,byval POSX As Integer, byval POSY As Integer, _
  byref FTEXT As String, byref FNAME As String,byval FSIZE As Integer, _
 byval FCOLOR As Uinteger=rgba(255,255,255,0),byval FSTYLE As Integer=0,byval CHARSET As Integer=DEFAULT_CHARSET )
  Static FINIT As Integer
  Static As hdc THEDC
  Static As hbitmap THEBMP
  Static As Any Ptr THEPTR
  Static As fb.image Ptr FBBLK
  Static As Integer WIDCHAR(65535)
  Static As Integer TXTSZ,COUNT,RESU,RESUU
  Static As Any Ptr SRCBUF,DSTBUF
  Static As hfont THEFONT
  Static As Integer FW,FI,TXYY,FCOR
  Static DSKWND As hwnd, DSKDC As hdc
  Static MYBMPINFO As BITMAPINFO
  Static As TEXTMETRIC MYTXINFO
  Static As SIZE TXTSIZE
  Static As RECT RCT
 #define GAMMA 1.3
  #define FontSize(PointSize) -MulDiv(PointSize, GetDeviceCaps(THEDC, LOGPIXELSY), 72) 
 
  If FINIT = 0 Then   
    FINIT = 1   
    With MYBMPINFO.bmiheader
      .biSize = sizeof(BITMAPINFOHEADER)
      .biWidth = 2048
      .biHeight = -513
      .biPlanes = 1
      .biBitCount = 32
      .biCompression = BI_RGB
    End With   
    DSKWND = GetDesktopWindow()
    DSKDC = GetDC(DSKWND)
    THEDC = CreateCompatibleDC(DSKDC)
    THEBMP = CreateDIBSection(THEDC,@MYBMPINFO,DIB_RGB_COLORS,@THEPTR,null,null)  
    ReleaseDC(DSKWND,DSKDC)   
  End If
  If (FSTYLE And FS_BOLD) Then FW = FW_BOLD Else FW = FW_NORMAL   
  If (FSTYLE And FS_ITALIC) Then FI = True Else FI = False   
  THEFONT = CreateFont(FontSize(FSIZE),0,0,0,FW,FI,0,0,CHARSET,0,0,0,0,cast(Any Ptr,Strptr(FNAME)))   
  SelectObject(THEDC,THEBMP)
  SelectObject(THEDC,THEFONT)
  GetTextMetrics(THEDC,@MYTXINFO)
  GetTextExtentPoint32(THEDC,Strptr(FTEXT),Len(FTEXT),@TXTSIZE) 
  TXTSZ = TXTSIZE.CX
  TXYY = TXTSIZE.CY
  If (FSTYLE And FS_ITALIC) Then
    If MYTXINFO.tmOverhang Then
      TXTSZ += MYTXINFO.tmOverhang
    Else
      TXTSZ += 1+(FSIZE/2)
    End If
    TXYY += 1+(FSIZE/8)
  End If
  If (FSTYLE And FS_ANTIALIAS) Then
    #if GAMMA>1 And GAMMA <= 2
    TXTSZ += GAMMA*2
    #endif
  End If
  With RCT
    .LEFT = 0
    .TOP = 1
    .RIGHT = TXTSZ
    .BOTTOM = TXYY+1
  End With
  TXTSZ -= 1
  TXYY -= 1
  asm
    mov eax,[FCOLOR]
    And eax,0xFFFFFF
    mov [FCOR],eax
    bswap eax
    ror eax,8
    mov [FCOLOR],eax
  End asm
  SetBkColor(THEDC,rgba(255,0,255,0))
  SetTextColor(THEDC,FCOLOR)
  SystemParametersInfo(SPI_GETFONTSMOOTHING,null,@RESU,null)
  If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,False,@RESUU,null)
  ExtTextOut(THEDC,0,1,ETO_CLIPPED Or ETO_OPAQUE,@RCT,Strptr(FTEXT),Len(FTEXT),null)
  If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,True,@RESUU,null)
  FBBLK = THEPTR+(2048*4)-sizeof(fb.image)
  FBBLK->type = 7
  FBBLK->bpp = 4
  FBBLK->width = 2048
  FBBLK->height = 512
  FBBLK->pitch = 2048*4
  If (FSTYLE And FS_ANTIALIAS) Then
    Dim As Any Ptr MYBLK
    MYBLK = THEPTR+(2048*4)
    asm
      mov ecx,2048*511
      mov ebx,[FCOR]
      mov esi,[MYBLK]     
      HERE:
      cmp [esi], dword Ptr 0xFF00FF     
      je _TRANS_
      mov [esi+3], Byte Ptr 0xFF     
      _TRANS_:     
      And [esi], dword Ptr 0xFF000000
      Or [esi], ebx
      add esi,4
      dec ecx
      jnz HERE
    End asm
   
    Dim As Integer TX,TY
    Dim As Integer ALP
    #define GetAlpha(PX,PY) Peek(MYBLK+((PY)*8192)+((PX)*4)+3)
    #define SetAlpha(PX,PY,NA) Poke(MYBLK+((PY)*8192)+((PX)*4)+3),NA
    If (FSTYLE And FS_BLUR) = FS_BLUR Then
      For TX = 1 To TXTSZ-1
        ALP = (GetAlpha(TX,0)+GetAlpha(TX+1,0)+GetAlpha(TX-1,0)+ _
        GetAlpha(TX,1)+GetAlpha(TX-1,1)+GetAlpha(TX+1,1)) / 6
        #if GAMMA>1 And GAMMA <= 1.6
        ALP *= (GAMMA+.5)
        If ALP > 255 Then ALP = 255
        #endif
        SetAlpha(TX,TY,ALP)
      Next TX
      For TX = 1 To TXTSZ-1
        For TY = 1 To TXYY-1         
          ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+GetAlpha(TX-1,TY)+ _
          GetAlpha(TX,TY-1)+GetAlpha(TX,TY+1) + _
          GetAlpha(TX-1,TY-1)+GetAlpha(TX-1,TY+1)+ _
          GetAlpha(TX+1,TY-1)+GetAlpha(TX+1,TY+1)) / 9
          #if GAMMA>1 And GAMMA <= 1.6
        ALP *= (GAMMA+.5)
        If ALP > 255 Then ALP = 255
        #endif
          SetAlpha(TX,TY,ALP)
        Next TY
      Next TX
      For TX = 1 To TXTSZ-1
        ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+GetAlpha(TX-1,TY)+ _
        GetAlpha(TX,TY-1)+GetAlpha(TX-1,TY-1)+GetAlpha(TX+1,TY-1)) / 6
        #if GAMMA>1 And GAMMA <= 1.6
        ALP *= (GAMMA+.5)
        If ALP > 255 Then ALP = 255
        #endif
        SetAlpha(TX,TY,ALP)
      Next TX
    Else     
      For TX = 1 To TXTSZ-1
        ALP = (GetAlpha(TX,0)+GetAlpha(TX+1,0)+_
        GetAlpha(TX-1,0)+GetAlpha(TX,1))/4       
        #if GAMMA>1 And GAMMA <= 2
        ALP *= GAMMA
        If ALP > 255 Then ALP = 255
        #endif       
        SetAlpha(TX,TY,ALP)
      Next TX
      For TX = 1 To TXTSZ-1
        For TY = 1 To TXYY-1
          ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+GetAlpha(TX-1,TY)+_
          GetAlpha(TX,TY-1)+GetAlpha(TX,TY+1))/5
          #if GAMMA>1 And GAMMA <= 2
          ALP *= GAMMA
          If ALP > 255 Then ALP = 255
          #endif         
          SetAlpha(TX,TY,ALP)         
        Next TY
      Next TX
      For TX = 1 To TXTSZ-1
        ALP = (GetAlpha(TX,TY)+GetAlpha(TX+1,TY)+ _
        GetAlpha(TX-1,TY)+GetAlpha(TX,TY-1))/4       
        #if GAMMA>1 And GAMMA <= 2
        ALP *= GAMMA
        If ALP > 255 Then ALP = 255
        #endif       
        SetAlpha(TX,TY,ALP)
      Next TX
    End If
    Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),alpha
  Else 
    Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),trans
  End If
  DeleteObject(THEFONT)
End Sub


type BlobType
    Area as integer
    Perimeter as integer
    xMin as integer
    xMax as integer
    yMin as integer
    yMax as integer
    xTot as integer
    yTot as integer
    xCentroid as integer
    yCentroid as integer
    xStart as integer
    yStart as integer
end type

dim shared as BlobType Blob
const iCOL = 1280
const iROW = 64

dim shared as any ptr image1,image2,image3
image1 = imagecreate(iCOL,iROW,rgb(0,0,0))
image2 = imagecreate(iCOL,iROW,rgb(0,0,0))
image3 = imagecreate(iCOL,iROW,rgb(0,0,0))


dim shared as integer xp(1000)  'save contour coordinates
dim shared as integer yp(1000)


sub initializeBlob()
    Blob.Area = 0
    Blob.Perimeter = 0
    Blob.xMin = 10000
    Blob.xMax = 0
    Blob.yMin = 10000
    Blob.yMax = 0
    Blob.xTot = 0
    Blob.yTot = 0
    Blob.xCentroid = 0
    Blob.yCentroid = 0
    Blob.xStart = 0
    Blob.yStart = 0
end sub


dim shared as integer AREA1
dim shared as integer length               'length of outline
dim shared as integer xMin,xMax,yMin,yMax  'box traversed blob

Sub getBlob (x As Integer, y As Integer,image1 as any ptr, colour As uInteger,image2 as any ptr)
    
    'clear image2 used as blobs destination
    line image2,(0,0)-(iCOL,iROW),rgb(0,0,0),bf
    
    'create a stack
    Dim as integer xs(1000),ys(1000),stkptr

    ' initialize blob data
    Blob.xStart = x
    Blob.yStart = y
    Blob.perimeter = 0
    Blob.Area = 0
    Blob.xMin = iCOL
    Blob.xMax = 0
    Blob.yMin = iROW
    Blob.yMax = 0
    Blob.xTot = 0
    Blob.yTot = 0
    ' -----------------
    
    'stack first item
    xs(stkptr) = x
    ys(stkptr) = y
    stkptr = stkptr + 1

    do
        'unstack item
        stkptr = stkptr - 1
        x = xs(stkptr)
        y = ys(stkptr)
        
        'move left if required
        if x>0 then
            while point(x-1,y,image1)=colour
                x = x - 1
            wend
        end if
        

        if point(x,y+1,image1)=colour and point(x-1,y+1,image1)=colour then
            xs(stkptr)=x
            ys(stkptr)=y+1
            stkptr = stkptr + 1
        end if

        if point(x,y-1,image1)=colour and point(x-1,y-1,image1)=colour then
            xs(stkptr)=x
            ys(stkptr)=y-1
            stkptr = stkptr + 1
        end if
        
        if point(x-1,y+1,image1)=colour and point(x,y+1,image1)<>colour then
            xs(stkptr)=x-1
            ys(stkptr)=y+1
            stkptr = stkptr + 1
        end if 
 
        if point(x-1,y-1,image1)=colour and point(x,y-1,image1)<>colour then
            xs(stkptr)=x-1
            ys(stkptr)=y-1
            stkptr = stkptr + 1
        end if 
        
        'move right setting pixels
        while point(x,y,image1)=colour
            

            if point(x,y+1,image1)=colour and point(x-1,y+1,image1)<> colour then
                'stack new horizontal line
                xs(stkptr) = x
                ys(stkptr) = y+1
                stkptr = stkptr + 1
            end if

            if point(x,y-1,image1)=colour and point(x-1,y-1,image1)<> colour then
                'stack new horizontal line
                xs(stkptr) = x
                ys(stkptr) = y-1
                stkptr = stkptr + 1
            end if
            
            if point(x+1,y-1,image1)=colour and point(x,y-1,image1)<> colour then
                'stack new horizontal line
                xs(stkptr) = x+1
                ys(stkptr) = y-1
                stkptr = stkptr + 1
            end if   
            
            if point(x+1,y+1,image1)=colour and point(x,y+1,image1)<> colour then
                'stack new horizontal line
                xs(stkptr) = x+1
                ys(stkptr) = y+1
                stkptr = stkptr + 1
            end if
            
            pset image1,(x,y),rgb(0,0,0)  'erase pixel to show it has been processed
            pset image2,(x,y),colour      'save blob in image2()
            
            '-------  update blob data ---------
            Blob.Area = Blob.Area + 1
            Blob.xTot = Blob.xTot + x
            Blob.yTot = Blob.yTot + y
            if x > Blob.xMax then Blob.xMax = x
            if y > Blob.yMax then Blob.yMax = y
            if x < Blob.xMin then Blob.xMin = x
            if y < Blob.yMin then Blob.yMin = y
            '----------------------------------
             
            x = x + 1
             
        wend

        'check stack for more items
    loop until stkptr = 0

end sub

sub TraverseBlob(x as integer, y as integer,image2 as any ptr,c as uinteger)
    dim as integer ox,oy,sx,sy,direction,cc
    
    AREA1 = 0
    
    direction = 0
    ox = x
    oy = y
    sx = x
    sy = y
    cc = point(x,y,image2)  'color to draw outline
    
    xMin = 320
    yMin = 320
    xMax = 0
    yMax = 0 
    
    do
        xp(Blob.perimeter)= x - sx
        yp(Blob.perimeter)= y - sy 
        
        if x>xMax then xMax = x
        if x<xMin then xMin = x
        if y>yMax then yMax = y
        if y<yMin then yMin = y
        
        select case as const direction

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

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

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

        pset image3,(x,y),rgb(255,0,0)  'display outline top/right quadrant

        'put (0,120),image3,pset
        
        '-- computes area of blob while traversing --'
        AREA1 = AREA1 + (x * (y-oy))-(y * (x-ox))
        '--------------------------------------------'

        length = length + 1        
        ox = x
        oy = y
        'sleep 1
        

        Blob.perimeter = Blob.perimeter + 1

    loop until sx = x and sy = y
    
    AREA1 = AREA1\2  'final adjustment
    
end sub

sub PrintBlobData()
    screenlock
    cls
    'display the bitmaps
    put (0,0),image1,pset
    put (0,80),image2,pset
    put (0,160),image3,pset
         
    locate 32,1
    print " *** JUST SOME OF THE SHAPE DATA ***"
    print
    print "Blob Area2 =";Blob.Area
    print "Blob Area1 =";AREA1
    print "perimeter  =";Blob.perimeter
    print "rect width  =";Blob.xMax - Blob.xMin
    print "rect height =";Blob.yMax - Blob.yMin
    print "Blob.xCentroid";Blob.xTot\Blob.Area
    print "Blob.yCentroid";Blob.yTot\Blob.Area
    screenunlock
    sleep
end sub


cls

dim as string text

read text

drawfont (image1,1,1,text,"Comic Sans MS",30,rgb(55,55,255),FS_BOLD)
line (0,0)-(iCOL-1,iROW-1),rgb(0,0,0),b 'black border
'=============================================================================      

'scans image array finding, extracting and traversing blobs
for j as integer = 1 to iROW-1
    for i as integer = 1 to iCOL-1
        if point(i,j,image1) <> rgb(0,0,0) then
            'extract blob from image1() and copy into image2()
            getBlob(i,j,image1,point(i,j,image1),image2)
            'traverse the blob to get its contour data
            traverseBlob(i,j,image2,point(i,j,image2))
            'print some data extracted from blob
            printBlobData()
            'sleep
        end if
    next i
next j

sleep
data "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Machine Vision

Post by dodicat »

Thanks BasicCoder2.
I'll have a play around with some ideas.
Some sort of comparison method required, maybe by scanning.
Either with the enlarged fonts by Mysoft (which I have used before) or the fb dos text, or maybe known shapes.
Anyway I'll have a mess around.
Post Reply