Demo

[D.J.Peters]

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 long 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]

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]

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
  addi=0.00001 + sin(w2)*0.000005
  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
  w+ =addi
  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 long 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]

Fantastic work!
Something like a black hole or wormhole.

[D.J.Peters]

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 long w,h
screeninfo ,h : h*=.8 : w=h
screenres w,h,32
dim as long 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
    line imgTexture,(x+1,y+1)-step(63,63),RGB(255,255,255),B
    n+=1
  next
next
' file the table image
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 : iu and= &HFF
    dim as long iv = sv*255 : iv and= &HFF
    dim as long iw = sw*255 : iw and= &HFF
    pTable[j*TablePitch+i] = (iw shl 16) or (iv shl 8) or iu
  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

[v1ctor]

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.

[badidea]

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.