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.
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
Well hello again, I'm here with another bit of code, I was pondering the idea of a way to add serial codes and code checks to my programs, and this is what i came up with to generate a serial number>
Code: (Select All)
Function genCode$
Dim As Single one, two, three: one = 8: two = 7: three = 4
Dim code As String
'1
Do
For i = 1 To 5
x$ = x$ + _Trim$(Str$(Int(Rnd * 10)))
Next
If Val(x$) Mod one = 0 Then
Exit Do
Else
x$ = ""
End If
Loop
code = x$
x$ = ""
'2
Do
For i = 1 To 7
x$ = x$ + _Trim$(Str$(Int(Rnd * 10)))
Next
If Val(x$) Mod two = 0 Then
Exit Do
Else
x$ = ""
End If
Loop
code = code + "-" + x$
x$ = ""
'3
Do
For i = 1 To 5
x$ = x$ + _Trim$(Str$(Int(Rnd * 10)))
Next
If Val(x$) Mod three = 0 Then
Exit Do
Else
x$ = ""
End If
Loop
and this is what checks to see if the code is valid, and then returns a 1 for valid and a 0 for invalid>
Code: (Select All)
Function checkcode (d As String)
Dim As Single one, two, three: one = 8: two = 7: three = 4
Dim As String a, b, c
If InStr(d, "-") = 0 Then
a = Mid$(d, 1, 5)
b = Mid$(d, 6, 7)
c = Mid$(d, 13, 5)
Print a, b, c
End If
a = Left$(d, InStr(d, "-") - 1)
b = Mid$(d, InStr(d, "-") + 1, 7)
c = Right$(d, 5)
If Val(a) Mod one = 0 And Val(b) Mod two = 0 And Val(c) Mod three = 0 Then
If d = "" Then checkcode = 0: Exit Function
checkcode = 1
Else
checkcode = 0
End If
End Function
I have heard in the air a spealing that said "Bubble sort!"
It let me remember a old fashioned book of programming in Pascal. An just then this the "bubble gum".
So while I go to Psychoanalyst to set up better my mind here a Demonstration of different ways to build up a Bubble Sort routine...
in sum their are seven different routines... the first is the classical version, then it follows the last_index decreasing, the last_index swaped, the split & compact with different dimensions for splitting and one of the two index optimized manners...
run and choose you preferred BUBBLE SORT algorithm...
here I show the result got running the following code
and here the code:
Code: (Select All)
Const max = 32767
Randomize Timer
Type DATATYPE
a As Integer
b As Integer
c As Integer
End Type
ReDim SortedList(1 To max) As DATATYPE, t(1 To max) As DATATYPE
'The sort will only be done on the value of 'a' (SortedList().a) and the values can range from 1 to 32767.
init SortedList() ' this is the original array created at random
initT SortedList(), t() ' this copies the first array into the second array
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble t()
Print t(1).a, t(max - 1).a, t(max).a
Color 1
Print " Bubble 1 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t() ' so we use the identical array to be ordered
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble2 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 2
Print " Bubble 2 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble3 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 3
Print " Bubble 3 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble4 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 4
Print " Bubble 4 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble5 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 5
Print " Bubble 5 order"
Print (Timer(.001) - t#)
Color 7
initT SortedList(), t()
Print "output the first and the last 2 items ";
Print t(1).a; " "; t(max - 1).a; " "; t(max).a
t# = Timer(.001)
Print "ordering...";
bubble6 t()
Print t(1).a, t(max - 1).a, t(max).a
Color 6
Print " Bubble 6 order"
Print (Timer(.001) - t#)
Color 7
End
Sub bubble (a() As DATATYPE)
' bubblesort
' we compare 2 sequential elements of a set of elements until no swap has been performed
' while the first element is higher/lower (increasing/decreasing order) than the second element we swap the 2 elements
NoSwap = 0
While NoSwap = 0
NoSwap = -1
For count = 1 To max - 1
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0
Next count
Wend
End Sub
Sub bubble2 (a() As DATATYPE)
' bubblesort
' we compare 2 sequential elements of a set of elements until no swap has been performed
' but we ignore the last elements because they has been already ordered
' while the first element is higher/lower (increasing/decreasing order) than the second element we swap the 2 elements
NoSwap = 0
Fmax = max
While NoSwap = 0
NoSwap = -1
Fmax = Fmax - 1
For count = 1 To Fmax
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0
Next count
Wend
End Sub
Sub bubble3 (a() As DATATYPE)
' bubblesort
' we compare 2 sequential elements of a set of elements until no swap has been performed
' but we ignore the last elements because they has been already ordered by swap
' while the first element is higher/lower (increasing/decreasing order) than the second element we swap the 2 elements
NoSwap = 0
Last = max - 1
While NoSwap = 0
NoSwap = -1
For count = 1 To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0: Last = count
Next count
Wend
End Sub
Sub bubble4 (a() As DATATYPE)
' this is multibubble
' we split the array if too big into many subarray ordered by bubble sort
' using as max bubble dimension to order 3200 item for array
stepB = UBound(a) / 3200
For index = 1 To (UBound(a) - stepB) Step stepB
' bubble2 type
NoSwap = 0
First = index
Last = index + stepB - 1
While NoSwap = 0
NoSwap = -1
Last = Last - 1
For count = First To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0
Next count
Wend
Next
bubble2 a() ' the last ordering operation
End Sub
Sub bubble5 (a() As DATATYPE)
' this is multibubble
' we split the array if too big into many subarray ordered by bubble sort
' using as max bubble dimension to order 100 item for array
stepB = UBound(a) / 100
For index = 1 To (UBound(a) - stepB) Step stepB
' bubble3 type
NoSwap = 0
First = index
Last = index + stepB - 1
While NoSwap = 0
NoSwap = -1
For count = First To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0: Last = count
Next count
Wend
Next
bubble3 a() ' the last ordering operation
End Sub
Sub bubble6 (a() As DATATYPE)
' this is multibubble
' we split the array if too big into many subarray ordered by bubble sort
' using as max bubble dimension to order 1000 item for array
stepB = UBound(a) / 1000
For index = 1 To (UBound(a) - stepB) Step stepB
' bubble3 type
NoSwap = 0
First = index
Last = index + stepB - 1
While NoSwap = 0
NoSwap = -1
For count = First To Last
If a(count).a > a(count + 1).a Then Swap a(count), a(count + 1): NoSwap = 0: Last = count
Next count
Wend
Next
bubble3 a() ' the last ordering operation
End Sub
Sub initT (b() As DATATYPE, a() As DATATYPE)
For count = 1 To max
a(count).a = b(count).a
Next count
End Sub
Sub init (a() As DATATYPE)
For count = 1 To max
a(count).a = (Rnd * max - 1) + 1
Next count
End Sub
Sub ShowArray (A() As DATATYPE)
For count = 1 To max
Print A(count).a
Next count
End Sub
Here's a couple routines to create randomly varying brickfill patterns. There are briefer and mathematically slicker ways to do simple brick patterns but if you want to add a little variation in color and style the code can get a little longer. If you can make use of it feel free.
Code: (Select All)
'linebricks
'playing with brick patterns drawn with the line command
'fills whole screen and 2 other area with a colored brick pattern that can randomly vary from brick to brick
'press any key for brickish wonder or esc to quit
Screen _NewImage(800, 500, 32)
_Title "Linebricks a brickfill demo"
Randomize Timer
Do
'this randomly sey bw (brick width) bh (brick height) and mw (mortar width) for the purposes of demonstration
bw = 4 + 4 * Int(Rnd * 8)
bh = (bw * 3) / 5
mw = bh / (4 + Rnd * 8)
If mw < .5 Then mw = .5
brickfill 0, 0, _Width, _Height, bw, bh, mw, _RGB32(240, 40, 40), _RGB32(100, 100, 100), 49, 12
brickfill 0, 0, 200, 150, bw, bh, mw, _RGB32(40, 40, 40), _RGB32(100, 100, 100), 50, 6
brickfill 200, 160, 400, 350, bw * 2, bh * 2, mw, _RGB32(40, 240, 40), _RGB32(100, 100, 100), 20, 10
Loop Until waitanykey$ = Chr$(27)
Function waitanykey$
_KeyClear
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
waitanykey$ = kk$
End Function
Sub brick (x, y, w, h, mwid, brickcolor As _Unsigned Long, mortarcolor As _Unsigned Long, cv)
'draw a brick
'each brick has color variation randomly picked in side the raneg defiend by cv
'each brick may be randonly standard, have a lightened highlight or a deep shadow and a higlight
Dim tcolor As _Unsigned Long
tred = _Red32(brickcolor) + Int(Rnd * cv) - Int(Rnd * cv)
tgreen = _Green32(brickcolor) + Int(Rnd * cv) - Int(Rnd * cv)
tblue = _Blue32(brickcolor) + Int(Rnd * cv) - Int(Rnd * cv)
If tred < 0 Then tred = 0
If tgreen < 0 Then tgreen = 0
If tblue < 0 Then tblue = 0
If tred > 255 Then tred = 255
If tgreen > 255 Then tgreen = 255
If tblue > 255 Then tblue = 255
tcolor = _RGB32(tred, tgreen, tblue)
Line (x, y)-(x - 1 + w, y - 1 + h), mortarcolor, BF
Select Case Int(1 + Rnd * 14)
Case 1, 2, 3, 4, 5, 6 'plain brick
Line (x + mwid, y + mwid)-(x - 1 + w - mwid, y - 1 + h - mwid), tcolor, BF
Case 7, 8 'sahdow and highlight brick
tred = tred - Int(cv / 2 + Rnd * cv)
tgreen = tgreen - Int(cv / 2 + Rnd * cv)
tblue = tblue - Int(cv / 2 + Rnd * cv)
If tred < 0 Then tred = 0
If tgreen < 0 Then tgreen = 0
If tblue < 255 Then tblue = 0
tcolor = _RGB32(tred, tgreen, tblue)
Line (x + mwid, y + mwid)-(x - 1 + w - mwid, y - 1 + h - mwid), tcolor, BF
tred = tred + Int(2 + Rnd * cv)
tgreen = tgreen + Int(2 + Rnd * cv)
tblue = tblue + Int(2 + Rnd * cv)
If tred > 255 Then tred = 255
If tgreen > 255 Then tgreen = 255
If tblue > 255 Then tblue = 255
tcolor = _RGB32(tred, tgreen, tblue)
sv = (10 + Rnd * 20) / 10
Line (x + (mwid * sv), y + mwid)-(x - 1 + w - mwid, y - 1 + h - (mwid * sv)), tcolor, BF
Case Else 'highlight brick
Line (x + mwid, y + mwid)-(x - 1 + w - mwid, y - 1 + h - mwid), tcolor, BF
tred = tred + Int(Rnd * (cv * .65))
tgreen = tgreen + Int(Rnd * (cv * .65))
tblue = tblue + Int(Rnd * (cv * .65))
If tred > 255 Then tred = 255
If tgreen > 255 Then tgreen = 255
If tblue > 255 Then tblue = 255
tcolor = _RGB32(tred, tgreen, tblue)
sv = (10 + Rnd * 20) / 10
Line (x + (mwid * sv), y + mwid)-(x - 1 + w - mwid, y - 1 + h - (mwid * sv)), tcolor, BF
End Select
End Sub
Sub brickfill (sx, sy, ex, ey, bw, bh, mwid, brickcolor As _Unsigned Long, mortarcolor As _Unsigned Long, cv, crackrange)
'crackrange is the raw maximum rnd range used to add cracks to the wall
Dim zag(1 To 10, 1 To 2)
b = 0
For y = sy To ey Step bh
b = b + 1
For x = sx To ex Step bw
If b Then
brick x - (bw \ 2), y, bw, bh, mwid, brickcolor, mortarcolor, cv
Else
brick x, y, bw, bh, mwid, brickcolor, mortarcolor, cv
End If
Next x
If b = 1 Then b = -1
Next y
cracks = Int(Rnd * crackrange)
For c = 1 To cracks
cx = Int(sx + Rnd * (ex - sx)): cy = Int(sy + Rnd * (ey - sy))
zag(1, 1) = cx: zag(1, 2) = cy
xshift = Int(-3 + Rnd * 6)
yshift = Int(-3 + Rnd * 6)
If xshift = 0 Then xshift = -1
If yshift = 0 Then yshift = -1
For z = 2 To 10
zag(z, 1) = zag(z - 1, 1) + xshift * Int(Rnd * ((ex - sx) / 20))
zag(z, 2) = zag(z - 1, 2) + yshift * Int(Rnd * ((ey - sy) / 20))
Next z
For z = 1 To 9
If zag(z, 1) > 0 And zag(z, 2) > 0 Then
If zag(z + 1, 1) <= ex And zag(z + 1, 2) <= ey Then Line (zag(z, 1), zag(z, 2))-(zag(z + 1, 1), zag(z + 1, 2)), _RGB32(90, 90, 90)
End If
Next z
Next c
End Sub
So is it me, my screen, an optical resolution, or how _putimage works that leads to me not actually getting square pixels with this little bit of code? The red dots created at 15,15 and 16,16 in the sample image just aren't the same size when I run this code:
Ok, so this is probably quite simple, but it's frustrating the heck out of me! This is A.jpg
(Please try to keep response simple).
Code: (Select All)
Screen _NewImage(1000, 800, 256)
Print "Why is line 8 returning Illegal function call?"
Sleep 2
h = 200: v = 200 ' horiz and vert position for pic
ReDim pic(4) As Long
im(1) = _LoadImage("RecPics/" + Chr$(65) + ".jpg")
Print: Print "im(1) is"; im(1); " (if less than -1, this handle should be ok)"
_PutImage (h, v), im(1)
Sleep
_FreeImage (im(1))
![[Image: Runnig-Graph.png]](https://i.ibb.co/ssRvY4d/Runnig-Graph.png)
![[Image: image.png]](https://i.ibb.co/NNJf6gz/image.png)
![[Image: A.jpg]](https://i.ibb.co/JvkNNYb/A.jpg)
