Just curious about the support for ARM and Raspberry Pi that QB64 has.
Does it work already on the Raspberry Pi, and if so, are there special setup instructions? Do we need to recompile the source code, or does it already work?
Also -- let's say I'm not using Raspberry Pi's official OS. If I am using Ubuntu, Manjaro, Linux Mint, or other Linux variants, do I pay closer attention to the Raspberry Pi, or to the version of Linux. In other words, is there one version of QB64 that works on multiple Linux distros, regardless of CPU, or do I need to stick to a Raspberry Pi/ARm version?
Nobel Prize will not receive itself
Nobelevskaya premiya sama sebya ne poluchit
Нобелевская премия сама себя не получит
Le prix Nobel ne se recevra pas
Nobelpreis wird sich nicht erhalten
Il Premio Nobel non ricevera se stesso
TYPE MenuType
Valid AS _BYTE
Visible AS _BYTE
ScrollBarHidden AS _BYTE
Top AS INTEGER
Left AS INTEGER
Width AS INTEGER
Height AS INTEGER
Frame AS _BYTE
BorderColor AS _UNSIGNED LONG
BackgroundColor AS _UNSIGNED LONG
Header AS _BYTE
Caption AS STRING * 255
CC AS _UNSIGNED LONG 'caption color
CBG AS _UNSIGNED LONG 'caption background color
HighLightColor AS _UNSIGNED LONG
Exit AS _BYTE
Entries AS INTEGER
TopEntry AS INTEGER
ListColor AS _UNSIGNED LONG
ListBackground AS _UNSIGNED LONG
ListJustify AS _BYTE
END TYPE
DIM SHARED MenusActive AS LONG
REDIM SHARED Menu(10) AS MenuType
REDIM SHARED MenuList(32767, 10) AS STRING 'Up to 32,767 items max in our list.
REDIM SHARED MenuListDisabled(32767, 10) AS _BYTE
REDIM SHARED MenuDisplayOrder(32767, 10) AS INTEGER
TYPE LinkType
one AS LONG
another AS LONG
END TYPE
REDIM SHARED LinkedTo(1000) AS LinkType
DIM SHARED ScrollDelay AS _FLOAT
DIM SHARED MouseScroll AS INTEGER
'Before here goes BI file content
'After here goes working program
DisableItem MainMenu, 5
ScrollDelay = .25
DO
CLS
LOCATE 20, 1: PRINT "Press <H> to hide the menu."
PRINT "Press <S> to show the menu."
PRINT "Press <N> for No Sort order."
PRINT "Press <A> for Alphabetic Sort order."
PRINT "Press <#> for Numeric Sort order."
PRINT "Press <C> to toggle case sorting."
PRINT "Press <R> to toggle reverse sorting."
PRINT "Press <L> to link the menus."
PRINT "Press <U> to unlink the menus."
PRINT "Press <TAB> to swap between menus."
PRINT "<ESC> to quit"
PRINT
PRINT "Currently: ";
IF sortmode AND 1 THEN
PRINT "ALPHA SORT";
IF kase THEN PRINT ", CASE-SENSITIVE";
IF reversed THEN PRINT ", REVERSE-ORDER" ELSE PRINT
ELSEIF sortmode AND 2 THEN
PRINT "NUMERIC SORT";
IF reversed THEN PRINT ", REVERSE-ORDER" ELSE PRINT
ELSE
PRINT "NOT SORTING"
END IF
LOCATE 5, 25
IF linked THEN PRINT "LINKED LISTS" ELSE PRINT "UNLINKED LISTS"
LOCATE 6, 15: PRINT "MENU ASSOCIATED WITH KEYBOARD: "; menuon
k = _KEYHIT
SELECT CASE k
CASE ASC("L"), ASC("l"): LinkMenus MainMenu, SecondMenu: linked = -1
CASE ASC("U"), ASC("u"): UnLinkMenus MainMenu, SecondMenu: linked = 0
CASE ASC("H"), ASC("h"): HideMenu menuon
CASE ASC("S"), ASC("s"): ShowMenu menuon
CASE ASC("N"), ASC("n"): sortmode = None: changed = -1: reversed = 0: kase = 0
CASE ASC("A"), ASC("a"): sortmode = Alpha: changed = -1
CASE ASC("#"), ASC("3"): sortmode = Numeric: changed = -1
CASE ASC("C"), ASC("c"): kase = NOT kase: changed = -1
CASE ASC("R"), ASC("r"): reversed = NOT reversed: changed = -1
CASE 9: menuon = menuon + 1: IF menuon = 3 THEN menuon = 1
CASE 27: SYSTEM
END SELECT
IF changed THEN
IF sortmode <> 0 THEN
IF kase THEN sortmode = sortmode OR NoCase ELSE sortmode = sortmode AND NOT NoCase
IF reversed THEN sortmode = sortmode OR Reverse ELSE sortmode = sortmode AND NOT Reverse
END IF
MenuDisplaySort menuon, sortmode
changed = 0
END IF
DisplayMenus
CheckMenus MouseStatus, MenuSelected, OptionSelected
IF MouseStatus <> 0 AND MenuSelected <> 0 THEN
IF MouseStatus AND LeftClick THEN
LOCATE 1, 1
PRINT "You LEFT CLICKED Option #"; OptionSelected; " in Menu #"; MenuSelected
PRINT "Which was: "; GetListItem(MenuSelected, OptionSelected)
PRINT
IF linked THEN
PRINT "Since our lists are linked, we get the following items:"; GetListItem(1, OptionSelected), GetListItem(2, OptionSelected)
ELSE
PRINT "Since our lists are unlinked, we get the following items:"; GetListItem(MenuSelected, OptionSelected)
END IF
_DISPLAY
_DELAY 2 'give it time to pop up
ELSEIF MouseStatus AND RightClick THEN
LOCATE 1, 1
PRINT "You RIGHT CLICKED Option #"; OptionSelected; " in Menu #"; MenuSelected
PRINT "Which was: "; GetListItem(MenuSelected, OptionSelected)
PRINT
IF linked THEN
PRINT "Since our lists are linked, we get the following items:"; GetListItem(1, OptionSelected), GetListItem(2, OptionSelected)
ELSE
PRINT "Since our lists are unlinked, we get the following items:"; GetListItem(MenuSelected, OptionSelected)
END IF
_DISPLAY
_DELAY 2 'give it time to pop up
END IF
COLOR Yellow
IF MouseStatus AND LeftDown THEN LOCATE 35, 1: PRINT "LEFT MOUSE DOWN over Option #"; OptionSelected; " in Menu #"; MenuSelected
IF MouseStatus AND RightDown THEN LOCATE 35, 1: PRINT "RIGHT MOUSE DOWN over Option #"; OptionSelected; " in Menu #"; MenuSelected
COLOR Purple
IF MouseStatus AND Hover THEN LOCATE 36, 1: PRINT "HOVERING over Option #"; OptionSelected; " in Menu #"; MenuSelected;
COLOR White
END IF
_LIMIT 30
_DISPLAY
LOOP
'And here goes the BM routines
SUB LinkMenus (handle1, handle2)
IF handle1 = 0 OR handle2 = 0 THEN ERROR 5: EXIT SUB
IF handle1 = handle2 THEN EXIT SUB 'Why the heck are we linking one list to itself?!
IF Menu(handle1).Valid AND Menu(handle2).Valid THEN
LinkMax = LinkedTo(0).one 'I'm using the very first entry into my array to store the number of link entries I have
'First check to see if the two menus are already linked
FOR i = 1 TO LinkMax
found = 0
IF handle1 = LinkedTo(i).one OR handle1 = LinkedTo(i).another THEN found = found + 1
IF handle2 = LinkedTo(i).one OR handle2 = LinkedTo(i).another THEN found = found + 1
IF found = 2 THEN EXIT SUB 'the two lists are already linked
IF handle1 = 0 AND handle2 = 0 AND openspot = 0 THEN openspot = i 'we found a spot where a link was freed before; let's use it
NEXT
MenuDisplaySort handle1, None: MenuDisplaySort handle2, None 'unsort the lists to begin with.
Menu(handle1).TopEntry = 1: Menu(handle2).TopEntry = 1 'and then reset them to their topmost position
IF openspot THEN
LinkedTo(openspot).one = handle1
LinkedTo(openspot).another = handle2
ELSE
LinkMax = LinkMax + 1: LinkedTo(0).one = LinkMax
LinkedTo(LinkMax).one = handle1
LinkedTo(LinkMax).another = handle2
END IF
ELSE
ERROR 5
END IF
END SUB
SUB UnLinkMenus (handle1, handle2)
IF handle1 = 0 OR handle2 = 0 THEN ERROR 5: EXIT SUB 'no list should be linked to 0. 0 is nothing... Can't free a link to nothing.
IF handle1 = handle2 THEN EXIT SUB 'We can't unlink a list from itself!
IF Menu(handle1).Valid AND Menu(handle2).Valid THEN
FOR i = 1 TO LinkedTo(0).one
IF handle1 = LinkedTo(i).one OR handle1 = LinkedTo(i).another THEN found = found + 1
IF handle2 = LinkedTo(i).one OR handle2 = LinkedTo(i).another THEN found = found + 1
IF found = 2 THEN LinkedTo(i).one = 0: LinkedTo(i).another = 0 'unlink them!
NEXT
ELSE
ERROR 5
END IF
END SUB
SUB DisableItem (handle, item)
IF Menu(handle).Valid THEN MenuListDisabled(item, handle) = -1 ELSE ERROR 5
END SUB
SUB EnableItem (handle, item)
IF Menu(handle).Valid THEN MenuListDisabled(item, handle) = 0 ELSE ERROR 5
END SUB
SUB ShowMenu (Handle)
IF Menu(Handle).Valid THEN Menu(Handle).Visible = -1 ELSE ERROR 5
END SUB
SUB HideMenu (Handle)
IF Menu(Handle).Valid THEN Menu(Handle).Visible = 0 ELSE ERROR 5
END SUB
SUB ShowMenuScrollBar (Handle)
IF Menu(Handle).Valid THEN Menu(Handle).ScrollBarHidden = 0 ELSE ERROR 5
END SUB
SUB HideMenuScrollBar (Handle)
IF Menu(Handle).Valid THEN Menu(Handle).ScrollBarHidden = -1 ELSE ERROR 5
END SUB
FUNCTION GetListItem$ (Handle, Item)
IF Menu(Handle).Valid THEN
IF Item < 0 OR Item > Menu(Handle).Entries THEN ERROR 5: EXIT FUNCTION
GetListItem$ = LTRIM$(RTRIM$(MenuList(Item, Handle)))
ELSE
ERROR 5
END IF
END FUNCTION
SUB AddMenuItem (Handle, Item$)
IF Menu(Handle).Valid THEN
Menu(Handle).Entries = Menu(Handle).Entries + 1
MenuList(Menu(Handle).Entries, Handle) = Item$
MenuDisplayOrder(Menu(Handle).Entries, Handle) = Menu(Handle).Entries
ELSE
ERROR 5
END IF
END SUB
SUB SetMenuListProperties (Handle, ListColor AS _UNSIGNED LONG, ListBackground AS _UNSIGNED LONG, ListJustify AS _BYTE)
IF Menu(Handle).Valid THEN
Menu(Handle).ListColor = ListColor
Menu(Handle).ListBackground = ListBackground
Menu(Handle).ListJustify = ListJustify
ELSE
ERROR 5
END IF
END SUB
SUB SetMenuHighLightColor (Handle, HighLightColor AS _UNSIGNED LONG)
IF Menu(Handle).Valid THEN
Menu(Handle).HighLightColor = HighLightColor
ELSE
ERROR 5
END IF
END SUB
SUB SetMenuCaption (Handle, Header, Caption AS STRING * 255, CaptionColor AS _UNSIGNED LONG, CaptionBackground AS _UNSIGNED LONG, Xit)
IF Menu(Handle).Valid THEN
Menu(Handle).Header = Header
Menu(Handle).Caption = Caption
Menu(Handle).CC = CaptionColor
Menu(Handle).CBG = CaptionBackground
Menu(Handle).Exit = Xit
ELSE
ERROR 5
END IF
END SUB
SUB SetMenuFrame (Handle, HaveFrame, FrameColor AS _UNSIGNED LONG, FrameBackGround AS _UNSIGNED LONG)
IF Menu(Handle).Valid THEN
Menu(Handle).Frame = HaveFrame
Menu(Handle).BorderColor = FrameColor
Menu(Handle).BackgroundColor = FrameBackGround
ELSE
ERROR 5
END IF
END SUB
SUB SetMenuPosition (Handle, Left, Top)
IF Menu(Handle).Valid THEN
'some basic error checking
IF Top < 0 THEN ERROR 5: EXIT SUB 'Let's try and keep the menu on the screen, why don't we
IF Left < 0 THEN ERROR 5: EXIT SUB
IF Left > _WIDTH THEN ERROR 5: EXIT SUB
IF Top > _HEIGHT THEN ERROR 5: EXIT SUB
Menu(Handle).Left = Left
Menu(Handle).Top = Top
ELSE
ERROR 5 'toss a generic error if the handle is bad
'I can add a custom error pop up routine later with appropiate messages
END IF
END SUB
SUB SetMenuVisible (Handle, Visible)
IF Menu(Handle).Valid THEN Menu(Handle).Visible = Visible ELSE ERROR 5
END SUB
SUB SetMenuSize (Handle, Width, Height)
IF Menu(Handle).Valid THEN
'some basic error checking
IF Width < _FONTWIDTH THEN ERROR 5: EXIT SUB 'Can't we at least make a menu which will hold a single character?!
IF Height < _FONTHEIGHT THEN ERROR 5: EXIT SUB
IF Width > _WIDTH THEN ERROR 5: EXIT SUB 'And let's not make it generally larger than our screen, why don't we?!
IF Height > _HEIGHT THEN ERROR 5: EXIT SUB
Menu(Handle).Width = Width
Menu(Handle).Height = Height
ELSE
ERROR 5 'toss a generic error if the handle is bad
'I can add a custom error pop up routine later with appropiate messages
END IF
END SUB
FUNCTION GetMenuHandle&
FOR i = 1 TO MenusActive
IF Menu(i).Valid = 0 THEN found = i: EXIT FOR
NEXT
IF NOT found THEN
MenusActive = MenusActive + 1
found = MenusActive
u = UBOUND(Menu)
DO UNTIL MenusActive < u
REDIM _PRESERVE Menu(u + 10) AS MenuType
REDIM _PRESERVE MenuList(32767, u + 10) AS STRING
REDIM _PRESERVE MenuDisplayOrder(32767, u + 10) AS INTEGER
REDIM _PRESERVE MenuListDisabled(32767, u + 10) AS _BYTE
u = UBOUND(Menu)
LOOP
END IF
GetMenuHandle& = found
Menu(found).Valid = -1 'and let's make this a valid handle
END FUNCTION
SUB CheckMenus (MouseStatus AS LONG, MenuSelected AS LONG, OptionSelected AS LONG)
MenuSelected = 0: OptionSelected = 0
FOR i = 1 TO MenusActive
IF Menu(i).Visible AND Menu(i).Valid THEN
IF startnum = 0 THEN startnum = i
ProcessMenu i, startnum, MouseStatus, MenuSelected, OptionSelected
IF MenuSelected THEN EXIT SUB
END IF
NEXT
END SUB
SUB DisplayMenus
FC = _DEFAULTCOLOR: BG = _BACKGROUNDCOLOR
FOR Whichone = 1 TO MenusActive
IF Menu(Whichone).Visible THEN
'Get the starting limits of where menu/list text can appear
x1 = Menu(Whichone).Left: x2 = x1 + Menu(Whichone).Width
y1 = Menu(Whichone).Top: y2 = Menu(Whichone).Top + Menu(Whichone).Height
caption$ = LTRIM$(RTRIM$(Menu(Whichone).Caption)) 'strip unneeded spaces from the caption (WhichOnef any)
'clear the background
LINE (Menu(Whichone).Left, Menu(Whichone).Top)-STEP(Menu(Whichone).Width, Menu(Whichone).Height), Menu(Whichone).BackgroundColor, BF
'draw the frame; adjust text limits
IF Menu(Whichone).Frame THEN
LINE (Menu(Whichone).Left, Menu(Whichone).Top)-STEP(Menu(Whichone).Width, Menu(Whichone).Height), Menu(Whichone).BorderColor, B
x1 = x1 + 1: y1 = y1 + 1
x2 = x2 - 1: y2 = y2 - 1
END IF
IF Menu(Whichone).Header THEN
temp = x2 - x1 + 1
LINE (x1, y1)-(x2, y1 + _FONTHEIGHT), Menu(Whichone).CBG, BF
IF Menu(Whichone).Exit THEN
temp = temp - _FONTWIDTH * 2
ex1 = x2 - 1 - _FONTWIDTH: ex2 = ex1 + _FONTWIDTH
ey1 = y1 + 1: ey2 = ey1 + _FONTHEIGHT - 3
LINE (ex1, ey1)-(ex2, ey2), Red, BF
LINE (ex1, ey1)-(ex2, ey2), Black
LINE (ex1, ey2)-(ex2, ey1), Black
END IF
DO UNTIL _PRINTWIDTH(caption$) <= temp
caption$ = LEFT$(caption$, LEN(caption$) - 1)
LOOP
COLOR Menu(Whichone).CC, Menu(Whichone).CBG
_PRINTSTRING (x1 + (temp - _PRINTWIDTH(caption$)) \ 2, y1), caption$
y1 = y1 + _FONTHEIGHT
IF Menu(Whichone).Frame THEN
LINE (x1, y1)-(x2, y1), Menu(Whichone).BorderColor
y1 = y1 + 2
END IF
END IF 'end header creation
IF Menu(Whichone).Entries > 0 THEN 'We have items in our list to display!
IF Menu(Whichone).TopEntry < 1 THEN Menu(Whichone).TopEntry = 1 'check to make certain we're displaying from the first entry on at least
IF Menu(Whichone).TopEntry > Menu(Whichone).Entries THEN Menu(Whichone).TopEntry = Menu(Whichone).Entries
printlimit = (x2 - x1 + 1) \ _FONTWIDTH
limitfound = 1 + (y2 - y1 + 1) \ _FONTHEIGHT - 1
IF limitfound > Menu(Whichone).Entries THEN
limitfound = Menu(Whichone).Entries
ELSE
scrollneeded = -1
printlimit = printlimit - 1
END IF
COLOR Menu(Whichone).ListColor, Menu(Whichone).ListBackground
IF Menu(Whichone).ScrollBarHidden = -1 THEN scrollneeded = 0
DIM r AS _UNSIGNED _BYTE, g AS _UNSIGNED _BYTE, b AS _UNSIGNED _BYTE
DIM CC AS INTEGER
r = _RED32(Menu(Whichone).BackgroundColor)
g = _GREEN32(Menu(Whichone).BackgroundColor)
b = _BLUE32(Menu(Whichone).BackgroundColor)
Fade& = _RGBA32(r, g, b, 180)
SELECT CASE Menu(Whichone).ListJustify
CASE Left
FOR j = 1 TO limitfound
CC = MenuDisplayOrder(Menu(Whichone).TopEntry + j - 1, Whichone) 'currentchoice
graybox = 0
t$ = RTRIM$(LTRIM$(MenuList(CC, Whichone)))
IF MenuListDisabled(CC, Whichone) THEN graybox = -1
FOR ii = 1 TO LinkedTo(0).one
IF Whichone = LinkedTo(ii).one AND MenuListDisabled(CC, LinkedTo(ii).another) THEN graybox = -1
IF Whichone = LinkedTo(ii).another AND MenuListDisabled(CC, LinkedTo(ii).one) THEN graybox = -1
NEXT
t$ = LEFT$(t$, printlimit)
_PRINTSTRING (x1, y1 + (j - 1) * _FONTHEIGHT), t$
IF graybox THEN LINE (x1, y1 + (j - 1) * _FONTHEIGHT)-(x2, y1 + (j) * _FONTHEIGHT), Fade&, BF
NEXT
CASE Right
FOR j = 1 TO limitfound
CC = MenuDisplayOrder(Menu(Whichone).TopEntry + j - 1, Whichone) 'currentchoice
graybox = 0
t$ = RTRIM$(LTRIM$(MenuList(MenuDisplayOrder(Menu(Whichone).TopEntry + j - 1, Whichone), Whichone)))
IF MenuListDisabled(CC, Whichone) THEN graybox = -1
FOR ii = 1 TO LinkedTo(0).one
IF Whichone = LinkedTo(ii).one AND MenuListDisabled(CC, LinkedTo(ii).another) THEN graybox = -1
IF Whichone = LinkedTo(ii).another AND MenuListDisabled(CC, LinkedTo(ii).one) THEN graybox = -1
NEXT
t$ = LTRIM$(LEFT$(t$, printlimit))
p = _PRINTWIDTH(t$)
IF scrollneeded THEN
_PRINTSTRING (x2 - p - _FONTWIDTH, y1 + (j - 1) * _FONTHEIGHT), t$
ELSE
_PRINTSTRING (x2 - p, y1 + (j - 1) * _FONTHEIGHT), t$
END IF
IF graybox THEN LINE (x1, y1 + (j - 1) * _FONTHEIGHT)-(x2, y1 + (j) * _FONTHEIGHT), Fade&, BF
NEXT
CASE Center
FOR j = 1 TO limitfound
CC = MenuDisplayOrder(Menu(Whichone).TopEntry + j - 1, Whichone) 'currentchoice
graybox = 0
t$ = LTRIM$(MenuList(MenuDisplayOrder(Menu(Whichone).TopEntry + j - 1, Whichone), Whichone))
IF MenuListDisabled(CC, Whichone) THEN graybox = -1
FOR ii = 1 TO LinkedTo(0).one
IF Whichone = LinkedTo(ii).one AND MenuListDisabled(CC, LinkedTo(ii).another) THEN graybox = -1
IF Whichone = LinkedTo(ii).another AND MenuListDisabled(CC, LinkedTo(ii).one) THEN graybox = -1
NEXT
t$ = LTRIM$(RTRIM$(LEFT$(t$, printlimit)))
p = _PRINTWIDTH(t$)
_PRINTSTRING ((x2 - x1 + 1) - p \ 2, y1 + (j - 1) * _FONTHEIGHT), t$
IF graybox THEN LINE (x1, y1 + (j - 1) * _FONTHEIGHT)-(x2, y1 + (j) * _FONTHEIGHT), Fade&, BF
NEXT
CASE ELSE
FOR j = 1 TO limitfound
CC = MenuDisplayOrder(Menu(Whichone).TopEntry + j - 1, Whichone) 'currentchoice
graybox = 0
t$ = RTRIM$(LTRIM$(MenuList(CC, Whichone)))
IF MenuListDisabled(CC, Whichone) THEN graybox = -1
FOR ii = 1 TO LinkedTo(0).one
IF Whichone = LinkedTo(ii).one AND MenuListDisabled(CC, LinkedTo(ii).another) THEN graybox = -1
IF Whichone = LinkedTo(ii).another AND MenuListDisabled(CC, LinkedTo(ii).one) THEN graybox = -1
NEXT
t$ = LEFT$(t$, printlimit)
_PRINTSTRING (x1, y1 + (j - 1) * _FONTHEIGHT), t$
IF graybox THEN LINE (x1, y1 + (j - 1) * _FONTHEIGHT)-(x2, y1 + (j) * _FONTHEIGHT), Fade&, BF
NEXT
Menu(Whichone).ListJustify = Left 'If it's not specified for some reason, let's make it left justified as default
END SELECT
END IF 'end of displaying items
IF scrollneeded THEN 'then we need a vertical scroll bar
barx1 = x2 - _FONTWIDTH - 1
barx2 = barx1 + _FONTWIDTH
LINE (barx1, y1)-(barx2, y2), LightGray, BF
COLOR Black, DarkGray
_PRINTSTRING (barx1, y1), ""
_PRINTSTRING (barx1, y2 - _FONTHEIGHT), ""
END IF
END IF
NEXT
COLOR FC, BG
END SUB
SUB ProcessMenu (WhichOne AS LONG, StartNum AS LONG, MouseStatus AS LONG, MenuSelected AS LONG, OptionSelected AS LONG)
STATIC OldMouse AS _BYTE, ElapsedTimer AS _FLOAT, Click AS _BYTE
STATIC ScrollAble AS _BYTE, OldMouse2 AS _BYTE, Click2 AS _BYTE
MX = _MOUSEX: MY = _MOUSEY: MB = _MOUSEBUTTON(1): MB2 = _MOUSEBUTTON(2)
IF ScrollDelay < 0 THEN ScrollDelay = 0
'Get the starting limits of where menu/list text can appear
x1 = Menu(WhichOne).Left: x2 = x1 + Menu(WhichOne).Width
y1 = Menu(WhichOne).Top: y2 = Menu(WhichOne).Top + Menu(WhichOne).Height
IF WhichOne = StartNum THEN
IF OldMouse = 0 AND MB = -1 THEN Click = -1 ELSE Click = 0
IF OldMouse2 = 0 AND MB2 = -1 THEN Click2 = -1 ELSE Click2 = 0
OldMouse = MB: OldMouse2 = MB2
IF ElapsedTimer + ScrollDelay < TIMER(0.01) THEN
ElapsedTimer = TIMER(0.01)
ScrollAble = -1
ELSE
ScrollAble = 0
END IF
END IF
IF Menu(WhichOne).Frame THEN
LINE (Menu(WhichOne).Left, Menu(WhichOne).Top)-STEP(Menu(WhichOne).Width, Menu(WhichOne).Height), Menu(WhichOne).BorderColor, B
x1 = x1 + 1: y1 = y1 + 1
x2 = x2 - 1: y2 = y2 - 1
END IF
IF Menu(WhichOne).Header THEN
temp = x2 - x1 + 1
IF Menu(WhichOne).Exit THEN
temp = temp - _FONTWIDTH * 2
ex1 = x2 - 1 - _FONTWIDTH: ex2 = ex1 + _FONTWIDTH
ey1 = y1 + 1: ey2 = ey1 + _FONTHEIGHT - 3
END IF
y1 = y1 + _FONTHEIGHT
IF Menu(WhichOne).Frame THEN y1 = y1 + 2
END IF 'end header creation
IF Menu(WhichOne).Entries > 0 THEN 'We have items in our list to display!
IF Menu(WhichOne).TopEntry < 1 THEN Menu(WhichOne).TopEntry = 1 'check to make certain we're displaying from the first entry on at least
IF Menu(WhichOne).TopEntry > Menu(WhichOne).Entries THEN Menu(WhichOne).TopEntry = Menu(WhichOne).Entries
printlimit = (x2 - x1 + 1) \ _FONTWIDTH
limitfound = 1 + (y2 - y1 + 1) \ _FONTHEIGHT - 1
IF limitfound > Menu(WhichOne).Entries THEN
limitfound = Menu(WhichOne).Entries
ELSE
scrollneeded = -1
printlimit = printlimit - 1
END IF
END IF 'end of displaying items
IF Menu(WhichOne).ScrollBarHidden = -1 THEN scrollneeded = 0
IF scrollneeded THEN 'then we need a vertical scroll bar
barx1 = x2 - _FONTWIDTH - 1
barx2 = barx1 + _FONTWIDTH
END IF
SELECT CASE MY 'let's determine which line we clicked the mouse on
CASE IS < ey1 'do nothing as it's too far up the screen to be a click in this box
CASE IS > y2 'do nothing again as it's too far down the screen to be a click in this box
CASE ey1 TO ey2 'we've clicked on the line where the EXIT button might exist
CASE y1 TO y2
END SELECT
SELECT CASE MY 'let's determine which line we clicked the mouse on
CASE IS < ey1 'do nothing as it's too far up the screen to be a click in this box
CASE IS > y2 'do nothing again as it's too far down the screen to be a click in this box
CASE ey1 TO ey2 'we've clicked on the line where the EXIT button might exist
IF Click AND Menu(WhichOne).Exit THEN
IF MX >= ex1 AND MX <= ex2 THEN Menu(WhichOne).Visible = False 'If the exit button is available, and we click it, it closes the menu/list
END IF
CASE y1 TO y2
done = 0
IF barx1 > 0 THEN p2 = barx1 - 1 ELSE p2 = x2
IF MX >= x1 AND MX <= p2 THEN 'highlight the choice the user is over
yPOS = ((MY - y1 + 1) \ _FONTHEIGHT) * _FONTHEIGHT + y1
IF yPOS + _FONTHEIGHT <= y2 THEN LINE (x1, yPOS)-(p2, yPOS + _FONTHEIGHT), Menu(WhichOne).HighLightColor, B
END IF
IF MouseScroll THEN
IF MX >= x1 AND MX <= x2 THEN
Menu(WhichOne).TopEntry = Menu(WhichOne).TopEntry + MouseScroll
IF Menu(WhichOne).TopEntry < 1 THEN Menu(WhichOne).TopEntry = 1
IF Menu(WhichOne).TopEntry > Menu(WhichOne).Entries - limitfound + 1 THEN Menu(WhichOne).TopEntry = Menu(WhichOne).Entries - limitfound + 1
FOR i = 1 TO LinkedTo(0).one
IF WhichOne = LinkedTo(i).one THEN Menu(LinkedTo(i).another).TopEntry = Menu(WhichOne).TopEntry
IF WhichOne = LinkedTo(i).another THEN Menu(LinkedTo(i).one).TopEntry = Menu(WhichOne).TopEntry
NEXT
END IF
END IF
IF scrollneeded THEN
IF MY >= y1 AND MY <= y1 + _FONTHEIGHT AND MX >= barx1 AND MX <= barx2 AND MB <> 0 THEN 'it's the top scroll bar
IF ScrollAble THEN Menu(WhichOne).TopEntry = Menu(WhichOne).TopEntry - 1
IF Menu(WhichOne).TopEntry < 1 THEN Menu(WhichOne).TopEntry = 1
done = -1
FOR i = 1 TO LinkedTo(0).one
IF WhichOne = LinkedTo(i).one THEN Menu(LinkedTo(i).another).TopEntry = Menu(WhichOne).TopEntry
IF WhichOne = LinkedTo(i).another THEN Menu(LinkedTo(i).one).TopEntry = Menu(WhichOne).TopEntry
NEXT
ELSEIF MY >= y2 - _FONTHEIGHT AND MY <= y2 AND MX >= barx1 AND MX <= barx2 AND MB <> 0 THEN 'it's the bottom scroll bar
IF ScrollAble THEN Menu(WhichOne).TopEntry = Menu(WhichOne).TopEntry + 1
IF Menu(WhichOne).TopEntry > Menu(WhichOne).Entries - limitfound + 1 THEN Menu(WhichOne).TopEntry = Menu(WhichOne).Entries - limitfound + 1
done = -1
FOR i = 1 TO LinkedTo(0).one
IF WhichOne = LinkedTo(i).one THEN Menu(LinkedTo(i).another).TopEntry = Menu(WhichOne).TopEntry
IF WhichOne = LinkedTo(i).another THEN Menu(LinkedTo(i).one).TopEntry = Menu(WhichOne).TopEntry
NEXT
ELSEIF MX >= barx1 AND MX <= barx2 AND MB <> 0 THEN
MenuLimit = Menu(WhichOne).Entries - limitfound + 2
ylimit = y2 - y1 - _FONTHEIGHT * 2 + 1
yPOS = MY - y1 - _FONTHEIGHT + 1
Menu(WhichOne).TopEntry = (MenuLimit - (ylimit - yPOS) / ylimit * MenuLimit)
IF Menu(WhichOne).TopEntry >= MenuLimit THEN Menu(WhichOne).TopEntry = MenuLimit - 1
done = -1
FOR i = 1 TO LinkedTo(0).one
IF WhichOne = LinkedTo(i).one THEN Menu(LinkedTo(i).another).TopEntry = Menu(WhichOne).TopEntry
IF WhichOne = LinkedTo(i).another THEN Menu(LinkedTo(i).one).TopEntry = Menu(WhichOne).TopEntry
NEXT
END IF
END IF
IF NOT done THEN 'if we've processed a scrollbar event, we're finished
IF MX >= x1 AND MX <= x2 THEN
MenuSelected = WhichOne
OptionSelected = MenuDisplayOrder((MY - y1 + 1) \ _FONTHEIGHT + Menu(WhichOne).TopEntry, WhichOne)
invalidate = 0
IF MenuListDisabled(OptionSelected, WhichOne) THEN invalidate = -1
FOR ii = 1 TO LinkedTo(0).one
IF WhichOne = LinkedTo(ii).one AND MenuListDisabled(OptionSelected, LinkedTo(ii).another) THEN invalidate = -1
IF WhichOne = LinkedTo(ii).another AND MenuListDisabled(OptionSelected, LinkedTo(ii).one) THEN invalidate = -1
NEXT
IF barx1 <> 0 AND MX > barx1 THEN invalidate = -1
IF invalidate THEN MenuSelected = 0: OptionSelected = 0
END IF
END IF
END SELECT
MouseStatus = 0
MouseStatus = MouseStatus OR -Click 'leftclick
MouseStatus = MouseStatus OR Click2 * -2 'rightclick
MouseStatus = MouseStatus OR _MOUSEBUTTON(1) * -4 'leftdown
MouseStatus = MouseStatus OR _MOUSEBUTTON(2) * -8 'rightdown
MouseStatus = MouseStatus OR (MenuSelected <> 0) * 16 'If we're over the menu, we're hovering
END SUB
SUB MenuDisplaySort (handle AS LONG, sortmethod AS _BYTE)
gap = Menu(handle).Entries
IF sortmethod AND Alpha THEN
IF sortmethod AND NoCase THEN
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
t$ = UCASE$(LTRIM$(RTRIM$(MenuList(MenuDisplayOrder(i, handle), handle))))
t1$ = UCASE$(LTRIM$(RTRIM$(MenuList(MenuDisplayOrder(i + gap, handle), handle))))
IF t$ > t1$ THEN
SWAP MenuDisplayOrder(i, handle), MenuDisplayOrder(i + gap, handle)
FOR ii = 1 TO LinkedTo(0).one
IF handle = LinkedTo(ii).one THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).another), MenuDisplayOrder(i + gap, LinkedTo(ii).another)
IF handle = LinkedTo(ii).another THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).one), MenuDisplayOrder(i + gap, LinkedTo(ii).one)
NEXT
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > Menu(handle).Entries
LOOP UNTIL gap = 1 AND swapped = 0
ELSE
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
t$ = LTRIM$(RTRIM$(MenuList(MenuDisplayOrder(i, handle), handle)))
t1$ = LTRIM$(RTRIM$(MenuList(MenuDisplayOrder(i + gap, handle), handle)))
IF t$ > t1$ THEN
SWAP MenuDisplayOrder(i, handle), MenuDisplayOrder(i + gap, handle)
FOR ii = 1 TO LinkedTo(0).one
IF handle = LinkedTo(ii).one THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).another), MenuDisplayOrder(i + gap, LinkedTo(ii).another)
IF handle = LinkedTo(ii).another THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).one), MenuDisplayOrder(i + gap, LinkedTo(ii).one)
NEXT
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > Menu(handle).Entries
LOOP UNTIL gap = 1 AND swapped = 0
END IF
IF sortmethod AND Reverse THEN
FOR i = 1 TO Menu(handle).Entries \ 2
SWAP MenuDisplayOrder(i, handle), MenuDisplayOrder(Menu(handle).Entries - i + 1, handle)
FOR ii = 1 TO LinkedTo(0).one
IF handle = LinkedTo(ii).one THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).another), MenuDisplayOrder(Menu(handle).Entries - i + 1, LinkedTo(ii).another)
IF handle = LinkedTo(ii).another THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).one), MenuDisplayOrder(Menu(handle).Entries - i + 1, LinkedTo(ii).one)
NEXT
NEXT
END IF
ELSEIF sortmethod AND Numeric THEN
DO
gap = 10 * gap \ 13
IF gap < 1 THEN gap = 1
i = 0
swapped = 0
DO
IF VAL(MenuList(MenuDisplayOrder(i, handle), handle)) > VAL(MenuList(MenuDisplayOrder(i + gap, handle), handle)) THEN
SWAP MenuDisplayOrder(i, handle), MenuDisplayOrder(i + gap, handle)
FOR ii = 1 TO LinkedTo(0).one
IF handle = LinkedTo(ii).one THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).another), MenuDisplayOrder(i + gap, LinkedTo(ii).another)
IF handle = LinkedTo(ii).another THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).one), MenuDisplayOrder(i + gap, LinkedTo(ii).one)
NEXT
swapped = -1
END IF
i = i + 1
LOOP UNTIL i + gap > Menu(handle).Entries
LOOP UNTIL gap = 1 AND swapped = 0
IF sortmethod AND Reverse THEN
FOR i = 1 TO Menu(handle).Entries \ 2
SWAP MenuDisplayOrder(i, handle), MenuDisplayOrder(Menu(handle).Entries - i + 1, handle)
FOR ii = 1 TO LinkedTo(0).one
IF handle = LinkedTo(ii).one THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).another), MenuDisplayOrder(Menu(handle).Entries - i + 1, LinkedTo(ii).another)
IF handle = LinkedTo(ii).another THEN SWAP MenuDisplayOrder(i, LinkedTo(ii).one), MenuDisplayOrder(Menu(handle).Entries - i + 1, LinkedTo(ii).one)
NEXT
NEXT
END IF
ELSE
FOR i = 1 TO Menu(handle).Entries
MenuDisplayOrder(i, handle) = i
FOR ii = 1 TO LinkedTo(0).one
IF handle = LinkedTo(ii).one THEN MenuDisplayOrder(i, LinkedTo(ii).another) = i
IF handle = LinkedTo(ii).another THEN MenuDisplayOrder(i, LinkedTo(ii).one) = i
NEXT
NEXT
END IF
END SUB
Here we can easily create a multiple lists of things. Link one list to another, if we want... Sort them. Select them. Hide them... Invalidate choices... It's a very powerful little library, and one which I plug into a lot of little things for when I need a menu of choices.
Sorting. Linking lists. Unlinking lists. Selecting things. Hiding lists. Restoring lists. Scrolling via the mouse wheel or in-built sliders. Hiding/showing sliders. Making selections unavailable, and restoring availability...
I'm doing another update for Ken's Artillery 2 using sliders for the power and angle. I got the sliders themselves working OK, but for some reason the computer keeps thinking the mouse button is pressed on each turn and after one turn, and then the computer, the computer takes over and shoots from your guy thinking you have pressed the mouse already. For a long time I've had some issues with the mouse commands and I'm not sure how to fix this. Any help is appreciated, thank you. I put comment lines where the code is at to help you. Also, I spent over 2 hours trying to fix this trying many different ways and loops, etc. No success, this is as best as I can get it so far. Is there a command to reset the _mousebutton (1) command? Because that's all I really need.
Code: (Select All)
'I've always wanted to make this game ever since I started programming in the 80's.
'This was created by Ken G. with much help from others below.
'Thank you to B+ for much of the math code.
'It takes the computer a little time to learn how to hit your base.
'Created on June 26, 2019.
'Version 2 made on April 30, 2022.
'Added: Levels, random colored mountains, and better looking cannons.
_Title "Ken's Artillery 2"
_Limit 200
Cls
Screen _NewImage(1200, 700, 32)
Print " Ken's Artillery 2"
Print: Print: Print
Print " By SierraKen with math help from B+."
Print: Print: Print
Print " Instructions: You play against the computer by shooting a cannonball"
Print " from your cannon at your base on the left side of the screen"
Print " to the computer's base on the right side of the screen."
Print " To do this, you type a power number between 0 and 80 and press Enter."
Print " Then you type an angle that the cannonball will travel at,"
Print " between 0 and 90 and press Enter."
Print " You get a point every time you hit the other base."
Print " If you hit the enemy 5 times you advance to the next mountain."
Print " If the enemy hits you 5 times in one mountain, you lose."
Print " Watch the wind speed indicator up on top to see the direction and"
Print " speed of the wind, which makes a big difference on where your"
Print " cannonball will land. Also, there will be a random sized mountain"
Print " and color for every level and game."
Print: Print: Print
Input " Press Enter to begin.", start$
Cls
level = 1
start:
c = 0
mountain = 0
win = 0
compoints = 0
points = 0
ground = 590 'up is negative in direction
'Your Cannon
cbx = 10 ' cannon butt end x, y
cby = ground - 20
cmx = 50 ' cannon mouth end
cmy = ground - 70
'Computer's Cannon
cbx2 = 1190
cby2 = cby
cmx2 = 1150
cmy2 = cmy
g = .15 ' with air resistance
Randomize Timer
air = Int(Rnd * 20)
air2 = air / 1000
Randomize Timer
air3 = Int(Rnd * 100)
If air3 > 50 Then air2 = -air2
airX = air2
Color , _RGB32(156, 210, 237)
Cls
'Bases
Line (cbx, ground)-(cbx + 100, ground - 20), _RGB32(4, 4, 4), BF
Line (cbx2, ground)-(cbx2 - 100, ground - 20), _RGB32(4, 4, 4), BF
'Mountain
Randomize Timer
sz = Int(Rnd * 300) + 100
circx = 595
cl1 = Int(Rnd * 55) + 50
cl2 = Int(Rnd * 55) + 50
cl3 = Int(Rnd * 55) + 50
Line (0, ground)-(1200, 700), _RGB32(cl1, cl2, cl3), BF 'ground
Circle (circx, ground), sz, _RGB32(cl1, cl2, cl3)
Paint (circx, ground - 2), _RGB32(cl1, cl2, cl3)
again:
Color _RGB(0, 0, 0)
Locate 10, 136: Print " "
Locate 10, 2: Print "Your Turn "
Randomize Timer
air = Int(Rnd * 20)
air2 = air / 1000
Randomize Timer
air3 = Int(Rnd * 100)
If air3 > 50 Then air2 = -air2
airX = air2
airx2 = airX * 1000
If airx2 < -1 Then winddir$ = "West"
If airx2 > 1 Then winddir$ = "East"
If airx2 > -1 And airx2 < 1 Then winddir$ = "Sunny"
If airx2 < 0 Then airx2 = airx2 * -1
GoSub Wind:
_PrintString (5, 50), "Power"
_PrintString (5, 80), "Angle"
Line (60, 40)-(260, 70), _RGB32(255, 255, 255), B
Line (60, 70)-(260, 100), _RGB32(255, 255, 255), B
Line (60, 100)-(120, 130), _RGB32(255, 0, 5), BF
Color _RGB32(0, 0, 0), _RGB32(255, 0, 5)
_PrintString (70, 110), "Fire!"
vel = 40
vel2 = 100
a = 45
a2 = 100
Line (61, 41)-(vel2, 69), _RGB32(255, 0, 1), BF
Line (61, 71)-(a2, 99), _RGB32(0, 255, 1), BF
'This is the part that I can't fix --------------------------------------------------------
go:
Do While _MouseInput
If Point(_MouseX, _MouseY) = _RGB32(255, 0, 1) And _MouseButton(1) = -1 Then
vel2 = _MouseX + 5
If vel2 > 259 Then vel2 = 259
Line (61, 41)-(259, 69), _RGB32(156, 210, 237), BF
Line (61, 41)-(vel2, 69), _RGB32(255, 0, 1), BF
vel = Int(vel2 / 4)
vel$ = Str$(vel)
Color _RGB32(0, 0, 0), _RGB32(255, 0, 0)
_PrintString (265, 50), vel$
_Display
End If
If Point(_MouseX, _MouseY) = _RGB32(0, 255, 1) And _MouseButton(1) = -1 Then
a2 = _MouseX + 5
If a2 > 259 Then a2 = 259
Line (61, 71)-(259, 99), _RGB32(156, 210, 237), BF
Line (61, 71)-(a2, 99), _RGB32(0, 255, 1), BF
a = Int(a2 / 3)
aaa$ = Str$(a)
Color _RGB32(0, 0, 0), _RGB32(0, 255, 0)
_PrintString (265, 80), aaa$
_Display
End If
If Point(_MouseX, _MouseY) = _RGB32(255, 0, 5) And _MouseButton(1) = -1 Then
GoTo going:
Else
GoTo go:
End If
Loop
Line (61, 41)-(vel2, 69), _RGB32(255, 0, 1), BF
Line (61, 71)-(a2, 99), _RGB32(0, 255, 1), BF
GoTo go:
'--------------------------------------------------------------------------------------------
going:
Color _RGB32(0, 0, 0), _RGB32(156, 210, 237)
If a > 90 Then a = 90
If a < 0 Then a = 0
If vel < 0 Then vel = 0
If vel > 80 Then vel = 80
vel = Int(vel / 4)
a = 360 - a
ca = _D2R(a)
cmx = cbx + (100 * Cos(_D2R(a)))
cmy = cby + (100 * Sin(_D2R(a)))
'initialize
bx = cmx 'ball x, y same as cannon mouth at start of shot
by = cmy
dx = vel * Cos(ca) 'start at cannon mouth
dy = vel * Sin(ca)
'shot
Do
_Limit 200
GoSub Wind:
a$ = InKey$
If a$ = Chr$(27) Then End
Circle (bx, by), 5, _RGB32(0, 0, 0)
Paint (bx, by), _RGB32(0, 0, 0), _RGB32(0, 0, 0)
For ccc = 0 To 7 Step .1
Line (cbx, cby)-(cmx + ccc, cmy), _RGB32(150, 50, 0) 'cannon line
Next ccc
oldbx = bx: oldby = by
dx = dx + airX
dy = dy + g
bx = bx + dx
by = by + dy
_Display
_Limit 30
Circle (oldbx, oldby), 5, _RGB(156, 210, 237)
Paint (oldbx, oldby), _RGB(156, 210, 237)
If Point(bx, by) = _RGB32(cl1, cl2, cl3) Then
mountain = 1
For explosion = 0 To 20 Step .5
Circle (bx, by), explosion, _RGB32(156, 210, 237)
Sound 100 + explosion, .25
Next explosion
End If
If bx > cbx2 - 120 And bx < cbx2 + 20 And by >= ground - 2 Then
points = points + 1
win = 0
Locate 3, 64: Print "You: "; points; " Computer: "; compoints
For explosion = 0 To 20 Step .5
Circle (bx, by), explosion, _RGB32(156, 210, 237)
Sound 100 + explosion, .25
Next explosion
For sndd = 500 To 700 Step 50
Sound sndd, 1
Next sndd
mountain = 1
If points = 5 And win = 0 Then win = 1: level = level + 1: GoTo start:
End If
Loop Until mountain = 1 Or by > 700
For ccc = 0 To 7 Step .1
Line (cbx, cby)-(cmx + ccc, cmy), _RGB32(156, 210, 237) 'delete cannon line
Next ccc
mountain = 0
'The Computer's Turn
If c = 0 Then GoTo nex:
'Last shot was too far away.
If oldbx2 < cbx Then
vel2 = oldvel2 - 1
If vel2 < 8 Then vel2 = 8
End If
'Last shot wasn't far enough.
If oldbx2 > cbx Then
vel2 = oldvel2 + 1
If vel2 > 15 Then vel2 = 15
End If
nex:
c = 1
ca2 = _D2R(a2)
cmx2 = cbx2 - (100 * Cos(_D2R(a2)))
cmy2 = cby2 + (100 * Sin(_D2R(a2)))
'initialize
bx2 = cmx2 'ball x, y same as cannon mouth at start of shot
by2 = cmy2
dx2 = vel2 * Cos(ca2) 'start at cannon mouth
dy2 = vel2 * Sin(ca2)
'shot
Do
_Limit 200
a$ = InKey$
If a$ = Chr$(27) Then End
Circle (bx2, by2), 5, _RGB32(0, 0, 0)
Paint (bx2, by2), _RGB32(0, 0, 0), _RGB32(0, 0, 0)
For ccc = 0 To 7 Step .1
Line (cbx2, cby2)-(cmx2 - ccc, cmy2), _RGB32(150, 50, 0) 'cannon line
Next ccc
oldbx2 = bx2: oldby2 = by2
dx2 = dx2 + airX
dy2 = dy2 + g
bx2 = bx2 - dx2
by2 = by2 + dy2
_Display
_Limit 30
Circle (oldbx2, oldby2), 5, _RGB(156, 210, 237)
Paint (oldbx2, oldby2), _RGB(156, 210, 237)
If Point(bx2, by2) = _RGB32(cl1, cl2, cl3) Then
mountain = 1
For explosion = 0 To 20 Step .5
Circle (bx2, by2), explosion, _RGB32(156, 210, 237)
Sound 100 + explosion, .25
Next explosion
End If
If bx2 > cbx - 20 And bx2 < cbx + 120 And by2 >= ground Then
compoints = compoints + 1
Locate 3, 64: Print "You: "; points; " Computer: "; compoints
For explosion = 0 To 20 Step .5
Circle (bx2, by2), explosion, _RGB32(156, 210, 237)
Sound 100 + explosion, .25
Next explosion
For sndd = 500 To 700 Step 50
Sound sndd, 1
Next sndd
mountain = 1
If compoints = 5 Then Color _RGB(0, 0, 0): Locate 20, 65: Print "COMPUTER WINS!": GoTo asking:
End If
Loop Until mountain = 1 Or by2 > 700
For ccc = 0 To 7 Step .1
Line (cbx2, cby2)-(cmx2 - ccc, cmy2), _RGB32(156, 210, 237) 'delete cannon line
Next ccc
mountain = 0
GoTo again:
'This code is used in a few different places in the program.
Wind:
Color _RGB(0, 0, 0)
Locate 1, 73: Print "Wind"
If winddir$ = "West" Then
Locate 2, 82: Print " "
Locate 2, 59: Print airx2; " mph "
End If
If winddir$ = "East" Then
Locate 2, 59: Print " "
Locate 2, 82: Print airx2; " mph "
End If
Locate 2, 68: Print "West <-> East"
Locate 3, 64: Print "You: "; points; " Computer: "; compoints
Locate 4, 71: Print "Level: "; level
Return
asking:
Locate 22, 65: Input "Again? (Yes/No):", ag$
If ag$ = "y" Or ag$ = "Y" Or ag$ = "yes" Or ag$ = "Yes" Or ag$ = "YES" Or ag$ = "yES" Or ag$ = "yeS" Then points = 0: level = 1: GoTo start:
End
One way to break down the logic of IMP is to remember with A IMP B:
Your result is *always* going to have all the bits of B set…
For example, let’s assume A and B are both _UNSIGNED _BYTEs.
Now if B =3, the result of A IMP B will be = ??????11, depending on A to fill in the ? And if B = 5, the result of A IMP B will be = ?????1?1, depending on A to fill in the ?
*Whatever* the final result is, it’s going to have every bit set that B already has set.
And, with that half of the process solved, it’s *also* going to set any bits that A *DOES NOT* have set.
A = 2. B = 3.
In binary, those are: A = 00000010 B = 00000011
A IMP B is solved by first setting all the bits in the answer to match B: ??????11 Then we toggle all the bits in A: 11111101. And we set the ones that are on, for our answer: 11111111
2 IMP 3 = 255
(NOT A) OR B
That’s the breakdown of what IMP is doing.
(NOT A) says the result is going to have all the bits set that A does NOT have. OR B says our result is *also* going to have all the bits set that B does.
A IMP B = (NOT A) OR B
Really, that’s all there is to it. It’s convoluted, and not really something I think most folks ever really need, but that’s all the does in a nutshell.
Two programs here which might be useful for someone who needs to access data from a DBF file for use inside a QB64 program.
First, we have a simple program to change DBF files to CSV (Comma Separated Value) Text files:
Code: (Select All)
'DBF to CSV text converter
'Program written by Steve McNeill @ 9/19/2012
'Code is free to use, abuse, modify, destroy, steal, copy, share, and alter in any way anyone wishes.
'Just be aware, I'm not responsible if it melts your computer, fries your brain, or makes you sing like a drunken sailor.
'Use is purely at your own risk, but it seems safe enough to me!
'All this does is convert old dbf files into a simple CSV text file, which can then be read into any program which you wish to use the data with.
'Your old files stay as they are, and it does nothing to them except read them and then give you a new, converted file to work with.
'change file$ and file1$ to the name of your DBF and new converted filename, respectively.
'No credit, cash, check, or money order needed for this. Enjoy!!
REM $DYNAMIC
TYPE DBF_Header
FileType AS _UNSIGNED _BYTE
Year AS _UNSIGNED _BYTE
Month AS _UNSIGNED _BYTE
Day AS _UNSIGNED _BYTE
RecordNumber AS _UNSIGNED LONG
FirstRecord AS _UNSIGNED INTEGER
RecordLength AS _UNSIGNED INTEGER
ReservedJunk AS STRING * 16
TableFlag AS _UNSIGNED _BYTE
CodePageMark AS _UNSIGNED _BYTE
ReservedJunk1 AS STRING * 2
END TYPE
TYPE Field_Subrecord
FieldName AS STRING * 11
FieldType AS STRING * 1
Displacement AS _UNSIGNED LONG
FieldLength AS _UNSIGNED _BYTE
FieldDecimal AS _UNSIGNED _BYTE
FieldFlags AS _UNSIGNED _BYTE
AutoNext AS _UNSIGNED LONG
AutoStep AS _UNSIGNED _BYTE
ReservedJunk AS STRING * 8
END TYPE
TYPE DBF_HeaderTerminator
EndCode AS _UNSIGNED _BYTE 'Our End of Field Code is a CHR$(13), or 13 if we read it as a byte
END TYPE
TYPE DBF_VFPInfo
Info AS STRING * 263
END TYPE
DIM DataH AS DBF_Header
DIM DataFS(1) AS Field_Subrecord
DIM DataHT AS DBF_HeaderTerminator
DIM DataVFP AS DBF_VFPInfo
Get_Header file$, DataH
'Display_Header DataH
Get_Fields file$, DataFS()
'Display_Fields DataFS()
Print_Data file$, DataH, DataFS(), file2$
PRINT "Your file has been converted."
PRINT "The original file was: "; file$
PRINT "The converted file is: "; file2$
END
SUB Display_Header (DataH AS DBF_Header)
PRINT "Data File Type: ";
SELECT CASE DataH.FileType
CASE 2: PRINT "FoxBASE"
CASE 3: PRINT "FoxBASE+/Dbase III plus, no memo"
CASE 48: PRINT "Visual FoxPro"
CASE 49: PRINT "Visual FoxPro, autoincrement enabled"
CASE 50: PRINT "Visual FoxPro with field type Varchar or Varbinary"
CASE 67: PRINT "dBASE IV SQL table files, no memo"
CASE 99: PRINT "dBASE IV SQL system files, no memo"
CASE 131: PRINT "FoxBASE+/dBASE III PLUS, with memo"
CASE 139: PRINT "dBASE IV with memo"
CASE 203: PRINT "dBASE IV SQL table files, with memo"
CASE 229: PRINT "HiPer-Six format with SMT memo file"
CASE 245: PRINT "FoxPro 2.x (or earlier) with memo"
CASE 251: PRINT "FoxBASE"
CASE ELSE: PRINT "Unknown File Type"
END SELECT
PRINT "Date: "; DataH.Month; "/"; DataH.Day; "/"; DataH.Year
PRINT "Number of Records: "; DataH.RecordNumber
PRINT "First Record: "; DataH.FirstRecord
PRINT "Record Length: "; DataH.RecordLength
PRINT "Reserved Junk: "; DataH.ReservedJunk
PRINT "Table Flags: ";
none = 0
IF DataH.TableFlag AND 1 THEN PRINT "file has a structural .cdx ";: none = -1
IF DataH.TableFlag AND 2 THEN PRINT "file has a Memo field ";: none = -1
IF DataH.TableFlag AND 4 THEN PRINT "file is a database (.dbc) ";: none = -1
IF none THEN PRINT ELSE PRINT "None"
PRINT "Code Page Mark: "; DataH.CodePageMark
PRINT "Reserved Junk: "; DataH.ReservedJunk1
END SUB
SUB Display_Fields (DataH() AS Field_Subrecord)
FOR r = 1 TO UBOUND(DataH)
PRINT "Field Name :"; DataH(r).FieldName
PRINT "Field Type :"; DataH(r).FieldType
PRINT "Field Displacement :"; DataH(r).Displacement
PRINT "Field Length :"; DataH(r).FieldLength
PRINT "Field Decimal :"; DataH(r).FieldDecimal
PRINT "Field Flags :"; DataH(r).FieldFlags
PRINT "Field AutoNext :"; DataH(r).AutoNext
PRINT "Field SutoStep :"; DataH(r).AutoStep
PRINT "Field Reserved Junk :"; DataH(r).ReservedJunk
SLEEP
PRINT "**************************"
NEXT
END SUB
SUB Get_Header (file$, DataH AS DBF_Header)
OPEN file$ FOR BINARY AS #1 LEN = LEN(DataH)
GET #1, 1, DataH
CLOSE
END SUB
SUB Get_Fields (file$, DataH() AS Field_Subrecord)
DIM databyte AS _UNSIGNED _BYTE
DIM temp AS Field_Subrecord
OPEN file$ FOR BINARY AS #1 LEN = 1
counter = -1: s = 33
DO
counter = counter + 1
GET #1, s, databyte
s = s + 32
LOOP UNTIL databyte = 13
REDIM DataH(counter) AS Field_Subrecord
IF counter < 1 THEN BEEP: BEEP: PRINT "Database has no file records.": END
CLOSE
OPEN file$ FOR BINARY AS #1 LEN = 32
FOR r = 1 TO counter
GET #1, 32 * r + 1, DataH(r) 'record 1 is our header info, so we need to start our field info at record 2
NEXT
CLOSE
END SUB
SUB Print_Data (file$, DataH AS DBF_Header, DataFS() AS Field_Subrecord, file2$)
DIM databyte AS _UNSIGNED _BYTE
OPEN file$ FOR BINARY AS #1
OPEN file2$ FOR OUTPUT AS #2
SEEK #1, DataH.FirstRecord + 1
DO
GET #1, , databyte 'This is the first byte which tells us if the record is good, or has been deleted.
IF databyte = 32 THEN WRITE #2, "Good Record", ELSE WRITE #2, "Deleted Record",
FOR i = 1 TO UBOUND(DataFS)
SELECT CASE DataFS(i).FieldType
CASE "C", "0"
'C is for Characters, or basically STRING characters.
'0 is for Null Flags, which I have no clue what they're for. I'm basically reading them here as worthless characters until I learn otherwise.
temp$ = ""
FOR j = 1 TO DataFS(i).FieldLength
GET #1, , databyte
temp$ = temp$ + CHR$(databyte)
NEXT
CASE "Y"
'Y is for currency, which is an _INTEGER 64, with an implied 4 spaces for decimal built in.
REDIM temp AS _INTEGER64
GET #1, , temp
temp$ = STR$(temp)
l = LEN(temp$)
temp$ = LEFT$(temp$, l - 4) + "." + RIGHT$(temp$, 4)
CASE "N", "F", "M", "G"
'N is for numberic, F is for Floating numbers, and both seem to work in the same manner.
'M is for Memo's, which are stored in a different DBT file. What we have here is the block number of the memo location in that file, stored as a simple set of characters.
'G is for OLE files. We store the info for it just the same as we do for a Memo.
'we read the whole thing as a string, which is an odd way for dBase to write it, but I don't make the rules. I just convert them!
temp$ = ""
FOR j = 1 TO DataFS(i).FieldLength
GET #1, , databyte
temp$ = temp$ + CHR$(databyte)
NEXT
CASE "D"
'D is for Date fields.
'Dates are stored as a string, in the format YYYYMMDD
temp$ = ""
FOR j = 1 TO DataFS(i).FieldLength
GET #1, , databyte
temp$ = temp$ + CHR$(databyte)
NEXT
year$ = LEFT$(temp$, 4)
month$ = MID$(temp$, 5, 2)
day$ = RIGHT$(temp$, 2)
temp$ = day$ + "/" + month$ + "/" + year$
CASE "L"
'L is our logical operator. Basically, it's simply True or False Boolean logic
GET #1, , databyte
IF databyte = 32 THEN temp$ = "True" ELSE temp$ = "false"
CASE "@", "O"
'@ are Timestamps, which I'm too lazy to fully support at the moment.
'They are 8 bytes - two longs, first for date, second for time.
'The date is the number of days since 01/01/4713 BC.
'Time is hours * 3600000L + minutes * 60000L + Seconds * 1000L
'All I'm going to do is read both longs as a single _Integer64 and then write that data to the disk.
'Be certain to convert it as needed to make use of the Timestamp.
'I'm just lazy and don't wanna convert anything right now! :P
'O are double long integers -- basically Integer 64s. Since I'm reading a timestamp as an Int64, this routine works for them as well.
REDIM temp1 AS _INTEGER64
GET #1, , temp1
temp$ = STR$(temp1)
CASE "I", "+"
'Long Integers. Basically 4 byte numbers
'+ are auto-increments. Stored the same way as a Long.
REDIM temp2 AS LONG
GET #1, , temp2
temp$ = STR$(temp2)
END SELECT
IF i = UBOUND(datafs) THEN WRITE #2, temp$ ELSE WRITE #2, temp$,
NEXT
LOOP UNTIL EOF(1)
CLOSE
END SUB
Useage here is simple: 1) Download the file below and put it in your QB64 folder (and extract it)
2) copy and paste the code above into your QB64 IDE.
3) compile and run 4) Enjoy looking at the "converted.txt" file which we created in that same folder, which now has all the DATA in that DBF file converted over to CSV TXT for ease of use in QB64 (or any other program which you might need it for).
