Squares

[dodicat]

Ok, this looks like one thread in a web with (atomic sized) dew droplets and gravity:

Got it running badidea.
A catenary I would say.
Looks like the bobbins on a trawl net, they thunder over the sea bed and scare the fishes up into the jaws of the net.
Brings back memories.

O, I earned me keep and I paid me way
And I earned the gear that I was wearing
Sailed a million miles, caught ten-million fishes
We were sailing after shoals of herring

[dodicat]

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

[rolliebollocks]

@Dodicat

Yeah, I guess the people's whose internet I've been ganking have finally wizened up, and I had to mosey on down to the Ice Cream parlor and use their WIFI. At any rate, I'm working on rigid body dynamics and something I call an axial polygon which has poles, a head and a tail, leftside, and rightside... So that it always is pointed at the angle it is traveling at.

I guess I'll be updating soon. I've added all sorts of curves too. Oh and I added Polar Points. And Bezier curves.

I think I'll add ellipses and axial circles.

I made another thickline out of circles.

Wacky stuff. At any rate, I'll have to wait to take a look at your doodles, but they sound cool.

[Richard]

@ dodicat.
Re: Monogamy; I did not realise that it was also grown as a tropical hardwood. I thought it was only grown as a cereal crop. Have you not heard of cereal monogamy?

Re: Your scaled maps. “Can I find the singular point on the small grid to stick a pin through?”
Probably, maybe draw a few straight lines through points that are visible on both maps. Sydney & Sydney, Darwin & Darwin, Perth & Perth, maybe the lines will all cross at the pin hole.

An attempt to recreate the geometry has actually been made at full scale. The first Australian line was commenced in the 1900s and drawn in a North – South direction in WA, it was also the route for parts of the Rabbit Proof Fence. The next Australian line was begun in the 1950s from the Woomera rocket range in SA, towards the West coast of WA, it was named the Gunbarrel Highway. These lines intersected at the Hamersley Ranges in the Pilbara where Australia's largest deposits of iron ore were then found. Iron and nickel mining began there in the 1960s and continues to this day, so it guess it must have been a very big nickel plated iron pin that was used in the dreaming.

I know it can be computed from three reference points that exist on both maps. To drill an etched printed circuit board I place the PCB any side up and any orientation, in an NC drilling machine with un-calibrated but linear x and y axes. Then under human control identify three fiducial points on the PCB. From the coordinates of those points all PCB drill hole positions can then be mapped and transformed to the drilling machines reference frame. This handles translation, rotation and scale. It is much easier than having to clamp the PCB in exactly the right position.

[dodicat]

@ Richard
Thanks for the tour.
The rabbit fence looks eco sound, most other things could probably leap over it, including kangaroos.
The gunbarrel highway needs a drop of tar.

Your post kind of reminded me of a book I read long long time past, Mettle at Woomera.
By the way, I have visited your land, and been at a mine, the bauxite quarries in Weipa.
@ Rollie~
Here's the Polygomia mating ritual.
This takes place at midnight, in a Queen's secluded garden, by moonlight, in the dark shadows of tall slender cypress trees, by a bubbling fountain's sound.
Rustum

Code: Select all

Dim Shared As Integer xres,yres
screeninfo xres,yres
'xres=700
'yres=700
screenres xres,yres,32
windowtitle "Press spacebar or Press 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/4 'SIZE OF POLY'S
Dim As Double a1=0,a2=0    'ANGLE TURN RATE OF POLY'S(degrees per loop)
dim shared translatespeed as double=1.001
dim bounce as double=10
dim shared as double speed1,speed2

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(30,60),sides2=rr(3,10)'random number of sides
Dim As Double leftmargin,rightmargin,topmargin,basemargin,temp
Dim As Double dx,dy,nx,ny,switch=4
dim as double vel1,vel2
dim as point2d lastd1,lastd2

 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
#macro  getsideimpulse(zz)
  select case zz
  case 1
 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
 
 case 2
 
 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 
end select

 #endmacro
 
 'EDGE BOUNDARIES
#macro dont_go_too_far_away_dear()
If pivot1.x>rightmargin Then
getsideimpulse(1)
 d1.x=d1.x+bounce*rightimpulse(1)
 a1=atn(d1.x/d1.y)
    'a2=atn(d2.x/d2.y)
 end if
If pivot1.x<leftmargin Then 
getsideimpulse(1)
d1.x=d1.x+bounce*leftimpulse(1)
a1=atn(d1.x/d1.y)
    'a2=atn(d2.x/d2.y)
   ' speed=translatespeed
end if
If pivot1.y>basemargin Then 
getsideimpulse(1)
d1.y=d1.y+bounce*baseimpulse(1)
a1=atn(d1.x/d1.y)
    'a2=atn(d2.x/d2.y)
end if
If pivot1.y<topmargin Then 
getsideimpulse(1)
d1.y=d1.y+bounce*topimpulse(1)
a1=atn(d1.x/d1.y)
    'a2=atn(d2.x/d2.y)
end if


If pivot2.x>rightmargin Then 
getsideimpulse(2)
d2.x=d2.x+bounce*rightimpulse(2)
'a1=atn(d1.x/d1.y)
    a2=atn(d2.x/d2.y)
end if
If pivot2.x<leftmargin Then 
getsideimpulse(2)
d2.x=d2.x+bounce*leftimpulse(2)
'a1=atn(d1.x/d1.y)
    a2=atn(d2.x/d2.y)
end if
If pivot2.y>basemargin Then 
getsideimpulse(2)
d2.y=d2.y+bounce*baseimpulse(2)
'a1=atn(d1.x/d1.y)
    a2=atn(d2.x/d2.y)
end if
If pivot2.y<topmargin Then 
getsideimpulse(2)
d2.y=d2.y+bounce*topimpulse(2)
'a1=atn(d1.x/d1.y)
    a2=atn(d2.x/d2.y)
end if

#endmacro
#macro You_are_cheeky()
For z As Integer=1 To Ubound (xx)
    If inpolygon(xx2(),yy2(),xx(z),yy(z)) Then
        polypoly()
        'a1=-a1:a2=-a2 'change spin
        a1=atn(d1.x/d1.y)
        'a2=atn(d2.x/d2.y)
        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
        'a1=atn(d1.x/d1.y)
        a2=atn(d2.x/d2.y)
        End If
    Next z
    
    #endmacro
      #macro maketwopolygons()
      
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=translatespeed:d1.y=translatespeed:d2.x=translatespeed:d2.y=translatespeed 'start off 

 #endmacro
 #macro Lets_dance()
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())
#endmacro
 #macro settledown()  
 d1.x=speed1*d1.x:d1.y=speed1*d1.y :d2.x=speed2*d2.x :d2.y=speed2*d2.y 
 vel1=sqr((lastd1.x-d1.x)^2+(lastd1.y-d1.y)^2)
 vel2=sqr((lastd2.x-d2.x)^2+(lastd2.y-d2.y)^2)
 if vel1>1 then
     speed1=.99*translatespeed
 end if
 if vel1<.5 then
     speed1=1.01*translatespeed
 end if
 
 if vel2>1 then
     speed2=.9*translatespeed
 end if
 if vel2<.5 then
     speed2=1.1*translatespeed
 end if
 lastd1.x=d1.x:lastd1.y=d1.y:lastd2.x=d2.x:lastd2.y=d2.y
 #endmacro

                Dim i As String
' ***********************************************

   Do             
  Randomize
 maketwopolygons()
 speed1=translatespeed:speed2=translatespeed
Do
 
 settledown()
dont_go_too_far_away_dear()
You_are_cheeky()
    screenlock
    Cls

Lets_dance()
a1=0:a2=0 'zero rotation until the next boundary or poly to poly
screenunlock
Sleep 1,1

i=Inkey
    If i=Chr(27) Then End
    if i=" " then exit do
Loop 

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

 

[rolliebollocks]

@Dodicat

Nice.

@All

I'm having a bout of polygomania. I ran into a problem than ran me into the wee hours of the morning. How do I make a spaceship point at anywhere I please?

It's a tought problem, because you have to get the angle between them, rotate the graphic around, set it's head to an axis with it's tail, and turn the polygon, the sprite attatched to and everything all at once.

So let me ask you? Can you make an isosceles triangle point at the mouse from anywhere on screen?

[dodicat]

Hi Rollie~
I'll have a think about it.
I see the dailly poet's bit is shut down.
Here's my Saturday night poem.

A friend o' mine, for many moons
fair loved to sing his favourite tunes.
In all his favourite county bars,
He'd sing with fiddlers, pipes, guitars.

Delilah was his special song,
he could sing it all day long.

He did in fact, and through each night
until the morning's golden light,
and all next day 'til sun had gone
and then right through until the dawn.

Alas, from work, he got fired.
His boss was truly sick and tired.
He told him, if he wanted back,
he'd have to go and see a quack.

He went along that same day,
singing Delilah on the way.

He explained to doc. his very plight,
Delilah day, Delilah night.
Doc said, well I'll make no bones,
you've got a bad case of Tom Jones.

My friend, with his syndrome now laid bare
inquired to doc if this was rare
Doc said, well, in certain places
It's not unusual in cases.

[Richard]

So let me ask you? Can you make an isosceles triangle point at the mouse from anywhere on screen?

Yes.

Code: Select all

Screen 19
Randomize Timer * 1e6
' Operators and routines for pointy maths
'-------------------------------------------------------------------
Type point2D
    x As Double
    y As Double
End Type

'-------------------------------------------------------------------
' point2D operators are just complex maths operators
'-------------------------------------------------------------------
'Declare Operator + (Byref As point2D, Byref As point2D) As point2D
'Declare Operator * (Byref As point2D, Byref As point2D) As point2D

'-------------------------------------------------------------------
Operator + (Byref lhs As point2D, Byref rhs As point2D ) As point2D
Return Type<point2D>( lhs.x + rhs.x, lhs.y + rhs.y )
End Operator 

'-------------------------------------------------------------------
Operator * (Byref lhs As point2D, Byref rhs As point2D ) As point2D
Return Type<point2D>(_
lhs.x * rhs.x - lhs.y * rhs.y,_
lhs.x * rhs.y + lhs.y * rhs.x )
End Operator 

'-------------------------------------------------------------------
' end of point2D operators

'===================================================================
Const As Integer n = 3
Type polygon
    n As Integer    ' number of vertices for this polygon
    v(0 To n) As point2D    ' vertices relative to the zero reference point
    posn As point2D ' position now on the screen of the reference point
    t As Double     ' radian orientation of the polygon
End Type

Dim As Integer i, m = 35    ' number of darts on screen
Dim Shared As polygon dart(m) 
For i = 1 To m
    With dart(i)
        .n = 3
        .v(1).x = 50 + Rnd * 80 ' the point
        .v(1).y = 0
        .v(2).x = - Rnd * 25
        .v(2).y = 5 + Rnd * 15
        .v(3).x = .v(2).x
        .v(3).y = -.v(2).y
        .v(0) = .v(n)     ' duplicate to close
        .posn.x = Rnd * 800
        .posn.y = Rnd * 600
        .t = 0
    End With
Next i

Sub plot_dart(Byref j As Integer)
    With dart(j)
        Dim As point2D temp, r = Type<point2D>( Cos(.t), Sin(.t) )
        temp = (r * .v(0)) + .posn
        Pset (temp.x, temp.y), 14
        For i As Integer = 1 To .n
            temp = (r * .v(i)) + .posn    ' vector rotate then translate
            Line -(temp.x, temp.y), 14
        Next i
        Circle (.posn.x, .posn.y), 5, 13
    End With
End Sub

Dim As Integer mx, my
Do
    Screenlock
    Cls
    Getmouse (mx, my)
    For i = 1 To m
        With dart(i)
            .t = Atan2(my - .posn.y, mx - .posn.x)
            plot_dart(i)
        End With
    Next i
    Screenunlock
Loop Until Inkey <> ""

[badidea]

Pretty funny those darts.

I made some code which is almost completely useless (as most of my projects are), but this might be a nice place to post it.

It lets you draw line segments and highlights the nearest segment and nearest endpoint. And you can make drawings like this:

Code: Select all

#include "fbgfx.bi"

#DEFINE MOUSE_IDLE 0
#DEFINE MOUSE_POS_CHANGED 1
#DEFINE MOUSE_LB_PRESSED 2
#DEFINE MOUSE_LB_RELEASED 3
#DEFINE MOUSE_RB_PRESSED 4
#DEFINE MOUSE_RB_RELEASED 5
#DEFINE MOUSE_MB_PRESSED 6
#DEFINE MOUSE_MB_RELEASED 7
#DEFINE MOUSE_WHEEL_UP 8
#DEFINE MOUSE_WHEEL_DOWN 9

#DEFINE MAX_CONNECTORS 800
#DEFINE MAX_LINKS 400

#macro end_program(txt)
  Print txt: Beep: Sleep: End
#endmacro

type connectorType
  x as integer
  y as integer
end type

type linkType
  p0 as integer
  p1 as integer
end type

type mouseType
 x as integer
 y as integer
 wheel as integer
 buttons as integer
 lb as integer 'left button
 rb as integer 'right button
 mb as integer 'middle button
end type

dim shared as integer numLinks = 0, numConnectors = 0
dim shared as connectorType connector(MAX_CONNECTORS-1)
dim shared as linkType link(MAX_LINKS-1)

function handleMouse(byref mouse as mouseType) as integer
  static previous as mouseType
  dim as integer change = MOUSE_IDLE
  getmouse mouse.x, mouse.y, mouse.wheel, mouse.buttons
  if (mouse.buttons = -1) then
    mouse.lb = 0
    mouse.rb = 0
    mouse.mb = 0
  else
    mouse.lb = (mouse.buttons and 1)
    mouse.rb = (mouse.buttons shr 1) and 1
    mouse.mb = (mouse.buttons shr 2) and 1
  end if
  if (previous.x <> mouse.x or previous.y <> mouse.y) then
    change = MOUSE_POS_CHANGED
  end if
  if (previous.buttons <> mouse.buttons) then
    if (previous.lb = 0 and mouse.lb = 1) then change = MOUSE_LB_PRESSED
    if (previous.lb = 1 and mouse.lb = 0) then change = MOUSE_LB_RELEASED
    if (previous.rb = 0 and mouse.rb = 1) then change = MOUSE_RB_PRESSED
    if (previous.rb = 1 and mouse.rb = 0) then change = MOUSE_RB_RELEASED
    if (previous.mb = 0 and mouse.mb = 1) then change = MOUSE_MB_PRESSED
    if (previous.mb = 1 and mouse.mb = 0) then change = MOUSE_MB_RELEASED
  end if
  if (mouse.wheel > previous.wheel) then change = MOUSE_WHEEl_UP
  if (mouse.wheel < previous.wheel) then change = MOUSE_WHEEl_DOWN
  previous = mouse
  return change
end function

sub flipScreen()
  static as integer page1 = 0
  static as integer page2 = 1
  page1 = page1 xor 1
  page2 = page2 xor 1
  screenset page1, page2
end sub

function findNearsetConnector(x as integer, y as integer) as integer
  dim as integer i
  dim as integer iNearestConnector = 0
  dim as single dist, distNearestConnector = 1e6 'something big
  if (numConnectors = 0) then return -1
  for i = 0 to numConnectors-1
    dist = sqr((x - connector(i).x) * (x - connector(i).x) + _
               (y - connector(i).y) * (y - connector(i).y))
    if (dist < distNearestConnector) then
      distNearestConnector = dist
      iNearestConnector = i
    end if
  next
  return iNearestConnector
end function

function findNearsetLink(x0 as integer, y0 as integer) as integer
  dim as integer i
  dim as integer iNearestLink = 0
  dim as single dist, distNearestLink = 1e6 'something big
  dim as integer x1, y1, x2, y2
  dim as single lineLengthSquared, rfactor
  dim as single distConnector0, distConnector1
  'dim as single distConnector0, distConnector1, distNearestConnector
  if (numLinks = 0) then return -1
  for i = 0 to numLinks-1
    x1 = connector(link(i).p0).x
    y1 = connector(link(i).p0).y
    x2 = connector(link(i).p1).x
    y2 = connector(link(i).p1).y
    lineLengthSquared = (x2-x1) * (x2-x1) + (y2-y1) * (y2-y1)
    rfactor = ((x0-x1) * (x2-x1) + (y0-y1) * (y2-y1)) / lineLengthSquared
    if ((rfactor >= 0) and (rfactor <= 1)) then
      dist = abs((x2-x1) * (y1-y0) - (y2-y1) * (x1-x0)) / sqr(lineLengthSquared)
    else
      distConnector0 = sqr((x1-x0) * (x1-x0) + (y1-y0) * (y1-y0))
      distConnector1 = sqr((x2-x0) * (x2-x0) + (y2-y0) * (y2-y0))
      if (distConnector0 < distConnector1) then
        dist = distConnector0
      else
        dist = distConnector1
      end if
    end if
    if (dist < distNearestLink) then
      distNearestLink = dist
      iNearestLink = i
    end if
  next
  return iNearestLink
end function


dim as mousetype mouse
dim as integer mouseEvent
dim as integer startPointSet = 0, endPointSet = 0
dim as integer x0, y0, x1, y1
dim as integer i, nearestConnector, nearestLink

screen 20, 32, 2
screenset 0, 0

while not multikey(FB.SC_ESCAPE)
  mouseEvent = handleMouse(mouse)
  if (mouse.buttons <> -1) then
    select case mouseEvent
    case MOUSE_LB_PRESSED
      if (startPointSet = 0) then
        x0 = mouse.x
        y0 = mouse.y
        startPointSet = 1
      else
        if (endPointSet = 0) then
          endPointSet = 1
          x1 = mouse.x
          y1 = mouse.y
        end if
      end if
    case MOUSE_RB_PRESSED
      startPointSet = 0
    end select
  end if
  if (startPointSet = 1) and (endPointSet = 1) then
    startPointSet = 0
    endPointSet = 0
    connector(numConnectors).x = x0: connector(numConnectors).y = y0
    link(numLinks).p0 = numConnectors
    numConnectors += 1
    if (numConnectors > MAX_CONNECTORS-1) then end_program("MAX_CONNECTORS")
    connector(numConnectors).x = x1: connector(numConnectors).y = y1
    link(numLinks).p1 = numConnectors
    numConnectors += 1
    if (numConnectors > MAX_CONNECTORS-1) then end_program("MAX_CONNECTORS")
    numLinks += 1
    if (numLinks > MAX_LINKS-1) then end_program("MAX_LINKS")
  end if
  nearestConnector = findNearsetConnector(mouse.x, mouse.y)
  nearestLink = findNearsetLink(mouse.x, mouse.y)
  
  cls
  if (startPointSet = 1) and (endPointSet = 0) then
    line (x0, y0)-(mouse.x, mouse.y), &h00ffffff
  end if
  for i = 0 to numLinks-1
    line (connector(link(i).p0).x, connector(link(i).p0).y)_
        -(connector(link(i).p1).x, connector(link(i).p1).y), &h00ffff00
  next
  for i = 0 to numConnectors-1
    circle (connector(i).x, connector(i).y), 5, &h0000ff00
  next
  if (nearestConnector > -1) then
    circle (connector(nearestConnector).x, connector(nearestConnector).y), 5, &h00ff00ff
  end if
  if (nearestLink > -1) then
    line (connector(link(nearestLink).p0).x, connector(link(nearestLink).p0).y)_
        -(connector(link(nearestLink).p1).x, connector(link(nearestLink).p1).y), &h0000ffff
  end if
  
  locate 1,1: print "Use mouse to draw line sections";
  locate 3,1: print "numLinks: "; numLinks; " /"; MAX_LINKS;
  locate 4,1: print "numConnectors: "; numConnectors; " /"; MAX_CONNECTORS;
  locate 5,1: print "nearestConnector: "; nearestConnector;
  locate 6,1: print "nearestLink: "; nearestLink;
  
  flipscreen()
  sleep 1,1

wend 
sleep

[dodicat]

So let me ask you? Can you make an isosceles triangle point at the mouse from anywhere on screen?

Yes.

Hi Richard
Supreme code
And so easy to use.
Hope that you don't mind, but I couldn't resist a tweak.
It only took five minutes do fiddle this.
(Just this once)

Code: Select all

dim shared as integer xres,yres
'screeninfo xres,yres
xres=800
yres=700
Screenres xres,yres,32
dim im as any pointer
im=imagecreate(xres,yres,rgb(0,0,0))

dim shared as double pi=4*atn(1)
dim shared as double xc,yc,xp,yp
xc=xres/2
yc=yres/2
declare Function rr(first As Double, last As Double) As Double
Randomize Timer * 1e6
' Operators and routines for pointy maths
'-------------------------------------------------------------------
Type point2D
    x As Double
    y As Double
End Type

dim shared as double red,green,blue,delta,h1,h2
delta=50
red=0:green=.5:blue=1
#macro psetline(xf,yf,zf,xs,ys,zs)
scope
Dim As Single x1=xf
Dim As Single y1=yf
Dim As Single z1=zf
Dim As Single x2=xs
Dim As Single y2=ys
Dim As Single z2=zs
Dim As Single nx=x2-x1
Dim As Single ny=y2-y1
Dim As Single nz=z2-z1
Dim As Single length=Sqr(nx^2+ny^2+nz^2)
nx=nx/length
ny=ny/length
nz=nz/length
For i As Integer=0 To length 
    x1=x1+nx
    y1=y1+ny
    z1=z1+nz
    Dim col As Uinteger=(255-delta)*(z1-zf)/(zs-zf)+delta
    Pset im,(x1,y1),rgb(col*red,col*green,col*blue)
    Next i
    end scope
#endmacro
'MAKE A SKY
for z as integer=0 to xres
    psetline(z,0,0,z,yres,1)
    next z
    

'-------------------------------------------------------------------
' point2D operators are just complex maths operators
'-------------------------------------------------------------------
'Declare Operator + (Byref As point2D, Byref As point2D) As point2D
'Declare Operator * (Byref As point2D, Byref As point2D) As point2D

'-------------------------------------------------------------------
Operator + (Byref lhs As point2D, Byref rhs As point2D ) As point2D
Return Type<point2D>( lhs.x + rhs.x, lhs.y + rhs.y )
End Operator 

'-------------------------------------------------------------------
Operator * (Byref lhs As point2D, Byref rhs As point2D ) As point2D
Return Type<point2D>(_
lhs.x * rhs.x - lhs.y * rhs.y,_
lhs.x * rhs.y + lhs.y * rhs.x )
End Operator 

'-------------------------------------------------------------------
' end of point2D operators

'===================================================================
Const As Integer n = 3
Type polygon
    n As Integer    ' number of vertices for this polygon
    v(0 To n) As point2D    ' vertices relative to the zero reference point
    posn As point2D ' position now on the screen of the reference point
    t As Double     ' radian orientation of the polygon
End Type

Dim As Integer i, m = 10000'35    ' number of darts on screen
Dim Shared As polygon dart(m) 
For i = 1 To m
    With dart(i)
        .n = 3
        '.v(1).x = 50 + Rnd * 20'50'80 ' the point
        .v(1).x = rr(45,50) + Rnd * 20'50'80 ' the point
        .v(1).y = 0
        .v(2).x = - Rnd * 25
        .v(2).y = 5 + Rnd * 15
        .v(3).x = .v(2).x
        .v(3).y = -.v(2).y
        .v(0) = .v(n)     ' duplicate to close
        .posn.x = rr(-100,xres+100)'Rnd * xres'800
        .posn.y = yres-20'800'Rnd * 600
        .t = 0
    End With
Next i

Sub plot_dart(Byref j As Integer)
    With dart(j)
        Dim As point2D temp, r = Type<point2D>( Cos(.t), Sin(.t) )
        dim as point2d firsttemp
        'temp = (r * .v(0)) + .posn
        firsttemp=(r * .v(0)) + .posn
        'Pset (temp.x, temp.y), rgb(255,255,255)'14
        For i As Integer = 1 To .n
            
            temp = (r * .v(i)) + .posn    ' vector rotate then translate
            Line(firsttemp.x,firsttemp.y) -(temp.x, temp.y), rgb(0,rr(40,50),rr(100,200))'14
            'psetline(firsttemp.x,firsttemp.y,0,temp.x, temp.y,1)
            pset(temp.x,temp.y),rgb(rr(200,255),255,255)
            
            pset(firsttemp.x,firsttemp.y),rgb(0,rr(200,255),0)
            h1=(temp.x+firsttemp.x)/rr(.1,2.02)
            h2=(temp.y+firsttemp.y)/rr(.1,2.02)
            pset(h1,h2),rgb(255,255,255)
        Next i
        'Circle (.posn.x, .posn.y), 5, 13
    End With
End Sub

Function rr(first As Double, last As Double) As Double
    Function = Rnd * (last - first) + first
End Function
function ellipse(k as double)as point2d
    dim as point2d pt
    pt.x=xc+(yres/3)*2.2*cos(k)
    pt.y=yc+(yres/3)*rr(1,1.02)*sin(k)
    return pt
end function
Dim As double mx, my
dim pt as point2d
dim z as double
do
 z=z+.05
 pt=ellipse(z)
'Do
    Screenlock
    Cls
    put(0,0),im,pset
    'mx=pt.x
    'my=pt.y
    'Getmouse (mx, my)
    For i = 1 To m
        With dart(i)
            .t = Atan2(pt.y - .posn.y, pt.x - .posn.x)
            plot_dart(i)
        End With
    Next i
    Screenunlock
'Loop Until Inkey <> ""
if z>2*pi then z=0
loop until inkey=chr(27)
imagedestroy im
 

[rolliebollocks]

@Richard

My algo is pretty close to that.

I have -atan2(mouse-p)

Where p represents the direction of the head to center... You can calibrate all four polar nodes to the center and make it point that way... Works on sprites too.

Very cool.

Updated my lib... Run Sandbox.exe go into 2d Geo Demos and find the Axial Polygon Demo... source is there...

The Axial sprite demo is under sprite demos...

@Badidea

Nice! I need nearest routine... It would come in handy.

@Dodicat

Tom Jones? You mean the Tom Jones of "She's a Lady" and "It's not Unusual" fame, or do you mean some other Tom Jones. My literary background is psychoanalysis and deconstruction, so everything anyone writes I try to diagnose. So let me just say, I liked it.

[badidea]

@rolliebollocks

For the distance to line segment, I converted the c-code mentioned on this forum:
http://www.codeguru.com/forum/showthread.php?t=194400
I didn't want to figure it out completely by myself.

[dodicat]

@rolliebollocks

For the distance to line segment, I converted the c-code mentioned on this forum:
http://www.codeguru.com/forum/showthread.php?t=194400
I didn't want to figure it out completely by myself.

Hi badidea
Yes, this is the place for matchstick men and matchstick cats and dogs.

A line can be a plane end on.
Distance from a plane can be signed, while the distance from a point to a line can't. (by the vector method)
So in view of this, this end-on plane isn't in view, but you can say hello to it in the passing, and on saying hello you can become green or red, depending in which way you say hello.

Code: Select all

'Crossing the line
Dim As Integer xres,yres
screeninfo xres,yres
screenres xres,yres,32
dim im as any pointer
im=imagecreate(xres,yres,rgb(0,0,0))
Type PLANE     'points to define a plane (screen edges in this case)
    As Double x,y,z
End Type
type point3d  ' points for a point
    As Double x,y,z
End Type
Declare Function planedistance(v() As PLANE,p As point3d) As Double
Function rr(first As Double, last As Double) As Double
    Function = Rnd * (last - first) + first
End Function
Dim As plane line3d(1 To 3)
dim as point3d line_start,line_end
randomize
'start and end of plane edge
line_start.x=rr(0,xres)
line_start.y=rr(0,yres)
line_start.z=0

line_end.x=rr(0,xres)
line_end.y=rr(0,yres)
line_end.z=0
'A plane end on
line3d(1).x=line_start.x:line3d(1).y=line_start.y:line3d(1).z=0
line3d(2).x=line_end.x:line3d(2).y=line_end.y:line3d(2).z=line_end.z
line3d(3).x=line_start.x:line3d(3).y=line_start.y:line3d(3).z=10

dim as double temp,distance,kx=10,ky=10
dim as point3d p,d
dim colour as uinteger

d.x=rr(0,50) 'direction numbers
d.y=rr(0,50)
temp=sqr(d.x^2+d.y^2)
d.x=d.x/temp  'normalised direction numbers
d.y=d.y/temp
do
    p.x=p.x+kx*d.x  'MOTION
    p.y=p.y+ky*d.y
    'BOUNDARIES AT EDGES
    if p.x>xres then kx=-kx
    if p.x<0 then kx=-kx
    if p.y>yres then ky=-ky
    if p.y<0 then ky=-ky
    '*********************
    screenlock
    cls
    put(0,0),im,pset
    'line(line_start.x,line_start.y)-(line_end.x,line_end.y)
    distance=planedistance(line3d(),p)
    if abs(distance)<5 then draw string im,(p.x,p.y),"Hi",rgb(rr(0,255),rr(0,255),rr(0,255))
    if distance<0 then
        colour=rgb(200,0,0)
    else
        colour=rgb(0,200,0)
        end if
    circle(p.x,p.y),10,colour,,,,f
    screenunlock
    sleep 1,1
    loop until inkey=chr(27)
imagedestroy im

Function planedistance(v() As PLANE,p As point3d) As Double
    Type FUNCTION_VECTOR 'internal type 
    As Double x,y,z
    End Type

    Dim vct(1 To 2) As function_vector 'to vector multiply
    Dim As Double wx,wy,wz,nw,dist 'for the macros
 Dim As Double px,py,pz
       px=p.x-v(1).x  'get vector (components) from p to a point on v()
       py=p.y-v(1).y
       pz=p.z-v(1).z
    #macro unitcross(product)
    wx= vct(1).y*vct(2).z-vct(1).z*vct(2).y
    wy= -(vct(1).x*vct(2).z-vct(2).x*vct(1).z) 
    wz=vct(1).x*vct(2).y-vct(2).x*vct(1).y
    nw=Sqr(wx^2+wy^2+wz^2) 'normalizer(length)
    wx=wx/nw   'unit cross product components
    wy=wy/nw
    wz=wz/nw
    #endmacro
    
    #macro dot(product)
    dist=wx*px+wy*py+wz*pz  
    #endmacro
    vct(1).x=v(1).x-v(2).x:vct(2).x=v(2).x-v(3).x 'get 2 vectors on plane
    vct(1).y=v(1).y-v(2).y:vct(2).y=v(2).y-v(3).y
    vct(1).z=v(1).z-v(2).z:vct(2).z=v(2).z-v(3).z
       unitcross(0)  'get unit normal to plane
       dot(0) 'scalar multiply by px,py and pz above
    Return dist
End Function

[albert]

@Dodicat / Richard

I farted around and got a floating point addition routine that equals and in some instances goes a few ticks faster than Dodicats plus function.

Code: Select all

declare function add( n1 as string , n2 as string) as string 'floating point addition routine.
declare Function plus(NUM1 As String,NUM2 As String) As String 'Dodicats integer addition routine.

dim as string n1,n2,answer1,answer2
dim as double ts1,te1,tt1
dim as double ts2,te2,tt2

do
    'setup number 1
    n1=""
    for a as integer = 1 to 20000000
        n1=n1+chr(rnd*9+48)
    next
    n1=n1+"."
    for a as integer = 1 to 10
        n1=n1+chr(rnd*9+48)
    next
    
    'setup number 2
    n2=""
    for a as integer = 1 to 20000000
        n2=n2+chr(rnd*9+48)
    next
    n2=n2+"."
    for a as integer = 1 to 10
        n2=n2+chr(rnd*9+48)
    next

    
    'print n1
    'print
    'print n2
    'print
    
    ts1=timer
    answer1=add(n1,n2)
    te1=timer
    tt1=te1-ts1
    'print answer1
    
    ts2=timer
    answer2=plus(n1,n2)
    te2=timer
    tt2=te2-ts2
    'print answer2
    print tt1
    print tt2
    print
    
    if inkey =" " then sleep
    if inkey = chr(27) then end

loop

sleep

END

'=================================================
'alberts addition function
'=================================================
function add(n1 as string,n2 as string) as string
    dim as string num1 = n1 ,num2 = n2
    dim as ulongint len1,len2
    dim as string answer
    dim as integer carry
    dim as integer val1,val2,tot
    
    dim as string int1,frac1
    dim as string int2,frac2
    dim as ulongint dec1,dec2
    
    dec1=instr(1,num1,".")
    if dec1 >= 1 then
        int1=left(num1,dec1-1)
        frac1=mid(num1,dec1+1)
    else
        int1 = num1
        frac1=""
    end if
    
    dec2=instr(1,num2,".")
    if dec2 >= 1 then
        int2=left(num2,dec2-1)
        frac2=mid(num2,dec2+1)
    else
        int2 = num2
        frac2=""
    end if
    
    
    if len(int1)<len(int2) then int1 = int1 + string(len(int2)-len(int1),"0")
    if len(int2)<len(int1) then int2 = int2 + string(len(int1)-len(int2),"0")
    if len(frac1)<len(frac2) then frac1 = frac1 + string(len(frac2)-len(frac1),"0")
    if len(frac2)<len(frac1) then frac2 = frac2 + string(len(frac1)-len(frac2),"0")
    
    num1=int1+"."+frac1
    num2=int2+"."+frac2

    len1=len(num1)
    len2=len(num2)
    
    answer = string(len1,"0")
    carry=0
    
    dim as ulongint l1,l2,la
    l1=len(num1)-1
    l2=len(num2)-1
    la=len(answer)-1
    
    dim as ubyte ptr pt1,pt2,pta
    pt1 = cptr(ubyte ptr , strptr(num1))+l1
    pt2 = cptr(ubyte ptr , strptr(num2))+l2
    pta = cptr(ubyte ptr , strptr(answer))+la

    for a as integer = len1-1 to 0 step -1
        val1=*pt1-48
        val2=*pt2-48
        if val2>=0 then
            tot = (val1)+(val2)+carry+48
            carry=0
            if tot >=58 then 
                carry=1
                *pta = tot-10
            else
                *pta = tot
            end if
        else
            *pta=46
        end if
        pt1-=1
        pt2-=1
        pta-=1
    next
    
    if carry>0 then answer=str(carry)+answer
    
    return answer
end function    

'===================================================
'dodicats plus function
'===================================================
Function plus(NUM1 As String,NUM2 As String) As String
        Dim As Long lenf,lens
        Dim As Byte flag
        'Dim As String part1,part2
         'set up tables
            Dim As Ubyte Qmod(0 To 19)
            Dim bool(0 To 19) As Ubyte
For z As Integer=0 To 19
    Qmod(z)=cubyte(z Mod 10+48)
    bool(z)=cubyte(-(10<=z))
Next z

'macro insert a character into a string unused yet
'#macro insert(s,char,position)
 'part1=Mid$(s,1,position-1)
 'part2=Mid$(s,position)
 's=part1+char+part2
 '#endmacro
 
 #macro finish(three)
  three=Ltrim(three,"0")
        If three="" Then Return "0"
       If flag=1 Then Swap NUM2,NUM1
       Return three
       Exit Function
 #endmacro
 lenf=Len(NUM1)
 lens=Len(NUM2)
 If lens>lenf Then 
 Swap NUM2,NUM1
 Swap lens,lenf
 flag=1
 Endif

        Dim diff As Long=lenf-lens-Sgn(lenf-lens)
        Dim As String two,three',one
        three="0"+NUM1
        two=String(lenf-lens,"0")+NUM2
        Dim As Long n2
        Dim As Ubyte addup,addcarry
        Dim As Ubyte ten=10
        Dim As Ubyte ninetysix=96
        Dim As Ubyte fortyeight=48
        Dim As Ubyte zero=0
        addcarry=zero
           
         For n2=lenf-1 To diff Step -1 
          addup=two[n2]+NUM1[n2]-ninetysix
            three[n2+1]=Qmod(addup+addcarry)
            addcarry=bool(addup+addcarry)
        Next n2 
       
        If addcarry=zero Then 
        finish(three)
        Endif
        If n2=-1 Then 
        three[0]=addcarry+fortyeight
         finish(three)
        Endif

        For n2=n2 To 0 Step -1 
             addup=two[n2]+NUM1[n2]-ninetysix
               three[n2+1]=Qmod(addup+addcarry)
            addcarry=bool(addup+addcarry)
        Next n2
        three[0]=addcarry+fortyeight
    finish(three)
End Function

[dodicat]

@Dodicat / Richard

I farted around and got a floating point addition routine that equals and in some instances goes a few ticks faster than Dodicats plus function.

Hi Albert
Remember that my plus isn't yet prepared for decimals.
I've set plus and minus into two macros, my final plus and minus functions will call these macros and do the business with the decimal points.
Here's my _plus and _minus macros and your plus, without decimals.

Code: Select all

'*************** START DODICAT _PLUS AND _MINUS ************************
'set the variables
#macro big(enable)
Dim As Long num1_length,num2_length,diff
Dim As Ubyte add_Qmod(0 To 19)
dim as ubyte sub_qmod(0 to 19)
Dim add_bool(0 To 19) As Ubyte
dim sub_bool(0 to 19) as ubyte
For z As Integer=0 To 19
    add_Qmod(z)=cubyte(z Mod 10+48)
    add_bool(z)=cubyte(-(10<=z))
    
    sub_Qmod(z)=cubyte(z Mod 10+48)
    sub_bool(z)=cubyte(-(10>z))
Next z
        Dim As Byte swap_flag
        Dim bigger As Byte
        Dim As String Macro_answer,_two',one
        Dim As Long _z
        Dim As Ubyte carry_under,carry_over
        Dim As Ubyte ten=10
        Dim As Ubyte ninetysix=96
        Dim As Ubyte fortyeight=48
        Dim As Ubyte zero=0
        Dim sign As String * 1
        #endmacro
   ' END OF SETUP    
#macro _plus(NUM1,NUM2)
  Do  
Macro_answer=""
_two="" 
 #macro finish(x)
  Macro_answer=Ltrim(Macro_answer,"0")
        If Macro_answer="" Then 
        Macro_answer="0"
        If swap_flag=1 Then Swap num1,num2
        swap_flag=0
        Endif
       Exit Do
 #endmacro
 num1_length=Len(NUM1)
 num2_length=Len(NUM2)
 If num2_length>num1_length Then 
 Swap NUM2,NUM1
 Swap num2_length,num1_length
 swap_flag=1
 Endif

         diff=num1_length-num2_length-Sgn(num1_length-num2_length)
        Macro_answer="0"+NUM1
        _two=String(num1_length-num2_length,"0")+NUM2
        carry_over=zero
         For _z=num1_length-1 To diff Step -1 
          carry_under=_two[_z]+NUM1[_z]-ninetysix
            Macro_answer[_z+1]=add_Qmod(carry_under+carry_over)
            carry_over=add_bool(carry_under+carry_over)
        Next _z 
        If carry_over=zero Then 
        finish(0)
        Exit Do
        Endif
        
        If _z=-1 Then 
        Macro_answer[0]=carry_over+fortyeight
         finish(0)
         Exit Do
        Endif
       'continue the loop to the bitter end if needed
        For _z=_z To 0 Step -1 
             carry_under=_two[_z]+NUM1[_z]-ninetysix
               Macro_answer[_z+1]=add_Qmod(carry_under+carry_over)
            carry_over=add_bool(carry_under+carry_over)
        Next _z
        Macro_answer[0]=carry_over+fortyeight
    finish(0)
    Exit Do
    Loop
#endmacro

'new july 2010

#macro _minus(num1,num2)
        bigger=0
        num1_length=Len(NUM1)
        num2_length=Len(NUM2)
         #macro compare(numbers)
If num2_length>num1_length Then bigger= -1:Goto fin
    If num2_length<num1_length Then bigger =0:Goto fin
    If NUM2>NUM1 Then 
        bigger=-1
    Else
        bigger= 0
    End If
    fin:
#endmacro
compare(numbers)
If bigger Then 
sign="-"
Swap NUM2,NUM1
Swap num2_length,num1_length
swap_flag=1
Endif
        
         diff =num1_length-num2_length-Sgn(num1_length-num2_length)
       
        Macro_answer=NUM1
        _two=String(num1_length-num2_length,"0")+NUM2
        
        carry_over=0
        Do
         For _z=num1_length-1 To diff Step -1 
           carry_under= NUM1[_z]-_two[_z]+ten-carry_over
           Macro_answer[_z]=sub_Qmod(carry_under)
            carry_over=sub_bool(carry_under)
        Next _z 
        If carry_over=0 Then Exit Do
        If _z=-1 Then Exit Do
        For _z=_z To 0 Step -1 
            carry_under= NUM1[_z]-_two[_z]+ten-carry_over
            Macro_answer[_z]=sub_Qmod(carry_under)
            carry_over=sub_bool(carry_under)
            Next _z
        Exit Do
        Loop
        Macro_answer=Ltrim(Macro_answer,"0")
        If Macro_answer="" Then Macro_answer="0"
        If swap_flag=1 Then Swap NUM1,NUM2
       macro_answer= sign+Macro_answer
#endmacro
'********************** END DODICAT'S MACROS ***********************

'ALBERT'S ADD
Function add(n1 As String,n2 As String) As String
    Dim As String num1 = n1 ,num2 = n2
    Dim As Ulongint len1,len2
    Dim As String answer
    Dim As Integer carry
    Dim As Integer val1,val2,tot
    
    Dim As String int1,frac1
    Dim As String int2,frac2
    Dim As Ulongint dec1,dec2
    
    dec1=Instr(1,num1,".")
    If dec1 >= 1 Then
        int1=Left(num1,dec1-1)
        frac1=Mid(num1,dec1+1)
    Else
        int1 = num1
        frac1=""
    End If
    
    dec2=Instr(1,num2,".")
    If dec2 >= 1 Then
        int2=Left(num2,dec2-1)
        frac2=Mid(num2,dec2+1)
    Else
        int2 = num2
        frac2=""
    End If
    
    
    If Len(int1)<len(int2) Then int1 = int1 + String(Len(int2)-Len(int1),"0")
    If Len(int2)<len(int1) Then int2 = int2 + String(Len(int1)-Len(int2),"0")
    If Len(frac1)<len(frac2) Then frac1 = frac1 + String(Len(frac2)-Len(frac1),"0")
    If Len(frac2)<len(frac1) Then frac2 = frac2 + String(Len(frac1)-Len(frac2),"0")
    
    num1=int1+"."+frac1
    num2=int2+"."+frac2

    len1=Len(num1)
    len2=Len(num2)
    
    answer = String(len1,"0")
    carry=0
    
    Dim As Ulongint l1,l2,la
    l1=Len(num1)-1
    l2=Len(num2)-1
    la=Len(answer)-1
    
    Dim As Ubyte Ptr pt1,pt2,pta
    pt1 = cptr(Ubyte Ptr , Strptr(num1))+l1
    pt2 = cptr(Ubyte Ptr , Strptr(num2))+l2
    pta = cptr(Ubyte Ptr , Strptr(answer))+la

    For a As Integer = len1-1 To 0 Step -1
        val1=*pt1-48
        val2=*pt2-48
        If val2>=0 Then
            tot = (val1)+(val2)+carry+48
            carry=0
            If tot >=58 Then 
                carry=1
                *pta = tot-10
            Else
                *pta = tot
            End If
        Else
            *pta=46
        End If
        pt1-=1
        pt2-=1
        pta-=1
    Next
    
    If carry>0 Then answer=Str(carry)+answer
    
    Return answer
End Function    


'*********************** EXAMPLES ***********************
'Please note, if using the macro _plus, _minus, then the answer is held in
' the string macro_answer which is created in big(enable)
big(enable) 'MUST DO THIS FOR DODICAT'S MACROS

Dim As String n1,n2,answer1,answer2
Dim As Double ts1,te1,tt1
Dim As Double ts2,te2,tt2

print "Press space to start, then no other key"
sleep
print "building  two 20000000 digit numbers, please wait"
Do
    'setup number 1
    n1=""
    For a As Integer = 1 To 20000000
        n1=n1+Chr(Rnd*9+48)
    Next
    'n1=n1+"."
    'For a As Integer = 1 To 10
       ' n1=n1+Chr(Rnd*9+48)
    'Next
    
    'setup number 2
    n2=""
    For a As Integer = 1 To 20000000
        n2=n2+Chr(Rnd*9+48)
    Next
    'n2=n2+"."
    'For a As Integer = 1 To 10
       ' n2=n2+Chr(Rnd*9+48)
    'Next

    
    'print n1
    'print
    'print n2
    'print
    
    ts1=Timer
    answer1=add(n1,n2)
    te1=Timer
    tt1=te1-ts1
    'print answer1
    
    ts2=Timer
    _plus(n1,n2)
    answer2=macro_answer
    te2=Timer
    tt2=te2-ts2
    'print answer2
    Print "Albert  "; tt1
    Print "Dodicat ";tt2
    dim answer3 as string
    answer1=rtrim(answer1,".")'MUST GET RID OF ALBERT'S TRAILING POINT
    _minus(answer1,answer2)
    answer3=macro_answer
    Print
    print "Albert answer - Dodicat answer = ";answer3
    print "Press esc to quit or space for another"
    If Inkey =" " Then Sleep
    
    If Inkey = Chr(27) Then End
print "continuing, press spacebar now if you want to quit next time round"
Loop

Sleep

End