## Squares

General FreeBASIC programming questions.
dodicat
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: spiderweb

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

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
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: spiderweb

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,yresscreeninfo xres,yres'xres=700'yres=700screenres xres,yres,32windowtitle "Press spacebar or Hold down escape any time  "+"resolution = "+str(xres)+" x  "+str(yres)type point2d    as double x,yend typedeclare 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 Integerdeclare Function INpolygon(xx() As Double,yy() As Double,x As Double,y As Double) As Integerdeclare Function rr(first As Double, last As Double) As Doubledeclare 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 point2ddim as double polysize=yres/3 'SIZE OF POLY'Sdim 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 polygonsRedim xx2(0) As Double,yy2(0) As Doubledim as uinteger colour(1 to 3)dim shared as point2d pivotdim  as point2d pivot1,pivot2dim as integer sides1=rr(3,9),sides2=rr(3,7)'random number of sidesDim As Double leftmargin,rightmargin,topmargin,basemargin,tempdim 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 zzcase 1colour(1)=255:colour(2)=100:colour(3)=0case 2    colour(1)=0end 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               randomizemakepolygon(sides1,.3*yres,.3*yres,xx(),yy(),polysize)pivot1.x=pivot.x:pivot1.y=pivot.ymakepolygon(sides2,.7*yres,.7*yres,xx2(),yy2(),polysize)pivot2.x=pivot.x:pivot2.y=pivot.ydim as point2d d1,d2  'the direction numbersd1.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 BOUNDARIESif 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 INTERACTIONfor 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    clsgetcolour(1)turnpolygon(a1,pivot1,xx(),yy(),d1) 'TURN AND MOVE POLYGONSdrawpolygon(xx(),yy(),colour())getcolour(2)turnpolygon(a2,pivot2,xx2(),yy2(),d2)drawpolygon(xx2(),yy2(),colour())screenunlocksleep 1,1loop until inkey=" "loop sleepFunction 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=0dim as double sumx,sumyFor 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=sumyEnd Subsub 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 subfunction 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/180dim as point2d npnp.x=dilator*(Cos(angle rad)*(_point.x-pivot.x)-Sin(angle rad)*(_point.y-pivot.y)) +pivot.xnp.y=dilator*(Sin(angle rad)*(_point.x-pivot.x)+Cos(angle rad)*(_point.y-pivot.y)) +pivot.yreturn npEnd functionsub 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,sumyfor 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 zpivot.x=sumx/ubound(x)pivot.y=sumy/ubound(x)end subFunction rr(first As Double, last As Double) As Double    Function = Rnd * (last - first) + firstEnd Function`
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york
@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
Posts: 3036
Joined: Jan 15, 2007 20:44
Location: Australia
@ 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
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland
@ 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,yresscreeninfo xres,yres'xres=700'yres=700screenres xres,yres,32windowtitle "Press spacebar or Press escape any time  "+"resolution = "+Str(xres)+" x  "+Str(yres)Type point2d    As Double x,yEnd TypeDeclare 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 IntegerDeclare Function INpolygon(xx() As Double,yy() As Double,x As Double,y As Double) As IntegerDeclare Function rr(first As Double, last As Double) As DoubleDeclare 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 point2dDim As Double polysize=yres/4 'SIZE OF POLY'SDim As Double a1=0,a2=0    'ANGLE TURN RATE OF POLY'S(degrees per loop)dim shared translatespeed as double=1.001dim bounce as double=10dim shared as double speed1,speed2Redim  xx(0) As Double,yy(0) As Double 'for the polygonsRedim xx2(0) As Double,yy2(0) As DoubleDim As Uinteger colour(1 To 3)Dim Shared As point2d pivotDim  As point2d pivot1,pivot2Dim As Integer sides1=rr(30,60),sides2=rr(3,10)'random number of sidesDim As Double leftmargin,rightmargin,topmargin,basemargin,tempDim As Double dx,dy,nx,ny,switch=4dim as double vel1,vel2dim 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 zzCase 1colour(1)=255:colour(2)=100:colour(3)=0Case 2    colour(1)=0End 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 Thengetsideimpulse(1) d1.x=d1.x+bounce*rightimpulse(1) a1=atn(d1.x/d1.y)    'a2=atn(d2.x/d2.y) end ifIf 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=translatespeedend ifIf 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 ifIf 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 ifIf 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 ifIf 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 ifIf 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 ifIf 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.ymakepolygon(sides2,.7*yres,.7*yres,xx2(),yy2(),polysize)pivot2.x=pivot.x:pivot2.y=pivot.yDim As point2d d1,d2  'the direction numbersd1.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 POLYGONSdrawpolygon(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=translatespeedDo  settledown()dont_go_too_far_away_dear()You_are_cheeky()    screenlock    ClsLets_dance()a1=0:a2=0 'zero rotation until the next boundary or poly to polyscreenunlockSleep 1,1i=Inkey    If i=Chr(27) Then End    if i=" " then exit doLoop 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=0Dim As Double sumx,sumyFor 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=sumyEnd SubSub 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 SubFunction 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/180Dim As point2d npnp.x=dilator*(Cos(angle rad)*(_point.x-pivot.x)-Sin(angle rad)*(_point.y-pivot.y)) +pivot.xnp.y=dilator*(Sin(angle rad)*(_point.x-pivot.x)+Cos(angle rad)*(_point.y-pivot.y)) +pivot.yReturn npEnd FunctionSub 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,sumyFor 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 zpivot.x=sumx/Ubound(x)pivot.y=sumy/Ubound(x)End SubFunction rr(first As Double, last As Double) As Double    Function = Rnd * (last - first) + firstEnd Function `
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york
@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
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland
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
Posts: 3036
Joined: Jan 15, 2007 20:44
Location: Australia
rolliebollocks wrote:So let me ask you? Can you make an isosceles triangle point at the mouse from anywhere on screen?
Yes.

Code: Select all

`Screen 19Randomize Timer * 1e6' Operators and routines for pointy maths'-------------------------------------------------------------------Type point2D    x As Double    y As DoubleEnd 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 point2DReturn Type<point2D>( lhs.x + rhs.x, lhs.y + rhs.y )End Operator '-------------------------------------------------------------------Operator * (Byref lhs As point2D, Byref rhs As point2D ) As point2DReturn 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 = 3Type 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 polygonEnd TypeDim As Integer i, m = 35    ' number of darts on screenDim 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 WithNext iSub 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 WithEnd SubDim As Integer mx, myDo    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    ScreenunlockLoop Until Inkey <> ""`
Posts: 2150
Joined: May 24, 2007 22:10
Location: The Netherlands
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#endmacrotype connectorType  x as integer  y as integerend typetype linkType  p0 as integer  p1 as integerend typetype 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 buttonend typedim shared as integer numLinks = 0, numConnectors = 0dim 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 changeend functionsub flipScreen()  static as integer page1 = 0  static as integer page2 = 1  page1 = page1 xor 1  page2 = page2 xor 1  screenset page1, page2end subfunction 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 iNearestConnectorend functionfunction 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 iNearestLinkend functiondim as mousetype mousedim as integer mouseEventdim as integer startPointSet = 0, endPointSet = 0dim as integer x0, y0, x1, y1dim as integer i, nearestConnector, nearestLinkscreen 20, 32, 2screenset 0, 0while 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,1wend sleep`
Last edited by badidea on Jan 16, 2011 17:58, edited 1 time in total.
dodicat
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland
Richard wrote:
rolliebollocks wrote: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,yresxres=800yres=700Screenres xres,yres,32dim im as any pointerim=imagecreate(xres,yres,rgb(0,0,0))dim shared as double pi=4*atn(1)dim shared as double xc,yc,xp,ypxc=xres/2yc=yres/2declare Function rr(first As Double, last As Double) As DoubleRandomize Timer * 1e6' Operators and routines for pointy maths'-------------------------------------------------------------------Type point2D    x As Double    y As DoubleEnd Typedim shared as double red,green,blue,delta,h1,h2delta=50red=0:green=.5:blue=1#macro psetline(xf,yf,zf,xs,ys,zs)scopeDim As Single x1=xfDim As Single y1=yfDim As Single z1=zfDim As Single x2=xsDim As Single y2=ysDim As Single z2=zsDim As Single nx=x2-x1Dim As Single ny=y2-y1Dim As Single nz=z2-z1Dim As Single length=Sqr(nx^2+ny^2+nz^2)nx=nx/lengthny=ny/lengthnz=nz/lengthFor 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 SKYfor 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 point2DReturn Type<point2D>( lhs.x + rhs.x, lhs.y + rhs.y )End Operator '-------------------------------------------------------------------Operator * (Byref lhs As point2D, Byref rhs As point2D ) As point2DReturn 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 = 3Type 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 polygonEnd TypeDim As Integer i, m = 10000'35    ' number of darts on screenDim 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 WithNext iSub 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 WithEnd SubFunction rr(first As Double, last As Double) As Double    Function = Rnd * (last - first) + firstEnd Functionfunction 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 ptend functionDim As double mx, mydim pt as point2ddim z as doubledo 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=0loop until inkey=chr(27)imagedestroy im `
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york
@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...

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.
Posts: 2150
Joined: May 24, 2007 22:10
Location: The Netherlands
@rolliebollocks

For the distance to line segment, I converted the c-code mentioned on this forum:
I didn't want to figure it out completely by myself.
dodicat
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland

For the distance to line segment, I converted the c-code mentioned on this forum:
I didn't want to figure it out completely by myself.

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 lineDim As Integer xres,yresscreeninfo xres,yresscreenres xres,yres,32dim im as any pointerim=imagecreate(xres,yres,rgb(0,0,0))Type PLANE     'points to define a plane (screen edges in this case)    As Double x,y,zEnd Typetype point3d  ' points for a point    As Double x,y,zEnd TypeDeclare Function planedistance(v() As PLANE,p As point3d) As DoubleFunction rr(first As Double, last As Double) As Double    Function = Rnd * (last - first) + firstEnd FunctionDim As plane line3d(1 To 3)dim as point3d line_start,line_endrandomize'start and end of plane edgeline_start.x=rr(0,xres)line_start.y=rr(0,yres)line_start.z=0line_end.x=rr(0,xres)line_end.y=rr(0,yres)line_end.z=0'A plane end online3d(1).x=line_start.x:line3d(1).y=line_start.y:line3d(1).z=0line3d(2).x=line_end.x:line3d(2).y=line_end.y:line3d(2).z=line_end.zline3d(3).x=line_start.x:line3d(3).y=line_start.y:line3d(3).z=10dim as double temp,distance,kx=10,ky=10dim as point3d p,ddim colour as uintegerd.x=rr(0,50) 'direction numbersd.y=rr(0,50)temp=sqr(d.x^2+d.y^2)d.x=d.x/temp  'normalised direction numbersd.y=d.y/tempdo    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 imFunction 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 distEnd Function`
albert
Posts: 5916
Joined: Sep 28, 2006 2:41
Location: California, USA

@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,answer2dim as double ts1,te1,tt1dim as double ts2,te2,tt2do    '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 endloopsleepEND'================================================='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 answerend 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 UbyteFor 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=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=addcarry+fortyeight    finish(three)End Function`
dodicat
Posts: 6720
Joined: Jan 10, 2006 20:30
Location: Scotland

albert wrote:@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,diffDim As Ubyte add_Qmod(0 To 19)dim as ubyte sub_qmod(0 to 19)Dim add_bool(0 To 19) As Ubytedim sub_bool(0 to 19) as ubyteFor 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=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=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:#endmacrocompare(numbers)If bigger Then sign="-"Swap NUM2,NUM1Swap num2_length,num1_lengthswap_flag=1Endif                 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 ADDFunction 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 answerEnd 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 MACROSDim As String n1,n2,answer1,answer2Dim As Double ts1,te1,tt1Dim As Double ts2,te2,tt2print "Press space to start, then no other key"sleepprint "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 Endprint "continuing, press spacebar now if you want to quit next time round"LoopSleepEnd`