After reading some guff about compression algorithms, I decide to ignore all the gobbledegook and follow a true compressor (Robert Boyle), who simply called compression of air -- the natural spring of air--, and no doubt, If he was here now, he would call computer files and all their zip, rar, e.t.c. counterparts -- the natural spring of data.
Anyway, the weather here is improving each day as the seasons grind on, so, add some old harmony to the new Spring.
Code: Select all
Type _point
As Single x,y,z
As Ulong col
End Type
Dim Shared im As Any Pointer
Dim Shared As Integer xres,yres
Screen 19,32,,64
Locate 10,10
Print "Please wait . . ."
Screeninfo xres,yres
im=Imagecreate(xres,yres)
Function rotatepoint3d(Byval pivot As _point,_
Byval first As _point,_
Byval angle As _point,_
Byval dilator As Single=1) As _point
#macro mv(m1,v,ans)
For i As Long=1 To 3
s=0
For k As Long = 1 To 3
s=s+m1(i,k)*v(k)
Next k
ans(i)=s
Next i
#endmacro
Static Pi As Single = 4*Atn(1)
Dim angle_radians As _point
Static pivot_vector(1 To 3) As Single
Dim s As Single
angle_radians.x=(Pi/180)*angle.x
angle_radians.y=(Pi/180)*angle.y
angle_radians.z=(Pi/180)*angle.z
pivot_vector(1)=(first.x-pivot.x)*dilator
pivot_vector(2)=(first.y-pivot.y)*dilator
pivot_vector(3)=(first.z-pivot.z)*dilator
Static Rx(1 To 3,1 To 3) As Single
Static Ry(1 To 3,1 To 3) As Single
Static Rz(1 To 3,1 To 3) As Single
'rotation matrices about the three axix
Rx(1,1)=1:Rx(1,2)=0:Rx(1,3)=0
Rx(2,1)=0:Rx(2,2)=Cos(angle_radians.x):Rx(2,3)=-Sin(angle_radians.x)
Rx(3,1)=0:Rx(3,2)=Sin(angle_radians.x):Rx(3,3)=Cos(angle_radians.x)
Ry(1,1)=Cos(angle_radians.y):Ry(1,2)=0:Ry(1,3)=Sin(angle_radians.y)
Ry(2,1)=0:Ry(2,2)=1:Ry(2,3)=0
Ry(3,1)=-Sin(angle_radians.y):Ry(3,2)=0:Ry(3,3)=Cos(angle_radians.y)
Rz(1,1)=Cos(angle_radians.z):Rz(1,2)=-Sin(angle_radians.z):Rz(1,3)=0
Rz(2,1)=Sin(angle_radians.z):Rz(2,2)=Cos(angle_radians.z):Rz(2,3)=0
Rz(3,1)=0:Rz(3,2)=0:Rz(3,3)=1
Static new_pos(1 To 3) As Single
Static temp1(1 To 3) As Single
Static temp2(1 To 3) As Single
mv (Rx,pivot_vector,temp1)
mv (Ry,temp1,temp2)
mv (Rz,temp2,new_pos)
new_pos(1)+=pivot.x
new_pos(2)+=pivot.y
new_pos(3)+=pivot.z
Dim As _point xyz=Type(first.x-new_pos(1),first.y-new_pos(2),first.z-new_pos(3))
Return Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)' pt
Dim As _point pt=Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)
Return Type(first.x-xyz.x,first.y-xyz.y,first.z-xyz.z)' pt
End Function
Function apply_perspective(p As _point,eye As _point,w As Single) As _point
Dim As _point rv
rv.x=(p.x-eye.x)/w+eye.x:rv.y=(p.y-eye.y)/w+eye.y:rv.z=(p.z-eye.z)/w+eye.z
Return rv
End Function
Function Filter(Byref tim As Ulong Pointer,_
Byval rad As Single,_
Byval destroy As Integer=1,_
Byval fade As Integer=0) As Ulong Pointer
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
If fade<0 Then fade=0:If fade>100 Then fade=100
Type p2
As Integer x,y
As Ulong col
End Type
#macro _ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*4
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*4
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As Integer=-ymin To ymax
For x1 As Integer=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
If fade=0 Then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
Else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
End If
#endmacro
Dim As Single fd=map(0,100,fade,1,0)
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As Integer pitch
Dim As Any Pointer row
Dim As Ulong Pointer pixel
Dim As Ulong col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As Integer=0 To (_y)-1
For x As Integer=0 To (_x)-1
_ppoint(x,y,col)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As Integer ar,ag,ab
Dim As Integer xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As Integer=0 To _y-1
For x As Integer=0 To _x-1
average()
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
Next x
Next y
If destroy Then Imagedestroy tim: tim = 0
Function= im
End Function
Sub Magnify()
#define resetwheel(w,fl) fl=w
#define wheel(w,f) w-f
Dim As Long mx,my,mw,button:Getmouse mx,my,mw,button
Static As Long flag,pmw
mw=Abs(mw/2)
Line(mx-40,my-40)-(mx+40,my+40),Rgb(0,0,0),B':exit sub
If button=1 Then resetwheel(mw,flag)
Dim As Ulong array(1 To 6561),count
pmw=wheel(mw,flag)
If pmw<=1 Then Exit Sub
For z As Long=1 To 2
For x As Long=mx-40 To mx+40
For y As Long=my-40 To my+40
count+=1
If z=1 Then
Var c=Point(x,y) 'needed to magnify an alpha screen
Var r =Cast(Ubyte Ptr,@c)[2]
Var g =Cast(Ubyte Ptr,@c)[1]
Var b =Cast(Ubyte Ptr,@c)[0]
Var al=Cast(Ubyte Ptr,@c)[3]
array(count)=Rgba(r,g,b,255)
End If
If z=2 Then
Var NewX=pmw*(x-mx)+mx:Var NewY=pmw*(y-my)+my
Line(newx-pmw/2,newy-pmw/2)-(newx+pmw/2,newy+pmw/2),array(count),bf
End If
Next y
Next x
count=0
Next z
Line(mx-pmw*40,my-pmw*40)-(mx+pmw*40,my+pmw*40),5,B
End Sub
Sub cloud(x As Long, y As Long,length As Long=100,Alpha As Long=105, Zoom As Single = 0,im As Any Pointer=0)
Dim As Long rr=255
Dim As Long bb=255
Dim As Long gg=255
Static As Double pi=3.14159
#define mp(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
If Length<=1 Or Alpha<=1 Then Exit Sub
Dim As Single rnded = -pi+Rnd*1*pi/2
Dim As Single rnded2 = -pi+Rnd*-3*pi
If Alpha<25 Then
For i As Long = 0 To 255-Alpha Step 100
Var c=mp((0),(500),y,0,100)
Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded*PI/3),y+Length/6+length*Sin(-pi/2+rnded*PI/3)),Rgba(Rr-c,Gg-c,Bb-c,Alpha)
Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded2*PI/3),y+Length/6+length*Sin(pi/2+rnded2*PI/3)),Rgba(Rr-c,Gg-c,Bb-c,Alpha)
Next
End If
cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded*PI/3),(Zoom/2)+y+length*Sin(-pi/2+rnded*PI/3),length/1.4,Alpha/1.2,Zoom,im)
cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi/2+rnded2*PI/3),length/1.4,Alpha/1.2,Zoom,im)
cloud(-(Zoom/2)+x+length*Cos(pi/3+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi+rnded2*PI/3),length/1.4,Alpha/2,Zoom,im)
End Sub
Sub trees()
Type v2
As Single x,y
End Type
Dim As Long rotx,roty
#define rr(first,last) Rnd * (last - first) + first
#macro rotate(pivotx,pivoty,px,py,a,scale)
rotx=scale*(Cos(a*.0174533)*(px-pivotx)-Sin(a*.0174533)*(py-pivoty))+pivotx
roty=scale*(Sin(a*.0174533)*(px-pivotx)+Cos(a*.0174533)*(py-pivoty))+pivoty
#endmacro
#macro turnline(piv,p1,p2,ang,col,d)
Scope
rotate(piv.x,piv.y,p1.x,p1.y,ang,d)
Var rot1=Type<v2>(rotx,roty)
rotate(piv.x,piv.y,p2.x,p2.y,ang,d)
Var rot2=Type<v2>(rotx,roty)
Line im,(rot1.x,rot1.y)-(rot2.x,rot2.y),col
End Scope
#endmacro
Dim As v2 v1,v2,piv
Dim As Ulong treecol
Dim As Double pivx,pivy,pivz,l,k,d
Dim As Long rd,g,b
For m As Double=0 To 50 Step 5
Randomize m
For n As Double=200-(m+rr(2,20)) To 990+m Step rr(3,9)
Randomize n^2
l=rr(2,11)
k=rr(1,5)
piv=Type(n,.8*yres+20*(1-Sin(.01*(n-m*5-k+40-200))))
Line im,(piv.x,piv.y)-(piv.x+rr(-2,5),piv.y+8),Rgb((100),(35),37)
Var cc=rr(1,40)
For a As Double=90 To 450 Step 7
Randomize a
Var shader=rr(1,6)
rd=20+shader+cc
g=150+shader:If g>40 Then g=g-40
b=20+shader:If b>20 Then b=b-20
treecol=Rgb(rd/2,g/2,b/2)
For a2 As Double=0 To l Step .3
If a>270 Then shader=-shader
treecol=Rgb(rd/2,(g-a2*shader)/2,b/2)
v1=Type(piv.x-a2,piv.y)
v2=Type(piv.x-l,piv.y)
turnline(piv,v1,v2,a,treecol,1)
Next a2
Next a
Next n
Next m
End Sub
Sub backdrop() 'hills/trees
#macro paintsketch(_function,minx,maxx,miny,maxy,r,g,b,alp)
For x As Double=minx To maxx Step (maxx-minx)/10000
Var x1=(xres)*(x-minx)/(maxx-minx)
Var y1=(yres)*(_function-maxy)/(miny-maxy)
gr=(lasty-y1)*1000
lasty=y1
If gr>g Then gr=g
Line im,(x1,yres)-(x1,y1),Rgba(r,g-gr,b,alp)
Next x
#endmacro
Dim As Double lasty,gr
paintsketch(.8*yres+20*Sin(.01*(x-200)),xres,0,yres,0,50,100,0,255)
im=filter(im,1)
trees()
End Sub
Sub background
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
For y As Long=0 To yres
Var rd=map(0,yres,y,0,200)
Var bl= map(0,yres,y,250,200)
Var gr=map(0,yres,y,0,200)
Line im,(0,y)-(xres,y),Rgb(rd,gr,bl)
Next y
cloud(100,340,150/2,250,1,im)
cloud(300,340,150/2,250,1,im)
cloud(600,340,150/2,250,1,im)
im=filter(im,2)
backdrop
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Sub birds
Static As Single span=1,k=1,w
Static As Single cx,cy,dslug
Dim As Long dist=100,pix
Static As Double pi=4*Atn(1)
#macro dot(rad,slug)
cx=150+xres/3+(5)*400/yres*rad*Cos(slug)
cy=.17*yres+(50)*yres/400+rad*Sin(slug)
#endmacro
span=span+.15*k
If span>5 Then k=-k
If span<1 Then k=-k
Do
dist-=10
pix=-10
If (dslug)>2*pi Then dslug=0
dot(yres/6,(dslug+.2*dist))
w=cy/100
Do
dslug=dslug+.000002
pix=pix+1
Circle(cx,cy),w/2,Rgb(200,200,0),,,,f
Line(cx,cy)-(cx+w*(span),cy+(span)-3),Rgb(180,180,180)
Line(cx,cy)-(cx-w*(span),cy+(span)-3),Rgb(255,255,255)
Loop Until pix>100
Loop Until dist<10
End Sub
#macro dot(rad,slug)
xdot=xres/2+2*rad*Cos(slug)
ydot=yres/10+rad*Sin(slug)
#endmacro
#define r(f,l) rnd*(l-f)+f
Dim As _point piv
piv.x=400:piv.y=00: piv.z=00
Dim As _point ang,np,eye,cp
eye.x=xres/2:eye.y=yres/2:eye.z=0
Dim As Single pi=4*Atn(1),rad,ep=1.5,flag,count,t,k=1,k2=1,dslug
Dim As String i
Dim As Long xdot,ydot
Dim As Long blades=8000
Dim Shared As _point gr(1 To blades)
'set array
For z As Long=1 To blades
gr(z).x=r(-100,xres+100)
gr(z).y=r(.9*yres,yres+50)
gr(z).col=r(50,250)
Next z
Dim As Single gl, fr
Dim As Long fps
background
Do
dslug=dslug+.01
If dslug>2*pi Then dslug=0
count=count+k*.01
If count>=.999 Then k=-k
If count<=-.999 Then k=-k
Screenlock
Cls
Put (0,0),im,Pset
if ep<9 then birds
Draw String(20,20),"Framerate " &fps
dot(200,dslug)
For z As Long=1 To blades
gl=(.1-.01)*(gr(z).y-.9*yres)/(yres+50-.9*yres)+.01
Line (gr(z).x,gr(z).y)-(gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)),Rgb(50,gr(z).col,0)
If z Mod 20 =0 Then
fr=(6-2)*(gr(z).y-.9*yres)/(yres+50-.9*yres)+2
Circle (gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)+1.1*fr),fr-2,Rgb(250,250,0),,,,f
Circle (gr(z).x+gl*(xdot-gr(z).x),gr(z).y+gl*(ydot-gr(z).y)),fr,Rgb(200,0,r(50,200)),,,,f
End If
Next z
i=Inkey
ep=ep+k2*.01
If ep>15 Then k2=-k2
If ep<1.5 Then k2=-k2
t=t+Asin(count)
ang.z=t-60:ang.y=(t-60)*1.1:ang.x=(t+60)/50
For z As Single=0 To 10*360 Step 1
cp.x=xres/2+.1*z*Cos(z*pi/180)
cp.y=yres/1.5+.1*z*Sin(z*pi/180)
cp.z=-z/5
np= rotatepoint3d(piv,cp,ang)
np=apply_perspective(np,eye,ep)
rad=((40-10)*(z)/3600 + 10)/ep
Circle(np.x,np.y),rad,Rgb(z*250/3600,0,255-z*250/3600),,,,f
Next z
if ep>9 then birds
magnify
Screenunlock
Sleep regulate(60,fps),1
Loop Until Inkey=Chr(27)
Imagedestroy im
Sleep