Basiccoder2, needs must gets me looking around.
Some of these windows shell instructions are very powerful.
I found mshta while working with Albert on his maverick gambling thing.
Code: Select all
'===============================================================================
#ifdef __fb_64bit__
#cmdline "-gen gas64"
#endif
#Include Once "GL/glu.bi"
#include Once "GL/glext.bi"
#include "fbgfx.bi"
#define range(f,l) Int(Rnd*((l+1)-(f))+(f))
#define Frange(f,l) Rnd*((l)-(f))+(f)
Dim Shared As Integer xres,yres
xres=800
yres=600
Screenres xres,yres,32,2,2
Screenset 1,0
Dim Shared As GLuint tex(1 To 52+1)
Dim Shared As Long drums(1 To 5)
Dim Shared As Long spoke
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
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 long _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As long 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
glShadeModel(GL_SMOOTH) ' Enables Smooth Color Shading
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST)
glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA)
glEnable GL_ALPHA
glEnable GL_BLEND
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+1)
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)
'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.0,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 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.
'three subs to switch from perspective to ortho and back
Sub remember_current_projection
glMatrixMode GL_PROJECTION
glPushMatrix
glMatrixMode GL_MODELVIEW
glPushMatrix
End Sub
Sub set_projection_ortho
glMatrixMode GL_PROJECTION
glLoadIdentity
glOrtho 0, xres, yres, 0,-1, 1
glMatrixMode GL_MODELVIEW
glLoadIdentity
' gldisable GL_LIGHTING
End Sub
Sub restore_previous_projection
glMatrixMode GL_PROJECTION
glPopMatrix
glMatrixMode GL_MODELVIEW
glPopMatrix
' glEnable GL_LIGHTING
End Sub
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,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
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+1
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 Long=1 To Ubound(face)
face(n)=Imagecreate(128,128,Rgba(255,255,255,255))
If n>=1 And n<=13 Then Drawstringgfx(10,35,Str(card(num))+""+ suit(1),Rgba(200,0,0,254),4,face(n))
If n>=14 And n<=26 Then Drawstringgfx(10,35,Str(card(num))+""+ suit(2),Rgba(200,0,0,254),4,face(n))
If n>=27 And n<=39 Then Drawstringgfx(10,35,Str(card(num))+""+ suit(3),Rgba(0,0,0,254),4,face(n))
If n>=40 And n<=52 Then Drawstringgfx(10,35,Str(card(num))+""+ suit(4),Rgba(0,0,0,254),4,face(n))
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 Long
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
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
glsetup
START:
Randomize Timer
Dim As Single k1,k2,k3,k4,k5
Dim As Long i(1 To 5)={1,2,3,4,5}
For n As Long=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 Long 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
glEnable (GL_CULL_FACE)
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)
remember_current_projection
set_projection_ortho
'glLoadIdentity()
'glTranslatef(0,0,0)
#macro hold
glbegin gl_Quads
glcolor4f 0,.2,0,1
glvertex2d xres,0
glvertex2d 0 ,0
glvertex2d 0 ,yres/6.5
glvertex2d xres,yres/6.5
glvertex2d xres,yres-yres/6.5
glvertex2d 0 ,yres-yres/6.5
glvertex2d 0 ,yres
glvertex2d xres,yres
glend
#endmacro
hold
drawstring(xres/4.35,yres/31,"Spent = " + Str(spent) ,Rgb(200,0,0),yres/245,xres,yres)
drawstring(xres/4.35,yres/12,"Payout = " + Str(gain) , Rgb(200,0,0),yres/245,xres,yres)
'drawstring(0,yres-30 ,"Framerate "&fps,textcol(),1)
drawstring(xres/1.75 , yres/15 ,"Diff = " + Str(gain-spent) , Rgb(200,0,0),yres/245,xres,yres)
If spoke Then
drawstring(xres/2.575,yres/1.025 ,"( Toggle b for payouts. )" , Rgb(200,0,0),yres/600,xres,yres)
drawstring(xres/3.20,yres/1.075,"Press ""space bar"" to Spin",Rgb(0,200,0),yres/400,xres,yres)
End If
If f5 Then
'drawstring(xres/3.75,yres/1.15, str(v(1)) ,rgb(0,0,200),yres/245,xres,yres)
'drawstring(xres/2.75,yres/1.15, str(v(2)) ,rgb(0,0,200),yres/245,xres,yres)
'drawstring(xres/2.10,yres/1.15, str(v(3)) ,rgb(0,0,200),yres/245,xres,yres)
'drawstring(xres/1.70,yres/1.15, str(v(4)) ,rgb(0,0,200),yres/245,xres,yres)
'drawstring(xres/1.40,yres/1.15, str(v(5)) ,rgb(0,0,200),yres/245,xres,yres)
End If
gllinewidth 8
glbegin gl_lines
glcolor3f(1,0,0)
glvertex2f(xres/4.89,yres/1.72): glvertex2f(xres/1.2575,yres/1.72)
glvertex2f(xres/4.89,yres/2.38): glvertex2f(xres/1.2575,yres/2.38)
glvertex2f(xres/4.89,yres/2.38): glvertex2f(xres/4.89 ,yres/1.72)
glvertex2f(xres/1.2575,yres/2.38): glvertex2f(xres/1.2575,yres/1.72)
glend
restore_previous_projection
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 spoke=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 Long 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 ink=" " Then spoke=0
If toggle = 0 Then
If ink = " " And counter >=(45*06) Then
For n As Long=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 Long i(1 To 5)={5,4,3,2,1}
For n As Long=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(40,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=""
Screenset 1,1
glEnable (GL_CULL_FACE)
glClear(GL_COLOR_BUFFER_BIT)
'var sz=350
drawstring(0,yres/100 ,"1 Pair (tens or better) = 1 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/28 ,"2 Pair = 5 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/14 ,"3 of a kind = 10 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/10 ,"Straight = 15 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/7.75,"Skip straight (1,3,5,7,9) = 15 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/6 ,"Flush (with any hand) =+25 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/5 ,"Fullhouse = 35 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/4.25,"4 of a kind = 100 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/3.75,"Royal straight = 150 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/3.25,"Straight flush = 250 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/2.95,"5 of a kind = 1000 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/2.65,"5 of a kind flush = 2000 " , Rgb(0,100,200),1.5,xres,yres)
drawstring(0,yres/2.45,"Royal straight flush = 4000 " , Rgb(0,100,200),1.5,xres,yres)
If lt<>t Then dt+="."
lt=t
'' drawstring(0,yres/2,"Wait five " &dt , textcol2(),1)
glend
If Inkey="b" Then Exit Do
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
Albert made some nice contributions to this forum over the years in many different fields.
I was sorry to see him kicked out for over zealous coding, nothing more, nothing less.
I think cortana might handle a microphone, you might get it command line, I have not tried.
-gen gas64 saved me here from looking for something -gen gcc 64 bits found as an error.
It is nigh impossible to debug from gcc's report.
Thank you SARG.