Squares

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

Re: Squares

Post by albert »

@Richard

I found the bug in the compressor...It doesn't compress after all...

CVS( "AA" ) returns 0 in every instance... The CVS function , is broken. it returns 0 for single chars and double chars...
So it was assigning all the location pointers to element 0

Interesting!!

it compresses when all the locations are assigned to a single string.. but not when the locations are spaced out..
It gives me a little insight into how the compressor is working..Maybe i can figure something out
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

Albert wrote:I found the bug in the compressor...It doesn't compress after all...
Albert wrote:It gives me a little insight into how the compressor is working..Maybe i can figure something out
I believe you are searching for something that does not exist. When you claim you can compress whole files down to a residue or seed of only one byte, you are effectively saying that you can only regenerate 256 possible different files. We know there are billions of different files, so compression of entire files to a single small seed must be impossible.
There must also be a dictionary or codebook.

To compress a file you must generate a smaller file that contains both a dictionary and the instructions needed to restore the original file from the dictionary.

For lossless compression, the last entry in the dictionary will be the seed or residue that resulted from compression.
For lossy compression, that residue is discarded as it represents the background noise after all relevant patterns have been recorded and extracted.
dodicat
Posts: 7978
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert
The cvs function needs four characters otherwise it returns zero.
I see your general point though. You compress with zlib, then change the format of the compressed file, in the hope of getting some more repetitions and run this through zlib again, at the same time reserving the capability to reverse your format changes for the decompression stages.
I think the idea is sound enough.
It is hard though, because your format change has to be reasonably concise each run , and completely reversible.
You are taking on a difficult task as usual.
dodicat
Posts: 7978
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.
Just got Freeview recently for the television.
Tons of channels, including the outback opal hunters which is fascinating.
I should have stayed in Australia all those years ago, perhaps I would have been an opal hunter.
I made up a childish sizzler outback. With -gen gas

Code: Select all


Type V3
    As long x,y,z
End Type

Type screendata
    As Integer w,h,depth,bpp,pitch
    As Any Pointer row
    As Ulong Pointer pixel32
End Type
#define vct Type<V3>
#define Intrange(f,l) int(Rnd*(((l)+1)-(f))+(f))
'Operators on the x,y,z of Type V3
Operator + (v1 As V3,v2 As V3) As V3
Return vct(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(v1 As V3,v2 As V3) As V3
Return vct(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (f As Single,v1 As V3) As V3 'scalar*V3
Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator * (v1 As V3,f As Single) As V3 'V3*scalar
Return f*v1
End Operator

Function length(v As V3) As long
    Return Sqr(v.x*v.x+v.y*v.y+v.z*v.z)
End Function

'Spline functions
Function catmull(p() As V3,t As Single) As V3
    Return 0.5 *(     (2 * P(2)) +_
    (-1*P(1) + P(3)) * t +_
    (2*P(1) - 5*P(2) + 4*P(3) - P(4)) * t*t +_
    (-1*P(1) + 3*P(2)- 3*P(3) + P(4)) * t*t*t)
End Function

Sub FetchCatmull(v() As V3,outarray() As V3,arraysize As long=1000)
    Dim As V3 p(1 To 4)
    Redim outarray(0)
    Dim As Single stepsize=(Ubound(v)-1)/(arraysize)
    If stepsize>1 Then stepsize=1
    For n As long=2 To Ubound(v)-2
        p(1)=v(n-1):p(2)=v(n):p(3)=v(n+1):p(4)=v(n+2)
        For t As Single=0 To 1 Step stepsize
            Var temp=catmull(p(),t)
            Redim Preserve outarray(1 To Ubound(outarray)+1)
            outarray(Ubound(outarray))=temp
        Next t
    Next n
End Sub
'Bressenham line 2d
Sub bline(sd As screendata,x1 As long,y1 As long,x2 As long,y2 As long,col As Ulong)
    #define ppset32(_x,_y,colour) *Cptr(Ulong Ptr,sd.row+ (_y)*sd.pitch+ (_x) Shl 2)  =(colour)
    #define onscreen ((x1+x)>=0) And ((x1+x)<(sd.w-1)) And ((y1+y)>=0) And ((y1+y)<(sd.h-1))
    Var dx=Abs(x2-x1),dy=Abs(y2-y1),sx=Sgn(x2-x1),sy=Sgn(y2-y1)
    Dim As long e
    If dx<dy Then  e=dx\2 Else e=dy\2
    Do
        For x As long=0 To 1
            For y As long=0 To 1
                If onscreen Then
                     ppset32((x1+x),(y1+y),col)
                End If
            Next y
        Next x
        If x1 = x2 Then If y1 = y2 Then Exit Do
        If dx > dy Then
            x1 += sx : e -= dy : If e < 0 Then e += dx : y1 += sy
        Else
            y1 += sy : e -= dx : If e < 0 Then e += dy : x1 += sx
        End If
    Loop
End Sub
'Bressenham line thickened
Sub thickline(sd As screendata,_
    x1 As Long,_
    y1 As Long,_
    x2 As Long,_
    y2 As Long,_
    thickness As Single,_
    colour As Ulong)
    Var h=Sqr((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1))
    Var s=(y1-y2)/h
    Var c=(x2-x1)/h
    For yp As Double=-thickness/2 To thickness/2 
        bline(sd,x1+(s*yp),y1+(c*yp),x2+(s*yp),y2+(c*yp),colour)
    Next yp
End Sub
'Interpolating points joined by lines
Sub drawpoints(s As screendata,a() As V3,col As Ulong,th As Single)
    For z As long=Lbound(a)+1 To Ubound(a)
        thickline(s,a(z-1).x,a(z-1).y,a(z).x,a(z).y,th,col)
    Next z
End Sub
'extrapolate line beyond end point
Function LineTo(p1 As v3,p2 As v3,l As Single) As V3
    Return vct(p1.x+l*(p2.x-p1.x),p1.y+l*(p2.y-p1.y),p1.z+l*(p2.z-p1.z))
End Function

Sub bendyline(s As screendata,p1 As V3,p2 As V3,b As v3,col As Ulong,th As Single)
    Var lngth=length(b-p1)+length(b-p2)
    static As v3 a(1 To 5)
    Var t=LineTo(b,p1,1.25):a(1)=vct(t.x,t.y,t.z)
    a(2)=p1:a(3)=b: a(4)=p2
    t=LineTo(b,p2,1.25):a(5)=vct(t.x,t.y,t.z)
    Redim As v3 C()
    FetchCatmull(a(),c(),2*lngth) '2*lngth=number of interpolating points
    Drawpoints(s,c(),col,th)      'Join by Bressenham thick line
End Sub

Function drawline(x As Long,y As Long,angle As Double,ln As Double) As v3
    angle=angle*.0174532925199433  '=4*atn(1)/180
    Var x2=x+ln*Cos(angle)
    Var y2=y-ln*Sin(angle)
    Return Type(x2,y2)
End Function

Function Ellipse(x As long,y As long,rx As long,ry As long,angle As long,col As Ulong,paintflag As long=1) As String
    Dim As String s="Ta" &angle &"Bm" &x &"," &y:s+="Bm+" &rx &"," &0:s+="C" &col
    Dim As Single pi2=8*Atn(1)
    Dim As long lx,ly
    For z As Single=0 To pi2*1.1 Step pi2/60 '60 steps
        If z>pi2 Then Exit For
        Dim As long xpos=rx*Cos(z)
        Dim As long ypos=ry*Sin(z)
        If z<>0 Then s+="M+" &(xpos-lx) &"," &(ypos-ly)
        lx=xpos:ly=ypos
    Next z
    If paintflag Then s+="BM" &x &"," &y &"P" &col &"," &col
    Return s
End Function

Sub tree(x As Long,y As Long,sz As Long,clr As Ulong,i As Any Ptr,s As screendata)
    Var a=90+Rnd*40-Rnd*40
    Var p=drawline(x,y,a,sz)
    thickline(s,x,y,p.x,p.y,sz/5,Rgb(200,100,00))
    Draw i,ellipse(p.x,p.y,sz,sz/5,a+90,Rgb(0,250,0))
End Sub

Function start As Long
    Screenres 900,500,32
    windowtitle "Heatwave"
    Dim As screendata ThisScreen,thisimage
    With ThisScreen
        Screeninfo .w,.h,.depth,.bpp,.pitch
        .row=Screenptr
    End With
    Dim As Any Ptr i=Imagecreate(900,500,Rgb(0,100,255))
    Dim As Any Ptr i2=Imagecreate(900,500,Rgb(0,100,255))
    
    With thisimage
        Imageinfo i,.w,.h,.bpp,.pitch,.row
        .depth=32
    End With
    
    For n As Long=0 To 250
        Line i,(0,n)-(900,n),Rgb(n,n,255)
    Next n
    Circle i,(450,200),100,Rgb(255,0,0),,,,f
    Circle i,(100,200),100,Rgb(255,255,255),,,.2,f
    thickline(thisimage,650,260,670,200,20,Rgb(200,100,00))
    Circle i,(670,200),100,Rgb(0,200,0),,,.2,f
    Line i,(0,250)-(900,500),Rgb(255,255,0),bf
    
    For n As Long=1 To 5
        Static As Long y=300
        Var x=intrange(20,890)
        Var sz=y/5
        y+=20
        tree(x,y,sz,Rgb(0,255,0),i,thisimage)
    Next
    For y As Long=0 To 500
        For x As Long=0 To 899
            Var p=Point(x,y,i)
            Var r=Cast(Ubyte Ptr,@p)[2],g=Cast(Ubyte Ptr,@p)[1],b=Cast(Ubyte Ptr,@p)[0] 
            Pset i2,(x,y),Rgb(b,g,r)
        Next
    Next
    
    Dim As v3 p1,p2
    Dim As long mx,my,btn,flag
    #define dist(a,b) sqr( (a.x-b.x)^2 + (a.y-b.y)^2)
    #define k iif(rnd>.5,1,-1)
    Do
        Getmouse mx,my,,btn
        Screenlock
        If btn And flag=0 Then 
            Var p=Point(mx,my,i2)
            Var r=Cast(Ubyte Ptr,@p)[2],g=Cast(Ubyte Ptr,@p)[1],b=Cast(Ubyte Ptr,@p)[0]
        End If
        p1=vct(IntRange(0,899),IntRange(0,499))
        Var d=dist(Type<v3>(0,0),Type<v3>(mx,my))
        d=d/10
        Var clr=Point(p1.x,p1.y,i)
        Var clr2=Rgb(Cast(Ubyte Ptr,@clr)[2],Cast(Ubyte Ptr,@clr)[1],Cast(Ubyte Ptr,@clr)[0])
        p2=vct(p1.x+k*d,p1.y+k*d)
        Circle(p1.x,p1.y),6,clr2,,,,f
        bendyline(thisscreen,p1,p2,.5*(p1+p2)+vct(IntRange(-d/2,d/2),IntRange(-d/2,d/2),0),clr,d/15)
        Circle(p2.x,p2.y),6,clr2,,,,f
        Screenunlock
        
        For n As Long=0 To 1000
        Next
        flag=btn
    Loop Until Len(Inkey)
    
    Sleep
    Return 0
End Function

End start

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

Re: Squares

Post by albert »

@Dodicat

It's amazing ; how you can get so much action , out of so little code..
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

That is not a heatwave, that is normal for the Australian outback.
It snowed here yesterday, and I need to warm up the colours. It is more realistic with a yellow sun and the ground as red ochre. I have #defined the colours and white spaced the code.

Code: Select all

Type V3
    As Long x, y, z
End Type

Type screendata
    As Integer w, h, depth, bpp, pitch
    As Any Pointer row
    As Ulong Pointer pixel32
End Type

#define vct Type<V3>
#define Intrange(f,l) int(Rnd*(((l)+1)-(f))+(f))

'Operators on the x,y,z of Type V3
Operator + ( Byref v1 As V3, Byref v2 As V3 ) As V3
Return vct( v1.x + v2.x, v1.y + v2.y, v1.z + v2.z )
End Operator

Operator - ( Byref v1 As V3, Byref v2 As V3 ) As V3
Return vct( v1.x - v2.x, v1.y - v2.y, v1.z - v2.z )
End Operator

Operator * ( Byref f As Single, Byref v1 As V3 ) As V3 'scalar*V3
Return vct( f * v1.x, f * v1.y, f * v1.z )
End Operator

Operator * ( Byref v1 As V3, Byref f As Single ) As V3 'V3*scalar
Return f * v1
End Operator

Function length( Byref v As V3 ) As Long
    Return Sqr( v.x * v.x + v.y * v.y + v.z * v.z )
End Function

'Spline functions
Function catmull( p() As V3, Byval t As Single ) As V3
    Return 0.5 * (     ( 2 * P( 2 ) ) + _
    ( - 1 * P( 1 ) + P( 3 ) ) * t + _
    ( 2 * P( 1 ) - 5 * P( 2 ) + 4 * P( 3 ) - P( 4 ) ) * t * t + _
    ( - 1 * P( 1 ) + 3 * P( 2 ) - 3 * P( 3 ) + P( 4 ) ) * t * t * t )
End Function

Sub FetchCatmull( v() As V3, outarray() As V3, Byval arraysize As Long = 1000 )
    Dim As V3 p( 1 To 4 )
    Redim outarray( 0 )
    Dim As Single stepsize = ( Ubound( v ) - 1 ) / ( arraysize )
    If stepsize > 1 Then stepsize = 1
    For n As Long = 2 To Ubound( v ) - 2
        p( 1 ) = v( n - 1 ) : p( 2 ) = v( n ) : p( 3 ) = v( n + 1 ) : p( 4 ) = v( n + 2 )
        For t As Single = 0 To 1 Step stepsize
            Var temp = catmull( p(), t )
            Redim Preserve outarray( 1 To Ubound( outarray ) + 1 )
            outarray( Ubound( outarray ) ) = temp
        Next t
    Next n
End Sub

'Bressenham line 2d
Sub bline( Byref sd As screendata, Byval x1 As Long, Byval y1 As Long, Byval x2 As Long, Byval y2 As Long, Byval col As Ulong )
    #define ppset32(_x,_y,colour) *Cptr(Ulong Ptr,sd.row+ (_y)*sd.pitch+ (_x) Shl 2)  =(colour)
    #define onscreen ((x1+x)>=0) And ((x1+x)<(sd.w-1)) And ((y1+y)>=0) And ((y1+y)<(sd.h-1))
    Var dx = Abs( x2 - x1 ), dy = Abs( y2 - y1 ), sx = Sgn( x2 - x1 ), sy = Sgn( y2 - y1 )
    Dim As Long e
    If dx < dy Then  e = dx \ 2 Else e = dy \ 2
    Do
        For x As Long = 0 To 1
            For y As Long = 0 To 1
                If onscreen Then
                    ppset32( ( x1 + x ), ( y1 + y ), col )
                End If
            Next y
        Next x
        If x1 = x2 Then If y1 = y2 Then Exit Do
        If dx > dy Then
            x1 += sx : e -= dy : If e < 0 Then e += dx : y1 += sy
        Else
            y1 += sy : e -= dx : If e < 0 Then e += dy : x1 += sx
        End If
    Loop
End Sub

'Bressenham line thickened
Sub thickline( Byref sd As screendata, _
    Byval x1 As Long, _
    Byval y1 As Long, _
    Byval x2 As Long, _
    Byval y2 As Long, _
    Byval thickness As Single, _
    Byval colour As Ulong )
    Var h = Sqr( ( x2 - x1 ) * ( x2 - x1 ) + ( y2 - y1 ) * ( y2 - y1 ) )
    Var s = ( y1 - y2 ) / h
    Var c = ( x2 - x1 ) / h
    For yp As Double = - thickness / 2 To thickness / 2
        bline( sd, x1 + ( s * yp ), y1 + ( c * yp ), x2 + ( s * yp ), y2 + ( c * yp ), colour )
    Next yp
End Sub

'Interpolating points joined by lines
Sub drawpoints( Byref s As screendata, a() As V3, Byval col As Ulong, Byval th As Single )
    For z As Long = Lbound( a ) + 1 To Ubound( a )
        thickline( s, a( z - 1 ).x, a( z - 1 ).y, a( z ).x, a( z ).y, th, col )
    Next z
End Sub

'extrapolate line beyond end point
Function LineTo( Byref p1 As v3, Byref p2 As v3, Byval l As Single ) As V3
    Return vct( p1.x + l * ( p2.x - p1.x ), p1.y + l * ( p2.y - p1.y ), p1.z + l * ( p2.z - p1.z ) )
End Function

Sub bendyline( Byref s As screendata, Byref p1 As V3, Byref p2 As V3, Byref b As v3, Byval col As Ulong, Byval th As Single )
    Var lngth = length( b - p1 ) + length( b - p2 )
    Static As v3 a( 1 To 5 )
    Var t = LineTo( b, p1, 1.25 ) : a( 1 ) = vct( t.x, t.y, t.z )
    a( 2 ) = p1 : a( 3 ) = b : a( 4 ) = p2
    t = LineTo( b, p2, 1.25 ) : a( 5 ) = vct( t.x, t.y, t.z )
    Redim As v3 C()
    FetchCatmull( a(), c(), 2 * lngth ) ' 2 * lngth = number of interpolating points
    Drawpoints( s, c(), col, th )       ' Join by Bressenham thick line
End Sub

Function drawline( Byval x As Long, Byval y As Long, Byval angle As Double, Byval ln As Double ) As v3
    angle = angle * .0174532925199433  ' = 4 * atn( 1 ) / 180
    Var x2 = x + ln * Cos( angle )
    Var y2 = y - ln * Sin( angle )
    Return Type( x2, y2 )
End Function

Function Ellipse( Byval x As Long, Byval y As Long, Byval rx As Long, Byval ry As Long, Byval angle As Long, Byval col As Ulong, Byval paintflag As Long = 1 ) As String
    Dim As String s = "Ta" &angle &"Bm" &x &"," &y : s += "Bm+" &rx &"," &0 : s += "C" &col
    Dim As Single pi2 = 8 * Atn( 1 )
    Dim As Long lx, ly
    For z As Single = 0 To pi2 * 1.1 Step pi2 / 60 '60 steps
        If z > pi2 Then Exit For
        Dim As Long xpos = rx * Cos( z )
        Dim As Long ypos = ry * Sin( z )
        If z <> 0 Then s += "M+" &( xpos - lx ) &"," &( ypos - ly )
        lx = xpos : ly = ypos
    Next z
    If paintflag Then s += "BM" &x &"," &y &"P" &col &"," &col
    Return s
End Function

#define blue  Rgb(   0, 100, 255 )
#define ochre Rgb( 190,  20,   0 )
#define white Rgb( 255, 255, 255 )
#define brown Rgb( 200, 100,  00 )
#define green Rgb(   0, 200,   0 ) ' tree leaf on horizon
#define dk_gr Rgb(   0, 220,   0 )
#define yellow Rgb(255, 255,   0 )

#define leafs  dk_gr  ' Rgb( 0, 255, 0 )
#define sky    blue
#define ground ochre
#define cloud  white
#define trunk  brown
#define leaf   green
#define sun   yellow

Sub tree( Byval x As Long, Byval y As Long, Byval sz As Long, Byval clr As Ulong, Byval i As Any Ptr, Byref s As screendata )
    Var a = 90 + Rnd * 40 - Rnd * 40
    Var p = drawline( x, y, a, sz )
    thickline( s, x, y, p.x, p.y, sz / 5, trunk )
    Draw i, ellipse( p.x, p.y, sz, sz / 5, a + 90, leaf )
End Sub

Function start As Long
    Screenres 900, 500, 32
    Windowtitle "Heatwave"
    Dim As screendata ThisScreen, thisimage
    With ThisScreen
        Screeninfo .w, .h, .depth, .bpp, .pitch
        .row = Screenptr
    End With
    Dim As Any Ptr i = Imagecreate( 900, 500, sun )
    Dim As Any Ptr i2 = Imagecreate( 900, 500, sky )
    
    With thisimage
        Imageinfo i, .w, .h, .bpp, .pitch, .row
        .depth = 32
    End With
    
    For n As Long = 0 To 250
        Line i, ( 0, n ) - ( 900, n ), Rgb( n, n, 255 )
    Next n
    Circle i, ( 450, 200 ), 100, sun, , , , f
    Circle i, ( 100, 200 ), 100, cloud, , , .2, f
    thickline( thisimage, 650, 260, 670, 200, 20, trunk )
    Circle i, ( 670, 200 ), 100, leaf , , , .2, f
    Line i, ( 0, 250 ) - ( 900, 500 ), ground, bf
    
    For n As Long = 1 To 5
        Static As Long y = 300
        Var x = intrange( 20, 890 )
        Var sz = y / 5
        y += 20
        tree( x, y, sz, leafs, i, thisimage )
    Next
    
    For y As Long = 0 To 500
        For x As Long = 0 To 899
            Var p = Point( x, y, i )
            Var r = Cast( Ubyte Ptr, @p )[ 2 ], g = Cast( Ubyte Ptr, @p )[ 1 ], b = Cast( Ubyte Ptr, @p )[ 0 ]
            Pset i2, ( x, y ), Rgb( b, g, r )
        Next
    Next
    
    Dim As v3 p1, p2
    Dim As Long mx, my, btn, flag
    #define dist(a,b) Sqr( ( a.x - b.x )^2 + ( a.y - b.y )^2 )
    #define k Iif( Rnd > .5, 1, -1 )
    Do
        Getmouse mx, my, , btn
        Screenlock
        If btn And flag = 0 Then
            Var p = Point( mx, my, i2 )
            Var r = Cast( Ubyte Ptr, @p )[ 2 ], g = Cast( Ubyte Ptr, @p )[ 1 ], b = Cast( Ubyte Ptr, @p )[ 0 ]
        End If
        p1 = vct( IntRange( 0, 899 ), IntRange( 0, 499 ) )
        Var d = dist( Type < v3 > ( 0, 0 ), Type < v3 > ( mx, my ) )
        d = d / 10
        Var clr = Point( p1.x, p1.y, i )
        Var clr2 = Rgb( Cast( Ubyte Ptr, @clr )[ 2 ], Cast( Ubyte Ptr, @clr )[ 1 ], Cast( Ubyte Ptr, @clr )[ 0 ] )
        p2 = vct( p1.x + k * d, p1.y + k * d )
        Circle( p1.x, p1.y ), 6, clr2, , , , f
        bendyline( thisscreen, p1, p2, .5 * ( p1 + p2 ) + vct( IntRange( - d / 2, d / 2 ), IntRange( - d / 2, d / 2 ), 0 ), clr, d / 15 )
        Circle( p2.x, p2.y ), 6, clr2, , , , f
        Screenunlock
        
        For n As Long = 0 To 1000
        Next
        flag = btn
    Loop Until Len( Inkey )
    
    Sleep
    
    Return 0
End Function

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

Re: Squares

Post by albert »

@Richard
@Dodicat

I've got another compression formula , But it doesn't compress.... It outputs 1:1 ( when used in conjunction with Dodicats zip it compresses. )

I can't get the de-compressor to output the input...

Can one of you guys help??

Code: Select all


Declare Function compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

dim as double time1,time2,time3,time4
do
    
    randomize
    
    dim as string s=""
    For n As Long = 1 To 10
        s+=chr(Int(Rnd*256))'+8)
    Next
    
    time1=timer
    'begin compress
        dim as string comp = compress_loop(s)
    'end compress
    time2 = timer
    
    time3=timer
    'begin decompress
        dim as string final_out = decompress_loop(comp) 
    'end decompress
    time4 = timer
    
    print
    print string(99,"=")
    print "inp = " ; s
    print string(99,"=")
    print "out = " ; final_out
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
    
    if s = final_out then print "Decompressed OK" else print "Decompression failed." 
    
    sleep
    
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    for a as longint = 1 to len(chrs) step 2
        n1 = bin( (chrs[a-1] * 100)  + chrs[a] )
        
        print "n1 = " ; len(n1) ' check for size
        
        binari+=right(string(16,"0") + n1,16)
    next
    
    print "inp = "  ; len(chrs) , chrs
    print
    print "bin = " ; len(binari) , binari
    
    dim as string outputs=""
    dim as string v1
    for a as longint = 1 to len(binari) step 8
        v1 = mid(binari,a,8)
        n1 = right("00"+hex(valulng("&B"+v1)),2)
        outputs+=n1
    next
    
    print "hex = " ; len(outputs) , outputs
    
    dim as string final_out =""
    for a as longint = 1 to len(outputs) step 2
       final_out+=chr(valulng("&H"+mid(outputs,a,2)))
    next
    
    print "fin = "; len(final_out) , final_out
        
    return final_out
        
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
    
    print
    
    dim as string binari=""
    dim as string n1
    for a as longint = 1 to len(chrs) step 1
        n1 = hex(chrs[a-1])
        binari+=right("00" + n1,2)
    next
    
    print "inp = " ; len(binari) , binari
    
    dim as string outputs=""
    dim as ulongint v1
    for a as longint = 1 to len(binari) step 2
        v1 = val("&H"+mid(binari,a,2))
        outputs+=right("00000000"+bin(v1),8)
    next
    
    print "out = " ; len(outputs) , outputs
    
    dim as string final_out = ""
    for a as longint = 1 to len(outputs) step 16
        n1 = bin(valulng("&B"+mid(outputs,a,16)))
        
        print "n1 = " ; len(n1) ' check for size
        
        for b as longint = 0 to 255
            for c as longint = 0 to 255
                if bin( (b*100) + c ) = n1 then final_out+=chr(b)+chr(c) : goto done
            next
        next
        done:
    next
    
    print "fin = "; len(final_out) , final_out
    
    return final_out
    
end function

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

Re: Squares

Post by albert »

@Richard
@Dodicat

I found the bug:

n1 = bin( ( chrs[a-1] * 100 ) + chrs[a] ) , the third digit , is overlapped ; so there's like 9 different values , that equal the bin value.

Should be : bin( ( chrs[a-1] * 1000 ) + chrs[a] ) , but then it equals 18 bits , so it positively won't compress...

But this compresses:
n1 = bin( chrs[a] ) : out = right( "11111111" + "0" + n1 , 8) : but if len( n1 ) = 8 you lose the zero identifier...
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Squares

Post by badidea »

Just for fun, a (non-square) color wheel

Code: Select all

const as integer NUM_COLORS = 6 * 256
dim as ulong colorWheel(NUM_COLORS - 1)

dim as integer colorIndex = 0
for section as integer = 0 to 6 - 1
	for intensity as integer = 0 to 256 - 1
		select case section
		case 0: colorWheel(colorIndex) = rgb(255, intensity, 0) 'green up
		case 1: colorWheel(colorIndex) = rgb(255 - intensity, 255, 0) 'red down
		case 2: colorWheel(colorIndex) = rgb(0, 255, intensity) 'blue up
		case 3: colorWheel(colorIndex) = rgb(0, 255 - intensity, 255) 'green down
		case 4: colorWheel(colorIndex) = rgb(intensity, 0, 255) 'red up
		case 5: colorWheel(colorIndex) = rgb(255, 0, 255 - intensity) 'blue down
		end select
		colorIndex += 1
	next
next

dim as double angle, pi2 = 2 * 3.1416
dim as double angleStep = (pi2 / NUM_COLORS) * 20

screenres 800, 600, 32

colorIndex = 0
for angle = 0 to pi2 step angleStep
	colorIndex = (angle * NUM_COLORS) / pi2
	if colorIndex >= NUM_COLORS then exit for
	line (400, 300)-step(200 * cos(angle), -200 * sin(angle)), colorWheel(colorIndex)
	circle(400 + 200 * cos(angle), 300 - 200 * sin(angle)), 10, colorWheel(colorIndex),,,,f
	sleep 15,0
next

print "press any key to exit"
while inkey = "": wend
Or with a function:

Code: Select all

function getColor(byval hue as single) as ulong
	if hue < 0 then hue = 0
	if hue > 1 then hue = 1
	hue *= 6
	dim as integer intensity = (int(hue * 256) and 255)
	select case hue
	case is < 1: return rgb(255, intensity, 0)
	case is < 2: return rgb(255 - intensity, 255, 0)
	case is < 3: return rgb(0, 255, intensity)
	case is < 4: return rgb(0, 255 - intensity, 255)
	case is < 5: return rgb(intensity, 0, 255)
	case else: return rgb(255, 0, 255 - intensity)
	end select
	return 0 'never
end function

dim as double angle, pi2 = 2 * 3.1416
dim as double angleStep = pi2 / 500

screenres 800, 600, 32

for angle = 0 to pi2 - (angleStep / 2) step angleStep
	line (400, 300)-step(200 * cos(3*angle), -200 * sin(angle)), getColor(angle / pi2)
	circle(400 + 200 * cos(3*angle), 300 - 200 * sin(angle)), 10, getColor(angle / pi2),,,,f
	sleep 15,0
next

print "press any key to exit"
while inkey = "": wend
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Richrad
@Dodicat

I got another formula that compresses...
( compresses ; only when used in conjunction with Dodi's zip lib code. Compresses 10K to 1K after 40 loops..)

Somehow I've got to figure out , if the original binary is 1,3,5,7 bits..
It steps through the raw bin by two's , and turns the two bits into 2 bits.
So:
If there's an odd number of bits (1,3,5,7) , you get and extra "00" or "01" at the end ; that needs to be turned back into a "0" or "1"
I can't figure out how to tell if the original is an odd number...

1 bit turns into 2
3 bits turns into 4
5 bits turns into 6
7 bits turns into 8

i can't tell 2,4,6,8 from 1,3,5,7 ???

Can one of you guys help???

Code: Select all


Declare Function compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

dim as double time1,time2,time3,time4
do
    
    randomize
    
    dim as string s=""
    For n As Long = 1 To 10
        s+=chr(Int(Rnd*256))'+8)
    Next
    
    time1=timer
    'begin compress
        dim as string comp = compress_loop(s)
    'end compress
    time2 = timer
    
    time3=timer
    'begin decompress
        dim as string final_out = decompress_loop(comp) 
    'end decompress
    time4 = timer
    
    'print
    print string(99,"=")
    print "inp = " ; s
    print string(99,"=")
    print "out = " ; final_out
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
    
    if s = final_out then print "Decompressed OK" else print "Decompression failed." 
    
    sleep
    
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
    
    print
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        n1 = bin(*ubp) : ubp+=1
        n2=""
        for b as longint = 1 to len(n1) step 2
            n2+=right("00"+bin(val("&B"+mid(n1,b,2))),2)
        next
        
        n2 = right("00000000"+n2,8)
        
        print "n1 = "; n1 , n2
        
        binari+=n2
        
    next
    
    print
    'print "inp = "  ; len(chrs) , chrs
    print "bin = "  ; len(binari) , binari
    
    dim as string final_out =""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
    
    'print "fin = "; len(final_out) , final_out
    
    return final_out
        
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        n1=bin(*ubp) : ubp+=1
        binari+=right("00000000"+n1,8)
    next
    
    print "bin = "  ; len(binari) , binari
    print
    
    for a as longint = 1 to len(binari) step 8
        
        n1 = ltrim(mid(binari,a,8),"0") : if n1="" then n1="0"
        
        print "n1 = " ; n1
        
    next
    
    dim as string final_out = chrs
    
    return final_out
    
end function

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

Re: Squares

Post by dodicat »

Nice colours Richard, you've probably lived in it.
Much as I am intrigued by these opal hunters, they leave a bit of a mess.
Nice spectrum of colours Badidea, everything is for fun in squares.
Back to the grindstone Albert! Again.
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Re: Squares

Post by albert »

@Richard
@Dodicat

I've tried everything i can think of:

tried swapping bits
tried rotating bits
tried bubble sorting bits with a map.

tried over a hundred formulas

nothing so far seems to compress...
If it compresses , then i have an error somewhere in the code.

The only thing that seems to work , is turning a bit into another bit. but then you don't know if it supposed to be a 0 or a 1??

if mid( 8 bits , 1 , 1 ) = "1" then mid( 8 bits , 1 , 1 ) = "0" , works ... Compresses 94% over 40 loops... but it can't be reversed.
Here's the code for the first bit ( 1 to 0 ) lossey compression.. ( compresses 10K to 500 bytes over 40 loops )

Code: Select all


Declare Function   compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

Namespace Zlibrary

#inclib "zlib"
Extern "C"
    Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
    Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
    Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern

Function getpassedinfo(text As String,Byref passed_length As Integer) As String
    Dim As String var1,var2
    Dim As Integer pst
    #macro splice(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
        var1=Mid(stri,1,pst-1)
        var2=Mid(stri,pst+1)
    Else
        var1=stri
    End If
    #endmacro
    splice(text,"|",var1,var2)
    text=var2
    passed_length=Valint(var1)
    Return text
End Function


'=================   UNPACK ===============
Function unpack(file As String) As String
    Dim As Integer passed_length
    Dim As String text=getpassedinfo(file,passed_length)
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength =passed_length
    Dim As Ubyte Ptr source
    Dim As Ubyte Ptr  destination =Callocate(destinationlength,1)
    source=@text[0]
    Var mistake=uncompress(destination,@destinationlength, source, stringlength)
    If mistake<>0 Then Print "There was an error":Sleep:End
    Dim As String uncompressed
    uncompressed=String(destinationlength,0)
    For i As Integer = 0 To destinationlength- 1
        uncompressed[i]=(destination[i])
    Next
    Deallocate destination
    Return uncompressed
End Function

'===================  PACK ============
Function pack(file As String) As String
    Dim As String text=file
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength = compressBound(stringlength)
    Dim As Ubyte Ptr source
    Dim As Ubyte Ptr destination =Callocate(destinationlength,1)
    source=@text[0]
    Var mistake=compress(destination, @destinationlength, source, stringlength)
    If mistake <>0 Then Print "There was an error"
    Dim As String compressed
    compressed=String(destinationlength,0)
    For n As Integer=0 To destinationlength-1
        compressed[n]=destination[n]
    Next n
    compressed=stringlength &"|"+compressed
    Deallocate destination
    Return compressed
End Function

End Namespace


'==================================================================
'==================================================================
'test zipper 
'==================================================================
'==================================================================
screen 19

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0 
dim as longint loops = 0
do
    
    loops+=1
    
    'one time run , create initial string 
    if loops = 1 then
        For n As Long = 1 To 10000
            s+=chr(Int(Rnd*256))'+48)
        Next
        compare =  s
        length = len(s)
    else
        'modify compression to make further compression possible 
        
        s = compress_loop(s)
        
    end if
    check = s
    compression = (100 - ( 100 / ( length / len(check) ) ))
    
    Print "original string"
    Print Len(s)
    Print
   
    Dim As String compressed=Zlibrary.pack(s)
    s = compressed
    
    Print "packed string "
    Print Len(compressed)
    Print
    
    Dim As String uncompressed=Zlibrary.unpack(compressed)
   
    Print "Retrieve"
    Print Len(uncompressed)
    Print
    'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
    Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
    Print Iif(uncompressed=check,"OK","ERROR")
    Print "-------------------------------"
    
    'sleep 1000
    
    'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do
    
    print "press a key for next compression."
    print
    print "press esc to exit."
    sleep
    
    if inkey = chr(27) then exit do
    
loop until loops = 40

print "Press a key to decompress."  
sleep

s = str(loops) + "_" + s ' save as an output file...

'==================================================================
'decompress
'==================================================================
dim as longint dec = instr(1,s,"_")
dim as longint count = val(left(s,dec-1))
dim as string comp = mid(s,dec+1)
dim as string val1
dim as string outs
for a as longint = count to 2 step -1
    s = Zlibrary.unpack(comp)
    outs = decompress_loop(s)
    comp = outs
next

comp = Zlibrary.unpack(comp)

print
print "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
print
if comp = compare then print "Decompression successful." else print "ERROR"
print
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1 
        
        n1 = bin(*ubp) : ubp+=1
        n1 = right(string(8,"0") +n1,8)
        
        if mid(n1,1,1) = "1" then mid(n1,1,1) = "0"
        
        binari+=n1
    next
    
    print "inp = "  ; len(chrs)
    print "bin = "  ; len(binari) ', binari

    dim as string final_out =""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
    
    print "fin = "; len(final_out)
        
    return final_out
        
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        n1 = bin(*ubp) : ubp+=1
        
        n1=right(string(8,"0") +n1,8)
        
        'print "n1 = "; n1
        
        binari+=n1
        
    next
    
    'print "bin = "  ; len(binari) , binari
    
    dim as string final_out = ""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
    
    return final_out

end function

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

DATA COMPRESSION

Post by albert »

Works , just as well ; stetting the 8th bit to 0 .... ( Compresses 10K to 600 bytes over 40 loops. )

I tried ushorts , it doesn't work.. It expands.. Only works with ubytes

Since in every case , the last bit = 0 ; you can take off the last bit , and it compresses 10K to 150 bytes over 40 loops.
Then you don't need Dodicats Zlib code..

Code: Select all


Declare Function   compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

Namespace Zlibrary

#inclib "zlib"
Extern "C"
    Declare Function compressBound(Byval sourceLen As Ulong) As Ulong
    Declare Function uncompress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
    Declare Function compress(Byval dest As Ubyte Ptr, Byval destLen As Uinteger Ptr, Byval source As  Ubyte Ptr, Byval sourceLen As Ulong) As Long
End Extern

Function getpassedinfo(text As String,Byref passed_length As Integer) As String
    Dim As String var1,var2
    Dim As Integer pst
    #macro splice(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2="" 
    If pst<>0 Then
        var1=Mid(stri,1,pst-1)
        var2=Mid(stri,pst+1)
    Else
        var1=stri
    End If
    #endmacro
    splice(text,"|",var1,var2)
    text=var2
    passed_length=Valint(var1)
    Return text
End Function


'=================   UNPACK ===============
Function unpack(file As String) As String
    Dim As Integer passed_length
    Dim As String text=getpassedinfo(file,passed_length)
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength =passed_length
    Dim As Ubyte Ptr source
    Dim As Ubyte Ptr  destination =Callocate(destinationlength,1)
    source=@text[0]
    Var mistake=uncompress(destination,@destinationlength, source, stringlength)
    If mistake<>0 Then Print "There was an error":Sleep:End
    Dim As String uncompressed
    uncompressed=String(destinationlength,0)
    For i As Integer = 0 To destinationlength- 1
        uncompressed[i]=(destination[i])
    Next
    Deallocate destination
    Return uncompressed
End Function

'===================  PACK ============
Function pack(file As String) As String
    Dim As String text=file
    Dim As Integer stringlength,destinationlength
    stringlength=Len(text)
    destinationlength = compressBound(stringlength)
    Dim As Ubyte Ptr source
    Dim As Ubyte Ptr destination =Callocate(destinationlength,1)
    source=@text[0]
    Var mistake=compress(destination, @destinationlength, source, stringlength)
    If mistake <>0 Then Print "There was an error"
    Dim As String compressed
    compressed=String(destinationlength,0)
    For n As Integer=0 To destinationlength-1
        compressed[n]=destination[n]
    Next n
    compressed=stringlength &"|"+compressed
    Deallocate destination
    Return compressed
End Function

End Namespace


'==================================================================
'==================================================================
'test zipper 
'==================================================================
'==================================================================
screen 19

Dim Shared As String s

Randomize

s=""
dim as string check=""
dim as string compare=""
dim as longint length = 0
dim as double compression = 0 
dim as longint loops = 0
do
    
    loops+=1
    
    'one time run , create initial string 
    if loops = 1 then
        For n As Long = 1 To 10000
            s+=chr(Int(Rnd*256))'+48)
        Next
        compare =  s
        length = len(s)
    else
        'modify compression to make further compression possible 
        
        s = compress_loop(s)
        
    end if
    check = s
    compression = (100 - ( 100 / ( length / len(check) ) ))
    
    Print "original string"
    Print Len(s)
    Print
   
    Dim As String compressed=Zlibrary.pack(s)
    s = compressed
    
    Print "packed string "
    Print Len(compressed)
    Print
    
    Dim As String uncompressed=Zlibrary.unpack(compressed)
   
    Print "Retrieve"
    Print Len(uncompressed)
    Print
    'Print "compression ratio  "; 100 - ( 100 / ( Len(s) / len(compressed) ) ) ; "%"
    Print "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
    Print Iif(uncompressed=check,"OK","ERROR")
    Print "-------------------------------"
    
    'sleep 1000
    
    'if loops > 2 and (100 - ( 100 / ( length / len(s) ) )) < compression then exit do
    
    print "press a key for next compression."
    print
    print "press esc to exit."
    sleep
    
    if inkey = chr(27) then exit do
    
loop until loops = 40

print "Press a key to decompress."  
sleep

s = str(loops) + "_" + s ' save as an output file...

'==================================================================
'decompress
'==================================================================
dim as longint dec = instr(1,s,"_")
dim as longint count = val(left(s,dec-1))
dim as string comp = mid(s,dec+1)
dim as string val1
dim as string outs
for a as longint = count to 2 step -1
    s = Zlibrary.unpack(comp)
    outs = decompress_loop(s)
    comp = outs
next

comp = Zlibrary.unpack(comp)

print
print "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"
print
if comp = compare then print "Decompression successful." else print "ERROR"
print
Print "!!~~Done~~!!"

Sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1 
        
        n1 = bin(*ubp) : ubp+=1
        
        n1 = right(string(8,"0") +n1,8)
        
        mid(n1,len(n1),1) = "0"
        
        binari+=n1
    next
    
    print "inp = "  ; len(chrs)
    print "bin = "  ; len(binari) ', binari
    
    dim as string final_out =""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
    
    print "fin = "; len(final_out)
        
    return final_out
        
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        
        n1 = bin(*ubp) : ubp+=1
        
        n1=right(string(8,"0")+ n1,8)
        
        'print "n1 = "; n1
        
        binari+=n1
        
    next
    
    'print "bin = "  ; len(binari) , binari
    
    
    dim as string final_out = ""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
    
    return final_out

end function

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

DATA COMPRESSION

Post by albert »

Here ; i turned the input into 64 bits , and threw out the last bit... so you got 63 bits.
So it compresses 1 bit for each 8 bytes...so the input data needs to be greater than 128 bytes. The bigger the merrier....

1 bit out of 64 is a negligible loss..

Code: Select all


Declare Function compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

dim as double time1,time2,time3,time4
do
    
    randomize
    
    dim as string s=""
    For n As Long = 1 To 128
        s+=chr(Int(Rnd*256))'+8)
    Next
    
    time1=timer
    'begin compress
        dim as string comp = compress_loop(s)
    'end compress
    time2 = timer
    
    time3=timer
    'begin decompress
        dim as string final_out = decompress_loop(comp) 
    'end decompress
    time4 = timer
    
    'print
    print string(99,"=")
    print "inp = " ; s
    print string(99,"=")
    print "out = " ; final_out
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
    
    if s = final_out then print "Decompressed OK" else print "Decompression failed." 
    
    sleep
    
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        
        n1 = bin(*ubp) : ubp+=1
        
        n1 = right(string(64,"0") +n1,64)
        
        'mid(n1,8,1)="0"
        
        n1 = left(n1,63)
        
        binari+=n1
    
    next
    
    print "inp = "  ; len(chrs)
    print "bin = "  ; len(binari) , binari
    
    dim as longint count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(binari)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then binari+="0" : count+=1
    loop until dec1=0
    
    dim as string final_out ="" 
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
    
    final_out=chr(count) + final_out
    
    print "fin = "; len(final_out)
        
    return final_out
        
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as longint count = asc(left(chrs,1))
    chrs = mid(chrs,2)
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        
        n1 = bin(*ubp) : ubp+=1
        
        n1=right(string(8,"0")+ n1,8)
        
        'print "n1 = "; n1
        
        binari+=n1
        
    next
    
    binari=left(binari,len(binari)-count)
    
    print "bin = "  ; len(binari) , binari
    
    dim as string outputs=""
    for a as longint = 1 to len(binari) step 63
        n1=mid(binari,a,63) + "0"
        outputs+=n1
    next
    
    dim as string final_out = ""
    for a as longint = 1 to len(outputs) step 64
        final_out+=mklongint(valulng("&B"+mid(outputs,a,64)))
    next
    
    return final_out

end function

After multiple loops , it seems to make a big difference....
Heres 3 loops

Code: Select all


Declare Function compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

dim as double time1,time2,time3,time4
do
    
    randomize
    
    dim as string s=""
    For n As Long = 1 To 64*4
        s+=chr(Int(Rnd*256))'+8)
    Next
    
    time1=timer
    'begin compress
        dim as string comp=s
        for a as longint = 1 to 3 step 1
            comp = compress_loop(comp)
        next
    'end compress
    time2 = timer
    
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 3 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
    
    'print
    print string(99,"=")
    print "inp = " ; s
    print string(99,"=")
    print "out = " ; final_out
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
    
    if s = final_out then print "Decompressed OK" else print "Decompression failed." 
    
    sleep
    
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
        
        n1 = bin(*ubp) : ubp+=1
        
        n1 = right(string(64,"0") +n1,64)
        
        'mid(n1,8,1)="0"
        
        n1 = left(n1,63)
        
        binari+=n1
    
    next
    
    'print "inp = "  ; len(chrs)
    'print "bin = "  ; len(binari) ', binari
    
    dim as longint count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(binari)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then binari+="0" : count+=1
    loop until dec1=0
    
    dim as string final_out ="" 
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
    
    final_out=chr(count) + final_out
    
    'print "fin = "; len(final_out)
        
    return final_out
        
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
    
    dim as longint count = asc(left(chrs,1))
    chrs = mid(chrs,2)
    
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
        
        n1 = bin(*ubp) : ubp+=1
        
        n1=right(string(8,"0")+ n1,8)
        
        'print "n1 = "; n1
        
        binari+=n1
        
    next
    
    binari=left(binari,len(binari)-count)
    
    'print "bin = "  ; len(binari) ', binari
    
    dim as string outputs=""
    for a as longint = 1 to len(binari) step 63
        n1=mid(binari,a,63) + "0"
        outputs+=n1
    next
    
    dim as string final_out = ""
    for a as longint = 1 to len(outputs) step 64
        final_out+=mklongint(valulng("&B"+mid(outputs,a,64)))
    next
    
    return final_out

end function

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

Re: Squares

Post by albert »

@Richrad
@Dodicat

I'm getting extra characters at the end of the output?
After 3 loops of 800 bytes , i'm getting an 816 output , instead of 800..

Any ideas?? It's real simple code...

Code: Select all


Declare Function compress_loop( chrs as string ) as string
Declare Function decompress_loop( chrs as string ) as string

screen 19

dim as double time1,time2,time3,time4
do
   
    randomize
   
    dim as string s=""
    For n As Long = 1 To 8*100
        s+=chr(Int(Rnd*256))'+8)
    Next
   
    time1=timer
    'begin compress
        dim as string comp=s
        for a as longint = 1 to 3 step 1
            comp = compress_loop(comp)
        next
    'end compress
    time2 = timer
   
    time3=timer
    'begin decompress
        dim as string final_out = comp
        for a as longint = 1 to 3 step 1
            final_out = decompress_loop(final_out)
        next
    'end decompress
    time4 = timer
   
    'print
    print string(99,"=")
    print "inp = " ; s
    print string(99,"=")
    print "out = " ; final_out
    print
    print "compress time   = "; time2-time1
    print "decompress time = "; time4-time3
    print
   
    if s = final_out then print "Decompressed OK" else print "Decompression failed."
   
    sleep
   
loop until inkey = chr(27)

sleep
end
'===============================================================================
'===============================================================================
'begin functions
'===============================================================================
'===============================================================================
Function compress_loop( chrs as string ) as string
   
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ulongint ptr ubp = cptr(ulongint ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 8
       
        n1 = bin(*ubp) : ubp+=1
       
        n1 = right(string(64,"0") +n1,64)
       
        'mid(n1,8,1)="0"
       
        n1 = left(n1,63)
       
        binari+=n1
   
    next
   
    print "c  in = "  ; len(chrs)
    'print "bin = "  ; len(binari) ', binari
   
    dim as longint count=0
    dim as string str1
    dim as longint dec1
    do
        str1=str(len(binari)/8)
        dec1=instr(1,str1,".")
        if dec1<>0 then binari+="0" : count+=1
    loop until dec1=0
   
    dim as string final_out =""
    for a as longint = 1 to len(binari) step 8
        final_out+=chr(valulng("&B"+mid(binari,a,8)))
    next
   
    print "c out = "; len(final_out)
       
    final_out = str(count) + final_out
    
    return final_out
       
end function
'===============================================================================
'===============================================================================
Function decompress_loop( chrs as string ) as string
   
    dim as longint count = val(left(chrs,1))
   
    chrs = mid(chrs,2)
   
    print "d  in = "  ; len(chrs)
   
    dim as string binari=""
    dim as string n1
    dim as string n2
    dim as ubyte ptr ubp = cptr(ubyte ptr,strptr(chrs))
    for a as longint = 1 to len(chrs) step 1
       
        n1 = bin(*ubp) : ubp+=1
       
        n1=right(string(8,"0")+ n1,8)
       
        'print "n1 = "; n1
       
        binari+=n1
       
    next
   
    binari=left(binari,len(binari)-count)
   
    'print "bin = "  ; len(binari) ', binari
   
    dim as string outputs=""
    for a as longint = 1 to len(binari) step 63
        n1=mid(binari,a,63) + "1"
        outputs+=n1
    next
   
    dim as string final_out = ""
    for a as longint = 1 to len(outputs) step 64
        final_out+=mklongint(valulng("&B"+mid(outputs,a,64)))
    next
   
    print "d out = "; len(final_out)
   
    return final_out

end function

Locked