- Welcome to Interactive PowerBasic Forum.
Your resource for programming with PowerBASIC™
Recent posts
#1
OxygenBasic Examples / Re: Slider Box changes triangl...
Last post by Charles Pegge - Yesterday at 06:33:18 PMHi Frank,
I've cleaned up the previous and linked color/transparency to one slider panel. I hope this answers your questions and resolves the issues you were having.
I've cleaned up the previous and linked color/transparency to one slider panel. I hope this answers your questions and resolves the issues you were having.
Code Select
'-------- experiment to combine triangle data with slider overlapped
'-------- oxygenbasic, by frank brübach, 27-11-2023
'
'17:29 03/12/2023 CP
#compact
'%filename "t.exe"
'uses RTL64
% Title "Triangle Data: Move points with mouse and arrow keys etc"
'% WindowStyle WS_OVERLAPPEDWINDOW
'% Animated
'% ScaleUp
% PlaceCentral
% AnchorCentral
'% shaders
uses consoleG
'uses glo2/geoplanar
'uses ControlPanels
uses controls
===================
class ControlPanelA
===================
float x,y,z
int id
float xx,yy,zz
float dx,dy,dz
float sc
int lock
int t1,t2
int f1,f2
string lbl
===================
sliders c[4]
lightbuttons l[4]
===================
method act(optional int n)
indexbase 1
if id=0
f1=0 'cube
f2=0 'pent
==========================================================================
'ctrl x y z sc shm shb tex id lk lbl
--------------------------------------------------------------------------
c[1]=>-.40,-.00, .00, 0.10, f1, 00, t1, 10, 1, "slider"
c[2]=>-.30,-.00, .00 , 0.10, f2, 00, t1, 20, 1, "slider"
c[3]=>-.20,-.00, .00 , 0.10, f2, 00, t1, 30, 1, "slider"
c[4]=>-.10,-.00, .00 , 0.10, f2, 00, t1, 40, 1, "slider"
-------------------------------------------------------------------------
l[1]=>-.40, .15, .00, 0.02, f1, 00, t1, 50, 1, "light button"
l[2]=>-.30, .15, .00 , 0.02, f2, 00, t1, 60, 1, "light button"
l[3]=>-.20, .15, .00 , 0.02, f2, 00, t1, 70, 1, "light button"
l[4]=>-.10, .15, .00 , 0.02, f2, 00, t1, 80, 1, "light button"
==========================================================================
id=1+n
int i
for i=1 to 4
c[i].id+=n
l[i].id+=n
next
end if
'
glpushmatrix
gltranslatef x,y,z
'
gltranslatef -.25,.0,-.0005
if sc then glscalef sc,sc,1.0
if pick
PickLabel id
else
QuadShadow .20,.20,.005,.5
glcolor3f .60,.50,.60 'fix alpha bug
glcolor4f .60,.50,.60,0.50 'box
endif
QuadTex .20,.20,.0.01
gltranslatef .25,.0,-.0
'
'DISPLAY LABELS
if lbl
glpushmatrix
gltranslatef -.43,-.13,.0005
glcolor4f .9,.9,.4,.9
float j=0.015
'DISPLAY EACH SLIDER VALUE
for i=1 to 4
glpushmatrix
gltranslatef j,0,0
glscalef .035,.035,.035
if pick
gltranslatef -.1,-.18,.0
picklabel id+i
PutBoxArea 2,1
gltranslatef .1,.18,.0
else
if picked=id+i 'edit
------------
'DATA EDITING
color 0.9,0.9,0.9
'box-around
gltranslatef -.1,-.18,.0
glBegin GL_LINE_STRIP
glVertex2f 0,0
glVertex2f 2,0
glVertex2f 2,1
glVertex2f 0,1
glVertex2f 0,0
glEnd
gltranslatef .1,.18,.0
'
static string ss
ss= str(50+c[i].vy*50,0) '0..100
input ss
c[i].vy=(val(ss)-50) *0.02
'
static int cpick,cy,cx
if cpick<>picked
cp=le+1 'place cursor at end of string
cy=y
cx=x
cpick=picked
endif
'
select lastkey
case VK_UP
c[i].vy+=0.01
case VK_DOWN
c[i].vy-=0.01
case VK_PRIOR 'PGUP
c[i].vy+=0.01
case VK_NEXT 'PGDN
c[i].vy-=0.01
case 9 'tab
if GetAsyncKeyState(VK_SHIFT)=0
picked++
if picked>id+4
picked=id+4
end if
else 'left
picked--
if picked<id+1
picked=id+1
endif
endif
end select
lastkey=0
lastchar=0
else 'display
gprint str(50+c[i].vy*50,0) '0..100
'gprint str((c[i].vy)*100 , 0) -100..100
endif
endif
glpopmatrix
j+=0.1
next
'DISPLAY MAIN PANEL LABEL
gltranslatef 0,-.05,0
glscalef .04,.04,.04
glcolor4f .9,.9,.0,.9
gprint lbl
glpopmatrix
endif
'
'
if bleft
if picked=id
if not lock
drag(dx,dy,1.0/sc)
x=xx+dx : y=yy+dy
end if
end if
else
xx=x : yy=y : zz=z 'ANCHOR
end if
'
'render
'
int i,oi1,oi2
for i=1 to 4
c[i].act(1,i,oi1)
l[i].act(1,i,oi2)
next
glpopmatrix
'
'show data
'
'glDisable GL_TEXTURE_2D
glDisable GL_LIGHTING
'
glPushMatrix
glLoadIdentity
if pick
PickLabel 0
endif
gltranslatef -.5,.35,-1.0
float w,h
glscalef .05,.05,.01
GetWordArea "Control:",w,h
if pick
PutBoxArea w,h
else
/*
glColor3f .99,.99,.00
gprint "Control: "
glColor3f .99,.99,.99
gprint str(picked)
if oi1+oi2
gprint " "
if oi1 then gprint str((1.0+c[oi1].vy)*50 , 0)
if oi2 then gprint str (l[oi2].lit)
end if
*/
end if
glPopMatrix
end method
'
method destructor()
===================
'del this.label
'sliders c[4]
'lightbuttons l[4]
int i
for i=1 to 4
c[i].destructor
next
for i=1 to 4
l[i].destructor
next
end method
'
end class
'#recordof ControlPanelA
'Keys: Esc, arrow-keys, n,m, F4
indexbase 1
sys texn[16]
sys GdiplusToken
float ang1
sys cube,pent
BeginScript
procedure main() 'triangle-data example
================
static single ra,ri,angi1=.5
static sys initscene
sys hwnd
static float rr=.5,gg=.5,bb=.5,aa=.8 'object color
'
'
'--------------------------------------------------- //
'WaitForEvent '0 off 1 on (default on)
static quad t1,t2
if opening 'FIRST CALL ONLY
timemark t1
'picked=100
'mbox "helo"
end if
'
if closing 'FINAL CALL BEFORE SHUTDOWN
'mbox "Bye!"
exit sub
end if
cls
subroutine ShowPolygon
======================
move 0,0,-1
shading
UserMovement mu,1100,3 'symbol identity, count
if opening
mu[1].x= 0
mu[1].y= 5
mu[2].x=-5
mu[2].y=-5
mu[3].x= 5
mu[3].y=-5
endif
scale 1
picklabel 0
int i
for i=1 to 3
pushstate
mu[i].act
color 1,.9,0,1
scale 0.4
go sphere
popstate
next
float xa,xb,xc,ya,yb,yc
xa=mu[1].x : ya=mu[1].y
xb=mu[2].x : yb=mu[2].y
xc=mu[3].x : yc=mu[3].y
'
'MOUSE DRAG ADJUSTMENT
select picked
case 1100 : xa+=mu[1].d.x : ya+=mu[1].d.y
case 1200 : xb+=mu[2].d.x : yb+=mu[2].d.y
case 1300 : xc+=mu[3].d.x : yc+=mu[3].d.y
end select
flat
thickness 2
'
color 1,1,0,1
pushstate
move xa-.5,ya-1
gprint "A"
popstate
pushstate
move xb+1,yb+1
gprint "B"
popstate
pushstate
move xc-1,yc+1
gprint "C"
popstate
'
color rr,gg,bb,aa 'linked to slider panel 1
float zp=-1.001
glBegin GL_TRIANGLES
glVertex3f xa,ya,zp
glVertex3f xb,yb,zp
glVertex3f xc,yc,zp
glEnd
'
color 0,.9,.9
glBegin GL_LINES
glVertex2f xa,ya
glVertex2f xb,yb
glVertex2f xb,yb
glVertex2f xc,yc
glVertex2f xc,yc
glVertex2f xa,ya
glEnd
move 5
'if not pick then
if key[49] then picked=100 'keypress '1'
if key[50] then picked=200 'keypress '2'
pushstate
move -20,12
static sys tally
timemark t2
scale 1.0
'
int dp=3
'
macro pr1(a) 'PRINTING LIST
-----------------------------
pushstate : color .5,1,1 : print a : popstate
printl ""
end macro
'
macro pr2(a,b) 'PRINTING LIST
-----------------------------
pushstate : color .5,1,1 : print a : popstate
pushstate : color 1,1,.5 : move 4 : print str(b,dp) : popstate
printl ""
end macro
'
macro pr3(a,b,c) 'PRINTING LIST
------------------------------
pushstate : color .5,1,1 : print a : popstate
pushstate : color 1,1,.5 : move 4 : print str(b,dp) : popstate
pushstate : color 1,1,.5 : move 8 : print str(c,dp) : popstate
printl ""
end macro
'
'
'DISPLAY INFO
-------------
picklabel 0
pushstate
scale 2
color 1,1,1
print "Triangle Data"
popstate
pr1 ""
pr1 ""
'pr2 "Action Code: ", act
'pr2 "indexbase ", indexbase
'pr2 "Keyboard Code: ", keyd
pr2 "Picked ID: ", picked
'
pr3 "Point A: ", str(xa,3), ya
pr3 "Point B: ", str(xb,3), yb
pr3 "Point C: ", str(xc,3), yc
'
float ab,ac,bc,ar,ht,hb
'
ab=hypot(xa-xb, ya-yb)
ac=hypot(xa-xc, ya-yc)
bc=hypot(xb-xc, yb-yc)
'
hb=0.5* ( ab*ab - ac*ac + bc*bc ) / bc
ht=sqr(ab*ab-hb*hb)
ar=0.5*bc*ht
'ANGLES
float na,nb,nc
nb=deg(asin(ht/ab))
nc=deg(asin(ht/ac))
na=180-nb-nc
pr1 ""
pr2 "Angle A:",na
pr2 "Angle B:",nb
pr2 "Angle C:",nc
pr1 ""
pr2 "Line AB:",ab
pr2 "Line AC:",ac
pr2 "Line BC:",bc
pr2 "Left base:",hb
pr2 "Height:",ht
pr2 "Area:", ar
pr1 ""
'
picklabel 0
popstate
'end if
end subroutine
'--------------------
'end polygon display
'--------------------
'PANEL DISPLAY
==============
static single ra,ri,angi1=.5
static sys initscene
'------------------------------
'glClearColor 0.5, 0.5, 0.7, 0
'glClearColor 0.1, 0.2, 0.1, 0
'
glColor4f .99,.99,.99,.99
'glEnable GL_TEXTURE_2D
'
'RENDERED LOWEST FIRST (FOR TRANSPARENCY BLENDING)
'
% ordn=1
static ControlPanelA cb[ordn]
static int ord[16]
static int idb[16]
'
if closing
int i
for i=1 to ordn
cb[i].destructor
next
exit sub
endif
'
'INITIAL PLACEMENT ETC
'
if initscene=0
ord={1,2,3}
idb={0,100,200}
cb[1].x=.8 : cb[1].y=.6 : cb[1].lbl="Color"
int i
'set scale
for i=1 to ordn : cb[i].sc=2.5 : next
initscene=1
end if
'
'ORDER OF BUILD (SUPPORTING TRANSPARENCY)
'
if picked and bleft
int a=1+trunc(picked/100)
PlaceTop(a,ord,ordn)
end if
'
'RENDER SCENE
'
move 0,0,-1
gosub ShowPolygon
move 0,0,1
'
glpushmatrix
static float layr=.001
static float f = -1 - layr*ordn
glscalef 15,15,1
gltranslatef .0, .0, f
int i,j
for i=1 to ordn
j=ord[i]
cb[j].act idb[j]
gltranslatef .0, .0, layr 'next micro-layer in front
next
'
'LINK TO SLIDERS
'COLOR
rr=0.5+cb[1].c[1].vy*.5
gg=0.5+cb[1].c[2].vy*.5
bb=0.5+cb[1].c[3].vy*.5
aa=0.5+cb[1].c[4].vy*.5
glpopmatrix
'
'
'
'
' ang1+=angi1
' if ang1>=360 then ang1-=360
end procedure 'main
EndScript
#2
OxygenBasic Examples / Re: Function strMatchPattern
Last post by Charles Pegge - December 02, 2023, 05:33:01 PMIt is an interesting algorithm with hidden complexity. Here is one of my code serpents. 
It is in the form of a instr, and as you can see, it is considerably more complex than this AI version:
It is in the form of a instr, and as you can see, it is considerably more complex than this AI version:Code Select
'01/12/2023 CP
'01/12/2023
'
function instrp(int i,string s,p,int*en=0) as int
=================================================
'
'i start position
's string to search
'p search string (with optional ? * wildcards
'en boundary of found key string
'
if i<1
i=1
endif
if not s
return 0 'no source string
endif
if not p
return 1 'no search string
endif
'
indexbase 1
byte bs at strptr(s) 'source string bytes
byte bp at strptr(p) 'search string bytes
int js=i 'source string position
int jp=1 'search string position
int ks=i 'next search start
int kt=i 'current search start
int kf=0 'prev key wild card position
int kg=0 'prev source wild card position
int fs=i 'possible found position
int ls=len(s) 'limit of source string
int lp=len(p) 'limit of search string
int ok=1 'vrification flag
byte ka=bp[1] 'first byte to search
do
if jp>lp
exit do
endif
if js>ls
if jp<=lp
ok=0
endif
exit do
endif
select bp[jp]
case 42 '*
ok=1
while bp[jp]=42
jp++
wend
do
if js>ls 'end of string
ok=1
jp--
exit do
endif
if ka=bs[js]
ks=js
endif
if jp>lp 'end of pattern
ok=1
jp--
exit do
endif
if bp[jp]=bs[js] 'possible match char
ok=1
jp--
'these flags used for resuming wild card
kf=jp
kg=js+1
exit do
endif
if bp[jp]=63 'possible match ? char
ok=1
jp--
exit do
endif
js++
loop
case 63 '?
if ka=bs[js]
ks=js
endif
ok=1
js++
case else 'all other chars
if bp[jp]=bs[js] 'byte match
ok=1
if ka=bs[js]
ks=js
endif
js++
else 'mismatch
ok=0
if kf
'prev wildcard positions
jp=kf-1
js=kg
kf=0
kg=0
else
if ka=63
ks=kt '?' was wildcard start
endif
if ks=kt
ks++ 'nudge fwd
endif
kt=ks
js=ks 'restart search
fs=js
jp=0
endif
endif
end select
jp++ 'next pattern byte
loop
if ok
function=fs
else
js=0
endif
en=js
end function
'
'test cases
===========
string s="aabcdefghijklmmnopqrstuvwxyz"
'print instrp 1,s,"ab"
'print instrp 1,s,"abz"
'print instrp 1,s,"xyz"
'print instrp 1,s,"mno"
'print instrp 1,s,"mm?o"
'print instrp 1,s,"m?o"
'print instrp 1,s,"m??"
'print instrp 1,s,"m??p"
'print instrp 1,s,"??m"
'print instrp 1,s,"*m"
'print instrp 1,s,"m*"
'print instrp 1,s,"m*z"
'print instrp 1,s,"m*k*z"
'print instrp 1,s,"m*n"
'print instrp 1,s,"a*b"
'print instrp 1,s,"a?*c"
'print instrp 1,s,"c?d"
'print instrp 1,s,"c*d"
'print instrp 1,s,"c?*e"
'print instrp 1,s,"c**f"
'print instrp 1,s,"c*??f" 'yes
'print instrp 1,s,"c*??g" 'no
'print instrp 1,s,"c??*g" 'yes
int en
'print instrp 1,s,"c??*g",en 'yes
'print en
uses console
s="abcdefghijklmmabcdefghijklmn"
int b
b=instrp(1,s,"d*lmm",en)
print b " - " en cr
print mid(s,b,en-b) cr
print instrp(1,s,"d*lmn",en) " - " en cr
print cr "ok" cr
wait
#3
OxygenBasic Examples / Re: Function strMatchPattern
Last post by Zlatko Vid - December 02, 2023, 05:20:12 PMso nobody respond ...looks like a stupid question or what ?
#4
OxygenBasic / Re: GetKey
Last post by Charles Pegge - December 02, 2023, 04:30:18 PMWith a small mod the Ascii code (supporting esc) can be made available:
in console.inc
test code:
in console.inc
Code Select
static KEY_RECORD KeyRecord
'
function inkey(int c=0) as int
================================
static KEY_RECORD k[8]
static int nr
int d
PeekConsoleInputA ConsIn,@k,8, @nr
if nr
if c=0
indexbase 1
int i
for i=1 to nr
if k[i].EventType=1 'KEY_EVENT
if k[i].bKeyDown
KeyRecord=k[i]
d=KeyRecord.wVirtualKeyCode
exit for
endif
endif
next
elseif GetAsyncKeyState(c)
d=c
endif
FlushConsoleInputBuffer ConsIn
return d
endif
end function
test code:
Code Select
/*
type KEY_RECORD
===============
word EventType
word wReserved
dword bKeyDown
word wRepeatCount
word wVirtualKeyCode
word wScanCode
word wAsciiCode
dword dwReserved
end type
*/
uses console
string k
int a,c
do
a=inkey
if a
c=KeyRecord.wAsciiCode
k=a ", " c
print k + cr
if a=13 then break
endif
loop
printl "end"
wait
[/cade] #5
OxygenBasic / Re: GetKey
Last post by Nicola - December 02, 2023, 01:06:39 PMOk, but I need how the current GetKey works, which recognizes whether they are uppercase or lowercase. The only thing is that, like inkey, the ESC key code also returns.
#6
OxygenBasic / Re: GetKey
Last post by Charles Pegge - December 01, 2023, 11:09:26 PMYes, these are virtual keyboard codes, not ascii char codes. Almost every key has its own code, not sensitive to ctrl or shift.
#7
OxygenBasic / Re: GetKey
Last post by Nicola - December 01, 2023, 09:21:10 PMHi Charles
It looks like all characters are capitalized
It looks like all characters are capitalized
#8
OxygenBasic Examples / Function strMatchPattern
Last post by Zlatko Vid - December 01, 2023, 06:55:42 PMFunction strMatchPattern recently posted by Theo generated by AI
do i made some stupid mistakes or i forget or something
else ..this function need array or not
in original use continue inside While loop i never saw before
is that normal ..program simply crush ?
my try:
do i made some stupid mistakes or i forget or something
else ..this function need array or not
in original use continue inside While loop i never saw before
is that normal ..program simply crush ?
my try:
Code Select
' Simple pattern matching function
'global vars
#lookahead
Dim in[500] as string
Dim patt[500] as string
'fn
Function strMatchPattern(s[500] as string, pattern[500] as string) as bool
Dim sPos as int : sPos = 1
Dim pPos as int : pPos = 1
Dim sLen as int : slen = len(s[])
Dim pLen as int : pLen = len(pattern[])
Dim match as int : match = 0
Dim star as int : star = 0
While sPos <= sLen
if pPos <= pLen and (pattern[pPos] = s[sPos] or pattern[pPos] = "?") then
pPos = pPos + 1
sPos = sPos + 1
goto cont
end if
if pPos <= pLen and pattern[pPos] = "*" then
star = pPos
match = sPos
pPos = pPos + 1
goto cont
end if
if star <> 0 then
pPos = star + 1
match += 1
sPos = match
goto cont
end if
return false
Wend
'label
cont:
While pPos <= pLen and pattern[pPos] = "*"
pPos = pPos + 1
Wend
'fn return boolean TRUE/FALSE
Return pPos > pLen
End Function
'call function...
in[1] = "testing" : patt[1]="test*"
print strMatchPattern( in[1] , patt[1] )
#9
OxygenBasic / Re: GetKey
Last post by Charles Pegge - December 01, 2023, 06:18:45 PMBetter!
This supports:
if inkey(27)
...
waitkey (27)
as well as inkey() and getkey()
You can use these functions in your code, but they will be incorporated into the next console.inc
Code Select
/*
function GetKey() as int
========================
static long blen,mode
static byte z[4]
GetConsoleMode ConsIn,mode
SetConsoleMode ConsIn,0
ReadConsole ConsIn,@z,1,@blen,null
SetConsoleMode ConsIn,mode
return z
end function
*/
! GetAsyncKeyState lib "user32.dll" (int c) as int
'
function inkey(int c=0) as int
================================
static KEY_RECORD k[8]
static int nr
int d
PeekConsoleInputA ConsIn,@k,8, @nr
if nr
if c=0
indexbase 1
int i
for i=1 to nr
if k[i].EventType=1 'KEY_EVENT
if k[i].bKeyDown
d=k[i].wVirtualKeyCode
exit for
endif
endif
next
elseif GetAsyncKeyState(c)
d=c
endif
FlushConsoleInputBuffer ConsIn
return d
endif
end function
function GetKey(int c=0) as int
===============================
int d
do
d=inkey(c)
if d
if c
if d=c
return c
endif
else 'c=0
return d
endif
endif
loop
end function
This supports:
if inkey(27)
...
waitkey (27)
as well as inkey() and getkey()
You can use these functions in your code, but they will be incorporated into the next console.inc
#10
OxygenBasic / Re: GetKey
Last post by Charles Pegge - December 01, 2023, 05:46:30 PMHi Nicola,
It's a bit sticky so I need to do some more work on the buffering.
It's a bit sticky so I need to do some more work on the buffering.