Demo

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
D.J.Peters
Posts: 7825
Joined: May 28, 2005 3:28

Demo

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
BasicCoder2
Posts: 3400
Joined: Jan 01, 2009 7:03

Re: Demo

And it runs on my old FreeBASIC Compiler - Version 0.24.0 :)
All it needs is music?
I wonder if it is possible to generate sound patterns as it is to generate visual patterns?
D.J.Peters
Posts: 7825
Joined: May 28, 2005 3:28

Re: Demo

Code: Select all

const g         as single  = 9.80665
const g2        as single  = g * 2.0
const gd2       as single  = g * 0.5
const pi        as single  = 3.141592654
const pi2       as single  = pi * 2.0
const onedegree as single  = pi/180.0

const max_particles as integer = 10000
const last_particle as integer = max_particles - 1
type PARTICLE
bt  as double 'birth time
scrx as integer
scry as integer
posx as integer
posy as integer
v0  as single 'speed    at time 0
a   as single
col as integer
end type
dim shared particles(max_particles) as PARTICLE

sub init_particle(byval i as integer,byval t as double)
static as single w,w2
dim as single rc,gc,bc,addi
rc=cos(w2     )*0.5+0.5
gc=cos(w2*1.25)*0.5+0.5
bc=cos(w2*1.5 )*0.5+0.5
with particles(i)
.posx=int(cos(w*pi)*320)
.posy=int(sin(w)*240)
.bt = t
.v0 = sin(w)*80+41
.a  = cos(w*w)*pi +rnd*.5
.col=rgb(255*rc,255*gc,255*bc)
end with
w2+=0.0001
end sub

sub update_particles(byval t as double)
dim as single s,vs
dim i as integer
for i=0 to last_particle
with particles(i)
s=(t - .bt):vs=.v0*s
.scrx=.posx + int(vs*cos(.a))
.scry=.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
line p,(0,0)-step(255,255),0,BF
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*100)=50 then init_particle(i,t)
next
draw string p,(0,abs(sin(w))*240),"-- FreeBASIC --",RGB(255,255,255)

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+=8
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 10
wend
Tyr_Anassazi
Posts: 26
Joined: Jul 01, 2013 15:01
Location: Russia, Novosibirsk
Contact:

Re: Demo

Fantastic work!
Something like a black hole or wormhole. D.J.Peters
Posts: 7825
Joined: May 28, 2005 3:28

Re: Demo Here are the description how it works.

The important part is the image in "imgTable" with the same resolution as the screen or window. What are in this table/image ?

The red channel: Every byte in this channel describes how bright or dark a texel of a texture are rendered.

The green channel. Every byte in this channel describes which texel of a texture must be read based on the X direction.

The blue channel. Every byte in this channel describes which texel of a texture must be read based on the Y direction.

pseudo code:

Code: Select all

loop
loop y all rows
loop x all cols
index = (x+y*rows+frame and mask)
plot x,y texture(table(index).green + table(index).blue*texturesize) * texture(index).red
end loop
end loop
frame+=1
end loop
The trick:
If you inc- or decrement the index that points in the table by a value (in this case number of frame)
the masking guaranteed always a legal location.

The result are the reading texels are changed this way so it looks like a animation.

Another point are the texture size is 256 x 256 pixels
in hex &HFFFF the high byte=y lo byte=x so it's easy to map any coords to a legal location.

Here are all together no magic ! ;-)

Joshy

Code: Select all

'
' main
'
dim as integer w,h
screeninfo ,h : h*=.8 : w=h
screenres w,h,32
dim as integer TexturePitch,BufferPitch,TablePitch
dim as ulong ptr pTexture,pBuffer,pTable

' create images drawbuffer, tableimage and texture
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)

' get pixel pointers and pitch of the images
imageinfo imgBuffer ,,,,BufferPitch ,pBuffer
imageinfo imgTable  ,,,,TablePitch  ,pTable
imageinfo imgTexture,,,,TexturePitch,pTexture

' convert bytes per row to pixels per row
TexturePitch shr=2
BufferPitch  shr=2
TablePitch   shr=2

' put something in the 256 x 256 pixel texture
dim as integer n
for y as integer = 0 to 256 step 64
for x as integer = 0 to 256 step 64
line imgTexture,(x,y)-step(65,65),RGB(x,y,x+y),BF
line imgTexture,(x,y)-step(65,65),RGB(255,255,255),B
n+=1
next
next

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

dim as single r,s
dim as integer offset
while inkey()=""
s=sin(r)*20:r+=0.01
windowtitle "s:" & s
offset+=1+s
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 &HFFFF) + offset) and &HFFFF ]
dim as const long isca = ival shr 16
pBuffer[j*BufferPitch+i] = ((((icol and &HFF00FF)*isca) shr 8) and &HFF00FF)  _
+ ((((icol and &H00FF00)*isca) shr 8) and &H00FF00)
next
next
put (0,0),imgBuffer,PSET
sleep 10

wend
Last edited by D.J.Peters on Sep 25, 2017 16:22, edited 2 times in total.
v1ctor
Posts: 3799
Joined: May 27, 2005 8:08
Location: SP / Bra[s]il
Contact:

Re: Demo

Long time not see a tunnel effect :)

I took your last demo and compiled it to javascript using the work in progress Emscripten port.

Take a look: http://freebasic.net/temp/js-tunnel/tunnel.html

On the desktop (Windows 10), it runs great in Firefox and Edge, and OK in Chrome. IE 11 can also run it, but it's a bit slow.

I tested it too on my Android phone (Note 3). Runs fine in the stock browser, and slow in Chrome.
Posts: 1545
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Demo

Tested the javascript version on my system, Xubuntu 14.04 64bit, with:
* Firefox: Smooth
* Chromium: Much slower, also the loading
And on the native browser of my Jolla phone: Somewhere in between, faster then my PC's chromium but slower then firefox on PC.