The ultimate FBGFX thread

mrminecrafttnt · Post by **mrminecrafttnt** » Nov 28, 2020 21:17

Rules:
- Post your code that shows some nice effects in screenmode
- Only the original FBGFX.bi is allowd
- Additional DirectX or OpenGL is cheating.. :)
- Have fun!

angros47 · Post by **angros47** » Dec 02, 2020 23:48

Since no one wants to begin, I will, with a variant of a program I posted years ago:

With 72 lines of code, go down in the water well:

Code: Select all

screenres 800,600,24

dim shared as unsigned integer LookUpTable (800,600,2)

Dim texture As unsigned long Ptr = ImageCreate( 256, 256,24 )

for i as integer=0 to 255
   line texture,(0,i)-(255,i),iif((i mod 32),rgb (128,64,64), rgb(64,0,0)),,254
   line texture,(0,i)-(255,i),iif(((i+16) mod 32),rgb (128,64,64), rgb(64,0,0)),,254*256
   line texture,(0,i)-(255,i),rgb(64,0,0),,257
next


dim as integer x,y

for x=0 to 800
   for y=0 to 600

      if y=300 then
         if x<400 then LookUpTable(x,y,1)=0 else LookUpTable(x,y,1)=1024
      else
         LookUpTable(x,y,1)=1024*(.5+atn((x-400)/(y-300))/3.1415926)
         if y<300 then LookUpTable(x,y,1)+=1024
      end if
      LookUpTable(x,y,2)= 8388608/((x-400)^2+(y-300)^2)

   next
next



dim as unsigned integer t=0

dim as unsigned integer u,v,t1,t2


texture +=8 ' Skip header data

do

   dim as unsigned long ptr target=screenptr

   screenlock
   for y=1 to 600
      for x=1 to 800
         t1=LookUpTable(x,y,1)
         t2=LookUpTable(x,y,2)
         u=(t1 + t) mod 255
         v=(t2 + t) mod 255
         *target=*(texture +u*256+v)     'point(u , v , texture)
         if t2>200 then 
            if t2>280 then 
               if t2>400 then 
                  *target=rgb(0,0,32) 
               else
                 *target= (*target shr 2) and rgb(63,255,255)
               end if
            else
               *target= (*target shr 1) and rgb(127,255,255)
            end if
         end if
         target+=1
      next
   next
   screenunlock
   sleep 1

   t+=1

loop until inkey<>""

end

dodicat · Post by **dodicat** » Dec 03, 2020 19:48

For me not down a well but up a chimney. (childhood memories).
On the subject of bricks and children:

Code: Select all

 
Dim Shared As Integer xres,yres,size,sizeb
Dim Shared As Single spread=25,scale=.76,sizeX=400,sizeY=300,depth=10
Const pie=4*Atn(1)
Screenres 800,600,32
Screeninfo xres,yres
Dim As Uinteger<32> Ptr im=Imagecreate(xres,yres/2+30)
Dim As Uinteger<32> Ptr imb=Imagecreate(xres,yres/2+30)
Dim As Uinteger<32> Ptr ims=Imagecreate(xres,yres/2+30)
Dim As Uinteger<32> Ptr pi,pib
Imageinfo im,,,,,pi,size
Imageinfo imb,,,,,pib,sizeb
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Sub YinYang(xpos As Integer<32>,ypos As Integer<32>,size As Integer<32>,c1 As Uinteger<32>=8,c2 As Uinteger<32>=12,an As Single)
      #macro rotate(px,py,a,rotx,roty)
      rotx=(Cos(a*.0174533)*(px-xpos)-Sin(a*.0174533)*(py-ypos)) +xpos
      roty=(Sin(a*.0174533)*(px-xpos)+Cos(a*.0174533)*(py-ypos)) +ypos
      #endmacro
      Dim As Single rx,ry,tempx1,tempy1,tempx2,tempy2
      Circle (xpos, ypos), size,c2
      Var yps1=ypos+size,yps2=ypos-size
      Var xps1=xpos+size/2,xps2=xpos-size/2
      Var yps3=ypos-size/2,yps4=ypos+size/2
      rotate(xpos,yps1,an,rx,ry)
      tempx1=rx:tempy1=ry
      rotate(xpos,yps2,an,rx,ry)
      tempx2=rx:tempy2=ry
      Line (tempx1, tempy1)-( tempx2,tempy2),c2
      rotate(xps1,ypos,an,rx,ry)
      tempx1=rx:tempy1=ry
      rotate(xps2,ypos,an,rx,ry)
      tempx2=rx:tempy2=ry
      Paint(tempx1,tempy1),c2
      Paint(tempx2,tempy2),c1,c2
      rotate(xpos,yps3,an,rx,ry)
      tempx1=rx:tempy1=ry
      rotate(xpos,yps4,an,rx,ry)
      tempx2=rx:tempy2=ry
      Circle (tempx1,tempy1), size/2,c2,,,,f
      Circle (tempx2,tempy2), size/2,c1,,,,f
      Circle (tempx1,tempy1), size/6,c1,,,,f
      Circle (tempx2,tempy2), size/6,c2,,,,f
End Sub

Sub Tree(x1 As Single,y1 As Single,size As Single,angle As Single,depth As Single,colb As Uinteger<32>=0,colL As Uinteger<32>=0,im As Any Ptr=0)
      #define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
      Var x2=x1-.25*size*Cos(angle*.01745329)
      Var y2=y1-.25*size*Sin(angle*.01745329)
      Static As Integer<32> count,fx,fy,sz,z
      If count=0 Then  fx=x1:fy=y1:sz=size:z=2^(depth+1)-1
      Line im,(x1,y1)-(x2,y2),colb
      If count=0 Then  fx=x2:fy=y2:sz=size
      count=count+1
      If count>z Then count=0
      If incircle(fx,fy,(.45*sz),x2,y2)=0 Then Circle im,(x2,y2),.01*sz,colL 
      If depth>0 Then
            Tree(x2, y2, size * Scale, angle - Spread, depth - 1,colB,colL,im)
            Tree(x2, y2, size * Scale, angle + Spread, depth - 1,colB,colL,im)
      End If
End Sub

Sub DrawToImages(Byref im As Uinteger<32> Ptr,Byref imb As Uinteger<32>Ptr,ims As Uinteger<32>Ptr)
      Randomize 1
      If ims<>0 Then
            For z As Integer<32>=0 To yres/2+5
                  Var r=map(0,(yres/2+5),z,0,250)
                  Var g=map(0,(yres/2+5),z,0,250)
                  Var b=map(0,(yres/2+5),z,200,250)
                  Line ims,(0,z)-(xres,z),Rgb(r,g,b)
            Next z
      End If
            Tree(200,305,200,80,12,Rgb(200,100,0),Rgb(0,100,0),imb)
            Tree(700,305,100,100,12,Rgb(100,50,0),Rgb(0,90,0),imb)
      Dim As Integer<32> bw=xres/20,bh=xres/40,k=bw/4
      For y As Integer<32>=0 To yres\2+30 Step bh
            For x As Integer<32>=-bw To xres Step bw
                  Line im,(x+k,y)-Step(bw,bh),Rgb(200,100+(Rnd*15-Rnd*15),0),bf
                  Line im,(x+k,y)-Step(bw,bh),Rgb(200,200,2000),b
            Next x
            k=-k
      Next y
      For x As Single=0 To 1.9*pie Step .01
            Dim As Integer<32> xpos=map(0,1.9*pie,x,0,xres)
            Dim As Integer<32> ypos=map(-1,1,Cos(x),(yres-5),(yres-30))
            ypos-=yres\2
            If x=0 Then Pset im,(xpos,ypos) Else Line im,-(xpos,ypos),Rgb(0,100,0)
      Next x
      Paint im,(1,yres\2),Rgb(0,100,0),Rgb(0,100,0)
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
      Static As Double timervalue,_lastsleeptime,t3,frames
      Var t=Timer
      frames+=1
      If (t-t3)>=1 Then t3=t:fps=frames:frames=0
      Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
      If sleeptime<1 Then sleeptime=1
      _lastsleeptime=sleeptime
      timervalue=T
      Return sleeptime
End Function

#macro Sweep(p,sz)
For z As Integer<32>=0 To (sz)\4
      Swap p[z],p[z+speed]
Next z
#endmacro
'=====================================================

DrawToImages(im,imb,ims)
Dim As Long fps,z=1
Dim As Single a,rad=yres/6,k,k2,a2
Const speed=2
Do
      z=-z
      a+=speed
      a2+=speed
      sweep(pi,size)
      If z=1 Then: sweep(pib,sizeb):End If
      If a2>xres*2 Then
            a2=0
            Paint im,(1,1),Rgb(0,0,0):Paint imb,(1,1),Rgb(0,0,0):Paint imb,(1,1),Rgb(255,0,255)
            DrawToImages(im,imb,0)
      End If
      Screenlock
      Put(0,0),ims,trans
      Put(0,0),imb,trans
      Put(0,yres\2),im,trans
      Var xpos=map(0,xres,a,0,2*pie)
      Var ypos=map(-1,1,Sin(xpos),5,30)
      For n As Integer<32>=1 To 8 Step 2
            If n=1 Then k=265:k2=ypos Else k=0 :k2=0
            Yinyang(200*Sqr(n),k+yres/2-rad/n-n/4+k2,rad/n,Rgb(30*n,0,0),Rgb(255-30*n,255,255),n*a)
      Next n
      draw string(5,5),"fps "&fps
      Screenunlock
      Sleep regulate(80,fps),1
Loop Until Len(Inkey)
Sleep
Imagedestroy im
Imagedestroy imb
Imagedestroy ims

Lothar Schirm · Post by **Lothar Schirm** » Dec 04, 2020 9:35

Two amazing examples! This one is a little bit simpler: interference of two circular waves.

Code: Select all

Dim As Double x01, y01, x02, y02, x, y, t, dt, v, dx, dy, A, hell
Dim As Integer i, j
Const pi = 4 * ATn(1)


Function Welle(ByVal x0 As Double, ByVal y0 As Double, ByVal x As Double, _
										ByVal y As Double, ByVal t As Double, ByVal v As Double) As Double
	'Kreisfoermige Welle ausgehend vom Punkt x0, y0, Wellengeschwindigkeit v.
	'Ergebnis ist die Wellenamplitude am Punkt x, y zum Zeitpunkt t.
	
	Dim As Double r
	
	r = Sqr((x-x0)^2 + (y-y0)^2)
	
	Return Cos(2 * pi * t - r / v)
	
End Function


'Hauptprogramm

ScreenRes 500, 500, 32, 2
WindowTitle "Ueberlagerung von Kreiswellen"
Window (0, 0) - (20, 20)

x01 = 8
y01 = 8
x02 = 12
y02 = 12
dt = 0.02
t = 0
v = 0.2
dx = 20/500
dy = 20/500
 
Do
	ScreenSet 1, 0
	Cls
	For x = 0 To 20 Step dx
		For y = 0 To 20 Step dy
			A = Welle(x01, y01, x, y, t, v) + Welle(x02, y02, x, y, t, v)
			hell = (A + 2) * 55
			PSet (x, y), RGB(hell, hell, hell)  
		Next
	Next
	ScreenSet 0, 0
	ScreenCopy 1, 0
	t = t + dt
Loop Until InKey <> ""

End

And here is another example (planet Saturn with three satellites): https://www.freebasic-portal.de/code-be ... t-126.html

Lothar Schirm · Post by **Lothar Schirm** » Dec 04, 2020 14:56

Contour plot of a 3D function in polar coordinates:

Code: Select all

DIM AS SINGLE r, phi, dx, dy, x, y, f
DIM AS INTEGER n
CONST pi = 4 * ATN(1)

ScreenRes 640, 480
WindowTitle "Function exp(-0.05 * r) * COS(r) * COS(n * phi)"
Width 80, 30
WINDOW(-10, -7) - (10, 7)
dx = 20 / 640
dy = 14 / 480

DO
  
  LOCATE 1, 1
  INPUT "n = integer value (e.g. 3), or 0 in order to exit: ", n
  IF n = 0 THEN EXIT DO

  FOR x = -10 TO 10 STEP dx
    FOR y = -7 TO 7 STEP dy
      phi = ATAN2(y, x)
      'ATan2 returns a value between -pi and pi ---> correction for -pi to 0: 
      IF phi < 0 THEN phi = 2 * pi + phi
      r = SQR(x^2 + y^2)
      f = exp(-0.05 * r) * COS(r) * Cos(n * phi)
      PSET(x, y), 24 + 7 * f
    NEXT y
  NEXT x
  
LOOP UNTIL n = 0

End

The grey colors 16 to 31 in 8 bit color graphics mode a used to define a grayscale por the plot.

UEZ · Post by **UEZ** » Dec 04, 2020 16:45

I would prefer rather an own folder called e.g. Graphical Examples maybe with sub folders rather than a thread which is not pinned and get lost someday.

Anyhow, here my contribution called Iris:

Code: Select all

'Iris coded by UEZ build 2020-12-04
#Include "fbgfx.bi"
Using FB

#Define Min(a, b)	(Iif(a < b, a, b))
#Define Map(Val, source_start, source_stop, dest_start, dest_stop)   ((Val - source_start) * (dest_stop - dest_start) / (source_stop - source_start) + dest_start)

Randomize
Dim As Integer sh = 1, w = 1920 Shr sh, h = 1080 Shr sh, w2 = w Shr 1, h2  = h Shr 1, iParticles = 10000, i

Screenres w, h, 32, 2, GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
Screenset 1, 0
Color &hFF, &hFF202020
Cls

Type vParticle
	Dim As Single x, y, vx, vy, px, py, th
	Dim As Ulong col
End Type

Dim As vParticle aParticles(iParticles)

Dim As Single radius = 50, a, t = 0
Dim As Long c
For i = 1 To iParticles
	a = Rnd() * 6.2831853
	aParticles(i).x = w2 + Cos(a) * radius
	aParticles(i).y = h2 + Sin(a) * radius
	aParticles(i).vx = -(w2 - aParticles(i).x) / (radius * 5)
	aParticles(i).vy = -(h2 - aParticles(i).y) / (radius * 5)
	aParticles(i).px = aParticles(i).x
	aParticles(i).py = aParticles(i).y
	aParticles(i).col = &hFFFFFFFF
	aParticles(i).th = 5
Next

Circle (w2, h2), radius + 1, &hF0000000,,,, F

Do
	For i = 1 To iParticles
		If aParticles(i).th > 0.5 Then
			Line (aParticles(i).x, aParticles(i).y) - (aParticles(i).px, aParticles(i).py), aParticles(i).col
			aParticles(i).px = aParticles(i).x
			aParticles(i).py = aParticles(i).y 
			aParticles(i).x += aParticles(i).vx + (Rnd * 2 - 1)
			aParticles(i).y += aParticles(i).vy + (Rnd * 2 - 1)
			c = Map(aParticles(i).th, 5, 0.5, 255, 10)
			aParticles(i).col = Rgba(0, Min(255, c Shl 1), 255 - 255 * Cos(c / 120), c)
			aParticles(i).th -= 0.005
			t += 0.01
		Endif
	Next
	Flip
	Sleep(10)
Loop Until Len(Inkey())

BasicCoder2 · Post by **BasicCoder2** » Dec 04, 2020 20:00

Xmas tree.
It could be improved with shading for the tree not just its trunk.
The fairy lights could have colors and programmed sequenced light displays such as those controlled by an Arduino.
Perhaps a star on top?
Perhaps some snow falling in the background?
A xmas carol playing as well? Now where are those FB music commands?

Code: Select all

screenres 640,480,32

dim as ulong shade
shade = 0

'draw trunk
for x as integer = 300 to 330
    line (x,300)-(x,400),rgb(30+shade,20+shade,shade)
    shade = shade + 1
next x

'draw leaves
for y as integer = 0 to 300
    for x as integer = 320-y/2 to 320 + y/2
        circle (x,y+30), int(rnd(1)*3), rgb ( int(rnd(1)*30), int(rnd(1)*200),0) ,,,,f
    next x
next y

dim as ulong colors(0 to 3)
colors(0)=rgb(255,0,0)
colors(1)=rgb(255,255,0)
colors(2)=rgb(0,0,255)
colors(3)=rgb(255,0,255)

'hang some baubles
for y as integer = 0 to 300
    for x as integer = 320-y/2 to 320 + y/2
        if int(rnd(1)*400)=1 then
            circle (x,y+30),4,colors(int(rnd(1)*4)),,,,f
        end if
    next x
next y

dim as integer lightX(300),lightY(300)

'select position of fairy lights
dim as integer i
for y as integer = 0 to 300
    for x as integer = 320-y/2 to 320 + y/2
        if int(rnd(1)*300)=1 then
            lightX(i)=x
            lightY(i)=y+30
            i = i + 1
            if i>300 then i=300
        end if
    next x
next y

Dim St As Double
St = Timer

dim as ulong c
do
    if timer>st+0.1 then
        st = timer
        screenlock
        for i as integer = 0 to 300
            c = int(rnd(1)*255)
            circle (lightX(i),lightY(i)),2,rgb(c,c,c),,,,f
        next i
        screenunlock
    end if
    sleep 2
loop until multikey(&H01)

Post by **paul doe** » Dec 04, 2020 22:36

Unimpressive, but all amazing things have humble beginnings:

Code: Select all

/'
  The Chaos Game
'/
private function rng overload( aMin as double, aMax as double ) as double
  return( rnd() * ( aMax - aMin ) + aMin )
end function

private function rng( aMin as integer, aMax as integer ) as integer
  return( rnd() * ( aMax - aMin ) + aMin )
end function

type XY
  as single x, y
end type

type IFSCoefs
  as single _
    a, b, c, _
    d, e, f
end type

type IFS
  as IFSCoefs coefs( any )
  as long count
end type

type Resolution
  as long w, h
end type

function setIFSCoefs( byref aIFS as IFS, n as long ) byref as IFS
  redim aIFS.coefs( 0 to n - 1 )
  
  with aIFS
    .count = n
    
    for i as integer = 0 to .count - 1
      .coefs( i ) = type <IFSCoefs>( _
        rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ), _
        rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ) )
    next
  end with
  
  return( aIFS )
end function

function eval overload( byref aIFS as IFS, byref prev as XY ) as XY
  var byref cf = aIFS.coefs( rng( 0, aIFS.count - 1 ) )
  
  return( type <XY>( _
    cf.a * prev.x + cf.b * prev.y + cf.c, _
    cf.d * prev.x + cf.e * prev.y + cf.f ) )
end function

function init( w as long, h as long, byref t as const string = "" ) as Resolution
  screenRes( w, h, 32 )
  color( rgb( 0, 0, 0 ), rgb( 255, 255, 255 ) )
  windowTitle( iif( len( t ), t, "Untitled" ) )
  cls()
  randomize()
  
  return( type <Resolution>( w, h ) )
end function

sub render( byref res as Resolution, byref aIFS as IFS, sc as single = 100.0f, it as long = 100000 )
  dim as XY prev
  
  cls()
  
  dim as single _
    hw = res.w * 0.5f, hh = res.h * 0.5f
  
  for i as integer = 1 to it
    var p = eval( aIFS, prev )
    
    pset ( p.x * sc + hw, p.y * sc + hh ), rgba( 0, 0, 0, 255 )
    
    prev = p
  next
end sub

/'
  Main code
'/
const as ulong KEY_ESC = 27

dim as IFS aIFS
dim as long coefs = 2

var res = init( _
  800, 600, "The chaos game. Any key to generate another IFS, ESC to quit." )

do
  aIFS = setIFSCoefs( aIFS, coefs )
  render( res, aIFS )
loop until( getKey() = KEY_ESC )

@dodicat: that one was particularly good. I recall you also posted it in another thread?

badidea · Post by **badidea** » Dec 04, 2020 22:37

Lothar Schirm wrote: This one is a little bit simpler: interference of two circular waves.

Your first demo (Ueberlagerung von Kreiswellen) is very heavy on the CPU. Even with a 'sleep 1' added, one core near 100% load.

UEZ · Post by **UEZ** » Dec 04, 2020 23:02

Next one:

Code: Select all

'Planless wave coded by UEZ build 2020-12-04
'Thanks to Joshy for the Perlin Noise adaption

#Include "fbgfx.bi"

Using FB

'Perlin Noise by Joshy aka D.J. Peters
Type REAL As Single
#define rAbs(x_)				IIf( (x_) < 0, -(x_), (x_) )
Const As REAL rPI              	= Acos(-1)
Const As REAL rDeg2Rad         	= rPI / 180

Type PERLINNOISE 
	Declare Constructor
	Declare Sub NoiseSeed(ByVal seed As Double)
	Declare Sub NoiseDetail(ByVal lod As Integer)
	Declare Sub NoiseDetail(ByVal lod As Integer, ByVal falloff As REAL)
	Declare Function Noise1D(ByVal x As REAL) As REAL
	Declare Function Noise2D(ByVal x As REAL,ByVal y As REAL) As REAL
	Declare Function Noise3D(ByVal x As REAL,ByVal y As REAL,ByVal z As REAL) As REAL
Private:
	Const As REAL    SINCOS_PRECISION = 0.5
	Const As Integer SINCOS_LENGTH    = (360 / SINCOS_PRECISION)
	Const As Integer PERLIN_YWRAPB    = 4
	Const As Integer PERLIN_YWRAP     = 1 Shl PERLIN_YWRAPB
	Const As Integer PERLIN_ZWRAPB    = 8
	Const As Integer PERLIN_ZWRAP     = 1 Shl PERLIN_ZWRAPB
	Const As Integer PERLIN_SIZE      = 4095
	Const As Integer PERLIN_TWOPI     = SINCOS_LENGTH
	Const As Integer PERLIN_PI        = PERLIN_TWOPI Shr 1
	As Integer perlin_octaves   	  = 4   ' default To medium smooth
	As REAL  perlin_amp_falloff 	  = 0.5 ' 50% reduction/octave
	As REAL  perlin_cosTable(SINCOS_LENGTH-1)
	As REAL  perlin(PERLIN_SIZE)
	Declare Sub reInit
	Declare Function noise_fsc(ByVal i As REAL) As REAL
End Type

Constructor PERLINNOISE 
	For i As Integer = 0 To SINCOS_LENGTH - 1
		perlin_cosTable(i) = Cos(i * rDEG2RAD * SINCOS_PRECISION)
	Next
	reInit
End Constructor

Sub PERLINNOISE.reInit 
	For i As Integer = 0 To PERLIN_SIZE
		perlin(i) = Rnd()
	Next
End Sub

Function PERLINNOISE.noise_fsc(ByVal i As REAL) As REAL 
	Dim As Integer index = Int(i * PERLIN_PI)
	Return 0.5 * (1.0 - perlin_cosTable(index Mod SINCOS_LENGTH))
End Function

Sub PERLINNOISE.noiseSeed(ByVal seed As Double) 
	'Randomize(0) ' !!!
	Randomize(seed) : reInit
End Sub

Sub PERLINNOISE.noiseDetail(ByVal lod As Integer) 
	If (lod > 0) Then perlin_octaves = lod
End Sub

Sub PERLINNOISE.noiseDetail(ByVal lod As Integer, ByVal falloff As REAL) 
	If (lod > 0) Then perlin_octaves = lod
	If (falloff > 0) Then perlin_amp_falloff = falloff
End Sub

Function PERLINNOISE.Noise1D(ByVal x As REAL) As REAL 
	Return noise3D(x, 0, 0)
End Function

Function PERLINNOISE.Noise2D(ByVal x As REAL, ByVal y As REAL) As REAL 
	Return noise3D(x, y, 0)
End Function

Function PERLINNOISE.Noise3D(ByVal x As REAL,ByVal y As REAL,ByVal z As REAL) As REAL 
	x = rAbs(x) : y = rAbs(y) : z = rAbs(z)
	Dim As Integer xi = Int(x), yi = Int(y), zi = Int(z)
	Dim As REAL xf = x - xi, yf = y - yi, zf = z - zi
	Dim As REAL r, ampl = 0.5
	For i As Integer = 0 To perlin_octaves - 1
		Dim As Integer of= xi + (yi Shl PERLIN_YWRAPB) + (zi Shl PERLIN_ZWRAPB)
		Dim As REAL rxf = noise_fsc(xf)
		Dim As REAL ryf = noise_fsc(yf)
		Dim As REAL n1 = perlin(of And PERLIN_SIZE)
		n1 += rxf * (perlin((of + 1) And PERLIN_SIZE) - n1)
		Dim As REAL n2 = perlin((of + PERLIN_YWRAP) And PERLIN_SIZE)
		n2 += rxf * (perlin((of + PERLIN_YWRAP + 1) And PERLIN_SIZE) - n2)
		n1 += ryf * (n2 - n1)
		of += PERLIN_ZWRAP
		n2  = perlin(of And PERLIN_SIZE)
		n2 += rxf * (perlin((of + 1) And PERLIN_SIZE) - n2)
		Dim As REAL n3 = perlin((of + PERLIN_YWRAP) And PERLIN_SIZE)
		n3 += rxf * (perlin((of + PERLIN_YWRAP + 1) And PERLIN_SIZE) - n3)
		n2 += ryf * (n3 - n2)
		n1 += noise_fsc(zf) * (n2 - n1)
		r += n1 * ampl
		ampl *= perlin_amp_falloff
		xi Shl = 1: xf *= 2
		yi Shl = 1: yf *= 2
		zi Shl = 1: zf *= 2
		If (xf >= 1) Then xi += 1 : xf -= 1
		If (yf >= 1) Then yi += 1 : yf -= 1
		If (zf >= 1) Then zi += 1 : zf -= 1
	Next
	Return r
End Function
'End Perlin Noise

#Define Max(a, b)	(Iif(a > b, a, b))

Randomize
Dim As Integer w = 1920 Shr 1, h = 1080 Shr 1, w2 = w Shr 1, h2 = h Shr 1

Screenres w, h, 32, 2, GFX_ALWAYS_ON_TOP Or GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH
Screenset 1, 0
Color &hFF, &hFFFFFFFF

Dim As ULong iFPS, cfps = 0
Dim As Double fTimer = Timer, t = Rnd()
Dim As Ulong i, iCircles = 300
Dim As Single m = Max(w, h) * 1.8, ss = m / iCircles, r, tt = 1 / iCircles ^ 1.75

Type vec
	As Single x, y
End Type

Dim As PERLINNOISE Perlin

Dim As vec aCircles(iCircles)
For i = 1 To iCircles
	aCircles(i).x = w2
	aCircles(i).y = h2
Next

Do
	Cls
	
	r = 1
	For i = 1 To iCircles
		Circle (aCircles(i).x, aCircles(i).y), r, &h80000000
		r += ss
		aCircles(i).x = w2 + (Perlin.Noise1D(t - i / 50) - 0.5) * w2
		aCircles(i).y = h2 + (Perlin.Noise1D(t + 50000 - i / 75) - 0.5) * h2
		t += tt
	Next
	
	Draw String(4, 4), iFPS & " fps", &hFF800000
	Flip	
	
	cfps += 1
	If Timer - fTimer > 0.99 Then
		iFPS = cfps
		cfps = 0
		fTimer = Timer
	End If
	Sleep(1)
Loop Until Len(Inkey())

BasicCoder2 wrote:Xmas tree.

I did something similar awhile ago with rotating xmas tree, chip sound, scroller and snow ^^: viewtopic.php?f=7&t=28880

BasicCoder2 · Post by **BasicCoder2** » Dec 05, 2020 0:28

UEZ wrote:
BasicCoder2 wrote:Xmas tree.
I did something similar awhile ago with rotating xmas tree, chip sound, scroller and snow ^^: viewtopic.php?f=7&t=28880

Very nice must have missed it. I was going to do a dodicat 3d pixel world version myself but I can't beat yours :)

dafhi · Post by **dafhi** » Dec 05, 2020 7:03

Mr. doe

Code: Select all

#include "fbgfx.bi"

function init( w as long, h as long, byref t as const string = "" ) as Resolution
  screenRes( w, h, 32,, fb.gfx_alpha_primitives )
  color( rgb( 0, 0, 0 ), rgb( 255, 255, 255 ) )
  windowTitle( iif( len( t ), t, "Untitled" ) )
  cls()
  randomize()
 
  return( type <Resolution>( w, h ) )
end function

Code: Select all

    pset ( p.x * sc + hw, p.y * sc + hh ), rgba( 0, 0, 0, 55 )

maybe you were trolling

Post by **paul doe** » Dec 05, 2020 7:16

dafhi wrote:...
maybe you were trolling

Hmm? What do you mean? Me, trolling? XD

Ah, I see. Well, no alpha primitives were set, but that remained there out of habit, perhaps? Or is there something I'm not seeing there?

dafhi · Post by **dafhi** » Dec 05, 2020 8:41

pset don't do rgba by default. it's fine. i'm just being my clownsome self. really like that example though. modifying to use my aa dot.

[update] aadot was a bust. i colorized it though

Code: Select all

/'
  The Chaos Game
'/
private function rng overload( aMin as double, aMax as double ) as double
  return( rnd() * ( aMax - aMin ) + aMin )
end function

private function rng( aMin as integer, aMax as integer ) as integer
  return( rnd() * ( aMax - aMin ) + aMin )
end function

type _ccFloat
  as single _
    x, y, z, w
end type
  
function _cdot( byref v as _ccFloat, byref w as _ccFloat ) as single
  return( v.x * w.x + v.y * w.y + v.z * w.z )
end function

function _saturate( byref c as _ccFloat ) as _ccFloat
  
  return( type <_ccFloat>( _
    iif( c.x < 0.0, 0.0, iif( c.x > 1.0, 1.0, c.x ) ), _
    iif( c.y < 0.0, 0.0, iif( c.y > 1.0, 1.0, c.y ) ), _
    iif( c.z < 0.0, 0.0, iif( c.z > 1.0, 1.0, c.z ) ), _
    1.0 ) )
end function

function _hueToRGB( h as single ) as _ccFloat
  
  return _saturate( type <_ccFloat>( _
      abs( h * 6 - 3 ) - 1, _
      2 - abs( h * 6 - 2 ), _
      2 - abs( h * 6 - 4 ), _
      1 ) )
end function


function HCYtoRGB( byref aHCY as _ccFloat ) as _ccFloat
  
  static as _ccFloat _
    Weights = ( 0.299, 0.587, 0.114 )

  var aRGB  = _hueToRGB( aHCY.x )
  var Z     = _cdot( aRGB, Weights )
  
  if ( aHCY.z < Z) then:  aHCY.y *= aHCY.z / Z
  elseif ( z < 1) then
    aHCY.y *= ( 1 - aHCY.z ) / ( 1 - Z )
  end if
  
  return  type <_ccFloat>( _
    ( aRGB.x - Z ) * aHCY.Y + aHCY.z, _
    ( aRGB.y - Z ) * aHCY.Y + aHCY.z, _
    ( aRGB.z - Z ) * aHCY.Y + aHCY.z, 1.0 )
    
end function


function clamp(in as single, hi as single=1, lo as single=0) as single
  return iif( in < lo, lo, iif( in > hi, hi, in))
End Function


union uni_snglng
  as single         s
  as ulong          col
  Type:  As UByte   b,g,r,a
  End Type
End union

type XY
  as single         x, y
  as uni_snglng     w
end type

type IFSCoefs
  as single _
    a, b, c, _
    d, e, f
end type

type IFS
  as IFSCoefs coefs( any )
  as long count
end type

type Resolution
  as long w, h
end type

function setIFSCoefs( byref aIFS as IFS, n as long ) byref as IFS
  redim aIFS.coefs( 0 to n - 1 )
 
  with aIFS
    .count = n
   
    for i as integer = 0 to .count - 1
      .coefs( i ) = type <IFSCoefs>( _
        rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ), _
        rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ), rng( -1.0f, 1.0f ) )
    next
  end with
 
  return( aIFS )
end function

function eval overload( byref aIFS as IFS, byref prev as XY ) as XY
  dim as integer i = rng( 0, aIFS.count - 1 )
  var byref cf = aIFS.coefs( i )
  static as XY        q
  static as _ccFloat cc
 
  q.x = cf.a * prev.x + cf.b * prev.y + cf.c
  q.y = cf.d * prev.x + cf.e * prev.y + cf.f
  
  '' HCY Y
  cc.z = .6
  
  '' HCY C
  cc.y = sin(q.x * prev.y + q.y * prev.x)*.99 + .5
  
  '' HCY H
  cc.x = sqr( (q.x+cc.y)*(prev.x+cc.y) + (q.y+cc.y)*(prev.y+cc.y) ) + i
  
  cc = HCYtoRGB( cc )
    
  q.w.col = rgb( _
    255.499*clamp(cc.x), _
    255.499*clamp(cc.y), _
    255.499*clamp(cc.z))
 
  return q
  
end function

#include "fbgfx.bi"

function init( w as long, h as long, byref t as const string = "" ) as Resolution
  screenRes( w, h, 32,, fb.gfx_alpha_primitives )
  color( rgb( 0, 0, 0 ), rgb( 255, 255, 255 ) )
  windowTitle( iif( len( t ), t, "Untitled" ) )
  cls()
  randomize()
 
  return( type <Resolution>( w, h ) )
end function

sub render( byref res as Resolution, byref aIFS as IFS, sc as single = 100.0f, it as long = 100000 )
  dim as XY prev
 
  color , rgb(128,128,128)
  cls()
 
  dim as single _
    hw = res.w * 0.5f, hh = res.h * 0.5f
 
  for i as integer = 1 to it
    var p = eval( aIFS, prev )
   
    p.w.a = 85 '' alpha
    pset ( p.x * sc + hw, p.y * sc + hh ), p.w.col
   
    prev = p
  next
end sub

/'
  Main code
'/
const as ulong KEY_ESC = 27

dim as IFS aIFS
dim as long coefs = 2

var res = init( _
  800, 600, "The chaos game. Any key to generate another IFS, ESC to quit." )

do
  aIFS = setIFSCoefs( aIFS, coefs )
  render( res, aIFS )
  sleep 1
loop until( getKey() = KEY_ESC )

Lothar Schirm · Post by **Lothar Schirm** » Dec 06, 2020 14:23

badidea wrote:
Lothar Schirm wrote: This one is a little bit simpler: interference of two circular waves.
Your first demo (Ueberlagerung von Kreiswellen) is very heavy on the CPU. Even with a 'sleep 1' added, one core near 100% load.

I measure around 25% on my machine (7 years old, Windows 8.1). I wanted to keep the code as simple as possible, so I did not make an effort to minimize CPU load.

Here is a nice pattern of circles I found on YouTube (https://www.youtube.com/watch?v=bZ45xmy ... sw&index=1). There are sevaral similiar examples written in QB64. I wrote this in FreeBasic:

Code: Select all

dim as integer n, i, j, colour
dim as double x, y, x0, y0, r, phi
const pi = 4 * atn(1)

screenres 800, 800
width 100, 50
WindowTitle "Axially symmetrical pattern of circles" 

do
	cls
	input "Enter an Integer value (e.g. 2), or  0 in order to exit: ", n
	if n = 0 then exit do
  
  for i = 0 To n
		phi = 2 * i * pi / n
		colour = 0
		for j = 1 to 400 step 5 
			colour = colour + 1
			r = j
			x0 = 400 + r * cos(phi)
			y0 = 400 + r * sin(phi)
			circle (x0, y0), r, colour
		next j
	next i
  locate 2, 1
  print "Press any key"
  getkey
loop

The ultimate FBGFX thread

The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread

Re: The ultimate FBGFX thread