Squares
Re: Squares
@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
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
Re: Squares
Albert wrote:I found the bug in the compressor...It doesn't compress after all...
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.Albert wrote:It gives me a little insight into how the compressor is working..Maybe i can figure something out
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.
Re: Squares
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.
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.
Re: Squares
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
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
Re: Squares
@Dodicat
It's amazing ; how you can get so much action , out of so little code..
It's amazing ; how you can get so much action , out of so little code..
Re: Squares
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.
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
Re: Squares
@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??
@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
Re: Squares
@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...
@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...
Re: Squares
Just for fun, a (non-square) color wheel
Or with a function:
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
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
Re: Squares
@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???
@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
Re: Squares
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.
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.
Re: Squares
@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 )
@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
DATA COMPRESSION
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..
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
DATA COMPRESSION
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..
After multiple loops , it seems to make a big difference....
Heres 3 loops
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
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
Re: Squares
@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...
@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