@Dodicat
We need to do better something different on the range() ,
the outer wheel only stops at red , black , aqua and orange .
the inner wheel does too , but sometime hits white , green and blue but never a yellow.
Squares
Re: Squares
I've put randomize before the main loop.
Added three integers, dirn,sflag,delta.
dirn alters the initial directions of turn.
sflag ensures a clean once only click on the inner.
delta is a random extra number to the inner spin (it spins a bit longer now)
lines 408:
range(1,4)
The wheels can spin faster in range 1 to 4, (previously 1 to 3)
Added three integers, dirn,sflag,delta.
dirn alters the initial directions of turn.
sflag ensures a clean once only click on the inner.
delta is a random extra number to the inner spin (it spins a bit longer now)
lines 408:
range(1,4)
The wheels can spin faster in range 1 to 4, (previously 1 to 3)
Code: Select all
#include once "windows.bi"
#include once "win/winnt.bi"
#include once "win/objbase.bi"
#inclib "ole32"
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
'===============================================================================
#Include Once "GL/glu.bi"
dim shared as integer xres=1024,yres=768
Screenres xres,yres,32,,2
Dim Shared As Double textcol(1 To 4 )={1,1,1,1}
Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour() As Double,size As Single,textangle As Single=0,charangle As Single=0)
glColor4f (colour(1),colour(2),colour(3),colour(4))
glend
glLineWidth(1.1*size)
glBegin (GL_LINES)
Type point2d
As Single x,y
End Type
Dim As Integer flag,codenum=256
If Instr(text,"|") Then flag=1
Static As Integer runflag
Static As point2d infoarray()
Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
If runflag=0 Then ' 'scan codenum of codepage once
Dim As Uinteger background=0
Screenres 10,10 '8 x 8 pixels on this screen
Dim count As Integer
For ch As Integer=1 To codenum
Cls
Draw String(1,1),Chr(ch)
For x As Integer=1 To 8 'scan for characters
For y As Integer=1 To 8
If Point(x,y)<>background Then
count=count+1
infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
End If
Next y
Next x
count=0
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As point2d temp(1 To 64,codenum),np
Dim As Single cr=.01745329,sta=Sin(textangle*cr),cta=Cos(textangle*cr), _
sca=Sin(charangle*cr),cca=Cos(charangle*cr),_
d_x=(size/2)*cta,d_y=(size/2)*sta
#macro rotate(p1,p2,c,s,d)
np.x=d*(C*(p2.x-p1.x)-S*(p2.y-p1.y)) +p1.x
np.y=d*(S*(p2.x-p1.x)+C*(p2.y-p1.y)) +p1.y
#endmacro
Dim As point2d cpt(1 To 64),c=Type<point2d>(xpos,ypos),c2
Dim As Integer dx=xpos,dy=ypos
For z6 As Integer=1 To Len(text)
var asci=text[z6-1]
If asci=124 Then
If charangle<>0 Then xpos=xpos+12*Sin(charangle*cr)
dx=xpos:dy=dy+12:Goto skip 'pipe | for new line
End If
For _x1 As Integer=1 To 64
temp(_x1,asci).x=infoarray(_x1,asci).x+dx
temp(_x1,asci).y=infoarray(_x1,asci).y+dy
rotate(c,temp(_x1,asci),cta,sta,size)
cpt(_x1)=np
var copyy=np.y
If charangle<>0 Then
Dim As Integer p
If flag Then p=1 Else p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr)))
rotate(c2,cpt(_x1),cca,sca,1)
If flag Then np.y=copyy
cpt(_x1)=np
End If
If infoarray(_x1,asci).x<>0 Then 'paint only relevant points
If Abs(size)>0 Then
glVertex3f (cpt(_x1).x-d_x,(cpt(_x1).y-d_y),0)
glVertex3f (cpt(_x1).x+d_x,(cpt(_x1).y+d_y),0)
End If
End If
Next _x1
dx=dx+8+4*(Sin(charangle*cr))*flag
skip:
Next z6
glend
End Sub
'initialize the fonts
Sub init Constructor 'automatic loader
Dim As Double col(1 To 4)
drawstring(0,0,"",col(),0)
Screen 0
End Sub
type glbox
as integer x,y,w,h
#define range(f,l) int(Rnd*((l+1)-(f))+(f))
end type
dim as glbox box1(1 to 9)
for n as integer=0 to 7
with box1(n+1)
.x=30
.w=50
.h=30
.y=100+.h*n
end with
next n
box1(9)=type<glbox>(xres/2-100,8,50,30)
dim as glbox box2(1 to 9)
for n as integer=0 to 7
with box2(n+1)
.x=90
.w=50
.h=30
.y=100+.h*n
end with
next n
box2(9)=type<glbox>(xres/2+50,8,50,30)
function inbox(b as glbox,x as integer,y as integer) as integer
return x>b.x and x<b.x+b.w and y>b.y and y<b.y+b.h
end function
Sub GL2dsetup
glMatrixMode (GL_PROJECTION)
glLoadIdentity ()
glOrtho (0,xres, yres,0, -1, 1)
glMatrixMode (GL_MODELVIEW)
glDisable (GL_DEPTH_TEST)
glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA)
glEnable (GL_BLEND)
glEnable (GL_LINE_SMOOTH)
glLineWidth(4)
glClearColor 0,.2,0,1
End Sub
Sub GLpolygon(n As Integer=8,_ 'number of sides
centreX As Integer,_ 'centres
centreY As Integer,_
col() As Single,_ 'dim 1 to 8,1 to 3
t As Integer=1,_ 'thickness
size As Integer=100,_ 'size
angle As Single=0,_ ' rotate
ex As Single=1,_ 'eccentricity on x plane
ey As Single=1,_ 'eccentricity on y plane
offset As Single=0) 'offset initial angle
angle=angle*0.0174532925199433 'degrees to radians
offset=offset*0.0174532925199433
Dim slug As Single=6.283185307179586/n
Dim As Single x1,x2,y1,y2
Dim As Single x1r,x2r,y1r,y2r
Dim As Integer count
Dim As Single cosangle=Cos(angle),sinangle=Sin(angle)
For z As Single=0+offset To 6.283185307179586 +offset Step slug
count+=1
If count>n Then Exit For
For k As Single =0 To t Step 1
x1=centrex+ex*(size-k)*Cos(z)
y1=centrey+ey*(size-k)*Sin(z)
x2=centrex+ex*(size-k)*Cos(z+slug)
y2=centrey+ey*(size-k)*Sin(z+slug)
'now rotate
x1r=(cosangle*(x1-centreX)-sinangle*(y1-centreY))+centreX
y1r=(sinangle*(x1-centreX)+cosangle*(y1-centreY))+centreY
x2r=(cosangle*(x2-centreX)-sinangle*(y2-centrey))+centreX
y2r=(sinangle*(x2-centreX)+cosangle*(y2-centreY))+centreY
'draw
glcolor4f (col(count,1),col(count,2),col(count,3),1)
glVertex2f (x1r, y1r)
glVertex2f (x2r,y2r)
Next k
Next z
End Sub
sub glbox(x as integer,y as integer,w as integer,h as integer)
glend
glbegin gl_quads
glVertex2f(x,y)
glVertex2f(x,y+h)
glVertex2f(x+w,y+h)
glVertex2f(x+w,y)
glVertex2f(x,y)
glend
end sub
Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
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
Function nearest(a As Single) As Integer
Dim As Integer pts(1 To 8)={0,45,90,135,180,225,270,315}
For z As Integer=1 To 8
If Abs(pts(z)-a) <= 23 Then Return pts(z)'45
Next z
End Function
function getmsg(p as ubyte ptr ) as string
dim as string m1
#define PP cast(ubyte ptr,p)
if pp[0] =255 and pp[1]=0 and pp[2]=0 then m1= " Red"
if pp[0] =0 and pp[1]=255 and pp[2]=0 then m1= " Green"
if pp[0] =0 and pp[1]=0 and pp[2]=255 then m1= " Blue"
if pp[0] =0 and pp[1]=0 and pp[2]=0 then m1= " Black"
if pp[0] =255 and pp[1]=255 and pp[2]=255 then m1= " White"
if pp[0] =255 and pp[1]=255 and pp[2]=0 then m1= "Yellow"
if pp[0] =0 and pp[1]=255 and pp[2]=255 then m1= " Aqua"
if pp[0] =255 and pp[1]=128 and pp[2]=0 then m1= "Orange"
return m1
end function
gl2dsetup
Dim i As String
Dim As Single angle1,angle2
Dim As Single col1(1 To 8,1 To 3)={ {1,0,0}, _
{0,1,0}, _
{0,0,1}, _
{0,0,0}, _
{1,1,1},_
{1,1,0}, _
{0,1,1}, _
{1,.5,0}}
Dim As Single col2(1 To 8,1 To 3)={ {1,0,0}, _
{0,1,0}, _
{0,0,1}, _
{0,0,0}, _
{1,1,1},_
{1,1,0}, _
{0,1,1}, _
{1,.5,0}}
Dim As Single k1=2,k2=3
Dim As Integer fps,mx,my,mb1,mb2 ,f,counter,f2,f1
dim as integer m1,m2 ,c1=0,c2=0,n1=0,n2 =0, m1hold=1 , m2hold =1 , spent =0 , gain=0,wheel_stop=0
dim as ubyte Finder
var dirn=1,sflag=0,delta=0
randomize
#undef beep
#define beep
Do
glReadPixels(573,640,1,1,GL_RGB,GL_UNSIGNED_BYTE,@Finder)
var msg1=getmsg(@Finder)
glReadPixels(573,580,1,1,GL_RGB,GL_UNSIGNED_BYTE,@Finder)
var msg2= getmsg(@Finder)
counter+=1
If counter=(60*2) Then f1=1
If counter>=(60*2*2)+delta Then f2=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
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':counter=0
counter=0
End If
getmouse mx,my,,mb1
for n as integer = 1 to 8
if inbox(box1(n),mx,my) and mb1=1 then m1=n :n1=n : m2 = 0 :m1hold=m1
next
getmouse mx,my,,mb2
for n as integer = 1 to 8
if inbox(box2(n),mx,my) and mb2=1 and sflag=0 then
sflag=1
if m2=0 then
do
dirn=range(-1,1)
loop until dirn<>0
end if
delta=Range(0,60)
m2=n : n2=n : m2hold = m2
end if
next
i=Inkey
angle1+=k1
angle2+=k2
If angle1>=360 Then angle1=0
If angle2>=360 Then angle2=0
glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)
for n as integer = 1 to 8
glcolor4f (col1(n,1),col1(n,2),col1(n,3),1)
glbox(box1(n).x,box1(n).y,box1(n).w ,box1(n).h)
glcolor4f (col2(n,1),col2(n,2),col2(n,3),1)
glbox(box2(n).x,box2(n).y,box2(n).w ,box2(n).h)
if mb1=1 and mb2=1 and m1<>0 and m2<>0 then
Do
f1=0:f2=0
k1=range(1,4)
k2=range(1,4)
loop until k1<>k2
counter=range(-60,0)
end if
next n
glcolor4f (col1(m1hold,1),col1(m1hold,2),col1(m1hold,3),1)
glbox(box1(9).x,box1(9).y,box1(9).w,box1(9).h)
glcolor4f (col2(m2hold,1),col2(m2hold,2),col2(m2hold,3),1)
glbox(box2(9).x,box2(9).y,box2(9).w,box2(9).h)
drawstring(40 ,85 , "outer",textcol(),.75)
drawstring(100 ,85 , "inner",textcol(),.75)
drawstring(15 , 115 , "1",textcol(),1)
drawstring(15 , 145 , "2",textcol(),1)
drawstring(15 , 175 , "3",textcol(),1)
drawstring(15 , 205 , "4",textcol(),1)
drawstring(15 , 235 , "5",textcol(),1)
drawstring(15 , 265 , "6",textcol(),1)
drawstring(15 , 295 , "7",textcol(),1)
drawstring(15 , 325 , "8",textcol(),1)
if m1<>0 and m2<>0 and mb1=1 and mb2=1 then
spent+=1
m1hold=m1
m2hold=m2
mb1=0
mb2=0
m1=0
m2=0
wheel_stop=1
end if
if k1=0 and k2=0 and wheel_stop=1 then
select case msg1
case " Red" : c1=1
case " Green" : c1=2
case " Blue" : c1=3
case " Black" : c1=4
case " White" : c1=5
case "Yellow" : c1=6
case " Aqua" : c1=7
case "Orange" : c1=8
end select
select case msg2
case " Red" : c2=1
case " Green" : c2=2
case " Blue" : c2=3
case " Black" : c2=4
case " White" : c2=5
case "Yellow" : c2=6
case " Aqua" : c2=7
case "Orange" : c2=8
end select
wheel_stop=0
if c1=c2 and n1=c1 and n2=c2 then gain+=8 :beep: speak( "you won 8 dollars"): goto done
if c1=c2 then gain+=4 :beep: speak( "you won 4 dollars"): goto done
if n1=c1 and n2=c2 then gain+=2 :beep: speak( "you won 2 dollars"): goto done
if n1=c1 or n1=c2 then gain+=1 :beep: speak( "you won 1 dollars"): goto done
if n2=c1 or n2=c2 then gain+=1 :beep: speak( "you won 1 dollars"): goto done
speak( "You lost")
end if
done:
drawstring(700,20 , msg1 + " " + msg2 ,textcol(),2)
drawstring(430,50 ,str(n1) + " " + str(n2),textcol(),2)
drawstring(430,75 ,str(c1) + " " + str(c2),textcol(),2)
drawstring(20,20 ,"Paid: IN OUT",textcol(),2)
drawstring(20,50, " " +Str(spent)+" "+Str(gain),textcol(),2)
glBegin (GL_LINES)
'windowtitle "" &counter
glpolygon(,xres/2,yres/2,col1(),50,300,angle1*dirn,,,22.5)
glpolygon(,xres/2,yres/2,col2(),50,245,-angle2*dirn,,,22.5)
glEnd()
sflag=mb2
Flip
Sleep regulate(60,fps),1
'RANDOMIZE' timer / int(rnd*200) / timer/rnd
Loop Until i=Chr(27)
Re: Squares
@Dodicat
At the request of my case mgr. I added instructions...
At the request of my case mgr. I added instructions...
Code: Select all
#include once "windows.bi"
#include once "win/winnt.bi"
#include once "win/objbase.bi"
#inclib "ole32"
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
'===============================================================================
#Include Once "GL/glu.bi"
dim shared as integer xres=1024,yres=768
Screenres xres,yres,32,,2
Dim Shared As Double textcol(1 To 4 )={1,1,1,1}
Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour() As Double,size As Single,textangle As Single=0,charangle As Single=0)
glColor4f (colour(1),colour(2),colour(3),colour(4))
glend
glLineWidth(1.1*size)
glBegin (GL_LINES)
Type point2d
As Single x,y
End Type
Dim As Integer flag,codenum=256
If Instr(text,"|") Then flag=1
Static As Integer runflag
Static As point2d infoarray()
Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
If runflag=0 Then ' 'scan codenum of codepage once
Dim As Uinteger background=0
Screenres 10,10 '8 x 8 pixels on this screen
Dim count As Integer
For ch As Integer=1 To codenum
Cls
Draw String(1,1),Chr(ch)
For x As Integer=1 To 8 'scan for characters
For y As Integer=1 To 8
If Point(x,y)<>background Then
count=count+1
infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
End If
Next y
Next x
count=0
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As point2d temp(1 To 64,codenum),np
Dim As Single cr=.01745329,sta=Sin(textangle*cr),cta=Cos(textangle*cr), _
sca=Sin(charangle*cr),cca=Cos(charangle*cr),_
d_x=(size/2)*cta,d_y=(size/2)*sta
#macro rotate(p1,p2,c,s,d)
np.x=d*(C*(p2.x-p1.x)-S*(p2.y-p1.y)) +p1.x
np.y=d*(S*(p2.x-p1.x)+C*(p2.y-p1.y)) +p1.y
#endmacro
Dim As point2d cpt(1 To 64),c=Type<point2d>(xpos,ypos),c2
Dim As Integer dx=xpos,dy=ypos
For z6 As Integer=1 To Len(text)
var asci=text[z6-1]
If asci=124 Then
If charangle<>0 Then xpos=xpos+12*Sin(charangle*cr)
dx=xpos:dy=dy+12:Goto skip 'pipe | for new line
End If
For _x1 As Integer=1 To 64
temp(_x1,asci).x=infoarray(_x1,asci).x+dx
temp(_x1,asci).y=infoarray(_x1,asci).y+dy
rotate(c,temp(_x1,asci),cta,sta,size)
cpt(_x1)=np
var copyy=np.y
If charangle<>0 Then
Dim As Integer p
If flag Then p=1 Else p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr)))
rotate(c2,cpt(_x1),cca,sca,1)
If flag Then np.y=copyy
cpt(_x1)=np
End If
If infoarray(_x1,asci).x<>0 Then 'paint only relevant points
If Abs(size)>0 Then
glVertex3f (cpt(_x1).x-d_x,(cpt(_x1).y-d_y),0)
glVertex3f (cpt(_x1).x+d_x,(cpt(_x1).y+d_y),0)
End If
End If
Next _x1
dx=dx+8+4*(Sin(charangle*cr))*flag
skip:
Next z6
glend
End Sub
'initialize the fonts
Sub init Constructor 'automatic loader
Dim As Double col(1 To 4)
drawstring(0,0,"",col(),0)
Screen 0
End Sub
type glbox
as integer x,y,w,h
#define range(f,l) int(Rnd*((l+1)-(f))+(f))
end type
dim as glbox box1(1 to 9)
for n as integer=0 to 7
with box1(n+1)
.x=30
.w=50
.h=30
.y=100+.h*n
end with
next n
box1(9)=type<glbox>(xres/2-100,8,50,30)
dim as glbox box2(1 to 9)
for n as integer=0 to 7
with box2(n+1)
.x=90
.w=50
.h=30
.y=100+.h*n
end with
next n
box2(9)=type<glbox>(xres/2+50,8,50,30)
function inbox(b as glbox,x as integer,y as integer) as integer
return x>b.x and x<b.x+b.w and y>b.y and y<b.y+b.h
end function
Sub GL2dsetup
glMatrixMode (GL_PROJECTION)
glLoadIdentity ()
glOrtho (0,xres, yres,0, -1, 1)
glMatrixMode (GL_MODELVIEW)
glDisable (GL_DEPTH_TEST)
glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA)
glEnable (GL_BLEND)
glEnable (GL_LINE_SMOOTH)
glLineWidth(4)
glClearColor 0,.2,0,1
End Sub
Sub GLpolygon(n As Integer=8,_ 'number of sides
centreX As Integer,_ 'centres
centreY As Integer,_
col() As Single,_ 'dim 1 to 8,1 to 3
t As Integer=1,_ 'thickness
size As Integer=100,_ 'size
angle As Single=0,_ ' rotate
ex As Single=1,_ 'eccentricity on x plane
ey As Single=1,_ 'eccentricity on y plane
offset As Single=0) 'offset initial angle
angle=angle*0.0174532925199433 'degrees to radians
offset=offset*0.0174532925199433
Dim slug As Single=6.283185307179586/n
Dim As Single x1,x2,y1,y2
Dim As Single x1r,x2r,y1r,y2r
Dim As Integer count
Dim As Single cosangle=Cos(angle),sinangle=Sin(angle)
For z As Single=0+offset To 6.283185307179586 +offset Step slug
count+=1
If count>n Then Exit For
For k As Single =0 To t Step 1
x1=centrex+ex*(size-k)*Cos(z)
y1=centrey+ey*(size-k)*Sin(z)
x2=centrex+ex*(size-k)*Cos(z+slug)
y2=centrey+ey*(size-k)*Sin(z+slug)
'now rotate
x1r=(cosangle*(x1-centreX)-sinangle*(y1-centreY))+centreX
y1r=(sinangle*(x1-centreX)+cosangle*(y1-centreY))+centreY
x2r=(cosangle*(x2-centreX)-sinangle*(y2-centrey))+centreX
y2r=(sinangle*(x2-centreX)+cosangle*(y2-centreY))+centreY
'draw
glcolor4f (col(count,1),col(count,2),col(count,3),1)
glVertex2f (x1r, y1r)
glVertex2f (x2r,y2r)
Next k
Next z
End Sub
sub glbox(x as integer,y as integer,w as integer,h as integer)
glend
glbegin gl_quads
glVertex2f(x,y)
glVertex2f(x,y+h)
glVertex2f(x+w,y+h)
glVertex2f(x+w,y)
glVertex2f(x,y)
glend
end sub
Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
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
Function nearest(a As Single) As Integer
Dim As Integer pts(1 To 8)={0,45,90,135,180,225,270,315}
For z As Integer=1 To 8
If Abs(pts(z)-a) <= 23 Then Return pts(z)'45
Next z
End Function
function getmsg(p as ubyte ptr ) as string
dim as string m1
#define PP cast(ubyte ptr,p)
if pp[0] =255 and pp[1]=0 and pp[2]=0 then m1= " Red"
if pp[0] =0 and pp[1]=255 and pp[2]=0 then m1= " Green"
if pp[0] =0 and pp[1]=0 and pp[2]=255 then m1= " Blue"
if pp[0] =0 and pp[1]=0 and pp[2]=0 then m1= " Black"
if pp[0] =255 and pp[1]=255 and pp[2]=255 then m1= " White"
if pp[0] =255 and pp[1]=255 and pp[2]=0 then m1= "Yellow"
if pp[0] =0 and pp[1]=255 and pp[2]=255 then m1= " Aqua"
if pp[0] =255 and pp[1]=128 and pp[2]=0 then m1= "Orange"
return m1
end function
gl2dsetup
Dim i As String
Dim As Single angle1,angle2
Dim As Single col1(1 To 8,1 To 3)={ {1,0,0}, _
{0,1,0}, _
{0,0,1}, _
{0,0,0}, _
{1,1,1},_
{1,1,0}, _
{0,1,1}, _
{1,.5,0}}
Dim As Single col2(1 To 8,1 To 3)={ {1,0,0}, _
{0,1,0}, _
{0,0,1}, _
{0,0,0}, _
{1,1,1},_
{1,1,0}, _
{0,1,1}, _
{1,.5,0}}
Dim As Single k1=2,k2=3
Dim As Integer fps,mx,my,mb1,mb2 ,f,counter,f2,f1
dim as integer m1,m2 ,c1=0,c2=0,n1=0,n2 =0, m1hold=1 , m2hold =1 , spent =0 , gain=0,wheel_stop=0
dim as ubyte Finder
var dirn=1,sflag=0,delta=0
randomize
#undef beep
#define beep
Do
glReadPixels(573,640,1,1,GL_RGB,GL_UNSIGNED_BYTE,@Finder)
var msg1=getmsg(@Finder)
glReadPixels(573,580,1,1,GL_RGB,GL_UNSIGNED_BYTE,@Finder)
var msg2= getmsg(@Finder)
counter+=1
If counter=(60*2) Then f1=1
If counter>=(60*2*2)+delta Then f2=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
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':counter=0
counter=0
End If
getmouse mx,my,,mb1
for n as integer = 1 to 8
if inbox(box1(n),mx,my) and mb1=1 then m1=n :n1=n : m2 = 0 :m1hold=m1
next
getmouse mx,my,,mb2
for n as integer = 1 to 8
if inbox(box2(n),mx,my) and mb2=1 and sflag=0 then
sflag=1
if m2=0 then
do
dirn=range(-1,1)
loop until dirn<>0
end if
delta=Range(0,60)
m2=n : n2=n : m2hold = m2
end if
next
i=Inkey
angle1+=k1
angle2+=k2
If angle1>=360 Then angle1=0
If angle2>=360 Then angle2=0
glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)
for n as integer = 1 to 8
glcolor4f (col1(n,1),col1(n,2),col1(n,3),1)
glbox(box1(n).x,box1(n).y,box1(n).w ,box1(n).h)
glcolor4f (col2(n,1),col2(n,2),col2(n,3),1)
glbox(box2(n).x,box2(n).y,box2(n).w ,box2(n).h)
if mb1=1 and mb2=1 and m1<>0 and m2<>0 then
Do
f1=0:f2=0
k1=range(1,4)
k2=range(1,4)
loop until k1<>k2
counter=range(-60,0)
end if
next n
glcolor4f (col1(m1hold,1),col1(m1hold,2),col1(m1hold,3),1)
glbox(box1(9).x,box1(9).y,box1(9).w,box1(9).h)
glcolor4f (col2(m2hold,1),col2(m2hold,2),col2(m2hold,3),1)
glbox(box2(9).x,box2(9).y,box2(9).w,box2(9).h)
drawstring(40 ,85 , "outer",textcol(),.75)
drawstring(100 ,85 , "inner",textcol(),.75)
drawstring(15 , 115 , "1",textcol(),1)
drawstring(15 , 145 , "2",textcol(),1)
drawstring(15 , 175 , "3",textcol(),1)
drawstring(15 , 205 , "4",textcol(),1)
drawstring(15 , 235 , "5",textcol(),1)
drawstring(15 , 265 , "6",textcol(),1)
drawstring(15 , 295 , "7",textcol(),1)
drawstring(15 , 325 , "8",textcol(),1)
if m1<>0 and m2<>0 and mb1=1 and mb2=1 then
spent+=1
m1hold=m1
m2hold=m2
mb1=0
mb2=0
m1=0
m2=0
wheel_stop=1
end if
if k1=0 and k2=0 and wheel_stop=1 then
select case msg1
case " Red" : c1=1
case " Green" : c1=2
case " Blue" : c1=3
case " Black" : c1=4
case " White" : c1=5
case "Yellow" : c1=6
case " Aqua" : c1=7
case "Orange" : c1=8
end select
select case msg2
case " Red" : c2=1
case " Green" : c2=2
case " Blue" : c2=3
case " Black" : c2=4
case " White" : c2=5
case "Yellow" : c2=6
case " Aqua" : c2=7
case "Orange" : c2=8
end select
wheel_stop=0
if c1=c2 and n1=c1 and n2=c2 then gain+=8 :beep: speak( "you won 8 dollars"): goto done
if c1=c2 then gain+=4 :beep: speak( "you won 4 dollars"): goto done
if n1=c1 and n2=c2 then gain+=2 :beep: speak( "you won 2 dollars"): goto done
if n1=c1 or n1=c2 then gain+=1 :beep: speak( "you won 1 dollars"): goto done
if n2=c1 or n2=c2 then gain+=1 :beep: speak( "you won 1 dollars"): goto done
speak( "You lost")
end if
done:
drawstring(20,20 ,"Paid: IN OUT",textcol(),2)
drawstring(20,50, " " +Str(spent)+" "+Str(gain),textcol(),2)
drawstring(20,570,"To play:", textcol(),1)
drawstring(20,600,"First click on an outer color" , textcol(),1)
drawstring(20,630,"Second click on an inner color" , textcol(),1)
drawstring(20,660,"To quit press 'esc'" , textcol(),1)
drawstring(700,20 , msg1 + " " + msg2 ,textcol(),2)
drawstring(430,50 ,str(n1) + " " + str(n2),textcol(),2)
drawstring(430,75 ,str(c1) + " " + str(c2),textcol(),2)
glBegin (GL_LINES)
'windowtitle "" &counter
glpolygon(,xres/2,yres/2,col1(),50,300,angle1*dirn,,,22.5)
glpolygon(,xres/2,yres/2,col2(),50,245,-angle2*dirn,,,22.5)
glEnd()
sflag=mb2
Flip
Sleep regulate(60,fps),1
'RANDOMIZE' timer / int(rnd*200) / timer/rnd
Loop Until i=Chr(27)
Re: Squares
Hi Albert.
I notice that speak has a slight lead on the wheels stopping (2 degrees).
If I make .5 the stop instead of 2 , lines 368/374, it is a bit better.
I notice that speak has a slight lead on the wheels stopping (2 degrees).
If I make .5 the stop instead of 2 , lines 368/374, it is a bit better.
Code: Select all
#include once "windows.bi"
#include once "win/winnt.bi"
#include once "win/objbase.bi"
#inclib "ole32"
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
'===============================================================================
#Include Once "GL/glu.bi"
dim shared as integer xres=1024,yres=768
Screenres xres,yres,32,,2
Dim Shared As Double textcol(1 To 4 )={1,1,1,1}
Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour() As Double,size As Single,textangle As Single=0,charangle As Single=0)
glColor4f (colour(1),colour(2),colour(3),colour(4))
glend
glLineWidth(1.1*size)
glBegin (GL_LINES)
Type point2d
As Single x,y
End Type
Dim As Integer flag,codenum=256
If Instr(text,"|") Then flag=1
Static As Integer runflag
Static As point2d infoarray()
Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
If runflag=0 Then ' 'scan codenum of codepage once
Dim As Uinteger background=0
Screenres 10,10 '8 x 8 pixels on this screen
Dim count As Integer
For ch As Integer=1 To codenum
Cls
Draw String(1,1),Chr(ch)
For x As Integer=1 To 8 'scan for characters
For y As Integer=1 To 8
If Point(x,y)<>background Then
count=count+1
infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
End If
Next y
Next x
count=0
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As point2d temp(1 To 64,codenum),np
Dim As Single cr=.01745329,sta=Sin(textangle*cr),cta=Cos(textangle*cr), _
sca=Sin(charangle*cr),cca=Cos(charangle*cr),_
d_x=(size/2)*cta,d_y=(size/2)*sta
#macro rotate(p1,p2,c,s,d)
np.x=d*(C*(p2.x-p1.x)-S*(p2.y-p1.y)) +p1.x
np.y=d*(S*(p2.x-p1.x)+C*(p2.y-p1.y)) +p1.y
#endmacro
Dim As point2d cpt(1 To 64),c=Type<point2d>(xpos,ypos),c2
Dim As Integer dx=xpos,dy=ypos
For z6 As Integer=1 To Len(text)
var asci=text[z6-1]
If asci=124 Then
If charangle<>0 Then xpos=xpos+12*Sin(charangle*cr)
dx=xpos:dy=dy+12:Goto skip 'pipe | for new line
End If
For _x1 As Integer=1 To 64
temp(_x1,asci).x=infoarray(_x1,asci).x+dx
temp(_x1,asci).y=infoarray(_x1,asci).y+dy
rotate(c,temp(_x1,asci),cta,sta,size)
cpt(_x1)=np
var copyy=np.y
If charangle<>0 Then
Dim As Integer p
If flag Then p=1 Else p=(z6-1)
c2=Type<point2d>(xpos+(size*8)*p*(Cos(textangle*cr)),ypos+(size*8)*p*(Sin(textangle*cr)))
rotate(c2,cpt(_x1),cca,sca,1)
If flag Then np.y=copyy
cpt(_x1)=np
End If
If infoarray(_x1,asci).x<>0 Then 'paint only relevant points
If Abs(size)>0 Then
glVertex3f (cpt(_x1).x-d_x,(cpt(_x1).y-d_y),0)
glVertex3f (cpt(_x1).x+d_x,(cpt(_x1).y+d_y),0)
End If
End If
Next _x1
dx=dx+8+4*(Sin(charangle*cr))*flag
skip:
Next z6
glend
End Sub
'initialize the fonts
Sub init Constructor 'automatic loader
Dim As Double col(1 To 4)
drawstring(0,0,"",col(),0)
Screen 0
End Sub
type glbox
as integer x,y,w,h
#define range(f,l) int(Rnd*((l+1)-(f))+(f))
end type
dim as glbox box1(1 to 9)
for n as integer=0 to 7
with box1(n+1)
.x=30
.w=50
.h=30
.y=100+.h*n
end with
next n
box1(9)=type<glbox>(xres/2-100,8,50,30)
dim as glbox box2(1 to 9)
for n as integer=0 to 7
with box2(n+1)
.x=90
.w=50
.h=30
.y=100+.h*n
end with
next n
box2(9)=type<glbox>(xres/2+50,8,50,30)
function inbox(b as glbox,x as integer,y as integer) as integer
return x>b.x and x<b.x+b.w and y>b.y and y<b.y+b.h
end function
Sub GL2dsetup
glMatrixMode (GL_PROJECTION)
glLoadIdentity ()
glOrtho (0,xres, yres,0, -1, 1)
glMatrixMode (GL_MODELVIEW)
glDisable (GL_DEPTH_TEST)
glBlendFunc(GL_SRC_ALPHA,GL_ONE_MINUS_SRC_ALPHA)
glEnable (GL_BLEND)
glEnable (GL_LINE_SMOOTH)
glLineWidth(4)
glClearColor 0,.2,0,1
End Sub
Sub GLpolygon(n As Integer=8,_ 'number of sides
centreX As Integer,_ 'centres
centreY As Integer,_
col() As Single,_ 'dim 1 to 8,1 to 3
t As Integer=1,_ 'thickness
size As Integer=100,_ 'size
angle As Single=0,_ ' rotate
ex As Single=1,_ 'eccentricity on x plane
ey As Single=1,_ 'eccentricity on y plane
offset As Single=0) 'offset initial angle
angle=angle*0.0174532925199433 'degrees to radians
offset=offset*0.0174532925199433
Dim slug As Single=6.283185307179586/n
Dim As Single x1,x2,y1,y2
Dim As Single x1r,x2r,y1r,y2r
Dim As Integer count
Dim As Single cosangle=Cos(angle),sinangle=Sin(angle)
For z As Single=0+offset To 6.283185307179586 +offset Step slug
count+=1
If count>n Then Exit For
For k As Single =0 To t Step 1
x1=centrex+ex*(size-k)*Cos(z)
y1=centrey+ey*(size-k)*Sin(z)
x2=centrex+ex*(size-k)*Cos(z+slug)
y2=centrey+ey*(size-k)*Sin(z+slug)
'now rotate
x1r=(cosangle*(x1-centreX)-sinangle*(y1-centreY))+centreX
y1r=(sinangle*(x1-centreX)+cosangle*(y1-centreY))+centreY
x2r=(cosangle*(x2-centreX)-sinangle*(y2-centrey))+centreX
y2r=(sinangle*(x2-centreX)+cosangle*(y2-centreY))+centreY
'draw
glcolor4f (col(count,1),col(count,2),col(count,3),1)
glVertex2f (x1r, y1r)
glVertex2f (x2r,y2r)
Next k
Next z
End Sub
sub glbox(x as integer,y as integer,w as integer,h as integer)
glend
glbegin gl_quads
glVertex2f(x,y)
glVertex2f(x,y+h)
glVertex2f(x+w,y+h)
glVertex2f(x+w,y)
glVertex2f(x,y)
glend
end sub
Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
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
Function nearest(a As Single) As Integer
Dim As Integer pts(1 To 8)={0,45,90,135,180,225,270,315}
For z As Integer=1 To 8
If Abs(pts(z)-a) <= 23 Then Return pts(z)'45
Next z
End Function
function getmsg(p as ubyte ptr ) as string
dim as string m1
#define PP cast(ubyte ptr,p)
if pp[0] =255 and pp[1]=0 and pp[2]=0 then m1= " Red"
if pp[0] =0 and pp[1]=255 and pp[2]=0 then m1= " Green"
if pp[0] =0 and pp[1]=0 and pp[2]=255 then m1= " Blue"
if pp[0] =0 and pp[1]=0 and pp[2]=0 then m1= " Black"
if pp[0] =255 and pp[1]=255 and pp[2]=255 then m1= " White"
if pp[0] =255 and pp[1]=255 and pp[2]=0 then m1= "Yellow"
if pp[0] =0 and pp[1]=255 and pp[2]=255 then m1= " Aqua"
if pp[0] =255 and pp[1]=128 and pp[2]=0 then m1= "Orange"
return m1
end function
gl2dsetup
Dim i As String
Dim As Single angle1,angle2
Dim As Single col1(1 To 8,1 To 3)={ {1,0,0}, _
{0,1,0}, _
{0,0,1}, _
{0,0,0}, _
{1,1,1},_
{1,1,0}, _
{0,1,1}, _
{1,.5,0}}
Dim As Single col2(1 To 8,1 To 3)={ {1,0,0}, _
{0,1,0}, _
{0,0,1}, _
{0,0,0}, _
{1,1,1},_
{1,1,0}, _
{0,1,1}, _
{1,.5,0}}
Dim As Single k1=2,k2=3
Dim As Integer fps,mx,my,mb1,mb2 ,f,counter,f2,f1
dim as integer m1,m2 ,c1=0,c2=0,n1=0,n2 =0, m1hold=1 , m2hold =1 , spent =0 , gain=0,wheel_stop=0
dim as ubyte Finder
var dirn=1,sflag=0,delta=0
randomize
Do
glReadPixels(573,640,1,1,GL_RGB,GL_UNSIGNED_BYTE,@Finder)
var msg1=getmsg(@Finder)
glReadPixels(573,580,1,1,GL_RGB,GL_UNSIGNED_BYTE,@Finder)
var msg2= getmsg(@Finder)
counter+=1
If counter=(60*2) Then f1=1
If counter>=(60*2*2)+delta Then f2=1
If f1=1 Then
var n=nearest(angle1)
If angle1>n Then k1=-.5 Else k1=.5
If Abs(n-angle1)<.5 Then k1=0:angle1=n
End If
If f2=1 Then
var n=nearest(angle2)
If angle2>n Then k2=-.5 Else k2=.5
If Abs(n-angle2)<.5 Then k2=0:angle2=n
counter=0
End If
getmouse mx,my,,mb1
for n as integer = 1 to 8
if inbox(box1(n),mx,my) and mb1=1 then m1=n :n1=n : m2 = 0 :m1hold=m1
next
getmouse mx,my,,mb2
for n as integer = 1 to 8
if inbox(box2(n),mx,my) and mb2=1 and sflag=0 then
sflag=1
if m2=0 then
do
dirn=range(-1,1)
loop until dirn<>0
end if
delta=Range(0,60)
m2=n : n2=n : m2hold = m2
end if
next
i=Inkey
angle1+=k1
angle2+=k2
If angle1>=360 Then angle1=0
If angle2>=360 Then angle2=0
glClear(GL_COLOR_BUFFER_BIT Or GL_DEPTH_BUFFER_BIT)
for n as integer = 1 to 8
glcolor4f (col1(n,1),col1(n,2),col1(n,3),1)
glbox(box1(n).x,box1(n).y,box1(n).w ,box1(n).h)
glcolor4f (col2(n,1),col2(n,2),col2(n,3),1)
glbox(box2(n).x,box2(n).y,box2(n).w ,box2(n).h)
if mb1=1 and mb2=1 and m1<>0 and m2<>0 then
Do
f1=0:f2=0
k1=range(1,4)
k2=range(1,4)
loop until k1<>k2
counter=range(-60,0)
end if
next n
glcolor4f (col1(m1hold,1),col1(m1hold,2),col1(m1hold,3),1)
glbox(box1(9).x,box1(9).y,box1(9).w,box1(9).h)
glcolor4f (col2(m2hold,1),col2(m2hold,2),col2(m2hold,3),1)
glbox(box2(9).x,box2(9).y,box2(9).w,box2(9).h)
drawstring(40 ,85 , "outer",textcol(),.75)
drawstring(100 ,85 , "inner",textcol(),.75)
drawstring(15 , 115 , "1",textcol(),1)
drawstring(15 , 145 , "2",textcol(),1)
drawstring(15 , 175 , "3",textcol(),1)
drawstring(15 , 205 , "4",textcol(),1)
drawstring(15 , 235 , "5",textcol(),1)
drawstring(15 , 265 , "6",textcol(),1)
drawstring(15 , 295 , "7",textcol(),1)
drawstring(15 , 325 , "8",textcol(),1)
if m1<>0 and m2<>0 and mb1=1 and mb2=1 then
spent+=1
m1hold=m1
m2hold=m2
mb1=0
mb2=0
m1=0
m2=0
wheel_stop=1
end if
if k1=0 and k2=0 and wheel_stop=1 then
select case msg1
case " Red" : c1=1
case " Green" : c1=2
case " Blue" : c1=3
case " Black" : c1=4
case " White" : c1=5
case "Yellow" : c1=6
case " Aqua" : c1=7
case "Orange" : c1=8
end select
select case msg2
case " Red" : c2=1
case " Green" : c2=2
case " Blue" : c2=3
case " Black" : c2=4
case " White" : c2=5
case "Yellow" : c2=6
case " Aqua" : c2=7
case "Orange" : c2=8
end select
wheel_stop=0
if c1=c2 and n1=c1 and n2=c2 then gain+=8 : speak( "you won 8 dollars"): goto done
if c1=c2 then gain+=4 : speak( "you won 4 dollars"): goto done
if n1=c1 and n2=c2 then gain+=2 : speak( "you won 2 dollars"): goto done
if n1=c1 or n1=c2 then gain+=1 : speak( "you won 1 dollars"): goto done
if n2=c1 or n2=c2 then gain+=1 : speak( "you won 1 dollars"): goto done
speak( "You lost")
end if
done:
drawstring(20,20 ,"Paid: IN OUT",textcol(),2)
drawstring(20,50, " " +Str(spent)+" "+Str(gain),textcol(),2)
drawstring(20,570,"To play:", textcol(),1)
drawstring(20,600,"First click on an outer color" , textcol(),1)
drawstring(20,630,"Second click on an inner color" , textcol(),1)
drawstring(20,660,"To quit press 'esc'" , textcol(),1)
drawstring(700,20 , msg1 + " " + msg2 ,textcol(),2)
drawstring(430,50 ,str(n1) + " " + str(n2),textcol(),2)
drawstring(430,75 ,str(c1) + " " + str(c2),textcol(),2)
glBegin (GL_LINES)
'windowtitle "" &angle2
glpolygon(,xres/2,yres/2,col1(),50,300,angle1*dirn,,,22.5)
glpolygon(,xres/2,yres/2,col2(),50,245,-angle2*dirn,,,22.5)
glEnd()
sflag=mb2
Flip
Sleep regulate(60,fps),1
'RANDOMIZE' timer / int(rnd*200) / timer/rnd
Loop Until i=Chr(27)
Re: Squares
@Dodicat
You did a nice job! Thanks. Now its time to get busted for having an illegal gambling operation. (HaHa!!)
You did a nice job! Thanks. Now its time to get busted for having an illegal gambling operation. (HaHa!!)
Re: Squares
doodle 10-6
Code: Select all
dim as integer xres,yres
screen 19
screeninfo xres,yres
screenres xres,yres
dim as double c1,c2,s1,s2
dim as double x1,x2,y1,y2
dim as double rad=atn(1)/-45
dim as double xctr,yctr,radius=150
dim as double deg1,deg2,span
xctr=xres/2
yctr=yres/2
for deg1 = 0 to 360 step .5
c1=cos(deg1*rad)
s1=sin(deg1*rad)^3
for deg2 = 0 to 360 step 2
c2 = cos(deg2*rad+c1)
s2 = sin(deg2*rad+s1)
x1=radius*c1*c1*atn(c1*c2*s2)*tan(log(c1/c2/s1*s2))
x2=radius*c2*s1*c1*(s1/c2/s2/c1)/2*cos((x1+y2)/50)*(y2/50)
y1=radius*s1*c1*s1/cos(c2*s1/s2*atn(c2+s2+c1))*((x2+y2)/10*c1*s2)/2
y2=radius*s2*s1^c1^atan2(deg1,c2)
y1+=s1*c1^s1^cos(c2*s1/s2*atn(c2+s2+c1))*((x2+y2)/10*c1*s2)/2
y2+=s1*s1^c1^atan2(deg1,c2)
y1/=s1*c1^s1^cos(c2*s1/s2*atn(c2+s2+c1))*((x2+y2)/10*c1*s2)/2
y2/=s1*s1^c1^atan2(deg1,c2)
pset( xctr++(x1+x2) , yctr++(y1+y2) ) , 9
pset( xctr++(x1+x2) , yctr+-(y1+y2) ) , 9
pset( xctr+-(x1+x2) , yctr++(y1+y2) ) , 9
pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , 9
pset( xctr++(y1+y2) , yctr++(x1+x2) ) , 9
pset( xctr++(y1+y2) , yctr+-(x1+x2) ) , 9
pset( xctr+-(y1+y2) , yctr++(x1+x2) ) , 9
pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , 9
next
next
sleep
END
Re: Squares
let's take it to the next level.
Code: Select all
type tImage
as any ptr img, pixels_any
as integer w,h,bpp,bypp,pitch,num_pages,flags, wm,hm,pitchBy
Declare Sub screen_init(wid As UShort = 1, hgt As UShort = 1, bpp_ as UInteger = 32, numPages as integer = 1, Flags as integer = 0)
Declare Function create(pWid As UShort = 1, pHgt As UShort = 1, color As Ulong = RGB(127,127,127)) As Any ptr
Declare Sub blit( dest as tImage ptr, x as integer=0, y as integer=0 )
declare sub checker_background(pColor As ULong=RGBA(145,145,145,255), CheckerSize As UInteger = 12)
Declare Destructor
Private:
as integer is_screen
Declare Sub destroy
end type
Sub tImage.Destroy()
If img <> 0 Then ImageDestroy img: img = 0
End Sub
Destructor tImage
Destroy
End Destructor
Sub tImage.screen_init(Wid As UShort, Hgt As UShort, bpp as UInteger, numpages as integer, flags as integer)
Destroy ' in case the image is being re-purposed
num_pages = numpages: this.bpp = bpp: this.flags=flags
ScreenRes Wid,Hgt,bpp,numPages,Flags
ScreenInfo w,h, bpp, bypp, pitch: pixels_any = ScreenPtr
if numPages > 1 then screenset 0,1
if pixels_any <> 0 then is_screen = -1
wm = w-1: hm = h-1: pitchBy = pitch \ bypp
End sub
Function tImage.create(wid As UShort, hgt As UShort, col As ULong) As Any Ptr
Destroy ' in case the image is being re-purposed
img = ImageCreate( wid, hgt, col, 32 )
ImageInfo img, w, h, bypp, pitch, pixels_any
is_screen=0
wm = w-1: hm = h-1: pitchBy = pitch \ bypp
Return img
End Function
sub tImage.blit( dest as tImage ptr, _x1 as integer, _y1 as integer )
dim as integer x1 = _x1, x2 = x1 + wm: if x1 < 0 then x1 = 0
dim as integer y1 = _y1, y2 = y1 + hm: if y1 < 0 then y1 = 0
if x2 > dest->wm then x2 = dest->wm
if y2 > dest->hm then y2 = dest->hm
dim as integer cols = x2 - x1 + 1: if cols < 1 then exit sub
dim as integer rows = y2 - y1 + 1: if rows < 1 then exit sub
dim as ulong ptr _src = pixels_any, dst = dest->pixels_any + y1 * dest->pitchBy + x1
'' shortcut of saying "if _y1 < 0 then _y1 = 0"
_src += _y1 * (_y1 < 0) * pitchBy + _x1 * (_x1 < 0)
dim as integer colsm = cols - 1
for y as integer = 1 to rows
dim as ulong ptr src = _src
for x as ulong ptr = dst to @dst[colsm]
*x = *src: src += 1
next: dst += dest->pitchBy: _src += pitchBy
next
end sub
Sub tImage.checker_background(pColor As ULong, CheckerSize As UInteger)
Dim As UInteger SizeDouble=CheckerSize*2,SizeM=CheckerSize-1
For Y as integer = 0 To hm Step CheckerSize
For X as integer = -CheckerSize * ((Y/SizeDouble)=Int(Y/SizeDouble)) To wm Step SizeDouble
Line this.img,(X,Y)-(X+SizeM,Y+SizeM),pColor,BF
Next
Next
End Sub
#Macro Alpha256(ret,back, fore, am, a256)
ret=((_
(fore And &Hff00ff) * a256 + _
(back And &Hff00ff) * am + &H800080) And &Hff00ff00 Or (_
(fore And &H00ff00) * a256 + _
(back And &H00ff00) * am + &H008000) And &H00ff0000) Shr 8
#EndMacro
const TwoPi = 8 * Atn(1)
const Pi = 4 * Atn(1)
' --- stack handler --- '
type stack_elem
as single iAngle, iiAngle, len
End Type
Type t_SH_DataType As stack_elem 'alias type for stack handler
Type tStackHandler
as any ptr p
as integer stackp
As Single expansion_coeff = 1.5
As String data
Declare Sub append(valu As t_SH_DataType)
private:
Declare Sub preserve
as integer elem_size, marker, size_x_len
as any ptr srcAny
End Type
Sub tStackHandler.preserve
elem_size = Len(t_SH_DataType): size_x_len = marker * elem_size
Dim As String sav = data: data = Space(size_x_len)
p = @data[0]: srcAny = @sav[0]
Dim As t_SH_DataType Ptr src = srcAny, _dst = p
For dst As t_SH_DataType Ptr = @_dst[0] To @_dst[stackp-1]
*dst = *src: src+=1
Next
End Sub
Sub tStackHandler.append(valu As t_SH_DataType)
If stackp = marker Then marker = (stackp+1) * expansion_coeff: preserve
p = @data[0]
Dim As t_SH_DataType ptr p = this.p: p[stackp] = valu: stackp += 1
End Sub
' --- custom draw udt --- '
#Macro RotC_(dsta,dstb,srca,srcb)
temp = cosa_*srca - sina_*srcb
dstb = cosa_*srcb + sina_*srca
dsta = temp
#EndMacro
#Macro DrawDotCommon(pdest,_col)
for pixy as ulong ptr = @pixels[y1] to @pixels[y2] step pdest->pitchBy
dim as single ySq = dy*dy, radSq_Minus_ySq = radSq-ySq
dim as single dx = x1-_sx
for pix as ulong ptr = @pixy[x1] to @pixy[x2]
dim as single d=dx*dx: dx+=1
if d < radSq_Minus_ySq Then
dim as long a256= ((rad-sqr(d+ySq)) * a_256)
dim as long am= 256-a256
Alpha256(*pix,*pix, _col_, am, a256)
End If
Next: dy+=1
Next
#EndMacro
#Macro DrawDot(pdest,x,y,z,_col,alpha_0to1)
dim as single _sx=(x)'+0.5 ''if rounding mode is down
dim as single _sy=(y)'+0.5
Dim As Single rad=(z)
Dim As Single radSq = rad*rad
dim as single a_256 = (alpha_0to1) * (_col shr 24) / rad
Dim As Integer y1 = _sy-rad: if y1<0 then y1=0
Dim As Integer y2 = _sy+rad: if y2>pdest->hm then y2=pdest->hm
Dim As Integer x1 = _sx-rad: if x1<0 then x1=0
Dim As Integer x2 = _sx+rad: if x2>pdest->wm then x2=pdest->wm: _sx -= 0.5
dim as single dy = y1 - (_sy-0.5), _dx = x1 - _sx: y1 *= pdest->pitchBy: y2 *= pdest->pitchBy
dim as ulong ptr pixels = pdest->pixels_any
dim as ulong _col_ = _col
DrawDotCommon(pdest,_col)
#EndMacro '' DrawDot
#Macro DrawDot_nodim(pdest,x,y,z,_col,alpha_0to1)
_sx=(x)'+0.5 ''if rounding mode is down
_sy=(y)'+0.5
rad=(z)
radSq = rad*rad
a_256 = (alpha_0to1) * (_col shr 24) / rad
y1 = _sy-rad: if y1<0 then y1=0
y2 = _sy+rad: if y2>pdest->hm then y2=pdest->hm
x1 = _sx-rad: if x1<0 then x1=0
x2 = _sx+rad: if x2>pdest->wm then x2=pdest->wm: _sx -= 0.5
dy = y1 - (_sy-0.5): _dx = x1 - _sx: y1 *= pdest->pitchBy: y2 *= pdest->pitchBy
DrawDotCommon(pdest,_col)
#EndMacro '' DrawDot
type tDrawShape
as single pos_step = .34
declare sub reset
declare sub render_target(byref dest as tImage)
declare sub random_shape( num_petals as integer = 3 + rnd * 14 )
declare sub draw( xp as single = 0.5, yp as single = 0.5 )
private:
declare sub push( iAngl0 as single = TwoPi * (rnd-0.5) / 100, _
iAngl1 as single = TwoPi * (rnd-0.5) / 1000, _
len as single = 10 + rnd * 150 )
as tStackHandler tSH
dim as stack_elem elem
as tImage ptr pdest
as integer num_petals
as double invisline_len, invisline_angle, invisline_lenperp, invisline_angle_petalstart
End Type
sub tDrawShape.reset
tSH.stackp = 0
End Sub
sub tDrawShape.render_target(byref dest as tImage)
pdest = @dest
End Sub
sub tDrawShape.push( iAngl as single, iiAngl as single, _len as single )
elem.iangle = -iAngl: elem.iiangle = -iiAngl: elem.len = _len
tSH.append elem
End Sub
sub tDrawShape.random_shape( _num_petals as integer )
reset
num_petals = _num_petals
dim as integer sections = 7 + rnd * 2
dim as single wire_tightness = 1.15 * (Rnd + 0.25) * pi
for i as integer = 1 to sections
dim as single seg_len = 10 + rnd * 400
dim as single angle_inc = wire_tightness / (0.2 + rnd * 10)
#define iangl rnd * angle_inc * (rnd-0.5)
push iangl, iangl, seg_len
next
invisline_angle = rnd * TwoPi
invisline_len = (rnd-0.0) * 275
invisline_lenperp = (rnd-0.1) * 25
invisline_angle_petalstart = (Rnd-0.5) * TwoPi
End Sub
sub tDrawShape.draw(xp as single, yp as single)
if pdest = 0 then ? "please set render_target": exit sub
if pdest->h < 1 then ? "please initialize gfx": exit sub
if tSH.stackp < 1 then ? "please define some points using .push": exit sub
dim as double cosa = cos(invisline_angle), sina = sin(invisline_angle)
dim as double x = invisline_len * cosa - invisline_lenperp * sina
dim as double x_m = invisline_len * cosa + invisline_lenperp * sina
dim as double y = invisline_len * sina + invisline_lenperp * cosa
dim as double y_m = invisline_len * sina - invisline_lenperp * cosa
dim as double a = invisline_angle_petalstart
dim as double a_m = -a: a += invisline_angle: a_m += invisline_angle
dim as t_SH_DataType ptr pp = tSH.p
dim as single cenx = pdest->wm * xp
dim as single ceny = pdest->hm * yp
dim as ulong col = 255 shl 24 or rnd*&HFFFFFF
dim as single dot_size = 1.27, alph = 0.37
dim as single petal_ang_inc = TwoPi / num_petals
Dim As double cosa__ = Cos(petal_ang_inc), sina__ = Sin(petal_ang_inc), cosa_ = cosa__, temp
'col = &HFFFFFFFF
for p as t_SH_DataType ptr = @pp[0] to @pp[tSH.stackp-1]
dim as single plen = p->len: if plen = 0 then plen = 1
dim as double iangle = p->iangle
dim as double iiangle = (p->iiangle - iangle) / plen
dim as integer j = abs(plen) + 0.5
if plen < 0 then a += pi
for i as integer = 0 to j
dim as single sx = x, sy = y, sx_m = x_m, sy_m = y_m
for i as integer = 1 to num_petals
dim as double sina_ = sina__
RotC_(sx,sy,sx,sy)
DrawDot(pdest, sx+cenx, sy+ceny, dot_size, col, alph)
sina_ = -sina__
RotC_(sx_m,sy_m,sx_m,sy_m)
DrawDot_nodim(pdest,sx_m+cenx,sy_m+ceny,dot_size,col,alph)
Next
if rnd < 0.0012 then col = 255 shl 24 or rnd*&HFFFFFF
x += pos_step * cos(a)
y += pos_step * sin(a)
x_m += pos_step * cos(a_m)
y_m += pos_step * sin(a_m)
a += iangle
a_m -= iangle
iangle += iiangle
Next: a -= (iangle - iiangle): a_m += (iangle - iiangle)
Next
End Sub
sub Main
dim as tImage buf, img
dim as tDrawShape DS
const BORDERLESS = 8
buf.screen_init 768, 768,,, BORDERLESS
'buf.screen_init 1000,1000',,, BORDERLESS
'buf.screen_init 1920,1080,,, BORDERLESS
DS.render_target buf
img.create buf.w, buf.h, rgb(10,10,10)
img.checker_background rgb(40, 40, 40), 32
randomize
DS.random_shape
dim as string k
do while k <> chr(27)
screenlock
img.blit @buf
for i as integer = 1 to 6
DS.random_shape
DS.draw 0.5, 0.5
sleep 20
next
screenunlock
Sleep 7500
k = inkey
loop
End Sub
Main
Re: Squares
@Daphi
Thats fantastic, nice work!! , you could lithograph and sell the pictures at an art show.
Thats fantastic, nice work!! , you could lithograph and sell the pictures at an art show.
-
D.J.Peters
- Posts: 8642
- Joined: May 28, 2005 3:28
- Contact:
Re: Squares
@Daphi really good job looks beauty I like it.
Joshy
Joshy
Re: Squares
@Daphi
I played with it a little and got real cool results
Some of the doodles look like cartoon characters
I played with it a little and got real cool results
Code: Select all
type tImage
as any ptr img, pixels_any
as integer w,h,bpp,bypp,pitch,num_pages,flags, wm,hm,pitchBy
Declare Sub screen_init(wid As UShort = 1, hgt As UShort = 1, bpp_ as UInteger = 32, numPages as integer = 1, Flags as integer = 0)
Declare Function create(pWid As UShort = 1, pHgt As UShort = 1, color As Ulong = RGB(127,127,127)) As Any ptr
Declare Sub blit( dest as tImage ptr, x as integer=0, y as integer=0 )
declare sub checker_background(pColor As ULong=RGBA(145,145,145,255), CheckerSize As UInteger = 12)
Declare Destructor
Private:
as integer is_screen
Declare Sub destroy
end type
Sub tImage.Destroy()
If img <> 0 Then ImageDestroy img: img = 0
End Sub
Destructor tImage
Destroy
End Destructor
Sub tImage.screen_init(Wid As UShort, Hgt As UShort, bpp as UInteger, numpages as integer, flags as integer)
Destroy ' in case the image is being re-purposed
num_pages = numpages: this.bpp = bpp: this.flags=flags
ScreenRes Wid,Hgt,bpp,numPages,Flags
ScreenInfo w,h, bpp, bypp, pitch: pixels_any = ScreenPtr
if numPages > 1 then screenset 0,1
if pixels_any <> 0 then is_screen = -1
wm = w-1: hm = h-1: pitchBy = pitch \ bypp
End sub
Function tImage.create(wid As UShort, hgt As UShort, col As ULong) As Any Ptr
Destroy ' in case the image is being re-purposed
img = ImageCreate( wid, hgt, col, 32 )
ImageInfo img, w, h, bypp, pitch, pixels_any
is_screen=0
wm = w-1: hm = h-1: pitchBy = pitch \ bypp
Return img
End Function
sub tImage.blit( dest as tImage ptr, _x1 as integer, _y1 as integer )
dim as integer x1 = _x1, x2 = x1 + wm: if x1 < 0 then x1 = 0
dim as integer y1 = _y1, y2 = y1 + hm: if y1 < 0 then y1 = 0
if x2 > dest->wm then x2 = dest->wm
if y2 > dest->hm then y2 = dest->hm
dim as integer cols = x2 - x1 + 1: if cols < 1 then exit sub
dim as integer rows = y2 - y1 + 1: if rows < 1 then exit sub
dim as ulong ptr _src = pixels_any, dst = dest->pixels_any + y1 * dest->pitchBy + x1
'' shortcut of saying "if _y1 < 0 then _y1 = 0"
_src += _y1 * (_y1 < 0) * pitchBy + _x1 * (_x1 < 0)
dim as integer colsm = cols - 1
for y as integer = 1 to rows
dim as ulong ptr src = _src
for x as ulong ptr = dst to @dst[colsm]
*x = *src: src += 1
next: dst += dest->pitchBy: _src += pitchBy
next
end sub
Sub tImage.checker_background(pColor As ULong, CheckerSize As UInteger)
Dim As UInteger SizeDouble=CheckerSize*2,SizeM=CheckerSize-1
For Y as integer = 0 To hm Step CheckerSize
For X as integer = -CheckerSize * ((Y/SizeDouble)=Int(Y/SizeDouble)) To wm Step SizeDouble
Line this.img,(X,Y)-(X+SizeM,Y+SizeM),pColor,BF
Next
Next
End Sub
#Macro Alpha256(ret,back, fore, am, a256)
ret=((_
(fore And &Hff00ff) * a256 + _
(back And &Hff00ff) * am + &H800080) And &Hff00ff00 Or (_
(fore And &H00ff00) * a256 + _
(back And &H00ff00) * am + &H008000) And &H00ff0000) Shr 8
#EndMacro
const TwoPi = 4 * Atn(1) / 45
const Pi = 2 * Atn(1)
' --- stack handler --- '
type stack_elem
as single iAngle, iiAngle, len
End Type
Type t_SH_DataType As stack_elem 'alias type for stack handler
Type tStackHandler
as any ptr p
as integer stackp
As Single expansion_coeff = 1.5
As String data
Declare Sub append(valu As t_SH_DataType)
private:
Declare Sub preserve
as integer elem_size, marker, size_x_len
as any ptr srcAny
End Type
Sub tStackHandler.preserve
elem_size = Len(t_SH_DataType): size_x_len = marker * elem_size
Dim As String sav = data: data = Space(size_x_len)
p = @data[0]: srcAny = @sav[0]
Dim As t_SH_DataType Ptr src = srcAny, _dst = p
For dst As t_SH_DataType Ptr = @_dst[0] To @_dst[stackp-1]
*dst = *src: src+=1
Next
End Sub
Sub tStackHandler.append(valu As t_SH_DataType)
If stackp = marker Then marker = (stackp+1) * expansion_coeff: preserve
p = @data[0]
Dim As t_SH_DataType ptr p = this.p: p[stackp] = valu: stackp += 1
End Sub
' --- custom draw udt --- '
#Macro RotC_(dsta,dstb,srca,srcb)
temp = cosa_*srca - sina_*srcb
dstb = cosa_*srcb + sina_*srca
dsta = temp
#EndMacro
#Macro DrawDotCommon(pdest,_col)
for pixy as ulong ptr = @pixels[y1] to @pixels[y2] step pdest->pitchBy
dim as single ySq = dy*dy, radSq_Minus_ySq = radSq-ySq
dim as single dx = x1-_sx
for pix as ulong ptr = @pixy[x1] to @pixy[x2]
dim as single d=dx*dx: dx+=1
if d < radSq_Minus_ySq Then
dim as long a256= ((rad-sqr(d+ySq)) * a_256)
dim as long am= 256-a256
Alpha256(*pix,*pix, _col_, am, a256)
End If
Next: dy+=1
Next
#EndMacro
#Macro DrawDot(pdest,x,y,z,_col,alpha_0to1)
dim as single _sx=(x)'+0.5 ''if rounding mode is down
dim as single _sy=(y)'+0.5
Dim As Single rad=(z)
Dim As Single radSq = rad*rad
dim as single a_256 = (alpha_0to1) * (_col shr 24) / rad
Dim As Integer y1 = _sy-rad: if y1<0 then y1=0
Dim As Integer y2 = _sy+rad: if y2>pdest->hm then y2=pdest->hm
Dim As Integer x1 = _sx-rad: if x1<0 then x1=0
Dim As Integer x2 = _sx+rad: if x2>pdest->wm then x2=pdest->wm: _sx -= 0.5
dim as single dy = y1 - (_sy-0.5), _dx = x1 - _sx: y1 *= pdest->pitchBy: y2 *= pdest->pitchBy
dim as ulong ptr pixels = pdest->pixels_any
dim as ulong _col_ = _col
DrawDotCommon(pdest,_col)
#EndMacro '' DrawDot
#Macro DrawDot_nodim(pdest,x,y,z,_col,alpha_0to1)
_sx=(x)'+0.5 ''if rounding mode is down
_sy=(y)'+0.5
rad=(z)
radSq = rad*rad
a_256 = (alpha_0to1) * (_col shr 24) / rad
y1 = _sy-rad: if y1<0 then y1=0
y2 = _sy+rad: if y2>pdest->hm then y2=pdest->hm
x1 = _sx-rad: if x1<0 then x1=0
x2 = _sx+rad: if x2>pdest->wm then x2=pdest->wm: _sx -= 0.5
dy = y1 - (_sy-0.5): _dx = x1 - _sx: y1 *= pdest->pitchBy: y2 *= pdest->pitchBy
DrawDotCommon(pdest,_col)
#EndMacro '' DrawDot
type tDrawShape
as single pos_step = .34
declare sub reset
declare sub render_target(byref dest as tImage)
declare sub random_shape( num_petals as integer = 3 + rnd * 14 )
declare sub draw( xp as single = 0.5, yp as single = 0.5 )
private:
declare sub push( iAngl0 as single = TwoPi * (rnd-0.5) / 100, _
iAngl1 as single = TwoPi * (rnd-0.5) / 1000, _
len as single = 10 + rnd * 150 )
as tStackHandler tSH
dim as stack_elem elem
as tImage ptr pdest
as integer num_petals
as double invisline_len, invisline_angle, invisline_lenperp, invisline_angle_petalstart
End Type
sub tDrawShape.reset
tSH.stackp = 0
End Sub
sub tDrawShape.render_target(byref dest as tImage)
pdest = @dest
End Sub
sub tDrawShape.push( iAngl as single, iiAngl as single, _len as single )
elem.iangle = -iAngl: elem.iiangle = -iiAngl: elem.len = _len
tSH.append elem
End Sub
sub tDrawShape.random_shape( _num_petals as integer )
reset
num_petals = _num_petals
dim as integer sections = 7 + rnd * 2
dim as single wire_tightness = 1.15 * (Rnd + 0.25) * pi
for i as integer = 1 to sections
dim as single seg_len = 10 + rnd * 400
dim as single angle_inc = wire_tightness / (0.2 + rnd * 10)
#define iangl rnd * angle_inc * (rnd-0.5)
push iangl, iangl, seg_len
next
invisline_angle = rnd * TwoPi
invisline_len = (rnd-0.0) * 275
invisline_lenperp = (rnd-0.1) * 25
invisline_angle_petalstart = (Rnd-0.5) * TwoPi
End Sub
sub tDrawShape.draw(xp as single, yp as single)
if pdest = 0 then ? "please set render_target": exit sub
if pdest->h < 1 then ? "please initialize gfx": exit sub
if tSH.stackp < 1 then ? "please define some points using .push": exit sub
dim as double cosa = cos(invisline_angle), sina = sin(invisline_angle)
dim as double x = invisline_len * cosa - invisline_lenperp * sina
dim as double x_m = invisline_len * cosa + invisline_lenperp * sina
dim as double y = invisline_len * sina + invisline_lenperp * cosa
dim as double y_m = invisline_len * sina - invisline_lenperp * cosa
dim as double a = invisline_angle_petalstart
dim as double a_m = -a: a += invisline_angle: a_m += invisline_angle
dim as t_SH_DataType ptr pp = tSH.p
dim as single cenx = pdest->wm * xp
dim as single ceny = pdest->hm * yp
dim as ulong col = 255 shl 24 or rnd*&HFFFFFF
dim as single dot_size = 1.27, alph = 0.37
dim as single petal_ang_inc = TwoPi / num_petals
Dim As double cosa__ = Cos(petal_ang_inc), sina__ = Sin(petal_ang_inc), cosa_ = cosa__, temp
'col = &HFFFFFFFF
for p as t_SH_DataType ptr = @pp[0] to @pp[tSH.stackp-1]
dim as single plen = p->len: if plen = 0 then plen = 1
dim as double iangle = p->iangle
dim as double iiangle = (p->iiangle - iangle) / plen
dim as integer j = abs(plen) + 0.5
if plen < 0 then a += pi
for i as integer = 0 to j
dim as single sx = x, sy = y, sx_m = x_m, sy_m = y_m
for i as integer = 1 to num_petals
dim as double sina_ = sina__
RotC_(sx,sy,sx,sy)
DrawDot(pdest, sy+cenx, sx+ceny, dot_size, col, alph)
sina_ = -sina__
RotC_(sx_m,sy_m,sx_m,sy_m)
DrawDot_nodim(pdest,sy_m+cenx,sx_m+ceny,dot_size,col,alph)
Next
if rnd < 0.0012 then col = 255 shl 24 or rnd*&HFFFFFF
x += pos_step * cos(a)
y += pos_step * sin(a)
x_m += pos_step * cos(a_m)
y_m += pos_step * sin(a_m)
a += iangle
a_m -= iangle
iangle += iiangle
Next: a -= (iangle - iiangle): a_m += (iangle - iiangle)
Next
End Sub
sub Main
dim as tImage buf, img
dim as tDrawShape DS
const BORDERLESS = 8
buf.screen_init 768, 768,,, BORDERLESS
'buf.screen_init 1000,1000',,, BORDERLESS
'buf.screen_init 1920,1080,,, BORDERLESS
DS.render_target buf
img.create buf.w, buf.h, rgb(10,10,10)
'img.checker_background rgb(0, 0, 0), 32
randomize
DS.random_shape
dim as string k
do while k <> chr(27)
screenlock
img.blit @buf
for i as integer = 1 to 10
DS.random_shape
DS.draw 0.5, 0.5
sleep 1
next
screenunlock
Sleep 1000
k = inkey
loop
End Sub
Main
Re: Squares
albert that's cool. it took me 45 minutes to figure out what you did.
you can have them be perfectly vertical:
you can have them be perfectly vertical:
Code: Select all
sub tDrawShape.random_shape( _num_petals as integer )
' ..
invisline_angle = rnd * TwoPiCode: Select all
sub tDrawShape.random_shape( _num_petals as integer )
' ..
invisline_angle = 0Re: Squares
@Dodicat
I did a real fast Halfer , it halves a million digits in .034
I did a real fast Halfer , it halves a million digits in .034
Code: Select all
do
dim as string n_1
for a as longint = 1 to 1000000 step 1
n_1+=str(int(rnd*10))
next
if left(n_1,1)="0" then mid(n_1,1,1) = str(int(rnd*9)+1)
dim as double t1 = timer , t2
dim as double val2 , val3
dim as string outs = string(len(n_1),"0")
for a as longint = 0 to len(n_1)-1 step 1
select case n_1[a]
case 48 '0
val2+= 48
val3 = 0
case 49 '1
val2+= 48
val3 = 5
case 50 '2
val2+= 49
val3 = 0
case 51 '3
val2+= 49
val3 = 5
case 52 '4
val2+= 50
val3 = 0
case 53 '5
val2+= 50
val3 = 5
case 54 '6
val2+= 51
val3 = 0
case 55 '7
val2+= 51
val3 = 5
case 56 '8
val2+= 52
val3 = 0
case 57 '9
val2+= 52
val3 = 5
end select
outs[a] = val2
val2 = val3
next
if val2 = 5 then outs+=".5"
t2=timer
print n_1
print val(n_1)/2
'print val1
print " " ; outs
print
print "time = " , t2-t1
print
sleep
loop until inkey=chr(27)
sleep
end
Re: Squares
Pretty fast Albert.
Here is my old half (used in the quarter square multiply).
I use crt.bi and puts instead of print (faster).
Also, the vertical scroll should follow the number down the screen, and the whole number should be visible in the scroller.
(It might not work with Win 8??)
Here is my old half (used in the quarter square multiply).
I use crt.bi and puts instead of print (faster).
Also, the vertical scroll should follow the number down the screen, and the whole number should be visible in the scroller.
(It might not work with Win 8??)
Code: Select all
Function half(fl As String) As String
Dim As Ubyte main,carry,temp
Dim As String sign ,s
If Instr(fl,".")=0 Then s=fl+".0" Else s=fl+"0"
If Instr(s,"-") Then sign="-":s=Ltrim(s,"-")
Dim As String ans=s
For z As Integer=0 To Len(s)-1
If s[z]<>46 Then
temp=(s[z]-48+carry)
main=temp Shr 1
carry=(temp And 1) Shl 3 +(temp And 1) Shl 1
ans[z]=main+48
End If
Next z
If Instr(ans,".") Then ans=Rtrim(ans,"0")
ans=Rtrim(ans,".")
ans=Ltrim(ans,"0")
Return sign+ans
End Function
#include "crt.bi"
var x=loword(width)
width x,12550
print "building string"
dim as string n_1
for a as longint = 1 to 1000000 step 1
n_1+=str(int(rnd*10))
next
if left(n_1,1)="0" then mid(n_1,1,1) = str(int(rnd*9)+1)
print "Halving"
dim as double t1 = timer , t2
var h=half(n_1)
t2=timer
puts h
print "Time = "; t2-t1
sleep
Re: Squares
@Dodicat
Another Halfer , it does million digits in .008 to .01 with the 64 bit FBC
Another Halfer , it does million digits in .008 to .01 with the 64 bit FBC
Code: Select all
DECLARE function Half(n_1 as string ) as string
do
dim as string n_1
for a as longint = 1 to 1000000 step 1
n_1+=str(int(rnd*10))
next
dim as double t1 = timer , t2
dim as string answer = half(n_1)
t2=timer
print n_1
print val(n_1)/2
print " " ; answer
print
print "time = " , t2-t1
print
sleep
loop until inkey=chr(27)
sleep
end
function Half(n_1 as string ) as string
dim as longint val1=0
dim as longint val2=0
dim as longint val3=0
dim as string outs = string( len(n_1) , chr(0) )
dim as ubyte ptr ubp1 = cptr(ubyte ptr , strptr(n_1))
dim as ubyte ptr ubp2 = cptr(ubyte ptr , strptr(outs))
for a as longint = 0 to len(n_1)-1 step 1
val1 = *ubp1-48 : ubp1+=1
val2+= val1 shr 1
val3 = (val1 and 1) * 5
*ubp2 = val2+48 : ubp2+=1
val2 = val3
next
if val2 = 5 then outs+=".5"
return outs
end function
Re: Squares
Hi Albert.
six times faster if you use optimized gcc (wxFBE ide).
Does your code now show the whole million or so digits in the scrollable console?
six times faster if you use optimized gcc (wxFBE ide).
Does your code now show the whole million or so digits in the scrollable console?
Code: Select all
DECLARE function Half(n_1 as string ) as string
var x=loword(width)
width x,12550
do
dim as string n_1
for a as longint = 1 to 1000000 step 1
n_1+=str(int(rnd*10))
next
dim as double t1 = timer , t2
dim as string answer = half(n_1)
t2=timer
'print n_1
print val(n_1)/2
print " " ; answer
print
print "time = " , t2-t1
print
sleep
cls
loop until inkey=chr(27)
sleep
end
function Half(n_1 as string ) as string
dim as longint val1=0
dim as longint val2=0
dim as longint val3=0
dim as string outs = string( len(n_1) , chr(0) )
dim as ubyte ptr ubp1 = cptr(ubyte ptr , strptr(n_1))
dim as ubyte ptr ubp2 = cptr(ubyte ptr , strptr(outs))
for a as longint = 0 to len(n_1)-1 step 1
val1 = *ubp1-48 : ubp1+=1
val2+= val1 shr 1
val3 = (val1 and 1) * 5
*ubp2 = val2+48 : ubp2+=1
val2 = val3
next
if val2 = 5 then outs+=".5"
return outs
end function