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

Postby D.J.Peters » Oct 08, 2015 18:44

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

Postby BasicCoder2 » Oct 08, 2015 20:07

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

Postby D.J.Peters » Oct 08, 2015 20:51

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

Postby Tyr_Anassazi » Oct 10, 2015 9:33

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

Re: Demo

Postby D.J.Peters » Oct 11, 2015 0:06

Image
Here are the description how it works.

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

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

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

The blue channel.
Image
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
Site Admin
Posts: 3799
Joined: May 27, 2005 8:08
Location: SP / Bra[s]il
Contact:

Re: Demo

Postby v1ctor » Oct 11, 2015 20:02

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
Posts: 1545
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Demo

Postby badidea » Oct 11, 2015 22:06

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.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 4 guests