That's fantastic looking !!!
ditto
That's fantastic looking !!!
Code: Select all
'Uses libz.a, FreeBasic static library file.
'http://sourceforge.net/projects/fbc/files/Binaries%20-%20Windows/Libraries/
'The required download is: FB-win32-zlib-1.2.7.zip
'put libz.a into your Freebasic lib folder
'=======================================================
'Call this file compress.bas
'COMPILE TO EXE
'USE DRAG AND DROP TO compress.exe to produce a zlib compressed file
dim as string file
file=command(1)
dim shared as integer f
#include once "zlib.bi"
declare Sub string_split(s_in As String,char As String,result() As String)
if len(file)=0 then
print "no input file"
sleep
end
end if
if instr(file,"ComPressed_") then
if instr(file,"UN_")=0 then
redim as string temp(0)
string_split(file,"\",temp())
print temp(ubound(temp)) & " has already been compressed by zlib"
sleep
end
end if
end if
print "PLEASE WAIT ..."
Sub string_split(s_in As String,char As String,result() As String)
Dim As String s=s_in,var1,var2
Dim As Long n,pst
#macro split(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
Endif
Redim preserve result(1 To 1+n-((Len(var1)>0)+(Len(var2)>0)))
result(n+1)=var1
#endmacro
Do
split(s,char,var1,var2):n=n+1:s=var2
Loop Until var2=""
Redim preserve result(1 To Ubound(result)-1)
End Sub
function getfile2(file as string) as string
f=freefile
Open file For Binary Access Read As #f
Dim As String text
If Lof(1) > 0 Then
text = String(Lof(f), 0)
Get #f, , text
End If
Close #f
return text
end function
var text=getfile2(file)
dim as integer stringlength,destinationlength
stringlength=len(text)
destinationlength = compressBound(stringlength)
Dim As UByte Ptr source = Allocate(stringlength)
Dim As UByte Ptr destination = Allocate(destinationlength)
source=@text[0]
var mistake=compress(destination, @destinationlength, source, stringlength)
redim as string temp()
string_split(file,"\",temp())
var filename=mid(temp(ubound(temp)),len(ubound(temp))-3)
print filename & " Compressed"
print
print filename & " Length = ";len(text)
print
print filename & " Compressed length = ";destinationlength
print
print "Compression = ";destinationlength/len(text)
if mistake <>0 then print "There was an error"
dim as string compressed=string(destinationlength,0)
for n as integer=0 to destinationlength-1
compressed[n]=destination[n]
next n
f=freefile
open "ComPressed_"+filename for output as #f
print #f,stringlength &"|";
print #f,compressed
close #f
print "The compressed file is "&"ComPressed_"+filename
print"Press any key"
'delete[] destination
'delete[] source
sleep
Code: Select all
'Uses libz.a, FreeBasic static library file.
'http://sourceforge.net/projects/fbc/files/Binaries%20-%20Windows/Libraries/
'The required download is: FB-win32-zlib-1.2.7.zip
'put libz.a into your Freebasic lib folder
'===========================================================
'call this file uncompress.bas
'COMPILE TO EXE
'USE DRAG AND DROP ON uncompress.exe to uncompress a zlib compressed file.
dim as string file
dim shared as integer f
dim shared as integer passed_length
file=command(1)
#include once "zlib.bi"
declare Sub string_split(s_in As String,char As String,result() As String)
if len(file)=0 then
print "no input file"
sleep
end
end if
'if instr(file,"ComPressed_")=0 or instr(file,"UN_ComPressed")<>0 then
'if left(file,11)<>"ComPressed_" then
redim as string temp(0)
string_split(file,"\",temp())
if left(temp(ubound(temp)),11)<>"ComPressed_" then
print temp(ubound(temp)) & " hasn't been compressed by zlib"
sleep
end
end if
print "PLEASE WAIT ..."
Sub string_split(s_in As String,char As String,result() As String)
Dim As String s=s_in,var1,var2
Dim As Long n,pst
#macro split(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End if
Redim preserve result(1 To 1+n-((Len(var1)>0)+(Len(var2)>0)))
result(n+1)=var1
#endmacro
Do
split(s,char,var1,var2):n=n+1:s=var2
Loop Until var2=""
Redim preserve result(1 To Ubound(result)-1)
End Sub
function getfile2(file as string) as string
dim as string var1,var2
dim as integer pst
#macro splice(stri,char,var1,var2)
pst=Instr(stri,char)
var1="":var2=""
If pst<>0 Then
var1=Mid(stri,1,pst-1)
var2=Mid(stri,pst+1)
Else
var1=stri
End if
#endmacro
f=freefile
Open file For Binary access read As #f
'Dim As Integer count
Dim As String text
If Lof(f) > 0 Then
text = String(Lof(f), 0)
Get #f, , text
End If
Close #f
splice(text,"|",var1,var2)
text=var2
passed_length=valint(var1)
return text
end function
var text=getfile2(file)
dim as integer stringlength,destinationlength
stringlength=len(text)
destinationlength =passed_length
Dim As UByte Ptr source = Allocate(stringlength)
Dim As UByte Ptr destination =Allocate(destinationlength)
source=@text[0]
var mistake=uncompress(destination,@destinationlength, source, stringlength)
if mistake<>0 then print "There was an error":sleep:end
dim as string uncompressed
'Build the uncompressed string
uncompressed=string(destinationlength,0)
For i As Integer = 0 To destinationlength- 1
uncompressed[i]=(destination[i])
Next
var filename=mid(temp(ubound(temp)),len(ubound(temp))-3)
f=freefile
open "UN_"+filename for output as #f
print #f,uncompressed
close #f
print "The UNcompressed file is "&"UN_"+filename
print"Press any key"
'delete[] destination
'delete[] source
sleep
Code: Select all
'abstract trig art #584
'Written if FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/-45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/-180
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius=175
dim as double xctr=xres/2
dim as double yctr=yres/2
for deg1 = 0 to 90 step .1
c1=cos(deg1*rad1)
s1=sin(deg1*rad1)
x1=radius*c1-atn(log(tan(deg2*rad2*c2)/57))
y1=radius*s1-atn(log(tan(deg2*rad2*c2)/57))
for deg2 = 0 to 360 step 1
c2 = cos(deg2*rad2*c1+deg2)
s2 = sin(deg2*rad2*s1+deg2)
x2=radius*c2^2-atn(log(tan(deg2*rad2*c2)/57))^10
y2=radius*s2^2-atn(log(tan(deg2*rad2*c2)/57))^10
pset( xctr+ (y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg2
pset( xctr+ (y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+-(y1+y2) ) , deg2
next
sleep 1
next
SLEEP
END
Code: Select all
'abstract trig art #585
'Written if FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/-45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/-180
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius=175
dim as double xctr=xres/2
dim as double yctr=yres/2
for deg1 = 45 to 90 step .1
c1=cos(deg1*rad1)
s1=sin(deg1*rad1)
x1=radius*c1-atn(log(tan(deg2*rad2*c2)/57))
y1=radius*s1-atn(log(tan(deg2*rad2*c2)/57))
for deg2 = 0 to 720 step 1
c2 = cos(deg2*rad2*c1+deg2)
s2 = sin(deg2*rad2*s1+deg2)
x2=radius*c2^2-atn(log(tan(deg2*rad2*c2)/57))^10
y2=radius*s2^2-atn(log(tan(deg2*rad2*c2)/57))^10
pset( xctr+ (y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg2
pset( xctr+ (y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+-(y1+y2) ) , deg2
next
sleep 1
next
SLEEP
END
Code: Select all
Type V3
As Single x,y,z
As Uinteger col
Declare Function rotate(As V3,As V3,As V3) As V3
Declare Function apply_perspective(As V3) As V3
End Type
Function V3.rotate(c As V3,angle As V3,scale As V3=Type<V3>(1,1,1)) As V3
Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
Dim As Single dx=this.x-c.x,dy=this.y-c.y,dz=this.z-c.z
Return Type<V3>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
(scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
(scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z,this.col)
End Function
Function V3.apply_perspective(eyepoint As V3) As V3
Dim As Single w=1+(this.z/eyepoint.z)
Return Type<V3>((this.x-eyepoint.x)/w+eyepoint.x,(this.y-eyepoint.y)/w+eyepoint.y,(this.z-eyepoint.z)/w+eyepoint.z,this.col)
End Function
Function length(v1 As V3,v2 As V3) As Single
Return Sqr((v1.x-v2.x)*(v1.x-v2.x)+(v1.y-v2.y)*(v1.y-v2.y)+(v1.z-v2.z)*(v1.z-v2.z))
End Function
Sub Qsort(array() As V3,begin As Integer,Finish As Uinteger)
Dim As Integer i=begin,j=finish
Dim As V3 x =array(((I+J)\2))
While I <= J
While array(I).z > X.z:I+=1:Wend
While array(J).z < X.z:J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J > begin Then Qsort(array(),begin,J)
If I < Finish Then Qsort(array(),I,Finish)
End Sub
'=================================================================
#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))\((b)-(a))+(c)
Dim As Integer num=25000
Redim As V3 a(1 To num),r(1 To num)
For n As Integer=1 To num
With a(n)
.x=IntRange(300,500)
.y=IntRange(200,400)
.z=IntRange(-100,100)
var d=length(a(n),Type<V3>(400,300,0))
.col=Rgb(255,255-d,d/2)
End With
Next n
Screenres 800,600,32
color ,rgb(255,255,255)
Dim As V3 ang,centre=Type<V3>(400,300,0),eye=Type<V3>(400,300,500)
Dim As Single sz=1,k=1
Do
sz=sz+.1*k
If sz>2 Then k=-k
If sz<1 Then k=-k
ang=Type<V3>(ang.x+.01,ang.y+.01,ang.z+.01)
For n As Integer=Lbound(a) To Ubound(a)
r(n)=a(n).rotate(centre,ang,Type<V3>(1,1,sz))
r(n)=r(n).apply_perspective(eye)
Next n
Qsort(r(),Lbound(r),Ubound(r))
Screenlock
Cls
For n As Integer=Lbound(r) To Ubound(r)
var rad=map(-100,100,r(n).z,4,2)
Circle(r(n).x,r(n).y),rad,r(n).col,,,,f
Next n
Screenunlock
Sleep 1,1
Loop Until Len(Inkey)
Code: Select all
'abstract trig art #586
'Written in FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/-45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/-45
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius=150
dim as double xctr=xres/2
dim as double yctr=yres/2
for deg1 = 0 to 90 step 1
c1=cos(deg1*rad1+deg1^50)
s1=sin(deg1*rad1+deg1^50)
x1=radius*c1
y1=radius*s1
for deg2 = 0 to 720 step .1
c2 = cos(deg2*rad2+deg1)
s2 = sin(deg2*rad2+deg1)
x2=radius*c2-atn(log(tan(deg2*rad2*c2)/57))^10
y2=radius*s2-atn(log(tan(deg2*rad2*c2)/57))^10
pset( xctr+ (y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg2
pset( xctr+ (y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+-(y1+y2) ) , deg2
next
sleep 1
next
SLEEP
END
Code: Select all
'abstract trig art #587
'Written if FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/-45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/-45
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius=150
dim as double xctr=xres/2
dim as double yctr=yres/2
for deg1 = 0 to 90 step 1
c1=cos(deg1*rad1+deg1^50)
s1=sin(deg1*rad1+deg1^50)
x1=radius*c1
y1=radius*s1-atn(log(tan(deg2*rad2*c1)/57))^10
for deg2 = 0 to 720 step .1
c2 = cos(deg2*rad2+deg1^10)
s2 = sin(deg2*rad2+deg1^10)
x2=radius*c2'-atn(log(tan(deg2*rad2*c2)/57))^10
y2=radius*s2-atn(log(tan(deg2*rad2*c2)/57))^10
pset( xctr+ (y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+ (x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+ (y1+y2) ) , deg2
pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg2
pset( xctr+ (y1+y2) , yctr+-(x1+x2) ) , deg2
pset( xctr+ (x1+x2) , yctr+-(y1+y2) ) , deg2
next
sleep 1
next
SLEEP
END
Code: Select all
'abstract trig art #588
'Written if FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/-45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/-45
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius=250
dim as double xctr=xres/2
dim as double yctr=yres/2
for deg1 = 0 to 360 step .1
c1=cos(deg1*rad1)
s1=sin(deg1*rad1)
x1=radius*c1^50
y1=radius*s1^50
for deg2 = 0 to 90 step 5
c2 = cos(deg2*rad2+deg2*rad2)
s2 = sin(deg2*rad2+deg2*rad2)
x2=radius*c2*c1*atan2(c1,c2)*-(atn(deg2*rad2*s1))
y2=radius*s2*s1*atan2(s1,s2)*-(atn(deg2*rad2*c1))
pset( xctr++(y1+x2) , yctr++(x1+y2) ) , 9
pset( xctr++(x1+y2) , yctr++(y1+x2) ) , 9
pset( xctr+-(y1+x2) , yctr+-(x1+y2) ) , 9
pset( xctr+-(x1+y2) , yctr+-(y1+x2) ) , 9
next
sleep 1
next
SLEEP
END
Code: Select all
'abstract trig art #589
'Written if FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/-45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/-45
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius=250
dim as double xctr=xres/2
dim as double yctr=yres/2
for deg1 = 0 to 360 step .1
c1=cos(deg1*rad1)
s1=sin(deg1*rad1)
x1=radius*c1^50
y1=radius*s1^50
for deg2 = 0 to 180 step 5
c2 = cos(deg2*rad2+deg2*rad2*2)
s2 = sin(deg2*rad2+deg2*rad2*2)
x2=radius*c2*c1^2
y2=radius*s2*s1^2
pset( xctr++(y1+x2) , yctr++(x1+y2) ) , 9
pset( xctr++(x1+y2) , yctr++(y1+x2) ) , 9
pset( xctr+-(y1+x2) , yctr+-(x1+y2) ) , 9
pset( xctr+-(x1+y2) , yctr+-(y1+x2) ) , 9
next
sleep 1
next
SLEEP
END
Users browsing this forum: Stonemonkey and 3 guests