Squares

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

Re: Squares

Post by dodicat »

That's really nice badidea.
I am inspired to simulate.
Note that colour as double works quite well.(First time I have tried it)
Some boxes are filled.

Code: Select all

Dim Shared As Long lim=50
Dim Shared As Long copy 'for the graphical destructor
copy=lim
Dim As Ulong black=Rgb(0,0,0),white=Rgb(255,255,255)
Screen 19,32,,64
Dim Shared As Integer xres,yres
Screeninfo xres,yres

Type box
    As Double Ptr p =New Double[8]             'all the spatial information
    Declare Sub move                           'advance
    Declare Sub Draw()                         'drawing method
    Declare Destructor                         'Goodbye, thanks for the memory
End Type

Sub box.draw()
    If p[5] Then Line(p[0],p[1])-(p[0]+p[2],p[1]+p[3]),p[4],bf Else _
    Line(p[0],p[1])-(p[0]+p[2],p[1]+p[3]),p[4],b
End Sub

Sub box.move
    p[0]+=p[6]
    p[1]+=p[7]
    If p[0]<0 Or p[0]>xres-p[2] Then p[6]=-p[6]
    If p[1]<0 Or p[1]>yres-p[3] Then p[7]=-p[7]
End Sub

Destructor box
lim-=1
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Var x=map(copy,0,lim,100,700)
Var y=map(100,700,x,100,500)
Circle(x,y),20,Rgb(200,0,0),,,,f
Circle(x,600-y),20,Rgb(200,0,0),,,,f
sleep 10
Delete [] p
End Destructor

#define range(f,l) Int(Rnd*((l+1)-(f))+(f))

Dim As box b(1 To lim)
randomize 1
'set up
For n As Long=1 To lim
    With b(n)
        If n=1 Then .p[0]=0 Else .p[0]=range(100,700)           'x
        If n=1 Then .p[1]=0 Else .p[1]=range(100,500)           'y
        If n=1 Then .p[2]=xres Else .p[2]=10+Rnd*80             'width
        If n=1 Then .p[3]=yres Else .p[3]=10+Rnd*80             'height
        If n=1 Then .p[4]=Rgba(0,0,0,1) Else .p[4]=Rnd*range(black,white) 
        If n=1 Then .p[5]=1 else.p[5]=iif(rnd>.5,1,0)            'filler
                    .p[6]=iif(rnd>.5,.2,-.2)                     'dx
                    .p[7]=iif(rnd>.5,.2,-.2)                     'dy
    End With
Next n

Do
    Screenlock
    For n As Long=1 To lim
        With b(n)  'b(1) is the fader
            .move
            .draw
        End With
    Next
    Screenunlock
    Sleep 1,1
Loop Until Inkey=Chr(27)

  
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Squares

Post by badidea »

dodicat wrote:That's really nice badidea
I was actually working on collision detection, but got distracted. Working on it now...
dodicat wrote:Note that colour as double works quite well.(First time I have tried it)
Hmm, I have to check that...
dodicat
Posts: 7979
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Yes, tested double over 10 million colours.

Code: Select all


for n as long=1 to 10000000
    dim as ulong u=rgba(rnd*255,rnd*255,rnd*255,rnd*255)
    dim as double d=u
    if d<> u then print d
next
print "done"   
Although single is 4 bytes (same as ulong), it fails.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Squares

Post by badidea »

Your code is certainly more compact, but all the p[..] from the topic "how many rectangles can I squeeze in a bit" makes it hard to read.
dafhi
Posts: 1641
Joined: Jun 04, 2005 9:51

Re: Squares

Post by dafhi »

this part is intiguing though. not sure how to incorporate it

Code: Select all

Type box
    As Double Ptr p =New Double[8]             'all the spatial information
    Declare Sub move                           'advance
    Declare Sub Draw()                         'drawing method
    Declare Destructor                         'Goodbye, thanks for the memory
End Type
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@odicat

My new algorithm is 6 times slower than my fastest multiplier.. So its no good!!

Code: Select all



Declare Function mul_loop_7( num1 as string , num2 as string ) as string
Declare Function           minus(num1 as String , num2 as String) As String
Declare Function              plus( num1 as String , num2 as String ) As String


screen 19

dim as double time1 , time2 , time3 , time4

do
    
    dim as string num1
    for a as longint = 1 to 100000
        num1+= str(int(rnd*10))
    next
    if left(num1,1) = "0" then mid(num1,1,1) = str(int(rnd*9)+1)
    
    dim as string num2
    for a as longint = 1 to 100000
        num2+= str(int(rnd*10))
    next
    if left(num2,1) = "0" then mid(num2,1,1) = str(int(rnd*9)+1)
    
    if num2 > num1 then swap num1,num2
    
    dim as string number1 =  plus( num1 , mid(num2,2) )
    dim as string number2 =  left(num2,1) + string(len(num2)-1,"0")
    
    'dim as ulongint ans7 = ( val(number1) * val(number2) ) + ( val(num1) * val(right(num2,len(num2)-1)) ) - ( val(num2)  * val(right(num2,len(num2)-1)) ) + (val(right(num2,len(num2)-1))^2)

    time1=timer
        dim as string my_answer = mul_loop_7( number1 , number2 ) 
        my_answer = plus( my_answer , mul_loop_7( num1 , right(num2 , len(num2)-1)) )
        my_answer = minus( my_answer , mul_loop_7( num2 , right(num2 , len(num2)-1)) )
        my_answer = plus( my_answer , mul_loop_7( right(num2,len(num2)-1) , right(num2,len(num2)-1) ) )
    time2 = timer
    
    time3 = timer
        dim as string answer = mul_loop_7( num1,num2)
    time4 = timer
    
    dim as string difference = minus( answer , my_answer)
    
    print
    print "n1  = " ; num1
    print "n2  = " ; num2
    print
    print "ans   = " ; val(num1) * val(num2)
    print "answer = " ; answer
    print "my ans = " ; my_answer
    'print "ans    = " ; ans7
    print
    print "difference = " ; difference
    print
    print "time new algorithm = " ; time2-time1
    print "time mul_loop_7    = " ; time4-time3
    
    sleep
    
    if inkey = chr(27) then exit do
    
loop

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
'===============================================================================
'===============================================================================

srvaldez
Posts: 3374
Joined: Sep 25, 2005 21:54

The Mechanical Universe

Post by srvaldez »

I really enjoyed this series of videos broadcasted in USA by PBS, it's a nice mix of history, science and fun animations, you can watch the 52 episodes on youtube https://www.youtube.com/playlist?list=P ... dk-XGtA5cZ
“The Mechanical Universe,” is a critically-acclaimed series of 52 thirty-minute videos covering the basic topics of an introductory university physics course.

Each program in the series opens and closes with Caltech Professor David Goodstein providing philosophical, historical and often humorous insight into the subject at hand while lecturing to his freshman physics class. The series contains hundreds of computer animation segments, created by Dr. James F. Blinn, as the primary tool of instruction. Dynamic location footage and historical re-creations are also used to stress the fact that science is a human endeavor.

The series was originally produced as a broadcast telecourse in 1985 by Caltech and Intelecom, Inc. with program funding from the Annenberg/CPB Project.

The online version of "The Mechanical Universe" is sponsored by the Information Science and Technology initiative at Caltech. http://ist.caltech.edu
dodicat
Posts: 7979
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: five cubes in squares.

Post by dodicat »

doodle.
Another 30 squares injected.

Code: Select all

 

Type Point
    As Single x,y,z
    Declare Static Function rotate(As Point,As Point,As Point,As Point=Type<Point>(1,1,1)) As Point
    Declare Static Function perspective(As Point,As Point=Type(400,300,900)) As Point
End Type

Function dot(v1 As Point,v2 As Point) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
    Dim As Single d1=Sqr(v1.x*v1.x + v1.y*v1.y+ v1.z*v1.z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
    Dim As Single v1x=v1.x/d1,v1y=v1.y/d1,v1z=v1.z/d1 'normalize
    Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
    Return (v1x*v2x+v1y*v2y+v1z*v2z) 
End Function

Function point.Rotate(c As Point,p As Point,angle As Point,scale As Point) As Point
    Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
    Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<Point>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
    (scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
    (scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z)',p.col)
End Function

Function point.perspective(p As Point,eyepoint As Point) As Point
    Dim As Single   w=1+(p.z/eyepoint.z)
    Return Type<Point>((p.x-eyepoint.x)/w+eyepoint.x,_
    (p.y-eyepoint.y)/w+eyepoint.y,_
    (p.z-eyepoint.z)/w+eyepoint.z)
End Function  

Type plane
    As Point p(1 To 4)
    Declare Sub Draw(As Ulong)
    Declare Static Sub fill(() As Point,As Ulong,As Long,As Long)
End Type

Sub plane.fill(a() As Point, c As Ulong,min As Long,max As Long)
    'translation of a c snippet
    Static As Long i,j,k,dy,dx, x,y,temp
    Static As Long NewX (1 To Ubound(a))
    Static As Single Grad(1 To Ubound(a))
    For i=1 To Ubound(a) - 1 
        dy=a(i+1).y-a(i).y
        dx=a(i+1).x-a(i).x
        If(dy=0) Then Grad(i)=1
        If(dx=0) Then Grad(i)=0
        If ((dy <> 0) And (dx <> 0)) Then
            Grad(i) = dx/dy
        End If
    Next i
    For y=min To max
        k = 1
        For i=1 To Ubound(a) - 1
            If( ((a(i).y<=y) Andalso (a(i+1).y>y)) Or ((a(i).y>y) _
            Andalso (a(i+1).y<=y))) Then
            NewX(k)= Int(a(i).x+ Grad(i)*(y-a(i).y))
            k +=1
        End If
    Next i
    For j = 1 To k-2
        For i = 1 To k-2
            If NewX(i) > NewX(i+1) Then
                temp = NewX(i)
                NewX(i) = NewX(i+1)
                NewX(i+1) = temp
            End If
        Next i
    Next j
    For i = 1 To k - 2 Step 2
        Line (NewX(i),y)-(NewX(i+1)+1,y), c
    Next i
Next y
End Sub

Sub plane.draw(clr As Ulong )
    Static As Single miny=1e6,maxy=-1e6
    Static As Point V1(1 To  Ubound(p)+1)
    Dim As Long n
    For n =1 To Ubound(p)
        If miny>p(n).y Then miny=p(n).y
        If maxy<p(n).y Then maxy=p(n).y
        V1(n)=p(n) 
    Next
    v1(Ubound(v1))=p(Lbound(p))
    plane.fill(v1(),clr,miny,maxy)
End Sub

Type cube
    As plane f(1 To 6)
    As Point centre
    As Point norm(1 To 6) 'normals
    As Ulong clr(1 To 6)
    As Point aspect
    As Point d 'increment speed
    Declare Constructor()
    Declare Sub translate(v As Point,s As Double)
    Declare Sub turn(As Point)
    Declare Function rotate(As Point,As Point) As cube
    Declare Static Sub bsort(() As cube)
    Declare Sub Draw
End Type

Constructor cube()
Dim As Double pi=4*Atn(1)
Static As Point g(1 To ...,1 To ...)={{(-1,-1,-1),(1,-1,-1),(1,1,-1),(-1,1,-1)},_'front
                                     {(1,-1,-1),(1,-1,1),(1,1,1),(1,1,-1)},_ 'right
                                     {(-1,-1,1),(1,-1,1),(1,1,1),(-1,1,1)},_'back
                                     {(-1,-1,-1),(-1,-1,1),(-1,1,1),(-1,1,-1)},_'left
                                     {(1,1,-1),(1,1,1),(-1,1,1),(-1,1,-1)},_'top
                                     {(1,-1,-1),(1,-1,1),(-1,-1,1),(-1,-1,-1)}}'base
For n As Long=1 To 6
    clr(n)=Rgb(Rnd*255,Rnd*255,Rnd*255) 'set a default colour
    For m As Long=1 To 4
        f(n).p(m)= g(n,m)  'set to g() 
    Next m
Next n
norm(1)=Type(0,0,-1) 'face normals
norm(2)=Type(1,0,0)
norm(3)=Type(0,0,1)
norm(4)=Type(-1,0,0)
norm(5)=Type(0,1,0)
norm(6)=Type(0,-1,0)
centre=Type(0,0,0)
'set some defaults
aspect=Type(Rnd*2*pi,Rnd*2*pi,Rnd*2*pi) 
For n As Long=1 To 6
    norm(n)=point.rotate(centre,norm(n),aspect)
    For m As Long=1 To 4
        f(n).p(m)=point.rotate(centre,f(n).p(m),aspect)
    Next
Next
d.x=(Rnd-Rnd)/50
d.y=(Rnd-Rnd)/50
d.z=(Rnd-Rnd)/50
End Constructor

Sub cube.turn(p As Point)
    Dim As cube tmp=This
    For n As Long=1 To 6
        For m As Long=1 To 4
            tmp.f(n).p(m)=point.rotate(centre,this.f(n).p(m),p)
            tmp.f(n).p(m)=point.perspective(tmp.f(n).p(m))
        Next
    Next
    For n As Long=1 To 6
        tmp.norm(n)=point.rotate(centre,this.norm(n),p)'normals turn also
    Next
    tmp.draw
End Sub

Function cube.rotate(c As Point,ang As Point) As cube
    Dim As cube tmp=This
    For n As Long=1 To 6
        For m As Long=1 To 4
            tmp.f(n).p(m)=point.rotate(c,this.f(n).p(m),ang)
        Next
    Next
    For n As Long=1 To 6
        tmp.norm(n)=point.rotate(c,this.norm(n),ang)
    Next
    tmp.centre=point.rotate(c,this.centre,ang)
    Return tmp
End Function

Sub cube.translate(v As Point,s As Double)
    For n As Long=1 To 6
        norm(n).x*=s
        norm(n).y*=s
        norm(n).z*=s
        For m As Long=1 To 4
            f(n).p(m).x*=s
            f(n).p(m).y*=s
            f(n).p(m).z*=s
        Next m
    Next n
    For n As Long=1 To 6
        norm(n).x=norm(n).x+v.x
        norm(n).y=norm(n).y+v.y
        norm(n).z=norm(n).z+v.z
        For m As Long=1 To 4
            f(n).p(m).x= f(n).p(m).x+v.x 
            f(n).p(m).y= f(n).p(m).y+v.y
            f(n).p(m).z= f(n).p(m).z+v.z
        Next m
    Next n
    centre.x+=v.x
    centre.y+=v.y
    centre.z+=v.z
End Sub

Sub cube.draw
    Static As Ubyte Ptr col
    For n As Long=1 To 5
        For m As Long=n+1 To 6
            If norm(n).z<norm(m).z Then
                Swap f(n),f(m)
                Swap norm(n),norm(m)
                Swap clr(n),clr(m)
            End If
        Next m
    Next n
   #define map_(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    For n As Long=1 To 6
          col=Cptr(Ubyte Ptr,@clr(n))
      Var cx=norm(n).x-centre.x,cy=norm(n).y-centre.y,cz=norm(n).z-centre.z
      Var dt=dot(Type(cx,cy,cz),Type(0,1,0))
      dt=map_(1,-1,dt,.3,1)
        f(n).draw(Rgb(dt*col[2],dt*col[1],dt*col[0]))
    Next n
End Sub

Sub cube.bsort(c() As cube)
    For n As Long=Lbound(c) To Ubound(c)-1
        For m As Long=n+1 To Ubound(c)
            If c(n).centre.z<c(m).centre.z Then Swap c(n),c(m)
        Next
    Next
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

Dim As cube c(1 To 5)
c(1).translate(Type(200,100,0),40)
c(2).translate(Type(600,100,0),40)
c(3).translate(Type(600,500,0),40)
c(4).translate(Type(200,500,0),40)
c(5).translate(Type(400,300,0),80)

Dim As Double pi2=8*Atn(1)
Dim As Double pi=4*Atn(1)
 For n As Long=Lbound(c) To Ubound(c)
         c(n)=c(n).rotate(Type(400,300,0),Type(0,pi/2,0))'flip 90 
        Next

Dim As cube tmp(Lbound(c) To Ubound(c))
Dim As Point a
'fix y and z
a.y=-pi/7
a.z=pi/2
Dim As Long fps

Screen 19,32
Color ,Rgb(0,0,100)

#define fmod(x,y) y*frac(x/y)
Do
    Screenlock
    Cls
    a.x+=.01:a.x=fmod(a.x,pi2)
    Draw String (20,20),"FPS = " &fps
    For n As Long=Lbound(c) To Ubound(c)
        tmp(n)=c(n).rotate(Type(400,300,0),a)
    Next
    cube.bsort(tmp())
    For n As Long=Lbound(tmp) To Ubound(tmp)
        c(n).aspect.x+=c(n).d.x: c(n).aspect.x=fmod(c(n).aspect.x,pi2)'turning angles
        c(n).aspect.y+=c(n).d.y: c(n).aspect.y=fmod(c(n).aspect.y,pi2)
        c(n).aspect.z+=c(n).d.z: c(n).aspect.z=fmod(c(n).aspect.z,pi2)
        tmp(n).turn(Type(tmp(n).aspect.x,tmp(n).aspect.y,tmp(n).aspect.z))
    Next
    Screenunlock
    Sleep regulate(90,fps),1
Loop Until Inkey=Chr(27)
Sleep



   
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: five cubes in squares.

Post by badidea »

dodicat wrote:doodle.
Another 30 squares injected.
Cool, I do see some artefacts. Short horizontal lines in the wrong place, sometimes.
dodicat
Posts: 7979
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: pseudo polymorphism

Post by dodicat »

Thanks for testing badidea.

The methods in the code can handle three different shapes.
cube, tetrahedron and square (plate).

I did have a try at oop polymorphism for this but got bogged down.
Most of examples of polymorphism have little methods/constructors e.t.c. which say "hello I am here".
But I got bogged down actually doing a real task in each, so I gave up.
anyway:

Code: Select all


'======  globals ====
type temp as point ptr 'advance notice
Const pi=4*Atn(1)
dim shared lightsource as temp
Dim Shared As integer xres,yres
Screen 20,32,,64  'or 19 or 17
Color Rgb(0,200,0),Rgb(0,0,55)
Screeninfo xres,yres
'====================
Enum
    cube
    tetra
    square
End Enum

Type Point
    As Single x,y,z
    Declare Static Function rotate(As Point,As Point,As Point,As Point=Type<Point>(1,1,1)) As Point
    Declare Static Function perspective(As Point,As Point=Type(xres\2,yres\2,1000)) As Point
    Declare Function dot(As Point) As Single
    declare sub normalize()
End Type

Function point.dot(v2 As Point) As Single 'dot product |v1| * |v2| *cos(angle between v1 and v2)
    Dim As Single d1=Sqr(x*x + y*y+ z*z),d2=Sqr(v2.x*v2.x + v2.y*v2.y +v2.z*v2.z)
    Dim As Single v1x=x/d1,v1y=y/d1,v1z=z/d1 'normalize
    Dim As Single v2x=v2.x/d2,v2y=v2.y/d2,v2z=v2.z/d2 'normalize
    Return (v1x*v2x+v1y*v2y+v1z*v2z) 
End Function

Function point.Rotate(c As Point,p As Point,angle As Point,scale As Point) As Point
    Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
    Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<Point>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
    (scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
    (scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z)',p.col)
End Function

Function point.perspective(p As Point,eyepoint As Point) As Point
    Dim As Single   w=1+(p.z/eyepoint.z)
    Return Type<Point>((p.x-eyepoint.x)/w+eyepoint.x,_
    (p.y-eyepoint.y)/w+eyepoint.y,_
    (p.z-eyepoint.z)/w+eyepoint.z)
End Function  

Type plane
    As Point p(Any)
    Declare Sub Draw(As Ulong)
    Declare Static Sub fill(() As Point,As Ulong,As Long,As Long)
End Type

Sub plane.fill(a() As Point, c As Ulong,min As Long,max As Long)
    Static As Long i,j,k,dy,dx, x,y
    Static As Long NewX (1 To Ubound(a))
    Static As Single Grad(1 To Ubound(a))
    For i=1 To Ubound(a) - 1 
        dy=a(i+1).y-a(i).y
        dx=a(i+1).x-a(i).x
        If(dy=0) Then Grad(i)=1
        If(dx=0) Then Grad(i)=0
        If ((dy <> 0) And (dx <> 0)) Then
            Grad(i) = dx/dy
        End If
    Next i
    For y=min To max
        k = 1
        For i=1 To Ubound(a) - 1
            If( ((a(i).y<=y) Andalso (a(i+1).y>y)) Or ((a(i).y>y) _
            Andalso (a(i+1).y<=y))) Then
            NewX(k)= Int(a(i).x+ Grad(i)*(y-a(i).y))
            k +=1
        End If
    Next i
    For j = 1 To k-2
        For i = 1 To k-2
            If NewX(i) > NewX(i+1) Then Swap  NewX(i),NewX(i+1)
        Next i
    Next j
    For i = 1 To k - 2 Step 2
        Line (NewX(i),y)-(NewX(i+1)+1,y), c
    Next i
Next y
End Sub

Sub plane.draw(clr As Ulong )
    Static As Long miny=1e6,maxy=-1e6
    Redim As Point V1(1 To  Ubound(p)+1)
    Dim As Long n
    For n =1 To Ubound(p)
        If miny>p(n).y Then miny=p(n).y
        If maxy<p(n).y Then maxy=p(n).y
        V1(n)=p(n) 
    Next
    v1(Ubound(v1))=p(Lbound(p))
    plane.fill(v1(),clr,miny,maxy)
End Sub

Type shape
    As plane f(Any) 'faces
    As Point centre
    As Point norm(Any) 'normals
    As Ulong clr(Any)
    As Point aspect
    As Point d 'increment speed
    Declare Sub Construct(As Long)
    Declare Sub translate(v As Point,s As Double)
    Declare Sub turn(As Point) 'turn about it's centroid
    Declare Function rotate(As Point,As Point) As shape 'roatate about a chosen point
    Declare Static Sub bsort(() As shape)'bubblesort (fast enough for a small number of things)
    Declare Sub Draw
End Type

Sub shape.construct(flag As Long)
    Static As Point g(1 To ...,1 To ...)= _  'cube
    {{(-1,-1,-1),(1,-1,-1),(1,1,-1),(-1,1,-1)},_'front
    {(1,-1,-1),(1,-1,1),(1,1,1),(1,1,-1)},_ 'right
    {(-1,-1,1),(1,-1,1),(1,1,1),(-1,1,1)},_'back
    {(-1,-1,-1),(-1,-1,1),(-1,1,1),(-1,1,-1)},_'left
    {(1,1,-1),(1,1,1),(-1,1,1),(-1,1,-1)},_   'top
    {(1,-1,-1),(1,-1,1),(-1,-1,1),(-1,-1,-1)}}'base
    
    Static As Point t(1 To ...,1 To ...)= _   'tetra                                             
    {{(-1,-1/Sqr(3),-1/Sqr(6)),(1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6))}, _ 'b
    {(-1,-1/Sqr(3),-1/Sqr(6)),(1,-1/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))},_           'f
    {(1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))}, _            'r
    {(-1,-1/Sqr(3),-1/Sqr(6)),(0,2/Sqr(3),-1/Sqr(6)),(0,0,3/Sqr(6))}}             'l  
    
    Static As Point s(1 To ...,1 To ...)= _  'square
    {{(-1,-1,0),(1,-1,0),(1,1,0),(-1,1,0)}}
  '==================   seperate the three shapes  =============  
    If flag=cube Then
        Redim f(1 To 6)
        Redim norm(1 To 6)
        Redim clr(1 To 6)
        For n As Long=1 To 6
            Redim (f(n).p)(1 To 4)'faces vertices
        Next
        norm(1)=Type(0,0,-1) 'face normals to cube
        norm(2)=Type(1,0,0)
        norm(3)=Type(0,0,1)
        norm(4)=Type(-1,0,0)
        norm(5)=Type(0,1,0)
        norm(6)=Type(0,-1,0)
        centre=Type(0,0,0)
    End If
    
    If flag=tetra Then
        Redim f(1 To 4)
        Redim norm(1 To 4)
        Redim clr(1 To 4)
        For n As Long=1 To 4
            Redim (f(n).p)(1 To 3)'faces vertices
        Next
        norm(1)=Type(0, 0,-0.4082483) 'normals to tetra faces
        norm(2)=Type(0,-0.3849002, 0.1360828)
        norm(3)=Type(0.3333333, 0.1924501, 0.1360828)
        norm(4)=Type(-0.3333333, 0.1924501, 0.1360828)
        centre=Type(0,0,0)
    End If
    
    If flag=square Then
        Redim f(1 To 1)
        Redim norm(1 To 1)
        Redim clr(1 To 1)
        For n As Long=1 To Ubound(f)
            Redim (f(n).p)(1 To 4)'
        Next
         norm(1)=Type(0,0,1)
        centre=Type(0,0,0)
    End If
    
    For n As Long=1 To Ubound(f)
        clr(n)=Rgb(Rnd*255,Rnd*255,Rnd*255) 'set a default colour
        For m As Long=1 To Ubound(f(n).p)
            If flag=cube Then f(n).p(m)= g(n,m)   'set to g() 
            If flag=tetra Then f(n).p(m)= t(n,m)  'set to t()
            If flag=square Then f(n).p(m)= s(n,m) 'set to s()
        Next m
    Next n
    '======================= each shape defined =========
    'set some defaults starting aspects
    aspect=Type(Rnd*2*pi,Rnd*2*pi,Rnd*2*pi) 
    For n As Long=1 To Ubound(f)
        norm(n)=point.rotate(centre,norm(n),aspect)
        For m As Long=1 To Ubound(f(n).p)
            f(n).p(m)=point.rotate(centre,f(n).p(m),aspect)
        Next
    Next
    'speeds
    d.x=(Rnd-Rnd)/50
    d.y=(Rnd-Rnd)/50
    d.z=(Rnd-Rnd)/50
End Sub

Sub shape.turn(p As Point)
    Dim As shape tmp=This
    For n As Long=1 To Ubound(f)
        For m As Long=1 To Ubound(f(n).p)
            tmp.f(n).p(m)=point.rotate(centre,this.f(n).p(m),p)
            tmp.f(n).p(m)=point.perspective(tmp.f(n).p(m))
        Next
    Next
    For n As Long=1 To Ubound(f)
        tmp.norm(n)=point.rotate(centre,this.norm(n),p)'normals turn also
    Next
    tmp.draw
End Sub

Function shape.rotate(c As Point,ang As Point) As shape
    Dim As shape tmp=This
    For n As Long=1 To Ubound(f)
        For m As Long=1 To Ubound(f(n).p)
            tmp.f(n).p(m)=point.rotate(c,this.f(n).p(m),ang)
        Next
    Next
    For n As Long=1 To Ubound(f)
        tmp.norm(n)=point.rotate(c,this.norm(n),ang)
    Next
    tmp.centre=point.rotate(c,this.centre,ang)
    Return tmp
End Function

Sub shape.translate(v As Point,s As Double)
    For n As Long=1 To Ubound(f)
        norm(n).x*=s
        norm(n).y*=s
        norm(n).z*=s
        For m As Long=1 To Ubound(f(n).p)
            f(n).p(m).x*=s
            f(n).p(m).y*=s
            f(n).p(m).z*=s
        Next m
    Next n
    For n As Long=1 To Ubound(f)
        norm(n).x=norm(n).x+v.x
        norm(n).y=norm(n).y+v.y
        norm(n).z=norm(n).z+v.z
        For m As Long=1 To Ubound(f(n).p)
            f(n).p(m).x= f(n).p(m).x+v.x 
            f(n).p(m).y= f(n).p(m).y+v.y
            f(n).p(m).z= f(n).p(m).z+v.z
        Next m
    Next n
    centre.x+=v.x
    centre.y+=v.y
    centre.z+=v.z
End Sub

Sub shape.draw
    Static As Ubyte Ptr col
    For n As Long=1 To Ubound(f)-1
        For m As Long=n+1 To Ubound(f)
            If norm(n).z<norm(m).z Then
                Swap f(n),f(m)
                Swap norm(n),norm(m)
                Swap clr(n),clr(m)
            End If
        Next m
    Next n
    #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
    For n As Long=1 To Ubound(f)
        col=Cptr(Ubyte Ptr,@clr(n))
        Dim As Single cx=norm(n).x-centre.x,cy=norm(n).y-centre.y,cz=norm(n).z-centre.z
        Dim As Point k=Type<Point>(cx,cy,cz)
        Dim As Single dt=k.dot(*lightsource)
        dt=map(1,-1,dt,.3,1)
        f(n).draw(Rgba(dt*col[2],dt*col[1],dt*col[0],col[3]))
    Next n
End Sub

Sub shape.bsort(c() As shape)
    For n As Long=Lbound(c) To Ubound(c)-1
        For m As Long=n+1 To Ubound(c)
            If c(n).centre.z<c(m).centre.z Then Swap c(n),c(m)
        Next
    Next
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

'====================  create and run ==============
Randomize 10
Dim As shape c(1 To 8)
c(1).construct(cube)
c(2).construct(cube)
c(3).construct(cube)
c(4).construct(cube)
c(5).construct(cube)
c(6).construct(tetra)
c(7).construct(tetra)
c(Ubound(c)).construct(square)
c(Ubound(c)).clr(1)=Rgba(255,0,0,100)'set colour

dim as single cx=xres\2,cy=yres\2

c(1).translate(Type(cx-.5*cx,cy-.6*cy,0),cx/10) 'cube
c(2).translate(Type(cx+.5*cx,cy-.6*cy,0),cx/10) 'cube
c(3).translate(Type(cx+.5*cx,cy+.6*cy,0),cx/10) 'cube
c(4).translate(Type(cx-.5*cx,cy+.6*cy,0),cx/10) 'cube
c(5).translate(Type(cx,cy,0),cx/5)              'cube
c(6).translate(Type(cx,cy-.65*cy,0),cx/10)      'tetra
c(7).translate(Type(cx,cy+.65*cy,0),cx/10)      'tetra
c(8).translate(Type(cx,cy+1.2*cy,0),cx/5)       'square
Dim As Double pi2=2*pi

For n As Long=Lbound(c) To Ubound(c)
    c(n)=c(n).rotate(Type(xres\2,yres\2,0),Type(0,pi/2,0)) 'flip 90 
Next

Dim As shape tmp(Lbound(c) To Ubound(c))
Dim As Point a
'fix y and z
a.y=-pi/9
a.z=pi/2

lightsource=new point
*lightsource=type(0,1,0)

Dim As Long fps
#define fmod(x,y) y*frac(x/y)
Dim As String key
Do
    key=Inkey 
    If key=Chr(255)+"P" Then a.y-=.05   'down
    If key=Chr(255)+"H" Then a.y+=.05   'up 
    If key=Chr(255)+"K" Then a.z-=.05   'right
    If key=Chr(255)+"M" Then a.z+=.05   'left
    If key=" " Then a.z=pi/2:a.y=-pi/9  'reset
  
    Screenlock
    Cls
    a.x+=.01:a.x=fmod(a.x,pi2)
    Draw String (20,20),"Cubes tetrahedrons and a plate. use arrow and space keys"
    Draw String (20,50),"FPS = " &fps
    
    For n As Long=Lbound(c) To Ubound(c)
        tmp(n)=c(n).rotate(Type(xres\2,yres\2,0),a)
    Next
    
    shape.bsort(tmp())
    
    For n As Long=Lbound(tmp) To Ubound(tmp)
        c(n).aspect.x+=c(n).d.x: c(n).aspect.x=fmod(c(n).aspect.x,pi2)'turning angles mod 2pi
        c(n).aspect.y+=c(n).d.y: c(n).aspect.y=fmod(c(n).aspect.y,pi2)
        c(n).aspect.z+=c(n).d.z: c(n).aspect.z=fmod(c(n).aspect.z,pi2)
        tmp(n).turn(Type(tmp(n).aspect.x,tmp(n).aspect.y,tmp(n).aspect.z))
    Next
    Screenunlock
    Sleep regulate(90,fps),1
Loop Until key=Chr(27)
Sleep
delete lightsource


   
srvaldez
Posts: 3374
Joined: Sep 25, 2005 21:54

Re: Squares

Post by srvaldez »

hi dodicat, here's a way to solve a sudoku game in under 60 seconds https://www.youtube.com/watch?v=zyXYzh7OmY4
dodicat
Posts: 7979
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Thanks srvaldez.
I think he/she had done one earlier.
I checked the answer anyway
1 6 8 9 5 3 2 7 4
2 5 9 4 7 6 1 8 3
7 4 3 1 2 8 6 9 5
9 1 7 8 4 2 3 5 6
8 2 6 3 9 5 4 1 7
5 3 4 7 6 1 8 2 9
3 7 2 6 8 9 5 4 1
4 8 1 5 3 7 9 6 2
6 9 5 2 1 4 7 3 8
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

@ Albert.
Here are new Pack() and Unpack() routines that convert between ASCII strings of decimal digits and packed binary data in arrays of Ulong. They convert data in blocks of 9 digits, so are a bit faster than the earlier versions.

There are some strange exceptions during the Unpack where expansion is handled by using the 64 bit HiLo as a carry. That was interesting code to write as it can generate a compound carry.

I allocate at least one extra leading zero array element because it was needed during debugging and does not slow things down.

I tried indexing the arrays through pointers, but there is little to gain since the inner loop multiply-accumulate dominates during the conversion. It could be twice the speed in assembly code, but it would then not cross platforms. Who needs speed anyway.

Code: Select all

'=======================================================================
' Convert between ASCII decimal strings and packed 32 bit integer arrays
'=======================================================================
Declare Sub pack( Byref ascii As String, pk() As Ulong )    ' ASCII decimal to Ulong binary
Declare Sub unpack( pk() As Ulong, Byref ascii As String )  ' Ulong binary to ASCII decimal
' following routines are used during testing oly
Declare Sub hex_dump(  b() As Ulong )                        ' hexdump Ulong binary array
Declare Sub hex_load( Byref hext As String, b() As Ulong )   ' Hex string into binary array
Declare Function random_digits( Byval n As Integer ) As String  ' make random decimal test string

'=======================================================================
' On 2012 technology ...  "<$fbc>" -exx -w pedantic "<$file>"
'   decimal ascii,     pack         unpack
'-----------------------------------------------
'       10 digits,   2.40 usec,   8.10 usec
'       30 digits,   2.70 usec,   9.30 usec
'      100 digits,   4.80 usec,   19.0 usec
'      300 digits,   16.6 usec,   54.5 usec
'    1,000 digits,   126. usec,   239. usec
'-----------------------------------------------
'    3,000 digits,   1.02 msec,   1.44 msec
'   10,000 digits,   11.6 msec,   14.0 msec
'   30,000 digits,   97.9 msec,   115. msec
'-----------------------------------------------
'  100,000 digits,   1.087 sec,   1.376 sec
'  200,000 digits,   4.328 sec,   5.175 sec
'  250,000 digits,   6.761 sec,   8.036 sec
'  500,000 digits,   27.06 sec,   33.60 sec
' 1000,000 digits,   108.2 sec,   143.9 sec
'=======================================================================
' Test pack and unpack
'=======================================================================
Dim As Integer n = 30000    ' length of dec test string
Dim As String a, c
Redim As Ulong b( 0 To 1 )  ' will be redimmed later
Dim As Double startime, stoptime, dt1, dt2  ' times in seconds
a = random_digits( n )

startime = Timer
pack( a, b() )              ' test pack
stoptime = Timer
dt1 = stoptime - startime
Print " Packed."

startime = Timer
unpack( b(), c )            ' test unpack
stoptime = Timer
dt2 = stoptime - startime
Print " Unpacked"

'-----------------------------------------------
If n <= 6000 Then
    Print a
    Print c
End If

'-----------------------------------------------
Print
If a = c Then
    Print n; " digits,  no error detected."
Else
    Print n; " digits,  W A R N I N G   conversion error."
End If

'-----------------------------------------------
' scale times to SI prefixes
Print
If ( dt1 < 1 ) And ( dt2 < 1 ) Then
    If ( dt1 < 0.001 ) And ( dt2 < 0.001 ) Then
        Print Using "dec to bin ####.# usec "; dt1 * 1e6
        Print Using "bin to dec ####.# usec "; dt2 * 1e6
    Else
        Print Using "dec to bin ####.### msec "; dt1 * 1000
        Print Using "bin to dec ####.### msec "; dt2 * 1000
    End If
Else
    Print Using "dec to bin ####.### sec "; dt1
    Print Using "bin to dec ####.### sec "; dt2
End If
Print 

Sleep

'=======================================================================
' test the hex load and hex_dump
'=======================================================================
n = 4
Dim As String txt = "1" + String( n, "0" )
Print txt; " hex"
hex_load( txt, b() )
hex_dump( b() )

unpack( b(), a )
Print " dec val = "; a
n = Len( a )

pack( a, b() )
hex_dump( b() )

'=======================================================================
Sleep
'=======================================================================

'=======================================================================
' Pack a base ten ASCII decimal string into binary Ulong integer array
'   the result array will be redimensioned, so must declare by; Redim as Ulong acc() 
'=======================================================================
Sub pack( Byref d As String, acc() As Ulong )   ' ASCII decimal to Ulong binary
    #define billion 1000000000ull
    Dim As Integer len_d = Len( d )  ' original length
    ' lengthen input string by up to 8 digits to make 9 digit blocks
    Dim As Integer n = len_d Mod 9
    If n Then d = String( 9 - n, "0" ) + d
    n = Len( d ) \ 9  ' number of input blocks
    '---------------------------------------------------------------
    ' Log10( 2 ) = 0.301029995664 digits per bit
    ' 32 * Log10( 2 ) = 9.6329598612474 decimal digits per 32 bit block
    ' 0.9342922766870705 Ulongs needed per 9 digits
    '---------------------------------------------------------------
    Dim As Integer m = 1 + n * 0.9342923
    Redim As Ulong acc( 0 To m )    ' sufficient accumulator array
    Dim As Integer k = 1  ' increasing size of active acc array
    For j As Integer = 0 To Len( d ) - 5 Step 9     ' take blocks of 9 digits
        '-----------------------------------------------
        ' Convert 9 digits to a binary number in carry
        Dim As Ulongint carry = d[ j ] - Asc( "0" ) ' 64 bit Unsigned Integer
        For i As Integer = j + 1 To j + 8
            carry = d[ i ] - Asc( "0" ) + ( carry * 10 )
        Next i
        '-----------------------------------------------
        ' Multiply the acc array by a billion and add the next 9 digits
        For i As Integer = 0 To k
            Dim As Ulongint product = ( Culngint( acc( i ) ) * billion ) + carry 
            acc( i ) = product And &hFFFFFFFFull ' sum is low order 32 bits
            carry = product Shr 32 ' carry is the high order 32 bits
        Next i
        '-----------------------------------------------
        If carry Then   ' need to extend accumulator
            k += 1
            acc( k ) = carry
        End If
        '-----------------------------------------------
    Next j  ' accumulator b() contains result in packed binary
    '---------------------------------------------------------------
    d = Right( d, len_d )    ' restore original length
End Sub

'=======================================================================
' Unpack binary in Ulong array into base ten ASCII decimal string
'=======================================================================
Sub unpack( b() As Ulong, Byref c As String ) ' Ulong binary to ASCII decimal
    #define billion 1000000000ull
    Dim As Integer len_b = Ubound( b ) ' upper element of binary array
    Dim As Integer n = 1 + Int( ( Len_b ) * 1.070328873472 ) ' 9 digit block count
    Dim As Ulong acc( 0 To n )  ' array to accumulate and build base 1e9
    '---------------------------------------------------------------
    Dim As Ulongint HiLo    ' allocates a 64 bit arithmetic register in memory
    Dim As Ulong Ptr Lo = Cptr( Ulong Ptr, @HiLo )  ' *Lo is the lower 32 bits
    Dim As Ulong Ptr Hi = Lo + 1    ' *Hi is the upper 32 bits of hilo
    '---------------------------------------------------------------
    ' convert packed binary 32 bit Ulong array to base 1e9 in acc
    Dim As Integer i, j, k = 1  ' loop counters
    For j = Len_b To 0 Step -1  ' the blocks to convert are added by inserting
        *lo = b( j )            '   them into register LSB of acc, clears *hi
        '-------------------------------------------
        For i = 0 To k      ' the active part of the base 1e9 acc
            *hi += acc( i ) ' multiply acc() by 2^32 by adding it to high side
            acc( i ) = Culng( hilo Mod billion ) ' MOD, keep it safe
            hilo \= billion ' DIV, carry is now in hilo
        Next i          ' on exit from MACC, if carry
        '-------------------------------------------
        Do While hilo   '   indicates need to extend active part of acc
            k += 1
            acc( k ) = Culng( hilo Mod billion )
            hilo = hilo \ billion
        Loop    ' hilo becomes zero at end of each MACC pass
        '-------------------------------------------
    Next j      ' acc now contains result blocks in base 10^9
    ' Print k; " blocks needed, "; n; " blocks allocated."
    '---------------------------------------------------------------
    ' unpack and return acc as decimal ASCII string
    c = ""
    For i = 0 To k
        c = Right( "000000000" + Str( acc( i ) ), 9 ) + c
    Next i
    '---------------------------------------------------------------
    c =  Ltrim( c, "0" )
End Sub

'=======================================================================
' Put a Hex string into a Ulong integer array
'=======================================================================
Sub hex_load( Byref x As String, b() As Ulong ) ' reverse hexdump
    ' lengthen input string by up to 7 hex symbols to make multiple of 8
    Dim As Integer len_x = Len( x ) ' original length
    Dim As Integer n = len_x Mod 8      ' number of symbols
    If n Then x = String( 8 - n, "0" ) + x  ' prefix with zeros
    '-----------------------------------------------
    n = Len( x ) \ 8    ' number of input blocks, plus one spare
    Redim As Ulong b( 0 To n )    ' sufficient array
    '-----------------------------------------------
    Dim As Integer i, k = 0
    For i = Len( x ) To 4 Step - 8
        b( k ) = Valint( "&h" + Mid( x, i - 7, 8 ) )
        k += 1
    Next i
End Sub    ' b( ) now contains the hex string

'=======================================================================
' Dump a packed binary Ulong integer array to Hex on screen
'=======================================================================
Sub hex_dump( b() As Ulong )   ' Ulong binary array to hex_dump
    For i As Integer = Ubound( b ) To 0 Step -1
        Print Hex( b( i ), 8 );
        If i Then Print Chr( 250 );     ' dot separators 249 or 250
    Next i
    Print
End Sub

'=======================================================================
' make a random decimal test string with a non-zero leading digit
'=======================================================================
Function random_digits( Byval n As Integer ) As String
    Dim As String x = String( n, "x" )
    Randomize
    x[ 0 ] = Asc( "1" ) + Int( 9 * Rnd )    ' avoid leading zero
    For i As Integer = 1 To Len( x ) - 1
        x[ i ] = Asc( "0" ) + Int( 10 * Rnd )   ' digits 0 to 9 only
    Next i
    Return x
End Function

'=======================================================================
' End of file
'=======================================================================
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Richard

Hi Richard!

I was thinking, if you convert to binary then you can step by 32 bits..without a sub-carry.
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

Albert wrote:I was thinking, if you convert to binary then you can step by 32 bits..without a sub-carry.
There are many possibilities. Go ahead and see what you can do.

The resized array can be referenced by pointers as 8, 16 or 32 bit unsigned integers. Because the array gets an extra zero most significant element you can also reference it as 64 bit Uintegers.

Use something like this to make the different span pointers into b().
Dim As Ulong Ptr b_ptr = Cptr( Ulong Ptr, @b( 0 ) )
Locked