Squares

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

Re: Squares

Post by albert »

@Richard
@Dodicat

How do you tell , how much compression you have??

if you got a file len = 10,000 and , you can compress it to 15 bits , how many bytes does that shave off??

Is it ( file_len * 8 ) / (16/15) / 8 bytes ? how do you calculate the bytes compressed..
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re:

Post by dodicat »

Richard wrote:@ dodicat. I really like your TV. Through your skill and the convergence of technology we now have those channels here too. Are more channels planned?
Yea Richard.
All you see at night now is Roulette, or pᴑker.
Times have changed, I have added another channel reluctantly.

Code: Select all


'MY TV
#include "fbgfx.bi"
Dim Shared As Integer xres,yres
Screen 19,32
Screeninfo xres,yres
Type box
    As Single x,y,z
    as string caption
    as uinteger textcol,boxcol
End Type
type point5d
    as double x,y,z,speed,dil
end type
#macro incircle(cx,cy,radius,x,y)
        (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro
dim info as point5d
info.x=530
info.y=240
info.z=0
info.speed=1
info.dil=.5
#define rect 4
declare Sub thickline_(x1 As Double,_
                     y1 As Double,_
                     x2 As Double,_
                     y2 As Double,_
                     thickness As Double,_
                     colour As Uinteger,_
                     im As Any Pointer=0)
                     declare sub dots
                     declare sub bird
declare Sub starfield(pixels As Integer=1000,maxlength As Integer=10,offx As Double=0,offy As Double=0)
declare sub drawstring(x as long,y as long,s as string,e as single=1,col as ulong,alph as ubyte=255)
declare Sub DIECAST(values as point5d)
declare Function inbox(p1() As box,p2 As box) As Integer
declare Function Regulate(Byval MyFps As long,Byref fps As long=0) As long
declare sub On_Click(box() as box,mp as box)
declare sub highlightbox(box() as box,mp as box,col as uinteger)
declare sub drawbox(x as integer,y as integer,box()as box,boxlength as integer,boxheight as integer,boxcolour as uinteger,outline as uinteger,highlight as uinteger,caption as string)
declare Sub draw_box(p() As box,col As Uinteger,pnt As String="paint",im As Any Pointer=0)
dim shared as box label(rect,1)
dim shared as box button(rect,1)
dim shared as integer flag
Dim shared As fb.event e
dim shared as integer counter
dim  shared as integer startreck,_dots,_bird,gold
dim as uinteger background=rgb(100,100,100)
Do
    counter=0
    screenlock
    Cls
paint(0,0),background
drawbox(400,100,label(),250,250,rgb(0,00,0),rgb(120,20,20),rgb(120,20,20),"")
if startreck then starfield(500,20,-.7,-.5)
if _dots then dots
if _bird then bird
if gold then diecast(info)

    drawstring 300,50,"Dodicat's television set",2,rgb(0,0,100)

    drawbox(100,100,button(),110,50,rgb(200,200,0),rgb(255,255,255),rgb(00,0,200),"Stand By")
    drawbox(100,200,button(),110,50,rgb(200,0,190),rgb(255,255,255),rgb(00,0,200),"Star Treck")
    drawbox(100,300,button(),110,50,rgb(0,200,190),rgb(255,255,255),rgb(00,0,200),"BBC Wildlife")
    drawbox(100,400,button(),110,50,rgb(0,200,190),rgb(255,255,255),rgb(00,0,200),"Gamble Gold")
    
    drawbox(350,350,label(),350,100,rgb(150,100,00),rgb(250,155,5),rgb(250,155,5),"           Bush TV Company Ltd.")
    circle(520,410),30,rgb(0,100,200),,,,f
    circle(520,410),30,rgb(200,0,0)
    drawstring 500,395,"Off",2,rgb(0,0,0)
    
    if (screenevent(@e)) then 
        if e.type=13 then end
        end if
    screenunlock
    
    Sleep regulate(100),1
Loop Until Inkey=Chr(27)

Sub mv(m1() As Double,m2() As Double,ans() As Double) 
   Dim s As Double
    For i As long=1 To 3
        s=0
        For k As long = 1 To 3
            s=s+m1(i,k)*m2(k)
        Next k
        ans(i)=s
        Next i
    End Sub
Dim Shared np(1 To 6) As Double 'For a position rotation, no lines or circles
'np(1),np(2),np(3)-------np(4),np(5),np(6)  for line ends
'np(4),np(5)                    for circle centres 
' use linepointset,circlepointset to draw the pixels
        Sub rotate(Byval pivot_x As Double,_  'x pivot for rotation
                   Byval pivot_y As Double,_  'y pivot for rotation 
                   Byval pivot_z As Double,_  'z pivot for rotation
                   Byval first_x As Double,_  'x for line,or centre for circle
                   Byval first_y As Double,_  'y for line,or centre for circle
                   Byval first_z As Double,_  'z for line or circle
                   Byval second_x As Double, _'x for line,or radius for circle 
                   Byval second_y As Double, _'y for line,or aspect for circle
                   Byval second_z As Double,_ 'z for line, first arc position circle 
                   Byval second_arc As Double,_ 'second arc position circle,0 line
                   Byval angleX As Double, _   'angle to rotate round x axis
                   Byval angleY As Double,_    'angle to rotate round y axis
                   Byval angleZ As Double,_    'angle to rotate round z axis
                   Byval magnifier As Double,_ '1=no magnifacation
                   Byval dilator As Double,_   'times distance from pivot(1=no dilation)
                   Byval colour As long,_   'color for line or circle
                   Byval thickness As Double,_ 'thickness line or circle
                   Byref shape As String,_ 'line/circle/circlefill/box/boxfill/linepoint[set],circlepoint[set]"
                   Byref mode As String,_    '2d or 3d
                   Byval perspective As Double=0,_ 'add some 3d perspective 0 to 1 approx
                   image As Any Pointer=0)        'write to an image if required
  shape=Lcase$(shape)
  mode=Lcase$(mode)
  Dim th As Double
  th=thickness
  Dim As Double zval,pp   'used in get_perspective
  Dim sx As Double=second_x
Dim p As Double = 4*Atn(1)  '(pi)
Dim angleX_degrees As Double
Dim angleY_degrees As Double
Dim angleZ_degrees As Double

#Macro thickline(t)
Dim As Double s,h,c
Dim As Ulong prime=rgb(255,255,255)
h=Sqr(((np(1))-(np(4)))^2+((np(2))-(np(5)))^2)
s=((np(5))-np(2))/h
c=(np(1)-(np(4)))/h
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),prime
Line image, (np(4)-s*t/2,np(5)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(4)-s*t/2,np(5)-c*t/2),prime
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),prime
Paint image,((np(4)+np(1))/2, (np(5)+np(2))/2),prime,prime

Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(1)+s*t/2,np(2)+c*t/2),colour
Line image, (np(4)-s*t/2,np(5)-c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Line image, (np(4)+s*t/2,np(5)+c*t/2)-(np(4)-s*t/2,np(5)-c*t/2),colour
Line image, (np(1)+s*t/2,np(2)+c*t/2)-(np(1)-s*t/2,np(2)-c*t/2),colour
Paint image,((np(4)+np(1))/2, (np(5)+np(2))/2), colour, colour
#EndMacro

#macro thickcircle(t)
Dim As Ulong prime=rgb(255,255,255)
Dim As Double xp1,xp2,yp1,yp2
Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
arc1=2*p+(arc1-(anglez_degrees))
arc2=2*p+(arc2-(anglez_degrees))
sx=sx*magnifier
If arc1=arc2 Then
     Circle image,(np(4),np(5)),sx,prime,,,second_y
    Circle image,(np(4),np(5)),sx-t,prime,,,second_y
    Paint image,(np(4),np(5)+sx-t/2),prime,prime
    Paint image,(np(4)+sx-t/2,np(5)),prime,prime
    Circle image,(np(4),np(5)),sx,colour,,,second_y
    Circle image,(np(4),np(5)),sx-t,colour,,,second_y
    Paint image,(np(4),np(5)+sx-t/2),colour,colour
    Paint image,(np(4)+sx-t/2,np(5)),colour,colour
End If
if arc1<>arc2 Then
    xp1=np(4)+(sx-t/2)*Cos(.5*(arc2+arc1))
yp1=np(5)-(sx-t/2)*Sin(.5*(arc2+arc1))
Circle image,(np(4),np(5)),sx,prime,arc1,arc2,second_y
    Circle image,(np(4),np(5)),sx-t,prime,arc1,arc2,second_y
    Line image,(np(4)+sx*Cos(arc1),np(5)-sx*Sin(arc1))-(np(4)+(sx-t)*Cos(arc1),np(5)-(sx-t)*Sin(arc1)),prime
    Line image,(np(4)+sx*Cos(arc2),np(5)-sx*Sin(arc2))-(np(4)+(sx-t)*Cos(arc2),np(5)-(sx-t)*Sin(arc2)),prime
    'pset(xp1,yp1),rgb(255,255,255)
    Paint image,(xp1,yp1),prime,prime

   Circle image,(np(4),np(5)),sx,colour,arc1,arc2,second_y
    Circle image,(np(4),np(5)),sx-t,colour,arc1,arc2,second_y
    Line image,(np(4)+sx*Cos(arc1),np(5)-sx*Sin(arc1))-(np(4)+(sx-t)*Cos(arc1),np(5)-(sx-t)*Sin(arc1)),colour
    Line image,(np(4)+sx*Cos(arc2),np(5)-sx*Sin(arc2))-(np(4)+(sx-t)*Cos(arc2),np(5)-(sx-t)*Sin(arc2)),colour
    'pset(xp1,yp1),rgb(255,255,255)
    Paint image,(xp1,yp1),colour,colour
End If
#endmacro

#macro get_perspective(np3,np6)
For n As long=3 To 6 Step 3
zval =np(n)  'for perspective
pp=perspective*((zval+1000)/1000-1)
pp=(1-pp)
If n=3 Then 
np(n-2)=np(n-2)-pivot_x
np(n-1)=np(n-1)-pivot_y
np(n-2)=np(n-2)*pp
np(n-1)=np(n-1)*pp
np(n-2)=np(n-2)+pivot_x
np(n-1)=np(n-1)+pivot_y
Endif
If n=6 Then 
    np(n-2)=np(n-2)-pivot_x
    np(n-1)=np(n-1)-pivot_y
    np(n-2)=np(n-2)*pp
    np(n-1)=np(n-1)*pp
    np(n-2)=np(n-2)+pivot_x
    np(n-1)=np(n-1)+pivot_y
Endif
Next n
sx=(pp)*sx
#endmacro

Dim pivot_vector(1 To 3) As Double
Dim line_vector(1 To 3) As Double
magnifier=dilator*magnifier
If shape="circle" Then
angleX=angleX Mod 360:angleY=angleY Mod 360:angleZ=angleZ Mod 360
End If
angleX_degrees=(2*p/360)*angleX      
angleY_degrees=(2*p/360)*angleY
angleZ_degrees=(2*p/360)*angleZ
pivot_vector(1)=first_x-pivot_x
pivot_vector(2)=first_y-pivot_y
pivot_vector(3)=first_z-pivot_z
pivot_vector(1)=dilator*pivot_vector(1)
pivot_vector(2)=dilator*pivot_vector(2)
pivot_vector(3)=dilator*pivot_vector(3)

Dim Rx(1 To 3,1 To 3) As Double
Dim Ry(1 To 3,1 To 3) As Double
Dim Rz(1 To 3,1 To 3) As Double
'rotat1on matrices about the three axix
If mode="3d" Then
Rx(1,1)=1:Rx(1,2)=0:Rx(1,3)=0
Rx(2,1)=0:Rx(2,2)=Cos(angleX_degrees):Rx(2,3)=-Sin(angleX_degrees)
Rx(3,1)=0:Rx(3,2)=Sin(angleX_degrees):Rx(3,3)=Cos(angleX_degrees)

Ry(1,1)=Cos(angleY_degrees):Ry(1,2)=0:Ry(1,3)=Sin(angleY_degrees)
Ry(2,1)=0:Ry(2,2)=1:Ry(2,3)=0
Ry(3,1)=-Sin(angleY_degrees):Ry(3,2)=0:Ry(3,3)=Cos(angleY_degrees)
Endif

Rz(1,1)=Cos(angleZ_degrees):Rz(1,2)=-Sin(angleZ_degrees):Rz(1,3)=0
Rz(2,1)=Sin(angleZ_degrees):Rz(2,2)=Cos(angleZ_degrees):Rz(2,3)=0
Rz(3,1)=0:Rz(3,2)=0:Rz(3,3)=1

line_vector(1)=magnifier*(second_x-first_x)'*pp                   'get the vector
line_vector(2)=magnifier*(second_y-first_y)'*pp                   'get the vector
line_vector(3)=magnifier*(second_z-first_z)'*pp

Dim new_pos(1 To 3) As Double
Dim temp1(1 To 3) As Double
Dim temp2(1 To 3) As Double
If mode="3d" Then
mv Rx(),pivot_vector(),temp1()           
mv Ry(),temp1(),temp2()
mv Rz(),temp2(),new_pos()
Endif
If mode="2d" Then
    mv Rz(),pivot_vector(),new_pos()
    Endif
new_pos(1)=new_pos(1)+pivot_x
new_pos(2)=new_pos(2)+pivot_y
new_pos(3)=new_pos(3)+pivot_z


Dim new_one(1 To 3) As Double            'To hold the turned value
If mode="3d" Then
mv Rx(),line_vector(),temp1()              'rotate
mv Ry(),temp1(),temp2()
mv Rz(),temp2(),new_one()
Endif
If mode="2d" Then
    mv Rz(),line_vector(),new_one()
    Endif
new_one(1)=new_one(1)+first_x              'translate
new_one(2)=new_one(2)+first_y
new_one(3)=new_one(3)+first_z

Dim xx As Double   
Dim yy As Double
Dim zz As Double
xx=first_x-new_pos(1)
yy=first_y-new_pos(2)
zz=first_z-new_pos(3)
 np(1)=new_one(1)-xx  
 np(2)=new_one(2)-yy
 np(3)=new_one(3)-zz
 np(4)=first_x-xx
 np(5)=first_y-yy
 np(6)= first_z-zz
If perspective <> 0 Then 
get_perspective(np(3),np(6))
End If
Select Case shape
Case "line"
    If th<2 Then
 Line image,(np(4),np(5))-(np(1),np(2)),colour 
Else
 thickline(th)   
 End If
Case "circle"
    Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
    If arc1=arc2 Then
    If th<=2 Then
 Circle image,(np(4),np(5)),magnifier*sx,colour,,,second_y
Else
 thickcircle(th)
End If
Endif
If arc1<>arc2 Then 
If th<=2 Then
    Circle image,(np(4),np(5)),magnifier*sx,colour,arc1,arc2,second_y
Else
    thickcircle(th)
End If
End If
Case "circlefill"
    Dim As Double xp1,xp2,yp1,yp2
Dim As Ulong prime=rgb(255,255,255)
Dim arc1 As Double=second_z*p/180
Dim arc2 As Double=second_arc*p/180
If arc1=arc2 Then Circle image,(np(4),np(5)),magnifier*sx,colour,,,second_y,F
If arc1<>arc2 Then
 xp1=np(4)+magnifier*sx*Cos(.5*(arc2+arc1))*3/4
yp1=np(5)-magnifier*sx*Sin(.5*(arc2+arc1))*3/4   
Circle image,(np(4),np(5)),magnifier*sx,prime,arc1,arc2,second_y
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc2),np(5)-magnifier*sx*Sin(arc2)),prime
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc1),np(5)-magnifier*sx*Sin(arc1)),prime
Paint image,(xp1,yp1),prime,prime

Circle image,(np(4),np(5)),magnifier*sx,colour,arc1,arc2,second_y
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc2),np(5)-magnifier*sx*Sin(arc2)),colour
Line image,(np(4),np(5))-(np(4)+magnifier*sx*Cos(arc1),np(5)-magnifier*sx*Sin(arc1)),colour
Paint image,(xp1,yp1),colour,colour
End If
 Case"box"
 
 Line image,(np(4),np(5))-(np(1),np(2)),colour,b
Case "boxfill"
 
 Line image,(np(4),np(5))-(np(1),np(2)),colour,bf
        Case "linepoint","circlepoint"
  'nothing drawn
Case "linepointset","circlepointset"
 If shape="linepointset" Then
 Pset image,(np(1),np(2)),colour
 Pset image,(np(4),np(5)),colour
 Endif
 If shape="circlepointset" Then
     Pset image,(np(4),np(5)),colour
 End If

        Case Else
 Print "unknown rotation shape"
End Select 
End Sub
'END OF ROTATOR
Function Regulate(Byval MyFps As long,Byref fps As long=0) As long
        Static As Double timervalue,lastsleeptime,t3,frames
        Var t=Timer
        frames+=1
        If (t-t3)>=1 Then t3=t:fps=frames:frames=0
        Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
        If sleeptime<1 Then sleeptime=1
        lastsleeptime=sleeptime
        timervalue=T
        Return sleeptime
    End Function
function resize(im As Any Ptr,Wdth As Single,Hght as single) as any ptr
     #define putpixel(_x,_y,colour)    *cptr(ulong ptr,rowS+ (_y)*pitchS+ (_x) shl 2)  =(colour)
     #define getpixel(_x,_y)           *cptr(ulong ptr,row + (_y)*pitch + (_x) shl 2)
     #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
    static As Integer pitch,pitchs
    static As Any Ptr row,rowS
    static As Ulong Ptr pixel,pixels
    static As Integer ddx,ddy,resultx,resulty
    Imageinfo im,ddx,ddy,,pitch,row
    static as any ptr im2:im2=imagecreate(Wdth,Hght)
    imageinfo im2,,,,pitchS,rowS
    For y As long=0 To Hght-1
         resulty=map(0,Hght,y,0,ddy)
        For x As long=0 To Wdth-1
            resultx=map(0,Wdth,x,0,ddx)
                    putpixel(x,y,getpixel(resultx,resulty))
        Next x
    Next y
    return im2
End function

sub drawstring(x as long,y as long,s as string,e as single=1,col as ulong,alph as ubyte=255)
    dim as any ptr i=imagecreate(8*len(s),16)
    draw string i,(0,0),s,col
    i=resize(i,e*8*len(s),e*16)
    put(x,y),i,alpha,alph
    imagedestroy i
    end sub


Sub DIECAST(values as point5d)

    Dim i As String 'For inkey$
Dim As Double px,py,pz   'pivot to rotate around
Dim  As Double u1,u2,u3,v1,v2,v3,wx,wy,wz,nw 'stuff for cross products
dim as double xc,yc,zc 'x,y,z reference for c.o.g.
xc=values.x
yc=values.y
zc=values.z


Dim As Ulong colour,markcolour
Dim mode As String 'mode
mode="3d"
Dim p As Double
p=.7            'perspective
Dim d As Double   'dilator
d=values.dil'1.3
static a1 As Double            'angle counter
static a2 As Double'=40
static a3 as double
static steps as long
Dim f As long= 12'number of faces(cube + marks)
static as double cnp()
redim preserve cnp(1 to 8)
static as double cznp()
redim preserve cznp(1 to 4)
static as double cz()
redim preserve cz(1 to f,1 to f)
'Dim As Double cnp(1 To 8),cznp(1 To 4),cz(1 To f,1 To f) 'copy line end positions
static as long paint_order()
reDim preserve paint_order(1 To f)
static as string action()
reDim preserve action(1 To f)
static as double copywx()
redim preserve copywx(1 To f)
static as double copywz()
reDim preserve copywz(1 To f)
static as double copywy()
redim preserve copywy(1 to f)
static As long k
dim as double sd 'spot dimension
sd=18
if steps=0 then
For n As long=1 To f:paint_order(n)=n:action(n)="line":Next n
    steps=1
    end if
        Dim As Double cx,cy    'centre of areas for painting
        'paint the cube faces
         #macro surface(sign,start_paint)  
        If sign*copywz(k)>start_paint Then
     If action(k)="line" Then    Paint(cx,cy),colour,colour
         action(k)="line"
     Else
         action(k)="linepoint"
        End If
        #endmacro
        'paint the spots
        #macro marksurface(sign,start_paint)
        If sign*copywz(k)>start_paint Then
     If action(k)="line" Then    Paint(cx,cy),markcolour,markcolour
         action(k)="line"
     Else
         action(k)="linepoint"
        End If
        #endmacro
 #macro zsort(n) 
 ' a quick bubblesort on z axis to get new paint order
For p1 As long = 1 To n - 1
    For p2 As long  = p1 + 1 To n          
        If (cz(p1,p1)) <= (cz(p2,p2)) Then 'Goto skip
        Swap cz(p1,p1),cz(p2,p2)
        Swap paint_order(p1),paint_order(p2)
        Endif
        skip: Next p2
    Next p1
 #endmacro
 #macro crossproduct(of_two_sides)
 'get vectors to origin
 u1=cnp(1)-cnp(3)
 u2=cnp(2)-cnp(4)
 u3=cznp(1)-cznp(2)
 v1=cnp(5)-cnp(7)
 v2=cnp(6)-cnp(8)
 v3=cznp(3)-cznp(4)
 'get the cross product 
 wx=(u2*v3-v2*u3)
 wy=-(u1*v3-v1*u3)
 wz=(u1*v2-v1*u2)
 nw=Sqr(wx^2+wy^2+wz^2)
 'normalized cross product components
 wx=wx/nw
 wy=wy/nw
 wz=wz/nw
 #endmacro
 #macro edge(number,centroids)
 Select Case number
 'define two edges for cross product
 Case 1
   cnp(1)=np(1)
   cnp(2)=np(2)
   cnp(3)=np(4)
   cnp(4)=np(5)
   cznp(1)=np(3)
   cznp(2)=np(6)
 Case 2
   cnp(5)=np(1)
   cnp(6)=np(2)
   cnp(7)=np(4)
   cnp(8)=np(5)
   cznp(3)=np(3)
   cznp(4)=np(6)
   end select
   'get the centroids, painting order depends on z centroid
cx=(cnp(1)+cnp(3)+cnp(5)+cnp(7))/4
cy=(cnp(2)+cnp(4)+cnp(6)+cnp(8))/4
if centroids=1 then
cz(paint_order(count),paint_order(count))=(cznp(1)+cznp(2)+cznp(3)+cznp(4))/4 
end if
 #endmacro
 'draw the spots then paint
 #macro mark(aspect,mx,my,mz,sgnsurface,sgnshade)
 markcolour=rgb(100-50*(1-copywx(k)),100-50*(1-copywx(k)),100-50*(1-copywx(k)))
 if aspect="xy" then
 rotate(px,py,pz,mx-sd,my,mz,mx,my-sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top /
 edge(1,0)
 rotate(px,py,pz,mx,my-sd,mz,mx+sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top \
 edge(2,0)
 crossproduct(0)
 rotate(px,py,pz,mx+sd,my,mz,mx,my+sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base /
 edge(2,0)
 rotate(px,py,pz,mx,my+sd,mz,mx-sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base \
end if
if aspect="yz" then
 rotate(px,py,pz,mx,my,mz-sd,mx,my-sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top /
 edge(1,0)
 rotate(px,py,pz,mx,my-sd,mz,mx,my,mz+sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top \
 edge(2,0)
 crossproduct(0)
 rotate(px,py,pz,mx,my,mz+sd,mx,my+sd,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base /
 edge(2,0)
 rotate(px,py,pz,mx,my+sd,mz,mx,my,mz-sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base \
    end if
if aspect="xz" then
  rotate(px,py,pz,mx,my,mz+sd,mx+sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top /
 edge(1,0)
 rotate(px,py,pz,mx+sd,my,mz,mx,my,mz-sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'top \
 edge(2,0)
 crossproduct(0)
 rotate(px,py,pz,mx,my,mz-sd,mx-sd,my,mz,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base /
 edge(2,0)
 rotate(px,py,pz,mx-sd,my,mz,mx,my,mz+sd,.0,a1,a2,a3,1,d,markcolour,1,action(k),mode,p)'base \  
    end if
 copywz(k)=wz
copywx(k)=sgnshade*wx
marksurface(sgnsurface,.03)
 #endmacro
 
 #macro getcentroids(fx1,fy1,fz1,fx2,fy2,fz2,sx1,sy1,sz1,sx2,sy2,sz2)
 rotate(px,py,pz,fx1,fy1,fz1,fx2,fy2,fz2,.0,a1,a2,a3,1,d,colour,1,"linepoint",mode,p)
 edge(1,1)
 rotate(px,py,pz,sx1,sy1,sz1,sx2,sy2,sz2,.0,a1,a2,a3,1,d,colour,1,"linepoint",mode,p)
edge(2,1)
 #endmacro
 
 #macro getface(colour_shader)
 colour=rgb(238-50*(1-copywx(k)),217-50*(1-copywx(k)),150-50*(1-copywx(k)))
 #endmacro
 ' ****************** DIE MOTION *******************
 

 p=.7
 
 px=xc
 py=yc
 pz=zc
 

       a1=a1+.9*values.speed'(.9*spin)*.1
       a2=a2+values.speed'spin*.1
       'draw string(20,20),str(copywx(k))
    

        For count As long=1 To f
            k=paint_order(count)
        Select Case k
'THE SIX FACES
  Case 1
      getface(0)
      'back
      'base 
rotate(px,py,pz,xc-100,yc+100,zc+100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(1,1)
'left side
rotate(px,py,pz,xc-100,yc-100,zc+100,xc-100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)
crossproduct(0)
'right side
rotate(px,py,pz,xc+100,yc+100,zc+100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
'edge(2)
'top 
rotate(px,py,pz,xc+100,yc-100,zc+100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)

copywz(k)=wz
copywx(k)=wx
copywy(k)=wy
surface(-1,.02)
case 7
    '1
getcentroids(xc-100,yc+100,zc+101,xc+100,yc+100,zc+101,xc+100,yc-100,zc+101,xc-100,yc-100,zc+101)
    'back mark(1)
  mark("xy",xc,yc,zc+101,-1,1)  

Case 2
    getface(0)
    'front
'base 
rotate(px,py,pz,xc-100,yc+100,zc-100,xc+100,yc+100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(1,1)
'left side 
rotate(px,py,pz,xc-100,yc-100,zc-100,xc-100,yc+100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)
crossproduct(0)
'right side 
rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
'top 
rotate(px,py,pz,xc+100,yc-100,zc-100,xc-100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
edge(2,1)
copywz(k)=wz
copywx(k)=-wx
surface(1,.02)
case 8
    '6
getcentroids(xc-100,yc+100,zc-101,xc+100,yc+100,zc-101,xc+100,yc-100,zc-101,xc-100,yc-100,zc-101)
    mark("xy",xc-50,yc-50,zc-101,1,-1)
     mark("xy",xc-50,yc,zc-101,1,-1)
      mark("xy",xc-50,yc+50,zc-101,1,-1)
      
     mark("xy",xc+50,yc-50,zc-101,1,-1)
     mark("xy",xc+50,yc,zc-101,1,-1)
      mark("xy",xc+50,yc+50,zc-101,1,-1) 
Case 3
    getface(0)
    'left side
    'base
    rotate(px,py,pz,xc-100,yc+100,zc-100,xc-100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    edge(1,1)
    'front
    rotate(px,py,pz,xc-100,yc+100,zc-100,xc-100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    edge(2,1)
    crossproduct(0)
    'back
    rotate(px,py,pz,xc-100,yc+100,zc+100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    'top
    rotate(px,py,pz,xc-100,yc-100,zc-100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
    edge(2,1)
copywz(k)=wz
copywx(k)=-wx
surface(1,.02)
case 9
    '2
 getcentroids( xc-101,yc+100,zc-100,xc-101,yc+100,zc+100,xc-101,yc-100,zc-100,xc-101,yc-100,zc+100)
 mark("yz",xc-101,yc-50,zc-50,-1,1)
 mark("yz",xc-101,yc+50,zc+50,-1,1) 
Case 4
    getface(0)
 'right side
 'base
 rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(1,1)
 'front
 rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
 crossproduct(0)
 'back
 rotate(px,py,pz,xc+100,yc+100,zc+100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 'top
 rotate(px,py,pz,xc+100,yc-100,zc-100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
copywz(k)=wz
copywx(k)=wx
 surface(-1,.02)
case 10
 '4
 getcentroids(xc+101,yc+100,zc-100,xc+101,yc+100,zc+100,xc+101,yc-100,zc-100,xc+101,yc-100,zc+100)
 mark("yz",xc+101,yc-50,zc-50,1,-1)
 mark("yz",xc+101,yc+50,zc+50,1,-1) 
 mark("yz",xc+101,yc-50,zc+50,1,-1)
 mark("yz",xc+101,yc+50,zc-50,1,-1)
Case 5
  getface(0)
 'topside
 'front
 rotate(px,py,pz,xc-100,yc-100,zc-100,xc+100,yc-100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(1,1)
 'left
 rotate(px,py,pz,xc-100,yc-100,zc-100,xc-100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
 crossproduct(0)
 'right
 rotate(px,py,pz,xc+100,yc-100,zc-100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 'back
 rotate(px,py,pz,xc-100,yc-100,zc+100,xc+100,yc-100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
copywz(k)=wz
copywx(k)=wx
 surface(-1,.02)
case 11
 '3
 getcentroids(xc-100,yc-101,zc-100,xc+100,yc-101,zc-100,xc-100,yc-101,zc+100,xc+100,yc-101,zc+100)
 mark("xz",xc,yc-101,zc,1,-1)
 mark("xz",xc+50,yc-101,zc+50,1,-1)
 mark("xz",xc-50,yc-101,zc-50,1,-1)
Case 6
    'colour=rgb(200-50*(1-copywx(k)),200-50*(1-copywx(k)),200-50*(1-copywx(k)))
    getface(0)
 'bottomside
 'front
 rotate(px,py,pz,xc-100,yc+100,zc-100,xc+100,yc+100,zc-100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(1,1)
 'left
 rotate(px,py,pz,xc-100,yc+100,zc-100,xc-100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
 crossproduct(0)
 'right
 rotate(px,py,pz,xc+100,yc+100,zc-100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 'back
 rotate(px,py,pz,xc-100,yc+100,zc+100,xc+100,yc+100,zc+100,.0,a1,a2,a3,1,d,colour,1,action(k),mode,p)
 edge(2,1)
copywz(k)=wz
copywx(k)=-wx
 surface(1,.02)
case 12
 '5
 getcentroids(xc-100,yc+101,zc-100,xc+100,yc+101,zc-100,xc-100,yc+101,zc+100,xc+100,yc+101,zc+100)
 mark("xz",xc,yc+101,zc,-1,1)
 mark("xz",xc+50,yc+101,zc+50,-1,1)
 mark("xz",xc-50,yc+101,zc-50,-1,1)
 mark("xz",xc+50,yc+101,zc-50,-1,1)
 mark("xz",xc-50,yc+101,zc+50,-1,1)
 
End Select
Next count
For n As long=1 To f:paint_order(n)=n:Next n
zsort(f)
If a1>360 Then a1=0
If a2>360 Then a2=0
if a3>360 then a3=0

End Sub
Sub draw_box(p() As box,col As Uinteger,pnt As String="paint",im As Any Pointer=0)
    Dim As Single n1= p(rect,0).z
    Dim As Integer index,nextindex
    Dim As Double xc,yc
    For n As Integer=1 To 4
        xc=xc+p(n,n1).x:yc=yc+p(n,n1).y
        index=n Mod 5:nextindex=(n+1) Mod 5
        If nextindex=0 Then nextindex=1
        thickline_(p(index,n1).x,p(index,n1).y,p(nextindex,n1).x,p(nextindex,n1).y,4,col,im)
        'Line im,(p(index,n1).x,p(index,n1).y)-(p(nextindex,n1).x,p(nextindex,n1).y),col
    Next
    xc=xc/Ubound(p):yc=yc/Ubound(p)
    If pnt="paint" Then Paint (xc,yc),col,col
End Sub

sub highlightbox(box() as box,mp as box,col as uinteger)
    box(rect,0).z=1
    if inbox(box(),mp) then draw_box(box(),col,"dont_paint")
    end sub

Function inbox(p1() As box,p2 As box) As Integer
    type pt2d:as single x,y:end type
    type ln2d:as pt2d v1,v2:end type
    
    #macro isleft(L,p)
    -Sgn(  (L.v1.x-L.v2.x)*(p.y-L.v2.y) - (p.x-L.v2.x)*(L.v1.y-L.v2.y))
    #endmacro
    Dim As Single n1=p1(rect,0).z
    Dim As Integer index,nextindex
    Dim send As ln2d
    Dim wn As Integer=0
    For n As Integer=1 To 4
        index=n Mod 5:nextindex=(n+1) Mod 5
        If nextindex=0 Then nextindex=1
        send.v1.x=p1(index,n1).x:send.v2.x=p1(nextindex,n1).x
        send.v1.y=p1(index,n1).y:send.v2.y=p1(nextindex,n1).y
        If p1(index,n1).y<=p2.y Then
            If p1(nextindex,n1).y>p2.y Then 
                If isleft(send,p2)>0 Then 
                    wn=wn+1
                End If
            End If
        Else
            If p1(nextindex,n1).y<=p2.y Then
                If isleft(send,p2)<0 Then
                    wn=wn-1
                End If
            End If
        End If
    Next n
    Return wn
End Function


sub drawbox(x as integer,y as integer,box()as box,boxlength as integer,boxheight as integer,boxcolour as uinteger,outline as uinteger,highlight as uinteger,caption as string)
    counter=counter+1
      Dim As box startpoint 
    startpoint.x=x:startpoint.y=y
    dim as integer mmx,mmy
    getmouse mmx,mmy
    dim as box mouse
    mouse.x=mmx
    mouse.y=mmy
    box(rect,1).boxcol=boxcolour
    box(rect,1).caption=caption
    dim as integer count=1
    'outline=rgb(255,255,255)
    #macro _highlightbox()
    box(rect,0).z=1
    if inbox(box(),mouse) then draw_box(box(),highlight,"dont_paint")
    #endmacro
    For x As Integer=1 To 4
            Select Case x
            Case 1
                box(1,count).x=startpoint.x
                box(1,count).y=startpoint.y
            Case 2
                box(2,count).x=box(1,count).x+boxlength
                box(2,count).y=box(1,count).y
            Case 3
                box(3,count).x=box(2,count).x
                box(3,count).y=box(2,count).y+boxheight
            Case 4
                box(4,count).x=box(3,count).x-boxlength
                box(4,count).y=box(3,count).y
            End Select
        Next x
        box(rect,0).z=1
       draw_box(box(),boxcolour)
        draw_box(box(),outline,"nopaint")
        if inbox(box(),mouse) then
            'highlightbox(box(),mouse,highlight)
            _highlightbox()
        If (ScreenEvent(@e)) Then
        If e.type=fb.EVENT_MOUSE_BUTTON_PRESS Then
        On_Click(box(),mouse)
        End If
        end if
    End If
        draw string(box(1,1).x+5,box(1,1).y+5),box(rect,1).caption,box(rect,1).textcol
    end sub
    sub On_Click(box() as box,mp as box)
        flag=-1
       if counter=3 then
       startreck=1:_dots=0:_bird=0:gold=0
   end if
   if counter=2 then
       window screen 
       startreck=0:_dots=1:_bird=0:gold=0
   end if
   if counter=4 then
       _bird=1:_dots=0:startreck=0:gold=0
   end if
   if counter=5 then
       gold=1:_dots=0:startreck=0:_bird=0
   end if
   if counter=6 then
       dim as long mx,my
       getmouse mx,my
       if incircle(520,410,30,mx,my) then end
       'beep
       end if
        'label(rect,1).caption=box(rect,1).caption
        'label(rect,1).textcol=box(rect,1).textcol
        'label(rect,1).boxcol=box(rect,1).boxcol
        end sub
Sub thickline_(x1 As Double,_
              y1 As Double,_
              x2 As Double,_
              y2 As Double,_
              thickness As Double,_
              colour As Uinteger,_
              im As Any Pointer=0)
              Dim p As Uinteger=Rgb(255, 255, 254)
              If thickness<2 Then
                  Line(x1,y1)-(x2,y2),colour
              Else               
dim as double h=Sqr((x2-x1)^2+(y2-y1)^2),s= (y1-y2)/h ,c=(x2-x1)/h 
for x as integer=1 to 2
Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),p
Line im,(x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),p
Line im,(x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
Paint im,((x1+x2)/2, (y1+y2)/2), p, p
p=colour
next x
End If
End Sub
Sub starfield(pixels As Integer=1000,maxlength As Integer=10,offx As Double=0,offy As Double=0)
    Dim  As Integer xres,yres
    Screeninfo xres,yres
    Dim As Integer _width=(1+offx)*xres,_height=(1+offy)*yres',X,Y,Z
    Static As Integer x,y,z
    view(405,105)-(645,345),rgb(0,0,50)
    #macro refresh(zz)
   
    X=rr(-(( _width + 1) - ( _width /2)),(( _width + 1) - ( _width /2)))
    Y=rr(-((_height + 1) - (_height /2)),((_height + 1) - (_height /2)))
    X3D(i,0) = X
    Y3D(i,0) = Y
    length=Int(Rnd*(maxlength))+1
    Z3D(i,0) =  length
    #endmacro
    #macro rr(first,last)
    Rnd * (last - first) + first
    #endmacro
   static as double size1()
    Static  As Double Z3D(),X2D(),Y2D()
    Static As Integer X3D(),Y3D()
    Static As Uinteger colour()
    Static count As Integer
    redim preserve size1(pixels)
    Redim Preserve X3D(pixels,2)'int
    Redim Preserve Y3D(pixels,2)'int
    Redim  Preserve Z3D(pixels,2) 'as double
    Redim Preserve X2D(pixels,2)'dbl
    Redim Preserve Y2D(pixels,2)'dbl
    Dim As Integer i
    Static As Integer  length
    Redim Preserve colour(pixels)
   
    ' Initialize on first call only
    If count=0 Then
        For i = 0 To pixels
            X=rr(-(( _width + 1) - ( _width /2)),(( _width + 1) - ( _width /2)))
            Y=rr(-((_height + 1) - (_height /2)),((_height + 1) - (_height /2)))
            Z=Int(Rnd*200)
            length=Int(Rnd*maxlength)+1
            X3D(i,0) = X
            Y3D(i,0) = Y
            Z3D(i,0) = Z  +  length
            X3D(i,1) = X
            Y3D(i,1) = Y
            Z3D(i,1) = Z
            colour(i)=Rgb(rr(0,255),rr(0,255),rr(0,255))
        Next
        count=count+1
    End If
   
    For i = 0 To pixels
        X2D(i,0) = ((X3D(i,0) * 256) / (256 - Z3D(i,0))) + ( _width / 2)
        Y2D(i,0) = (((_height / 2)- Y3D(i,0) * 256) / (256 - Z3D(i,0))) + (_height / 2)
       
        X2D(i,1) = ((X3D(i,1) * 256) / (256 - Z3D(i,1))) + ( _width / 2)
        Y2D(i,1) = (((_height / 2)- Y3D(i,1) * 256) / (256 - Z3D(i,1))) + (_height / 2)
        Line(X2d(i,0),Y2D(i,0))-(X2d(i,1),Y2D(i,1)),colour(i)'rgb(x3d(i,1),y3d(i,1),z3d(i,1))
        'size1(i)=.03*sqr((x2d(i,0)-x2d(i,1))^2+(y2d(i,0)-y2d(i,1))^2)
    'drawstars(X2D(i,0),Y2d(i,0),size1(i),colour(i)+1)
    Next 
    For i = 0 To pixels
        Z3D(i,0) = Z3D(i,0) + 1
        Z3D(i,1) = Z3D(i,1) + 1
       
        If Z3D(i,1) > 254 - maxlength Then 
            Refresh(0)
        End If
       
        If Z3D(i,1) > 254 - maxlength Then
            X3D(i,1) = X3D(i,0): Y3D(i,1) = Y3D(i,0)
        End If
        If Z3D(i,1) > 254 - maxlength Then
            Z3D(i,1) = 0
        End If
    Next
    view(0,0)-(xres,yres)
End Sub
sub dots
    #define rn(f,l) rnd*(l-f)+f
     for z as integer=1 to 100
        pset(rn(405,645),rn(105,345)),rgb(255,255,255)
        next z
        pset(rn(405,645),rn(105,345)),rgb(100,0,0)
    end sub
 sub bird
dim as integer xres,yres
screeninfo xres,yres
line(405,105)-(645,345),rgb(0,0,10),B
window(-(600+700),-(200+100))-((900+400),800+500)
dim as double PLOT_grade=2000
dim as double temp1,temp2
#macro sketch(_function,minx,maxx,miny,maxy)
For x As Double=minx To maxx  Step (maxx-minx)/PLOT_GRADE
    dim as double x1=Cdbl(xres)*(x-minx)/(maxx-minx)
    dim as double y1=Cdbl(yres)*(_function-maxy)/(miny-maxy)
    Pset(x1,y1),rgb(0,0,10)'10
    if abs(x)<1e-3 then
        temp1=x1:temp2=y1
        end if
Next x
circle (temp1,temp2),50,rgb(0,200,0),,,,f
circle (temp1-20,temp2-20),10,rgb(200,200,200),,,,f
circle (temp1+20,temp2-20),10,rgb(200,200,200),,,,f

circle (temp1-20-5*z,temp2-20),3,rgb(00,00,200),,,,f
circle (temp1+20-5*z,temp2-20),3,rgb(00,00,200),,,,f

circle (temp1,temp2),30,rgb(0,0,0),4,5.5
circle (temp1,temp2-2),30,rgb(0,0,0),4-k/3,5.5+k/3
circle (temp1,temp2),51,rgb(0,0,10)
#endmacro

static k as integer=1
static z as double
dim pi as double=4*atn(1)
     z=z+.02*k '.02

sketch (-sin(z*x+z),-(pi),pi,-2,2)
sketch (sin(z*x-z),-(pi),pi,-2,2)
paint (.25*xres,.5*yres),rgb(100,200,220),rgb(0,0,10)
paint (.75*xres,.5*yres),rgb(100,200,220),rgb(0,0,10)
if z>1.1 then k=-k
if z<-1.1 then k=-k
if z>2*pi then z=0
window screen (0,0)-(xres,yres)
end sub


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

Re: Squares

Post by albert »

@Richard
@Dodicat

If you got a file len = 10,000 * 8 bits , 80,000 bytes , and you can compress it to 15 bits instead of 16 , how many bytes does that shave off?

Can you guys give me a formula to figure it out?
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Hi Albert.
just working on 10000
(But I don't think this is what you mean)

Code: Select all


var bytes=10000
var bits=bytes*8
bits=(15/16)*bits
var newbytes=bits/8
print bytes-newbytes; "  bytes off"
sleep


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

Re: Squares

Post by albert »

@Dodicat

I think your formula was wrong.. I tinkered with it , and got it working..

My compressor , compresses only 25%.

Each bit you compress by is equal to 12.5% compression
1 bit = 12.%%
2 bits = 25 %
3 bits = 37.5%
4 bits = 50 %

Code: Select all


screen 19

do
    
    var bytes = int(rnd*100000)
    var bits = bytes * 8
    bits = bits - ((12-10)*bytes)
    var newbytes = bits / 8
    
    print
    print "bits in   = " ; bytes * 8
    print "bits out  = " ; bits
    print
    print "bytes in  = " ; bytes
    print "bytes out = " ; bytes - (bytes - newbytes)
    print
    print "compress  = " , (100 / (bytes / (bytes - newbytes))) ; "%" 
    sleep

loop until inkey = chr(27)

sleep
end

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

Re: Squares

Post by albert »

@Richard

I figured out "data compression" finally...

Try this code on *.bas or *.exe files.., it can't compress *.zip or *.mp3 files..

It doesn't really compress yet, it's just code for building the two dictionaries..

if in dict1 = 0 then put it in dict1.. if in dict1 > 0 then put it in dict2 as a pointer to the location in dict1.

Code: Select all

#define WIN_INCLUDEALL
#Include "windows.bi"
#Include "File.bi"

declare sub getfilename()
declare sub compress()
declare sub decompress()
declare function MultiBase_Number( byval Number as ulongint , byval Number_Base as ulongint ) as string

dim shared as string file , extension , file_data , bytes , file_name
dim as ubyte value1

Dim As MSG msg
Dim shared As HWND hWnd

screen 19

getfilename()

if FileExists(file) then
    for a as ulongint = len(file)-1 to 0 step -1
        bytes=chr(file[a])
        if bytes = "\" then file_name = mid(file,a+2):exit for
    next
    
    print file_name

    file_data = ""
    open file for binary as #1
        do
            get #1,,value1
            file_data = file_data + chr(value1)
        loop until eof(1)
    close #1
    
    if extension = ".BDC" then
        print
        print "DECOMPRESSING:" , len(file_data)
        decompress()
    else
        print
        print "COMPRESSING:" , len(file_data)
        extension=".BDC"
        compress()
    end if

end if
'===============================================================================
'===============================================================================
'END Program
'===============================================================================
'===============================================================================
END

'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
sub compress()
    
    dim as double time1 , time2
    
    time1 = timer
    
        dim as string inputs = file_data
        
        dim as longint size = 2
        
        start:
        
        print "building first dictionary"
        
        dim as string dict1 = ""
        dim as string dict2 = ""
        dim as string vals = ""
        dim as longint place = 0
        dim as longint count = 0
        dim as longint counter = 0
        for a as longint = 1 to len(inputs) step size
            vals = mid(inputs,a,size)
            place = instr(1,dict1,vals)
            if place = 0 then 
                dict1+= vals
                count+= size
                counter+=1
            end if
        next
        
        print "building second dictionary"
        
        dim as longint locs = 0
        for a as longint = 1 to len(inputs) step size
            vals = mid(inputs,a,size)
            place = instr(1,dict1,vals)
            if place > 0 and place mod size > 0 then
                locs = instr(1,dict2,right(string(len(bin(count)),"0") + bin(place), len(bin(count))))
                if locs = 0 then
                    dict2+= right(string(len(bin(count)),"0") + bin(place), len(bin(count))) + " " 
                    if a mod 1007 = 0  then print a , place , right(dict2,len(bin(count))+3)
                    if a = len(inputs) then print a , place , right(dict2,len(bin(count))+3)
                end if
            end if
        next
        
        print
        print "counting spaces"
        print
        
        dim as longint num = 0
        for a as longint = 1 to len(dict2)
            if mid(dict2,a,1) = " " then num+=1
        next
                
        print "unique = " ; counter ;" " ; "num = " ; count ; " " ; "len dict1 = " ; len(dict1) ;" " ; "len_dict2 = " ; (len(dict2)-num)\8 ;" " ;"total dict = " ; len(dict1) + ((len(dict2)-num)\8)
        
        sleep
        
    time2 = timer
    
    'dim as longint place = 1
    'for a as longint = 1 to len(dict1) step size
    '    print place ; " " ; "step = " ; size*8 ; " " ; "dict = " ; (len(dict1)-count) ; " " ; "compression = " ; ((size*8)-len(bin(place)))*12.5/2 ; "%" , len(bin(place)) , len(file_data)
    '    place+=1
    'next
    
    print
    print "Dict size = " ; len(dict1) + ((len(dict2)-num)\8)
    print
    print "Time = " ; time2-time1
    print
    print file_name ; "  " ; len(file_data)
    print
    'print dict2
    
    sleep
    
    'sleep
    '    open file_name+".BDC" for output as #1
    '        print #1,bytes_out
    '    close #1
    'sleep
        
            
end sub
'===============================================================================
'===============================================================================
'Decompress
'===============================================================================
'===============================================================================
sub decompress()
'not written yet
end sub
'===============================================================================
'===============================================================================
'Get File Name
'===============================================================================
'===============================================================================
sub getfilename()
        dim ofn as OPENFILENAME
        dim filename as zstring * MAX_PATH+1
        
        with ofn
                .lStructSize            = sizeof( OPENFILENAME )
                .hwndOwner              = hWnd
                .hInstance              = GetModuleHandle( NULL )
                .lpstrFilter            = strptr( !"All Files, (*.*)\0*.*\0\0" )
                .lpstrCustomFilter      = NULL
                .nMaxCustFilter         = 0
                .nFilterIndex           = 1
                .lpstrFile              = @filename
                .nMaxFile               = sizeof( filename )
                .lpstrFileTitle         = NULL
                .nMaxFileTitle          = 0
                .lpstrInitialDir        = NULL
                '.lpstrTitle            = @"File Open Test"
                .lpstrTitle             = @"File to Compress/Decompress"
                .Flags                  = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
                .nFileOffset            = 0
                .nFileExtension         = 0
                .lpstrDefExt            = NULL
                .lCustData              = 0
                .lpfnHook               = NULL
                .lpTemplateName         = NULL
        end with
        
        if( GetOpenFileName( @ofn ) = FALSE ) then
            file = ""
            return
        else
            file = filename
            extension = right$(filename,4)
    end if

end sub

MrSwiss
Posts: 3910
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: Squares

Post by MrSwiss »

sancho3 wrote:So if you push three bytes into an integer you are going to waste 1 full byte. That is a lot of wasted space.
This only holds true, in FBC 32-bit.
In fact, it becomes far worse, when using FBC 64: 5 wasted Bytes (Integer = LongInt = 8 Bytes)!

This is one of the reasons, that I prefer FIXED-Size Types: U/Byte, U/Short, U/Long, U/LongInt (over Integer)!
(their size remains, independent of FBC's bitness used)
albert
Posts: 6000
Joined: Sep 28, 2006 2:41
Location: California, USA

Data Compressor

Post by albert »

Hello Guys;

I got the data compressor working.. ( but it can't compress *.ZIP or *.MP3 files..)

It builds a dictionary and output to 256 values , then spawns another dictionary and output.

it takes in 2 bytes and outputs 1 byte , when the total goes above 255 then it creates another dict and out.
It compresses *.txt and *.bas files quite a bit..

It doesn't yet have an output , it's just creating the dict and out arrays..

Code: Select all

#define WIN_INCLUDEALL
#Include "windows.bi"
#Include "File.bi"

declare sub getfilename()
declare sub compress()
declare sub decompress()
declare function MultiBase_Number( byval Number as ulongint , byval Number_Base as ulongint ) as string

dim shared as string file , extension , file_data , bytes , file_name
dim as ubyte value1

Dim As MSG msg
Dim shared As HWND hWnd

screen 19

getfilename()

if FileExists(file) then
    for a as ulongint = len(file)-1 to 0 step -1
        bytes=chr(file[a])
        if bytes = "\" then file_name = mid(file,a+2):exit for
    next
    
    print file_name

    file_data = ""
    open file for binary as #1
        do
            get #1,,value1
            file_data = file_data + chr(value1)
        loop until eof(1)
    close #1
    
    if extension = ".BDC" then
        print
        print "DECOMPRESSING:" , len(file_data)
        decompress()
    else
        print
        print "COMPRESSING:" , len(file_data)
        extension=".BDC"
        compress()
    end if

end if
'===============================================================================
'===============================================================================
'END Program
'===============================================================================
'===============================================================================
END

'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
sub compress()
    
    dim as double time1 , time2
    
    time1 = timer
        
        dim as string inputs = file_data
        
        dim as longint size = 2
        
        start:
        
        print "trying size = " ; size
        
        redim as string dict(1)
        redim as string outs(1)
        dim as string vals
        dim as longint element = 1
        dim as longint bytes = 0
        dim as longint spaces = 0
        for a as longint = 1 to len(inputs) step 2
            vals = mid(inputs,a,2)
            if instr(1,dict(element),vals) = 0 then 
                dict(element)+= vals + " " : spaces+=1
                outs(element)+= chr(bytes)
                bytes+=1
            end if
            if bytes = 256 then 
                bytes = 0
                element+=1
                redim preserve dict(element)
                redim preserve outs(element)
            end if
        next
        
        dim as longint dict_total = 0
        dim as longint outs_total = 0
        for a as longint = 1 to ubound(dict)
            dict_total+= len(dict(a))
            outs_total+= len(outs(a))
            'print len(dict(a)) , len(outs(a))
        next
        
    time2 = timer
    
    print "size of dict = " ; dict_total-spaces ; " " ; "total_out = " ; outs_total
    print "Total size   = " ; (dict_total-spaces) + outs_total
    print
    print "Time = " ; time2 - time1
    print
    print file_name ; "  " ; len(file_data)
    print
    
    
    sleep
    
    'sleep
    '    open file_name+".BDC" for output as #1
    '        print #1,bytes_out
    '    close #1
    'sleep
        
            
end sub
'===============================================================================
'===============================================================================
'Decompress
'===============================================================================
'===============================================================================
sub decompress()
'not written yet
end sub
'===============================================================================
'===============================================================================
'Get File Name
'===============================================================================
'===============================================================================
sub getfilename()
        dim ofn as OPENFILENAME
        dim filename as zstring * MAX_PATH+1
        
        with ofn
                .lStructSize            = sizeof( OPENFILENAME )
                .hwndOwner              = hWnd
                .hInstance              = GetModuleHandle( NULL )
                .lpstrFilter            = strptr( !"All Files, (*.*)\0*.*\0\0" )
                .lpstrCustomFilter      = NULL
                .nMaxCustFilter         = 0
                .nFilterIndex           = 1
                .lpstrFile              = @filename
                .nMaxFile               = sizeof( filename )
                .lpstrFileTitle         = NULL
                .nMaxFileTitle          = 0
                .lpstrInitialDir        = NULL
                '.lpstrTitle            = @"File Open Test"
                .lpstrTitle             = @"File to Compress/Decompress"
                .Flags                  = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
                .nFileOffset            = 0
                .nFileExtension         = 0
                .lpstrDefExt            = NULL
                .lCustData              = 0
                .lpfnHook               = NULL
                .lpTemplateName         = NULL
        end with
        
        if( GetOpenFileName( @ofn ) = FALSE ) then
            file = ""
            return
        else
            file = filename
            extension = right$(filename,4)
    end if

end sub

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

Re: Squares

Post by albert »

Hello Guys;

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

I re-wrote the Mew Years song "Old Lang Syne" and made it about partying...

( Genre = ??? )

( Title = New Years Eve )

( entry music )

should we all drink another beer , for the passing of yule-tide
we're ringing in another year , and with cheer we all imbibe

and should our new years eve dinner , be of pork or country ham
they sailed cross the ocean blue , and here's a toast to the land

and should our new years eve this year , turn into a valentine
we count our blessings as we go , i'll be hers and she'll be mine

we're ringing in another year , as the old one passes by
and with a cheer we drink a beer, as the hour hand goes high

( music )

should we all drink another beer , for the passing of yule-tide
we're ringing in another year , and with cheer we all imbibe

should we all meet on new years eve , for a party at the end
as the new year is ringing in, have you got a cheer to lend

should we all meet on new years eve , drinking beer and shots and wine
we're waiting for the ball to drop , with a taste of bubbly wine

should we ring in another year , with a cheer a shout a cry
we're drinking beer and shots and wine , as the old year passes by

( music )

should we all drink another beer , for the passing of yule-tide
we're ringing in another year , and with cheer we all imbibe

( exit music )

albert_redditt@yahoo.com

Albert Redditt
315 W. Carrillo St. #104
Santa Barbara, Ca. 93101 U.S.A.
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

strobogrammatic numbers

Post by srvaldez »

based on the work of Rei Colina https://gist.github.com/reinaldo13/fa705090cebedb14464b

Code: Select all

function reverselong(byval n as long) as long
	dim as string r="", c, s=str(n)
	dim as long l=len(s)
	if l<=1 then
		return n
	else
		for i as long=1 to l
			c=mid(s,l-i+1,1)
			if c="6" then
				c="9"
			elseif c="9" then
				c="6"
			end if
			r+=c
		next
	end if
	return val(r)
end function

dim as long count
dim as long low, high
dim as string number

low=0 : high=1000000
count=0

for i as long = low to high
	if i<>6 andalso i<>9 then
		number=str(i)
		if instr(number, any "23457")=0 then
			if i=reverselong(i) then
				print i,
				count+=1
			end if
		end if
	end if
next
print
print "number of strobogrammatic numbers between ";low;" and ";high;" is ";count
Last edited by srvaldez on Jan 19, 2018 16:09, edited 1 time in total.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Squares

Post by dodicat »

Happy new year Albert and all squares participants.
Srvaldez
I tried with a different font set
(Led lights(ish))
colour 7, size 7, and there are seven bulbs in a Led display (The old ones anyway)

Code: Select all

function reverselong(byval n as long) as long
   dim as string r="", c, s=str(n)
   dim as long l=len(s)
   if l<=1 then
      return n
   else
      for i as long=1 to l
         c=mid(s,l-i+1,1)
         if c="6" then
            c="9"
         elseif c="9" then
            c="6"
         end if
         r+=c
      next
   end if
   return val(r)
end function
Sub digits(t As String,x As long,y As long,clr As Ulong,sz As long,img As Any Pointer=0)
        x=x-2*sz
        dim as single s=any,c=any
        #macro thickline(x1,y1,x2,y2)
             s=(y1-y2)/10
             c=(x2-x1)/10
            Line img,(x1-s,y1-c)-(x2+s,y2+c),clr,bf
        #endmacro
        #macro display(_a,_b,_c,_d,_e,_f,_g)
        x=x+2*sz
        If _a=1 Then :thickline(x,y,(x+sz),y):End If
        If _b=1 Then :thickline((x+sz),y,(x+sz),(y+sz)):End If
        If _c=1 Then :thickline((x+sz),(y+sz),(x+sz),(y+2*sz)):End If 
        If _d=1 Then :thickline((x+sz),(y+2*sz),x,(y+2*sz)):End If
        If _e=1 Then :thickline(x,(y+2*sz),x,(y+sz)):End If
        If _f=1 Then :thickline(x,(y+sz),x,y):End If
        If _g=1 Then :thickline(x,(y+sz),(x+sz),(y+sz)):End If
        #endmacro
        For z As long=0 To Len(t)-1
            Select Case As Const t[z]
            Case 48 :display(1,1,1,1,1,1,0)             '"0"
            Case 49 :display(0,1,1,0,0,0,0)             '"1"
            Case 50 :display(1,1,0,1,1,0,1)             '"2"
            Case 51 :display(1,1,1,1,0,0,1)             '"3"
            Case 52 :display(0,1,1,0,0,1,1)             '"4"
            Case 53 :display(1,0,1,1,0,1,1)             '"5"
            Case 54 :display(1,0,1,1,1,1,1)             '"6"
            Case 55 :display(1,1,1,0,0,0,0)             '"7"
            Case 56 :display(1,1,1,1,1,1,1)             '"8"
            Case 57 :display(1,1,1,1,0,1,1)            '"9"
            Case 58                                     '":"                   
                Circle((x+2*sz),(y+sz/2)),(sz/5),clr,,,,f
                Circle((x+2*sz),(y+1.5*sz)),(sz/5),clr,,,,f
                x=x+sz 
            Case 45 :display(0,0,0,0,0,0,1)              '"-"                       
            Case 46                                      '"."                       
                Circle((x+2*sz),(y+1.9*sz)),(sz/5),clr,,,,f
                x=x+sz 
            Case 32                                      '" "
                x=x+sz 
            End Select
        Next z
    End Sub  
dim as long count
dim as long low, high,x=0,y=10
dim as string number
screen 20
low=0 : high=1000000
count=0
for i as long = low to high
   number=str(i)
   if instr(number, any "23457")=0 then
      if i=reverselong(i) then
          x+=1
         
         digits(number,x*100,y,7,7)
         count+=1
        
      end if
   end if
   if x>8 then x=0:y+=30
  
next
print
locate 45
print "number of strobogrammatic numbers between ";low;" and ";high;" is ";count
sleep 
srvaldez
Posts: 3373
Joined: Sep 25, 2005 21:54

Re: Squares

Post by srvaldez »

@dodicat
with your fonts we can include 2's and 5's with a tiny modification
by changing if instr(number, any "23457")=0 then
to if instr(number, any "347")=0 then
there's no need to swap a 2 with a 5 and vice versa because 2 and 5 remain the same when flipped.
it greatly increases the amount of numbers
[edit] corrected a bug, single digit 6 and 9 must be excluded

Code: Select all

function reverselong(byval n as long) as long
   dim as string r="", c, s=str(n)
   dim as long l=len(s)
   if l<=1 then
      return n
   else
      for i as long=1 to l
         c=mid(s,l-i+1,1)
         if c="6" then
            c="9"
         elseif c="9" then
            c="6"
         end if
         r+=c
      next
   end if
   return val(r)
end function
Sub digits(t As String,x As long,y As long,clr As Ulong,sz As long,img As Any Pointer=0)
        x=x-2*sz
        dim as single s=any,c=any
        #macro thickline(x1,y1,x2,y2)
             s=(y1-y2)/10
             c=(x2-x1)/10
            Line img,(x1-s,y1-c)-(x2+s,y2+c),clr,bf
        #endmacro
        #macro display(_a,_b,_c,_d,_e,_f,_g)
        x=x+2*sz
        If _a=1 Then :thickline(x,y,(x+sz),y):End If
        If _b=1 Then :thickline((x+sz),y,(x+sz),(y+sz)):End If
        If _c=1 Then :thickline((x+sz),(y+sz),(x+sz),(y+2*sz)):End If 
        If _d=1 Then :thickline((x+sz),(y+2*sz),x,(y+2*sz)):End If
        If _e=1 Then :thickline(x,(y+2*sz),x,(y+sz)):End If
        If _f=1 Then :thickline(x,(y+sz),x,y):End If
        If _g=1 Then :thickline(x,(y+sz),(x+sz),(y+sz)):End If
        #endmacro
        For z As long=0 To Len(t)-1
            Select Case As Const t[z]
            Case 48 :display(1,1,1,1,1,1,0)             '"0"
            Case 49 :display(0,1,1,0,0,0,0)             '"1"
            Case 50 :display(1,1,0,1,1,0,1)             '"2"
            Case 51 :display(1,1,1,1,0,0,1)             '"3"
            Case 52 :display(0,1,1,0,0,1,1)             '"4"
            Case 53 :display(1,0,1,1,0,1,1)             '"5"
            Case 54 :display(1,0,1,1,1,1,1)             '"6"
            Case 55 :display(1,1,1,0,0,0,0)             '"7"
            Case 56 :display(1,1,1,1,1,1,1)             '"8"
            Case 57 :display(1,1,1,1,0,1,1)            '"9"
            Case 58                                     '":"                   
                Circle((x+2*sz),(y+sz/2)),(sz/5),clr,,,,f
                Circle((x+2*sz),(y+1.5*sz)),(sz/5),clr,,,,f
                x=x+sz 
            Case 45 :display(0,0,0,0,0,0,1)              '"-"                       
            Case 46                                      '"."                       
                Circle((x+2*sz),(y+1.9*sz)),(sz/5),clr,,,,f
                x=x+sz 
            Case 32                                      '" "
                x=x+sz 
            End Select
        Next z
    End Sub  
dim as long count
dim as long low, high,x=0,y=10
dim as string number
screen 20
low=0 : high=60000
count=0
for i as long = low to high
	if i<>6 andalso i<>9 then
	   number=str(i)
	   if instr(number, any "347")=0 then
		  if i=reverselong(i) then
			  x+=1
			 
			 digits(number,x*100,y,7,7)
			 count+=1
			
		  end if
	   end if
	   if x>8 then x=0:y+=30
	end if
next
print
locate 45
print "number of strobogrammatic numbers between ";low;" and ";high;" is ";count
sleep
Richard
Posts: 3096
Joined: Jan 15, 2007 20:44
Location: Australia

Re: Squares

Post by Richard »

Edited to conform with conventions.

Code: Select all

'=======================================================================
' Strobogrammatic number generator.
'   Generates only the LHS pattern of the number, then makes the RHS fit.
'   If middle digit is self symmetric then an odd digit count is possible.
'   Leading zeros are prohibited, so trailing zeros cannot exist either.
'=======================================================================

Const As Integer min = 0, max = 60000
Const As Integer n = 3  ' half the maximum number of digits

'-----------------------------------------------------------------------
' use a base 7 counter to avoid ever dealing with symbols 3, 4 or 7
Dim t( 0 To 6 ) As Byte = { 0, 1, 2, 5, 6, 8, 9 } ' forward translate symbol
Dim r( 0 To 6 ) As Byte = { 0, 1, 2, 5, 9, 8, 6 } ' reverse translate symbol
Dim s( 0 To 6 ) As Byte = { 1, 1, 1, 1, 0, 1, 0 } ' flag self centred symbols
Dim As Byte d( 1 To n ) ' counter for the lhs digits
Dim As String txt   ' output string

'-----------------------------------------------------------------------
Dim As Integer i, b = Asc( "0" )  ' offset translate tables to ascii code
For i = 0 To 6
    t( i ) += b
    r( i ) += b
Next i

#Macro total
v = Valint(txt)
If ( v >= min ) And  ( v <= max ) Then
    count += 1
    Print v,
End If
#Endmacro

'-----------------------------------------------------------------------
' output format for;   odd { m...1...m },   and;  even { m...11...m }.
'-----------------------------------------------------------------------
Dim As Integer v, carry, count, m = 1 ' active digits in radix 7 counter

Print 0,    ' fake the zero special case to avoid leading zero detection
count = 1

Do
    ' first report the present state
    If d(m) Then  ' detect if leading zero
        '----------------------------------------------
        ' odd length only if middle digit is symmetric
        If s( d(1) ) Then
            txt = Chr( t( d(1) ) )
            For i = 2 To m
                txt = Chr( t( d(i) ) ) +  txt + Chr( r( d(i) ) )
            Next i
            total
        End If
        '----------------------------------------------
        txt = ""   ' even length is always possible
        For i = 1 To m
            txt = Chr( t( d(i) ) ) + txt + Chr( r( d(i) ) )
        Next i
        total
        '----------------------------------------------
    End If
    
    ' increment counter to next state
    For i = 1 To m
        carry = 0
        d(i) += 1
        If d(i) = 7 Then 
            d(i) = 0
            carry = 1
        Else
            Exit For    ' no carry yet
        End If
    Next i
    
    ' special cases set carry
    If carry = 1 Then   ' extend the accumulator
        m += 1
        If m > n Then 
            Exit Do     ' end of entire search range
        End If
    End If
    
    '--------------------------------------------------
Loop Until Len( Inkey )

Print
Print
Print " Strobogrammatic numbers between"; min; " and"; max; " is"; count
Print

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

Re: Squares

Post by albert »

Heres another attempt at data compression that failed to compress..

It takes an int(sqr(number)) and tries to find the fraction of the original sqr(number)
At a length of 15 digit stepping , it requires 8 decimal places , to recreate the original number.
So in the universe of data , theres only 8 digits of unique values possible. 99,999,999 possible..
And you can count out , most all the values , less than 8 digits long. so that leaves like 9,999,999 possible???

I found that *.mp3 files have the most unique fractions.. like 90+% of the total nums of steps..

it takes quite a while to run, so open it on a small file , like a bas or txt file..less than 10,000 bytes...

Code: Select all

#define WIN_INCLUDEALL
#Include "windows.bi"
#Include "File.bi"

declare sub getfilename()
declare sub compress()
declare sub decompress()
declare function MultiBase_Number( byval Number as ulongint , byval Number_Base as ulongint ) as string

dim shared as string file , extension , file_data , bytes , file_name
dim as ubyte value1

Dim As MSG msg
Dim shared As HWND hWnd

screen 19

getfilename()

if FileExists(file) then
    for a as ulongint = len(file)-1 to 0 step -1
        bytes=chr(file[a])
        if bytes = "\" then file_name = mid(file,a+2):exit for
    next
   
    print file_name

    file_data = ""
    open file for binary as #1
        do
            get #1,,value1
            file_data = file_data + chr(value1)
        loop until eof(1)
    close #1
   
    if extension = ".BDC" then
        print
        print "DECOMPRESSING:" , len(file_data)
        decompress()
    else
        print
        print "COMPRESSING:" , len(file_data)
        extension=".BDC"
        compress()
    end if

end if
'===============================================================================
'===============================================================================
'END Program
'===============================================================================
'===============================================================================
END

'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
sub compress()
   
    dim as double time1 , time2
   
    time1 = timer
        
        dim as longint vals = 0
        dim as string inputs = ""
        for a as longint = 1 to len(file_data) step 1
            vals = asc(mid(file_data,a,1))
            inputs+= right("000"+str(vals),3)
        next
        
        dim as string outputs = ""
        
        redim as string num(1)
        dim as longint val1 = 0
        dim as longint val2 = 0
        dim as double count = 0
        dim as double places = 0
        for a as longint = 1 to len(inputs) step 15
            val1 = valulng(mid(inputs,a,15))
            val2 = int(sqr(val1))
            count = 0
            places=.1
            if val1 > 0 then
                do
                    do
                        count+=places
                    loop until int((val2 + count)^2) > val1
                    
                    if int((val2 + count)^2) > val1 then 
                        count-=places
                        places/=10
                    end if
                    
                loop until int((val2 + count)^2) = val1
            end if
            
            count = val(left(str(count),10))
            
            for n as longint = 1 to ubound(num)
                if num(n) = str(count) then goto done
            next
            num(ubound(num)) = str(count)
            redim preserve num(ubound(num)+1)
            done:
            
            print val1 , int((val2+count)^2) , val2 , count
            
            'if a mod 10000 = 1 then 
            '    'print val1 , int((val2+count)^2) , val2 , count
            '    print
            '    print "sleeping" , ubound(num) , a\15 ; " out of " ; len(inputs)\15
            '    sleep 5000
            'end if
            
        next
        if num(ubound(num)) = "" then redim preserve num(ubound(num)-1)
        
        print  
        print "unique fractions = " ; ubound(num) ; " out of " ; len(inputs) \ 15 ; " numbers."
        'print " total out = " ; (ubound(num)*8) + ((len(inputs)\15)*8)
        '
        'print "len out = " ; len(outputs) / 8
        'print outputs
        
        
    time2 = timer
   
    'print "size of dict = " ; (dict_total-spaces) ; " " ; "total_out = " ; outs_total
    'print "Total size   = " ; (dict_total-spaces) + outs_total
    'print "number of dicts = " ; ubound(dict)
    print
    print "Time = " ; time2 - time1
    print
    print file_name ; "  " ; len(file_data)
    print
   
   
    sleep
   
    'sleep
    '    open file_name+".BDC" for output as #1
    '        print #1,bytes_out
    '    close #1
    'sleep
       
           
end sub
'===============================================================================
'===============================================================================
'Decompress
'===============================================================================
'===============================================================================
sub decompress()
'not written yet
end sub
'===============================================================================
'===============================================================================
'Get File Name
'===============================================================================
'===============================================================================
sub getfilename()
        dim ofn as OPENFILENAME
        dim filename as zstring * MAX_PATH+1
       
        with ofn
                .lStructSize            = sizeof( OPENFILENAME )
                .hwndOwner              = hWnd
                .hInstance              = GetModuleHandle( NULL )
                .lpstrFilter            = strptr( !"All Files, (*.*)\0*.*\0\0" )
                .lpstrCustomFilter      = NULL
                .nMaxCustFilter         = 0
                .nFilterIndex           = 1
                .lpstrFile              = @filename
                .nMaxFile               = sizeof( filename )
                .lpstrFileTitle         = NULL
                .nMaxFileTitle          = 0
                .lpstrInitialDir        = NULL
                '.lpstrTitle            = @"File Open Test"
                .lpstrTitle             = @"File to Compress/Decompress"
                .Flags                  = OFN_EXPLORER 'or OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST
                .nFileOffset            = 0
                .nFileExtension         = 0
                .lpstrDefExt            = NULL
                .lCustData              = 0
                .lpfnHook               = NULL
                .lpTemplateName         = NULL
        end with
       
        if( GetOpenFileName( @ofn ) = FALSE ) then
            file = ""
            return
        else
            file = filename
            extension = right$(filename,4)
    end if

end sub

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

Re: Squares

Post by albert »

@Dodicat

Do you have a program to factorize numbers?
Locked