1 Attachment(s)
another test... and some Error
Got an Error! But not related to the current topic but while experimenting with new tB-functions.
This is my testing script, requires the heap-unit below and thinCore.dll above anyway since the unit makes use of the new Array Scan Ptr-functionality
Code:
Uses "console"
#INCLUDE "Heap.tBasicU"
' some simple udt for test
Type t_vec3d
X As Double
Y As Double
Z As Double
SetPos As Function
End Type
Function t_Vec3d.SetPos(ByVal X As Double, ByVal Y As Double, ByVal Z As Double)
Me.X = X
Me.Y = Y
Me.Z = Z
End Function
' ---------------
Dim foo As Heap
' create some space to store different things at foo
foo.AllocLike("Heap", 3)
' first heap at foo shall contain a string
Dim vHeap Like foo.GetType At foo.pData
vHeap.Be("Hello World", "String")
' next heap at foo shall contain some longs
SetAt(vHeap, VarPtr(vHeap) + SizeOf(vHeap))
vHeap.Be(MKL$(1,2,3,4,5), "Long")
' next heap at foo shall contain 3 vecs
SetAt(vHeap, VarPtr(vHeap) + SizeOf(vHeap))
vHeap.allocLike("t_Vec3d", 3)
' fill in some udt-data
Dim vVec Like vHeap.GetType At vHeap.pData
vVec.SetPos(1.1, 1.2, 1.3)
SetAt( vVec, VarPtr(vVec)+ SizeOf(vVec) )
vVec.SetPos(2.1, 2.2, 2.3)
SetAt( vVec, VarPtr(vVec)+ SizeOf(vVec) )
vVec.SetPos(3.1, 3.2, 3.3)
' now reset to first heap
SetAt( vHeap, foo.pData )
While VarPtr(vHeap) < foo.GetEnd
PrintL "Type is " & vHeap.GetType
' replace below
' "HEAP_Get(vHeap.pType)" with "vHeap.GetType()" to have error
'the following line is the one:
Select Case HEAP_Get(vHeap.pType)
Case "STRING"
PrintL "contains :" & vHeap.Is
Case "LONG"
Dim vLong As Long At vHeap.pData
While VarPtr(vLong) < vHeap.GetEnd
PrintL vLong
SetAt(vLong, VarPtr(vLong) + SizeOf(Long))
Wend
Case "T_VEC3D"
SetAt(vVec, vHeap.pData)
While VarPtr(vVec) < vHeap.GetEnd
PrintL "X:" & vVec.X
PrintL "Y:" & vVec.Y
PrintL "Z:" & vVec.Z
SetAt(vVec, VarPtr(vVec) + SizeOf(vVec))
Wend
End Select
' push forward to next heap
SetAt(vHeap, VarPtr(vHeap) + SizeOf(vHeap) )
Wend
PrintL $CRLF & Repeat$(42, "*")
PrintL $CRLF & "Any key to end"
WaitKey
check line 53 of the script.
Code:
Select Case [some type-function-result]
results in crash, no matter if parenthesis used or not. I don't know if that is always the case since i discovered this as a reason of error for the first time
2 Attachment(s)
some speed-test for the new array-scan-ptr
some speedtest to compare the way i used before and now ... and i'm happy about the result,
now needs around 15% to 20% of the time it needed before to find a certain element:
#MinVersion 1.9.13.0 + new thinCore.dll ( attachement a few posts above )
Code:
Uses "console"
' heap-scan-speedtest
Function TBMain()
Local myPtr(&H4000) As DWord
Local i, j As Long
Local startingTime, neededTime As Quad
Local sToFind As String
Randomize
HiResTimer_Init
PrintL "filling in data now..."
For i = 1 To UBound(myPtr)
myPtr(i) = HEAP_AllocByStr("Mississippi" & Hex$(i,8))
Next
' - - - - - - - - - - - - - - - - - - -
PrintL "do 255 scans the old way:"
startingTime = HiResTimer_Get
For i = 1 To 255
sToFind = Ucase$("mississippi" & Hex$(Rnd(1, UBound(myPtr)), 8))
For j = 1 To UBound(myPtr)
If Ucase$(HEAP_Get(myPtr(j))) = sToFind Then
Print "." ' <<< if comment this then <<<
Exit For
EndIf
Next
Next
PrintL
neededTime = HiResTimer_Get - startingtime
PrintL "Time needed : " + Format$(neededTime / 1000000, "#.0000")
PrintL $CRLF & Repeat$(42, "_")
' - - - - - - - - - - - - - - - - - - -
PrintL "now 255 scans the new way:"
startingTime = HiResTimer_Get
For i = 1 To 255
sToFind = Ucase$("mississippi" & Hex$(Rnd(1, UBound(myPtr)), 8))
If Array Scan myPtr Ptr, Collate Ucase, = sToFind Then
Print "." ' <<< comment this too <<<
EndIf
Next
PrintL
neededTime = HiResTimer_Get - startingtime
PrintL "Time needed : " + Format$(neededTime / 1000000, "#.0000")
' - - - - - - - - - - - - - - - - - - -
PrintL $CRLF & Repeat$(42, "*")
PrintL $CRLF & "Any key to end"
WaitKey
End Function
(you may comment lines 30 & 47 to subtract the printing-time)
Results may differ due randomized values to check for, but the felt average on my system = 1.0 / 5.5
1 Attachment(s)
new thinCore.dll leads to crash
when i tried out my current gui-project i discovered that tB instantly crashes on startup. i does not happen if i use the previous thincore-version.
Find array-scan-functions in unit-file GUI.tBasicU, all called like t_GUI.Enum...()
idea for 2 functions: Array Load & Save
working on any type of fixed size array
Code:
#MinVersion 1.9.11.0
Function Array_Load(ByVal sFilename As String, _
ByRef a() As Any _
) As Long
ReDim a(1)
Local lSize As Long = SizeOf(a(1))
Local sData As String = Load_File(sFilename)
If StrPtrLen(StrPtr(sData)) = 0 Then Return 0
ReDim a(StrPtrLen(StrPtr(sData))/lSize)
Memory_Set(VarPtr(a(1)), sData )
Function = UBound(a)
End Function
Function Array_Save(ByVal sFilename As String, _
ByRef a() As Any, _
Optional ByVal FirstElementIndex As Long, _
ByVal numElements As Long _
) As Boolean
If UBound(a) < 1 Then Return FALSE
Local lSize As Long = SizeOf(a(1))
firstElementIndex = MinMax(firstElementIndex, 1, UBound(a) )
If numElements < 1 Then numElements = UBound(a)
numElements = MinMax(numElements, 1, UBound(a) + 1 - FirstElementIndex)
Function = ( Save_File(sFilename, Memory_Get(VarPtr(a(FirstElementIndex)), numElements * lSize)) <> 0 )
End Function
' -------------------------------------------------------------
' test
Uses "console"
Type t_myType
A As Long
B As Byte
C As Double
D As String * 8
End Type
$Filename = APP_ScriptPath & "test.dat"
Dim foo(3) As t_myType
Dim i As Long
' fill in some data
For i = 1 To UBound(foo)
foo(i).a = i * 123
foo(i).b = i
foo(i).c = i * 1.23
foo(i).d = "foo(" & TStr$(i) & ")"
Next
If Not Array_Save($Filename, foo ) Then
PrintL "oops- did not work..."
Else
PrintL "data saved"
' kill data:
ReDim foo(1)
PrintL "memory erased now"
If Not Array_Load($Filename, foo ) Then
PrintL "damn, error on loading!"
Else
PrintL "seems it loaded, let's check data"
For i = 1 To UBound(foo)
PrintL foo(i).d & " :", foo(i).A, foo(i).B, foo(i).c
Next
EndIf
EndIf
WaitKey
side product of some thoughts only...
Petr would name those Array ToFile/FromFile probably ;)
