Squares
Re: Squares
@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
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..
Re:
Yea Richard.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?
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
Re: Squares
@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
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?
Re: Squares
Hi Albert.
just working on 10000
(But I don't think this is what you mean)
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
Re: Squares
@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 %
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
Re: Squares
@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.
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
Re: Squares
This only holds true, in FBC 32-bit.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.
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)
Data Compressor
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..
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
Re: Squares
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.
(!!~~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.
strobogrammatic numbers
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.
Re: Squares
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)
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
Re: Squares
@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
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
Re: Squares
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
'=======================================================================
Re: Squares
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...
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
Re: Squares
@Dodicat
Do you have a program to factorize numbers?
Do you have a program to factorize numbers?