## Squares

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

### Re: Event Horizon

Jupiterish.

Code: Select all

`type ball   x as single    'position x component   y as single    'position y component   dx as single   'velocity x component   dy as single   'velocity y component   col as uLong   'colour    as Long r,m    'radius, massend typedim shared as any ptr rowdim shared as integer pitchdim shared as integer xres,yres #define incircle(cx,cy,r,mx,my,a) _ iif(a<=1,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r))#define shade(c,n)  rgb(Cptr(Ubyte Ptr,@c)[2]*n,Cptr(Ubyte Ptr,@c)[1]*n,Cptr(Ubyte Ptr,@c)[0]*n)Function o(c As Ulong) As Ulong 'mono makerVar v=.299*((c Shr 16)And 255)+.587*((c Shr 8)And 255)+.114*(c And 255)Return Rgb(v,v,v)End Functionfunction dist(b1 as ball,b2 as ball) as single    return sqr((b1.x-b2.x)^2 + (b1.y-b2.y)^2)end functionfunction rainbow( x as single ) as ulong 'idea from bluatigro    static as double pi=4*atn(1)    #define rad(n) (pi/180)*(n)  dim as ulong r , g , b  r = sin( rad( x ) ) * 127 + 128  g = sin( rad( x - 120 ) ) * 127 + 128  b = sin( rad( x + 120 ) ) * 127 + 128  return rgb( r and 255 , g and 255 , b and 255 )end function sub _circle(b as ball) 'custom     #define onscreen x>=0 and x<xres and y>.0 and y<yres      #define putpixel(_x,_y,colour)    *cptr(ulong ptr,row+ (_y)*pitch+ (_x) shl 2)  =(colour)     dim as ulong tc     for x as long=b.x-b.r to b.x+b.r         for y as long=b.y-b.r to b.y+b.r             if incircle(b.x,b.y,b.r,x,y,1) andalso onscreen then                 if incircle(512,768\2,400,x,y,.75)  then tc=b.col else tc=o(b.col)             putpixel(x,y,tc)             end if         next         next    end sub     sub MoveAndDraw( b() as ball,byref e as Long)'get energy also    for n as Long=lbound(b) to ubound(b)   b(n).x+=b(n).dx:b(n).y+=b(n).dy    _circle(b(n))    e+=.5*b(n).m*(b(n).dx*b(n).dx + b(n).dy*b(n).dy)    next nend sub sub edges(b() as ball,xres as Long,yres as Long,byref status as Long ) 'get status also    for n as Long=lbound(b) to ubound(b)    if(b(n).x<b(n).r) then b(n).x=b(n).r: b(n).dx=-b(n).dx    if(b(n).x>xres-b(n).r )then b(n).x=xres-b(n).r: b(n).dx=-b(n).dx    if(b(n).y<b(n).r)then b(n).y=b(n).r:b(n).dy=-b(n).dy    if(b(n).y>yres-b(n).r)then  b(n).y=yres-b(n).r:b(n).dy=-b(n).dy    if b(n).x<0 or b(n).x>xres then status=0    if b(n).y<0 or b(n).y>yres then status=0    next nend subFunction DetectBallCollisions( B1 As ball,B2 As ball) As single 'avoid using sqr if they are well seperated    Dim As Long xdiff = B2.x-B1.x    Dim As Long ydiff = B2.y-B1.y    If Abs(xdiff) > (B2.r+B1.r) Then Return 0    If Abs(ydiff) > (B2.r+B1.r) Then Return 0    var L=Sqr(xdiff*xdiff+ydiff*ydiff)    If L<=(B2.r+B1.r) Then Function=L else Function=0End Function sub BallCollisions(b() as ball)    for n1 as Long=lbound(b) to ubound(b)-1        for n2 as Long=n1+1 to ubound(b)            dim as single  L= DetectBallCollisions(b(n1),b(n2))            if L then       dim as single  impulsex=(b(n1).x-b(n2).x)/L       dim as single  impulsey=(b(n1).y-b(n2).y)/L       'set one ball to nearest non overlap position       b(n1).x=b(n2).x+(b(n2).r+b(n1).r)*impulsex       b(n1).y=b(n2).y+(b(n2).r+b(n1).r)*impulsey              dim as single  impactx=b(n1).dx-b(n2).dx       dim as single  impacty=b(n1).dy-b(n2).dy       dim as single  dot=impactx*impulsex+impacty*impulsey       dim as single  mn2=b(n1).m/(b(n1).m+b(n2).m),mn1=b(n2).m/(b(n1).m+b(n2).m)            b(n1).dx-=dot*impulsex*2*mn1        b(n1).dy-=dot*impulsey*2*mn1        b(n2).dx+=dot*impulsex*2*mn2        b(n2).dy+=dot*impulsey*2*mn2        end ifnext n2next n1end sub'steady framerateFunction Regulate(Byval MyFps As Long,Byref fps As Long) As Long    Static As double timervalue,lastsleeptime,t3,frames    frames+=1    If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0    Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000    If sleeptime<1 Then sleeptime=1    lastsleeptime=sleeptime    timervalue=Timer    Return sleeptimeEnd Functionsub Start()    dim  as ball b(0 to 10)    dim as Long fps,energy,status=1    screen 20,32    row=screenptr    screeninfo xres,yres,,,pitch    dim as any ptr i=imagecreate(xres,yres)    dim as ball p(15)    for n as long=0 to ubound(p)        p(n)=type(rnd*xres,rnd*yres)    next    for y as long=0 to yres        for x as long=0 to xres             if incircle(512,768\2,400,x,y,.75) then               pset i,(x,y),rainbow(x-y)           else               var clr=o(rainbow(x-y))             pset i,(x,y),shade(clr,.75)             end if        next    next    randomize 3    for n as Long=lbound(b) to ubound(b)        with b(n)            .x=xres/2            .y=yres/2            .dx=rnd*3-rnd*3            .dy=rnd*3-rnd*3            select case n            case 0:.col=rgb(0,55,55)            case 1:.col=rgb(200,0,0)            case 2:.col=rgb(0,200,0)            case 3:.col=rgb(0,0,200)            case 4:.col=rgb(255,215,0)            case 5:.col=rgb(0,200,200)            case 6:.col=rgb(0,50,255)            case 7:.col=rgb(255,100,0)            case 8:.col=rgb(255,0,255)            case else:.col=rgb(rnd*255,rnd*255,rnd*255)                end select            .r=20+rnd*40            .m=.r^2            end with        next   while 1        energy=0      edges(b(),xres,yres,status)      BallCollisions(b())      screenlock        cls        put(0,0),i,pset               MoveAndDraw(b(),energy)      draw string(50, 10), " Press escape key to end",0      draw string(50, 55), "framerate " &fps ,0      draw string (50,100),"System energy " &energy,0        draw string (50,145),"System stauus " & iif(1,"OK","Leaks"),0      screenunlock         sleep regulate(65, fps)      if inkey=chr(27) then exit while   wend    imagedestroy iend subStartsleep  `
Richard
Posts: 3047
Joined: Jan 15, 2007 20:44
Location: Australia

### Re: Squares

Better energy conservation.

Code: Select all

`Function DetectBallCollisions( B1 As ball, B2 As ball) As Single    Dim As Single xdiff2 = B2.x - B1.x : xdiff2 *= xdiff2    Dim As Single ydiff2 = B2.y - B1.y : ydiff2 *= ydiff2    Dim As Single sumR2  = B2.r + B1.r : sumR2  *= sumR2    If xdiff2 > sumR2 Then Return 0  ' fast exits    If ydiff2 > sumR2 Then Return 0  '  avoids call abs()    Dim As Single sos = xdiff2 + ydiff2 ' sum of squares    If sos <= sumR2 Then Return Sqr( sos ) Else Return 0End Function            ' uses sqr() only if colliding`
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat

Got compression....Compresses 80+% after 40 loops... I'm working on the decompression...

It steps by 3 bits.

if len = 1 , then it sets both strings to s
if len = 2 , then it sets both strings to s
if len = 3 , then it sets outs1 to "1" and outs2 to mid(s,2)

So , the two strings don't equal each other if len = 3 , otherwise they equal each other.

Should be pretty easy , to write the de-compressor...

Code: Select all

`Declare Function   compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringNamespace 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 LongEnd ExternFunction 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 textEnd 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 uncompressedEnd 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 compressedEnd FunctionEnd Namespace'=================================================================='=================================================================='test zipper'=================================================================='==================================================================screen 19Dim Shared As String sRandomizes=""dim as string check=""dim as string compare=""dim as longint length = 0dim as double compression = 0dim as longint loops = 0do       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." ; " loops = " ; loops ; " out of 40."    print    print "press esc to exit."    'sleep       if inkey = chr(27) then exit do   loop until loops = 40print "Press a key to decompress." sleeps = 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 val1dim as string outsfor a as longint = count to 2 step -1    s = Zlibrary.unpack(comp)    outs = decompress_loop(s)    comp = outsnextcomp = Zlibrary.unpack(comp)printprint "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"printif comp = compare then print "Decompression successful." else print "ERROR"printPrint "!!~~Done~~!!"Sleepend'==============================================================================='==============================================================================='begin functions'==============================================================================='================='==============================================================Function compress_loop( chrs as string ) as string        dim as string bits=""    dim as string zeros = string(8,"0")    dim as ulongint n1    for a as longint = 0 to len(chrs)-1 step 1        n1 = chrs[a]        bits+=right(zeros+bin(n1),8)    next        print "c inp = " ; len(bits)        dim as string outs1=""    dim as string outs2=""    dim as string s    for a as longint = 1 to len(bits) step 3                s = mid(bits,a,3)        s = ltrim(s,"0") : if s = "" then s = "0"                if len(s) = 1 then outs1+= s : outs2+= s        if len(s) = 2 then outs1+= s : outs2+= s        if len(s) = 3 then outs1+= "1" : outs2+= mid(s,2)                'print s        'print outs1        'print outs2        'sleep        'if inkey=" " then end            next        print    print "c out 1 = " ; len(outs1)    print "c out 2 = " ; len(outs2)        dim as string final_out = ""    for a as longint = 1 to len(outs1) step 8        final_out+=chr(valulng("&B"+mid(outs1,a,8)))    next    final_out+="END"    for a as longint = 1 to len(outs2) step 8        final_out+=chr(valulng("&B"+mid(outs2,a,8)))    next        print "c fin =  "; len(final_out) ' , final        return final_out    end function'==============================================================================='============================================================================Function decompress_loop( chrs as string ) as string    return chrsend function`
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat

I modified it so that both output strings , are the same length... It should make it easier to decompress..

Compresses 10,000 78+% after 50 loops...
Compresses 100,000 94+% after 50 loops...
Compresses 1,000,000 98+% after 50 loops...

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= s : outs2+= s
if len(s) = 2 then outs1+= left(s,1) : outs2+= right(s,1)
if len(s) = 3 then outs1+= left(s,2) : outs2+= "0" + right(s,1)

Code: Select all

`Declare Function   compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringNamespace 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 LongEnd ExternFunction 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 textEnd 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 uncompressedEnd 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 compressedEnd FunctionEnd Namespace'=================================================================='=================================================================='test zipper'=================================================================='==================================================================screen 19Dim Shared As String sRandomizes=""dim as string check=""dim as string compare=""dim as longint length = 0dim as double compression = 0dim as longint loops = 0do       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." ; " loops = " ; loops ; " out of 50."    print    print "press esc to exit."    'sleep       if inkey = chr(27) then exit do   loop until loops = 50print "Press a key to decompress." sleeps = 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 val1dim as string outsfor a as longint = count to 2 step -1    s = Zlibrary.unpack(comp)    outs = decompress_loop(s)    comp = outsnextcomp = Zlibrary.unpack(comp)printprint "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"printif comp = compare then print "Decompression successful." else print "ERROR"printPrint "!!~~Done~~!!"Sleepend'==============================================================================='==============================================================================='begin functions'==============================================================================='================='==============================================================Function compress_loop( chrs as string ) as string        dim as string bits=""    dim as string zeros = string(8,"0")    dim as ulongint n1    for a as longint = 0 to len(chrs)-1 step 1        n1 = chrs[a]        bits+=right(zeros+bin(n1),8)    next        print "c inp = " ; len(bits)        dim as string outs1=""    dim as string outs2=""    dim as string s    for a as longint = 1 to len(bits) step 3                s = mid(bits,a,3)        s = ltrim(s,"0") : if s = "" then s = "0"                if len(s) = 1 then outs1+= s    : outs2+= s        if len(s) = 2 then outs1+= left(s,1) : outs2+= right(s,1)        if len(s) = 3 then outs1+= left(s,2) : outs2+= "0" + right(s,1)                'print s        'print outs1        'print outs2        'sleep        'if inkey=" " then end            next        print    print "c out 1 = " ; len(outs1)    print "c out 2 = " ; len(outs2)        dim as string final_out = ""    for a as longint = 1 to len(outs1) step 8        final_out+=chr(valulng("&B"+mid(outs1,a,8)))    next    final_out+="END"    for a as longint = 1 to len(outs2) step 8        final_out+=chr(valulng("&B"+mid(outs2,a,8)))    next        print "c fin =  "; len(final_out) ' , final        return final_out    end function'==============================================================================='============================================================================Function decompress_loop( chrs as string ) as string    return chrsend function`
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat

While writing the de-compressor i ran into a snafu , you can't tell one from the other...So i modified it again..

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= s : outs2+= "0"
if len(s) = 2 then outs1+= right(s,1) : outs2+= "1"
if len(s) = 3 then outs1+= right(s,2) : outs2+= "00"

Now you can search for the "1"'s , and then you have to figure the "0" verses the "00".

Compresses 90+% after 40 loops..

Code: Select all

`Declare Function   compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringNamespace 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 LongEnd ExternFunction 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 textEnd 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 uncompressedEnd 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 compressedEnd FunctionEnd Namespace'=================================================================='=================================================================='test zipper'=================================================================='==================================================================screen 19Dim Shared As String sRandomizes=""dim as string check=""dim as string compare=""dim as longint length = 0dim as double compression = 0dim as longint loops = 0do       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." ; " loops = " ; loops ; " out of 40."    print    print "press esc to exit."    'sleep       if inkey = chr(27) then exit do   loop until loops = 40print "Press a key to decompress." sleeps = 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 val1dim as string outsfor a as longint = count to 2 step -1    s = Zlibrary.unpack(comp)    outs = decompress_loop(s)    comp = outsnextcomp = Zlibrary.unpack(comp)printprint "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"printif comp = compare then print "Decompression successful." else print "ERROR"printPrint "!!~~Done~~!!"Sleepend'==============================================================================='==============================================================================='begin functions'==============================================================================='================='==============================================================Function compress_loop( chrs as string ) as string        dim as string bits=""    dim as string zeros = string(8,"0")    dim as ulongint n1    for a as longint = 0 to len(chrs)-1 step 1        n1 = chrs[a]        bits+=right(zeros+bin(n1),8)    next        print "c inp = " ; len(bits)        dim as string outs1=""    dim as string outs2=""    dim as string s    for a as longint = 1 to len(bits) step 3                s = mid(bits,a,3)        s = ltrim(s,"0") : if s = "" then s = "0"                if len(s) = 1 then outs1+= s : outs2+= "0"        if len(s) = 2 then outs1+= right(s,1) : outs2+= "1"        if len(s) = 3 then outs1+= right(s,2) : outs2+= "00"                'print        'print mid(bits,a,3)        'print outs1        'print outs2        'sleep        'if inkey=" " then end            next        print    print "c out 1 = " ; len(outs1)    print "c out 2 = " ; len(outs2)        dim as string final_out = ""    for a as longint = 1 to len(outs1) step 8        final_out+=chr(valulng("&B"+mid(outs1,a,8)))    next    final_out+="END"    for a as longint = 1 to len(outs2) step 8        final_out+=chr(valulng("&B"+mid(outs2,a,8)))    next        print "c fin =  "; len(final_out) ' , final        return final_out    end function'==============================================================================='============================================================================Function decompress_loop( chrs as string ) as string    return chrsend function`
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat

I came up with an idea for corporate board members...
Companies have between 7 and 31 board members..

So you split the screen into 4 , 8, 16 ,32 video squares.

Kinda like Skype...But each member has their own square on the screen..
Then they can have board meetings without gathering together around a table..

The chairman of the board would have the biggest square , in the center of the screen..
Then the board members would each have a given square around the chairman square, with their name on the bottom of their square.
Each members square , would be assigned to a given DNS : IP

If they're not online then the square would be dark...
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Dodicat

I modified the compressor again...Ran into another snafu , can't tell one form the next...

s = mid(bits,a,3)
s = ltrim(s,"0") : if s = "" then s = "0"

if len(s) = 1 then outs1+= "0" + s
if len(s) = 2 then outs1+= "0" + s
if len(s) = 3 then outs1+= s

I tried to make all outputs 3 bits.... But if len(s) = 1 then outs1+= "00" + s , doesn't compress..So i had to make it "0" + s

So if you run into a "00" or a "01" then you have to put a "0" in front of it....

Code: Select all

`Declare Function   compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringNamespace 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 LongEnd ExternFunction 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 textEnd 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 uncompressedEnd 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 compressedEnd FunctionEnd Namespace'=================================================================='=================================================================='test zipper'=================================================================='==================================================================screen 19Dim Shared As String sRandomizes=""dim as string check=""dim as string compare=""dim as longint length = 0dim as double compression = 0dim as longint loops = 0do       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." ; " loops = " ; loops ; " out of 40."    print    print "press esc to exit."    'sleep       if inkey = chr(27) then exit do   loop until loops = 40print "Press a key to decompress." sleeps = 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 val1dim as string outsfor a as longint = count to 2 step -1    s = Zlibrary.unpack(comp)    outs = decompress_loop(s)    comp = outsnextcomp = Zlibrary.unpack(comp)printprint "input = "; length , "output = " ; len(comp) , "compression ratio  "; 100 - ( 100 / ( length / len(s) ) ) ; "%"printif comp = compare then print "Decompression successful." else print "ERROR"printPrint "!!~~Done~~!!"Sleepend'==============================================================================='==============================================================================='begin functions'==============================================================================='================='==============================================================Function compress_loop( chrs as string ) as string        dim as string bits=""    dim as string zeros = string(8,"0")    dim as ulongint n1    for a as longint = 0 to len(chrs)-1 step 1        n1 = chrs[a]        bits+=right(zeros+bin(n1),8)    next        print "c inp = " ; len(bits) ', bits        dim as string outs1=""    dim as string s    for a as longint = 1 to len(bits) step 3                s = mid(bits,a,3)        s = ltrim(s,"0") : if s = "" then s = "0"                if len(s) = 1 then outs1+=  "0" + s        if len(s) = 2 then outs1+=  "0" + s        if len(s) = 3 then outs1+=  s        'print s        'print outs1        'print outs2        'sleep        'if inkey=" " then end            next        print "c out = " ; len(outs1) ', outs1        dim as longint count=0    dim as string str1    dim as longint dec1    do        str1=str(len(outs1)/8)        dec1=instr(1,str1,".")        if dec1<>0 then outs1+="0" : count+=1    loop until dec1=0        dim as string final_out = ""    for a as longint = 1 to len(outs1) step 8        final_out+=chr(valulng("&B"+mid(outs1,a,8)))    next        final_out = chr(count) + final_out        print "c fin = "; len(final_out) ' , final        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 bits=""    dim as string zeros = string(8,"0")    dim as ulongint n1    for a as longint = 0 to len(chrs)-1 step 1        n1 = chrs[a]        bits+=right(zeros+bin(n1),8)    next        bits = left(bits,len(bits)-count)        'print "d inp = " ; len(bits) , bits            return chrsend function`
Richard
Posts: 3047
Joined: Jan 15, 2007 20:44
Location: Australia

### Re: Squares

Albert wrote:I came up with an idea for corporate board members...
Companies have between 7 and 31 board members..

I believe "The Peter Principle", 1969, demonstrated that having more than 7 members on a board or committee makes it unmanageable and unproductive.
https://en.wikipedia.org/wiki/Peter_principle
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Richard

I just googled "How many board members in a company".. It replied 7 to 31..
dodicat
Posts: 6767
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: Squares

The Peter Principle only mentions promotion.
It has completely missed the concept of demotion, and the fact that promotion in the demotion direction acts faster than the other way round, so there is no need to be incompetent for long.
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

@Richard
@Dodicat

dim as single s1
for a as longint = 0 to len( chrs )-1 step 1
s1 = chrs[a] / 2
if frac(s1) = 0 then if s1 mod 2 = 0 then chrs[a] / = 2
next

How would you reverse it???
Richard
Posts: 3047
Joined: Jan 15, 2007 20:44
Location: Australia

### Re: Squares

Albert wrote:How would you reverse it???

You have lost information so you cannot always reverse it.
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

I got compression without Zlib...

The problem is ; how to differentiate 3 bits values , from 4 bit values.

Code: Select all

`Declare Function      compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringscreen 19dim as double time1 , time2 , time3 , time4do       randomize       dim as string s=""    For n As Long = 1 To 8        s+=chr(Int(Rnd*256))'+8)    Next       time1=timer    'begin compress        dim as string comp = s        'do        '    dim as longint chk = len(comp) - 1        '    comp = compress_loop(comp)        '    if len(comp) >= chk then exit do        'loop               for a as longint = 1 to 1 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 1 step 1            final_out = decompress_loop(final_out)        next    'end decompress    time4 = timer      'sleep       'cls    'draw string( 0,10) , left(s,100)    'draw string( 0,30) , left(final_out,100)    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."    print string(99,"=")       sleep   loop until inkey = chr(27)sleepend'==============================================================================='==============================================================================='begin functions'==============================================================================='===============================================================================Function compress_loop( chrs as string ) as string       dim as string bits = ""    dim as string zeros = string(64,"0")    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))    dim as string n1    for a as longint = 1 to len(chrs) step 8        n1 = zeros + bin(*ulp) : ulp+=1        bits+=right(n1,64)    next        print "c inp = "; len(bits) , bits    dim as string outs1=""    dim as string s1    for a as longint = 1 to len(bits) step 4                s1 = mid(bits,a,4)                if s1 = "0000" then outs1+="001"        if s1 = "0001" then outs1+="010"        if s1 = "0010" then outs1+="011"        if s1 = "0011" then outs1+="100"        if s1 = "0100" then outs1+="101"        if s1 = "0101" then outs1+="110"        if s1 = "0110" then outs1+="111"                if s1 = "0111" then outs1+="0000"        if s1 = "1000" then outs1+="0001"        if s1 = "1001" then outs1+="0010"        if s1 = "1010" then outs1+="0011"        if s1 = "1011" then outs1+="0100"        if s1 = "1100" then outs1+="0101"        if s1 = "1101" then outs1+="0110"        if s1 = "1110" then outs1+="0111"                if s1 = "1111" then outs1+="1000"            next        print "c out = "; len(outs1) , outs1        dim as longint count=0    dim as string str1    dim as longint dec1    do        str1=str(len(outs1)/8)        dec1=instr(1,str1,".")        if dec1<>0 then outs1+="0" : count+=1    loop until dec1=0        dim as string final = ""    for a as longint = 1 to len(outs1) step 8        final+=chr(val("&B"+mid(outs1,a,8)))    next        final = chr(count) + final        print "c fin = "; len(final) ' , final       return final   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 bits = ""    dim as string zeros = string(8,"0")    dim as string n1    for a as longint = 1 to len(chrs) step 1        n1 = zeros + bin( chrs[a-1] )        bits+=right(n1,8)    next        bits = left(bits,len(bits)-count)        print "d inp = "; len(bits) , bits       return chrsend function`

Its worth working it out... figuring a way to tell 3 bit vals from 4 bit vals...
Here it is doing 1,000,000 bytes... it compresses down to 2 digits...

Code: Select all

`Declare Function      compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringscreen 19dim as double time1 , time2 , time3 , time4do       randomize       dim as string s=""    For n As Long = 1 To 1000000        s+=chr(Int(Rnd*256))'+8)    Next       time1=timer    'begin compress        dim as string comp = s        do            dim as longint chk = len(comp) - 1            comp = compress_loop(comp)            if len(comp) >= chk then exit do        loop        'for a as longint = 1 to 1 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 1 step 1            final_out = decompress_loop(final_out)        next    'end decompress    time4 = timer      'sleep       'cls    'draw string( 0,10) , left(s,100)    'draw string( 0,30) , left(final_out,100)    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."    print string(99,"=")       sleep   loop until inkey = chr(27)sleepend'==============================================================================='==============================================================================='begin functions'==============================================================================='===============================================================================Function compress_loop( chrs as string ) as string       dim as string bits = ""    dim as string zeros = string(64,"0")    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))    dim as string n1    for a as longint = 1 to len(chrs) step 8        n1 = zeros + bin(*ulp) : ulp+=1        bits+=right(n1,64)    next        'print "c inp = "; len(bits) , bits    dim as string outs1=""    dim as string s1    for a as longint = 1 to len(bits) step 4                s1 = mid(bits,a,4)                if s1 = "0000" then outs1+="001"        if s1 = "0001" then outs1+="010"        if s1 = "0010" then outs1+="011"        if s1 = "0011" then outs1+="100"        if s1 = "0100" then outs1+="101"        if s1 = "0101" then outs1+="110"        if s1 = "0110" then outs1+="111"                if s1 = "0111" then outs1+="0000"        if s1 = "1000" then outs1+="0001"        if s1 = "1001" then outs1+="0010"        if s1 = "1010" then outs1+="0011"        if s1 = "1011" then outs1+="0100"        if s1 = "1100" then outs1+="0101"        if s1 = "1101" then outs1+="0110"        if s1 = "1110" then outs1+="0111"                if s1 = "1111" then outs1+="1000"            next        'print "c out = "; len(outs1) , outs1        dim as longint count=0    dim as string str1    dim as longint dec1    do        str1=str(len(outs1)/8)        dec1=instr(1,str1,".")        if dec1<>0 then outs1+="0" : count+=1    loop until dec1=0        dim as string final = ""    for a as longint = 1 to len(outs1) step 8        final+=chr(val("&B"+mid(outs1,a,8)))    next        final = chr(count) + final        print "c fin = "; len(final) ' , final       return final   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 bits = ""    dim as string zeros = string(8,"0")    dim as string n1    for a as longint = 1 to len(chrs) step 1        n1 = zeros + bin( chrs[a-1] )        bits+=right(n1,8)    next        bits = left(bits,len(bits)-count)        'print "d inp = "; len(bits) , bits       return chrsend function`
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

Time Rhyme!!

5:03 hive yo bee
albert
Posts: 5927
Joined: Sep 28, 2006 2:41
Location: California, USA

### Re: Squares

I altered the compressor above....
Now it should be easier to identify the 3 bit vals form the 4 bit vals..

Compresses 1,000,000 bytes , down to ; between 120 bytes and 90 bytes..

s1 = mid(bits,a,4)

if s1 = "0000" then outs1+="100"
if s1 = "0001" then outs1+="101"
if s1 = "0010" then outs1+="110"
if s1 = "0011" then outs1+="111"
if s1 = "0100" then outs1+="1000"
if s1 = "0101" then outs1+="1001"
if s1 = "0110" then outs1+="1010"

if s1 = "0111" then outs1+="0000"
if s1 = "1000" then outs1+="0001"
if s1 = "1001" then outs1+="0010"
if s1 = "1010" then outs1+="0011"
if s1 = "1011" then outs1+="0100"
if s1 = "1100" then outs1+="0101"
if s1 = "1101" then outs1+="0110"
if s1 = "1110" then outs1+="0111"

if s1 = "1111" then outs1+="1100"

Code: Select all

`Declare Function      compress_loop( chrs as string ) as stringDeclare Function decompress_loop( chrs as string ) as stringscreen 19dim as double time1 , time2 , time3 , time4do       randomize       dim as string s=""    For n As Long = 1 To 8        s+=chr(Int(Rnd*256))'+8)    Next       time1=timer    'begin compress        dim as string comp = s        'do        '    dim as longint chk = len(comp) - 1        '    comp = compress_loop(comp)        '    if len(comp) >= chk then exit do        'loop        for a as longint = 1 to 1 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 1 step 1            final_out = decompress_loop(final_out)        next    'end decompress    time4 = timer      'sleep       'cls    'draw string( 0,10) , left(s,100)    'draw string( 0,30) , left(final_out,100)    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."    print string(99,"=")       sleep   loop until inkey = chr(27)sleepend'==============================================================================='==============================================================================='begin functions'==============================================================================='===============================================================================Function compress_loop( chrs as string ) as string       dim as string bits = ""    dim as string zeros = string(64,"0")    dim as ulongint ptr ulp = cptr(ulongint ptr,strptr(chrs))    dim as string n1    for a as longint = 1 to len(chrs) step 8        n1 = zeros + bin(*ulp) : ulp+=1        bits+=right(n1,64)    next        print "c inp = "; len(bits) , bits    dim as string outs1=""    dim as string s1    for a as longint = 1 to len(bits) step 4                s1 = mid(bits,a,4)                if s1 = "0000" then outs1+="100"        if s1 = "0001" then outs1+="101"        if s1 = "0010" then outs1+="110"        if s1 = "0011" then outs1+="111"        if s1 = "0100" then outs1+="1000"        if s1 = "0101" then outs1+="1001"        if s1 = "0110" then outs1+="1010"                if s1 = "0111" then outs1+="0000"        if s1 = "1000" then outs1+="0001"        if s1 = "1001" then outs1+="0010"        if s1 = "1010" then outs1+="0011"        if s1 = "1011" then outs1+="0100"        if s1 = "1100" then outs1+="0101"        if s1 = "1101" then outs1+="0110"        if s1 = "1110" then outs1+="0111"                if s1 = "1111" then outs1+="1100"            next        print "c out = "; len(outs1) , outs1        dim as longint count=0    dim as string str1    dim as longint dec1    do        str1=str(len(outs1)/8)        dec1=instr(1,str1,".")        if dec1<>0 then outs1+="0" : count+=1    loop until dec1=0        dim as string final = ""    for a as longint = 1 to len(outs1) step 8        final+=chr(val("&B"+mid(outs1,a,8)))    next        final = chr(count) + final        print "c fin = "; len(final) ' , final       return final   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 bits = ""    dim as string zeros = string(8,"0")    dim as string n1    for a as longint = 1 to len(chrs) step 1        n1 = zeros + bin( chrs[a-1] )        bits+=right(n1,8)    next        bits = left(bits,len(bits)-count)        print "d inp = "; len(bits) , bits       return chrsend function`