possible bug in FreeBASIC [SOLVED]

Linux specific questions.
Post Reply
fatman2021
Posts: 215
Joined: Dec 14, 2013 0:43

possible bug in FreeBASIC [SOLVED]

Post by fatman2021 »

Code: Select all

proc SYSTEM_BUS_T.Spectrum(x as float ) as vector3
    ' https://www.shadertoy.com/view/wlSBzD
	dim as float r, g, b
    
    r = iif(x<.16 , smoothstep(0., .16, x)*.169 , _
    	iif(x<.22 , smoothstep(.22, .16, x)*.134+.035 , _
    	iif(x<.41 , smoothstep(.22, .41, x)*.098+.035 , _
    	iif(x<.64 , smoothstep(.41,.64,x)*.851+.133 , _
    			    smoothstep(1., .64, x)*.984))))
    
    g = iif(x<.05 , 0. , _
    	iif(x<.15 , smoothstep(.05, .15, x)*.047 , _
    	iif(x<.45 , smoothstep(.15, .45, x)*.882+.047 , _
    	iif(x<.70 , smoothstep(.70, .45, x)*.796+.133 , _
    			    smoothstep(1.0, .70, x)*.133))))
    
    b = iif(x<.18 , smoothstep(0.0, .18, x)*.5 , _
    	iif(x<.22 , smoothstep(.22, .18, x)*.1+.4 , _
    	iif(x<.35 , smoothstep(.22, .35, x)*.059+.4 , _
    	iif(x<.54 , smoothstep(.54, .35, x)*.334+.125 , _
    	iif(x<.60 , smoothstep(.54, .60, x)*.169+.125 , _
    	iif(x<.69 , smoothstep(.69, .60, x)*.243+.051 , _
    	iif(x<.72 , smoothstep(.69, .72, x)*.043+.051 , _
    	iif(x<.89 , smoothstep(.89, .72, x)*.094 , 0.))))))))
    
    return vector3(r,g,b)
end proc

proc SYSTEM_BUS_T.SpectrumPoly(x as float) as vector3
    ' https://www.shadertoy.com/view/wlSBzD
    return (vector3( 1.220023e0,-1.933277e0, 1.623776e0) _
          +(vector3(-2.965000e1, 6.806567e1,-3.606269e1) _
          +(vector3( 5.451365e2,-7.921759e2, 6.966892e2) _
          +(vector3(-4.121053e3, 4.432167e3,-4.463157e3) _
          +(vector3( 1.501655e4,-1.264621e4, 1.375260e4) _
          +(vector3(-2.904744e4, 1.969591e4,-2.330431e4) _
          +(vector3( 3.068214e4,-1.698411e4, 2.229810e4) _
          +(vector3(-1.675434e4, 7.594470e3,-1.131826e4) _
          + vector3( 3.707437e3,-1.366175e3, 2.372779e3) _
            *x)*x)*x)*x)*x)*x)*x)*x)*x
end proc

def SYSTEM_BUS_T.mainImage overload (fragColor as vector4, fragCoord as const vector2)

 dim as vector2 uv = fragCoord/iResolution.xy
 dim as vector3 col = vector3(0)
 dim as vector3 spectrum3 = iif((iGlobalTime mod 2.)<1. , Spectrum(uv.x) , SpectrumPoly(uv.x))
    
    col = spectrum3*smoothstep(.3, .7, uv.y)
    col += smoothstep(.01, .0, abs(spectrum3-uv.y*2.))
    
    fragColor = vector4(col,1.0)
   
end def
What the above source code is supposed to do:
Image

What it actually does:Image
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: possible bug in FreeBASIC

Post by D.J.Peters »

It's not a part of FreeBASIC maybe karma not a bug !
if you tell peoples on youtube the shadertoy.com stuff is your work ;-)

Joshy
fatman2021
Posts: 215
Joined: Dec 14, 2013 0:43

Re: possible bug in FreeBASIC

Post by fatman2021 »

D.J.Peters wrote: Jul 07, 2022 2:55 It's not a part of FreeBASIC maybe karma not a bug !
if you tell peoples on youtube the shadertoy.com stuff is your work ;-)

Joshy
If you bothered to read the video description, you would clearly see that I go out of my way to show that is not the case.
caseih
Posts: 2157
Joined: Feb 26, 2007 5:32

Re: possible bug in FreeBASIC

Post by caseih »

fatman2021 wrote: Jul 07, 2022 3:16If you bothered to read the video description, you would clearly see that I go out of my way to show that is not the case.
What video description? All I see was the shader code (not sure what dialect) and two images.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: possible bug in FreeBASIC

Post by dodicat »

That yellowish colour looks like you are out of the 0 to 255 range in one or more of the three rgb colours.
similarISH

Code: Select all


Function map(a As Double,b As Double,x As Double,c As Double,d As Double) As Double
      Return ((d)-(c))*((x)-(a))/((b)-(a))+(c)
End Function

Function haversineISH(x As Double) As Double
      Return map(0,1,(1-Cos(x))/2,.5,1)
End Function

Function rainbowISH( x As Single,set As boolean = false ) As Ulong 'idea from bluatigro
      Static As Double pi=4*Atn(1)
      Static  As Double kr,kg,kb
      If set=true Then kr=0:kg=0:kb=0:Return 0
      kr+=.0088
      kg+=.0077
      kb+=.0099
      #define rad(n) (pi/180)*(n)
      Dim As Ulong r , g , b
      r = Sin( rad( x ) ) * 127 + 128
      r=haversineISH(kr)*r
      g = Sin( rad( x - 120 ) ) * 127 + 128
       g=haversineISH(kg)*g
      b = Sin( rad( x + 120 ) ) * 127 + 128
      b=haversineISH(kb)*b
      Return Rgb( r And 255 , g And 255 , b And 255 )
End Function


Sub filter(i As Any Ptr,n As Long)
    Dim As Integer ix,iy
    Imageinfo i,ix,iy
 Dim As Long p(0 To 4)
    For k As Long=1 To n
    For x As Long=1 To ix-2
        For y As Long=1 To iy-2
            Var r=0
            Var g=0
            Var b=0
            p(0)=Point(x,y,i)
            p(1)=Point(x,y-1,i)
            p(2)=Point(x+1,y,i)
            p(3)=Point(x,y+1,i)
            p(4)=Point(x-1,y,i)
            For n As Long=0 To 4
                r+=Cast(Ubyte Ptr,@p(n))[2]
                g+=Cast(Ubyte Ptr,@p(n))[1]
                b+=Cast(Ubyte Ptr,@p(n))[0]
            Next
            r/=5
            g/=5
            b/=5
            Pset i,(x,y),Rgb(r,g,b)
        Next y
    Next x
Next k
End Sub


Screen 20,32,,64
Dim As Any Ptr im=Imagecreate(1024,768,0)
Dim As Ulong colour
Dim As Double xpos,ypos
Dim As Ubyte r,g,b,a

For xx As Long=0 To 1024
      Var ps=map(0,1024,xx,80,400)
       colour=rainbowISH(ps)
      For yy As Long=0 To 768\2
            r= Cptr(Ubyte Ptr,@colour)[2] 
            g= Cptr(Ubyte Ptr,@colour)[1] 
            b= Cptr(Ubyte Ptr,@colour)[0]
            a=map(768\2,0,yy,0,255)
            Pset im,(xx,yy),Rgba(r,g,b,a)
      Next yy
Next xx
rainbowISH(0,true)
For xx As Long=0 To 1024
      Var ps=map(0,1024,xx,80,400)
      colour=rainbowISH(ps)
      r= Cptr(Ubyte Ptr,@colour)[2] 
      g= Cptr(Ubyte Ptr,@colour)[1] 
      b= Cptr(Ubyte Ptr,@colour)[0]
      Var rval=map(0,255,r,760,400)
      Var rad=map(0,255,r,1,4)
      Circle im,(xx,rval),rad,Rgb(255,0,0),,,,f
      Var gval=map(0,255,g,760,400)
      rad=map(0,255,g,1,4)
      Circle im,(xx,gval),rad,Rgb(0,255,0),,,,f
      Var bval=map(0,255,b,760,400)
      rad=map(0,255,b,1,4)
      Circle im,(xx,bval),rad,Rgb(0,0,255),,,,f
Next xx
filter(im,5)
Put(0,0),im,Pset

Sleep
Imagedestroy(im) 
fatman2021
Posts: 215
Joined: Dec 14, 2013 0:43

Re: possible bug in FreeBASIC

Post by fatman2021 »

dodicat wrote: Jul 07, 2022 11:18 That yellowish colour looks like you are out of the 0 to 255 range in one or more of the three rgb colours.
similarISH

Code: Select all


Function map(a As Double,b As Double,x As Double,c As Double,d As Double) As Double
      Return ((d)-(c))*((x)-(a))/((b)-(a))+(c)
End Function

Function haversineISH(x As Double) As Double
      Return map(0,1,(1-Cos(x))/2,.5,1)
End Function

Function rainbowISH( x As Single,set As boolean = false ) As Ulong 'idea from bluatigro
      Static As Double pi=4*Atn(1)
      Static  As Double kr,kg,kb
      If set=true Then kr=0:kg=0:kb=0:Return 0
      kr+=.0088
      kg+=.0077
      kb+=.0099
      #define rad(n) (pi/180)*(n)
      Dim As Ulong r , g , b
      r = Sin( rad( x ) ) * 127 + 128
      r=haversineISH(kr)*r
      g = Sin( rad( x - 120 ) ) * 127 + 128
       g=haversineISH(kg)*g
      b = Sin( rad( x + 120 ) ) * 127 + 128
      b=haversineISH(kb)*b
      Return Rgb( r And 255 , g And 255 , b And 255 )
End Function


Sub filter(i As Any Ptr,n As Long)
    Dim As Integer ix,iy
    Imageinfo i,ix,iy
 Dim As Long p(0 To 4)
    For k As Long=1 To n
    For x As Long=1 To ix-2
        For y As Long=1 To iy-2
            Var r=0
            Var g=0
            Var b=0
            p(0)=Point(x,y,i)
            p(1)=Point(x,y-1,i)
            p(2)=Point(x+1,y,i)
            p(3)=Point(x,y+1,i)
            p(4)=Point(x-1,y,i)
            For n As Long=0 To 4
                r+=Cast(Ubyte Ptr,@p(n))[2]
                g+=Cast(Ubyte Ptr,@p(n))[1]
                b+=Cast(Ubyte Ptr,@p(n))[0]
            Next
            r/=5
            g/=5
            b/=5
            Pset i,(x,y),Rgb(r,g,b)
        Next y
    Next x
Next k
End Sub


Screen 20,32,,64
Dim As Any Ptr im=Imagecreate(1024,768,0)
Dim As Ulong colour
Dim As Double xpos,ypos
Dim As Ubyte r,g,b,a

For xx As Long=0 To 1024
      Var ps=map(0,1024,xx,80,400)
       colour=rainbowISH(ps)
      For yy As Long=0 To 768\2
            r= Cptr(Ubyte Ptr,@colour)[2] 
            g= Cptr(Ubyte Ptr,@colour)[1] 
            b= Cptr(Ubyte Ptr,@colour)[0]
            a=map(768\2,0,yy,0,255)
            Pset im,(xx,yy),Rgba(r,g,b,a)
      Next yy
Next xx
rainbowISH(0,true)
For xx As Long=0 To 1024
      Var ps=map(0,1024,xx,80,400)
      colour=rainbowISH(ps)
      r= Cptr(Ubyte Ptr,@colour)[2] 
      g= Cptr(Ubyte Ptr,@colour)[1] 
      b= Cptr(Ubyte Ptr,@colour)[0]
      Var rval=map(0,255,r,760,400)
      Var rad=map(0,255,r,1,4)
      Circle im,(xx,rval),rad,Rgb(255,0,0),,,,f
      Var gval=map(0,255,g,760,400)
      rad=map(0,255,g,1,4)
      Circle im,(xx,gval),rad,Rgb(0,255,0),,,,f
      Var bval=map(0,255,b,760,400)
      rad=map(0,255,b,1,4)
      Circle im,(xx,bval),rad,Rgb(0,0,255),,,,f
Next xx
filter(im,5)
Put(0,0),im,Pset

Sleep
Imagedestroy(im) 
It works great. Thanks
fatman2021
Posts: 215
Joined: Dec 14, 2013 0:43

Re: possible bug in FreeBASIC [SOLVED]

Post by fatman2021 »

Image
Post Reply