Welcome, Guest |
You have to register before you can post on our site.
|
Latest Threads |
MBA Assignment Help in Du...
Forum: General Discussion
Last Post: hafsahomar
06-11-2025, 07:05 AM
» Replies: 0
» Views: 12
|
лучшие песни медляки слуш...
Forum: Petr
Last Post: WillieTop
06-08-2025, 02:21 AM
» Replies: 0
» Views: 27
|
пинк слушать онлайн беспл...
Forum: SMcNeill
Last Post: WillieTop
06-08-2025, 02:20 AM
» Replies: 0
» Views: 22
|
скачать музыку российскую...
Forum: madscijr
Last Post: WillieTop
06-08-2025, 02:18 AM
» Replies: 0
» Views: 23
|
нежная музыка mp3 скачать
Forum: Keybone
Last Post: WillieTop
06-08-2025, 02:17 AM
» Replies: 0
» Views: 23
|
лучшая песня слушать онла...
Forum: bplus
Last Post: WillieTop
06-08-2025, 02:16 AM
» Replies: 0
» Views: 27
|
пикник слушать онлайн луч...
Forum: Spriggsy
Last Post: WillieTop
06-08-2025, 02:15 AM
» Replies: 0
» Views: 22
|
какая сейчас популярная м...
Forum: RhoSigma
Last Post: WillieTop
06-08-2025, 02:14 AM
» Replies: 0
» Views: 18
|
хит лета 2019 музыка на т...
Forum: Christmas Code
Last Post: WillieTop
06-08-2025, 02:12 AM
» Replies: 0
» Views: 29
|
бесплатная музыка mp3 рег...
Forum: Works in Progress
Last Post: WillieTop
06-08-2025, 02:11 AM
» Replies: 0
» Views: 18
|
|
|
Simple GUI example |
Posted by: James D Jarvis - 11-30-2022, 07:20 PM - Forum: Programs
- Replies (3)
|
 |
all the cool kids are doing it so why not?
A simple gui example to demonstrate a scheme for button handling and menu selection.
This makes use of a couple of the new dialog controls in version 3.4
Menu selections return input from the selection, there's a little but of button manipulation shown, you cna quit from a menu or the big red quit button. Menu2 uses the new dialog controls, the hello menu selection wlil have a different message if the user has enters a username.
This is fairly barebones and hopefully straightforward enough someone may find this useful.
Code: (Select All) 'a relatively simple gui example by James D. Jarvis
'QB64 PE 3.4 or later needed to compile
'text screen mode 0 program that uses the mouse button to track gui input
'the scheme in this program allows for up to 255 buttons to be used in a program
'
'a mouse is used to click on button and menu selections that are shown in a text screen
'the position of buttons that are active is recorded in a button image
'$dynamic
Dim Shared ts&
Dim Shared bt&
Dim Shared forek, backk
ts& = _NewImage(80, 25, 0) 'the main text screen for the program
Screen ts&
bt& = _NewImage(_Width + 1, _Height + 1, 256) 'the button tracking image needed for the gui
Type button_type
txt As String 'the button label
style As String 'what type of button to use : TEXTONLY,BTEXT,MENU,LBAR,CBAR,BBOX1,BBOX2
bxx As Integer 'button x coordinate
byy As Integer 'button y coordinate
bwid As Integer 'button width in pixels. button height is determined by style and text size
tklr As Integer 'text color
bklr As Integer 'background color
fklr As Integer 'foreground color
state As String 'is button on or off
container As String 'doesn't do anything in the demo but I like to plan ahead
End Type
Dim Shared btn(0) As button_type
Dim tempb As button_type
Dim Shared button_count
button_count = 0
Print "Building GUI";
forek = 15: backk = 0
menu_on = 0
'creating buttosn for the demo code
tempb.bxx = 3: tempb.byy = 3: tempb.bwid = 8: tempb.style = "TEXTONLY"
tempb.txt = "Button 1": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "ON": tempb.container = ""
addbutton tempb
tempb.bxx = 3: tempb.byy = 5: tempb.bwid = 8: tempb.style = "BTEXT"
tempb.txt = "Button 2": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "ON": tempb.container = ""
addbutton tempb
tempb.bxx = 3: tempb.byy = 7: tempb.bwid = 12: tempb.style = "BBOX2"
tempb.txt = "Button 3": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "ON": tempb.container = ""
addbutton tempb
tempb.bxx = 3: tempb.byy = 15: tempb.bwid = 52: tempb.style = "BBOX1"
tempb.txt = "QUIT": tempb.tklr = 0: tempb.bklr = 12: tempb.fklr = 15
tempb.state = "ON": tempb.container = ""
addbutton tempb
'creating the menus for the demo code.
'note: menu selections are just buttons that are only active when the menu is selected
tempb.bxx = 1: tempb.byy = 1: tempb.bwid = 8: tempb.style = "MENU"
tempb.txt = "MENU": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "ON": tempb.container = ""
addbutton tempb
tempb.bxx = 1: tempb.byy = 2: tempb.bwid = 8: tempb.style = "LBAR"
tempb.txt = "Select1": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "OFF": tempb.container = ""
addbutton tempb
tempb.bxx = 1: tempb.byy = 3: tempb.bwid = 8: tempb.style = "LBAR"
tempb.txt = "Select2": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "OFF": tempb.container = ""
addbutton tempb
tempb.bxx = 1: tempb.byy = 4: tempb.bwid = 8: tempb.style = "LBAR"
tempb.txt = "--------": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "OFF": tempb.container = ""
addbutton tempb
tempb.bxx = 1: tempb.byy = 5: tempb.bwid = 8: tempb.style = "LBAR"
tempb.txt = "QUIT": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "OFF": tempb.container = ""
addbutton tempb
tempb.bxx = 9: tempb.byy = 1: tempb.bwid = 8: tempb.style = "MENU"
tempb.txt = "MENU2": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "ON": tempb.container = ""
addbutton tempb
tempb.bxx = 9: tempb.byy = 2: tempb.bwid = 8: tempb.style = "LBAR"
tempb.txt = "Hello": tempb.tklr = 15: tempb.bklr = 7: tempb.fklr = 15
tempb.state = "OFF": tempb.container = ""
addbutton tempb
tempb.bxx = 9: tempb.byy = 3: tempb.bwid = 8: tempb.style = "LBAR"
tempb.txt = "Name?": tempb.tklr = 15: tempb.bklr = 5: tempb.fklr = 15
tempb.state = "OFF": tempb.container = ""
addbutton tempb
Dim Shared username$
username$ = ""
Cls
draw_allbuttons 'have to draw them if you want the user to see them
Locate 3, 16: Print "Will Show Button 3 if it is hiding"
Locate 5, 16: Print "Changes Text Color of this button"
Locate 8, 16: Print "Will hide itself"
Do ' main program loop
_Limit 1000
bkk = 0
Do While _MouseInput
pbx = _MouseX
pby = _MouseY
If _MouseButton(1) Then
_Source bt& 'checking the button tracking image
bkk = Point(pbx, pby) 'get the button clicked if there is one at those coordinates
_Source ts&
'uncomment following lines if you wish to see the demo echoing the button click
' If bkk > 0 Then
' Locate 1, 1: Print "Clicked "; bkk
' Else
' Locate 1, 1: Print " "
' End If
End If
Loop
Select Case bkk 'a handler for each button
Case 1
Beep
flash_button 1
If btn(3).state = "HIDE" Then show_button 3
draw_button 1
Case 2
flash_button 2
btn(2).tklr = Int(Rnd * 32)
draw_button 2
Case 3
flash_button 3
hide_button 3
Case 4
flash_button 4
draw_button 4
Exit Do
Case 5 'menu1
menu1 mchoice$
Locate 12, 16
If mchoice$ <> "" Then Print "Selected "; mchoice$
If mchoice$ = "QUIT" Then Exit Do
Case 6 'this is a menu selection and tracked in the sub menu1
Case 7 'this is a menu selection and tracked in the sub menu1
Case 8 'this is a menu selection and tracked in the sub menu1
Case 9 'this is a menu selection and tracked in the sub menu1
Case 10 'menu2
mchoice$ = ""
menu2 mchoice$
If mchoice$ = "hello" Then
If username$ = "" Then
_MessageBox "Hello", "Hello stranger.", "info"
Else
un$ = "HELLO THERE " + username$ + "!"
_MessageBox "HELLO", un$, "info"
End If
End If
If mchoice$ = "name?" Then
username$ = _InputBox$("Name?", "Enter your name:", "anonymous")
End If
Case 11 'this is a menu selection and tracked in the sub menu2
Case 12 'this is a menu selection and tracked in the sub menu2
End Select
Loop Until InKey$ = Chr$(27)
_FreeImage bt&
System
'=========================================================================
' button routines for gui
'=========================================================================
Sub menu1 (mchoice$)
'menu handling has to be hardcoded as is, this needs to change.
show_button 6
show_button 7
show_button 8
show_button 9
menu_on = 1
mchoice$ = ""
Do 'menu takes over mouse handling only recognizing clicks in the menu or pressing the escape key
_Limit 60
Do While _MouseInput
pbx = _MouseX
pby = _MouseY
If _MouseButton(1) Then
_Source bt& 'checking the button tracking image
bkk = Point(pbx, pby) 'get the button clicked if there is one at those coordinates
_Source ts&
End If
Loop
Select Case bkk 'a handler for each button
Case 6
flash_button 6
mchoice$ = "m1a"
menu_on = 0
Case 7
flash_button 7
mchoice$ = "m1b"
menu_on = 0
'case 8
'there is no entry for button 8. it's just a line separator
Case 9
flash_button 9
mchoice$ = "QUIT"
menu_on = 0
End Select
mk$ = InKey$
Loop Until menu_on = 0 Or mk$ = Chr$(27)
'hide all the menu entries
hide_button 6
hide_button 7
hide_button 8
hide_button 9
'draw all the buttons now that the menu entries are hidden
draw_allbuttons
End Sub
Sub menu2 (mchoice$)
'menu handling has to be hardcoded as is
show_button 11
show_button 12
menu_on = 1
mchoice$ = ""
Do 'menu takes over mouse handling only recognizing clicks in the menu or pressing the escape key
_Limit 60
Do While _MouseInput
pbx = _MouseX
pby = _MouseY
If _MouseButton(1) Then
_Source bt& 'checking the button tracking image
bkk = Point(pbx, pby) 'get the button clicked if there is one at those coordinates
_Source ts&
End If
Loop
Select Case bkk 'a handler for each button
Case 11
flash_button 11
mchoice$ = "hello"
menu_on = 0
Case 12
flash_button 7
mchoice$ = "name?"
menu_on = 0
End Select
mk$ = InKey$
Loop Until menu_on = 0 Or mk$ = Chr$(27)
'hide the menu entries
hide_button 11
hide_button 12
'draw all the buttons now that the menu entries are hidden
draw_allbuttons
End Sub
Sub addbutton (newbtn As button_type)
If button_count < 255 Then
button_count = button_count + 1
ReDim _Preserve btn(button_count) As button_type
Swap btn(button_count), newbtn
Select Case btn(button_count).style
Case "TEXTONLY", "BTEXT"
'correct bwid to be equal to text length for these styles
btn(button_count).bwid = Len(btn(button_count).txt)
End Select
End If
End Sub
Sub draw_button (bnum)
'draw alll the buttons on the mainscreen and on the button tracking image
If bnum < 1 Or bnum > button_count GoTo enddrawb
ds& = _Dest
If btn(bnum).state = "ON" Then
_Dest bt&
Select Case btn(bnum).style
Case "TEXTONLY"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), bnum, BF
_Dest ds&
Color btn(bnum).tklr, backk
_PrintString (btn(bnum).bxx, btn(bnum).byy), btn(bnum).txt
Color forek
Case "BTEXT", "MENU"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), bnum, BF
_Dest ds&
Color btn(bnum).tklr, btn(bnum).bklr
_PrintString (btn(bnum).bxx, btn(bnum).byy), btn(bnum).txt
Color forek, backk
Case "LBAR"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), bnum, BF
_Dest ds&
Color btn(bnum).tklr, btn(bnum).bklr
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy), btn(bnum).txt
Color forek, backk
Case "CBAR"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), bnum, BF
_Dest ds&
Color btn(bnum).tklr, btn(bnum).bklr
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, " ")
tpx = btn(bnum).bxx + (Int(btn(bnum).bwid / 2) - Int(Len(btn(bnum).txt) / 2))
_PrintString (tpx, btn(bnum).byy), btn(bnum).txt
Color forek, backk
Case "BBOX1"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 2), bnum, BF
_Dest ds&
Color btn(bnum).fklr, btn(bnum).bklr
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, Chr$(196))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(btn(bnum).bwid, Chr$(196))
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(1, Chr$(218))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(1, Chr$(179))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(1, Chr$(192))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), String$(1, Chr$(191))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 1), String$(1, Chr$(179))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 2), String$(1, Chr$(217))
Color btn(bnum).tklr, btn(bnum).bklr
tpx = btn(bnum).bxx + (Int(btn(bnum).bwid / 2) - Int(Len(btn(bnum).txt) / 2))
_PrintString (tpx, btn(bnum).byy + 1), btn(bnum).txt
Color forek, backk
Case "BBOX2"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 2), bnum, BF
_Dest ds&
Color btn(bnum).fklr, btn(bnum).bklr
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, Chr$(205))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(btn(bnum).bwid, Chr$(205))
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(1, Chr$(201))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(1, Chr$(186))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(1, Chr$(200))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), String$(1, Chr$(187))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 1), String$(1, Chr$(186))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 2), String$(1, Chr$(188))
Color btn(bnum).tklr, btn(bnum).bklr
tpx = btn(bnum).bxx + (Int(btn(bnum).bwid / 2) - Int(Len(btn(bnum).txt) / 2))
_PrintString (tpx, btn(bnum).byy + 1), btn(bnum).txt
Color forek, backk
End Select
End If
enddrawb:
End Sub
Sub hide_button (bnum)
'blacks out a button on the mainscreen and the button tracking image
If bnum < 1 Or bnum > button_count Then GoTo endhide
ds& = _Dest
If btn(bnum).state = "ON" Then
btn(bnum).state = "HIDE"
_Dest bt&
Select Case btn(bnum).style
Case "TEXTONLY"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), 0, BF
_Dest ds&
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(Len(btn(bnum).txt), " ")
Case "BTEXT", "MENU"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), 0, BF
_Dest ds&
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(Len(btn(bnum).txt), " ")
Color forek, backk
Case "LBAR"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), 0, BF
_Dest ds&
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, " ")
Case "CBAR"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), 0, BF
_Dest ds&
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, " ")
Case "BBOX1", "BBOX2"
Line (btn(bnum).bxx, btn(bnum).byy)-(btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 2), 0, BF
_Dest ds&
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(btn(bnum).bwid, " ")
End Select
End If
endhide:
End Sub
Sub show_button (bnum)
'chnage a buttons state and draw it on the main screen and button tracking image
If bnum > 0 And bnum <= button_count Then
btn(bnum).state = "ON"
draw_button bnum
End If
End Sub
Sub draw_allbuttons
'draw all the buttons
For b = 1 To button_count
draw_button b
Next b
End Sub
Sub flash_button (bnum)
'have the button flash to show it has been selected
If bnum < 1 Or bnum > button_count GoTo endflashb
If btn(bnum).state = "ON" Then
Select Case btn(bnum).style
Case "TEXTONLY"
Color backk, btn(bnum).tklr \ 2
_PrintString (btn(bnum).bxx, btn(bnum).byy), btn(bnum).txt
_Delay 0.3
Color forek
Case "BTEXT", "MENU"
Color backk, btn(bnum).tklr \ 2
_PrintString (btn(bnum).bxx, btn(bnum).byy), btn(bnum).txt
_Delay 0.3
Color forek, backk
Case "LBAR"
Color backk, btn(bnum).tklr, btn(bnum).bklr
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy), btn(bnum).txt
_Delay 0.3
Color forek, backk
Case "CBAR"
Color backk, btn(bnum).tklr \ 2
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, " ")
tpx = btn(bnum).bxx + (Int(btn(bnum).bwid / 2) - Int(Len(btn(bnum).txt) / 2))
_PrintString (tpx, btn(bnum).byy), btn(bnum).txt
_Delay 0.3
Color forek, backk
Case "BBOX1"
Color backk, btn(bnum).fklr \ 2
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, Chr$(196))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(btn(bnum).bwid, Chr$(196))
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(1, Chr$(218))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(1, Chr$(179))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(1, Chr$(192))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), String$(1, Chr$(191))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 1), String$(1, Chr$(179))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 2), String$(1, Chr$(217))
Color backk, btn(bnum).tklr
tpx = btn(bnum).bxx + (Int(btn(bnum).bwid / 2) - Int(Len(btn(bnum).txt) / 2))
_PrintString (tpx, btn(bnum).byy + 1), btn(bnum).txt
_Delay 0.3
Color forek, backk
Case "BBOX2"
Color backk, btn(bnum).fklr \ 2
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(btn(bnum).bwid, Chr$(205))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(btn(bnum).bwid, " ")
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(btn(bnum).bwid, Chr$(205))
_PrintString (btn(bnum).bxx, btn(bnum).byy), String$(1, Chr$(201))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 1), String$(1, Chr$(186))
_PrintString (btn(bnum).bxx, btn(bnum).byy + 2), String$(1, Chr$(200))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy), String$(1, Chr$(187))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 1), String$(1, Chr$(186))
_PrintString (btn(bnum).bxx + btn(bnum).bwid - 1, btn(bnum).byy + 2), String$(1, Chr$(188))
Color backk, btn(bnum).tklr
tpx = btn(bnum).bxx + (Int(btn(bnum).bwid / 2) - Int(Len(btn(bnum).txt) / 2))
_PrintString (tpx, btn(bnum).byy + 1), btn(bnum).txt
_Delay 0.3
Color forek, backk
End Select
End If
endflashb:
End Sub
|
|
|
IsNum |
Posted by: SMcNeill - 11-30-2022, 04:00 PM - Forum: Utilities
- Replies (4)
|
 |
A quick little routine to tell you if a string is a number, or not.
Code: (Select All) Function IsNum%% (PassedText As String)
text$ = PassedText
special$ = UCase$(Left$(text$, 2))
Select Case special$
Case "&H", "&B", "&O"
'check for symbols on right side of value
r3$ = Right$(text$, 3)
Select Case r3$
Case "~&&", "~%%", "~%&" 'unsigned int64, unsigned byte, unsigned offset
text$ = Left$(text$, Len(text$) - 3)
Case Else
r2$ = Right$(text$, 2)
Select Case r2$
Case "~&", "##", "%&", "%%", "~%", "&&" 'unsigned long, float, offset, byte, unsigned integer, int64
text$ = Left$(text$, Len(text$) - 2)
Case Else
r$ = Right$(text$, 1)
Select Case r$
Case "&", "#", "%", "!" 'long, double, integer, single
text$ = Left$(text$, Len(text$) - 1)
End Select
End Select
End Select
check$ = "0123456789ABCDEF"
If special$ = "&O" Then check$ = "01234567"
If special$ = "&B" Then check$ = "01"
temp$ = Mid$(UCase$(text$), 2)
For i = 1 To Len(temp$)
If InStr(check$, Mid$(temp$, i, 1)) = 0 Then Exit For
Next
If i <= Len(temp$) Then IsNum = -1
Case Else
If _Trim$(Str$(Val(text$))) = text$ Then IsNum = -1
End Select
End Function
Note that this may fail if you're dealing with values that are so large they translate into scientific notation on you. "1234567890123456788901234567890" is NOT going to be counted as a number, as QB64 would expect to see this written as "1.234567E30", and your string definitely isn't going to compare to that string. (And the values probably won't match either, as you lost multiple digits to rounding when it became a scientific notation value.)
If you look close, you'll see that this function is basically one line of code, unless you happen to be passing it &H, &B, &O values -- in which case it has to work much harder to see if the string you passed it is a valid number, or not.
|
|
|
Borderless window? RESIZE THIS! |
Posted by: Pete - 11-29-2022, 11:46 PM - Forum: General Discussion
- No Replies
|
 |
Hey if you like borderless windows but want a way to resize them forget about using $RESIZE. It has no border to grab on to. Oh, if you don't mind ugly, or want an all black window, you can add a WS_THICKBORDER element to your API call, which Steve discovered, but it's ugly. (It leaves a thin black row just below the top white border in any window that has a colored background.) Anyway, if you don't mind that, you can use it with QB64 $RESIZE. If you want an alternative to $RESIZE, try something like this...
Try a mouse drag at any side or any corner to enlarge or shrink the borderless window. Esc to quit.
Code: (Select All) DIM SHARED WinMse AS POINTAPI
TYPE POINTAPI
X_Pos AS LONG
Y_Pos AS LONG
END TYPE
DECLARE DYNAMIC LIBRARY "user32"
FUNCTION ShowWindow& (BYVAL hwnd AS LONG, BYVAL nCmdShow AS LONG)
FUNCTION GetAsyncKeyState% (BYVAL vkey AS LONG)
FUNCTION GetCursorPos (lpPoint AS POINTAPI)
FUNCTION FindWindowA& (BYVAL ClassName AS _OFFSET, WindowName$) 'handle by title
REM FUNCTION ShowWindow& (BYVAL hwnd AS LONG, BYVAL nCmdShow AS LONG) 'maximize process
FUNCTION GetForegroundWindow& 'Find currently focused process handle
FUNCTION SetWindowPos& (BYVAL hWnd AS LONG, BYVAL hWndInsertAfter AS _OFFSET, BYVAL X AS INTEGER, BYVAL Y AS INTEGER, BYVAL cx AS INTEGER, BYVAL cy AS INTEGER, BYVAL uFlags AS _OFFSET)
FUNCTION GetWindowLongA& (BYVAL hwnd AS LONG, BYVAL nIndex AS LONG)
FUNCTION SetWindowLongA& (BYVAL hwnd AS LONG, BYVAL nIndex AS LONG, BYVAL dwNewLong AS LONG)
FUNCTION SetLayeredWindowAttributes& (BYVAL hwnd AS LONG, BYVAL crKey AS LONG, BYVAL bAlpha AS _UNSIGNED _BYTE, BYVAL dwFlags AS LONG)
FUNCTION SetCursorPos% (BYVAL cx AS INTEGER, BYVAL cy AS INTEGER)
SUB SENDKEYS ALIAS keybd_event (BYVAL bVk AS LONG, BYVAL bScan AS LONG, BYVAL dwFlags AS LONG, BYVAL dwExtraInfo AS LONG)
END DECLARE
DIM AS INTEGER setcurx, setcury, sizeit, oldmx, oldmy, x, y, fw, fh
x = _SCREENX
y = _SCREENY
w = _WIDTH
h = _HEIGHT
fw = _FONTWIDTH
fh = _FONTHEIGHT
DIM hWnd AS LONG
hWnd = _WINDOWHANDLE
_DELAY .1
GWL_STYLE = -16
WS_POPUP = &H4800000 ' Can be used to make a razor thin border but is not resizable.
ws_border = &H800000
WS_VISIBLE = &H10000000
DO
winstyle& = GetWindowLongA&(hWnd, GWL_STYLE)
LOOP UNTIL winstyle&
DO
a& = SetWindowLongA&(hWnd, GWL_STYLE, winstyle& AND WS_VISIBLE)
LOOP UNTIL a&
a& = SetWindowPos&(hWnd&, 0, 0, 0, 0, 0, 39) ' Required to allow printing where title bar used to be.
_DELAY .1
wintp = _SCREENY \ fh: winbt = _SCREENY \ fh + _HEIGHT: winlt = _SCREENX \ fw: winrt = _SCREENX \ fw + _WIDTH
DO
_LIMIT 60
WHILE _MOUSEINPUT: WEND
IF _MOUSEBUTTON(1) THEN lb = 1 ELSE IF lb = 1 AND _MOUSEBUTTON(1) = 0 THEN lb = 0: side$ = "": enl = 0
z& = GetCursorPos(WinMse)
setcurx = WinMse.X_Pos: setcury = WinMse.Y_Pos
WinMse.X_Pos = WinMse.X_Pos \ fw
WinMse.Y_Pos = WinMse.Y_Pos \ fh
IF lb THEN
IF LEN(side$) THEN
IF oldmx <> WinMse.X_Pos OR oldmy <> WinMse.Y_Pos THEN
DO ' Falx loop.
SELECT CASE side$
CASE "left-top"
sizeit = -SGN(oldmy - WinMse.Y_Pos) * ABS(oldmy - WinMse.Y_Pos)
IF sizeit THEN GOSUB topsize
sizeit = SGN(oldmx - WinMse.X_Pos) * ABS(oldmx - WinMse.X_Pos)
IF sizeit THEN GOSUB leftsize
CASE "right-top"
sizeit = -SGN(oldmy - WinMse.Y_Pos) * ABS(oldmy - WinMse.Y_Pos)
IF sizeit THEN GOSUB topsize
sizeit = -SGN(oldmx - WinMse.X_Pos) * ABS(oldmx - WinMse.X_Pos)
IF sizeit THEN GOSUB rightsize
CASE "left-bottom"
sizeit = SGN(oldmx - WinMse.X_Pos) * ABS(oldmx - WinMse.X_Pos)
IF sizeit THEN GOSUB leftsize
sizeit = SGN(oldmy - WinMse.Y_Pos) * ABS(oldmy - WinMse.Y_Pos)
IF sizeit THEN GOSUB bottomsize
CASE "right-bottom"
sizeit = -SGN(oldmx - WinMse.X_Pos) * ABS(oldmx - WinMse.X_Pos)
IF sizeit THEN GOSUB rightsize
sizeit = SGN(oldmy - WinMse.Y_Pos) * ABS(oldmy - WinMse.Y_Pos)
IF sizeit THEN GOSUB bottomsize
CASE "top" ' up/down
sizeit = -SGN(oldmy - WinMse.Y_Pos) * ABS(oldmy - WinMse.Y_Pos)
IF sizeit THEN GOSUB topsize
CASE "bottom"
sizeit = SGN(oldmy - WinMse.Y_Pos) * ABS(oldmy - WinMse.Y_Pos)
IF sizeit THEN GOSUB bottomsize
CASE "left"
sizeit = SGN(oldmx - WinMse.X_Pos) * ABS(oldmx - WinMse.X_Pos)
IF sizeit THEN GOSUB leftsize
CASE "right"
sizeit = -SGN(oldmx - WinMse.X_Pos) * ABS(oldmx - WinMse.X_Pos)
IF sizeit THEN GOSUB rightsize
END SELECT
wintp = y \ fh: winbt = y \ fh + _HEIGHT: winlt = x \ fw: winrt = x \ fw + _WIDTH
EXIT DO
LOOP
END IF
END IF
ELSE
IF WinMse.X_Pos = winlt AND WinMse.Y_Pos = wintp THEN
_MOUSESHOW "TOPLEFT_BOTTOMRIGHT": side$ = "left-top"
ELSEIF WinMse.X_Pos = winlt AND WinMse.Y_Pos = winbt THEN _MOUSESHOW "TOPRIGHT_BOTTOMLEFT": side$ = "left-bottom"
ELSEIF WinMse.X_Pos = winrt AND WinMse.Y_Pos = wintp THEN _MOUSESHOW "TOPRIGHT_BOTTOMLEFT": side$ = "right-top"
ELSEIF WinMse.X_Pos = winrt AND WinMse.Y_Pos = winbt THEN _MOUSESHOW "TOPleft_BOTTOMRIGHT": side$ = "right-bottom"
ELSEIF WinMse.X_Pos = winlt THEN _MOUSESHOW "HORIZONTAL": side$ = "left"
ELSEIF WinMse.X_Pos = winrt THEN _MOUSESHOW "HORIZONTAL": side$ = "right"
ELSEIF WinMse.Y_Pos = wintp THEN _MOUSESHOW "VERTICAL": side$ = "top"
ELSEIF WinMse.Y_Pos = winbt THEN _MOUSESHOW "VERTICAL": side$ = "bottom"
ELSE
IF LEN(side$) THEN side$ = "": _MOUSESHOW "default"
END IF
END IF
oldmx = WinMse.X_Pos: oldmy = WinMse.Y_Pos
IF INKEY$ = CHR$(27) THEN SYSTEM
LOOP
topsize:
IF h - sizeit < 5 THEN RETURN
h = h - sizeit
x = _SCREENX
y = _SCREENY + sizeit * fh
WIDTH w, h
_FONT 16
_SCREENMOVE x, y
z% = SetCursorPos%(setcurx, setcury)
RETURN
leftsize:
IF w + sizeit < 15 THEN RETURN
w = w + sizeit
x = _SCREENX - sizeit * fw
y = _SCREENY
WIDTH w, h
_FONT 16
_SCREENMOVE x, y
z% = SetCursorPos%(x, setcury)
RETURN
rightsize:
IF w + sizeit < 15 THEN RETURN
w = w + sizeit
x = _SCREENX - sizeit * fw
y = _SCREENY
WIDTH w, h
_FONT 16
x = _SCREENX: y = _SCREENY
z% = SetCursorPos%(x + _WIDTH * fw, setcury)
RETURN
bottomsize:
IF h - sizeit < 5 THEN RETURN
h = h - sizeit
WIDTH w, h
_FONT 16
x = _SCREENX: y = _SCREENY
z% = SetCursorPos%(setcurx, y + _HEIGHT * fh)
RETURN
Something I may try later is using the _NEWIMAGE equivalent of SCREEN 0. I'd like to see if that would eliminate the need to load QB64 default 16 size font. One problem with window sizing in SCREEN 0 is that 16 size font gets traded out at different sizes with what I think is the 8 size square font. Anyway, that causes irregular resizing results. Specifying _FONT 16 prevents that occurrence.
As always, if anyone has any improvement suggestions, go ahead and post them. A nice perk to sharing code is more minds often results in more performance.
Pete
|
|
|
QIX |
Posted by: james2464 - 11-29-2022, 02:36 AM - Forum: Works in Progress
- Replies (13)
|
 |
Making my way through this game, thought I'd share what I have done so far.
For those not familiar, it's an old arcade game from 1981. The idea is to fill in 75% of the screen to complete a level. (So far no scores yet, and unlimited lives)
Still some things missing (like those sparks) and there are some bugs to sort out. No sound either - not sure how I'll do that because the original game had bad sound effects.
One thing I'd like to do eventually is learn a flood fill algorithm. I struggled with that and decided to just use paint for now. Flood fill in this case was more complicated than I was expecting it to be. But it'd be nice to do it like the original game does.
Code: (Select All) 'QB64 Qix
'james2464 - November 2022
'controls : arrow keys to move
' : left CTRL for fast draw (blue)
' : left ALT for slow draw (red)
_FullScreen
Option _Explicit
Dim Shared scx, scy
scx = 610: scy = 500
Screen _NewImage(scx, scy, 32)
Const PI = 3.141592654#
Randomize Timer
Dim Shared bg&, dbg&, logo1
bg& = _NewImage(scx, scy, 32)
dbg& = _NewImage(scx, scy, 32)
Dim Shared xx, yy, t, olddir, x, y, h, hd, fl, fl2, ct
Dim Shared sdinprocess, fdinprocess As Integer
Dim Shared qpath, flag, n, movepermit, flagrestart As Integer
Dim Shared qixtot, qxv, qyv, f, pmove, pfast, pslow, oldpx, oldpy, ps, drawoldx, drawoldy
Dim Shared j, k, checkx1, checkx2, checky1, checky2, totpct, btot, rtot
Dim Shared bluetot, redtot As _Integer64
'origin
xx = 320: yy = 240
Dim Shared c(50) As Long
c(0) = _RGB(0, 0, 0)
c(1) = _RGB(200, 200, 210) 'outside border
c(2) = _RGB(255, 255, 255) 'cursor white dot
c(3) = _RGB(200, 100, 100)
c(4) = _RGB(50, 120, 150) 'fast zone (fill)
c(5) = _RGB(180, 60, 30) 'slow zone (fill)
c(6) = _RGB(0, 255, 0)
c(7) = _RGB(255, 0, 0) 'cursor red
c(44) = _RGB(50, 120, 155) 'fast zone (drawing lines)
c(45) = _RGB(185, 60, 30) 'slow zone (drawing lines)
Type player
x As Single
y As Single
End Type
Dim Shared pl As player
Type qix
dir As Single
x1 As Integer
x2 As Integer
y1 As Integer
y2 As Integer
xx As Single
yy As Single
len1 As Single
c1 As Integer
c2 As Integer
c3 As Integer
End Type
Dim Shared q(7) As qix
Dim Shared qd(7) As qix
qixtot = 7: qpath = 0: f = 1
ps = 5
Do
'start
pl.x = 320: pl.y = 440
flagrestart = 0
For t = 1 To qixtot
q(t).xx = xx: q(t).yy = yy: q(t).len1 = 40
Next t
'_MouseHide
Cls
'screen setup
Line (120, 40)-(520, 440), c(1), B 'outer border
'_PutImage (500, 50), logo1
bluetot = 0: redtot = 0
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx, scy) 'take snapshot of screen
Do
_Limit 20
'player cursor =======================================================================================
'get keyboard input
pmove = arrowkey
pfast = fastdraw
pslow = slowdraw
oldpx = pl.x: oldpy = pl.y
If pfast + pslow = 0 Then normalmove
If pfast > pslow Then fastdrawmove
If pfast < pslow Then slowdrawmove
'ok so about that qix thing....=======================================================================================
'heading and direction -----------------------------------------------------
If qpath < 1 Then
If qpath = 0 Then
'_Delay 1.
qpath = Int(Rnd * 11) + 1: qxv = Rnd * 30 - 15: qyv = Rnd * 30 - 15
olddir = q(1).dir: q(1).dir = olddir + Rnd * PI - PI / 2
End If
If qpath = -1 Then
'_Delay .5
qpath = (Rnd * 22) + 1: qxv = Rnd * 30 - 15: qyv = Rnd * 30 - 15
olddir = q(1).dir
If olddir > PI Then
q(1).dir = olddir - PI
Else
q(1).dir = olddir + PI
End If
End If
End If
qpath = Int(qpath - 1)
'update trailing lines -----------------------------------------------------
For t = 7 To 2 Step -1
q(t).xx = q(t - 1).xx: q(t).yy = q(t - 1).yy
q(t).x1 = q(t - 1).x1: q(t).x2 = q(t - 1).x2
q(t).y1 = q(t - 1).y1: q(t).y2 = q(t - 1).y2
q(t).len1 = q(t - 1).len1
q(t).c1 = q(t - 1).c1: q(t).c2 = q(t - 1).c2: q(t).c3 = q(t - 1).c3
Next t
'collision detection -------------------------------------------------------
flag = 0 'collision - assume none to start
q(1).xx = q(1).xx + qxv
q(1).yy = q(1).yy + qyv
q(1).dir = q(1).dir + Rnd * .9 - .45
q(1).len1 = q(1).len1 + Rnd * 10 - 4.4
If q(1).len1 > 40 Then q(1).len1 = 40
If q(1).len1 < 5 Then q(1).len1 = 5
x = Cos(q(1).dir) * q(1).len1
y = Sin(q(1).dir) * q(1).len1
q(1).x1 = q(1).xx + x: q(1).x2 = q(1).xx - x
q(1).y1 = q(1).yy - y: q(1).y2 = q(1).yy + y
'scan background colour along line
For j = 0 To q(1).len1
x = Cos(q(1).dir) * j: y = Sin(q(1).dir) * j
checkx1 = q(1).xx + x: checkx2 = q(1).xx - x
checky1 = q(1).yy - y: checky2 = q(1).yy + y
c(19) = Point(checkx1, checky1)
c(20) = Point(checkx2, checky2)
If c(19) <> c(0) Then
Select Case c(19)
Case c(1)
flag = 1
Case q(2).c1, q(3).c1, q(4).c1, q(5).c1, q(6).c1, q(7).c1
flag = 1
Case c(44), c(7)
If fdinprocess = 1 Then
flag = 2
End If
Case c(45), c(7)
If sdinprocess = 1 Then
flag = 2
End If
End Select
End If
If c(20) <> c(0) Then
Select Case c(20)
Case c(1)
flag = 1
Case q(2).c1, q(3).c1, q(4).c1, q(5).c1, q(6).c1, q(7).c1
flag = 1
Case c(44), c(7)
If fdinprocess = 1 Then
flag = 2
End If
Case c(45), c(7)
If sdinprocess = 1 Then
flag = 2
End If
End Select
End If
Next j
'check for skipped/crossed line
h = _Hypot(qyv, qxv)
hd = _Atan2(-qxv, -qyv)
For j = 0 To Int(h) Step .5
x = Sin(-hd) * j: y = Cos(hd) * j
checkx2 = q(1).xx - x
checky2 = q(1).yy + y
c(20) = Point(checkx2, checky2)
If c(20) <> c(0) Then
Select Case c(20)
Case c(1)
flag = 1
Case q(2).c1, q(3).c1, q(4).c1, q(5).c1, q(6).c1, q(7).c1
flag = 1
Case c(4), c(7)
If fdinprocess = 1 Then
flag = 2
End If
Case c(5), c(7)
If sdinprocess = 1 Then
flag = 2
End If
End Select
End If
Next j
'changing colour
q(1).c1 = q(1).c1 + Rnd * 60 - 30
If q(1).c1 < 80 Then q(1).c1 = 80
If q(1).c1 > 255 Then q(1).c1 = 255
q(1).c2 = q(1).c2 + Rnd * 60 - 30
If q(1).c2 < 80 Then q(1).c2 = 80
If q(1).c2 > 255 Then q(1).c2 = 255
q(1).c3 = q(1).c3 + Rnd * 60 - 30
If q(1).c3 < 80 Then q(1).c3 = 80
If q(1).c3 > 255 Then q(1).c3 = 255
'if collision detected...
If flag = 1 Then
qpath = -1 'new path needed - reverse direction
q(1).xx = q(3).xx: q(1).yy = q(3).yy
q(1).x1 = q(3).x1: q(1).x2 = q(3).x2
q(1).y1 = q(3).y1: q(1).y2 = q(3).y2
q(1).len1 = q(3).len1 - 3 'shorter line
End If
If flag = 2 Then
youdead
_PutImage (1, 1)-(scx, scy), dbg&, bg&, (1, 1)-(scx, scy)
End If
'====================================================================================================
'====================================================================================================
'====================================================================================================
'====================================================================================================
Cls
_PutImage (0, 0)-(scx, scy), bg&, 0 'draw background
For t = 1 To qixtot
c(9) = _RGB(q(t).c1, q(t).c2, q(t).c3)
Line (q(t).x1, q(t).y1)-(q(t).x2, q(t).y2), c(9)
Next t
Line (pl.x - ps, pl.y)-(pl.x, pl.y - ps), c(7)
Line (pl.x, pl.y - ps)-(pl.x + ps, pl.y), c(7)
Line (pl.x + ps, pl.y)-(pl.x, pl.y + ps), c(7)
Line (pl.x, pl.y + ps)-(pl.x - ps, pl.y), c(7)
Line (pl.x - 1, pl.y)-(pl.x + 1, pl.y), c(2)
Line (pl.x, pl.y - 1)-(pl.x, pl.y + 1), c(2)
btot = Int(bluetot / 1570)
rtot = Int(redtot / 1570)
totpct = Int(btot + rtot)
Locate 29, 20
Print "BLUE:"; btot; "%"
Locate 29, 36
Print "RED:"; rtot; "%"
Locate 29, 52
Print "TOTAL:"; totpct; "%"
_Display
If sdinprocess < 0 Then
_Delay .8
sdinprocess = 0
End If
If fdinprocess < 0 Then
_Delay .8
fdinprocess = 0
End If
If totpct > 75 Then
endlevel
flagrestart = 1
End If
If _KeyDown(15104) Then
endlevel
flagrestart = 1
End If
Loop Until flagrestart = 1
Loop
Function arrowkey
arrowkey = 0
If _KeyDown(18432) Then ' IF up arrow key was pressed
arrowkey = 1 '
End If
If _KeyDown(20480) Then ' IF down arrow key was pressed
arrowkey = 2 '
End If
If _KeyDown(19200) Then ' IF left arrow key was pressed
arrowkey = 3 '
End If
If _KeyDown(19712) Then ' IF right arrow key was pressed
arrowkey = 4 '
End If
End Function
Function fastdraw
fastdraw = 0
If _KeyDown(100306) Then ' IF L-CTRL key was pressed
fastdraw = 1 '
End If
End Function
Function slowdraw
slowdraw = 0
If _KeyDown(100308) Then ' IF L-ALT key was pressed
slowdraw = 1 '
End If
End Function
'-----------------------------------------------------------------------------------------------------------------
Sub normalmove
Select Case pmove
Case 1
pl.y = pl.y - 4
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
movepermit = 0
While movepermit = 0
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.y = pl.y + 2
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.y = pl.y + 2
movepermit = -1
End If
End If
Wend
Case 2
pl.y = pl.y + 4
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
movepermit = 0
While movepermit = 0
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.y = pl.y - 2
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.y = pl.y - 2
movepermit = -1
End If
End If
Wend
Case 3
pl.x = pl.x - 4
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
movepermit = 0
While movepermit = 0
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.x = pl.x + 2
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.x = pl.x + 2
movepermit = -1
End If
End If
Wend
Case 4
pl.x = pl.x + 4
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
movepermit = 0
While movepermit = 0
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.x = pl.x - 2
c(19) = Point(pl.x, pl.y)
c(20) = Point(pl.x + 1, pl.y)
c(21) = Point(pl.x - 1, pl.y)
c(22) = Point(pl.x, pl.y + 1)
c(23) = Point(pl.x, pl.y - 1)
c(24) = Point(pl.x + 1, pl.y + 1)
c(25) = Point(pl.x - 1, pl.y - 1)
c(26) = Point(pl.x - 1, pl.y + 1)
c(27) = Point(pl.x + 1, pl.y - 1)
fl2 = 0
For fl = 20 To 27 Step 1
If c(fl) = c(0) Then fl2 = 1
Next fl
If c(19) = c(1) And fl2 > 0 Then
movepermit = 1
Else
pl.x = pl.x - 2
movepermit = -1
End If
End If
Wend
End Select
End Sub
Sub fastdrawmove
Select Case pmove
Case 1
pl.y = pl.y - 4
If pl.y < 40 Then pl.y = 40
c(19) = Point(pl.x, pl.y)
c(18) = Point(pl.x, pl.y + 2)
movepermit = 0
While movepermit = 0
If c(18) = c(0) Then
movepermit = 1
Else
pl.y = pl.y + 2
If c(18) = c(1) Then
movepermit = 1
Else
pl.y = pl.y + 2
movepermit = -1
End If
End If
Wend
Case 2
pl.y = pl.y + 4
If pl.y > 440 Then pl.y = 440
c(19) = Point(pl.x, pl.y)
c(18) = Point(pl.x, pl.y - 2)
movepermit = 0
While movepermit = 0
If c(18) = c(0) Then
movepermit = 1
Else
pl.y = pl.y - 2
If c(18) = c(1) Then
movepermit = 1
Else
pl.y = pl.y - 2
movepermit = -1
End If
End If
Wend
Case 3
pl.x = pl.x - 4
If pl.x < 120 Then pl.x = 120
c(19) = Point(pl.x, pl.y)
c(18) = Point(pl.x + 2, pl.y)
movepermit = 0
While movepermit = 0
If c(18) = c(0) Then
movepermit = 1
Else
pl.x = pl.x + 2
If c(18) = c(1) Then
movepermit = 1
Else
pl.x = pl.x + 2
movepermit = -1
End If
End If
Wend
Case 4
pl.x = pl.x + 4
If pl.x > 520 Then pl.x = 520
c(19) = Point(pl.x, pl.y)
c(18) = Point(pl.x - 2, pl.y)
movepermit = 0
While movepermit = 0
If c(18) = c(0) Then
movepermit = 1
Else
pl.x = pl.x - 2
If c(18) = c(1) Then
movepermit = 1
Else
pl.x = pl.x - 2
movepermit = -1
End If
End If
Wend
End Select
c(19) = Point(pl.x, pl.y)
If c(19) = c(0) Then
Cls
_PutImage (0, 0)-(scx, scy), bg&, 0 'draw background screen
If fdinprocess = 0 Then
drawoldx = oldpx: drawoldy = oldpy
_PutImage (1, 1)-(scx - 1, scy - 1), 0, dbg&, (1, 1)-(scx, scy) 'take snapshot of screen - in case of death
End If
Line (oldpx, oldpy)-(pl.x, pl.y), c(44)
If fdinprocess = 0 Then
PSet (oldpx, oldpy), c(1)
End If
fdinprocess = 1
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx, scy) 'take snapshot of screen
End If
If fdinprocess = 1 Then
c(19) = Point(pl.x, pl.y)
If c(19) = c(1) Then 'fast draw completed
Cls
_PutImage (0, 0)-(scx, scy), bg&, 0 'draw background screen
Line (oldpx, oldpy)-(pl.x, pl.y), c(44)
PSet (pl.x, pl.y), c(1)
fdinprocess = -1
claimlinefast
claimfillfast
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx, scy) 'take snapshot of screen
End If
End If
End Sub
Sub slowdrawmove
Select Case pmove
Case 1
pl.y = pl.y - 2
If pl.y < 40 Then pl.y = 40
c(19) = Point(pl.x, pl.y)
movepermit = 0
While movepermit = 0
If c(19) = c(0) Then
movepermit = 1
Else
If c(19) = c(1) Then
movepermit = 1
Else
pl.y = pl.y + 2
movepermit = -1
End If
End If
Wend
Case 2
pl.y = pl.y + 2
If pl.y > 440 Then pl.y = 440
c(19) = Point(pl.x, pl.y)
movepermit = 0
While movepermit = 0
If c(19) = c(0) Then
movepermit = 1
Else
If c(19) = c(1) Then
movepermit = 1
Else
pl.y = pl.y - 2
movepermit = -1
End If
End If
Wend
Case 3
pl.x = pl.x - 2
If pl.x < 120 Then pl.x = 120
c(19) = Point(pl.x, pl.y)
movepermit = 0
While movepermit = 0
If c(19) = c(0) Then
movepermit = 1
Else
If c(19) = c(1) Then
movepermit = 1
Else
pl.x = pl.x + 2
movepermit = -1
End If
End If
Wend
Case 4
pl.x = pl.x + 2
If pl.x > 520 Then pl.x = 520
c(19) = Point(pl.x, pl.y)
movepermit = 0
While movepermit = 0
If c(19) = c(0) Then
movepermit = 1
Else
If c(19) = c(1) Then
movepermit = 1
Else
pl.x = pl.x - 2
movepermit = -1
End If
End If
Wend
End Select
c(19) = Point(pl.x, pl.y)
If c(19) = c(0) Then
Cls
_PutImage (0, 0)-(scx, scy), bg&, 0 'draw background screen
If sdinprocess = 0 Then
drawoldx = oldpx: drawoldy = oldpy
_PutImage (1, 1)-(scx - 1, scy - 1), 0, dbg&, (1, 1)-(scx, scy) 'take snapshot of screen - in case of death
End If
Line (oldpx, oldpy)-(pl.x, pl.y), c(45)
If sdinprocess = 0 Then
PSet (oldpx, oldpy), c(1)
End If
sdinprocess = 1
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx, scy) 'take snapshot of screen
End If
If sdinprocess = 1 Then
c(19) = Point(pl.x, pl.y)
If c(19) = c(1) Then 'slow draw completed
Cls
_PutImage (0, 0)-(scx, scy), bg&, 0 'draw background screen
Line (oldpx, oldpy)-(pl.x, pl.y), c(45)
PSet (pl.x, pl.y), c(1)
sdinprocess = -1
claimlineslow
claimfillslow
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx, scy) 'take snapshot of screen
End If
End If
End Sub
Sub claimlinefast
'scan board for blue line
For j = 41 To 439
For k = 121 To 519
c(19) = Point(k, j)
n = 0
If c(19) = c(44) Then 'blue pixel found
c(20) = Point(k - 1, j)
c(21) = Point(k + 1, j)
c(22) = Point(k, j - 1)
c(23) = Point(k, j + 1)
c(24) = Point(k, j + 2)
c(25) = Point(k, j - 2)
c(26) = Point(k + 2, j)
'horizontal line
If c(22) = c(0) Then 'look above
If c(23) = c(0) Then n = Int(2) 'look below
End If
'upper left corner
If n = 0 Then
'look below 2 pixels
If c(23) = c(44) Then
If c(24) = c(44) Then
If c(20) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'upper right corner
If n = 0 Then
'look below 2 pixels
If c(23) = c(44) Then
If c(24) = c(44) Then
If c(21) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'lower left corner
If n = 0 Then
'look to the right 2 pixels
If c(21) = c(44) Then
If c(26) = c(44) Then
If c(23) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'lower right corner
If n = 0 Then
'look above 2 pixels
If c(22) = c(1) Then
If c(25) = c(1) Then
If c(23) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'if part of vertical line
If c(20) = c(0) Then
If c(21) = c(0) Then n = Int(2)
End If
If n = 2 Then
PSet (k, j), c(1) 'change blue pixel to white
End If
End If
Next k
Next j
End Sub
Sub claimlineslow
'scan board for red line
For j = 41 To 439
For k = 121 To 519
c(19) = Point(k, j)
n = 0
If c(19) = c(45) Then 'red pixel found
c(20) = Point(k - 1, j)
c(21) = Point(k + 1, j)
c(22) = Point(k, j - 1)
c(23) = Point(k, j + 1)
c(24) = Point(k, j + 2)
c(25) = Point(k, j - 2)
c(26) = Point(k + 2, j)
'horizontal line
If c(22) = c(0) Then 'look above
If c(23) = c(0) Then n = Int(2) 'look below
End If
'upper left corner
If n = 0 Then
'look below 2 pixels
If c(23) = c(45) Then
If c(24) = c(45) Then
If c(20) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'upper right corner
If n = 0 Then
'look below 2 pixels
If c(23) = c(45) Then
If c(24) = c(45) Then
If c(21) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'if lower left corner
If n = 0 Then
'look to the right 2 pixels
If c(21) = c(45) Then
If c(26) = c(45) Then
If c(23) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'if lower right corner
If n = 0 Then
'look above 2 pixels
If c(22) = c(1) Then
If c(25) = c(1) Then
If c(23) = c(0) Then
n = Int(2)
End If
End If
End If
End If
'if part of vertical line
If c(20) = c(0) Then
If c(21) = c(0) Then n = Int(2)
End If
If n = 2 Then
PSet (k, j), c(1) 'change red pixel to white
End If
End If
Next k
Next j
End Sub
Sub claimfillfast 'using paint for flood fills
'start at qix
c(14) = _RGB(30, 30, 30)
k = q(1).xx: j = q(1).yy
Paint (k, j), c(14), c(1)
'fill black with blue
For j = 41 To 439
For k = 121 To 519
c(16) = Point(k, j)
If c(16) = c(0) Then
PSet (k, j), c(4)
bluetot = bluetot + 1
End If
Next k
Next j
'fill gray with black
k = q(1).xx: j = q(1).yy
Paint (k, j), c(0), c(1)
End Sub
Sub claimfillslow 'using paint for flood fills
'start at qix
c(14) = _RGB(30, 30, 30)
k = q(1).xx: j = q(1).yy
Paint (k, j), c(14), c(1)
'fill black with red
For j = 41 To 439
For k = 121 To 519
c(16) = Point(k, j)
If c(16) = c(0) Then
PSet (k, j), c(5)
redtot = redtot + 1
End If
Next k
Next j
'fill gray with black
k = q(1).xx: j = q(1).yy
Paint (k, j), c(0), c(1)
End Sub
Sub endlevel
'fill black
For j = 121 To 519
For k = 439 To 41 Step -1
PSet (j, k), c(0)
Next k
_Display
_Delay .005
Next j
End Sub
Sub youdead
Dim ct2, ct3, ct4, basedir, tx, ty, dist, d2, rp
basedir = .785
dist = 15
d2 = 10
qd(1).xx = pl.x + 5: qd(1).yy = pl.y - 5
qd(1).len1 = 10
qd(1).dir = basedir
For ct = 1 To 35
Cls
_PutImage (0, 0)-(scx, scy), bg&, 0 'draw background screen
dist = dist + 10
rp = ct
If rp > 7 Then rp = 7
qd(1).dir = basedir
qd(1).len1 = qd(1).len1 + 1.5
If rp > 1 Then
For ct4 = 2 To rp
qd(ct4).len1 = qd(ct4 - 1).len1 - 1.5
qd(ct4).dir = basedir
Next ct4
End If
For ct2 = 1 To rp
For ct3 = 1 To 4
Select Case ct3
Case 1
qd(ct2).xx = pl.x + (dist - ct2 * d2): qd(ct2).yy = pl.y - (dist - ct2 * d2)
Case 2
qd(ct2).xx = pl.x + (dist - ct2 * d2): qd(ct2).yy = pl.y + (dist - ct2 * d2)
Case 3
qd(ct2).xx = pl.x - (dist - ct2 * d2): qd(ct2).yy = pl.y + (dist - ct2 * d2)
Case 4
qd(ct2).xx = pl.x - (dist - ct2 * d2): qd(ct2).yy = pl.y - (dist - ct2 * d2)
End Select
qd(ct2).dir = qd(ct2).dir + (PI / 2)
x = Cos(qd(ct2).dir) * qd(ct2).len1
y = Sin(qd(ct2).dir) * qd(ct2).len1
qd(ct2).x1 = qd(ct2).xx + x: qd(ct2).x2 = qd(ct2).xx - x
qd(ct2).y1 = qd(ct2).yy - y: qd(ct2).y2 = qd(ct2).yy + y
Line (qd(ct2).x1, qd(ct2).y1)-(qd(ct2).x2, qd(ct2).y2), c(1)
Next ct3
Next ct2
_Display
_Delay .04
Next ct
_Delay 1.
sdinprocess = 0
fdinprocess = 0
pl.x = drawoldx: pl.y = drawoldy
End Sub
|
|
|
|