Code archives/Graphics/Draw outlines of overlapped circles
This code has been declared by its author to be Public Domain code.
Download source code
| |||||
| Suppose you have a load of circles in the plane and you want just to draw their outlines, avoiding the bits where circles intersect each other. I've wanted to be able to do this the proper algorithmic way for years, and yesterday I finally had a bout of inspiration! Here's my code. It's pretty lengthy, but to use it in your programs you can do with just copying everything above the example code, and the only bits you need to pay attention to are passing a list of circles to the intersectcircles function and doing whatever you want with the circle.draw method. | |||||
Type circle
Field x#,y#,r#
Field nonarcs:TList
Field vx#,vy#
Method New()
nonarcs=New TList
End Method
Function Create:circle(x#,y#,r#)
c:circle=New circle
c.x=x
c.y=y
c.r=r
an#=Rnd(360)
v#=Rnd(.5,2)
c.vx=v*Cos(an)
c.vy=v*Sin(an)
Return c
End Function
Method update()
x:+vx
If x<0 Or x>800
vx=-vx
x:+vx
EndIf
y:+vy
If y<0 Or y>800
vy=-vy
y:+vy
EndIf
End Method
Method intersect(c2:circle)
debugo "<<<<<"
dx#=c2.x-x
dy#=c2.y-y
d=Sqr(dx*dx+dy*dy)
If d>=r+c2.r Then Return
fullcircle:nonarc=nonarc.Create(0,360)
If r>c2.r
If d+c2.r<=r
c2.nonarcs=New TList
c2.nonarcs.addlast fullcircle
debugo "removed second circle!"
Return
EndIf
Else
If d+r<=c2.r
nonarcs=New TList
nonarcs.addlast fullcircle
debugo "removed first circle"
Return
EndIf
EndIf
dx:/d
dy:/d
b#=(r*r-c2.r*c2.r+d*d)/(2*d)
theta#=ACos(b/r)
phi#=ATan2(dy,dx)
addnonarc(phi-theta,phi+theta)
Rem
If anbetween(0,phi-theta,phi+theta)
SetColor 255,0,0
Else
SetColor 0,0,255
EndIf
x1#=x+Cos(phi-theta)*r
y1#=y+Sin(phi-theta)*r
x2#=x+Cos(phi+theta)*r
y2#=y+Sin(phi+theta)*r
DrawText "1",x1,y1
DrawText "2",x2,y2
SetColor 255,255,255
EndRem
theta2#=ACos((d-b)/c2.r)
phi2#=phi+180
c2.addnonarc(phi2-theta2,phi2+theta2)
Rem
x3#=c2.x+Cos(phi2-theta2)*c2.r
y3#=c2.y+Sin(phi2-theta2)*c2.r
x4#=c2.x+Cos(phi2+theta2)*c2.r
y4#=c2.y+Sin(phi2+theta2)*c2.r
DrawText "3",x3+5,y3
DrawText "4",x4+5,y4
EndRem
End Method
Method addnonarc(b1#,b2#)
newna:nonarc=nonarc.Create(b1,b2)
For na:nonarc=EachIn nonarcs
debugo "compare "+newna.repr()+" with "+na.repr()
If na.contains(b1)
If na.contains(b2)
If newna.contains(na.an1) And newna.contains(na.an2)
debugo("both arcs contained in each other - full circle")
nonarcs=New TList
nonarcs.addlast nonarc.Create(0,360)
Return
EndIf
debugo("new arc wholly contained in old arc")
Return
Else
debugo("a1->b2")
nonarcs.remove na
addnonarc(na.an1,b2)
Return
EndIf
Else
If na.contains(b2)
debugo("b1->a2")
nonarcs.remove na
addnonarc(b1,na.an2)
Return
Else
If newna.contains(na.an1)
debugo("old arc wholly contained in new arc")
nonarcs.remove na
Else
debugo("arcs don't intersect")
EndIf
EndIf
EndIf
Next
nonarcs.addlast newna
End Method
Method draw()
DrawText nonarcs.count(),x+8,y
Select nonarcs.count()
Case 0 'this circle doesn't intersect any other, so just draw all of it
drawarc(0,360)
Case 1 'this circle intersects one other, so only need to look at one nonarc
na:nonarc=nonarc(nonarcs.first())
'If na.an1=0 And na.an2=360 Then Return
drawarc(na.an2,na.an1)
Default 'this circle intersects several others, so work through list of nonarcs, drawing
'from end of previous one to start of next one
SortList nonarcs,True,nonarc.comparestarts
ona:nonarc=nonarc(nonarcs.last())
For na:nonarc=EachIn nonarcs
drawarc(ona.an2,na.an1)
ona=na
Next
End Select
If drawnonarcs
SetColor 255,0,0
For na:nonarc=EachIn nonarcs
drawarc(na.an1,na.an2)
Next
SetColor 255,255,255
EndIf
End Method
Method drawarc(a#,b#)
If b<a Then b:+360
steps=2*Pi*r/10
s#=360.0/steps
theta#=a
ox#=x+r*Cos(theta)
oy#=y+r*Sin(theta)
While theta<b
dx#=x+r*Cos(theta)
dy#=y+r*Sin(theta)
DrawLine ox,oy,dx,dy
ox=dx
oy=dy
theta:+s
Wend
DrawLine ox,oy,x+r*Cos(b),y+r*Sin(b)
End Method
End Type
Type nonarc
Field an1#,an2#
Function Create:nonarc(an1#,an2#)
na:nonarc=New nonarc
an1=an1 Mod 360
If an1<0 Then an1:+360
If an2<>360 Then an2=an2 Mod 360
If an2<0 Then an2:+360
na.an1=an1
na.an2=an2
Return na
End Function
Method contains(an#)
d1#=andiff(an2,an1)
If d1<0 Then d1:+360
d2#=andiff(an,an1)
If d2=0 Then Return 1
If d2<0 Then d2:+360
debugo " "+d1
debugo " "+d2
If d2<d1 Then Return 1 Else Return 0
End Method
Function comparestarts(o1:Object,o2:Object)
na1:nonarc=nonarc(o1)
na2:nonarc=nonarc(o2)
If nicean(na1.an1)<nicean(na2.an1) Then Return -1 Else Return 1
End Function
Method repr$()
Return "("+String(Int(an1))+","+String(Int(an2))+")"
End Method
End Type
Function nicean#(an#)
an=an Mod 360
If an<=-180 Then an:+360
Return an
End Function
Function andiff#(an1#,an2#)
'debugo String(an1)+" , "+String(an2)
If an2=0 And an1=360 Then Return 360
dan#=(an1-an2) Mod 360
If dan>180 dan:-360
If dan<-180 dan:+360
Return dan
End Function
Function anbetween(an#,an1#,an2#)
End Function
Function intersectcircles(circles:TList)
For c:circle=EachIn circles
c.nonarcs=New TList
Next
l:TList=circles.copy()
While l.count()>1
debugo "?????"
c1:circle=circle(l.removefirst())
For c2:circle=EachIn l
c1.intersect(c2)
Next
Wend
End Function
''''TEST EXAMPLE
Global debugging=0
Function debugo(txt$)
If debugging
Print txt
EndIf
End Function
Global drawnonarcs=0
circles:TList=New TList
SeedRnd MilliSecs()
For n=0 To 20
circles.addlast circle.Create(Rand(300,500),Rand(300,500),Rand(30,100))
Next
c2:circle=circle.Create(400,400,80)
circles.addlast c2
Graphics 800,800,0
While Not KeyHit(KEY_ESCAPE) Or AppTerminate()
c2.x=MouseX()
c2.y=MouseY()
If MouseHit(2)
debugging=1
debugo "------------------"
Else
debugging=0
EndIf
If MouseHit(1)
drawnonarcs=1-drawnonarcs
EndIf
For c:circle=EachIn circles
c.update()
Next
intersectcircles(circles)
For c:circle=EachIn circles
c.draw()
Next
DrawText "click mouse to see non-arcs",0,0
Flip
Cls
Wend |
Comments
| ||
| Nice. |
Code Archives Forum
   |