Squares

General FreeBASIC programming questions.
Locked
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Mul_Loop_7

Post by albert »

@Dodicat
@Richard

(Humor)
she eight minutes fast = she ate me nuts fast
she's a whole four minutes = she's a hole for me nuts
(HAHAHA)

I beat my multiplier_7 time by .12 seconds

new mul = 1.18 seconds for 100,000 x 100,000 digits
old mul = 1.30 seconds for 100,000 x 100,000 digits

Dodicat What timings do you get with Geany and -o3 optimization ??

Heres Mul_Loop_7

Code: Select all



Declare Function mul_loop_7( num1 as string , num2 as string ) as string 

DECLARE FUNCTION multiplier_7(byref num1 as string, byref num2 as string) as string

DECLARE Function minus(NUM1 As String,NUM2 As String) As String
Declare Function       plus( NUMber1 As String  ,  NUMber2 As String ) As String

screen 19

do 
    
    dim as string num1
    dim as string num2
    for a as longint = 1 to 100000 step 1
        num1+=str(int(rnd*10))
    next
    for a as longint = 1 to 100000 step 1
        num2+=str(int(rnd*10))
    next
    if len(num2) < len(num1)  then swap num1 , num2
        
    print
    print num1
    print num2
    
    dim as double t1 , t2 , t3 , t4
    
    t1 = timer
        dim as string answer = mul_loop_7( num1,num2 )
    t2 = timer
    
    t3 = timer
        dim as string real_answer = multiplier_7( num1 , num2 )
        real_answer = rtrim( real_answer,".")
    t4 = timer
        
    dim as string difference = minus( answer , real_answer )
    
    print answer
    print real_answer
    print "Difference = " ; difference
    print "Mul_loop     Time = " ; t2 - t1
    print "Multiplier_7 Time = " ; t4 - t3
        
    sleep
    
loop until inkey=chr(27)

sleep
end

'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
function mul_loop_7( num1 as string , num2 as string ) as string 
    
    dim as string number1 = num1
    dim as string number2 = num2
    
    'make numbers equal multiple of 7 bytes
    dim as string str1
    dim as longint dec1
    do
        str1 = str(len(number1)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number1 = "0" + number1
    loop until dec1 = 0
    do
        str1 = str(len(number2)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number2 = "0" + number2
    loop until dec1 = 0
        
    'convert the numeric strings to use pointers
    'convert number1
    dim as string n1 = string(len(number1)*8,chr(0))
    dim as ulongint ptr ulp1 = cptr(ulongint ptr,strptr(n1))
    dim as longint valu1
    dim as longint len_1 = 0
    for a as longint = 0 to len(number1)-1 step 7
        valu1  = (number1[a     ]-48)*1e6
        valu1+= (number1[a+1]-48)*1e5
        valu1+= (number1[a+2]-48)*1e4
        valu1+= (number1[a+3]-48)*1e3
        valu1+= (number1[a+4]-48)*1e2
        valu1+= (number1[a+5]-48)*1e1
        valu1+= (number1[a+6]-48)'*1
        *ulp1 = valu1
        ulp1+=1
        len_1+=8
    next
    number1 = left(n1,len_1)
    n1=""
    
    'convert the numeric strings to use pointers
    'convert number2
    dim as string n2 = string(len(number2)*8,chr(0))
    dim as ulongint ptr ulp2 = cptr(ulongint ptr,strptr(n2))
    dim as longint valu2
    dim as longint len_2 = 0
    for a as longint = 0 to len(number2)-1 step 7
        valu2 =  (number2[a     ]-48)*1e6
        valu2+= (number2[a+1]-48)*1e5
        valu2+= (number2[a+2]-48)*1e4
        valu2+= (number2[a+3]-48)*1e3
        valu2+= (number2[a+4]-48)*1e2
        valu2+= (number2[a+5]-48)*1e1
        valu2+= (number2[a+6]-48)'*1
        *ulp2 = valu2
        ulp2+=1
        len_2+=8
    next
    number2 = left(n2,len_2)
    n2=""
    
    'create accumulator
    dim as string answer = string( len(number1) + len(number2) , chr(0) ) 
    dim as ulongint outblocks = ( len(answer) \ 8 ) 
    dim as ulongint ptr outplace = cptr(ulongint ptr , strptr(answer)) + (outblocks - 1 )
    dim as ulongint stops = ( (len(number1)\8) + (len(number2)\8) )
    dim as ulongint value = 0 
    dim as longint hold = -1
    dim as longint locat = 0
    dim as longint vals = 0 
    dim as ulongint high1 = ( len(number1)  \ 8 ) - 1
    dim as ulongint high2 = ( len(number2)  \ 8 ) - 1
    dim as longint ptr num1_ptr = cptr( ulongint ptr , strptr(number1) ) + high1
    dim as longint ptr num2_ptr = cptr( ulongint ptr , strptr(number2) ) + high2
    do
        hold+=1
        vals = hold
        locat = 0
        if vals > high2 then vals = high2 : locat = (hold - high2)
        num1_ptr = cptr( ulongint ptr , strptr(number1) ) + high1 - locat
        num2_ptr = cptr( ulongint ptr , strptr(number2) ) + high2 - vals
        do
            value+= *( num1_ptr ) * *( num2_ptr )
            num1_ptr-=1
            num2_ptr+=1
            if num1_ptr = cptr( ulongint ptr , strptr(number1) ) - 1 then goto done
            if num2_ptr > cptr( ulongint ptr , strptr(number2) ) + high2  then goto done
        loop
        Done:
        *outplace = value mod 1e7
         outplace-= 1
         value = value \ 1e7
    loop until hold = stops-2
    
     *outplace = value mod 1e7
       
    'convert answer back to ascii
   dim as string outtext=""
   outplace = cptr( ulongint ptr , strptr(answer) )
   for a as ulongint = 1 to outblocks step 1
       value = *outplace
       outplace+=1
       outtext+= right("0000000" + str(value),7)
    next    
    
   outtext = ltrim(outtext,"0")
    
   return outtext
    
end function
'===============================================================================
'===============================================================================
'Dodicats plus & Minus functions
'===============================================================================
'===============================================================================
    Function plus(_num1 As String,_num2 As String) As String
        Dim  ADDQmod(0 To 19) As Ubyte
        Dim  ADDbool(0 To 19) As Ubyte
        For z As Integer=0 To 19
            ADDQmod(z)=(z Mod 10+48)
            ADDbool(z)=(-(10<=z))
        Next z
        Var _flag=0,n_=0
        Dim As Ubyte addup=Any,addcarry=Any
        #macro finish()
        answer=Ltrim(answer,"0")
        If _flag=1 Then Swap _num2,_num1
        Return answer
        #endmacro
        If Len(_num2)>Len(_num1) Then 
            Swap _num2,_num1
            _flag=1
        End If
        Var diff=Len(_num1)-Len(_num2)
        Var answer="0"+_num1
        addcarry=0
        For n_=Len(_num1)-1 To diff Step -1 
            addup=_num2[n_-diff]+_num1[n_]-96
            answer[n_+1]=ADDQmod(addup+addcarry)
            addcarry=ADDbool(addup+addcarry)
        Next n_ 
        If addcarry=0 Then 
            finish()
        End If
        If n_=-1 Then 
            answer[0]=addcarry+48
            finish()
            Endif
            For n_=n_ To 0 Step -1 
                addup=_num1[n_]-48
                answer[n_+1]=ADDQmod(addup+addcarry)
                addcarry=ADDbool(addup+addcarry)
                If addcarry=0 Then Exit For
            Next n_
            answer[0]=addcarry+48
            finish()
        End Function
'===============================================================================
'===============================================================================
Function minus(NUM1 As String,NUM2 As String) As String
     'Dim As String copyfirstnum=mul_num_1,copysecondnum=mul_num_2
    Dim As Byte swapflag            
    Dim As Long lenf,lens
    Dim sign As String * 1
    'Dim As String part1,part2
    Dim bigger As Byte
     '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
    lenf=Len(NUM1)
    lens=Len(NUM2)
    #macro compare(numbers)
        If Lens>lenf Then bigger= -1:Goto fin
        If Lens<lenf 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 lens,lenf
        swapflag=1
    Endif
    'lenf=Len(NUM1)
    'lens=Len(NUM2)
    Dim diff As Long=lenf-lens-Sgn(lenf-lens)
    Dim As String one,two,three
    three=NUM1
    two=String(lenf-lens,"0")+NUM2
    one=NUM1
    Dim As Long n2
    Dim As Ubyte takeaway,subtractcarry
    Dim As Ubyte ten=10
    'Dim z As Long
    subtractcarry=0
    Do
         For n2=lenf-1 To diff Step -1 
           takeaway= one[n2]-two[n2]+ten-subtractcarry
           three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
        Next n2 
        If subtractcarry=0 Then Exit Do
        If n2=-1 Then Exit Do
        For n2=n2 To 0 Step -1 
            takeaway= one[n2]-two[n2]+ten-subtractcarry
            three[n2]=Qmod(takeaway)
            subtractcarry=bool(takeaway)
            Next n2
        Exit Do
    Loop
    
    three=Ltrim(three,"0")
    If three="" Then Return "0"
    If swapflag=1 Then Swap NUM1,NUM2
   
    Return sign+three
    
End Function
'===============================================================================
'===============================================================================
function multiplier_7(byref num1 as string, byref num2 as string) as string
    
    dim as string number1,number2
    dim as string answer,outtext
    
    dim as string int1,frac1,int2,frac2
    dim as ulongint dec,dec1,len1,len2
    dim as string str1
    dim as string sign1,sign2,outsign
    
    number1 = num1
    number2 = num2
    
    sign1 = left(number1,1)
    if sign1 = "+" or sign1 = "-" then number1 = mid(number1,2) else sign1 = ""
    
    sign2 = left(number2,1)
    if sign2 = "+" or sign2 = "-" then number2 = mid(number2,2) else sign2 = ""
    
    if (sign1 = sign2) then outsign = ""
    if (sign1 <> sign2) then outsign = "-"
    
    dec = instr(1,number1,".")
    if dec > 0 then 
        int1 = left(number1,dec-1)
        frac1 = mid(number1,dec+1)
    else
        int1 = number1
        frac1 = ""
    end if
    
    dec = instr(1,number2,".")
    if dec > 0 then 
        int2 = left(number2,dec-1)
        frac2 = mid(number2,dec+1)
    else
        int2 = number2
        frac2 = ""
    end if

    dec = len(frac1)+len(frac2)
    number1 = int1+frac1
    number2 = int2+frac2

    'swap numbers so that bigger number is number1 and smaller is number2
    if len(number2) > len(number1) then swap number1,number2
    if len(number1) = len(number2) then 
        if val(left(number2,1)) > val(left(number1,1)) then swap number1,number2
    end if

    'make numbers equal multiple of 7 bytes
    do
        str1 = str(len(number1)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number1 = "0" + number1
    loop until dec1 = 0
    do
        str1 = str(len(number2)/7)
        dec1 = instr(1,str1,".")
        if dec1 <> 0 then number2 = "0" + number2
    loop until dec1 = 0
    
    'convert the numeric strings to use pointers
    'convert number1
    dim as string n1 = string(len(number1)*8,chr(0))
    dim as ulongint ptr ulp1 
    ulp1 = cptr(ulongint ptr,strptr(n1))
    dim as longint val1
    dim as longint len_1 = 0
    dim as uinteger a
    for a = 0 to len(number1)-1 step 7
        val1 = (number1[a+0]-48)*1000000ull
        val1+= (number1[a+1]-48)*100000ull
        val1+= (number1[a+2]-48)*10000ull
        val1+= (number1[a+3]-48)*1000ull
        val1+= (number1[a+4]-48)*100ull
        val1+= (number1[a+5]-48)*10ull
        val1+= (number1[a+6]-48)*1ull
        *ulp1 = val1
        ulp1+=1
        len_1+=8
    next
    number1 = left(n1,len_1)
    n1=""
    
    'convert the numeric strings to use pointers
    'convert number2
    dim as string n2 = string(len(number2)*8,chr(0))
    dim as ulongint ptr ulp2
    ulp2 = cptr(ulongint ptr,strptr(n2))
    dim as longint val2
    dim as longint len_2 = 0
    for a = 0 to len(number2)-1 step 7
        val2 = (number2[a+0]-48)*1000000ull
        val2+= (number2[a+1]-48)*100000ull
        val2+= (number2[a+2]-48)*10000ull
        val2+= (number2[a+3]-48)*1000ull
        val2+= (number2[a+4]-48)*100ull
        val2+= (number2[a+5]-48)*10ull
        val2+= (number2[a+6]-48)*1ull
        *ulp2 = val2
        ulp2+=1
        len_2+=8
    next
    number2 = left(n2,len_2)
    n2=""
    
    'create accumulator
    answer = string( len(number1) + len(number2) + 8 , chr(0) ) 
    'dimension vars for the mul
    dim as longint ptr start1,stop1,start2,stop2 'use longint because the pointers go negative
    dim as longint ptr chk_1 , chk_2
    dim as longint ptr inc1,inc2
    dim as longint ptr outplace
    dim as ulongint carry
    dim as ulongint total
    dim as ulongint blocknumber1 = len(number1)/8
    dim as ulongint blocknumber2 = len(number2)/8
    dim as ulongint outblocks = len(answer)/8
    
    'set initial accumulator place
    outplace = cptr(longint ptr , strptr(answer)) + (outblocks - 1)
    'set initial pointers into number1 
    start1 = cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    stop1 =  cptr(longint ptr , strptr(number1))+(blocknumber1-1)
    'set initial pointers into number2
    start2 = cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    stop2 =  cptr(longint ptr , strptr(number2))+(blocknumber2-1)
    'set comparison to beg of numbers
    chk_1 = cptr( longint ptr , strptr(number1))
    chk_2 = cptr( longint ptr , strptr(number2))
    
    'zero the carry
    carry = 0
    
    'begin looping thru strings multiplying
    do
        'set total to zero
        total = 0
        'we are going to be incrementing thru number2 while decrementing thru number1
        'working in opposite directions from start1 to stop1 and start2 to stop2
        'inc1 works from right to left in the top number1 string
        'inc2 works from start2 to stop 2, in the bottom number2 string, decrementing each loop.
        inc1 = start1
        inc2 = start2
        do
            total += *inc1 * *inc2
            inc1-= 1
            inc2+= 1
        loop until inc2 = stop2+1
    
        total = total + carry
        carry = total \ 1e7
        *outplace = total mod 1e7
        '*outplace = imod(total , 1e7)
        
        outplace -= 1
        
        'each loop we need to decrement stop1
        'if stop1 goes negative we reset it to zero and decrement stop2
        stop1 -= 1
        if stop1 < chk_1 then
            stop1 += 1
            stop2 -=1
            if stop2 < chk_2 then stop2+= 1
        end if
        'each loop we decrement start2 to the left
        start2 -= 1
        'if start2 goes negative we reset it to zero and decrement start1
        'start1 is the rightmost digit of number1 we need to multiply
        if start2 < chk_2 then
            start2 += 1
            start1 -= 1
            if start1 < chk_1 then start1+=1
        end if
    
    loop until outplace = cptr(ulongint ptr,strptr(answer))+1
    
    'put in the carry at the end
    if carry > 0  then *outplace = carry else *outplace = 0
    
    'convert answer back to ascii
    for a as ulongint = 1 to outblocks-1 step 1
        val1 = *outplace
        outplace +=1
        outtext = outtext + right("0000000" + str(val1),7)
    next    

    'put in the decimal point
    outtext = left(outtext,len(outtext)-dec) + "." +  mid(outtext,(len(outtext)-dec)+1)
    'trim leading zeros
    outtext = trim(outtext,"0") 'if multiplying by 1, we have a zero in front.
    outtext = outsign + outtext

    return outtext

end function
'===============================================================================
'===============================================================================

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

Re: Squares

Post by dodicat »

Hi Albert
Both 64 and 32 bit compilers.

Code: Select all


64 bit compiler
-Wc -O3

Difference = 0
Mul_loop     Time =  0.2358976216055453
Multiplier_7 Time =  0.4173078187741339

Difference = 0
Mul_loop     Time =  0.2348204045556486
Multiplier_7 Time =  0.4161710599437356

Difference = 0
Mul_loop     Time =  0.2349849981255829
Multiplier_7 Time =  0.4161337614059448

Difference = 0
Mul_loop     Time =  0.2343303868547082
Multiplier_7 Time =  0.4164164108224213

Difference = 0
Mul_loop     Time =  0.2343245693482459
Multiplier_7 Time =  0.4162613986991346

'====================================================

32 bit compiler
-Wc -O3


Difference = 0
Mul_loop     Time =  0.6235340530984104
Multiplier_7 Time =  0.5633984226733446

Difference = 0
Mul_loop     Time =  0.6219404693692923
Multiplier_7 Time =  0.5635958672501147

Difference = 0
Mul_loop     Time =  0.6216441323049367
Multiplier_7 Time =  0.5631017428822815

Difference = 0
Mul_loop     Time =  0.6216571354307234
Multiplier_7 Time =  0.5630206437781453

Difference = 0
Mul_loop     Time =  0.621824124827981
Multiplier_7 Time =  0.5656483289785683



 
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

How fast does it do 1,000,000 x 1,000,000 digits? With the -O3 optimization?
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert

Code: Select all

1000000 * 1000000 digits multiply:

64 bit compiler -O3
Difference = 0
Mul_loop     Time =  22.80171670438722
Multiplier_7 Time =  40.93220921279863






32 bit compiler -O3
Difference = 0
Mul_loop     Time =  60.44105964247137
Multiplier_7 Time =  55.05824228748679



 
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

So it's 18 seconds faster than the Multiplier_7()
Thanks!
I haven't downloaded the FreeBASIC for Linux , so i couldn't test it myself.
srvaldez
Posts: 3379
Joined: Sep 25, 2005 21:54

Re: Squares

Post by srvaldez »

dodicat wrote: Binary stars are ten a penny.
Binary planets are as yet an unknown entity, so this is purely a guess as to what they are like in the cosmos.
viewtopic.php?p=238936#p238936
very nice dodicat, compiles and runs ok on my Mac (even the mouse functions)
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Thanks for testing srvaldez.

I have an old book here:
<cough!> It is a bit dusty.

Microsoft QuickBASIC for Apple Macintosh Systems.
All you need is 128 K rom.
It looks like a 1988 edition.
571 pages.
Example page 250 -- point (Very slightly altered for fb)

Code: Select all

'page 250
'Microsoft quick basic for Apple Macintosh Systems.
#lang "qb"
screen 12
defint x,y
r$="y"

while r$="y"
    cls
    input "Angle of tilt in degrees: ",ang
    ang=(3.1415926#/180)*ang
    cs=cos(ang)
    sn=sin(ang)
    circle(45,70),50,,,,2
    for y=20 to 120
        for x=20 to 70
            if point(x,y)=15 then 
                xnew=(x*cs-y*sn)+200:ynew=(x*sn+y*cs)+200
                pset (xnew,ynew)
                end if
            next
        next
        locate 10,1:print "New Angle?":r$=input$(1)
    wend
     
srvaldez
Posts: 3379
Joined: Sep 25, 2005 21:54

Re: Squares

Post by srvaldez »

hello dodicat
works ok here, I should still have MS Quickbasic for Mac installed on my antique Mac II Ci.
srvaldez
Posts: 3379
Joined: Sep 25, 2005 21:54

Re: Squares

Post by srvaldez »

found a backup of the old Mac HD and using Mini vMac was able to run QB for Mac, somehow it lost it's appeal, nostalgia works better with a bottle of wine. :-)
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

(!!~~OFF TOPIC~~!!)

I wrote a "Country Rock" Gospel song..
Nashville Song Service accepted it for demo. So i'll get it demo'd in April to June of 2018.

So far i got 20 songs to get demo'd at $375 each..I have to get one done every two months.

Code: Select all


( genre = Country Rock )

( title= Hallelujah ) 

( entry music )

never thought too much about it
i never had too much to say

read the bible while i stumble
hoping that , my soul can be saved

reading the books of the bible
just stumble along as i pray

asking jesus's forgiveness
for all the mistakes that I've made

	and i sing a hallelujah
	(music)
	and i sing a hallelujah

( music )

just kneeling down in the temple
before the altar and i pray

asking god for his forgiveness
i know somehow i have to pay

he resides up in the heavens
like a beacon he always shines

and i hope that my , soul is saved
i take a sip of holy wine

	and i sing a hallelujah
	(music)
	and i sing a hallelujah

( music )

and the empty church i ponder
i wonder if i might be saved

and just kneeling at the altar
somehow living got in the way

here to ask for my forgiveness
and kneeling down i start to pray

thanking jesus of nazareth
for taking all my sins away

	and i sing a hallelujah
	(music)
	and i sing a hallelujah

( exit music )

albert_redditt@yahoo.com

Albert Redditt
315 W. Carrillo St. #104
Santa Barbara , Ca. 93101 U.S.A.

albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Dodicat

I'm working on a new multiplier
I think it's gonna be faster yet..

It'll be a few weeks for me to write it , and work out the bugs.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

I got an idea for a computer program.

You get maps of a city , so you can account for one-way streets..

Then the user types in , all the addresses they need to stop at.
And it calculates the fastest route for all the stops.
And it shows a line on the map for your route to follow.

It could be useful for school buses , FedEx , UPS , Taxi cabs , couriers , police , fire , etc...

Maybe it could be used with Google maps, for the maps..
dodicat
Posts: 7983
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.
Nice idea.
I did a travelling salesman thing a while back,
It iterates to the minimum distance (mostly).
I have included the maximum distance also. (For taxi drivers).

Code: Select all


screen 19
screencontrol 100,350,50
#include "crt.bi"
#define Intrange(f,l) int(Rnd*(((l)+1)-(f))+(f))

type pt
    as integer x,y
end type

type pts
    as pt p(any)
    as integer index
end type

'omit sqr for speed
#define length(a,b) ((a.x-b.x)*(a.x-b.x)+(a.y-b.y)*(a.y-b.y))

function distance(points as pts) as integer
    dim as single total,L
    for n as integer=lbound(points.p) to ubound(points.p)-1
    L= length(points.p(n),points.p(n+1))
    total+=sqr(L)
next n
return total
end function

randomize 1
start:

dim as integer dots=IntRange(4,15)       'number of points
dim as integer runs=dots^4'*2000             'iterations

dim as pts points
dim shared as pts cpy(runs)

redim points.p(1 to dots)

#macro setup()
for n as integer=lbound(points.p) to ubound(points.p)
    points.p(n)=type<pt>(IntRange(10,790),IntRange(50,590))
next n
#endmacro

#macro show(c,flag)
 circle(c.p(1).x,c.p(1).y),5,4,,,,f 
for n as integer=lbound(c.p)+1 to ubound(c.p)
    if flag then line -(c.p(n).x,c.p(n).y)
  if n< ubound(c.p) then circle(c. p(n).x,c.p(n).y),5 else circle(c. p(n).x,c.p(n).y),5,2,,,,f
next n
if flag then
draw string(c.p(1).x,c.p(1).y-20),str(1)
for n as integer=lbound(c.p)+1 to ubound(c.p)
   draw string(c.p(n).x,c.p(n).y-20),str(n)
next n
end if
#endmacro

dim as integer total,L,max=-1e7,min=1e7,ctr,lastmin

setup()
show(points,0)
print "Press a key"
var key=input(1)

dim as string i,st
do
    ctr+=1
    dim as integer x,y
    do
    x=IntRange(lbound(points.p)+1,ubound(points.p)-1):y=IntRange(lbound(points.p)+1,ubound(points.p)-1)
    loop until x<>y
    swap points.p(x),points.p(y)
    Total=0
 'Get the total sum through the points   
for n as integer=lbound(points.p) to ubound(points.p)-1
    L= length(points.p(n),points.p(n+1))
    total+=L
next n
'keep track history
cpy(ctr)=points      'copy the whole array
cpy(ctr).index=total 'set the index

if max<total then max=total
if min>total then min=total
' consol print
if lastmin<>min then
puts str(min)
end if

lastmin=min
loop until  ctr=runs


dim as integer Vmin,Vmax
for n as integer=lbound(cpy) to ubound(cpy)
    if cpy(n).index=min then Vmin=n
    if cpy(n).index=max then Vmax=n  
    next n
show(cpy(Vmin),1)
draw string(10,10), "minimum distance = "& distance(cpy(Vmin)) & "   Iterations = " &runs
var tmp=input(1)
cls
show(cpy(Vmax),1)
draw string(10,10), "maximum distance = "& distance(cpy(Vmax))
i=input(1)
if i<>chr(27) then cls:puts " ":puts "climb down": goto start else end
sleep

 
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

@ Albert.
There is a class of mathematics problem called a “Travelling Salesman Problem”.
https://en.wikipedia.org/wiki/Travellin ... an_problem

Many parcel pickup and delivery companies have confidential in-house software that optimises the route taken by one or more vehicles in any geographic area. That software knows if it is quicker to turn left or right and can work on a rectangular grid like Manhattan or on an arbitrary map.

There have been many mathematicians and supercomputers applied to the problem over the years, yet there is no guaranteed algorithm that will always identify the minimum solution once more than a couple of dozen sites must be visited.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Richard
@Dodicat

You'd need to get a "postal service" map of the city , so the program knows , where all the addresses are.
A lot of businesses and homes don't have address placards or signs on the home or business.

Then you'd need different cities to update you , on lane closures , detours and construction areas..
Then you'd need to know which streets are one-way..
Then you need to know all the businesses loading docks.
( a lot of loading docks are on a different street than the front door of the business or in an alley way. )

Someone on the forum here posted in "Tips & Tricks" a self solving maze. ( it generates the maze and then solves it.)
You'd need a program like it , to solve for minimum distances between stops.
Locked