Code: Select all

`const g as single = 9.81`

const g2 as single = g * 2.0

const gd2 as single = g * 0.5

const pi as single = atn(1)*4.0

const pi2 as single = pi * 2.0

const onedegree as single = pi/180.0

const max_particles as integer = 5000

const last_particle as integer = max_particles - 1

type PARTICLE

bt as double

scrx as integer

scry as integer

posx as integer

posy as integer

v0 as single

a as single

col as ulong

end type

dim shared particles(last_particle) as PARTICLE

sub init_particle(byval i as integer,byval t as double)

static w as single

dim as single rc,gc,bc

rc=cos(w)*0.5+0.5

gc=cos(w*1.25)*0.5+0.5

bc=cos(w*1.5)*0.5+0.5

with particles(i)

.posx=128+int(cos(w)*128)

.posy=128+int(sin(w)*128)

.bt = t

.v0 = sin(w)*80

.a = cos(w)*pi+pi2*rnd

.col=rgb(255*rc,255*gc,255*bc)

end with

w=w+(1.0/max_particles)

end sub

sub update_particles(byval t as double)

dim as single s,vs

for i as integer=0 to last_particle

with particles(i)

s=(t - .bt):vs=.v0*s

.scrx=128 +.posx + int(vs*cos(.a))

.scry=128 -(.posy + int(vs*sin(.a)-gd2*(s*s)))

end with

next

end sub

sub render_particles(byval p as ulong ptr,byval t as double)

static as single w=0 : w+=0.01

dim as ubyte c = (2-sin(w))*32

line p,(0,0)-step(255,255),0,BF

draw string p,(0,abs(sin(w))*240),"-- FreeBASIC --",&HFFFFFF

for i as integer = 0 to last_particle

with particles(i)

.scrx and=255

.scry and=255

pset p,(.scrx,.scry),.col

end with

if int(rnd*c)=64-c then init_particle(i,t)

next

end sub

'

' main

'

dim as integer w=640,h=480

'screeninfo w,h

screenres w,h,32,,1

setMouse ,,0

dim as integer TexturePitch,BufferPitch,TablePitch

dim as ulong ptr pTexture,pBuffer,pTable

dim as any ptr imgBuffer =imagecreate(w,h,0)

dim as any ptr imgTable =imagecreate(w,h,0)

dim as any ptr imgTexture=imagecreate(256,256,0)

imageinfo imgBuffer ,,,,BufferPitch ,pBuffer

imageinfo imgTable ,,,,TablePitch ,pTable

imageinfo imgTexture,,,,TexturePitch,pTexture

TexturePitch shr=2

BufferPitch shr=2

TablePitch shr=2

for j as integer=0 to h-1

dim as single sy = 1 - j*(2/h)

for i as integer=0 to w-1

dim as single sx = -1 + i*(2/w)

dim as single sr = sqr(sx*sx+sy*sy)

dim as single sa = atan2(sy,sx)

dim as single su = 1/sr

dim as single sv = sa * 3/3.14159

dim as single sw = sr * sr

if ( sw>1 ) then sw=1

dim as long iu = su*255

dim as long iv = sv*255

dim as long iw = sw*255

pTable[j*TablePitch+i] = ((iw and &HFF) shl 16) or ((iv and &HFF) shl 8) or (iu and &HFF)

next

next

' main

dim as double t=Timer()

for index as integer=0 to last_particle

init_particle index,t

next

dim as long frame

while inkey()=""

t=Timer()

update_particles t

render_particles imgTexture,t

frame+=5

for j as integer = 0 to h-1

for i as integer = 0 to w-1

dim as const long ival = pTable[j*TablePitch+i]

dim as const long icol = pTexture[ ( (ival and &H0000FFFF) + frame) and &H0000FFFF ]

dim as const long isca = ival shr 16

pBuffer[j*BufferPitch+i] = ((((icol and &H00FF00FF)*isca) shr 8) and &H00FF00FF) _

+ ((((icol and &H0000FF00)*isca) shr 8) and &H0000FF00)

next

next

put (0,0),imgBuffer,PSET

sleep 5

wend