Hi
Monogamy, round these parts, is a type of tropical hardwood.
Polygamy is this effort.
@Rollie
I had to resort to bleeding impulses to keep the polygons moving, I thought that just switching direction numbers would do, but it didn't.
@ All
If I got a large map of Australia, and cut the island out with scissors, and laid it flat on a table.
Then I got a smaller scale map of Australia, and cut the island out with scissors.
Say the approx. relative sizes were
1) Larger cut out about the size of a computer desk.
2) Smaller cut out about the size of a mouse mat.
I then chuck the small map onto the large map.
If I then get a pin, one point in the small map will be the same place on the large map, so I can place the pin on that point, and the pin marks a single place in Australia on both maps.
The same with two cartesian grids.
some point x,y above, will be the same as some point X,Y, below
I need some additional information obviously
say (x1,y1) on the small grid lies over (X1,Y1) on the large
and
(x2,y2) on the small lies over (X2,Y2) on the large.
Can I find the singular point on the small grid to stick a pin through?
Anyway Poligamy:
Code: Select all
Dim Shared As Integer xres,yres
screeninfo xres,yres
'xres=700
'yres=700
screenres xres,yres,32
windowtitle "Press spacebar or Hold down escape any time "+"resolution = "+str(xres)+" x "+str(yres)
type point2d
as double x,y
end type
declare sub turnpolygon(angle as double,byref pivot as point2d, x() as double, y() as double,d as point2d)
declare Function isleft(xx() As Double,yy() As Double,x As Double,y As Double) As Integer
declare Function INpolygon(xx() As Double,yy() As Double,x As Double,y As Double) As Integer
declare Function rr(first As Double, last As Double) As Double
declare Sub makepolygon(n As Integer,cx As Double,cy As Double,xx() as double,yy() as double,k As Double=200)
declare sub drawpolygon(x() as double,y() as double,col() as uinteger,im as any pointer=0)
declare function rotatepoint2d(pivot As point2d,_
_point as point2d,_
angle As Double,_
dilator as double=1) as point2d
dim as double polysize=yres/3 'SIZE OF POLY'S
dim as double a1=1.5,a2=-1 'ANGLE TURN RATE OF POLY'S(degrees per loop)
Redim xx(0) As Double,yy(0) As Double 'for the polygons
Redim xx2(0) As Double,yy2(0) As Double
dim as uinteger colour(1 to 3)
dim shared as point2d pivot
dim as point2d pivot1,pivot2
dim as integer sides1=rr(3,9),sides2=rr(3,7)'random number of sides
Dim As Double leftmargin,rightmargin,topmargin,basemargin,temp
dim as double dx,dy,nx,ny,switch=2
leftmargin=.25*xres
rightmargin=.75*xres
topmargin=.25*yres
basemargin=.75*yres
Dim As Double leftimpulse(2),rightimpulse(2),topimpulse(2),baseimpulse(2)
#macro getcolour(zz)
select case zz
case 1
colour(1)=255:colour(2)=100:colour(3)=0
case 2
colour(1)=0
end select
#endmacro
#macro polypoly()
dx=(pivot1.x-pivot2.x) '(dx,dy) line of action
dy=(pivot1.y-pivot2.y)
nx=dx/Sqr(dx^2+dy^2) 'line of action direction numbers(unit vector)
ny=dy/Sqr(dx^2+dy^2)
d1.x=d1.x+switch*nx 'new vectors
d1.y=d1.y+switch*ny
d2.x=d2.x-switch*nx
d2.y=d2.y-switch*ny
temp=Sqr(d1.x^2+d1.y^2)
d1.x=d1.x/temp 'new direction numbers(unit)
d1.y=d1.y/temp
temp=Sqr(d2.x^2+d2.y^2)
d2.x=d2.x/temp
d2.y=d2.y/temp
#endmacro
dim i as string
do
randomize
makepolygon(sides1,.3*yres,.3*yres,xx(),yy(),polysize)
pivot1.x=pivot.x:pivot1.y=pivot.y
makepolygon(sides2,.7*yres,.7*yres,xx2(),yy2(),polysize)
pivot2.x=pivot.x:pivot2.y=pivot.y
dim as point2d d1,d2 'the direction numbers
d1.x=5:d1.y=5:d2.x=5:d2.y=5 'start off
do
i=inkey
if i=chr(27) then end
'GET SIDE IMPULSES
leftimpulse(1)=leftmargin-pivot1.x:temp=Sqr(leftmargin^2+pivot1.x^2)
leftimpulse(1)=leftimpulse(1)/temp
rightimpulse(1)=rightmargin-pivot1.x:temp=Sqr(rightmargin^2+pivot1.x^2)
rightimpulse(1)=rightimpulse(1)/temp
topimpulse(1)=topmargin-pivot1.y:temp=Sqr(topmargin^2+pivot.y^2)
topimpulse(1)=topimpulse(1)/temp
baseimpulse(1)=basemargin-pivot1.y:temp=Sqr(basemargin^2+pivot.y^2)
baseimpulse(1)=baseimpulse(1)/temp
leftimpulse(2)=leftmargin-pivot2.x:temp=Sqr(leftmargin^2+pivot2.x^2)
leftimpulse(2)=leftimpulse(2)/temp
rightimpulse(2)=rightmargin-pivot2.x:temp=Sqr(rightmargin^2+pivot2.x^2)
rightimpulse(2)=rightimpulse(2)/temp
topimpulse(2)=topmargin-pivot2.y:temp=Sqr(topmargin^2+pivot2.y^2)
topimpulse(2)=topimpulse(2)/temp
baseimpulse(2)=basemargin-pivot2.y:temp=Sqr(basemargin^2+pivot2.y^2)
baseimpulse(2)=baseimpulse(2)/temp
'EDGE BOUNDARIES
if pivot1.x>rightmargin then d1.x=d1.x+3*rightimpulse(1)
if pivot1.x<leftmargin then d1.x=d1.x+3*leftimpulse(1)
if pivot1.y>basemargin then d1.y=d1.y+3*baseimpulse(1)
if pivot1.y<topmargin then d1.y=d1.y+3*topimpulse(1)
if pivot2.x>rightmargin then d2.x=d2.x+3*rightimpulse(2)
if pivot2.x<leftmargin then d2.x=d2.x+3*leftimpulse(2)
if pivot2.y>basemargin then d2.y=d2.y+3*baseimpulse(2)
if pivot2.y<topmargin then d2.y=d2.y+3*topimpulse(2)
' POLY TO POLY INTERACTION
for z as integer=1 to ubound (xx)
if inpolygon(xx2(),yy2(),xx(z),yy(z)) then
polypoly()
a1=-a1:a2=-a2 'change spin
end if
next z
for z as integer=1 to ubound (xx2)
if inpolygon(xx(),yy(),xx2(z),yy2(z)) then
polypoly()
a1=-a1:a2=-a2 'change spin
end if
next z
screenlock
cls
getcolour(1)
turnpolygon(a1,pivot1,xx(),yy(),d1) 'TURN AND MOVE POLYGONS
drawpolygon(xx(),yy(),colour())
getcolour(2)
turnpolygon(a2,pivot2,xx2(),yy2(),d2)
drawpolygon(xx2(),yy2(),colour())
screenunlock
sleep 1,1
loop until inkey=" "
loop
sleep
Function isleft(xx() As Double,yy() As Double,x As Double,y As Double) As Integer
Return -Sgn( (xx(1)-xx(2))*(y-yy(2)) - (x-xx(2))*(yy(1)-yy(2)))
End Function
Function INpolygon(xx() As Double,yy() As Double,x As Double,y As Double) As Integer
Dim As Integer index,nextindex
Dim k As Integer=Ubound(xx)+1
Dim sendx(1 To 2) As Double
Dim sendy(1 To 2) As Double
Dim wn As Integer=0
For n As Integer=1 To Ubound(xx)
index=n Mod k:nextindex=(n+1) Mod k
If nextindex=0 Then nextindex=1
sendx(1)=xx(index):sendx(2)=xx(nextindex)
sendy(1)=yy(index):sendy(2)=yy(nextindex)
'line(sendx(1),sendy(1))-(sendx(2),sendy(2))
If yy(index)<=y Then
If yy(nextindex)>y Then
If isleft(sendx(),sendy(),x,y)>0 Then
wn=wn+1
Endif
Endif
Else
If yy(nextindex)<=y Then
If isleft(sendx(),sendy(),x,y)<0 Then
wn=wn-1
Endif
Endif
Endif
Next n
Return wn
End Function
Sub makepolygon(n As Integer,cx As Double,cy As Double,xx() as double,yy() as double,k As Double=200)
Dim As Double r,bigr,x,y,num
Dim As Double pi=4*Atn(1)
Redim xx(1 To n),yy(1 To n)
#define rad *pi/180
Dim count As Integer=0
dim as double sumx,sumy
For z As Double=0 To 2*pi Step 2*pi/n
count=count+1
num= (45*(2*n-4)/n) rad
num=Cos(num)
r=num/(1+num)
bigr=((1-r))*k
r=(r)*k
x=cx+bigr*Cos(z)
y=cy+bigr*Sin(z)
If count<=n Then
xx(count)=rr(x-r,x+r)
sumx=sumx+xx(count)
yy(count)=rr(y-r,y+r)
sumy=sumy+yy(count)
Endif
Next z
sumx=sumx/ubound(xx)
sumy=sumy/ubound(yy)
pivot.x=sumx
pivot.y=sumy
End Sub
sub drawpolygon(x() as double,y() as double,col() as uinteger,im as any pointer=0)
dim k as integer=ubound(x)+1
dim as integer index,nextindex
dim as double xc,yc
for n as integer=1 to ubound(x)'+1
xc=xc+x(n):yc=yc+y(n)
index=n mod k:nextindex=(n+1) mod k
if nextindex=0 then nextindex=1
line im,(x(index),y(index))-(x(nextindex),y(nextindex)),rgb(col(1),col(2),col(3))
next
xc=xc/ubound(x):yc=yc/ubound(y)
paint (xc,yc),rgb(col(1),col(2),col(3)),rgb(col(1),col(2),col(3))
end sub
function rotatepoint2d(pivot As point2d,_
_point as point2d,_
angle As Double,_
dilator as double=1) as point2d
Dim pi As Double=4*Atn(1)
#define rad *pi/180
dim as point2d np
np.x=dilator*(Cos(angle rad)*(_point.x-pivot.x)-Sin(angle rad)*(_point.y-pivot.y)) +pivot.x
np.y=dilator*(Sin(angle rad)*(_point.x-pivot.x)+Cos(angle rad)*(_point.y-pivot.y)) +pivot.y
return np
End function
sub turnpolygon(angle as double,byref pivot as point2d, x() as double, y() as double,d as point2d)
dim as point2d switch,temp
dim as double sumx,sumy
for z as integer=1 to ubound(x)
switch.x=x(z)+d.x
switch.y=y(z)+d.y
temp=rotatepoint2d(pivot,switch,angle,1)
x(z)=temp.x:sumx=sumx+temp.x
y(z)=temp.y:sumy=sumy+temp.y
next z
pivot.x=sumx/ubound(x)
pivot.y=sumy/ubound(x)
end sub
Function rr(first As Double, last As Double) As Double
Function = Rnd * (last - first) + first
End Function