TinyGL for FreeBASIC.

External libraries (GTK, GSL, SDL, Allegro, OpenGL, etc) questions.
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

TinyGL for FreeBASIC.

Postby D.J.Peters » Aug 03, 2016 6:47

download: fbTinyGL.zip Nov 01, 2017

Joshy
readme.txt wrote:fbTinyGL is based on TinyGL (C) 1997-1998 Fabrice Bellard

homepage: http://bellard.org/TinyGL/

original source code: http://bellard.org/TinyGL/TinyGL-0.4.tar.gz

changes:
First I made fbTinyGL as a one *.c file version.
I build it static and dynamic for Windows and Linux (32 and 64-bit)
Internal it's a 16-bit only render system now.
All pixel buffer stuff follows the fbgfx pitch rule (16 byte row allinged).
All drawing method exist in three versions now. (with z-buffer enabled/disabled and GL_BLEND enabled/disabled)
All pointer stuff is 64-bit compatible now.

Added:
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_DONT_CARE / GL_FASTEST / GL_NICEST)
glError()
glGetString(GL_VENDOR / GL_RENDERER / GL_VERSION)
glEnable(GL_BLEND) (a simple transparency mode pink pixels in textures are ignored)
glDrawArrays()
glArrayElements()
glVertexPointer()
glColorPointer()
glNormalPointer()
glTexCoordPointer()
glEdgeFlagPointer()

glXXXPointer all OpenGL legal data types are supported now:
GL_BYTE, GL_SHORT, GL_INT, GL_FLOAT, GL_DOUBLE
GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT, GL_UNSIGNED_INT

Fixed some bugs:
16 bit to RGB/RGBA
all stride params are bytes offsets now
and other things I can't remember
Last edited by D.J.Peters on Nov 01, 2017 1:22, edited 6 times in total.
dodicat
Posts: 5757
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: TinyGL for FreeBASIC.

Postby dodicat » Aug 03, 2016 10:06

Thank you D.J.Peters.
I shall try to re-create Albert's Five Deck Maverick.

I don't want to use your dll, but if I did want it and don't use
#define LINK_STATIC
The dll can't be found.
Win 10 64 bit system using the 32 bit compiler and the 64 bit compiler.

Also, to load windows.bi with tinygl.bi, your
sub SwapBuffers(g as GFX_CONTEXT ptr)
clashes. (I have renamed it swap_buffers).

Do you have the alternative to glortho ?
Some texture subs are unavailable, here is the texturing routine from Albert's Five deck maverick:
http://www.freebasic.net/forum/viewtopic.php?f=3&t=16207&start=5145

Also glLineWidth(~), have you an alternative?

The Five deck maverick may take a while.
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Re: TinyGL for FreeBASIC.

Postby D.J.Peters » Aug 03, 2016 13:19

TinyGL and fbTinyGL is only a small subset of OpenGL in software.

I used it primary on the Beagle Bone Black and my Raspbery PI's in the past and on PC's also.

There is curently no glTexParameter or glTexEnv what you get is in fbTinyGL.bi (not more nor less)

Internal it's:
GL_TEXTURE_MAG_FILTER = GL_NEAREST
GL_TEXTURE_MIN_FILTER = GL_NEAREST
GL_TEXTURE_WRAP_T = GL_REPEAT
GL_TEXTURE_WRAP_D = GL_REPEAT


Joshy

here are glOrtho()

Code: Select all

' b = bottom t = top
' l = left r = right
' n = near f = far
' m = m4x4 pointer
sub glOrtho(byval b as single, byval t as single, _
            byval l as single, byval r as single, _
            byval n as single, byval f as single, _
            byval m as single ptr)
  dim as single rl=r-l, tb=t-b, fn=f-n
  m[0]=2/rl : m[4]=0    : m[ 8]= 0    : m[12]=-(r+l)/rl
  m[1]=0    : m[5]=2/tb : m[ 9]= 0    : m[13]=-(t+b)/tb
  m[2]=0    : m[6]=0    : m[10]=-2/fn : m[14]=-(f+n)/fn
  m[3]=0    : m[7]=0    : m[11]= 0    : m[15]= 1
end sub
dodicat
Posts: 5757
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: TinyGL for FreeBASIC.

Postby dodicat » Aug 03, 2016 16:12

OK D.J.Peters
You have fb screen with opengl, no need for ortho.
Your lib is very neat.
Here is Albert's maverick game running.
Perhaps he will alter it a bit if he uses your lib.

Code: Select all

#include once "windows.bi"
#include once "win/winnt.bi"
#include once "win/objbase.bi"
#inclib "ole32"
'#Include Once "glu_.bi"
#define LINK_STATIC
#include once "TinyGL.bi"
#include "windows.bi"
#include "fbgfx.bi"
#define gluint ulong
#define glvertex2d glvertex2f

Dim shared IID_ISpVoice As GUID => ( &H6c44df74, &H72b9, &H4992, {&Ha1, &Hec, &Hef, &H99, &H6e, &H04, &H22, &Hd4 })
Dim shared CLSID_SpVoice As GUID => ( &H96749377, &H3391, &H11d2, {&H9e, &He3, &H00, &Hc0, &H4f, &H79, &H73, &H96 })

Type ISpVoiceVtbl_ As ISpVoiceVtbl

Type ISpVoice
    lpVtbl As ISpVoiceVtbl_ Ptr
End Type

#define SPF_DEFAULT 0

Type ISpVoiceVtbl
rem iunknown
    QueryInterface As Function(Byval As ISpVoice Ptr, Byval As IID Ptr, Byval As Any Ptr) As HRESULT
    AddRef As Function(Byval As ISpVoice Ptr) As ULONG
    Release As Function(Byval As ISpVoice Ptr) As ULONG

rem stubs
    SetNotifySink As Function() As HRESULT
    SetNotifyWindowMessage As Function() As HRESULT
    SetNotifyCallbackFunction As Function() As HRESULT
    SetNotifyCallbackInterface As Function() As HRESULT
    SetNotifyWin32Event As Function() As HRESULT
    WaitForNotifyEvent As Function() As HRESULT
    GetNotifyEventHandle As Function() As HRESULT
    SetInterest As Function() As HRESULT
    GetEvents As Function() As HRESULT
    GetInfo As Function() As HRESULT
    SetOutput As Function() As HRESULT
    GetOutputObjectToken As Function() As HRESULT
    GetOutputStream As Function() As HRESULT

rem done
    Pause As Function(Byval As ISpVoice Ptr) As HRESULT
    Resume As Function(Byval As ISpVoice Ptr) As HRESULT

rem stubs
    SetVoice As Function() As HRESULT
    GetVoice As Function() As HRESULT

rem done
    Speak As Function(Byval As ISpVoice Ptr, Byval pwcs As Wstring Ptr, Byval dwFlags As DWORD, Byval pulStreamNumber As ULONG Ptr) As HRESULT

rem stubs
    SpeakStream As Function() As HRESULT
    GetStatus As Function() As HRESULT
    Skip As Function() As HRESULT
    SetPriority As Function() As HRESULT
    GetPriority As Function() As HRESULT
    SetAlertBoundary As Function() As HRESULT
    GetAlertBoundary As Function() As HRESULT

rem done
    SetRate As Function(Byval As ISpVoice Ptr, Byval RateAdjust As Integer) As HRESULT
    GetRate As Function(Byval As ISpVoice Ptr, Byval RateAdjust As Integer Ptr) As HRESULT
    SetVolume As Function(Byval As ISpVoice Ptr, Byval usVolume As Ushort) As HRESULT
    GetVolume As Function(Byval As ISpVoice Ptr, Byval pusVolume As Ushort Ptr) As HRESULT
    WaitUntilDone As Function(Byval As ISpVoice Ptr, Byval msTimeout As ULONG) As HRESULT

rem stubs
    SetSyncSpeakTimeout As Function() As HRESULT
    GetSyncSpeakTimeout As Function() As HRESULT
    SpeakCompleteEvent As Function() As HRESULT
    IsUISupported As Function() As HRESULT
    DisplayUI As Function() As HRESULT
End Type

sub Speak ( byref tstring as string, byval rate as integer = 0 )
    Dim voices As ISpVoice Ptr
        CoInitialize(NULL)
        CoCreateInstance(@CLSID_SpVoice, NULL, CLSCTX_ALL, @IID_ISpVoice, Cast (Any Ptr, @voices))
        voices->lpVtbl->SetRate(voices, rate)
        voices->lpVtbl->Speak(voices, tString, 1, NULL)
        voices->lpVtbl->WaitUntilDone(voices, INFINITE)
        voices->lpVtbl->Release(voices)
        CoUninitialize()
end sub

sub Speak_No_Rate ( byval param as any ptr )
    dim as zstring ptr tstring = Cast(zstring ptr, param)
    ? tstring
   
    Dim voices As ISpVoice Ptr
        CoInitialize(NULL)
        CoCreateInstance(@CLSID_SpVoice, NULL, CLSCTX_ALL, @IID_ISpVoice, Cast (Any Ptr, @voices))
        voices->lpVtbl->SetRate(voices, -2)
        voices->lpVtbl->Speak(voices, *tString, SPF_DEFAULT, NULL)
        voices->lpVtbl->WaitUntilDone(voices, INFINITE)
        voices->lpVtbl->Release(voices)
        CoUninitialize()
end sub
'===============================================================================



#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
#define Frange(f,l) Rnd*((l)-(f))+(f)

const xres=800
const yres=600
screenres xres,yres,32,2
'screenset 0,0

Dim Shared As GLuint tex(1 To 52)
Dim Shared As Long drums(1 To 5)
Const FS_BOLD = 2
Const FS_ITALIC = 4

Sub DrawFont(Byref BUFFER As Any Ptr=0,Byval POSX As Long, Byval POSY As Long, _
    Byref FTEXT As String, Byref FNAME As String,Byval FSIZE As Long, _
    Byval FCOLOR As Ulong=Rgb(255,255,255),Byval FSTYLE As Long=0,Byval CHARSET As Long=DEFAULT_CHARSET )
   
    Static FINIT As Long
    Static As hdc THEDC
    Static As hbitmap THEBMP
    Static As Any Ptr THEPTR
    Static As fb.image Ptr FBBLK
    Static As Long TXTSZ,RESU,RESUU
    Static As hfont THEFONT
    Static As Long FW,FI,TXYY
    Static DSKWND As hwnd, DSKDC As hdc
    Static MYBMPINFO As BITMAPINFO
    Static As TEXTMETRIC MYTXINFO
    Static As SIZE TXTSIZE
    Static As RECT RCT
    Static As Ubyte Ptr ubp
    ubp=Cptr(Ubyte Ptr,@FCOLOR)
    Swap ubp[0],ubp[2]
    Dim As Ubyte alphaval =ubp[3]
    ubp[3]=0
    #define FontSize(PointSize) -MulDiv(PointSize, GetDeviceCaps(THEDC, LOGPIXELSY), 72)
   
    If FINIT = 0 Then   
        FINIT = 1   
        With MYBMPINFO.bmiheader
            .biSize = Sizeof(BITMAPINFOHEADER)
            .biWidth = 2048
            .biHeight = -513
            .biPlanes = 1
            .biBitCount = 32
            .biCompression = BI_RGB
        End With   
        DSKWND = GetDesktopWindow()
        DSKDC = GetDC(DSKWND)
        THEDC = CreateCompatibleDC(DSKDC)
        THEBMP = CreateDIBSection(THEDC,@MYBMPINFO,DIB_RGB_COLORS,@THEPTR,null,null)
        ReleaseDC(DSKWND,DSKDC)   
    End If
    If (FSTYLE And FS_BOLD) Then FW = FW_BOLD Else FW = FW_NORMAL   
    If (FSTYLE And FS_ITALIC) Then FI = True Else FI = False   
    THEFONT = CreateFont(FontSize(FSIZE),0,0,0,FW,FI,0,0,CHARSET,0,0,0,0,Cast(Any Ptr,Strptr(FNAME)))   
    SelectObject(THEDC,THEBMP)
    SelectObject(THEDC,THEFONT)
    GetTextMetrics(THEDC,@MYTXINFO)
    GetTextExtentPoint32(THEDC,Strptr(FTEXT),Len(FTEXT),@TXTSIZE)
    TXTSZ = TXTSIZE.CX
    TXYY = TXTSIZE.CY
    If (FSTYLE And FS_ITALIC) Then
        If MYTXINFO.tmOverhang Then
            TXTSZ += MYTXINFO.tmOverhang
        Else
            TXTSZ += 1+(FSIZE/2)
        End If
        TXYY += 1+(FSIZE/8)
    End If
    RCT.LEFT = 0
    RCT.TOP = 1
    RCT.RIGHT = TXTSZ
    RCT.BOTTOM = TXYY+1
    TXTSZ -= 1
    TXYY -= 1
    SetBkColor(THEDC,Rgba(255,0,255,0))
    SetTextColor(THEDC,FCOLOR)
    SystemParametersInfo(SPI_GETFONTSMOOTHING,null,@RESU,null)
    If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,False,@RESUU,null)
    ExtTextOut(THEDC,0,1,ETO_CLIPPED Or ETO_OPAQUE,@RCT,Strptr(FTEXT),Len(FTEXT),null)
    If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,True,@RESUU,null)
    FBBLK = THEPTR+(2048*4)-Sizeof(fb.image)
    FBBLK->Type = 7
    FBBLK->bpp = 4
    FBBLK->Width = 2048
    FBBLK->height = 512
    FBBLK->pitch = 2048*4
    Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),Alpha,alphaval
    DeleteObject(THEFONT)
End Sub

Function Filter(Byref tim As Uinteger Pointer,_
    byval rad As Single,_
    byval destroy As Integer=1,_
    byval fade As Integer=0) As Uinteger 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 Integer x,y
        As Uinteger 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 Integer=-ymin To ymax
        For x1 As Integer=-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 Uinteger Pointer im=Imagecreate(_x,_y)
    Dim As Integer pitch
    Dim  As Any Pointer row
    Dim As Uinteger Pointer pixel
    Dim As Uinteger col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As Integer=0 To (_y)-1
        For x As Integer=0 To (_x)-1
            p_point(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Uinteger averagecolour
    Dim As Integer ar,ag,ab
    Dim As Integer xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As Integer=0 To _y-1
        For x As Integer=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 )
    dim as integer iwidth,iheight,iBytesPerPixel
    dim as ubyte ptr pPixels
    ImageInfo image,iWidth,iHeight,iBytesPerPixel,,pPixels
glTexImage2D(GL_TEXTURE_2D, 0, iBytesPerPixel, iWidth,iHeight, 0,  GL_RGB, GL_UNSIGNED_BYTE, pPixels)
glEnable(GL_TEXTURE_2D)
    Return texture
End Function


Sub glsetup
    glShadeModel(GL_SMOOTH)                 ' Enables Smooth Color Shading
    glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST)
    glViewport(0, 0, xres, yres)       ' Set the viewport
    glMatrixMode(GL_PROJECTION)        ' Change Matrix Mode to Projection
    glLoadIdentity                     ' Reset View
    gluPerspective(45, xres/yres, 1, 100)
    glMatrixMode(GL_MODELVIEW)         ' Return to the modelview matrix
    glLoadIdentity                     '  Reset View
    glClearColor 0,.2,0,1              'background
   
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 EIGHT FACES
Redim Shared As V3 a(1 To 4) 'For starters
Dim Shared As V3 normals(1 To 52)

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

var ctx = CreateRenderContext()
var mode = GL_DONT_CARE
glHint(GL_PERSPECTIVE_CORRECTION_HINT,mode)
glsetup
'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.00,1)
Dim Shared As v3 centroid(1 To 52),rt(1 To 52)
centroid(1)=Type(0,0,z)
For z As Long=1 To 51'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(r,0,0),sc)
    a(n+2)=RotatePoint(ctr,a(n+2-4),Type(r,0,0),sc)
    a(n+3)=RotatePoint(ctr,a(n+3-4),Type(r,0,0),sc)
    a(n+4)=RotatePoint(ctr,a(n+4-4),Type(r,0,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

'sleep
'NOW WE HAVE EIGHT FACES DONE And THE NORMALS TO EACH FACE.

Sub DrawFaces(Byval rotangle As Single,x As Single,y As Single,Byval Z As Single,flag As Long=1)
    glEnable( GL_TEXTURE_2D )
    Dim As Single pi=4*Atn(1)
    glLoadIdentity()
    glTranslatef(x,y,Z)
    glRotatef(rotangle,1,0,0)           ' Rotate
    Dim As Long n=0
    Static As Long i
    i=i+1
    If i>5 Then i=1
    glcolor4f(0,0,0,1)
    For z As Long=1 To 52
        if z>1 and z<=13 then glcolor4f(1,0,0,1)
        if z>=14 and z<=26 then glcolor4f(1,0,0,1)
        if z>=27 and z<=39 then glcolor4f(0,0,0,1)
        if z>=40 and z<=52 then glcolor4f(0,0,0,1)
        glBindTexture(GL_TEXTURE_2D, tex(z))
        glBegin(GL_QUADS)
        rt(z)=RotatePoint(Type(0,0,0),centroid(z),Type(rotangle*pi/180,0,0),Type(1,1,1))
        glNormal3f normals(z).x,normals(z).y,normals(z).z
        If rt(z).z>0 Then
            If rt(z).y<5.5 And rt(z).y>-5.5 Then  '5.5 7.2
                If Abs(rt(z).y)<1 Then drums(i)=z '' A SCORE, THE DRUM IS CENTRAL
                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)
            End If
        End If
        n=n+4
        glend
    Next z
   
    glend
    gldisable( GL_TEXTURE_2D )
End Sub


Function nearest(a As Single) As Single
    Dim As Single pts(1 To 52),ctr
    For z As Single=0 To 360 Step (360/52)
        ctr+=1
        If ctr>52 Then Exit For
        pts(ctr)=z
    Next z
    For z As Long=1 To 52
        If Abs(pts(z)-a) <= 6 Then Return pts(z)'45
    Next z
End Function


dim as string card(1 to 13)
card(01) = " A"
card(02) = " 2"
card(03) = " 3"
card(04) = " 4"
card(05) = " 5"
card(06) = " 6"
card(07) = " 7"
card(08) = " 8"
card(09) = " 9"
card(10) = "10"
card(11) = " J"
card(12) = " Q"
card(13) = " K"
dim as any ptr face(52)
dim as string suit(1 to 4) = {chr(3),chr(4),chr(5),chr(6)}
dim as ubyte num=1
for n as integer=1 to ubound(face)
   
    face(n)=imagecreate(128,128,rgba(255,255,255,255))
   
    if n>=1  and n<=13 then DrawFont(face(n),10,35,str(card(num))+""+ suit(1) ,"TERMINAL",40,rgba(200,0,0,254))
    if n>=14 and n<=26 then DrawFont(face(n),10,35,str(card(num))+""+ suit(2) ,"TERMINAL",40,rgba(200,0,0,254))
    if n>=27 and n<=39 then DrawFont(face(n),10,35,str(card(num))+""+ suit(3) ,"TERMINAL",40,rgba(0  ,0,0,254))
    if n>=40 and n<=52 then DrawFont(face(n),10,35,str(card(num))+""+ suit(4) ,"TERMINAL",40,rgba(0  ,0,0,254))
   
    line face(n),(0,0)-(127,127),0,b
   face(n)=filter(face(n),1)
    num+=1
    if num=14 then num=1
   
next n

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

dim shared as string W(1 to 5 , 1 to 52)
W(1,01) = "01-H" : W(2,01) = "01-H" : W(3,01) = "01-H" : W(4,01) = "01-H" : W(5,01) = "01-H"
W(1,02) = "02-H" : W(2,02) = "02-H" : W(3,02) = "02-H" : W(4,02) = "02-H" : W(5,02) = "02-H"
W(1,03) = "03-H" : W(2,03) = "03-H" : W(3,03) = "03-H" : W(4,03) = "03-H" : W(5,03) = "03-H"
W(1,04) = "04-H" : W(2,04) = "04-H" : W(3,04) = "04-H" : W(4,04) = "04-H" : W(5,04) = "04-H"
W(1,05) = "05-H" : W(2,05) = "05-H" : W(3,05) = "05-H" : W(4,05) = "05-H" : W(5,05) = "05-H"
W(1,06) = "06-H" : W(2,06) = "06-H" : W(3,06) = "06-H" : W(4,06) = "06-H" : W(5,06) = "06-H"
W(1,07) = "07-H" : W(2,07) = "07-H" : W(3,07) = "07-H" : W(4,07) = "07-H" : W(5,07) = "07-H"
W(1,08) = "08-H" : W(2,08) = "08-H" : W(3,08) = "08-H" : W(4,08) = "08-H" : W(5,08) = "08-H"
W(1,09) = "09-H" : W(2,09) = "09-H" : W(3,09) = "09-H" : W(4,09) = "09-H" : W(5,09) = "09-H"
W(1,10) = "10-H" : W(2,10) = "10-H" : W(3,10) = "10-H" : W(4,10) = "10-H" : W(5,10) = "10-H"
W(1,11) = "11-H" : W(2,11) = "11-H" : W(3,11) = "11-H" : W(4,11) = "11-H" : W(5,11) = "11-H"
W(1,12) = "12-H" : W(2,12) = "12-H" : W(3,12) = "12-H" : W(4,12) = "12-H" : W(5,12) = "12-H"
W(1,13) = "13-H" : W(2,13) = "13-H" : W(3,13) = "13-H" : W(4,13) = "13-H" : W(5,13) = "13-H"
W(1,14) = "01-D" : W(2,14) = "01-D" : W(3,14) = "01-D" : W(4,14) = "01-D" : W(5,14) = "01-D"
W(1,15) = "02-D" : W(2,15) = "02-D" : W(3,15) = "02-D" : W(4,15) = "02-D" : W(5,15) = "02-D"
W(1,16) = "03-D" : W(2,16) = "03-D" : W(3,16) = "03-D" : W(4,16) = "03-D" : W(5,16) = "03-D"
W(1,17) = "04-D" : W(2,17) = "04-D" : W(3,17) = "04-D" : W(4,17) = "04-D" : W(5,17) = "04-D"
W(1,18) = "05-D" : W(2,18) = "05-D" : W(3,18) = "05-D" : W(4,18) = "05-D" : W(5,18) = "05-D"
W(1,19) = "06-D" : W(2,19) = "06-D" : W(3,19) = "06-D" : W(4,19) = "06-D" : W(5,19) = "06-D"
W(1,20) = "07-D" : W(2,20) = "07-D" : W(3,20) = "07-D" : W(4,20) = "07-D" : W(5,20) = "07-D"
W(1,21) = "08-D" : W(2,21) = "08-D" : W(3,21) = "08-D" : W(4,21) = "08-D" : W(5,21) = "08-D"
W(1,22) = "09-D" : W(2,22) = "09-D" : W(3,22) = "09-D" : W(4,22) = "09-D" : W(5,22) = "09-D"
W(1,23) = "10-D" : W(2,23) = "10-D" : W(3,23) = "10-D" : W(4,23) = "10-D" : W(5,23) = "10-D"
W(1,24) = "11-D" : W(2,24) = "11-D" : W(3,24) = "11-D" : W(4,24) = "11-D" : W(5,24) = "11-D"
W(1,25) = "12-D" : W(2,25) = "12-D" : W(3,25) = "12-D" : W(4,25) = "12-D" : W(5,25) = "12-D"
W(1,26) = "13-D" : W(2,26) = "13-D" : W(3,26) = "13-D" : W(4,26) = "13-D" : W(5,26) = "13-D"
W(1,27) = "01-C" : W(2,27) = "01-C" : W(3,27) = "01-C" : W(4,27) = "01-C" : W(5,27) = "01-C"
W(1,28) = "02-C" : W(2,28) = "02-C" : W(3,28) = "02-C" : W(4,28) = "02-C" : W(5,28) = "02-C"
W(1,29) = "03-C" : W(2,29) = "03-C" : W(3,29) = "03-C" : W(4,29) = "03-C" : W(5,29) = "03-C"
W(1,30) = "04-C" : W(2,30) = "04-C" : W(3,30) = "04-C" : W(4,30) = "04-C" : W(5,30) = "04-C"
W(1,31) = "05-C" : W(2,31) = "05-C" : W(3,31) = "05-C" : W(4,31) = "05-C" : W(5,31) = "05-C"
W(1,32) = "06-C" : W(2,32) = "06-C" : W(3,32) = "06-C" : W(4,32) = "06-C" : W(5,32) = "06-C"
W(1,33) = "07-C" : W(2,33) = "07-C" : W(3,33) = "07-C" : W(4,33) = "07-C" : W(5,33) = "07-C"
W(1,34) = "08-C" : W(2,34) = "08-C" : W(3,34) = "08-C" : W(4,34) = "08-C" : W(5,34) = "08-C"
W(1,35) = "09-C" : W(2,35) = "09-C" : W(3,35) = "09-C" : W(4,35) = "09-C" : W(5,35) = "09-C"
W(1,36) = "10-C" : W(2,36) = "10-C" : W(3,36) = "10-C" : W(4,36) = "10-C" : W(5,36) = "10-C"
W(1,37) = "11-C" : W(2,37) = "11-C" : W(3,37) = "11-C" : W(4,37) = "11-C" : W(5,37) = "11-C"
W(1,38) = "12-C" : W(2,38) = "12-C" : W(3,38) = "12-C" : W(4,38) = "12-C" : W(5,38) = "12-C"
W(1,39) = "13-C" : W(2,39) = "13-C" : W(3,39) = "13-C" : W(4,39) = "13-C" : W(5,39) = "13-C"
W(1,40) = "01-S" : W(2,40) = "01-S" : W(3,40) = "01-S" : W(4,40) = "01-S" : W(5,40) = "01-S"
W(1,41) = "02-S" : W(2,41) = "02-S" : W(3,41) = "02-S" : W(4,41) = "02-S" : W(5,41) = "02-S"
W(1,42) = "03-S" : W(2,42) = "03-S" : W(3,42) = "03-S" : W(4,42) = "03-S" : W(5,42) = "03-S"
W(1,43) = "04-S" : W(2,43) = "04-S" : W(3,43) = "04-S" : W(4,43) = "04-S" : W(5,43) = "04-S"
W(1,44) = "05-S" : W(2,44) = "05-S" : W(3,44) = "05-S" : W(4,44) = "05-S" : W(5,44) = "05-S"
W(1,45) = "06-S" : W(2,45) = "06-S" : W(3,45) = "06-S" : W(4,45) = "06-S" : W(5,45) = "06-S"
W(1,46) = "07-S" : W(2,46) = "07-S" : W(3,46) = "07-S" : W(4,46) = "07-S" : W(5,46) = "07-S"
W(1,47) = "08-S" : W(2,47) = "08-S" : W(3,47) = "08-S" : W(4,47) = "08-S" : W(5,47) = "08-S"
W(1,48) = "09-S" : W(2,48) = "09-S" : W(3,48) = "09-S" : W(4,48) = "09-S" : W(5,48) = "09-S"
W(1,49) = "10-S" : W(2,49) = "10-S" : W(3,49) = "10-S" : W(4,49) = "10-S" : W(5,49) = "10-S"
W(1,50) = "11-S" : W(2,50) = "11-S" : W(3,50) = "11-S" : W(4,50) = "11-S" : W(5,50) = "11-S"
W(1,51) = "12-S" : W(2,51) = "12-S" : W(3,51) = "12-S" : W(4,51) = "12-S" : W(5,51) = "12-S"
W(1,52) = "13-S" : W(2,52) = "13-S" : W(3,52) = "13-S" : W(4,52) = "13-S" : W(5,52) = "13-S"
Function Idx(angle As Single) As Integer
    var q=(angle/(360/52))
    q=53-q
    If q=53 Then q=1
    Return q
End Function

Dim As Long fps
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
'===============================================================================
'===============================================================================


START:
   
    Randomize timer
   
    dim as single k1,k2,k3,k4,k5
    dim as integer i(1 to 5)={1,2,3,4,5}
    for n as integer=1 to rnd*100
        swap i(range(1,5)),i(range(1,5))
    next n
    k1=i(1):k2=i(2):k3=i(3):k4=i(4):k5=i(5)
   
dim as long flag=1,toggle,counter=0,starter=1,cflag
Dim As Single angle1,angle2,angle3,angle4,angle5
Dim As String ink
Dim As Long f1,f2,f3,f4,f5,diff=30
Dim As Long spent,gain,score,check,won
Dim As string t(1 to 5) , text
dim as ubyte v(1 to 5)
dim as integer s(1 to 5)={1,1,1,1,1}
Windowtitle "Five Deck Maverick"

Do
   
    if s(1) then angle1+=k1
    if s(2) then angle2+=k2
    if s(3) then angle3+=k3
    if s(4) then angle4+=k4
    if s(5) then angle5+=k5
   
    If angle1>=360 Then angle1=0
    If angle2>=360 Then angle2=0
    If angle3>=360 Then angle3=0
    If angle4>=360 Then angle4=0
    If angle5>=360 Then angle5=0
    'screenlock
    screenset 1,0
    glEnable (GL_CULL_FACE)
     Swap_Buffers(ctx)
    glClear(GL_COLOR_BUFFER_BIT)
   
    dim as single zz=-30 - (xres/275)
    DrawFaces(angle1, -4.1  ,0 ,zz ,1)
    DrawFaces(angle2, -2.05 ,0 ,zz ,2)
    DrawFaces(angle3, +-0   ,0 ,zz ,3)
    DrawFaces(angle4, +2.05 ,0 ,zz ,4)
    DrawFaces(angle5, +4.1  ,0 ,zz ,5)

    line(0,0)-(xres,90),rgb(0,48,0),bf
    line(0,yres-90)-(xres,yres),rgb(0,48,0),bf
    for k as long=0 to 4
    line(.2*xres-k,.42*yres-k)-(.8*xres+k,.58*yres+k),rgb(200,0,0),b
    next k
   
    glend
    drawfont(,xres/2.575,.9*yres,"( Press b for payouts. )","Comic Sans MS",15,Rgb(255,255,255))
    drawfont(,xres/4.35,yres/31,"Spent  = " + str(spent),"Comic Sans MS",20,Rgb(255,255,255))
    drawfont(,xres/4.35,yres/12,"Payout = " + Str(gain)  ,"Comic Sans MS",20,Rgb(255,255,255))
    drawfont(,xres/20,yres-30,"Framerate "&fps ,"Comic Sans MS",15,Rgb(255,255,255))
    drawfont(,xres/1.75,yres/15,"Diff = " + Str(gain-spent) ,"Comic Sans MS",20,Rgb(255,255,255))
     drawfont(,xres/3.2,.95*yres,"Press ""space bar"" to Spin" ,"Comic Sans MS",15,Rgb(255,255,255))
   
    If f5 Then
        dim as string s
        for n as long=1 to 5
            s+=str(v(n))+"         "
            next n
         drawfont(,xres/3.75,.85*yres,s ,"Comic Sans MS",20,Rgb(0,155,255))
    end if
   
    Flip
    'toggle and spacebar stuff
    If flag Then
        flag=0
        angle1=nearest(angle1)
        angle2=nearest(angle2)
        angle3=nearest(angle3)
        angle4=nearest(angle4)
        angle5=nearest(angle5)
    Else
        counter+=1
        'stop wheels one after the other
        If counter= (45*01) Then f1=1
        If counter= (45*02) Then f2=1
        If counter= (45*03) Then f3=1
        If counter =(45*04) Then f4=1
        If counter =(45*05) Then f5=1 : score=1 'now get scores
        If counter =(45*06) Then speak(text)
       
        If f1=1 and s(1) Then
            var n=nearest(angle1)
            If angle1>n Then k1=-.5 Else  k1=.5
            If Abs(n-angle1)<=2 Then k1=0:angle1=n:s(1)=0
            t(1)= w(1,Idx(n))
        End If
       
        If f2=1 and s(2) Then
            var n=nearest(angle2)
            If angle2>n Then k2=-.5 Else k2=.5
            If Abs(n-angle2)<=2 Then k2=0:angle2=n:s(2)=0
            t(2)= w(2,Idx(n))
        End If
       
        If f3=1 and s(3) Then
            var n=nearest(angle3)
            If angle3>n Then k3= -.5 Else k3=.5
            If Abs(n-angle3)<=2 Then k3=0:angle3=n: s(3)=0
            t(3)= w(3,Idx(n))
        End If
       
        If f4=1 and s(4) Then
            var n=nearest(angle4)
            If angle4>n Then k4= -.5 Else k4=.5
            If Abs(n-angle4)<=2 Then k4=0:angle4=n: s(4)=0
            t(4)= w(4,Idx(n))
        End If
   
        If f5=1 and s(5) Then
            Var n=nearest(angle5)
            If angle5>n Then k5=-.5 else k5=.5
            If Abs(angle5-n)<=2 Then k5=0:angle5=n: s(5)=0
            t(5)= w(5,Idx(n))
        end if
    end if
   
    k1=.995*k1
    k2=.995*k2
    k3=.995*k3
    k4=.995*k4
    k5=.995*k5
   
    if score = 1 then
       
        text = ""
        dim as integer value=0
        dim as ubyte flush=0
       
        'sort lowest to highest
        v(1)=val(left(t(1),2))
        v(2)=val(left(t(2),2))
        v(3)=val(left(t(3),2))
        v(4)=val(left(t(4),2))
        v(5)=val(left(t(5),2))
        for a as longint = 1 to 5
            for b as longint = 1 to 5
                if v(a)<=v(b) then swap v(a),v(b)
            next
        next
       
        'check for flush
        dim as string*1 suit(1 to 5)
        suit(1) = right(t(1),1)
        suit(2) = right(t(2),1)
        suit(3) = right(t(3),1)
        suit(4) = right(t(4),1)
        suit(5) = right(t(5),1)
        if suit(1)=suit(2) and suit(1)=suit(3) and suit(1)=suit(4) and suit(1)=suit(5) then flush=1

        'check for pairs
        for a as longint = 1 to 5
            for b as longint = a+1 to 5
                if v(a) = v(b) then value+=1
            next
        next
       
        'check pair for (tens or better)
        if value = 1 then
            for a as longint = 1 to 5
                for b as longint = a+1 to 5
                    if v(a) = v(b) then
                        if v(a)=1 or v(a)>=10 then
                            value=1
                        else
                            value=0
                            if flush = 0 then text = "you need tens or better to score "
                        end if
                    end if
                next
            next
        end if   
        '    1 pair (tens or better)   = 1
        '    2 pair                    = 5
        '    3 of a kind               = 10
        '    straight                  = 15
        '    skip straight (1,3,5,7,9) = 15
        '    flush (with any hand)     =+25
        '    fullhouse                 = 35
        '    4 of a kind               = 100
        '    royal straight            = 150
        '    straight flush            = 250
        '    5 of a kind               = 1000
        '    5 of a kind flush         = 2000
        '    royal straight flush      = 4000
        if value=1  then value=1    : text = "you got a pair tens or better " : goto DONE
        if value=2  then value=5    : text = "you got two pairs "             : goto DONE
        if value=3  then value=10   : text = "you got three of a kind "       : goto DONE
        if value=4  then value=35   : text = "you got a full house "          : goto DONE
        if value=6  then value=100  : text = "you got four of a kind "        : goto DONE
        if value=10 then value=1000 : text = "you got five of a kind "        : goto DONE
       
        DONE:
       
        'check for straight
        if v(2)=v(1)+1 and v(3)=v(2)+1 and v(4)=v(3)+1 and v(5)=v(4)+1 then
            value=15
            text= "you got a straight "
        end if
       
        'check for even skip straights
        if v(1)=2 and v(2)=4 and v(3)=6 and v(4)=8 and v(5)=10  then
            value=15
            text= "you got a skip straight "  ' 2,4,6,8,10
        end if
        if v(1)=4 and v(2)=6 and v(3)=8 and v(4)=10 and v(5)=12  then
            value=15
            text= "you got a skip straight "  ' 4,6,8,10,12
        end if
        if v(1)=6 and v(2)=8 and v(3)=10 and v(4)=12 and v(5)=1  then
            value=15
            text= "you got a skip straight "  ' 6,8,10,12,1
        end if
       
        'check for odd skip straights
        if v(1)=1 and v(2)=3 and v(3)=5 and v(4)=7 and v(5)=9   then
            value=15
            text= "you got a skip straight "  ' 1,3,5,7,9
        end if
        if v(1)=3 and v(2)=5 and v(3)=7 and v(4)=9  and v(5)=11  then
            value=15
            text= "you got a skip straight "  ' 3,5,7,9,11
        end if
        if v(1)=5 and v(2)=7 and v(3)=9  and v(4)=11 and v(5)=13 then
            value=15
            text= "you got a skip straight "  ' 5,7,9,11,13
        end if
       
        'check for royal straight
        if v(2)=10 and v(3)=11 and v(4)=12 and v(5)=13 and v(1)=1 then
            value=150
            text= "you got a royal straight "
        end if
       
        if flush then
            value+=25
            if text ="you got a royal straight " then value = 4000
            if text ="you got five of a kind "   then value = 2000
            text+= "and it's a flush."
        end if
       
        if value=0 then text+= "You Lost."
        if value>0 then text+= " You Won" + str(value) + "Dollars."
        if  value>0 then gain+=value:value=0
        score=0
    end if

    ink = Inkey
   
    If toggle = 0 Then
        If ink = " " and counter >=(45*06) Then
            for n as integer=1 to 5
                s(n)=1
            next n
            flag=1:toggle=1:counter=0:f1=0:f2=0:f3=0:f4=0:f5=0:diff=range(0,60):spent+=1:cflag=0
            randomize timer
        end if
        toggle=0
    Else
        dim as integer i(1 to 5)={5,4,3,2,1}
        for n as integer=1 to rnd*100
            swap i(range(1,5)),i(range(1,5))
        next n
        k1=i(1):k2=i(2):k3=i(3):k4=i(4):k5=i(5)
    End If
   
    toggle=Len(ink)
   
    Sleep regulate(35,fps),1
   
    dim as double TT=timer
    dim as long lt
    dim as string dt
    if ink="b" then
        do
        dim as long t=int(timer)
        ink=""
        cls
        screenset 1,0
        glEnable (GL_CULL_FACE)
        glClear(GL_COLOR_BUFFER_BIT)
            drawfont(,0,.1*yres, "1 Pair (tens or better)   = 1    " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.15*yres,"2 Pair                    = 5    " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.2*yres, "3 of a kind               = 10   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.25*yres,"Straight                  = 15   " , "Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.3*yres, "Skip straight (1,3,5,7,9) = 15   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.35*yres,"Flush (with any hand)     =+25   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.4*yres ,"Fullhouse                 = 35   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.45*yres,"4 of a kind               = 100  " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.5*yres, "Royal straight            = 150  " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.55*yres,"Straight flush            = 250  " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.6*yres, "5 of a kind               = 1000 " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.65*yres,"5 of a kind flush         = 2000 " , "Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.7*yres, "Royal straight flush      = 4000 " ,"Comic Sans MS",20,Rgb(0,155,255))
        if lt<>t then dt+="."
        lt=t
           draw string(0,.8*yres),"Wait five " &dt
        flip
        if (timer-tt)>5 then exit do
        loop
        screenset 0,0
    end if

Loop Until ink=Chr(27)

for a as longint = 1 to 52
    ImageDestroy face(a)
next

END
 


Forget to mention
I changed sub SwapBuffers(g as GFX_CONTEXT ptr) to swap_buffers in your .bi file.
srvaldez
Posts: 1934
Joined: Sep 25, 2005 21:54

Re: TinyGL for FreeBASIC.

Postby srvaldez » Aug 03, 2016 17:20

Hi dodicat
I get errors trying to compile your program
fbc -w all "Five deck maverick.bas" -asm intel -gen gcc -Wc -O2 (in directory: C:\dev\FreeBASIC-1.06.0-win64\examples)
inc\TinyGL.bi(348) error 20: Type mismatch in 'sub SwapBuffers(g as GFX_CONTEXT ptr)'
inc\TinyGL.bi(348) warning 28(0): Return method mismatch
inc\TinyGL.bi(351) error 9: Expected expression in 'if g=0 then return'
inc\TinyGL.bi(352) error 9: Expected expression in 'p=ScreenPtr() :if p=0 then return'
inc\TinyGL.bi(359) warning 13(0): Function result was not explicitly set
Five deck maverick.bas(567) error 41: Variable not declared, Swap_Buffers in 'Swap_Buffers(ctx)'
Compilation failed.

I ran all the test programs included in TinyGL without problems
dodicat
Posts: 5757
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: TinyGL for FreeBASIC.

Postby dodicat » Aug 03, 2016 18:08

You have to alter swapbuffers to swap_buffers in the Tinygl.bi
Otherwise it clashes with the windows lib.
I tested 32/64 bit fbc, gas/gcc
-gen gcc -O3
is the only switch I used.
Ir runs OK in the ide, also the .exe runs straight from my desktop with the static opengl lib.
srvaldez
Posts: 1934
Joined: Sep 25, 2005 21:54

Re: TinyGL for FreeBASIC.

Postby srvaldez » Aug 03, 2016 18:25

thank you dodicat, that works.
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Re: TinyGL for FreeBASIC.

Postby D.J.Peters » Aug 04, 2016 15:33

You don't need to rename SwapBuffers if you include "windows.bi" before use #undef instead :-)

Joshy

Code: Select all

#include "fbgfx.bi"
#include once "windows.bi"
#include once "win/winnt.bi"
#include once "win/objbase.bi"
#inclib "ole32"

#undef SwapBuffers ' <--- !!!
#define LINK_STATIC
#include once "TinyGL.bi"

#define gluint ulong
#define glvertex2d glvertex2f

Dim shared IID_ISpVoice As GUID => ( &H6c44df74, &H72b9, &H4992, {&Ha1, &Hec, &Hef, &H99, &H6e, &H04, &H22, &Hd4 })
Dim shared CLSID_SpVoice As GUID => ( &H96749377, &H3391, &H11d2, {&H9e, &He3, &H00, &Hc0, &H4f, &H79, &H73, &H96 })

Type ISpVoiceVtbl_ As ISpVoiceVtbl

Type ISpVoice
    lpVtbl As ISpVoiceVtbl_ Ptr
End Type

#define SPF_DEFAULT 0

Type ISpVoiceVtbl
rem iunknown
    QueryInterface As Function(Byval As ISpVoice Ptr, Byval As IID Ptr, Byval As Any Ptr) As HRESULT
    AddRef As Function(Byval As ISpVoice Ptr) As ULONG
    Release As Function(Byval As ISpVoice Ptr) As ULONG

rem stubs
    SetNotifySink As Function() As HRESULT
    SetNotifyWindowMessage As Function() As HRESULT
    SetNotifyCallbackFunction As Function() As HRESULT
    SetNotifyCallbackInterface As Function() As HRESULT
    SetNotifyWin32Event As Function() As HRESULT
    WaitForNotifyEvent As Function() As HRESULT
    GetNotifyEventHandle As Function() As HRESULT
    SetInterest As Function() As HRESULT
    GetEvents As Function() As HRESULT
    GetInfo As Function() As HRESULT
    SetOutput As Function() As HRESULT
    GetOutputObjectToken As Function() As HRESULT
    GetOutputStream As Function() As HRESULT

rem done
    Pause As Function(Byval As ISpVoice Ptr) As HRESULT
    Resume As Function(Byval As ISpVoice Ptr) As HRESULT

rem stubs
    SetVoice As Function() As HRESULT
    GetVoice As Function() As HRESULT

rem done
    Speak As Function(Byval As ISpVoice Ptr, Byval pwcs As Wstring Ptr, Byval dwFlags As DWORD, Byval pulStreamNumber As ULONG Ptr) As HRESULT

rem stubs
    SpeakStream As Function() As HRESULT
    GetStatus As Function() As HRESULT
    Skip As Function() As HRESULT
    SetPriority As Function() As HRESULT
    GetPriority As Function() As HRESULT
    SetAlertBoundary As Function() As HRESULT
    GetAlertBoundary As Function() As HRESULT

rem done
    SetRate As Function(Byval As ISpVoice Ptr, Byval RateAdjust As Integer) As HRESULT
    GetRate As Function(Byval As ISpVoice Ptr, Byval RateAdjust As Integer Ptr) As HRESULT
    SetVolume As Function(Byval As ISpVoice Ptr, Byval usVolume As Ushort) As HRESULT
    GetVolume As Function(Byval As ISpVoice Ptr, Byval pusVolume As Ushort Ptr) As HRESULT
    WaitUntilDone As Function(Byval As ISpVoice Ptr, Byval msTimeout As ULONG) As HRESULT

rem stubs
    SetSyncSpeakTimeout As Function() As HRESULT
    GetSyncSpeakTimeout As Function() As HRESULT
    SpeakCompleteEvent As Function() As HRESULT
    IsUISupported As Function() As HRESULT
    DisplayUI As Function() As HRESULT
End Type

sub Speak ( byref tstring as string, byval rate as integer = 0 )
    Dim voices As ISpVoice Ptr
        CoInitialize(NULL)
        CoCreateInstance(@CLSID_SpVoice, NULL, CLSCTX_ALL, @IID_ISpVoice, Cast (Any Ptr, @voices))
        voices->lpVtbl->SetRate(voices, rate)
        voices->lpVtbl->Speak(voices, tString, 1, NULL)
        voices->lpVtbl->WaitUntilDone(voices, INFINITE)
        voices->lpVtbl->Release(voices)
        CoUninitialize()
end sub

sub Speak_No_Rate ( byval param as any ptr )
    dim as zstring ptr tstring = Cast(zstring ptr, param)
    ? tstring
   
    Dim voices As ISpVoice Ptr
        CoInitialize(NULL)
        CoCreateInstance(@CLSID_SpVoice, NULL, CLSCTX_ALL, @IID_ISpVoice, Cast (Any Ptr, @voices))
        voices->lpVtbl->SetRate(voices, -2)
        voices->lpVtbl->Speak(voices, *tString, SPF_DEFAULT, NULL)
        voices->lpVtbl->WaitUntilDone(voices, INFINITE)
        voices->lpVtbl->Release(voices)
        CoUninitialize()
end sub
'===============================================================================



#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
#define Frange(f,l) Rnd*((l)-(f))+(f)

const xres=800
const yres=600
screenres xres,yres,32,2
'screenset 0,0

Dim Shared As GLuint tex(1 To 52)
Dim Shared As Long drums(1 To 5)
Const FS_BOLD = 2
Const FS_ITALIC = 4

Sub DrawFont(Byref BUFFER As Any Ptr=0,Byval POSX As Long, Byval POSY As Long, _
    Byref FTEXT As String, Byref FNAME As String,Byval FSIZE As Long, _
    Byval FCOLOR As Ulong=Rgb(255,255,255),Byval FSTYLE As Long=0,Byval CHARSET As Long=DEFAULT_CHARSET )
   
    Static FINIT As Long
    Static As hdc THEDC
    Static As hbitmap THEBMP
    Static As Any Ptr THEPTR
    Static As fb.image Ptr FBBLK
    Static As Long TXTSZ,RESU,RESUU
    Static As hfont THEFONT
    Static As Long FW,FI,TXYY
    Static DSKWND As hwnd, DSKDC As hdc
    Static MYBMPINFO As BITMAPINFO
    Static As TEXTMETRIC MYTXINFO
    Static As SIZE TXTSIZE
    Static As RECT RCT
    Static As Ubyte Ptr ubp
    ubp=Cptr(Ubyte Ptr,@FCOLOR)
    Swap ubp[0],ubp[2]
    Dim As Ubyte alphaval =ubp[3]
    ubp[3]=0
    #define FontSize(PointSize) -MulDiv(PointSize, GetDeviceCaps(THEDC, LOGPIXELSY), 72)
   
    If FINIT = 0 Then   
        FINIT = 1   
        With MYBMPINFO.bmiheader
            .biSize = Sizeof(BITMAPINFOHEADER)
            .biWidth = 2048
            .biHeight = -513
            .biPlanes = 1
            .biBitCount = 32
            .biCompression = BI_RGB
        End With   
        DSKWND = GetDesktopWindow()
        DSKDC = GetDC(DSKWND)
        THEDC = CreateCompatibleDC(DSKDC)
        THEBMP = CreateDIBSection(THEDC,@MYBMPINFO,DIB_RGB_COLORS,@THEPTR,null,null)
        ReleaseDC(DSKWND,DSKDC)   
    End If
    If (FSTYLE And FS_BOLD) Then FW = FW_BOLD Else FW = FW_NORMAL   
    If (FSTYLE And FS_ITALIC) Then FI = True Else FI = False   
    THEFONT = CreateFont(FontSize(FSIZE),0,0,0,FW,FI,0,0,CHARSET,0,0,0,0,Cast(Any Ptr,Strptr(FNAME)))   
    SelectObject(THEDC,THEBMP)
    SelectObject(THEDC,THEFONT)
    GetTextMetrics(THEDC,@MYTXINFO)
    GetTextExtentPoint32(THEDC,Strptr(FTEXT),Len(FTEXT),@TXTSIZE)
    TXTSZ = TXTSIZE.CX
    TXYY = TXTSIZE.CY
    If (FSTYLE And FS_ITALIC) Then
        If MYTXINFO.tmOverhang Then
            TXTSZ += MYTXINFO.tmOverhang
        Else
            TXTSZ += 1+(FSIZE/2)
        End If
        TXYY += 1+(FSIZE/8)
    End If
    RCT.LEFT = 0
    RCT.TOP = 1
    RCT.RIGHT = TXTSZ
    RCT.BOTTOM = TXYY+1
    TXTSZ -= 1
    TXYY -= 1
    SetBkColor(THEDC,Rgba(255,0,255,0))
    SetTextColor(THEDC,FCOLOR)
    SystemParametersInfo(SPI_GETFONTSMOOTHING,null,@RESU,null)
    If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,False,@RESUU,null)
    ExtTextOut(THEDC,0,1,ETO_CLIPPED Or ETO_OPAQUE,@RCT,Strptr(FTEXT),Len(FTEXT),null)
    If RESU Then SystemParametersInfo(SPI_SETFONTSMOOTHING,True,@RESUU,null)
    FBBLK = THEPTR+(2048*4)-Sizeof(fb.image)
    FBBLK->Type = 7
    FBBLK->bpp = 4
    FBBLK->Width = 2048
    FBBLK->height = 512
    FBBLK->pitch = 2048*4
    Put BUFFER,(POSX,POSY),FBBLK,(0,0)-(TXTSZ-1,TXYY),Alpha,alphaval
    DeleteObject(THEFONT)
End Sub

Function Filter(Byref tim As Uinteger Pointer,_
    byval rad As Single,_
    byval destroy As Integer=1,_
    byval fade As Integer=0) As Uinteger 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 Integer x,y
        As Uinteger 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 Integer=-ymin To ymax
        For x1 As Integer=-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 Uinteger Pointer im=Imagecreate(_x,_y)
    Dim As Integer pitch
    Dim  As Any Pointer row
    Dim As Uinteger Pointer pixel
    Dim As Uinteger col
    Imageinfo tim,,,,pitch,row
    Dim As p2 NewPoints(_x-1,_y-1)
    For y As Integer=0 To (_y)-1
        For x As Integer=0 To (_x)-1
            p_point(x,y,col)
            NewPoints(x,y)=Type<p2>(x,y,col)
        Next x
    Next y
    Dim As Uinteger averagecolour
    Dim As Integer ar,ag,ab
    Dim As Integer xmin,xmax,ymin,ymax,inc
    Imageinfo im,,,,pitch,row
    For y As Integer=0 To _y-1
        For x As Integer=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 )
    dim as integer iwidth,iheight,iBytesPerPixel
    dim as ubyte ptr pPixels
    ImageInfo image,iWidth,iHeight,iBytesPerPixel,,pPixels
    glTexImage2D(GL_TEXTURE_2D, 0, iBytesPerPixel, iWidth,iHeight, 0,  GL_RGB, GL_UNSIGNED_BYTE, pPixels)
    glEnable(GL_TEXTURE_2D)
    Return texture
End Function


Sub glsetup
    glShadeModel(GL_SMOOTH)                 ' Enables Smooth Color Shading
    glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_DONT_CARE)
    glViewport(0, 0, xres, yres)       ' Set the viewport
    glMatrixMode(GL_PROJECTION)        ' Change Matrix Mode to Projection
    glLoadIdentity                     ' Reset View
    gluPerspective(45, xres/yres, 1, 100)
    glMatrixMode(GL_MODELVIEW)         ' Return to the modelview matrix
    glLoadIdentity                     '  Reset View
    glClearColor 0,.2,0,1              'background
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 EIGHT FACES
Redim Shared As V3 a(1 To 4) 'For starters
Dim Shared As V3 normals(1 To 52)

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

var ctx = CreateRenderContext()
glsetup
'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.00,1)
Dim Shared As v3 centroid(1 To 52),rt(1 To 52)
centroid(1)=Type(0,0,z)

For z As Long=1 To 51'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(r,0,0),sc)
    a(n+2)=RotatePoint(ctr,a(n+2-4),Type(r,0,0),sc)
    a(n+3)=RotatePoint(ctr,a(n+3-4),Type(r,0,0),sc)
    a(n+4)=RotatePoint(ctr,a(n+4-4),Type(r,0,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

'sleep
'NOW WE HAVE EIGHT FACES DONE And THE NORMALS TO EACH FACE.

Sub DrawFaces(Byval rotangle As Single,x As Single,y As Single,Byval Z As Single,flag As Long=1)
    glEnable( GL_TEXTURE_2D )
    Dim As Single pi=4*Atn(1)
    glLoadIdentity()
    glTranslatef(x,y,Z)
    glRotatef(rotangle,1,0,0)           ' Rotate
    Dim As Long n=0
    Static As Long i
    i=i+1
    If i>5 Then i=1
    glcolor4f(0,0,0,1)
    For z As Long=1 To 52
        if z>1 and z<=13 then glcolor4f(1,0,0,1)
        if z>=14 and z<=26 then glcolor4f(1,0,0,1)
        if z>=27 and z<=39 then glcolor4f(0,0,0,1)
        if z>=40 and z<=52 then glcolor4f(0,0,0,1)
        glBindTexture(GL_TEXTURE_2D, tex(z))
        glBegin(GL_QUADS)
        rt(z)=RotatePoint(Type(0,0,0),centroid(z),Type(rotangle*pi/180,0,0),Type(1,1,1))
        glNormal3f normals(z).x,normals(z).y,normals(z).z
        If rt(z).z>0 Then
            If rt(z).y<5.5 And rt(z).y>-5.5 Then  '5.5 7.2
                If Abs(rt(z).y)<1 Then drums(i)=z '' A SCORE, THE DRUM IS CENTRAL
                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)
            End If
        End If
        n=n+4
        glend
    Next z
   
    glend
    gldisable( GL_TEXTURE_2D )
End Sub


Function nearest(a As Single) As Single
    Dim As Single pts(1 To 52),ctr
    For z As Single=0 To 360 Step (360/52)
        ctr+=1
        If ctr>52 Then Exit For
        pts(ctr)=z
    Next z
    For z As Long=1 To 52
        If Abs(pts(z)-a) <= 6 Then Return pts(z)'45
    Next z
End Function


dim as string card(1 to 13)
card(01) = " A"
card(02) = " 2"
card(03) = " 3"
card(04) = " 4"
card(05) = " 5"
card(06) = " 6"
card(07) = " 7"
card(08) = " 8"
card(09) = " 9"
card(10) = "10"
card(11) = " J"
card(12) = " Q"
card(13) = " K"
dim as any ptr face(52)
dim as string suit(1 to 4) = {chr(3),chr(4),chr(5),chr(6)}
dim as ubyte num=1
for n as integer=1 to ubound(face)
   
    face(n)=imagecreate(128,128,rgba(255,255,255,255))
   
    if n>=1  and n<=13 then DrawFont(face(n),10,35,str(card(num))+""+ suit(1) ,"TERMINAL",40,rgba(200,0,0,254))
    if n>=14 and n<=26 then DrawFont(face(n),10,35,str(card(num))+""+ suit(2) ,"TERMINAL",40,rgba(200,0,0,254))
    if n>=27 and n<=39 then DrawFont(face(n),10,35,str(card(num))+""+ suit(3) ,"TERMINAL",40,rgba(0  ,0,0,254))
    if n>=40 and n<=52 then DrawFont(face(n),10,35,str(card(num))+""+ suit(4) ,"TERMINAL",40,rgba(0  ,0,0,254))
   
    line face(n),(0,0)-(127,127),0,b
   face(n)=filter(face(n),1)
    num+=1
    if num=14 then num=1
   
next n

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

dim shared as string W(1 to 5 , 1 to 52)
W(1,01) = "01-H" : W(2,01) = "01-H" : W(3,01) = "01-H" : W(4,01) = "01-H" : W(5,01) = "01-H"
W(1,02) = "02-H" : W(2,02) = "02-H" : W(3,02) = "02-H" : W(4,02) = "02-H" : W(5,02) = "02-H"
W(1,03) = "03-H" : W(2,03) = "03-H" : W(3,03) = "03-H" : W(4,03) = "03-H" : W(5,03) = "03-H"
W(1,04) = "04-H" : W(2,04) = "04-H" : W(3,04) = "04-H" : W(4,04) = "04-H" : W(5,04) = "04-H"
W(1,05) = "05-H" : W(2,05) = "05-H" : W(3,05) = "05-H" : W(4,05) = "05-H" : W(5,05) = "05-H"
W(1,06) = "06-H" : W(2,06) = "06-H" : W(3,06) = "06-H" : W(4,06) = "06-H" : W(5,06) = "06-H"
W(1,07) = "07-H" : W(2,07) = "07-H" : W(3,07) = "07-H" : W(4,07) = "07-H" : W(5,07) = "07-H"
W(1,08) = "08-H" : W(2,08) = "08-H" : W(3,08) = "08-H" : W(4,08) = "08-H" : W(5,08) = "08-H"
W(1,09) = "09-H" : W(2,09) = "09-H" : W(3,09) = "09-H" : W(4,09) = "09-H" : W(5,09) = "09-H"
W(1,10) = "10-H" : W(2,10) = "10-H" : W(3,10) = "10-H" : W(4,10) = "10-H" : W(5,10) = "10-H"
W(1,11) = "11-H" : W(2,11) = "11-H" : W(3,11) = "11-H" : W(4,11) = "11-H" : W(5,11) = "11-H"
W(1,12) = "12-H" : W(2,12) = "12-H" : W(3,12) = "12-H" : W(4,12) = "12-H" : W(5,12) = "12-H"
W(1,13) = "13-H" : W(2,13) = "13-H" : W(3,13) = "13-H" : W(4,13) = "13-H" : W(5,13) = "13-H"
W(1,14) = "01-D" : W(2,14) = "01-D" : W(3,14) = "01-D" : W(4,14) = "01-D" : W(5,14) = "01-D"
W(1,15) = "02-D" : W(2,15) = "02-D" : W(3,15) = "02-D" : W(4,15) = "02-D" : W(5,15) = "02-D"
W(1,16) = "03-D" : W(2,16) = "03-D" : W(3,16) = "03-D" : W(4,16) = "03-D" : W(5,16) = "03-D"
W(1,17) = "04-D" : W(2,17) = "04-D" : W(3,17) = "04-D" : W(4,17) = "04-D" : W(5,17) = "04-D"
W(1,18) = "05-D" : W(2,18) = "05-D" : W(3,18) = "05-D" : W(4,18) = "05-D" : W(5,18) = "05-D"
W(1,19) = "06-D" : W(2,19) = "06-D" : W(3,19) = "06-D" : W(4,19) = "06-D" : W(5,19) = "06-D"
W(1,20) = "07-D" : W(2,20) = "07-D" : W(3,20) = "07-D" : W(4,20) = "07-D" : W(5,20) = "07-D"
W(1,21) = "08-D" : W(2,21) = "08-D" : W(3,21) = "08-D" : W(4,21) = "08-D" : W(5,21) = "08-D"
W(1,22) = "09-D" : W(2,22) = "09-D" : W(3,22) = "09-D" : W(4,22) = "09-D" : W(5,22) = "09-D"
W(1,23) = "10-D" : W(2,23) = "10-D" : W(3,23) = "10-D" : W(4,23) = "10-D" : W(5,23) = "10-D"
W(1,24) = "11-D" : W(2,24) = "11-D" : W(3,24) = "11-D" : W(4,24) = "11-D" : W(5,24) = "11-D"
W(1,25) = "12-D" : W(2,25) = "12-D" : W(3,25) = "12-D" : W(4,25) = "12-D" : W(5,25) = "12-D"
W(1,26) = "13-D" : W(2,26) = "13-D" : W(3,26) = "13-D" : W(4,26) = "13-D" : W(5,26) = "13-D"
W(1,27) = "01-C" : W(2,27) = "01-C" : W(3,27) = "01-C" : W(4,27) = "01-C" : W(5,27) = "01-C"
W(1,28) = "02-C" : W(2,28) = "02-C" : W(3,28) = "02-C" : W(4,28) = "02-C" : W(5,28) = "02-C"
W(1,29) = "03-C" : W(2,29) = "03-C" : W(3,29) = "03-C" : W(4,29) = "03-C" : W(5,29) = "03-C"
W(1,30) = "04-C" : W(2,30) = "04-C" : W(3,30) = "04-C" : W(4,30) = "04-C" : W(5,30) = "04-C"
W(1,31) = "05-C" : W(2,31) = "05-C" : W(3,31) = "05-C" : W(4,31) = "05-C" : W(5,31) = "05-C"
W(1,32) = "06-C" : W(2,32) = "06-C" : W(3,32) = "06-C" : W(4,32) = "06-C" : W(5,32) = "06-C"
W(1,33) = "07-C" : W(2,33) = "07-C" : W(3,33) = "07-C" : W(4,33) = "07-C" : W(5,33) = "07-C"
W(1,34) = "08-C" : W(2,34) = "08-C" : W(3,34) = "08-C" : W(4,34) = "08-C" : W(5,34) = "08-C"
W(1,35) = "09-C" : W(2,35) = "09-C" : W(3,35) = "09-C" : W(4,35) = "09-C" : W(5,35) = "09-C"
W(1,36) = "10-C" : W(2,36) = "10-C" : W(3,36) = "10-C" : W(4,36) = "10-C" : W(5,36) = "10-C"
W(1,37) = "11-C" : W(2,37) = "11-C" : W(3,37) = "11-C" : W(4,37) = "11-C" : W(5,37) = "11-C"
W(1,38) = "12-C" : W(2,38) = "12-C" : W(3,38) = "12-C" : W(4,38) = "12-C" : W(5,38) = "12-C"
W(1,39) = "13-C" : W(2,39) = "13-C" : W(3,39) = "13-C" : W(4,39) = "13-C" : W(5,39) = "13-C"
W(1,40) = "01-S" : W(2,40) = "01-S" : W(3,40) = "01-S" : W(4,40) = "01-S" : W(5,40) = "01-S"
W(1,41) = "02-S" : W(2,41) = "02-S" : W(3,41) = "02-S" : W(4,41) = "02-S" : W(5,41) = "02-S"
W(1,42) = "03-S" : W(2,42) = "03-S" : W(3,42) = "03-S" : W(4,42) = "03-S" : W(5,42) = "03-S"
W(1,43) = "04-S" : W(2,43) = "04-S" : W(3,43) = "04-S" : W(4,43) = "04-S" : W(5,43) = "04-S"
W(1,44) = "05-S" : W(2,44) = "05-S" : W(3,44) = "05-S" : W(4,44) = "05-S" : W(5,44) = "05-S"
W(1,45) = "06-S" : W(2,45) = "06-S" : W(3,45) = "06-S" : W(4,45) = "06-S" : W(5,45) = "06-S"
W(1,46) = "07-S" : W(2,46) = "07-S" : W(3,46) = "07-S" : W(4,46) = "07-S" : W(5,46) = "07-S"
W(1,47) = "08-S" : W(2,47) = "08-S" : W(3,47) = "08-S" : W(4,47) = "08-S" : W(5,47) = "08-S"
W(1,48) = "09-S" : W(2,48) = "09-S" : W(3,48) = "09-S" : W(4,48) = "09-S" : W(5,48) = "09-S"
W(1,49) = "10-S" : W(2,49) = "10-S" : W(3,49) = "10-S" : W(4,49) = "10-S" : W(5,49) = "10-S"
W(1,50) = "11-S" : W(2,50) = "11-S" : W(3,50) = "11-S" : W(4,50) = "11-S" : W(5,50) = "11-S"
W(1,51) = "12-S" : W(2,51) = "12-S" : W(3,51) = "12-S" : W(4,51) = "12-S" : W(5,51) = "12-S"
W(1,52) = "13-S" : W(2,52) = "13-S" : W(3,52) = "13-S" : W(4,52) = "13-S" : W(5,52) = "13-S"
Function Idx(angle As Single) As Integer
    var q=(angle/(360/52))
    q=53-q
    If q=53 Then q=1
    Return q
End Function

Dim As Long fps
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
'===============================================================================
'===============================================================================


START:
   
    Randomize timer
   
    dim as single k1,k2,k3,k4,k5
    dim as integer i(1 to 5)={1,2,3,4,5}
    for n as integer=1 to rnd*100
        swap i(range(1,5)),i(range(1,5))
    next n
    k1=i(1):k2=i(2):k3=i(3):k4=i(4):k5=i(5)
   
dim as long flag=1,toggle,counter=0,starter=1,cflag
Dim As Single angle1,angle2,angle3,angle4,angle5
Dim As String ink
Dim As Long f1,f2,f3,f4,f5,diff=30
Dim As Long spent,gain,score,check,won
Dim As string t(1 to 5) , text
dim as ubyte v(1 to 5)
dim as integer s(1 to 5)={1,1,1,1,1}
Windowtitle "Five Deck Maverick"

Do
   
    if s(1) then angle1+=k1
    if s(2) then angle2+=k2
    if s(3) then angle3+=k3
    if s(4) then angle4+=k4
    if s(5) then angle5+=k5
   
    If angle1>=360 Then angle1=0
    If angle2>=360 Then angle2=0
    If angle3>=360 Then angle3=0
    If angle4>=360 Then angle4=0
    If angle5>=360 Then angle5=0
    'screenlock
    screenset 1,0
    glEnable (GL_CULL_FACE)
    SwapBuffers(ctx)
    glClear(GL_COLOR_BUFFER_BIT)
   
    dim as single zz=-30 - (xres/275)
    DrawFaces(angle1, -4.1  ,0 ,zz ,1)
    DrawFaces(angle2, -2.05 ,0 ,zz ,2)
    DrawFaces(angle3, +-0   ,0 ,zz ,3)
    DrawFaces(angle4, +2.05 ,0 ,zz ,4)
    DrawFaces(angle5, +4.1  ,0 ,zz ,5)

    line(0,0)-(xres,90),rgb(0,48,0),bf
    line(0,yres-90)-(xres,yres),rgb(0,48,0),bf
    for k as long=0 to 4
    line(.2*xres-k,.42*yres-k)-(.8*xres+k,.58*yres+k),rgb(200,0,0),b
    next k
   
    glend
    drawfont(,xres/2.575,.9*yres,"( Press b for payouts. )","Comic Sans MS",15,Rgb(255,255,255))
    drawfont(,xres/4.35,yres/31,"Spent  = " + str(spent),"Comic Sans MS",20,Rgb(255,255,255))
    drawfont(,xres/4.35,yres/12,"Payout = " + Str(gain)  ,"Comic Sans MS",20,Rgb(255,255,255))
    drawfont(,xres/20,yres-30,"Framerate "&fps ,"Comic Sans MS",15,Rgb(255,255,255))
    drawfont(,xres/1.75,yres/15,"Diff = " + Str(gain-spent) ,"Comic Sans MS",20,Rgb(255,255,255))
     drawfont(,xres/3.2,.95*yres,"Press ""space bar"" to Spin" ,"Comic Sans MS",15,Rgb(255,255,255))
   
    If f5 Then
        dim as string s
        for n as long=1 to 5
            s+=str(v(n))+"         "
            next n
         drawfont(,xres/3.75,.85*yres,s ,"Comic Sans MS",20,Rgb(0,155,255))
    end if
   
    Flip
    'toggle and spacebar stuff
    If flag Then
        flag=0
        angle1=nearest(angle1)
        angle2=nearest(angle2)
        angle3=nearest(angle3)
        angle4=nearest(angle4)
        angle5=nearest(angle5)
    Else
        counter+=1
        'stop wheels one after the other
        If counter= (45*01) Then f1=1
        If counter= (45*02) Then f2=1
        If counter= (45*03) Then f3=1
        If counter =(45*04) Then f4=1
        If counter =(45*05) Then f5=1 : score=1 'now get scores
        If counter =(45*06) Then speak(text)
       
        If f1=1 and s(1) Then
            var n=nearest(angle1)
            If angle1>n Then k1=-.5 Else  k1=.5
            If Abs(n-angle1)<=2 Then k1=0:angle1=n:s(1)=0
            t(1)= w(1,Idx(n))
        End If
       
        If f2=1 and s(2) Then
            var n=nearest(angle2)
            If angle2>n Then k2=-.5 Else k2=.5
            If Abs(n-angle2)<=2 Then k2=0:angle2=n:s(2)=0
            t(2)= w(2,Idx(n))
        End If
       
        If f3=1 and s(3) Then
            var n=nearest(angle3)
            If angle3>n Then k3= -.5 Else k3=.5
            If Abs(n-angle3)<=2 Then k3=0:angle3=n: s(3)=0
            t(3)= w(3,Idx(n))
        End If
       
        If f4=1 and s(4) Then
            var n=nearest(angle4)
            If angle4>n Then k4= -.5 Else k4=.5
            If Abs(n-angle4)<=2 Then k4=0:angle4=n: s(4)=0
            t(4)= w(4,Idx(n))
        End If
   
        If f5=1 and s(5) Then
            Var n=nearest(angle5)
            If angle5>n Then k5=-.5 else k5=.5
            If Abs(angle5-n)<=2 Then k5=0:angle5=n: s(5)=0
            t(5)= w(5,Idx(n))
        end if
    end if
   
    k1=.995*k1
    k2=.995*k2
    k3=.995*k3
    k4=.995*k4
    k5=.995*k5
   
    if score = 1 then
       
        text = ""
        dim as integer value=0
        dim as ubyte flush=0
       
        'sort lowest to highest
        v(1)=val(left(t(1),2))
        v(2)=val(left(t(2),2))
        v(3)=val(left(t(3),2))
        v(4)=val(left(t(4),2))
        v(5)=val(left(t(5),2))
        for a as longint = 1 to 5
            for b as longint = 1 to 5
                if v(a)<=v(b) then swap v(a),v(b)
            next
        next
       
        'check for flush
        dim as string*1 suit(1 to 5)
        suit(1) = right(t(1),1)
        suit(2) = right(t(2),1)
        suit(3) = right(t(3),1)
        suit(4) = right(t(4),1)
        suit(5) = right(t(5),1)
        if suit(1)=suit(2) and suit(1)=suit(3) and suit(1)=suit(4) and suit(1)=suit(5) then flush=1

        'check for pairs
        for a as longint = 1 to 5
            for b as longint = a+1 to 5
                if v(a) = v(b) then value+=1
            next
        next
       
        'check pair for (tens or better)
        if value = 1 then
            for a as longint = 1 to 5
                for b as longint = a+1 to 5
                    if v(a) = v(b) then
                        if v(a)=1 or v(a)>=10 then
                            value=1
                        else
                            value=0
                            if flush = 0 then text = "you need tens or better to score "
                        end if
                    end if
                next
            next
        end if   
        '    1 pair (tens or better)   = 1
        '    2 pair                    = 5
        '    3 of a kind               = 10
        '    straight                  = 15
        '    skip straight (1,3,5,7,9) = 15
        '    flush (with any hand)     =+25
        '    fullhouse                 = 35
        '    4 of a kind               = 100
        '    royal straight            = 150
        '    straight flush            = 250
        '    5 of a kind               = 1000
        '    5 of a kind flush         = 2000
        '    royal straight flush      = 4000
        if value=1  then value=1    : text = "you got a pair tens or better " : goto DONE
        if value=2  then value=5    : text = "you got two pairs "             : goto DONE
        if value=3  then value=10   : text = "you got three of a kind "       : goto DONE
        if value=4  then value=35   : text = "you got a full house "          : goto DONE
        if value=6  then value=100  : text = "you got four of a kind "        : goto DONE
        if value=10 then value=1000 : text = "you got five of a kind "        : goto DONE
       
        DONE:
       
        'check for straight
        if v(2)=v(1)+1 and v(3)=v(2)+1 and v(4)=v(3)+1 and v(5)=v(4)+1 then
            value=15
            text= "you got a straight "
        end if
       
        'check for even skip straights
        if v(1)=2 and v(2)=4 and v(3)=6 and v(4)=8 and v(5)=10  then
            value=15
            text= "you got a skip straight "  ' 2,4,6,8,10
        end if
        if v(1)=4 and v(2)=6 and v(3)=8 and v(4)=10 and v(5)=12  then
            value=15
            text= "you got a skip straight "  ' 4,6,8,10,12
        end if
        if v(1)=6 and v(2)=8 and v(3)=10 and v(4)=12 and v(5)=1  then
            value=15
            text= "you got a skip straight "  ' 6,8,10,12,1
        end if
       
        'check for odd skip straights
        if v(1)=1 and v(2)=3 and v(3)=5 and v(4)=7 and v(5)=9   then
            value=15
            text= "you got a skip straight "  ' 1,3,5,7,9
        end if
        if v(1)=3 and v(2)=5 and v(3)=7 and v(4)=9  and v(5)=11  then
            value=15
            text= "you got a skip straight "  ' 3,5,7,9,11
        end if
        if v(1)=5 and v(2)=7 and v(3)=9  and v(4)=11 and v(5)=13 then
            value=15
            text= "you got a skip straight "  ' 5,7,9,11,13
        end if
       
        'check for royal straight
        if v(2)=10 and v(3)=11 and v(4)=12 and v(5)=13 and v(1)=1 then
            value=150
            text= "you got a royal straight "
        end if
       
        if flush then
            value+=25
            if text ="you got a royal straight " then value = 4000
            if text ="you got five of a kind "   then value = 2000
            text+= "and it's a flush."
        end if
       
        if value=0 then text+= "You Lost."
        if value>0 then text+= " You Won" + str(value) + "Dollars."
        if  value>0 then gain+=value:value=0
        score=0
    end if

    ink = Inkey
   
    If toggle = 0 Then
        If ink = " " and counter >=(45*06) Then
            for n as integer=1 to 5
                s(n)=1
            next n
            flag=1:toggle=1:counter=0:f1=0:f2=0:f3=0:f4=0:f5=0:diff=range(0,60):spent+=1:cflag=0
            randomize timer
        end if
        toggle=0
    Else
        dim as integer i(1 to 5)={5,4,3,2,1}
        for n as integer=1 to rnd*100
            swap i(range(1,5)),i(range(1,5))
        next n
        k1=i(1):k2=i(2):k3=i(3):k4=i(4):k5=i(5)
    End If
   
    toggle=Len(ink)
   
    Sleep regulate(35,fps),1
   
    dim as double TT=timer
    dim as long lt
    dim as string dt
    if ink="b" then
        do
        dim as long t=int(timer)
        ink=""
        cls
        screenset 1,0
        glEnable (GL_CULL_FACE)
        glClear(GL_COLOR_BUFFER_BIT)
            drawfont(,0,.1*yres, "1 Pair (tens or better)   = 1    " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.15*yres,"2 Pair                    = 5    " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.2*yres, "3 of a kind               = 10   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.25*yres,"Straight                  = 15   " , "Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.3*yres, "Skip straight (1,3,5,7,9) = 15   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.35*yres,"Flush (with any hand)     =+25   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.4*yres ,"Fullhouse                 = 35   " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.45*yres,"4 of a kind               = 100  " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.5*yres, "Royal straight            = 150  " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.55*yres,"Straight flush            = 250  " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.6*yres, "5 of a kind               = 1000 " ,"Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.65*yres,"5 of a kind flush         = 2000 " , "Comic Sans MS",20,Rgb(0,155,255))
            drawfont(,0,.7*yres, "Royal straight flush      = 4000 " ,"Comic Sans MS",20,Rgb(0,155,255))
        if lt<>t then dt+="."
        lt=t
           draw string(0,.8*yres),"Wait five " &dt
        flip
        if (timer-tt)>5 then exit do
        loop
        screenset 0,0
    end if

Loop Until ink=Chr(27)

for a as longint = 1 to 52
    ImageDestroy face(a)
next
dodicat
Posts: 5757
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: TinyGL for FreeBASIC.

Postby dodicat » Aug 04, 2016 15:52

To use the dll, I presume leaving out
#define LINK_STATIC
should do it.
But I get a system message error, tinyGL-32.dll or tinyGL-64.dll is missing (depending on the compiler).
Same with your examples in the same folder.

Win 10
(everything is running from a desktop folder)
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Re: TinyGL for FreeBASIC.

Postby D.J.Peters » Aug 04, 2016 16:36

You have to copy from lib folder the *.dll to the folder where your *.exe are.

Joshy
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Re: TinyGL for FreeBASIC.

Postby D.J.Peters » Aug 09, 2016 7:07

included for texture loading: FBImage dynamic and static Win/Lin 32/64-bit

fixed:
all stride params are bytes offsets now

added:
glError()
glGetString(GL_VENDOR / GL_RENDERER / GL_VERSION)
glEnable(GL_BLEND)
glDrawArrays()
glArrayElements()
glVertexPointer()
glColorPointer()
glNormalPointer()
glTexCoordPointer()
glEdgeFlagPointer()

glXXXPointer all OpenGL legal data types are supported now:
GL_BYTE, GL_SHORT, GL_INT, GL_FLOAT, GL_DOUBLE
GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT, GL_UNSIGNED_INT

examples:
glGet.bas
glBlend01.bas
glBlend02.bas
glDrawArrays.bas
glArrayElements.bas
test04.bas
test05.bas

Both source codes FBImage and fbTinyGL are included as Code::Blocks projects also.

Joshy
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Re: TinyGL for FreeBASIC.

Postby D.J.Peters » Aug 09, 2016 15:45

I found and fixed a bug in my textured triangle code ZB_DrawTriangleTexturedPerspective_zb.
(if Z-Buffer and GL_BLEND was enabled)

Joshy
MrSwiss
Posts: 3078
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: TinyGL for FreeBASIC.

Postby MrSwiss » Aug 09, 2016 22:29

@Joshy,

a really great piece of code (for all, wanting to start with GL).

If one is using FBEdit, there is a problem, with the bi-file, since its formatting of the preprocessor
stuff is broken. I suppose it was written in FBIde, because there the problem seems not to manifest.

Apart from SwapBuffers, on which I'd support dodicat, in changing it to Swap_Buffers (I don't like
the #undef suggestion). Because the next guy/gal, wants to use the windows.bi stuff too ...
dodicat
Posts: 5757
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: TinyGL for FreeBASIC.

Postby dodicat » Aug 10, 2016 14:23

I cannot seem to get tinyGL shading to work.
The Lightdiffuse and Lightposition arrays are exactly the same as openGL.

At the top of this code (4 rotating drums), you can un-comment #define TinyShade too see it's effect.
Otherwise, I have used my own shading method which resembles the openGL result.

Code: Select all


'Shading test -- tinyGL

'#define TinyShade
'#define fullscreen


#define LINK_STATIC
#include once "TinyGL.bi"
#define gluint ulong
#define glvertex2d glvertex2f
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Declare Sub glsetup
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 ppoint(_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
            ppoint(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
Sub drawstring(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 init Constructor
    drawstring(0,0,"",0,0)
    Screen 0
End Sub
Function Colour(Byref im As Any Pointer,Byval newcol As Ulong,Byval tweak As long,Byval fontsize As Single) As Any Pointer
    #macro ppset2(_x,_y,colour)
    pixel2=row2+pitch2*(_y)+(_x)*dpp2
    *pixel2=(colour)
    #endmacro
    #macro ppoint(_x,_y,colour)
    pixel=row+pitch*(_y)+(_x)*dpp
    (colour)=*pixel
    #endmacro
    Dim As long grade
    Select Case  fontsize
    Case 1 To 1.5:grade=205
    Case 2 :grade=225
    Case 2.5:grade=222
    Case 3 To 3.5:grade=200
    Case 4 To 4.5:grade=190
    Case 5 To 5.5:grade=165
    Case Else: grade=160
    End Select
    Dim As Integer w,h
    Dim As Integer pitch,pitch2,dpp,dpp2
    Dim  As Any Pointer row,row2
    Dim As Ulong Pointer pixel,pixel2
    Dim As Ulong col
    Imageinfo im,w,h,dpp,pitch,row
    Dim As Any Pointer temp=Imagecreate(w,h)
    Imageinfo temp,,,dpp2,pitch2,row2
    For y As long=0 To h-1
        For x As long=0 To w-1
            ppoint(x,y,col)
            Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
            If v>(grade+tweak) Then
                ppset2(x,y,newcol)
            Else
                ppset2(x,y,Rgb(255,0,255))
            End If
        Next x
    Next y
    Return temp
End Function

Sub CreateFont(Byref myfont As Any Pointer,Byval fontsize As Single,Byval col As Ulong,Byval tweak As long=0)
    fontsize=Int(2*Abs(fontsize))/2
    If fontsize=0 Then fontsize=.5
    Dim As Ubyte Ptr p
    Dim As Any Pointer temp
    Dim As integer i
    temp = Imagecreate(FontSize*768,FontSize*16)
    myfont=Imagecreate(FontSize*768,FontSize*16)
    For i = 32 To 127
        drawstring ((i-32)*FontSize*8,1,Chr(i),Rgb(255,255,255),FontSize,temp)
    Next i
    If fontsize>1.5 Then
        For n As Single=0 To fontsize-2:temp=filter(temp,1,1,0):Next
        End If
        temp=Colour(temp,col,tweak,fontsize)
        Put myfont,(0,0),temp,trans
        Imageinfo( myfont,i,,,, p )
        p[0]=0:p[1]=32:p[2]=127
        For i = 32 To 127
            p[3+i-32]=FontSize*8
        Next i
        Imagedestroy(temp)
    End Sub
   
   
    #define red rgb(255,0,0)'type<gl>({1,0,0})
    #define green rgb(0,255,0)' type<gl>({0,1,0})
    #define blue rgb(0,0,255)'type<gl>({0,0,1})
    #define black rgb(20,20,20)'type<gl>({0,0,0})
    #define pink rgb(255,100,255)'type<gl>({1,1,1}) 'mauve
    #define yellow  rgb(255,255,0)'type<gl>({1,1,0})
    #define aqua rgb(0,255,255)'type<gl>({0,1,1})
    #define orange rgb(255,100,0)'type<gl>({1,.5,0})
   
   
    Dim Shared As Ulong w(1 To 4,1 To 8)
    w(1,1)=red   :w(2,1)=yellow:w(3,1)=blue:w(4,1)=blue
    w(1,2)=green :w(2,2)=orange:w(3,2)=green:w(4,2)=orange
    w(1,3)=blue  :w(2,3)=green:w(3,3)=aqua:w(4,3)=red
    w(1,4)=black :w(2,4)=aqua:w(3,4)=orange:w(4,4)=black
    w(1,5)=pink :w(2,5)=blue:w(3,5)=pink:w(4,5)=yellow
    w(1,6)=yellow:w(2,6)=black:w(3,6)=red:w(4,6)=aqua
    w(1,7)=aqua :w(2,7)=red:w(3,7)=black:w(4,7)=green
    w(1,8)=orange:w(2,8)=pink:w(3,8)=yellow:w(4,8)=pink
   
    Declare  Function tmp(b1 As Ulong,b2 As Ulong,b3 As Ulong,b4 As Ulong) As String
   
    Dim Shared As long xres,yres
    xres=800
    yres=600
    #ifdef fullscreen
    Screenres xres,yres,32,,1
    #else
    Screenres xres,yres,32
    #endif
    Dim As Any Ptr scores,colours,frate
    createfont scores,2.5,Rgb(200,200,0)
    createfont colours,2,Rgb(100,0,50)
    createfont frate,1,Rgb(0,0,50)
    Dim Shared LightDiffuse(0 To 3) As Single ={.6,.6,.6,1}
    Dim Shared LightPosition(0 To 3) As Single ={0,0,1,1}'
    Var ctx = CreateRenderContext()
    glsetup
   
    Sub glsetup
        glShadeModel(GL_SMOOTH)                 ' Enables Smooth Color Shading
        glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST)
        glViewport(0, 0, xres, yres)       ' Set the viewport
        glMatrixMode(GL_PROJECTION)        ' Change Matrix Mode to Projection
        glLoadIdentity                     ' Reset View
        gluPerspective(45, xres/yres, 1, 100)
        glMatrixMode(GL_MODELVIEW)         ' Return to the modelview matrix
        glLoadIdentity                     '  Reset View
        glClearColor 0,.5,0,1              'background
        'Set up the light
        #ifndef tinyshade
        Exit Sub
        #endif
        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  'enable  lighting to colours
       
    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
   
    #define range(f,l) int(Rnd*((l+1)-(f))+(f))
   
    'SET UP THE EIGHT FACES
    Redim Shared As V3 a(1 To 4) 'For starters
    Dim Shared As V3 normals(1 To 8),rt(1 To 8)
   
    Dim As V3 ctr=Type(0,0,0)            'rotate about gl origin
    Dim As Double z=1.207106781186547*2  'z value of first face
    Dim As Double r=2*4*Atn(1)/8 'rotate angle (360/8)
   
    'first face (FRONT)
    a(1)=Type( 1, 1, z)
    a(2)=Type(-1, 1, z)
    a(3)=Type(-1,-1, z)
    a(4)=Type( 1,-1, z)
    Var c=.5*(a(1)+a(3))
    normals(1)=c
   
    For z As long=1 To 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(r,0,0),Type(1,1,1))
        a(n+2)=RotatePoint(ctr,a(n+2-4),Type(r,0,0),Type(1,1,1))
        a(n+3)=RotatePoint(ctr,a(n+3-4),Type(r,0,0),Type(1,1,1))
        a(n+4)=RotatePoint(ctr,a(n+4-4),Type(r,0,0),Type(1,1,1))
        c=.5*(a(n+1)+a(n+3))
        normals(z+1)=c
    Next z
    For n As long=1 To 8
        Var l=Sqr(normals(n).x^2+normals(n).y^2 +normals(n).z^2)
        normals(n)=(1/l)*normals(n) 'normalize
    Next n
    'NOW WE HAVE EIGHT FACES DONE And THE NORMALS TO EACH FACE.
   
    Sub DrawFaces(Byval rotangle As Single,x As Single,y As Single,Byval Z As Single,flag As long=1)
        Dim As Single pi=4*Atn(1)
        glLoadIdentity()
        glTranslatef(x,y,Z)
        glRotatef(rotangle,1,0,0)           ' Rotate
        glBegin(GL_QUADS)
       
        Dim As long n=0
        Dim As Ubyte r,g,b
        For z As long=1 To 8
           
            #ifndef tinyshade
            rt(z)=RotatePoint(Type(0,0,0),normals(z),Type(rotangle*pi/180,0,0),Type(1,1,1))
            #endif
            Var cc=w(flag,z)
            r= Cptr(Ubyte Ptr,@cc)[2]
            g= Cptr(Ubyte Ptr,@cc)[1]
            b= Cptr(Ubyte Ptr,@cc)[0]
            #ifndef tinyshade
            Var f=map(-1,1,rt(z).z,-1,1)
            r=r*f
            g=g*f
            b=b*f
            #endif
            glcolor3f(r/255,g/255,b/255)
            #ifdef tinyshade
            glNormal3f normals(z).x,normals(z).y,normals(z).z
            #endif
            glVertex3f(a(n+1).x,a(n+1).y,a(n+1).z)
            glVertex3f(a(n+2).x,a(n+2).y,a(n+2).z)
            glVertex3f(a(n+3).x,a(n+3).y,a(n+3).z)
            glVertex3f(a(n+4).x,a(n+4).y,a(n+4).z)
            n=n+4
        Next z
       
        glend
    End Sub
   
    Function nearest(a As Single) As long
        Dim As long pts(1 To 8)={0,45,90,135,180,225,270,315}
        For z As long=1 To 8
            If Abs(pts(z)-a) <= 23 Then Return pts(z)'45
        Next z
    End Function
   
    Function different(a As long,b As long,c As long,d As long) As long
        If a=b Then Return 0
        If a=c Then Return 0
        If b=c Then Return 0
        If d=a Or d=b Or d=c Then Return 0
        Return -1
    End Function
   
    Function Idx(angle As Single) As long
        Var q=(angle/45+1)
        q=10-q
        If q=9 Then q=1
        Return q
    End Function
   
    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 Long thisscore
    Dim As Single angle1,angle2=180,angle3=270,angle4
    Dim As Single k1=2,k2=3,k3=4,k4=5
    Dim As String ink
    Dim As long flag=1,toggle,counter=range(-20,20),starter=1,fps,cflag
    Dim As long f1,f2,f3,f4,diff=30
    Dim As long spent,gain,score,check
    Dim As Ulong t(1 To 4)
    glsetup
    Windowtitle "Four Drums"
    Randomize
   
    Do
        angle1+=k1
        angle2+=k2
        angle3+=k3
        angle4+=k4
        If angle1>=360 Then angle1=0
        If angle2>=360 Then angle2=0
        If angle3>=360 Then angle3=0
        If angle4>=360 Then angle4=0
        Screenlock
       
        glEnable (GL_CULL_FACE)
        Swap_Buffers(ctx)
       
        glClear(GL_COLOR_BUFFER_BIT)
       
        Draw String(100,20),"Paid:     IN      OUT",,scores
        Draw String(650,20),"Won",,scores
        Draw String(100,50),"          " +Str(spent)+"       "+Str(gain),,scores
        Draw String(650,50),Str(thisscore),,scores
        Draw String(10,yres-50),"Framerate " &fps,,frate
        Draw String(10,yres-20),"<Space bar> to re-start",,frate
        If f4 And cflag Then Draw String(.15*xres,yres-100),tmp(t(1),t(2),t(3),t(4)),,colours
        Dim As Single dg=0'.2'.3
        DrawFaces(angle1,-2.05-dg-1,0,-11,1)
        DrawFaces(angle2,0-1-dg/3,0,-11,2)
        DrawFaces(angle3,2.05-1+dg/3,0,-11,3)
        DrawFaces(angle4,4.1-1+dg,0,-11,4)
        Screenunlock
        'Flip
        'toggle and spacebar stuff
        If flag Mod 2 And starter Then
            starter=0
            angle1=nearest(angle1)
            angle2=nearest(angle2)
            angle3=nearest(angle3)
            angle4=nearest(angle4)
        Else
            counter+=1
            'stop wheels one after the other
            If counter=(60*2) Then f1=1
            If counter=(120*2) Then f2=1
            If counter=(180*2)+diff Then f3=1':score=1
            If counter =(240*2)+ diff Then f4=1 :score=1
            If f1=1 Then
                Var n=nearest(angle1)
                If angle1>n Then k1=-.5 Else  k1=.5
                If Abs(n-angle1)<=2 Then k1=0:angle1=n:t(1)= w(1,Idx(n))
            End If
           
            If f2=1 Then
                Var n=nearest(angle2)
                If angle2>n Then k2=-.5 Else k2=.5
                If Abs(n-angle2)<=2 Then k2=0:angle2=n: t(2)= w(2,Idx(n))
            End If
           
            If f3=1 Then
                Var n=nearest(angle3)
                If angle3>n Then k3= -.5 Else k3=.5
                If Abs(n-angle3)<=2 Then
                    k3=0:angle3=n
                    t(3)= w(3,Idx(n))
                End If
            End If
        End If
       
        If f4=1 Then
            Var n=nearest(angle4)
           
            If angle4>n Then k4=-.5 Else k4=.5
           
            If Abs(angle4-n)<=2 Then
                k4=0:angle4=n'earest(angle4)
                t(4)= w(4,Idx(n))
                If score=1 Then check=1
            End If 
            counter=range(0,60)
        End If
       
        If score And check Then
            thisscore=0
            check=0
            score=0
            cflag=1
            For n1 As Long=1 To 4
                For n2 As Long=n1+1 To 4
                    If t(n1)=t(n2) Then gain+=1:thisscore+=1
                    Next:Next
                    If thisscore=3 Then thisscore=5:gain+=5
                    If thisscore=2 Then thisscore=4:gain+=4
                    If thisscore=6 Then thisscore=12:gain+=12
                End If
                ink = Inkey
                If toggle =0  Then
                    If ink = " " Then flag+=1:toggle=1:counter=range(0,60):f1=0:f2=0:f3=0:f4=0:diff=range(0,60):spent+=1:cflag=0
                Else
                    Do
                        Randomize
                        k1=range(2,5)
                        k2=range(2,5)
                        k3=range(2,5)
                        k4=range(2,5)
                    Loop Until different(k1,k2,k3,k4)
                End If
                toggle=Len(ink)
                Sleep regulate(60,fps),1
            Loop Until ink=Chr(27)
            ' colour check
            Function tmp(b1 As Ulong,b2 As Ulong,b3 As Ulong,b4 As Ulong) As String
                Dim As String m1,m2,m3,m4
                If b1=blue Then m1="Blue"
                If b1=yellow Then m1="Yellow"
                If b1=green Then m1="Green"
                If b1=red Then m1="Red"
                If b1=aqua Then m1="Aqua"
                If b1=pink Then m1="pink"
                If b1=black Then m1="Black"
                If b1=orange Then m1="Orange"
               
                If b2=blue Then m2="Blue"
                If b2=yellow Then m2="Yellow"
                If b2=green Then m2="Green"
                If b2=red Then m2="Red"
                If b2=aqua Then m2="Aqua"
                If b2=pink Then m2="pink"
                If b2=black Then m2="Black"
                If b2=orange Then m2="Orange"
               
                If b3=blue Then m3="Blue"
                If b3=yellow Then m3="Yellow"
                If b3=green Then m3="Green"
                If b3=red Then m3="Red"
                If b3=aqua Then m3="Aqua"
                If b3=pink Then m3="pink"
                If b3=black Then m3="Black"
                If b3=orange Then m3="Orange"
               
                If b4=blue Then m4="Blue"
                If b4=yellow Then m4="Yellow"
                If b4=green Then m4="Green"
                If b4=red Then m4="Red"
                If b4=aqua Then m4="Aqua"
                If b4=pink Then m4="pink"
                If b4=black Then m4="Black"
                If b4=orange Then m4="Orange"
               
                Var ll=xres/80
                Var s1=String(ll-Len(m1)," "),s2=String(ll-Len(m2)," "),s3=String(ll-Len(m3)," ")
                Return m1 + s1 + m2 + s2 + m3 +s3 + m4
            End Function
             
D.J.Peters
Posts: 7667
Joined: May 28, 2005 3:28

Re: TinyGL for FreeBASIC.

Postby D.J.Peters » Aug 11, 2016 1:55

If you don't enable GL_COILOR_MATERIAL you can see light is working
Image
The result is what i would accept with your position inside the wheels !

for example light over the wheels LightPosition = {0,5,0,0}
Image
Be sure all your colors are in range of 0.0-1.0 and your normals in range of -1.0 - +1.0 !
The GPU will clamp all values in the right range for you but not the CPU :-)

Joshy
Last edited by D.J.Peters on Sep 25, 2017 21:44, edited 1 time in total.

Return to “Libraries”

Who is online

Users browsing this forum: No registered users and 2 guests