Around the Sphere build 2020-09-22

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Roland Chastain
Posts: 993
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: Around the Sphere build 2020-09-22

Post by Roland Chastain »

UEZ wrote:I'm not aware that I can upload files to the (German?) FB Portal. All the better if I could.
Yes, I speak of the german FB portal. See at the bottom of this page. Your programs could be located, for example, in the Demos directory.

You could even (but it's another thing) ask to Sebastian a user domain like this one.

Regards.

Roland

P.-S. If you just want to upload code, you can also use this page.
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Around the Sphere build 2020-09-22

Post by badidea »

File encoding needs to be ISO-8859-1, not UTF-8. Or at least, when I set that in Geany, it works.
And fTimer should to be double.
Roland Chastain
Posts: 993
Joined: Nov 24, 2011 19:49
Location: France
Contact:

Re: Around the Sphere build 2020-09-22

Post by Roland Chastain »

badidea wrote:File encoding needs to be ISO-8859-1, not UTF-8. Or at least, when I set that in Geany, it works.
And fTimer should to be double.
Yes, it works for me too.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Around the Sphere build 2020-09-22

Post by dodicat »

I cannot get transparency on an openGL texture (yet), but I am working on it.
So the text is on a strip (which should be transparent, but I am fed up messing about just now)

Code: Select all


#Include Once "GL/glu.bi"
#include Once "GL/glext.bi"
#include "fbgfx.bi"

Dim Shared LightDiffuse(0 To 3) As Single => {0.7, 0.7, 0.7, 1.0} 
Dim Shared LightPosition(0 To 3) As Single => {0.0 , 0.0 , 1.0, 1.0}
Dim Shared As Integer xres,yres
xres=1024
yres=768
Screenres xres,yres,32,,2 

Dim Shared As GLuint tex(1 To 52+1)

#ifdef __FB_WIN32__
Function speak(text As String) As Long
    Dim As String x="mshta vbscript:Execute(""CreateObject(""""SAPI.SpVoice"""").Speak("""""+text+""""")(window.close)"")"
    Shell x
    Return 1
End Function
#endif

Sub drawstringgfx(Byval xpos As Long,Byval ypos As Long,Byref text As String,Byval colour As Ulong,Byval size As Single,Byref im As Any Pointer=0)
    Type D2
        As Double x,y
        As Ulong col
    End Type
    size=Abs(size)
    Static As d2 XY()
    Static As Long runflag
    If runflag=0 Then   
        Redim  XY(128,127)
        Screen 8
        Width 640\8,200\16 
        Dim As Ulong Pointer img
        Dim count As Long
        For ch As Long=1 To 127
            img=Imagecreate(9,17)
            Draw String img,(1,1),Chr(ch)
            For x As Long=1 To 8  
                For y As Long=1 To 16
                    If Point(x,y,img)<>0 Then
                        count=count+1
                        XY(count,ch)=Type<D2>(x,y)
                    End If 
                Next y
            Next x
            count=0
            Imagedestroy img
        Next ch
        runflag=1 
    End If
    If size=0 Then Exit Sub
    Dim As D2 np,t
    #macro Scale(p1,p2,d)
    np.col=p2.col
    np.x=d*(p2.x-p1.x)+p1.x
    np.y=d*(p2.y-p1.y)+p1.y
    #endmacro
    Dim As D2 c=Type<D2>(xpos,ypos)
    Dim As Long dx=xpos,dy=ypos,f
    If Abs(size)=1.5 Then f=3 Else f=2
    For z6 As Long=1 To Len(text)
        Var asci=text[z6-1]
        For _x1 As Long=1 To 64*2
            t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)         
            Scale(c,t,size)
            If XY(_x1,asci).x<>0 Then 
                If size>1 Then 
                    Line im,(np.x-size/f,np.y-size/f)-(np.x+size/f,np.y+size/f),np.col,bf
                Else
                    Pset im,(np.x,np.y),np.col
                End If
            End If
        Next _x1
        dx=dx+8
    Next z6 
End Sub
Sub initgfx Constructor 
    drawstringgfx(0,0,"",0,0)
    Screen 0
End Sub

Function Filter(Byref tim As Ulong Pointer,_
    Byval rad As Single,_
    Byval destroy As Long=1,_
    Byval fade As Long=0) As Ulong Pointer
    #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
    If fade<0 Then fade=0:If fade>100 Then fade=100
    Type p2
        As Long x,y
        As Ulong col
    End Type
    #macro p_point(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    (colour)=*pixel
    #endmacro
    #macro ppset(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*4
    *pixel=(colour)
    #endmacro
    #macro average()
    ar=0:ag=0:ab=0:inc=0
    xmin=x:If xmin>rad Then xmin=rad
    xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
    ymin=y:If ymin>rad Then ymin=rad
    ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
    For y1 As Long=-ymin To ymax
        For x1 As Long=-xmin To xmax
            inc=inc+1 
            ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
            ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
            ab=ab+(NewPoints(x+x1,y+y1).col And 255)
        Next x1
    Next y1
    If fade=0 Then
        averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
    Else
        averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
    End If
    #endmacro
    Dim As Single fd=map(0,100,fade,1,0)
    Dim As Integer _x,_y
    Imageinfo tim,_x,_y
    Dim  As Ulong Pointer im=Imagecreate(_x,_y)
    Dim As Integer pitch
    Dim  As Any Pointer row
    Dim As Ulong Pointer pixel
    Dim As Ulong col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As Long=0 To (_y)-1
        For x As Long=0 To (_x)-1
            p_point(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Ulong averagecolour
    Dim As Long ar,ag,ab
    Dim As Long xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As Long=0 To _y-1
        For x As Long=0 To _x-1  
            average()
            ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour) 
        Next x
    Next y
    If destroy Then Imagedestroy tim: tim = 0
    Function= im
End Function

Function settexture(image As Any Ptr) As gluint
    Dim As gluint texture
    glGenTextures(1, @texture)
    glBindTexture( GL_TEXTURE_2D, texture )
    glTexImage2d( GL_TEXTURE_2D, 0, GL_RGBA, Cast(fb.image Ptr, image)->Width, Cast(fb.image Ptr, image)->height, 0, GL_BGRA, GL_UNSIGNED_BYTE, image+Sizeof(fb.image) )
    glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST )
    glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST )
    glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_DECAL)
    Return texture
End Function


Sub GLsetup
    glViewport 0,0,xres,yres
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 45,xres/yres,1,100
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glShadeModel GL_SMOOTH
    glClearColor 0,.4,1,0
    
    glClearDepth 1
    glEnable GL_DEPTH_TEST
    glDepthFunc GL_LEQUAL
    glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST
    glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA)'''
    glEnable GL_ALPHA
    glEnable GL_BLEND
    
    glLightfv GL_LIGHT1, GL_DIFFUSE, @LightDiffuse(0)
    glLightfv GL_LIGHT1, GL_POSITION, @LightPosition(0)
    glEnable GL_LIGHT1
    
    'Enable lighting
    glEnable GL_LIGHTING
    glEnable GL_COLOR_MATERIAL
End Sub


'MY OWN ROTATE TO SET UP THE FACES
Type v3
    As Single x,y,z
End Type
Operator + (v1 As V3,v2 As V3) As V3
Return Type(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator * (f As Single,v1 As V3) As V3 'scalar*V3
Return Type(f*v1.x,f*v1.y,f*v1.z)
End Operator

Function RotatePoint(c As V3,p As v3,angle As V3,scale As V3=Type<V3>(1,1,1)) As V3
    Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
    Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
    Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
    Return Type<V3>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
    (scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
    (scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z)
End Function

'SET UP THE RINGFACES
Redim Shared As V3 a(1 To 4)
Dim Shared As V3 normals(1 To 52+1)

Dim As V3 ctr=Type(0,0,0)            'rotate about gl origin
Dim As Double z=1.207106781186547*2+14.4-.3  'z value of first face
Dim As Double r=2*4*Atn(1)/52 

'first face (FRONT)
glTexCoord2f( 1,1)
a(1)=Type( 1, 1, z)
glTexCoord2f( 0,1)
a(2)=Type(-1, 1, z)
glTexCoord2f( 0,0)
a(3)=Type(-1,-1, z)
glTexCoord2f( 1,0)
a(4)=Type( 1,-1, z)

Var c=.5*(a(1)+a(3))
normals(1)=c
Dim As v3 sc=(1,1,1)
Dim Shared As v3 centroid(1 To 52+1),rt(1 To 52+1)
centroid(1)=Type(0,0,z)
For z As Long=1 To 52'7
    Var n=Ubound(a)
    Redim Preserve a(1 To Ubound(a)+4)
    'rotate the faces, four corners at a time around (0,0,0), angle r
    a(n+1)=RotatePoint(ctr,a(n+1-4),Type(0,r,0),sc)
    a(n+2)=RotatePoint(ctr,a(n+2-4),Type(0,r,0),sc)
    a(n+3)=RotatePoint(ctr,a(n+3-4),Type(0,r,0),sc)
    a(n+4)=RotatePoint(ctr,a(n+4-4),Type(0,r,0),sc)
    c=.5*(a(n+1)+a(n+3))
    normals(z+1)=c
    centroid(z+1)=.5*(a(n+1)+a(n+3))
Next z
For n As Long=1 To 52
    Var l=Sqr(normals(n).x^2+normals(n).y^2 +normals(n).z^2)
    normals(n)=(1/l)*normals(n) 'normalize
Next n

Sub drawstring(xpos As Long,ypos As Long,text As String ,col As Ulong,size As Single,xres As Long,yres As Long) Export
    
    glMatrixMode GL_PROJECTION 'save projection
    glPushMatrix
    glMatrixMode GL_MODELVIEW
    glPushMatrix
    
    glMatrixMode GL_PROJECTION 'make ortho
    glLoadIdentity
    glOrtho 0, xres, yres, 0,-1, 1
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    #define Red(c) ((c) Shr 16 And 255)
    #define Green(c) ((c) Shr  8 And 255)
    #define Blue(c) ((c) And 255)
    #define Alph(c) ((c) Shr 24)
    glColor4ub Red(col),Green(col),Blue(col),alph(col)
    glend
    glpointsize(1.1*size)
    glBegin (GL_POINTS)
    Type D2
        As Single x,y
    End Type
    Static As d2 cpt(),XY()
    Static As Long runflag
    If runflag=0 Then   
        Redim  XY(128,127)
        Redim cpt(1 To 64*2)
        Screen 8
        Width 640\8,200\16
        Dim As Ulong Pointer img
        Dim count As Long
        For ch As Long=1 To 127
            img=Imagecreate(640,200)
            Draw String img,(1,1),Chr(ch)
            For x As Long=1 To 8 
                For y As Long=1 To 16
                    If Point(x,y,img)<>0 Then
                        count=count+1
                        XY(count,ch)=Type<D2>(x,y)
                    End If
                Next y
            Next x
            count=0
            Imagedestroy img
        Next ch
        runflag=1
    End If
    If size=0 Then Exit Sub
    Dim As D2 np,t
    #macro Scale(p1,p2,d)
    np.x=d*(p2.x-p1.x)+p1.x
    np.y=d*(p2.y-p1.y)+p1.y
    #endmacro
    
    Dim As D2 c=Type<D2>(xpos,ypos)
    Dim As Long dx=xpos,dy=ypos
    For z6 As Long=1 To Len(text)
        Var asci=text[z6-1]
        For _x1 As Long=1 To 64*2
            t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy)         
            Scale(c,t,size)
            cpt(_x1)=np
            
            If XY(_x1,asci).x<>0 Then
                If Abs(size)>0 Then
                    glVertex3f (cpt(_x1).x,(cpt(_x1).y),0)
                End If
            End If
        Next _x1
        dx=dx+8
    Next z6
    glend
    glMatrixMode GL_PROJECTION 'restore 
    glPopMatrix
    glMatrixMode GL_MODELVIEW
    glPopMatrix
End Sub

Sub inittext Constructor
    drawstring(0,0,"",0,0,0,0)
End Sub

Sub DrawFaces(Byval rotangle As Single,x As Single,y As Single,Byval Z As Single)
    glEnable( GL_TEXTURE_2D )
    Dim As Single pi=4*Atn(1)
    glLoadIdentity()
    glTranslatef(x,y,Z-5)
    glrotatef(10,1,0,0)
    glRotatef(rotangle,0,1,0)           ' Rotate
    Dim As Long n
    glcolor4f(0,0,0,1)
    For z As Long=1 To 52+1
        glBindTexture(GL_TEXTURE_2D, tex(z))
        glBegin(GL_QUADS)
        rt(z)=RotatePoint(Type(0,0,0),centroid(z),Type(0,rotangle*pi/180,0),Type(1,1,1))
        glNormal3f normals(z).x,normals(z).y,normals(z).z
        glTexCoord2f( 1,0)'1 0
        glVertex3f(a(n+1).x,a(n+1).y,a(n+1).z)
        glTexCoord2f( 0,0)'0 0
        glVertex3f(a(n+2).x,a(n+2).y,a(n+2).z)
        glTexCoord2f(0,1)'0 1
        glVertex3f(a(n+3).x,a(n+3).y,a(n+3).z)
        glTexCoord2f(1,1)'1 1
        glVertex3f(a(n+4).x,a(n+4).y,a(n+4).z)
        n=n+4
        glend
    Next z
    glend
    gldisable( GL_TEXTURE_2D )
End Sub

Sub Cube(Byref rotangle As Single)
    Var k=5
    glLoadIdentity()
    glTranslatef(0,-.7,-32)
    glRotatef(rotangle,1,1,1)           ' Rotate
    glBegin(GL_QUADS)
    
    glcolor4ub 255,0,0,255
    glNormal3f 0,1,0
    glVertex3f( K*1.0, K*1.0,-K*1.0)            ' Top right of the quad (top)
    glVertex3f(-K*1.0, K*1.0,-K*1.0)            ' Top left of the quad (top)
    glVertex3f(-K*1.0, K*1.0, K*1.0)            ' Bottom left of the quad (top)
    glVertex3f( K*1.0, K*1.0, K*1.0)            ' Bottom right of the quad (top)
    
    glcolor4ub 255,100,0,255
    glNormal3f 0,-1,0
    glVertex3f( K*1.0,-K*1.0, K*1.0)            ' Top right of the quad (bottom)
    glVertex3f(-K*1.0,-K*1.0, K*1.0)            ' Top left of the quad (bottom)
    glVertex3f(-K*1.0,-K*1.0,-K*1.0)            ' Bottom left of the quad (bottom)
    glVertex3f( K*1.0,-K*1.0,-K*1.0)            ' Bottom right of the quad (bottom)
    
    glcolor4ub 255,0,255,255
    glNormal3f 0,0,1
    glVertex3f( K*1.0, K*1.0, K*1.0)            ' Top right of the quad (front)
    glVertex3f(-K*1.0, K*1.0, K*1.0)            ' Top left of the quad (front)
    glVertex3f(-K*1.0,-K*1.0, K*1.0)            ' Bottom left of the quad (front)
    glVertex3f( K*1.0,-K*1.0, K*1.0)            ' Bottom right of the quad (front)
    
    glcolor4ub 0,0,200,255
    glNormal3f 0,0,-1
    glVertex3f( K*1.0,-K*1.0,-K*1.0)            ' Bottom left of the quad (back)
    glVertex3f(-K*1.0,-K*1.0,-K*1.0)            ' Bottom right of the quad (back)
    glVertex3f(-K*1.0, K*1.0,-K*1.0)            ' Top right of the quad (back)
    glVertex3f( K*1.0, K*1.0,-K*1.0)            ' Top left of the quad (back)
    
    glcolor4ub 0,255,0,255
    glNormal3f -1,0,0
    glVertex3f(-K*1.0, K*1.0, K*1.0)            ' Top right of the quad (left)
    glVertex3f(-K*1.0, K*1.0,-K*1.0)            ' Top left of the quad (left)
    glVertex3f(-K*1.0,-K*1.0,-K*1.0)            ' Bottom left of the quad (left)
    glVertex3f(-K*1.0,-K*1.0, K*1.0)            ' Bottom right of the quad (left)
    
    glcolor4ub 255,0,100,255
    glNormal3f 1,0,0
    glVertex3f( K*1.0, K*1.0,-K*1.0)            ' Top right of the quad (right)
    glVertex3f( K*1.0, K*1.0, K*1.0)            ' Top left of the quad (right)
    glVertex3f( K*1.0,-K*1.0, K*1.0)            ' Bottom left of the quad (right)
    glVertex3f( K*1.0,-K*1.0,-K*1.0)
    glend
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long) 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



Dim As Any Ptr face(52)

Dim As String s= " Around the Sphere started by UEZ. "
s+="OpenGL on a ring "
s+=s

For n As Long=1 To Ubound(face)
    face(n)=Imagecreate(128,128,Rgba(200,200,200,255))
    Drawstringgfx(10,20,Mid(s,n,1),Rgba(0,0,0,255),6,face(n))
    face(n)=filter(face(n),1)
Next n

For n As Long=1 To 52
    tex(n)=settexture(face(n))
Next n


glsetup

Dim As Long fps
Dim As Single angle3
Dim As String ink

Windowtitle "---"
Dim As Single zz=-30 - (xres/275)
Do
    ink=Inkey
    angle3+=3
    glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)
    drawstring(20,50,"fps  = " + Str(fps) ,Rgb(0,0,0),1,xres,yres)
    drawstring(20,80,"Press <esc> to end . . . ",Rgb(0,0,0),1,xres,yres)
    glEnable (GL_CULL_FACE)
    cube(angle3/5)
    gldisable (GL_CULL_FACE)
    DrawFaces(-angle3/10,0,0,zz)
    Flip
    Sleep regulate(60,fps),1
Loop Until ink=Chr(27)
#ifdef __FB_WIN32__
speak ("goodbye")
#endif

For a As Longint = 1 To 52
    Imagedestroy face(a)
Next

End
 
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-22

Post by UEZ »

badidea wrote:File encoding needs to be ISO-8859-1, not UTF-8. Or at least, when I set that in Geany, it works.
And fTimer should to be double.
I can vague remember that we had this discussion already some times ago because of Base128 en-/decoding issues.
Roland Chastain wrote:Yes, it works for me too.
Good to read. ;-)
dodicat wrote:I cannot get transparency on an openGL texture (yet), but I am working on it.
So the text is on a strip (which should be transparent, but I am fed up messing about just now)
Thanks for your OpenGL example. Looks very nice and I like the opaque strip version. It looks cool, too. Maybe you could set alpha channel of the cube to a lower value so that the strip shimmer a little bit through the cube.
Unfortunately I've no skills in OpenGL to provide an answer how to get the strip transparent...
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: Around the Sphere build 2020-09-22

Post by jj2007 »

When copied from the first post, it doesn't work - no compiler error, but the exe just closes immediately. When downloaded from the Mediafile link, it compiles and runs fine - congrats, it's a very nice example!
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Around the Sphere build 2020-09-22

Post by dodicat »

Even using notepad to load and run, the file all is OK here.
Are you having compiler / ide problems again jj2007?
If you are using new builds then I guess you are, I am using the official build with gcc 5.2.0 .
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Around the Sphere build 2020-09-22

Post by badidea »

UEZ wrote:
badidea wrote:File encoding needs to be ISO-8859-1, not UTF-8. Or at least, when I set that in Geany, it works.
And fTimer should to be double.
I can vague remember that we had this discussion already some times ago because of Base128 en-/decoding issues.
Yes, here: Twister Effect build 2020-04-15
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Around the Sphere build 2020-09-22

Post by UEZ »

badidea wrote:
UEZ wrote:
badidea wrote:File encoding needs to be ISO-8859-1, not UTF-8. Or at least, when I set that in Geany, it works.
And fTimer should to be double.
I can vague remember that we had this discussion already some times ago because of Base128 en-/decoding issues.
Yes, here: Twister Effect build 2020-04-15
Well, on the other hand UTF-8 seems to work, too as dodicat confirms because this site seems to display text in UTF-8 char set. Additionally, I'm using in the IDE UTF-8 or ANSI usually and UTF-8 seems to work properly with base128 char set.
jj2007
Posts: 2326
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: Around the Sphere build 2020-09-22

Post by jj2007 »

dodicat wrote:Are you having compiler / ide problems again jj2007?
As written above, the downloaded source compiles and runs perfectly. It is only the copy & paste version that didn't run. Now I tried again, and it works - mysteries of Windows...
Post Reply