So, was digging through the wiki and here. Hoping for a command, or a library but is there a simple way to verify input as a filename that won't crash a program with an illegal character?
I had a tutorial user contact me about using the SHARED statement. He was trying to share variables in a subroutine like this:
SHARED a, b, c AS INTEGER
According to the Wiki this is not an alternate method of using SHARED, however, the IDE accepts this form and there is no run-time error either.
Code: (Select All)
DIM AS INTEGER a, b, c
a = 10
b = 20
c = 30
Mysub
SUB Mysub ()
'---------------
' ** Method 1 ** ------------> ** THIS WORKS **
'---------------
'SHARED AS INTEGER a, b, c ' all SHARED on a single line
'---------------
' ** Method 2 ** ------------> ** THIS WORKS **
'---------------
'SHARED a AS INTEGER ' all SHARED on a separate line
'SHARED b AS INTEGER
'SHARED c AS INTEGER
'---------------
' ** Method 3 ** ------------> ** THIS WORKS **
'---------------
'SHARED AS INTEGER a, b ' two different SHARED alternatives
'SHARED c AS INTEGER
'---------------
' ** Method 4 ** ------------> ** THIS DOES -NOT- WORK **
'---------------
'SHARED a, b, c AS INTEGER ' only the value of 'c' is passed, 'a' and 'b' are zero.
'-----------------------------------------------------------------------------------
' Method 4 is not a valid alternative to SHARED listed in the Wiki and should
' therefore not work. However, I would think an error would be generated in the IDE
' or at least at run-time when SHARED is attempted to be used in this manner?
'-----------------------------------------------------------------------------------
PRINT a, b, c
END SUB
Shouldn't method 4 above get flagged somehow as being incorrect?
This is Hex_Maze version 0B. It generates a crude labyrinth using hexes as cells as opposed to a standard orthogonal square grid.
There are a couple subs in it that don't get used in this run but would prove useful in using the hex-grid in a program.
Code: (Select All)
'hex_maze
'by James D. Jarvis Mar. 14,2023
' geneate a haex "maze" in a hex grid as opposed to a more standard orthogonal square grid
'generates a new hexmaze on a keypress press q to exit
Screen _NewImage(1100, 600, 32)
_FullScreen _SquarePixels , _Smooth
Randomize Timer
Dim Shared hexradius
Dim Shared hexborder As _Unsigned Long
hexborder = _RGB32(100, 100, 100)
hexradius = 8 'can be any value but draws cleaner if radius is evenly divisible by 4
maxx = 80: maxy = 40 'maxx is the maxximum number of columns and maxy is the maximum height of a column
Dim Shared map(maxx, maxy)
Dim Shared hgrid(0 To maxx + 1, 0 To maxy + 1, 6)
Do
Cls
For y = 1 To maxy
For x = 1 To maxx
map(x, y) = 1
Next x
Next y
sx = Int(maxx / 5 + Rnd * maxx / 2)
sy = Int(maxy / 5 + Rnd * maxy / 2)
'map(sx, sy) = 0
lastgo = Int(1 + Rnd * 6)
c = 0
clim = 600 + Int((1 + Rnd * 4) * (Rnd * (maxx + maxy))) 'determine how many hex cells will be dug for this hex maze haven't found an ideal ratio yet
hrun = 7
lasthrun = Int(1 + Rnd * 3)
Do
'generate hex maze with a drunken wanderer method. Not a true maze but it will work for a shoot-n-scoot or a roguelike
dgo = Int(1 + Rnd * 8) 'generate direction to send the tunnel
hrun = Int(1 + Rnd * (2 + Sqr(maxy))) 'generate a length for the tunnel being dug
If hrun > Sqr(maxy) Then hrun = lasthrun
If sx = 2 And dgo = 5 Then dgo = 3
If sx = 2 And dgo = 6 Then dgo = 2
If dgo > 6 Then dgo = lastgo
For hgo = 1 To hrun
Select Case dgo
Case 1
If sy - 1 > 1 Then
sy = sy - 1
End If
Case 2
If sx + 1 < maxx Then
If sx Mod 2 Then
If sy - 1 > 1 Then
sx = sx + 1
sy = sy - 1
End If
Else
sx = sx + 1
End If
End If
Case 3
If sx + 1 < maxx Then
If sx Mod 2 Then
sx = sx + 1
Else
If sy + 1 < (maxy - 1) Then
sx = sx + 1
sy = sy + 1
End If
End If
End If
Case 4
If sy + 1 < maxy Then
sy = sy + 1
End If
Case 5
If sx - 1 > 1 Then
If sx Mod 2 Then
If sy - 1 > 1 Then
sx = sx - 1
sy = sy - 1
End If
Else
sx = sx - 1
End If
End If
Case 6
If sx - 1 > 1 Then
If sx Mod 2 Then
sx = sx - 1
Else
If sy + 1 < (maxy - 1) Then
sx = sx - 1
sy = sy + 1
End If
End If
End If
End Select
If map(sx, sy) = 1 Then 'only dig out and count the hex-cell if it is filled
map(sx, sy) = 0
c = c + 1
End If
lastgo = dgo
lasthrun = hrun
Next hgo
Loop Until c >= clim
'draw the hex grid
For y = 1 To maxy
For x = 1 To maxx
If map(x, y) = 1 Then
hexat x, y
hexpaint x, y, _RGB32(200, 200, 200)
End If
Next x
Next y
_Display
Do
_KeyClear
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
Loop Until kk$ = "q"
Sub hexpaint (x, y, hklr As _Unsigned Long)
'paint an arbitrary hex
'hexradius and hexborder defined as shared variables in main program
hr = hexradius
If x Mod 2 Then
Paint ((x * 2) * hr * .75, y * (hr * 1.75)), hklr, hexborder
Else
Paint ((x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875)), hklr, hexborder
End If
End Sub
Sub hexput (sp&, x, y, sscale, hf)
'drop a sprite/image inside a hex , hf is hexfacing given in degrees
'sp& would be an image handle to a sprite created elsewere in program
hr = hexradius
If x Mod 2 Then
RotoZoom23d (x * 2) * hr * .75, y * (hr * 1.75), sp&, sscale, sscale, hf
Else
RotoZoom23d (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), sp&, sscale, sscale, hf
End If
End Sub
Sub hexat (xx, yy)
'draw an arbitrary hex, hexradius and hexborder are shared variables created in main porgram
hr = hexradius
y = yy
x = xx
If x Mod 2 Then
rotpoly (x * 2) * hr * .75, y * (hr * 1.75), hr, 60, 30, hexborder
Else
rotpoly (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), hr, 60, 30, hexborder
End If
End Sub
Sub hexgrid (xx, yy)
'draw a whole empty hexgrid
hr = hexradius
For y = 1 To yy
For x = 1 To xx
If x Mod 2 Then
rotpoly (x * 2) * hr * .75, y * (hr * 1.75), hr, 60, 30, hexborder
Else
rotpoly (x * 2) * hr * .75, y * (hr * 1.75) + (hr * .875), hr, 60, 30, hexborder
End If
Next x
Next y
End Sub
Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
'draw an equilateral polygon (if shapedeg divides evenly into 360) centered on cx and cy
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
Line (cx + x, cy + y)-(cx + x, cy + y), klr
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
Line -(cx + x2, cy + y2), klr
Next
End Sub
'used in hexput to drop a sprite in a hex
Sub RotoZoom23d (centerX As Long, centerY As Long, Image As Long, xScale As Single, yScale As Single, Rotation As Single)
Dim px(3) As Single: Dim py(3) As Single
Wi& = _Width(Image&): Hi& = _Height(Image&)
W& = Wi& / 2 * xScale
H& = Hi& / 2 * yScale
px(0) = -W&: py(0) = -H&: px(1) = -W&: py(1) = H&
px(2) = W&: py(2) = H&: px(3) = W&: py(3) = -H&
sinr! = Sin(-0.01745329 * Rotation): cosr! = Cos(-0.01745329 * Rotation)
For i& = 0 To 3
x2& = (px(i&) * cosr! + sinr! * py(i&)) + centerX: y2& = (py(i&) * cosr! - px(i&) * sinr!) + centerY
px(i&) = x2&: py(i&) = y2&
Next
_MapTriangle (0, 0)-(0, Hi& - 1)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(1), py(1))-(px(2), py(2))
_MapTriangle (0, 0)-(Wi& - 1, 0)-(Wi& - 1, Hi& - 1), Image& To(px(0), py(0))-(px(3), py(3))-(px(2), py(2))
End Sub
I remember once hearing about a project in which they hard-coded some paths in a javascript program. When testing the program in the test environment, those paths had to be changed for the test server.
When the program would be approved for production, they would change the hard-coded paths for the production server before deploying the program to the production server.
And then everybody, I.T. and users, were confused when one day the production system no longer had a whole bunch of records. They had, of course, forgotten to change the paths in the source code before deploying to production, so the production application was hard-coded to look for things on the test server.
Dumb.
First, do not hard-code. But if you must (or if for any reason a part of a program ought to behave one way in one environment and a different way in the other, the best thing to have is all of that being in the one file, and have the behaviour of the file change depending on the current environment.
Type element
tag As String * 10
value As String * 10
End Type
Dim Shared aa(10) As element
Dim Shared aalast ' Last occupied AA() element
setvalue "foo", "bar"
setvalue "foo", "coffee"
Print getvalue$("foo") ' prints bar also after adding coffee
End
Function getvalue$ (tag As String)
tag = LTrim$(RTrim$(tag))
tag = tag + String$(10 - Len(tag), " ")
For i = 0 To aalast
If (tag = aa(i).tag) Then
getvalue$ = aa(i).value
Exit Function
End If
Next
End Function
Sub setvalue (tag As String, value As String)
aa(aalast).tag = tag
aa(aalast).value = value
aalast = aalast + 1
End Sub
this code has been taken from this article on this webpage QBHash
this demo is very simple and with many limitations that cannot let us think about it like a real dictonary data structure.
What is the data structure coded has these features: you can store more than one value linked to the tag value; moreover these collisions (new values linked to the tag) are stored into different cells of the array. The author to get this result used an external index/counter (AALAST). In the while the GetValue SUB is broken because it returns only the first value linked to the string index.
However here more information.
Issues:
1 the value stored can fit only 10 characters (ASCII values)
Code: (Select All)
Type element
tag As String * 10 ' <----- hash value stored as a string of 10 characters that is searched sequentially
value As String * 10 '<----- max 10 character for value
End Type
2 the hash index is not direct but searched rowly from the start to the end of arrayList
Code: (Select All)
Function getvalue$ (tag As String)
tag = LTrim$(RTrim$(tag))
tag = tag + String$(10 - Len(tag), " ")
For i = 0 To aalast
If (tag = aa(i).tag) Then
getvalue$ = aa(i).value
Exit Function
End If
Next
End Function
3 the store value routine does not avoid that the hashindex value has no duplicates.
Code: (Select All)
Sub setvalue (tag As String, value As String)
aa(aalast).tag = tag
aa(aalast).value = value
aalast = aalast + 1
End Sub
4 the search value routine get the first cell of the array that has the hashvalue searched
Code: (Select All)
If (tag = aa(i).tag) Then
getvalue$ = aa(i).value
Exit Function
End If
Anyone know a good source for math (or even code) for designing non-orthogonal grids? I did a searches on two different search engines and was not impressed with the results.
So, during my rewrite I am condensing the number of files needed by having all (or most) of my menus printed. I tried my orignal font I was using and saw it was cutting off the top and bottoms of some letters. I also tried some cursive fonts (only one seemed to work but it also cut the top and bottoms of some letters) and seems that compiler doesn't like that and puts space between words. Or maybe I am doing something wrong as well. Just want to see what y'all think about it.
You can see that capital J and Y are cut and lower f, j, q, and y are also cut.
Nothing fancy done to the code. I will include the font as well if you want to try it out. I have been trying fonts from Google: https://fonts.google.com so I assume the fonts are ok...
For a guy who was so active on this forum daily to be completely inactive for many months, I feel the loss. I was wondering if it might be an idea to have a Wall of Fame, for those who have contributed so much and are gone. Maybe Pete could have his own Prolific Programmer where we could access all his witty posts and code suggestions. Or, if not all his posts. then a selection of those that captured his talent and wit. Maybe it's too early to even consider this as we have many examples of coders who disappear for many months and turn up again. Maybe a Wall of Fame would be for those who we know are no longer with us.
Posted by: Petr - 03-12-2023, 10:14 AM - Forum: Petr
- Replies (2)
Input values are considered in the range -1 to 1, the input is not guarded (internal checking is disabled) so using higher values will render outside the intended range. I think it might be useful for someone.
Code: (Select All)
_Title "Running Graph"
'Wroted by Petr Preclik, 11.March 2023
Type RG
position As Integer
SO As Long 'array in array StartOffset for RG_HELPER
Recs As Long 'how much records graph contains (record lenght in array RG_Helper)
End Type
ReDim Shared RG(0) As RG
ReDim Shared RG_Helper(0) As Single
Screen _NewImage(800, 600, 256)
test = NewRG(1, 500)
test2 = NewRG(1, 203)
test3 = NewRG(1, 300) 'test, test2, test3 is returned index record from array RG
Do
i = i + .1
j = j + .012
t = Sin(i)
UpdateRG test, t 'update values in array RG_Helper using array RG in RG_Helper SUB
v = Cos(j)
UpdateRG test2, v
UpdateRG test3, (v + t) 'both previous
ShowRG 100, 150, test, "Sinus"
ShowRG 100, 300, test2, "Cosinus" 'Draw it - use RG array to drive RG_Helper array and show values RG_Helper array on the screen
ShowRG 100, 450, test3, "Both mixed"
_Display
_Limit 200
Loop
Function NewRG (value, records) 'create new graph handle, reserve place in RG_Helper, write to RG_Helper array first value and this value position in RG_Helper array
u = records
u2 = UBound(RG_Helper)
u3 = UBound(RG)
RG(u3).SO = u2
RG(u3).Recs = u
RG(u3).position = 1
NewRG = u3
RG_Helper(u2) = value
ReDim _Preserve RG_Helper(u2 + u + 1) As Single
ReDim _Preserve RG(u3 + 1) As RG
End Function
Sub UpdateRG (identity, value) ' update and shift values in RG_Helper array using RG array (identity is RG array index)
Id = identity
V = value
If RG(Id).position < RG(Id).Recs Then
RG(Id).position = RG(Id).position + 1
i2 = RG(Id).position
u = RG(Id).SO
RG_Helper(u + i2) = value
Exit Sub
Else
shift = RG(Id).SO
Do Until shift = RG(Id).SO + RG(Id).Recs
RG_Helper(shift) = RG_Helper(shift + 1)
shift = shift + 1
Loop
RG_Helper(RG(Id).SO + RG(Id).Recs) = value
End If
End Sub
Sub ShowRG (x, y, id, index$) ' Draw graph to screen
xx = x
s2 = RG(id).Recs
s = RG(id).SO
_PrintMode _KeepBackground
p = xx - 10 + s2 / 2 - _PrintWidth(index$) / 2 'printstring X
Line (xx - 20, y - 70)-(xx + 20 + s2, y + 50), 30, BF
Line (xx - 17, y - 67)-(xx + 17 + s2, y + 47), , B
C = _DefaultColor
Color 0
_PrintString (p, y - 64), index$
Color C
_PrintMode _FillBackground
Line (xx - 20, y - 70)-(xx + 20 + s2, y + 50), , B
Line (xx - 17, y - 47)-(xx + 17 + s2, y + 47), , B
ss = s
Do Until ss = s2 + s - 1
v = RG_Helper(ss)
v2 = RG_Helper(ss + 1)
GoTo notthis
If Abs(v) > 1 Then
Do Until Abs(v) <= 1
v = v / 2
Loop
End If
notthis:
xx = xx + 1
Line (xx, y + v * 15)-(xx + 1, y + v2 * 15), 0
ss = ss + 1
Loop
xx = 0
End Sub
![[Image: image.png]](https://i.ibb.co/QFN4Mxz/image.png)
![[Image: Runnig-Graph.png]](https://i.ibb.co/ssRvY4d/Runnig-Graph.png)
