Reason for request:
Recent compilation of the Linux version of qp64pe forces all cpus to run - for a Xeon box, but not for an i7-7500U box. This occurs for identical versions of Linux Mint (both 21.3 and 22 versions).
This did not occur on the ISE release around a year ago - also Linux Mint OS.
Is there a specific statement in the IDE that forces/allow all cpus to be engaged?
I was playing with Steve's code about multiscreen using TCP/IP ... but I have no informations about this field of programming, so I am also in learning mode...
where I can get more informations about the use of TCP/IP used in localhost mode?
I have read WIKI and its code examples ....
but how many clients can I connect to a localhost?
I have found no answer to this my dubt.
The program only ever works once. Then one have to delete the exe file, otherwise it will always just show "unknown". Even deleting the program and using a different name didn't help. Does anyone know what could be wrong? Thanks!
I think I've had a similar case before, but I can't remember how I solved the problem.
Code: (Select All)
'Codenummer der gedrueckten Taste ermitteln - 30. Juli 2024
Option _Explicit
Dim As Integer x
Print "Taste"
_Delay 2
x = _KeyHit
If x = 32 Then
Print "Leertaste "; x
ElseIf x = 27 Then
Print "Esc-Taste "; x
Else
Print "Unbekannt"
End If
Here is my Editor project kind of stalled out for awhile. It is 820 LOC and has allot of standard features QB64 has including Cut, Copy and Paste. This is working condition before I attempted to add horizontal scrolling so that part is not working like QB64 yet. You have 100 chars wide plus?... screening.
You should have entire menu with one right click but F2 button not added yet. It pastes the entire file you are working on into the Clipboard to paste where-ever you want. So this thing should not need instructions to use, if it does I'd like to know. The menu lists the shortcut buttons with it's function.
' Screen, colors, font
Dim Shared As Long XMax: XMax = 1200 '109 chars wide minus 6 space for line numbers 100 chars
Dim Shared As Long YMax: YMax = 700 ' 30 chars high (600) + 100 pixels = 5 rows for Editor stuff
Screen _NewImage(XMax, YMax, 32): _ScreenMove 40, 35
Dim Shared As _Unsigned Long FG, BG, EFG, EBG: ColorTheme 1 ' Forest color theme
Dim Shared As Long Fnt, FW, FH: Fnt = _LoadFont("lucon.ttf", 18, "MONOSPACE") ' add font to folder
If Fnt <= 0 Then Print "Font failed to load, goodbye!": _Delay 5: System
_Font Fnt: FH = _FontHeight: FW = _FontWidth 'FW=11, FH=18 use 20 for row height, cursor fits below
' cursor on screen area
Dim Shared As Long MinCol: MinCol = 7 ' on left is 5 digits and space for line numbers
Dim Shared As Long MaxCol: MaxCol = 109 ' 109 no minus 6 for line numbers but text starts on col 7
Dim Shared As Long MaxRow: MaxRow = 30 ' 30 rows * 20
' for display, track the array index for top row of screen
Dim Shared As Long VsScreenTop: VsScreenTop = 1
Dim Shared As Long VsUB, VsIndex, VsCol ' <<< only set or updated in CheckShared
Dim Shared VsTail$, VsHead$ ' CheckShared but Backspace sets VsHead$ too
ReDim Shared VS$(1 To 1) ' VS$ Variable String main work array
' cursor
Dim Shared As Long CCol, CRow ' the cursor position on screen and actual text is 7 char position
'track selected text and highlighting it
Dim Shared As Long Shift ' Shared?? used in CheckShift sub, one line could be added back in main
Dim Shared As Long SelRow, SelCol ' these anchor the one point in text for cursor in any direction
' work file
Dim Shared Filename$ ' the working filename "untitled" no extension until SaveIt called
Dim Shared As Long NeedsSaving: NeedsSaving = 0 ' track whether the work needs to be saved
' search and change
Dim Shared Find$, CaseSense As Long, Change$, findR As Long, findC As Long
' locals
Dim As Long kh, ctrl, alt, b1, b2 ' key variables and booleans
Dim As Long scroll, mdx, mdy, mx, my, mb, mdFlag, saveTOP ' mouse and flags for mouse functions
Dim As Long saveMdx, saveMdy, saveMx, saveMy ' detecting pixel moves of mouse to select single char
Dim s$ ' to shorten super long code lines because of text ie messagebox text
FLoad
Do 'main interface loop
CheckShared ' the one and only place where all the Vs... Variables are set Except VsTopScreen!
Show ' replace CLS now draws cursor and _displays from sub
_Limit 60 'easy on the cpu?
kh = _KeyHit
Shift = _KeyDown(100304) Or _KeyDown(100303)
ctrl = _KeyDown(100306) Or _KeyDown(100305)
alt = _KeyDown(100308) Or _KeyDown(100307)
Do While _MouseInput ' scrolling just like an up or down arrow
scroll = _MouseWheel
If scroll = -1 Then 'up
CRow = 1 ' faster scrolling
kh = 18432
ElseIf scroll = 1 Then 'down
If VsScreenTop + 30 - 1 > VsUB Then CRow = VsUB - VsScreenTop + 1 Else CRow = 30
kh = 20480
End If
Loop
' MouseButton down and drag set MouseDown x, y for select anchor
'
' Yea! Finally this will highlite up and down screen by dragging mouse!
' Saved EDIT VSLA 2023-11-24 ***
'
mdFlag = 0: saveMdx = _MouseX: saveMdy = _MouseY ' get precise pixels for later
mdx = saveMdx \ FW + 1: mdy = saveMdy \ 20 + 1: mb = _MouseButton(1)
If mb And ((mdx >= MinCol) And ((mdx <= MaxCol) And (mdy <= MaxCol))) Then
SelRow = VsScreenTop + mdy - 1: SelCol = mdx - 6
mdFlag = 1: saveTOP = VsScreenTop ' this is for just a click? code
'Beep ' should only be once at mouse down OK
Do
While _MouseInput: Wend
saveMx = _MouseX: saveMy = _MouseY
mx = saveMx \ FW + 1: my = saveMy \ 20 + 1: mb = _MouseButton(1)
If ((mx >= MinCol) And (mx <= MaxCol)) And (mb And (my <= MaxRow)) Then
If (saveMy < 4) And ((mx >= MinCol) And (mx <= MaxCol)) Then 'scroll up
If VsScreenTop > 1 Then VsScreenTop = VsScreenTop - 1: _Delay .1
ElseIf (saveMy > 596) And ((mx >= MinCol) And (mx <= MaxCol)) Then 'scroll down?
If VsScreenTop < VsUB Then VsScreenTop = VsScreenTop + 1: _Delay .1
End If
CRow = my: CCol = mx
If CRow + VsScreenTop - 1 > VsUB Then CRow = VsUB - VsScreenTop + 1
Show
End If
Loop Until mb = 0
End If
If mdFlag Then ' was it just a click? Just the slightest drag is needed to select 1 char
b1 = Abs(saveMdx - saveMx) < 2: b2 = Abs(saveMdy - saveMy) < 2
If (b1 And b2) And (VsScreenTop = saveTOP) Then
SelRow = 0: SelCol = 0 ' yes just a click else select single char
End If
End If
Select Case kh
Case 96 And ctrl And Shift ' this is dummy thing because have really wierd error
Case 18176 And ctrl And Shift ' ctrl + shift + home
SelRow = VsScreenTop + CRow - 1: CCol = Len(VS$(SelRow)) + 6
VsScreenTop = 1: CRow = 1: CCol = 7
Case 20224 And ctrl And Shift ' ctrl + shift + end
SelRow = VsScreenTop + CRow - 1: CCol = 7
VsScreenTop = VsUB: CRow = 1: CCol = Len(VS$(VsUB)) + 6
Case 96 And ctrl ' tic + ctrl this is dummy thing because have really wierd error
Case 120 And ctrl: CopySelected: DeleteSelected: NeedsSaving = -1 ' ctrl and x cut
Case 99 And ctrl: CopySelected ' 11/25 fix changing CRow ' ctrl and c copy
Case 118 And ctrl: Paste: NeedsSaving = -1 ' ctrl and V paste
Case 110 And ctrl: New ' ctrl and N new file stuff
Case 111 And ctrl: FLoad ' ctrl and O open
Case 115 And ctrl: SaveIt ' ctrl and S Save
Case 97 And ctrl: SaveAsName ' ctrl and A Save As
Case 15616 And ctrl: FindWhat 1: FindNext 0 ' ctrl + F3 is Find...
Case 15616 And Shift: FindNext -1
Case 18176 And ctrl: VsScreenTop = 1: CRow = 1: CCol = 7 ' ctrl+home
Case 20224 And ctrl: VsScreenTop = VsUB: CRow = 1: CCol = Len(VS$(VsUB)) + 6 ' ctrl+end
Case 15616 And alt: ChangeToWhat 0 ' alt + F3
Case 21248 ' delete above my backspace keyboard
If SelRow Then
DeleteSelected
ElseIf VsTail$ = "" Then
VS$(VsIndex) = VsHead$ + VS$(VsIndex + 1)
DynArr_Delete VsIndex + 1, VS$()
Else
VS$(VsIndex) = VsHead$ + Right$(VsTail$, Len(VsTail$) - 1)
End If
NeedsSaving = -1: SelRow = 0
Case 8 ' backspace drag text at the cursor
If SelRow Then DeleteSelected
If CCol > 7 Then ' to left one space
VS$(VsIndex) = Mid$(VsHead$, 1, Len(VsHead$) - 1) + VsTail$
CCol = CCol - 1: NeedsSaving = -1
ElseIf CCol = 7 And CRow > 1 Then 'drag VsTail$ up to end of back row
CRow = CRow - 1: NeedsSaving = -1
VsHead$ = VS$(VsIndex - 1)
CCol = Len(VsHead$) + 1 + 6
VS$(VsIndex - 1) = VsHead$ + VsTail$
DynArr_Delete VsIndex, VS$() 'delete line at vsIndex
End If
NeedsSaving = -1: SelRow = 0
Case 13 ' enter
If SelRow Then DeleteSelected
If CCol = 7 Then ' blank line here and all else moved down
DynArr_Insert "", VsIndex, VS$()
ElseIf CCol >= Len(VS$(VsIndex)) + 1 + 6 Then ' next line is blank
DynArr_Insert "", VsIndex + 1, VS$()
Else ' in the middle of the text line
VS$(VsIndex) = VsHead$
DynArr_Insert VsTail$, VsIndex + 1, VS$()
End If
CCol = 1 + 6
If CRow < MaxRow Then ' fix curs going down past screen!
CRow = CRow + 1
Else
VsScreenTop = VsScreenTop + 1
End If
NeedsSaving = -1: SelRow = 0
Case 32 To 255 And (ctrl = 0)
If SelRow Then DeleteSelected
If CCol < MaxCol Then ' insert chr$ and advance
VS$(VsIndex) = VsHead$ + Chr$(kh) + VsTail$
CCol = CCol + 1
Else
s$ = "You are at the end of line for editing."
_MessageBox "Keypress ignored.", s$, "warning"
End If
NeedsSaving = -1: SelRow = 0
Case 18432 ' up
CheckShift
If CRow > 1 Then
CRow = CRow - 1
ElseIf VsScreenTop > 1 Then
VsScreenTop = VsScreenTop - 1
End If
Case 20480 ' down
CheckShift
If CRow < MaxRow And CRow + VsScreenTop <= VsUB Then
CRow = CRow + 1
ElseIf VsScreenTop < VsUB And CRow + VsScreenTop <= VsUB Then
VsScreenTop = VsScreenTop + 1
End If
Case 19200 ' left
CheckShift: If CCol > 7 Then CCol = CCol - 1
Case 19712 ' right
CheckShift: If CCol < MaxCol Then CCol = CCol + 1
Case 18176 ' home
CheckShift: CCol = 7
Case 20224 ' end vs$(index) = VsScreenTop + Crow-1
CheckShift: CCol = Len(VS$(VsScreenTop + CRow - 1)) + 7
If CCol > MaxCol Then CCol = MaxCol
Case 18688 ' page up
CheckShift
If VsScreenTop > MaxRow Then VsScreenTop = VsScreenTop - MaxRow Else VsScreenTop = 1
Case 20736 ' page down
CheckShift: If VsScreenTop + MaxRow <= VsUB Then VsScreenTop = VsScreenTop + MaxRow
If CRow + VsScreenTop > VsUB Then CRow = VsUB - VsScreenTop + 1
If CRow < 1 Then Beep: CRow = 1 ' needed ?
Case 27: CheckSave: System ' esc exec keys
Case 15104: Menu ' F1 help
Case 15360: LoadClip ' F2 loads file array into Clipboard
Case 15616: FindNext 0 ' F3 Find Next
Case 15872: ChangeToWhat -1 ' F4 Change all
End Select
If _MouseButton(2) Then Menu
Loop
' ========================================File Handling Stuff might make a nice ToolBox !
Sub CheckSave
Dim a As Long, s$
If NeedsSaving = -1 Then
s$ = "Do you want to save changes to " + Filename$
a = _MessageBox("Save work?", s$, "yesno", "question")
If a = 1 Then SaveIt
End If
End Sub
Sub New
CheckSave
ReDim VS$(1 To 1)
CCol = 7: CRow = 1: VsScreenTop = 1: NeedsSaving = 0
Filename$ = "untitled": SelRow = 0: SelCol = 0
End Sub
Sub FLoad () 'to do a .txt file getter plug-in here
Dim fn$, fline$
Dim As Long lc, ub
CheckSave
fn$ = _OpenFileDialog$("Select File to Edit", , "*.txt|*.bas", "Text or Basic files")
If fn$ <> "" Then
If _FileExists(fn$) Then
ReDim VS$(1 To 100)
Open fn$ For Input As #1
While Not EOF(1)
Line Input #1, fline$
lc = lc + 1
ub = UBound(VS$)
If lc > UBound(VS$) Then ReDim _Preserve VS$(1 To ub + 100)
VS$(lc) = fline$
Wend
Close #1
ReDim _Preserve VS$(1 To lc)
Filename$ = fn$
CCol = 7: CRow = 1: VsScreenTop = 1: NeedsSaving = 0
SelRow = 0: SelCol = 0
End If
End If
End Sub
Sub SaveIt
Dim lb As Long, i As Long, fini As Long
If Filename$ = "untitled" Then SaveAsName: Exit Sub ' get a name going
lb = LBound(VS$)
i = UBound(VS$) ' dont save a bunch of emptiness
While _Trim$(VS$(i)) = "" ' don't go below lb
If i - 1 > lb Then i = i - 1 Else Exit While
Wend
fini = i
Open Filename$ For Output As #1
For i = 1 To fini
Print #1, VS$(i)
Next
Close
NeedsSaving = 0
_MessageBox "Saved", Filename$
End Sub
Sub SaveAsName ' reset a file name then save to that
Dim answer$, t$, w$, m$, n$, yn As Long
t$ = "Save As Warning:"
w$ = "warning"
n$ = "Nothing has been saved yet."
answer$ = _SaveFileDialog$("Save File As:", _CWD$, "*.txt|*.bas", "txt or bas file")
If answer$ <> "" Then
If _FileExists(answer$) Then
m$ = answer$ + ", File already exists. Do you wish to Start Over?"
yn = _MessageBox("Write Over Existing File?", m$, "yesno", w$)
If yn <> 1 Then _MessageBox t$, n$, w$: Exit Sub
End If
Filename$ = answer$
_Delay .1 'make sure the name is changed Why the hell is this asking me twice!!!!!!!!
SaveIt
Else
_MessageBox t$, n$, w$
End If
End Sub
' ========================================================= End of File Handling Stuff
Sub CheckShared
Dim s$, ls As Long
If CRow < 1 Then CRow = CRow + 1
While CRow > MaxRow
CRow = CRow - 1
Wend
While CCol < MinCol
CCol = CCol + 1
Wend
While CCol > MaxCol ' get col in screen
CCol = CCol - 1
Wend
VsUB = UBound(VS$)
If VsScreenTop > VsUB Then VsScreenTop = VsUB
While VsScreenTop + CRow - 1 > VsUB
CRow = CRow - 1
Wend
VsIndex = VsScreenTop + CRow - 1
VsCol = CCol - 6
s$ = VS$(VsIndex): ls = Len(s$)
If VsCol > ls Then
s$ = Left$(s$ + Space$(103), 103)
VsTail$ = RTrim$(Mid$(s$, VsCol))
Else
VsTail$ = Mid$(s$, VsCol)
End If
If VsCol > 1 Then VsHead$ = Mid$(s$, 1, VsCol - 1) Else VsHead$ = ""
End Sub
Sub CheckShift ' do I need this? oh yeah now I do!!! use only on navigator keys
If SelRow And Shift Then
' ok
ElseIf SelRow = 0 And Shift Then ' select on
SelRow = VsScreenTop + CRow - 1: SelCol = CCol - 6 ' set anchor point
Else
SelRow = 0: SelCol = 0 ' select off
End If
End Sub
Sub DrwCurs ' for this app specially for font
Static As Long loops
loops = loops + 1
If loops Mod 30 < 15 Then
Line ((CCol - 1) * FW, (CRow - 1) * 20 + 19)-Step(FW, 1), FG, BF
End If
If loops Mod 30 = 0 Then loops = 1
End Sub
Sub Show ' and tell when the line is getting dangerously long, no word wrap
Dim As Long i, r, fini
Dim As Long selLow, selHigh, selRow2, selCol2, lC, rCol ' for showing selected text
Dim s$
Line (0, 0)-(6 * FW, _Height), EBG, BF
Line (0, 30.5 * 20)-(_Width, _Height), EBG, BF
Line (6 * FW, 0)-(_Width, 30.5 * 20), BG, BF
Color FG
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then lC = SelCol: rCol = selCol2 Else lC = selCol2: rCol = SelCol
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
If VsScreenTop + 29 <= VsUB Then fini = VsScreenTop + 29 Else fini = VsUB '? last page
Color EFG, EBG ' print the line numbers
For i = VsScreenTop To fini
r = r + 1
_PrintString (0, (r - 1) * 20), (Right$(Space$(4) + _Trim$(Str$(i)), 5)) ' + " "
Next
r = 0
Color FG, BG ' main part of screen
For i = VsScreenTop To fini
r = r + 1
If (selLow = selHigh) And (i = selLow) Then ' highlite partial section on 1 line
_PrintString (6 * FW + 1, (r - 1) * 20), Mid$(VS$(i), 1, lC - 1)
Color BG, FG
_PrintString ((6 + lC - 1) * FW + 1, (r - 1) * 20), Mid$(VS$(i), lC, rCol - lC + 1)
Color FG, BG
_PrintString ((6 + rCol) * FW + 1, (r - 1) * 20), Mid$(VS$(i), rCol + 1)
ElseIf (selLow <> selHigh) And ((i >= selLow) And (i <= selHigh)) Then
Color BG, FG ' highlight whole line
_PrintString (6 * FW + 1, (r - 1) * 20), VS$(i)
Else
Color FG, BG ' normal line no highlites
_PrintString (6 * FW + 1, (r - 1) * 20), VS$(i)
End If
Next
Color EFG, EBG ' Bottom section
If Len(Filename$) <= 100 Then
s$ = Filename$
Else
s$ = Left$(Filename$, 10) + "... " + Right$(Filename$, 86)
End If
CP 32, s$
s$ = "Menu/Help F1" + Spc(20)
s$ = s$ + "Cursor Row, Col:" + n3$(CRow) + "," + n3$(CCol - 6)
If NeedsSaving = 0 Then s$ = s$ + Spc(20) + "Saved" Else s$ = s$ + Spc(20) + "NOT saved"
CP 33, s$
s$ = "Selected Text Anchor Row, Col: " + n3$(SelRow) + "," + n3$(SelCol)
s$ = s$ + Spc(10) + "Find: '" + Find$ + "'"
PS 3, 34, s$
s$ = "Selected Text End Row, Col: " + n3$(selRow2) + "," + n3$(selCol2)
s$ = s$ + Spc(8) + "Change: '" + Change$ + "'"
PS 6, 35, s$
DrwCurs
_Display
End Sub
Sub CopySelected ' now copy to clipboard
Dim As Long i ' multi lines
Dim As Long selLow, selHigh, selRow2, selCol2, lCol, rCol ' for selected text
If SelRow = 0 Then _Clipboard$ = "": Exit Sub ' nothing to see here
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then
lCol = SelCol: rCol = selCol2
Else
lCol = selCol2: rCol = SelCol
End If
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
If selLow = selHigh Then ' using lc and rc no row deletions from VS$
_Clipboard$ = Mid$(VS$(selLow), lCol, rCol - lCol + 1)
Else ' for deleting we will have to work backwards in VS$()
_Clipboard$ = "" ' clear contents
For i = selLow To selHigh ' these are vs$ array indexes
If i = selLow Then
_Clipboard$ = VS$(i) ' clear contents
Else
_Clipboard$ = _Clipboard$ + Chr$(13) + Chr$(10) + VS$(i)
End If
Next
End If
'_MessageBox "Copy in Clipboard$", _Clipboard$
End Sub
Sub DeleteSelected ' built from redundant model from Show to cover all vs$()
' save what we are deleting just in case?
Dim As Long i, Nlines, Sline
Dim As Long selLow, selHigh, selRow2, selCol2, lCol, rCol ' for showing selected text
Dim s$
If SelRow = 0 Then Exit Sub ' nothing to see here
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selCol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selCol2 Then
lCol = SelCol: rCol = selCol2
Else
lCol = selCol2: rCol = SelCol
End If
selLow = SelRow: selHigh = selRow2
ElseIf SelRow < selRow2 Then
selLow = SelRow: selHigh = selRow2
ElseIf SelRow > selRow2 Then
selLow = selRow2: selHigh = SelRow
End If
End If
Nlines = selHigh - selLow + 1
Sline = Nlines
If selLow = selHigh Then ' using lc and rc no row deletions from VS$
s$ = Mid$(VS$(selLow), 1, lCol - 1)
s$ = s$ + Mid$(VS$(selLow), rCol + 1)
VS$(selLow) = s$
CCol = lCol + 6
Else ' for deleting we will have to work backwards in VS$()
For i = selHigh To selLow Step -1 ' these are vs$ array indexes
DynArr_Delete i, VS$()
Sline = Sline - 1
Next
If selLow - 1 > 0 Then CRow = selLow - 1 Else CRow = 1
CCol = 7
End If
SelRow = 0: SelCol = 0
CheckShared ' <<< do i have to??? it keeps everything in bounds safe hopefully
End Sub
Sub Paste ' check clipboard for CRLF, LF, if non found assume single line paste
Dim As Long ubClip, i, currentRow
Dim c$, d$, s$, t$
If SelRow Then DeleteSelected ' does CheckShared
currentRow = VsScreenTop + CRow - 1 ' need a CheckShared first?
c$ = _Clipboard$
If c$ = "" Then Exit Sub
If InStr(c$, Chr$(13) + Chr$(10)) Then
d$ = Chr$(13) + Chr$(10)
ElseIf InStr(c$, Chr$(10)) Then
d$ = Chr$(10)
Else ' it's a oneliner or less
s$ = Mid$(VS$(currentRow), 1, CCol - 7) ' 6 is 1 too far right
t$ = s$ + c$ + Mid$(VS$(currentRow), CCol - 6)
VS$(currentRow) = t$
CCol = CCol + Len(c$)
Exit Sub
End If
ReDim clip$(1 To 1)
Split c$, d$, clip$()
ubClip = UBound(clip$)
For i = 1 To ubClip
DynArr_Insert clip$(i), currentRow, VS$()
currentRow = currentRow + 1
Next
CRow = CRow + currentRow ' put cursor at end of inserted
CheckShared ' makesure CRow ok and update vs variables
CCol = Len(VS$(VsScreenTop + CRow - 1)) + 7
End Sub
Function n3$ (n As Long)
n3$ = Right$(Spc(2) + Str$(n), 3)
End Function
Sub PS (Col&, Row&, txt$) ' for this app
_PrintString ((Col& - 1) * 11, (Row& - 1) * 20), txt$
End Sub
Sub CP (row, txt$) 'on row center Print txt$ modified for this app
Dim col As Long, s$
If _PrintWidth(txt$) > _Width Then
s$ = Right$(txt$, Int(_Width / FW))
Else
s$ = txt$
End If
col = (_Width / FW - Len(txt$)) \ 2
_PrintString (col * FW, (row - 1) * 20), s$
End Sub
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound
curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
arrpos = arrpos + 1
If arrpos > UBound(loadMeArray) Then
ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
End If
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End Sub
Function Join$ (arr() As String, delimiter$)
Dim i As Long, b$
For i = LBound(arr) To UBound(arr)
If i = LBound(arr) Then b$ = arr(LBound(arr)) Else b$ = b$ + delimiter$ + arr(i)
Next
Join$ = b$
End Function
'2023-11-14 \QB64 Files\000 work QB64\000 Test\Array Tools_
' \Dynamic Array Tools\DynArr_Insert and Delete.bas"
Sub DynArr_Insert (Text$, Place&, DynArr$())
' Text$ is a string of text, or empty string
' Place& is insertion index
' DynArr$() is an array that can be resized, the first step in fact
' to insert the line we increase the array ubound by 0ne
' copy all lines below up one
' finally insert the line into place&
' ah! what if Place& is > ub ? then just add it to end or place it exactly?
' I say place it exactly!
Dim As Long lb, ub, i, diff
Dim m$ ' message too long for one line
lb = LBound(DynArr$)
If Place& < lb Then
m$ = "The Place& argument < Lbound(DynArr$), skipping insertion."
_MessageBox "Sub DynArr_Insert Error", m$, "warning"
Exit Sub ' no since shutting down program for little error
End If
ub = UBound(DynArr$)
If Place& > ub Then
diff = Place& - ub
ReDim _Preserve DynArr$(lb To ub + diff)
For i = ub + 1 To ub + diff - 1
DynArr$(i) = "" ' fill in between
Next
Else
ReDim _Preserve DynArr$(lb To ub + 1)
For i = ub To Place& Step -1
DynArr$(i + 1) = DynArr$(i) ' copy lines up one
Next
End If
DynArr$(Place&) = Text$ ' finally add the insertion
End Sub
'2023-11-14 \QB64 Files\000 work QB64\000 Test\Array Tools_
' \Dynamic Array Tools\DynArr_Insert and Delete.bas"
Sub DynArr_Delete (Place&, DynArr$())
' the reverse of an insertion
' Place& is deletion index
' DynArr$() is an array that can be resized
' to delete the line we copy all the lines above, down one
' then remove the last line by Redim one line less
Dim As Long lb, ub, i
Dim m$ ' message too long for one line
lb = LBound(DynArr$)
ub = UBound(DynArr$)
If ub = lb Then Exit Sub
If Place& < lb Or Place& > ub Then ' nope!
m$ = "The Place& argument is outside the bounds of array, skipping deletion."
_MessageBox "Sub DynArr_Delete Error", m$, "warning"
Exit Sub ' no since shutting down program for little error
End If
If Place& < ub Then
For i = Place& To ub - 1
DynArr$(i) = DynArr$(i + 1) ' copy lines up one
Next
End If
ReDim _Preserve DynArr$(lb To ub - 1)
End Sub
Sub Menu ' modified for this app
'this sub uses drwBtn
Dim As Long ub, lb, b, col, row, mx, my, mb, topChoice
topChoice = 15
Dim choice$(1 To topChoice), s$
ub = UBound(choice$): lb = LBound(choice$)
For b = lb To ub ' drawing a column of buttons at _width - 210 starting at y = 10
col = Int((b - 1) / 8)
If b Mod 8 = 0 Then row = 8 Else row = b Mod 8
drwBtn col * 290 + 40, row * 60 + 10, choice$(b)
Next
Do
While _MouseInput: Wend
mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
If mb Then
_Delay .25 ' delay to give user time to release mouse button
For b = lb To ub
col = Int((b - 1) / 8)
If b Mod 8 = 0 Then row = 8 Else row = b Mod 8
If mx > col * 290 + 40 And mx <= col * 290 + 290 Then
If my >= row * 60 + 10 And my <= row * 60 + 60 Then
Exit Do
End If
End If
Next
End If
_Display
_Limit 60
Loop
s$ = "Enter: 1 = Forest, 2 = Patriot, 3 = Orange or ? = Mystery"
Select Case b
Case 1: New
Case 2: FLoad
Case 3: SaveIt
Case 4: SaveAsName
Case 5: CopySelected: DeleteSelected: NeedsSaving = -1
Case 6: CopySelected
Case 7: Paste: NeedsSaving = -1
Case 8: Exit Sub
Case 9: FindWhat 1: FindNext (0) ' get find$ and start search
Case 10: FindNext 0 ' search forward
Case 11: FindNext -1 ' serach reverse
Case 12: ChangeToWhat 0 ' alt + F3
Case 13: ChangeToWhat -1 ' F4 change all
Case 14: b = Val(_InputBox$("Color Theme:", s$, "1")): ColorTheme b
Case 15: CheckSave: System
End Select
_KeyClear
End Sub
Sub drwBtn (x, y, s$) '250 x 50 modified for this app
Dim fc~&, bc~&
Line (x + 2, y + 2)-Step(248, 48), _RGB32(0), BF ' shadow
Line (x, y)-Step(244, 44), _RGB32(255), BF ' highlight edge
Line (x + 2, y + 2)-Step(243, 43), _RGB32(190), BF ' face color
fc~& = _DefaultColor: bc~& = _BackgroundColor ' save color before we change
Color _RGB32(0), _RGB32(190)
_PrintString (x + 125 - .5 * FW * Len(s$) + 1, y + 16 + 1), s$
Color fc~&, bc~& ' restore color
End Sub
Sub ColorTheme (n%)
Select Case n%
Case 1 ' Forest Theme sky, leaves, earth
FG = _RGB32(160, 160, 255): BG = _RGB32(0, 60, 0): EFG = FG: EBG = _RGB32(40, 20, 10)
Case 2 ' Patriot Theme edge of eye watering white, OldGloryRed, OldGloryBlue
FG = &HFFDDDDDD: BG = &HFFBF0A30: EFG = FG: EBG = &HFF002868 '
Case 3 ' Orange Theme light, low, med red/low (no blue)
FG = _RGB32(200, 250, 200): BG = _RGB32(240, 120, 0): EFG = FG: EBG = _RGB32(160, 30, 0)
Case Else ' Gray Theme
FG = _RGB32(0): BG = _RGB32(160): EBG = _RGB32(80)
End Select
End Sub
Sub FindWhat (title As Long)
Dim t$, s$
If title = 1 Then t$ = "Find..."
If title = 2 Then t$ = "Change..."
If title = 3 Then t$ = "Change All"
s$ = SelectedLine$
If Len(s$) Then
Find$ = _InputBox$(t$, "Find what?", s$)
Else
Find$ = _InputBox$(t$, "Find what?")
End If
CaseSense = _MessageBox("Case Sensitive?", "Match case exactly?", "yesno")
If CaseSense = 1 Then CaseSense = -1 Else CaseSense = 0
findR = 0: findC = 0: Change$ = ""
End Sub
Sub ChangeToWhat (all As Long)
Dim As Long i, startRow, startCol, cpos, yn, countChanges
If all Then FindWhat 3 Else FindWhat 2
Change$ = _InputBox$("Change:", "Change " + Find$ + " to what?")
i = VsScreenTop + CRow - 1: startRow = i: startCol = 1
Do
checkRow:
If CaseSense Then ' exact match
cpos = InStr(startCol, VS$(i), Find$)
Else
cpos = InStr(startCol, UCase$(VS$(i)), UCase$(Find$))
End If
If cpos Then
startCol = cpos + 1 ' set next find
If all = 0 Then
SelRow = i: SelCol = cpos ' setting up for display of find, select anchor
VsScreenTop = i: CRow = 1: CCol = 6 + cpos + Len(Find$) - 1 ' display find
Show
yn = _MessageBox("Change to:", Change$, "yesnocancel", "question")
If yn = 0 Then ' Cancel
SelRow = 0: SelCol = 0
Exit Sub
ElseIf yn = 1 Then ' change
VS$(i) = Mid$(VS$(i), 1, cpos - 1) + Change$ + Mid$(VS$(i), cpos + Len(Find$))
SelRow = 0: SelCol = 0
Show
NeedsSaving = -1
countChanges = countChanges + 1
'ElseIf yn = 2 Then ' dont change it but continue search
End If
GoTo checkRow ' search row some more!
Else
VS$(i) = Mid$(VS$(i), 1, cpos - 1) + Change$ + Mid$(VS$(i), cpos + Len(Find$))
NeedsSaving = -1
countChanges = countChanges + 1
GoTo checkRow ' search row some more!
End If
End If
i = i + 1: If i > VsUB Then i = 1
startCol = 1
If i = startRow And startCol = 1 Then Exit Do ' we are back to where we started
Loop
_MessageBox "Change...", "There were" + Str$(countChanges) + " changes made.", "info"
Change$ = ""
_KeyClear
End Sub
Sub FindNext (reverse As Long)
Dim As Long i, saveRow, start, cpos
If Find$ = "" Then FindWhat 1
i = VsScreenTop + CRow - 1: start = findC + 1: saveRow = i
Do
If CaseSense Then ' exact match
cpos = InStr(start, VS$(i), Find$)
Else
cpos = InStr(start, UCase$(VS$(i)), UCase$(Find$))
End If
If cpos Then
findR = i: findC = cpos ' save last find
SelRow = i: SelCol = cpos ' select anchor
VsScreenTop = i: CRow = 1: CCol = 6 + cpos + Len(Find$) - 1 ' display find
Show
Exit Sub
End If
If reverse Then
i = i - 1: If i < 1 Then i = VsUB
Else
i = i + 1: If i > VsUB Then i = 1
End If
start = 1
If i > VsUB Then i = 1
If i = 0 Then i = VsUB
If i = saveRow And start = 1 Then Exit Do
Loop
_MessageBox "Find Next", "Match not found.", "info"
End Sub
Sub LoadClip ' F2 instead of select all just load clipboard with vs$
Dim i As Long, crlf$
crlf$ = Chr$(13) + Chr$(10)
_Clipboard$ = VS$(1)
For i = 2 To VsUB
_Clipboard$ = _Clipboard$ + crlf$ + VS$(i)
Next
_MessageBox "Clipboard Update:", "File loaded into Clipboard.", "info"
End Sub
Function SelectedLine$
Dim selRow2, selcol2, lCol, rCol
If SelRow Then ' we have selected text get our ducks in order
selRow2 = VsScreenTop + CRow - 1 ' update this shared variable
selcol2 = CCol - 6 ' no if's this has to be set , this shouldn't be shared
If SelRow = selRow2 Then
If SelCol < selcol2 Then
lCol = SelCol: rCol = selcol2
Else
lCol = selcol2: rCol = SelCol
End If
SelectedLine$ = Mid$(VS$(SelRow), lCol, rCol - lCol + 1)
End If
End If
End Function
Theme 1 Forest
Theme 2 Patriot
Theme 3 Orange with Menu popup buttons
Although not complete, it is a good step further than other efforts and might give an aspiring editor builder some helpful ideas.
Oh for Linux users lucon.ttf (all lower case) attached here :
This is simple elegant version in Screen 0 ie no noisey, shiney bling!
Its all about getting an fairly intelligent AI to play against. I call this version of Battleship Mod842 because the structure of the AI's random shots uses waves of Mod 8 then Mod 4 then Mod 2 in it's bombing patterns so the Destroyer the smallest ship of length 2 has to be caught in final mod 2 net if not found before that.
Code: (Select All)
_Title "BattleShip Mod842" ' b+ 2024-07-26 port from JB
' Battleship Mod842 b+ 2024-07-25 uses a garanteed AI to find Destroyer in 50 shots
' unlike Battleship 2 which AI uses mod 3 it is screwed if fails to find Destroyer when mod 3 shooting
' covers the ocean taking something like up to 66 shots to garantee finding Destroyer.
' This code starts from my first Battleship coded for JB:
' Battleship based on Hasbro Game b+ 2024-07-23 allot of code ported out of old QB64 version
' 2024-07-26 besides port trans back to QB64, fix the showing of computer ships so only the ones
' or parts not hit with ship number. Add Sound when ship is hit.
Dim Shared As Long PXO, PYO, CXO, CYO, SXO, SYO ' offsets for player, computer and ships sunk boards
Dim Shared As Long Dir ' for AI bombing testing 4 directions from last hit for more ship
Dim Shared As Long AiI ' index for AiShots$()
Dim Shared As Long CurrentHits ' tracks how many hits have been made when ship is sunk subtract it's length
' are there still unaccounted for hits?
Dim Shared As Long PTurn, GameOn ' TF players turn or not and GameOn if still running game
Dim Shared As Long X1, Y1, BombX, BombY, Hit2 ' tracking bombs and hits for AI to sink ship
Dim Shared As Long P(9, 9), C(9, 9), Hits(9, 9) ' player board, computer board and hits tracking for AI
Dim Shared As Long ShipLen(10), ShipHor(10), ShipX(10), ShipY(10), ShipSunk(10)
Dim Shared ShipName$(10), ShipHits$(10)
' Ship arrays are 0 based but are really numbered 1 to 10, 0 is ignored
' ShipName$() are names of ships according to length in character cells see approx line 38
' ShipLen() is the length or how many character cells a ship is long, 5 down to 2 according to index
' ShipHor() is a T/F value (0|-1) if it is Setup horizontal see SetUp where ships are positioned
' ShipX() and ShipY() locate the top of a ship if vertically set or the left start of ship if horizontal
' ShipHits$() tracks which cell on each ship was hit
' ShipSunk() T/F if ship has been sunk
Dim Shared AiShots$(50) ' AiShots sequence pattern coverage of board for bombs
Color 15, 9
Randomize Timer
' set one time only stuff
PXO = 8: PYO = 6 ' offsets for player grid
CXO = 35: CYO = 6 ' offsets for computer grid player shoots at
SXO = 68: SYO = 10 ' offsets ship tally
For i = 1 To 10 ' not sure I need names yet
Select Case i
Case 1: ShipLen(i) = 5: ShipName$(i) = "Carrier"
Case 2: ShipLen(i) = 4: ShipName$(i) = "Battleship"
Case 3: ShipLen(i) = 3: ShipName$(i) = "Cruiser"
Case 4: ShipLen(i) = 3: ShipName$(i) = "Submarine"
Case 5: ShipLen(i) = 2: ShipName$(i) = "Destroyer"
Case 6: ShipLen(i) = 5: ShipName$(i) = "Carrier"
Case 7: ShipLen(i) = 4: ShipName$(i) = "Battleship"
Case 8: ShipLen(i) = 3: ShipName$(i) = "Cruiser"
Case 9: ShipLen(i) = 3: ShipName$(i) = "Submarine"
Case 10: ShipLen(i) = 2: ShipName$(i) = "Destroyer"
End Select
Next
While 1 'run game loop until player quits
Setup
Shoot
Wend
Sub Setup ' get a game ready to play
' clear shared arrays and variables
Erase ShipX, ShipY, ShipHor, ShipHits$, ShipSunk, P, C, Hits
PTurn = 0: GameOn = 0: Dir = 0: AiI = 0: CurrentHits = 0 ' globals
'setup 2 bombing patterns to cover sea in checkerboard pattern one is chosen in each game
s1$ = "A0B1C2D3E4F5G6H7I8J9I0J1A8B9E0F1G2H3I4J5A4B5C6D7E8F9C0D1E2F3G4H5I6J7A6B7C8D9G0H1I2J3A2B3C4D5E6F7G8H9"
s2$ = "A9B8C7D6E5F4G3H2I1J0B0A1I9J8A5B4C3D2E1F0E9F8G7H6I5J4A3B2C1D0A7B6C5D4E3F2G1H0C9D8E7F6G5H4I3J2G9H8I7J6"
If Rnd < .5 Then shots$ = s1$ Else shots$ = s2$ ' don't be predictable with bombing patterns
' shuffle sections: priority diagonal then sub diagonals, Mod 8 then mod 4 then mod 2
ReDim As Long T(50), i
For i = 1 To 50: T(i) = i: Next
start = 1: stp = 10: Shuffle T(), start, stp
start = 11: stp = 14: Shuffle T(), start, stp
start = 15: stp = 26: Shuffle T(), start, stp
start = 27: stp = 50: Shuffle T(), start, stp
For i = 1 To 50 ' stow into an array
AiShots$(i) = Mid$(shots$, 2 * T(i) - 1, 2)
Next
Cls
' Game Board draw once per game
Print ""
Print " Player Computer"
Print ""
Print " A B C D E F G H I J A B C D E F G H I J"
Print " ------------------- -------------------"
Print " 0| . . . . . . . . . . 0| . . . . . . . . . ."
Print " 1| . . . . . . . . . . 1| . . . . . . . . . ."
Print " 2| . . . . . . . . . . 2| . . . . . . . . . ."
Print " 3| . . . . . . . . . . 3| . . . . . . . . . . Ships: P C"
Print " 4| . . . . . . . . . . 4| . . . . . . . . . . Carrier . ."
Print " 5| . . . . . . . . . . 5| . . . . . . . . . . Battleship . ."
Print " 6| . . . . . . . . . . 6| . . . . . . . . . . Cruiser . ."
Print " 7| . . . . . . . . . . 7| . . . . . . . . . . Submarine . ."
Print " 8| . . . . . . . . . . 8| . . . . . . . . . . Destroyer . ."
Print " 9| . . . . . . . . . . 9| . . . . . . . . . ."
Print " ------------------- -------------------"
Print " A B C D E F G H I J A B C D E F G H I J"
'locate 6, 5: print "X" ' check offsets
' check AIshots$((aiI) OK
'For i = 1 To 50 'double check checker board coverage 50 cells in priority order
' x = InStr("ABCDEFGHIJ", Left$(AiShots$(i), 1)) - 1
' y = Val(Mid$(AiShots$(i), 2, 1))
' LP x, y, "p", "O"
' _Delay 1
'Next
For i = 1 To 10 ' restring ship hits to all clear no hits
ShipHits$(i) = String$(ShipLen(i), "o")
Next
Autosetup 1 'setup the Computers ships offer to that for player
Message "Let computer setup your ships? press y for yes, n for no..."
k$ = UCase$(Input$(1))
If k$ = "Y" Then
Autosetup 0
Else
For s = 1 To 5 ' do it yourself ship placement
OK = 0
Locate 21, 1
Print "To place ship:" + Chr$(13) + "Enter v for vertical, h for horizontal, letter and digit for top, left of ship"
While OK = 0
ClearMessage
Message "Setting up the " + ShipName$(s) + " with length" + Str$(ShipLen(s))
Locate 23, 1: Print Space$(80);
Locate 23, 1: Input "placement? "; place$
place$ = UCase$(place$)
If Left$(place$, 1) = "V" Then ShipHor(s) = 0 Else ShipHor(s) = 1
sx = InStr("ABCDEFGHIJ", Mid$(place$, 2, 1)) - 1
sy = Val(Mid$(place$, 3, 1))
Locate 23, 1: Print Space$(80);
If ShipHor(s) Then
If sx <= 10 - ShipLen(s) Then
OK = 1
For xx = 0 To ShipLen(s) - 1
If P(sx + xx, sy) <> 0 Then OK = 0: Exit For
Next
If OK Then
ShipX(s) = sx: ShipY(s) = sy
For xx = 0 To ShipLen(s) - 1
P(sx + xx, sy) = s
LP sx + xx, sy, "p", _Trim$(Str$(s))
Next
End If
End If
Else
If sy <= 10 - ShipLen(s) Then
OK = 1
For yy = 0 To ShipLen(s) - 1
If P(sx, sy + yy) <> 0 Then OK = 0: Exit For
Next
If OK Then
ShipX(s) = sx: ShipY(s) = sy
For yy = 0 To ShipLen(s) - 1
P(sx, sy + yy) = s
LP sx, sy + yy, "p", _Trim$(Str$(s))
Next
End If
End If
End If
Wend
Next
Locate 21, 1: Print Space$(80); ' clear multi-lines
Locate 22, 1: Print Space$(80);
Locate 23, 1: Print Space$(80);
End If
ClearMessage
End Sub
Sub Autosetup (AItf As Long) ' there is surely a shorter way to do this but I am eager to get on with other stuff
If AItf Then 'setup Computer's ships
'setup a board with ships, Computer or AI's setup
For s = 6 To 10
OK = 0
While OK = 0
ShipHor(s) = Rand(0, 1)
If ShipHor(s) Then
sy = Rand(0, 9)
sx = Rand(0, 10 - ShipLen(s))
OK = 1
For xx = 0 To ShipLen(s) - 1
If C(sx + xx, sy) <> 0 Then OK = 0: Exit For
Next
If OK Then
ShipX(s) = sx: ShipY(s) = sy
For xx = 0 To ShipLen(s) - 1
C(sx + xx, sy) = s
'LP sx + xx, sy, "c", _Trim$(Str$(S Mod 10)) ' for debugg
Next
End If
Else
sx = Rand(0, 9)
sy = Rand(0, 10 - ShipLen(s))
OK = 1
For yy = 0 To ShipLen(s) - 1
If C(sx, sy + yy) <> 0 Then OK = 0: Exit For
Next
If OK Then
ShipX(s) = sx: ShipY(s) = sy
For yy = 0 To ShipLen(s) - 1
C(sx, sy + yy) = s
'LP sx, sy + yy, "c", _Trim$(Str$(S Mod 10)) ' for debugg
Next
End If
End If
Wend
Next
Else 'setup Player's ships
For s = 1 To 5
OK = 0
While OK = 0
ShipHor(s) = Rand(0, 1)
If ShipHor(s) Then
sy = Rand(0, 9)
sx = Rand(0, 10 - ShipLen(s))
OK = 1
For xx = 0 To ShipLen(s) - 1
If P(sx + xx, sy) <> 0 Then OK = 0: Exit For
Next
If OK Then
ShipX(s) = sx: ShipY(s) = sy
For xx = 0 To ShipLen(s) - 1
P(sx + xx, sy) = s
LP sx + xx, sy, "p", _Trim$(Str$(s))
Next
End If
Else
sx = Rand(0, 9)
sy = Rand(0, 10 - ShipLen(s))
OK = 1
For yy = 0 To ShipLen(s) - 1
If P(sx, sy + yy) <> 0 Then OK = 0: Exit For
Next
If OK Then
ShipX(s) = sx: ShipY(s) = sy
For yy = 0 To ShipLen(s) - 1
P(sx, sy + yy) = s
LP sx, sy + yy, "p", _Trim$(Str$(s))
Next
End If
End If
Wend
Next
End If
End Sub
Sub Message (m$)
Locate 20, 3: Print m$;
End Sub
Sub ClearMessage
Locate 20, 1: Print Space$(80);
Locate 20, 1: Print ""
End Sub
Sub LP (x As Long, y As Long, pcGrid$, s$)
If pcGrid$ = "p" Then Locate PYO + y, PXO + 2 * x Else Locate CYO + y, CXO + 2 * x
Print s$;
End Sub
Function Rand& (low As Long, high As Long) ' Random integer from low to high inclusive
Rand& = Int(Rnd * (high - low + 1)) + low
End Function
Sub Shoot
GameOn = 1
While GameOn
If PTurn Then PTurn = 0 Else PTurn = 1
If PTurn Then ' player
Locate 20, 1: Input "Enter your next bomb site letter digit "; place$
If place$ = "" Then GameOn = 0
place$ = UCase$(place$)
bx = InStr("ABCDEFGHIJ", Left$(place$, 1)) - 1
by = Val(Mid$(place$, 2, 1))
If bx >= 0 And bx < 10 Then ' better check
If by >= 0 And by < 10 Then
If C(bx, by) <> 0 Then 'hit
LP bx, by, "c", "X"
Sound 200, 2
HitEval "c", bx, by 'game could end here
Else
LP bx, by, "c", "o"
End If
End If
End If
ClearMessage
Else
'AI's turn if it gets a hit it will bomb around the ship until it is finished
'could be trouble if 2 ships are next to each other. Some effort to work it, still might get confused.
'hits() array tracks red = 1 and white pegs = -1 like a human player for AI
If Dir Then 'we are working around the latest hit with bombx, bomby to test
If P(BombX, BombY) <> 0 Then 'hit!
Hit2 = 1
Hits(BombX, BombY) = 1: CurrentHits = CurrentHits + 1
LP BombX, BombY, "p", "X"
'we need to know stuff but can't use this info for AI finding the ship
'when hitEval announces a ship sunk we can reduce the currentHits count by that ships amount
'if still have more current hits, continue bombing area as another ship is there
Sound 2000, 2 ' wakeup player!
HitEval "p", BombX, BombY 'this will reduce currentHits by the amount a ship could take when sunk
If CurrentHits = 0 Then 'clear our checklist we sank all ships we hit, call off bombing of area
X1 = 0: Y1 = 0: Dir = 0
Else
DecideWhereToBombNext
End If
Else 'no hit from checklist scratch off one item
Hit2 = 0
Hits(BombX, BombY) = -1
LP BombX, BombY, "p", "o"
DecideWhereToBombNext
End If ' are we still working on hit
Else
'not working on any hits x1, y1 = 0, dir = 0, currentHits might be = 0
'random but systematic shooting, bring up next good shooting location
alreadyHit:
AiI = AiI + 1 ' next random shoot
If AiI > 50 Then ' we should never get this far but just in case
x = Rand(0, 9)
y = Rand(0, 9)
Else ' normal shooting pattern by diagonals to form checker board coverage
x = InStr("ABCDEFGHIJ", Left$(AiShots$(AiI), 1)) - 1
y = Val(Mid$(AiShots$(AiI), 2, 1))
End If
If Hits(x, y) <> 0 Then GoTo alreadyHit
' was that shot just fired a hit or miss
If P(x, y) <> 0 Then ' test our shot just fired is hit!
X1 = x: Y1 = y 'save first hit to come back to
Hits(X1, Y1) = 1: CurrentHits = CurrentHits + 1
LP X1, Y1, "p", "X"
' we need to know stuff but can't use this info for AI finding the ship
' keep the same as for the player
Sound 2000, 2 ' wakeup player!
HitEval "p", X1, Y1
'did we just happen to finish off a ship? current hits = 0
If CurrentHits = 0 Then 'must of finished off an ship
X1 = 0: Y1 = 0: Dir = 0 'we are done
Else
Dir = -1 ' this signals we are working on a hit
DecideWhereToBombNext
End If
Else 'no hit
Hits(x, y) = -1
LP x, y, "p", "o"
End If
End If 'rI was hit or not
End If 'whose turn is it
_Delay 1.5 ' a sec pause to allow us to see computers move
Wend
Message "Play Again? press y for yes, n for no..."
k$ = Input$(1)
Cls
If k$ = "n" Then End
End Sub
Sub HitEval (board$, bbx, bby)
'this is like a referee for both players to announce a ship sunk and a game won?
If board$ <> "p" Then
s = C(bbx, bby) ' which ship number
you$ = "Player": my$ = "Computer's"
istart = 6: istop = 10
Else
s = P(bbx, bby)
you$ = "Computer": my$ = "Player's"
istart = 1: istop = 5
End If
If ShipHor(s) Then D = bbx - ShipX(s) + 1 Else D = bby - ShipY(s) + 1
Mid$(ShipHits$(s), D, 1) = "X"
If ShipHits$(s) = String$(ShipLen(s), "X") Then
ShipSunk(s) = 1
If board$ = "p" Then CurrentHits = CurrentHits - ShipLen(s)
UpdateStatus
_MessageBox "Congrats:", you$ + " sank " + my$ + " " + ShipName$(s) + "!"
tot = 0
For i = istart To istop
If ShipSunk(i) = 1 Then tot = tot + 1
Next
If tot = 5 Then
UpdateStatus
If you$ = "Computer" Then ShowComputersShips
_MessageBox "Congratulations ", you$ + ", you sank all " + my$ + " ships! GameOver..."
GameOn = 0
End If
End If
End Sub
Sub DecideWhereToBombNext
'find next good location, mark the direction we took
If Dir = -1 Then '
Hit2 = 0 'when direction = 0 reset 2nd hit signal to 0
If X1 + 1 <= 9 Then
If Hits(X1 + 1, Y1) = 0 Then
BombX = X1 + 1: BombY = Y1: Dir = 1: Exit Sub
End If
End If
'still here?
If Y1 + 1 <= 9 Then
If Hits(X1, Y1 + 1) = 0 Then
BombX = X1: BombY = Y1 + 1: Dir = 2: Exit Sub
End If
End If
'still here?
If X1 - 1 >= 0 Then
If Hits(X1 - 1, Y1) = 0 Then
BombX = X1 - 1: BombY = Y1: Dir = 3: Exit Sub
End If
End If
'still here OK this has to do it!
If Y1 - 1 >= 0 Then
If Hits(X1, Y1 - 1) = 0 Then
BombX = X1: BombY = Y1 - 1: Dir = 4: Exit Sub
End If
End If
'still here ???? damn! give up and go back to random shots
Dir = 0: Exit Sub ' < this signals that
End If
'setup next bombx, bomby
If Hit2 Then 'whatever direction we are taking, continue if we can
Select Case Dir
Case 1
If BombX + 1 <= 9 Then
If Hits(BombX + 1, BombY) = 0 Then
BombX = BombX + 1: Exit Sub
End If
End If
Case 2
If BombY + 1 <= 9 Then
If Hits(BombX, BombY + 1) = 0 Then
BombY = BombY + 1: Exit Sub
End If
End If
Case 3
If BombX - 1 >= 0 Then
If Hits(BombX - 1, BombY) = 0 Then
BombX = BombX - 1: Exit Sub
End If
End If
Case 4
If BombY - 1 >= 0 Then
If Hits(BombX, BombY - 1) = 0 Then
BombY = BombY - 1: Dir = 4: Exit Sub
End If
End If
End Select
End If
'still here? then we have to change direction and go back to x1, y1 the first hit
Hit2 = 0 'reset this for the new direction check
While Dir < 4
Dir = Dir + 1
Select Case Dir
Case 2
If Y1 + 1 <= 9 Then
If Hits(X1, Y1 + 1) = 0 Then
BombX = X1: BombY = Y1 + 1: Exit Sub
End If
End If
Case 3
If X1 - 1 >= 0 Then
If Hits(X1 - 1, Y1) = 0 Then
BombX = X1 - 1: BombY = Y1: Exit Sub
End If
End If
Case 4
If Y1 - 1 >= 0 Then
If Hits(X1, Y1 - 1) = 0 Then
BombX = X1: BombY = Y1 - 1: Exit Sub
End If
End If
End Select
Wend
'still here, well we've run out of directions
Dir = 0 'back to random bombing
End Sub
Sub UpdateStatus ' ships area
For i = 1 To 5 ' row 10 carrier player colum 66 computer column 68
If ShipSunk(i) Then Locate i + 9, 68,: Print "X";
If ShipSunk(i + 5) Then Locate i + 9, 70: Print "X"
Next
End Sub
Sub ShowComputersShips ' fixed this so only empty spaces not bombed are displayed
For s = 6 To 10
If ShipHor(s) Then
sx = ShipX(s): sy = ShipY(s)
For xx = 0 To ShipLen(s) - 1
If Mid$(ShipHits$(s), xx + 1, 1) = "o" Then LP sx + xx, sy, "c", _Trim$(Str$(s Mod 10))
Next
Else
sx = ShipX(s): sy = ShipY(s)
For yy = 0 To ShipLen(s) - 1
If Mid$(ShipHits$(s), yy + 1, 1) = "o" Then LP sx, sy + yy, "c", _Trim$(Str$(s Mod 10))
Next
End If
Next
End Sub
Sub Shuffle (a() As Long, start, stp) ' here used to randomize shooting pattern a bit
For i = stp To start + 1 Step -1
Swap a(i), a(Rand(start, i))
Next
End Sub
PS I commented a little more than usual for Phil.
Oh here is Introduction to Battleship Game my version is based on Hasbro Game.
Quote:The object of the game is to sink all the Computer's ships before it sinks all yours.
Both the Player and the Computer are given 5 ships to lay out on a 10x10 grid.
The ships are a straight line of squares (2 to 5 squares) forming a long rectangle.
The ships are laid vertically or horizontally on the 10x10 cell grid without overlap.
Each square must be hit by the opponent in order to sink the ship.
The 5 ships are:
Carrier - 5 squares to hit
Battleship - 4 squares to hit
Cruiser - 3 squares to hit
Submarine - 3 squares to hit
Destroyer - 2 squares to hit
The game is started by each opponent laying out their ships secretly to the other.
You the Player must setup your ships on the left board.
They are setup in same order I listed above.
If you do not want the computer to setup for you:
So the first ship to set up will be the Carrier that is 5 squares long.
Enter v or h for horizontal or vertical then the column letter don't worry about capitals then
the digit 0 to 9. So that is 3 chraracters the first v or h, the 2nd abcdefghi or j and 3rd
is 0 to 9. Be careful not to click other places on board because printing will start there
and mess up board.
If there is room on board to lay out all 5 across AND this ship does not overlap another,
then the rest of the ship will be drawn in with its numbers 1 - 5 for the player. The computers
ship numbers are 6-10 but 10 is shown as 0 (after you lose and the comnputers ship placement is
displayed, you can see these before next game is started.)
(Of course, the first ship can't overlap another but every other ship has that potential.)
If there is not room or the ship would overlap another,
then you must start over with the prompt to lay the ship horizontally or vertically...
When you get all 5 of your ships laid out on the 10x10 grid on the left, the shooting match begins!
You will be prompted to Enter a cell on the right 10x10 board to guess where a Computer's ship might be.
If you hit a cell of the Computers ships an X for hit appears at that cell.
If you miss all the Computers ships, an O will appear = miss
The Computer will then take a shot and your board will show an X or O according to the Computer's hit or miss.
Then it's your turn again. If you had a hit the last turn you will likely want to find the
rest of the ship to sink it. So Enter cells above, below, left or right of the hit.
A 2nd hit will tell you if the ship is laid out horizontally or vertically.
A 2nd hit would actually sink a Destroyer because it is only 2 squares long.
So you scout around the 10x10 board making random shots (or systematically cover the board with shots)
until you find a ship, sink it and go hunting for the next ship to sink until you get all 5.
Meanwhile the Computer is doing the same thing, so whichever opponent sinks all the ships first, wins!
Oh a caveat!
It is possible to align the ships side by side or one end up next to another ship
(as long as they don't overlap). This makes it confusing as you might be hitting 2 different ships
with your shots, so pay close attention to which ship is announced sunk, you might have more hits
in the same area than how many it took to sink the ship.
It's been quite some time since I last posted on QB64PE Forum. I'm so glad that you kind folks have continued QB64. Greetings from Vientiane, Laos.
I've installed and compiled the Linux version on my Linux Mint box. When I run the ISE, it almost flatlines 4 of 4 cpus. This makes things a bit sluggish.
Is there a way to restrict operation to 1 or 2 cpus at most?
It's been quite some time since I last posted on QB64PE Forum. I'm so glad that you kind folks have continued QB64. Greetings from Vientiane, Laos.
I've installed and compiled the Linux version on my Linux Mint box. When I run the ISE, it almost flatlines 4 of 4 cpus. This makes things a bit sluggish.
Is there a way to restrict operation to 1 or 2 cpus at most?
I've run across a bug(s) with variable length strings nested within a UDT.
It manifested itself when I had some variables that originate from a UDT that should have been initialized to zero, but were instead a random value.
This is a stripped down example of the issue(s).
Its seems that if you nest a variable length string in a UDT It can causes crashes.
Variable length strings in this case is convenient for me because the LEN function reports the actual length of string, not the allocated block of memory. This makes the string parsing and manipulation easier.
The workaround would to use fixed length strings and roll my own LEN function.
I'm using Linux and QB v3.13.0
Code: (Select All)
'Nested String UDT Issues
TYPE tUDT_NEST_DEEPER
'If I comment out the 'a' element, and the element 's' is not
' a fixed length, the elements do not initialize to zero properly.
a AS LONG
's AS STRING * 10 ' Works with no issue
s AS STRING ' broken
b AS LONG
END TYPE
TYPE tUDTNEST
s AS STRING
n AS LONG
u AS tUDT_NEST_DEEPER
END TYPE
TYPE tUDT
a AS LONG
b AS tUDTNEST
c AS LONG
END TYPE
DIM test AS tUDT
'The following should initialize to 0 or blank
PRINT " These should all be zero or blank."
PRINT "test.a = "; test.a
PRINT "test.b.s = "; test.b.s
PRINT "test.b.n = "; test.b.n
PRINT "test.c = "; test.c
'Uncomment for crash, if you are using variable length strings
'PRINT "test.b.u.s = "; test.b.u.s
'PRINT "test.b.u.b = "; test.b.u.b
![[Image: Funktioniert-nur-einmal.jpg]](https://i.ibb.co/hChQ1RF/Funktioniert-nur-einmal.jpg)
