| Welcome, Guest |
You have to register before you can post on our site.
|
|
|
| READ$/Data Slow |
|
Posted by: Brent F Boshart - 11.10.2025, 12:55 AM - Forum: PowerBASIC for Windows
- Replies (4)
|
 |
I have some data that I want to keep embedded in the code instead of an external file. This takes about 4 seconds to execute (the routines formatStarRA, formatStarDec and J2000Topo only account for about 0.3 seconds). I could make each line (element) one string padding with spaces and then using mid$ to parse it out. That would be 2400 READ$ instead of 2400*11. Any other suggestions to speed this up?
FUNCTION DoubleStarLoad AS LONG
LOCAL t AS LONG
LOCAL tempRA, TempDec AS DOUBLE, dummy AS STRING
FOR t= 0 TO 2399
DoubleStarData(t).CST=READ$((t)*11+1)
DoubleStarData(t).ObjName=READ$((t)*11+2)
DoubleStarData(t).SAO=READ$((t)*11+3)
tempRA=formatStarRA(READ$((t)*11+4))
tempDec=formatStarDec(READ$((t)*11+5))
J2000Topo(tempRA,tempDec)
DoubleStarData(t).RA=tempRA
DoubleStarData(t).Dec=tempDec
DoubleStarData(t).Magnitude1=READ$(t*11+6)
DoubleStarData(t).Magnitude2=READ$(t*11+7)
DoubleStarData(t).Spectral=READ$(t*11+9)
DoubleStarData(t).Distance=VAL(READ$(t*11+10))
DoubleStarData(t).Separation=READ$(t*11+11)
NEXT t
DATA "Aqr","1 Aqr","126062","20:39:25","+00:29:11","5.27","12.3","7.03","K0III","71.48","65"
DATA "Ari","1 Ari","74966","01:49:50","+22:15:45","16","17","1","M3.7+M4.2","","17.5"
DATA "Ari","1 Ari","74966","01:50:09","+22:16:30","6.33","7.21","0.88","G3III","179.53","2.9"
DATA "Boo","1 Boo","82942","13:40:40","+19:57:20","5.76","9.6","3.84","A1V","100.6","4.4"
DATA "Cam","1 Cam","24672","04:32:02","+53:54:39","5.78","6.82","1.04","B0III","217.39","10.4"
DATA "Del","1 Del","106172","20:30:18","+10:53:45","6.2","8.02","1.82","Be+B","227.79","0.9"
DATA "Dra","1 Dra","15532","11:31:07","+69:24:00","14.3","14.8","0.5","","","1.2"
....
END FUNCTION
|
|
|
| 7zip alternatives ? |
|
Posted by: Johan Klassen - 08.10.2025, 08:10 AM - Forum: This and that - friendly chat
- Replies (4)
|
 |
I noticed that when I was 7zip compressing a 300GB folder the CPU would stay very close to 100% and the CPU temperature was about 70c
I don't want to burn-up my CPU!
I don't want to run the CPU this high for hours on end, 50% usage and 50c is reasonable, any 7zip alternatives recommendations ?
|
|
|
|
| Doubly Linked String/WString List (Parser?) |
|
Posted by: Stanley Durham - 05.10.2025, 10:15 AM - Forum: Source Code Library
- Replies (2)
|
|
Compiler? Do you write a compiler or parse code for an existing compiler?
Two versions, String or WString. No dependencies. Fast, get 1,0000,000 values in less than 1/10 of a second.
This is something I did thinking it might be useful for parsing code. It’s a list, queue, stack and deque. You can push, peek pop from front or back.
But it also has a cursor that can be moved forward and backwards. The cursor position also acts as a queue, stack and deque. You can push, peek, pop and delete before and after cursor position. The cursor can save its position one time; you can move around and then return.
Supports Split/Join.
It can load a text file and be saved as a text file (code file). WString version uses UTF8.
It can be stored/restored to/from file, binary format.
It can get a list of files, folders, sub-folders and all files in sub-folders matching a mask.
There are probably a lot better tools out there, but simplicity appeals to me. It seems like each different tool is a whole new programming language to learn. And different versions of the same type of compiler have different tools.
The idea is that you have an input and output list containing lines of code. One or more temporary list can be used to split a line of code apart. Push the output to the output list.
It’s an allocated container, must call …New() before use. Call PtrFree(p) to free handle or pointer. Errors are logged if %LogOnError is defined. Message on error if %MessageOnError is defined. You can use the ExitIf() macro to log parsing errors.
It might be useful, might not.
Code: 'StrList.inc
'Public domain, use at own risk. SDurham
'Function StrListNew() As Long
'allocate new instance : return container pointer : call PtrFree(p) to free pointer
'Sub StrListClear(ByVal p As StrListT Ptr)
'empty container
'Function StrListCount(ByVal p As StrListT Ptr) As Long
'get item count
'Sub StrListAdd(ByVal p As StrListT Ptr, ByRef value As String)
'append value
'Function StrListCursor(ByVal p As StrListT Ptr) As Long
'true/false if cursor valid
'Function StrListFirst(ByVal p As StrListT Ptr) As Long
'move cursor to first node : true/false success
'Function StrListNext(ByVal p As StrListT Ptr) As Long
'move cursor to next node : true/false success
'Function StrListLast(ByVal p As StrListT Ptr) As Long
'move cursor to last node : true/false success
'Function StrListPervious(ByVal p As StrListT Ptr) As Long
'move cursor to previous node : true/false success
'Function StrListRember(ByVal p As StrListT Ptr) As Long
'remember cursor position : fail if cursor null : true/false success
'Function StrListReturn(ByVal p As StrListT Ptr) As Long
'return to remembered position : fail if node deleted : true/false success
'Function StrListGet(ByVal p As StrListT Ptr) As String
'get value at cursor position : null if cursor null
'Function StrListSet(ByVal p As StrListT Ptr, ByRef value As String) As Long
'set value at cursor position : fail if cursor null : true/false success
'Function StrListDeleteForward(ByVal p As StrListT Ptr) As Long
'move to next node and delete node at cursor position : fail if cursor null : true/false success
'cursor will be null if no next node
'Function StrListDeleteBackward(ByVal p As StrListT Ptr) As Long
'move to previous node and delete node at cursor position : fail if cursor null : true/false success
'cursor will be null if no previous node
'Function StrListIsBefore(ByVal p As StrListT Ptr) As Long
'true/false if there is a node before cursor position
'Function StrListIsAfter(ByVal p As StrListT Ptr) As Long
'true/false if there is a node after cursor position
'Function StrListDeleteBefore(ByVal p As StrListT Ptr) As Long
'delete node before cursor position : fail if cursor null or no previous node : true/false success
'Function StrListDeleteAfter(ByVal p As StrListT Ptr) As Long
'delete node after cursor position : fail if cursor null or no next node : true/false success
'Function StrListPushBefore(ByVal p As StrListT Ptr, ByRef value As String) As Long
'add value before cursor position : fail if cursor null : true/false success
'Function StrListPushAfter(ByVal p As StrListT Ptr, ByRef value As String) As Long
'add value after cursor position : fail if cursor null : true/false success
'add value before cursor position : fail if cursor null : true/false success
'Function StrListPeekBefore(ByVal p As StrListT Ptr) As String
'get value before cursor position : null if cursor invalid or no previous node
'Function StrListPeekAfter(ByVal p As StrListT Ptr) As String
'get value after cursor position : null if cursor invalid or no next node
'Function StrListPopBefore(ByVal p As StrListT Ptr) As String
'get and remove value before cursor position : null if cursor invalid or no previous node
'Function StrListPopAfter(ByVal p As StrListT Ptr) As String
'get and remove value after cursor position : null if cursor invalid or no next node
'Sub StrListPushFirst(ByVal p As StrListT Ptr, ByRef value As String)
'insert at front
'Sub StrListPushLast(ByVal p As StrListT Ptr, ByRef value As String)
'append to end
'Function StrListPeekFirst(ByVal p As StrListT Ptr) As String
'get fist value : null if list empty
'Function StrListPeekLast(ByVal p As StrListT Ptr) As String
'get last value : null list empty
'Function StrListPopFirst(ByVal p As StrListT Ptr) As String
'get and remove fist value : null if list empty
'Function StrListPopLast(ByVal p As StrListT Ptr) As String
'get and remove last value : null if list empty
'Sub StrListImport(ByVal p As StrListT Ptr, a() As String)
'import PB array
'Sub StrListExport(ByVal p As StrListT Ptr, a() As String)
'export to PB array
'Sub StrListSplit(ByVal p As StrListT Ptr, ByVal delimited As String, ByVal delimiter As String)
'split array on delimited string
'Function StrListJoin(ByVal p As StrListT Ptr, ByVal delimiter As String) As String
'join array on delimiter
'Sub StrListToText(ByVal p As StrListT Ptr, ByVal file As WString)
'store list as text file
'Sub StrListFromText(ByVal p As StrListT Ptr, ByVal file As WString)
'load text file
'Sub StrListFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)
'get all folders in root folder
'Sub StrListFiles(ByVal p As StrListT Ptr, ByVal folder As String, ByVal mask As String)
'get all files in folder matching mask
'Sub StrListAllFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)
'get all folders in root folder and sub-folders, including root folder
'Sub StrListAllFiles(ByVal p As StrListT Ptr, ByVal rootFolder As String, ByVal mask As String)
'get all files in root folder, and sub-folders, matching mask
'Function StrListStore(ByVal p As StrListT Ptr) As String
'store container to String
'Sub StrListRestore(ByVal p As StrListT Ptr, ByRef stored As String)
'restore container from String
'Sub StrListFileStore(ByVal p As StrListT Ptr, ByVal file As WString)
'store container to File
'Sub StrListFileRestore(ByVal p As StrListT Ptr, ByVal file As WString)
'restore container from File
#If Not %Def(%ExitIf240526)
%ExitIf240526 = 1
'----------------------------------------------------------------------
'Error Exit Macro
'Exit procedure with error message
'if %LogOnError defined then errors logged to app folder
'if %MessageOnError defined then message on error
'if %HaltOnError defined then app halt with message on error
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
%ExitIfErr = 151
'----------------------------------------------------------------------
Macro ExitIf(test, message, exitWhat)
If test Then
ExitLog FuncName$ + "() " + message
Error %ExitIfErr
Exit exitWhat
End If
End Macro
Macro ExitF(test, message) = ExitIf(test, message, Function)
Macro ExitS(test, message) = ExitIf(test, message, Sub)
Macro ExitM(test, message) = ExitIf(test, message, Method)
Macro ExitP(test, message) = ExitIf(test, message, Property)
Macro ExitMC(test, message) = ExitIf(test, message, Macro)
'GoTo with error message
Macro GoToIf(test, message, goWhere)
If test Then
ExitLog FuncName$ +": "+ message
Error %ExitIfErr
GoTo goWhere
End If
End Macro
'----------------------------------------------------------------------
Sub ExitLog(ByVal message As String) Private
Local h As Long
h = FreeFile
#If %Def(%LogOnError) Or %Def(%MessageOnError) Or %Def(%HaltOnError)
Open Exe.Path$+"Error.log" For Append As h
If Lof(h) < 16000 Then
Print# h, Date$ +", "+ Time$ +", "+ Exe.Full$ +", "+ message
End If
Close h
#EndIf
#If %Def(%MessageOnError) Or %Def(%HaltOnError)
? message,,"Error!"
#EndIf
#If %Def(%HaltOnError)
End
#EndIf
End Sub
'----------------------------------------------------------------------
#EndIf '%ExitIf240526
#If Not %Def(%Memory230925)
%Memory230925 = 1
'----------------------------------------------------------------------
'Memory Allocation
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
Declare Function GlobalAlloc Lib "Kernel32.dll" Alias "GlobalAlloc" (ByVal uFlags As Dword, ByVal dwBytes As Dword) As Dword
Declare Function GlobalReAlloc Lib "Kernel32.dll" Alias "GlobalReAlloc" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword
Declare Function GlobalFree Lib "Kernel32.dll" Alias "GlobalFree" (ByVal hMem As Dword) As Dword
%MEMFIXED = &H0000 : %MEMMOVEABLE = &H0002 : %MEMZEROINIT = &H0040 : %MEMGPTR = (%MEMZEROINIT Or %MEMFIXED)
'----------------------------------------------------------------------
Function MemAlloc(ByVal bytes As Long) As Long
'allocate memory
If bytes Then Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)
End Function
'----------------------------------------------------------------------
Function MemReAlloc(ByVal hMem As Long, ByVal bytes As Long) As Long
'reallocate new size
If hMem And bytes Then
Function = GlobalReAlloc(ByVal hMem, ByVal bytes, ByVal %MEMMOVEABLE Or %MEMZEROINIT)
ElseIf bytes Then
Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)
ElseIf hMem Then
Function = GlobalFree(ByVal hMem)
End If
End Function
'----------------------------------------------------------------------
Function MemFree(ByVal hMem As Long) As Long
'free memory
If hMem Then GlobalFree(ByVal hMem)
End Function
'----------------------------------------------------------------------
#EndIf '%Memory230925
#If Not %Def(%Ptr250717)
%Ptr250717 = 1
'----------------------------------------------------------------------
'Allocate UDT Pointer
'PtrT must be first item in UDT
'call PtrNew() to allocate pointer
'call PtrFree() to free pointer
'if PtrNewCallback() supplied then called after memory allocated
'if PtrFinalCallback() supplied then called before memory freed
'instance count supported but shouldn't be used unless needed
'should be made clear who is responsible for freeing pointer
'----------------------------------------------------------------------
Declare Sub PtrNewCallback(ByVal p As Long)
'if supplied then called after ponter allocated
Declare Sub PtrFinalCallback(ByVal p As Long)
'if supplied then called before ponter freed
Declare Function PtrStoreCallback(ByVal p As Long) As String
'return String holding pointer's associated data
Declare Function PtrRestorCallback(ByRef stored As String) As Long
'return new instance with data restored
'----------------------------------------------------------------------
%PtrTag = 648910727
Type PtrT
tag As Long
instances As Long
finalCB As Long
End Type
'----------------------------------------------------------------------
Function PtrNew(ByVal SizeOfUdt As Long, ByVal newCB As Long, ByVal finalCB As Long) As Long
'allocate new pointer instance : return pointer
'if new callback supplied then called after memory allocated
'if final callback supplied then called before memory freed
Local p As PtrT Ptr
ExitF(SizeOfUdt < SizeOf(PtrT), "invalid size")
p = MemAlloc(SizeOfUdt)
If p Then
@p.tag = %PtrTag
@p.instances = 1
@p.finalCB = finalCB
If newCB Then Call Dword newCB Using PtrNewCallback(p)
Function = p
End If
End Function
'----------------------------------------------------------------------
Function PtrFree(ByVal p As PtrT Ptr) As Long
'free pointer allocated by PtrNew() : return null
'if final callback was supplied then called before memory freed
If p Then
ExitF(@p.tag <> %PtrTag, "invalid ptr")
ExitF(@p.instances < 1, "invalid instance count")
Decr @p.instances
If @p.instances = 0 Then
If @p.finalCB Then Call Dword @p.finalCB Using PtrFinalCallback(p)
MemFree(p)
End If
End If
End Function
'----------------------------------------------------------------------
Sub PtrIncr(ByVal p As PtrT Ptr)
'increment instance count
ExitS(p = 0 Or @p.tag <> %PtrTag, "invalid ptr")
Incr @p.instances
End Sub
'----------------------------------------------------------------------
#EndIf '%Ptr250717
#If Not %Def(%StrBuild250811)
%StrBuild250811 = 1
'----------------------------------------------------------------------
'String Builder
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
%BytSize = 1
%StrBuildBufferMax = 5000000
'----------------------------------------------------------------------
Type StrBuildT
mem As Long
count As Long
max As Long
End Type
'----------------------------------------------------------------------
Sub StrBuildPush(t As StrBuildT, ByVal value As String)
'append value
Local strlen, currentcount, buffer, newmax As Long
strlen = Len(value)
If strlen Then
If strlen > t.max - t.count Then
currentcount = t.count : t.count = 0 : t.max = 0
buffer = Max&(1, 2 * currentcount)
buffer = Min&(buffer, %StrBuildBufferMax)
newmax = currentcount + buffer + strlen
t.mem = MemReAlloc(t.mem, newmax * %BytSize)
If t.mem = 0 Then Exit Sub
t.count = currentcount : t.max = newmax
End If
Memory Copy StrPtr(value), t.mem + (t.count * %BytSize), strlen * %BytSize
t.count += strlen
End If
End Sub
'----------------------------------------------------------------------
Function StrBuildPop(t As StrBuildT) As String
'get whole string : free memory
If t.mem And t.count Then Function = Peek$(t.mem, t.count)
t.mem = MemFree(t.mem)
t.count = 0
t.max = 0
End Function
'----------------------------------------------------------------------
#EndIf '%StrBuild250811
#If Not %Def(%FileStore250717)
%FileStore250717 = 1
Sub FilePut(ByVal file As WString, ByRef value As WString)
'store value to File
Local f As Long
If Len(file) = 0 Then Exit Sub
f = FreeFile
Open file For Binary As f
SetEof f
Put$ f, value
Close f
End Sub
Function FileGet(ByRef file As WString) As WString
'restore value from File
Local f As Long, value As WString
If IsFalse IsFile(file) Then Exit Function
f = FreeFile
Open file For Binary As f
Get$ f, Lof(f), value
Close f
Function = value
End Function
#EndIf '%FileStore250717
#If Not %Def(%PtrList250812)
%PtrList250812 = 1
'----------------------------------------------------------------------
'Pointer Doubly Linked List : Stack : Queue : Deque
'pointers to allocated UDTs
'PtrT must be first item in UDT
'pointer must have been allocated with PtrNew()
'stored pointers can't be null
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
Declare Function PtrStoreCallback(ByVal p As Long) As String
'return String holding pointer's associated data
Declare Function PtrRestorCallback(ByRef stored As String) As Long
'return new instance with data restored
'----------------------------------------------------------------------
%LngSize = 4
%PtrListTag = -699621965
Type PtrListNodeT
allocator As PtrT
next As PtrListNodeT Ptr
prev As PtrListNodeT Ptr
value As Long
End Type
Type PtrListT
allocator As PtrT
tag As Long
count As Long
first As PtrListNodeT Ptr
last As PtrListNodeT Ptr
cursor As PtrListNodeT Ptr
remember As PtrListNodeT Ptr
End Type
'----------------------------------------------------------------------
Function PtrListNew() As Long
'allocate new instance : return container pointer : call PtrFree(p) to free pointer
Function = PtrNew(SizeOf(PtrListT), CodePtr(PtrListNewCB), CodePtr(PtrListClear))
End Function
'----------------------------------------------------------------------
Sub PtrListClear(ByVal p As PtrListT Ptr)
'empty container
Local node As PtrListNodeT Ptr
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
While @p.first
node = @p.first
@p.first = @node.next
PtrFree(node)
Wend
@p.last = 0
@p.count = 0
@p.cursor = 0
@p.remember = 0
End Sub
'----------------------------------------------------------------------
Function PtrListCount(ByVal p As PtrListT Ptr) As Long
'get item count
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
Function = @p.count
End Function
'----------------------------------------------------------------------
Sub PtrListAdd(ByVal p As PtrListT Ptr, ByVal pItem As Long)
'append value
PtrListPushLast p, pItem
End Sub
'----------------------------------------------------------------------
Function PtrListCursor(ByVal p As PtrListT Ptr) As Long
'true/false if cursor valid
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListFirst(ByVal p As PtrListT Ptr) As Long
'move cursor to first node : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
@p.cursor = @p.first
If @p.cursor Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListNext(ByVal p As PtrListT Ptr) As Long
'move cursor to next node : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor Then @p.cursor = @p.@cursor.next
If @p.cursor Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListLast(ByVal p As PtrListT Ptr) As Long
'move cursor to last node : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
@p.cursor = @p.last
If @p.cursor Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListPervious(ByVal p As PtrListT Ptr) As Long
'move cursor to previous node : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor Then @p.cursor = @p.@cursor.prev
If @p.cursor Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListRember(ByVal p As PtrListT Ptr) As Long
'remember cursor position : fail if cursor null : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
@p.remember = @p.cursor
If @p.remember Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListReturn(ByVal p As PtrListT Ptr) As Long
'return to remembered position : fail if node deleted : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
@p.cursor = @p.remember
If @p.cursor Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListGet(ByVal p As PtrListT Ptr) As Long
'get value at cursor position : null if cursor null
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor Then Function = @p.@cursor.value
End Function
'----------------------------------------------------------------------
Function PtrListDeleteForward(ByVal p As PtrListT Ptr) As Long
'move to next node and delete node at cursor position : fail if cursor null : true/false success
'cursor will be null if no next node
Local n As PtrListNodeT Ptr
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor Then
Function = 1
n = @p.cursor
@p.cursor = @p.@cursor.next
PtrListNodeDelete(p, n)
End If
End Function
'----------------------------------------------------------------------
Function PtrListDeleteBackward(ByVal p As PtrListT Ptr) As Long
'move to previous node and delete node at cursor position : fail if cursor null : true/false success
'cursor will be null if no previous node
Local n As PtrListNodeT Ptr
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor Then
Function = 1
n = @p.cursor
@p.cursor = @p.@cursor.prev
PtrListNodeDelete(p, n)
End If
End Function
'----------------------------------------------------------------------
Function PtrListIsBefore(ByVal p As PtrListT Ptr) As Long
'true/false if there is a node before cursor position
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor And @p.@cursor.prev Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListIsAfter(ByVal p As PtrListT Ptr) As Long
'true/false if there is a node after cursor position
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor And @p.@cursor.next Then Function = 1
End Function
'----------------------------------------------------------------------
Function PtrListDeleteBefore(ByVal p As PtrListT Ptr) As Long
'delete node before cursor position : fail if cursor null or no previous node : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor And @p.@cursor.prev Then
PtrListNodeDelete p, @p.@cursor.prev
Function = 1
End If
End Function
'----------------------------------------------------------------------
Function PtrListDeleteAfter(ByVal p As PtrListT Ptr) As Long
'delete node after cursor position : fail if cursor null or no next node : true/false success
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor And @p.@cursor.next Then
PtrListNodeDelete p, @p.@cursor.next
Function = 1
End If
End Function
'----------------------------------------------------------------------
Function PtrListPushBefore(ByVal p As PtrListT Ptr, ByVal pItem As Long) As Long
'add value before cursor position : fail if cursor null : true/false success
Local node As PtrListNodeT Ptr
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitF(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")
If @p.cursor Then
Function = 1
If @p.cursor = @p.first Then
PtrListPushFirst p, pItem
Else
ExitF(@p.@cursor.prev = 0, "previous node null")
node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))
ExitF(node = 0, "PtrNew fail")
@node.value = pItem
@node.next = @p.cursor
@node.prev = @p.@cursor.prev
@p.@cursor.@prev.next = node
@p.@cursor.prev = node
End If
End If
End Function
'----------------------------------------------------------------------
Function PtrListPushAfter(ByVal p As PtrListT Ptr, ByVal pItem As Long) As Long
'add value after cursor position : fail if cursor null : true/false success
Local node As PtrListNodeT Ptr
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitF(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")
If @p.cursor Then
Function = 1
If @p.cursor = @p.last Then
PtrListPushLast p, pItem
Else
ExitF(@p.@cursor.next = 0, "next node null")
node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))
ExitF(node = 0, "PtrNew fail")
@node.value = pItem
@node.prev = @p.cursor
@node.next = @p.@cursor.next
@p.@cursor.@next.prev = node
@p.@cursor.next = node
End If
End If
End Function
'----------------------------------------------------------------------
Function PtrListPeekBefore(ByVal p As PtrListT Ptr) As Long
'get value before cursor position : null if cursor invalid or no previous node
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor And @p.@cursor.prev Then Function = @p.@cursor.@prev.value
End Function
'----------------------------------------------------------------------
Function PtrListPeekAfter(ByVal p As PtrListT Ptr) As Long
'get value after cursor position : null if cursor invalid or no next node
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.cursor And @p.@cursor.next Then Function = @p.@cursor.@next.value
End Function
'----------------------------------------------------------------------
Function PtrListPopBefore(ByVal p As PtrListT Ptr) As Long
'get and remove value before cursor position : null if cursor invalid or no previous node
'user responsible for freeing popped pointers
Local h As Long
h = PtrListPeekBefore(p)
If h Then
PtrIncr(h)
Function = h
PtrListDeleteBefore(p)
End If
End Function
'----------------------------------------------------------------------
Function PtrListPopAfter(ByVal p As PtrListT Ptr) As Long
'get and remove value after cursor position : null if cursor invalid or no next node
'user responsible for freeing popped pointers
Local h As Long
h = PtrListPeekAfter(p)
If h Then
PtrIncr(h)
Function = h
PtrListDeleteAfter(p)
End If
End Function
'----------------------------------------------------------------------
Sub PtrListPushFirst(ByVal p As PtrListT Ptr, ByVal pItem As Long)
'insert at front
Local node As PtrListNodeT Ptr
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitS(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")
node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))
ExitS(node = 0, "PtrNew fail")
@node.value = pItem
If @p.count Then
ExitS(@p.first = 0, "first node null")
@p.@first.prev = node
@node.next = @p.first
@p.first = node
Incr @p.count
Else
@p.first = node
@p.last = node
@p.count = 1
End If
End Sub
'----------------------------------------------------------------------
Sub PtrListPushLast(ByVal p As PtrListT Ptr, ByVal pItem As Long)
'append to end
Local node As PtrListNodeT Ptr
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitS(pItem = 0 Or Peek(Long, pItem) <> %PtrTag, "invalid item")
node = PtrNew(SizeOf(PtrListNodeT), 0, CodePtr(PtrListNodeFinalCB))
ExitS(node = 0, "PtrNew fail")
@node.value = pItem
If @p.count Then
ExitS(@p.last = 0, "last node null")
@p.@last.next = node
@node.prev = @p.last
@p.last = node
Incr @p.count
Else
@p.first = node
@p.last = node
@p.count = 1
End If
End Sub
'----------------------------------------------------------------------
Function PtrListPeekFirst(ByVal p As PtrListT Ptr) As Long
'get fist value : null if list empty
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.first Then Function = @p.@first.value
End Function
'----------------------------------------------------------------------
Function PtrListPeekLast(ByVal p As PtrListT Ptr) As Long
'get last value : null list empty
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.last Then Function = @p.@last.value
End Function
'----------------------------------------------------------------------
Function PtrListPopFirst(ByVal p As PtrListT Ptr) As Long
'get and remove fist value : null if list empty
'user responsible for freeing popped pointers
Local h As Long
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.first Then
h = @p.@first.value
PtrIncr(h)
Function = h
PtrListNodeDelete(p, @p.first)
End If
End Function
'----------------------------------------------------------------------
Function PtrListPopLast(ByVal p As PtrListT Ptr) As Long
'get and remove last value : null if list empty
'user responsible for freeing popped pointers
Local h As Long
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
If @p.last Then
h = @p.@last.value
PtrIncr(h)
Function = h
PtrListNodeDelete(p, @p.last)
End If
End Function
'----------------------------------------------------------------------
Function PtrListStore(ByVal p As PtrListT Ptr, ByVal storeCB As Long) As String
'store container to String
'Declare Function PtrStoreCallback(ByVal p As Long) As String
Local more, h As Long
Local sb As StrBuildT
Local s As String
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitF(storeCB = 0, "null callback")
If @p.count Then
StrBuildPush sb, Mkl$(@p.count)
more = PtrListFirst(p)
While more
h = PtrListGet(p)
ExitF(h = 0, "unexpected null")
Call Dword storeCB Using PtrStoreCallback(h) To s
StrBuildPush sb, Mkl$(Len(s))
StrBuildPush sb, s
more = PtrListNext(p)
Wend
End If
Function = StrBuildPop(sb)
End Function
'----------------------------------------------------------------------
Sub PtrListRestore(ByVal p As PtrListT Ptr, ByRef stored As String, ByVal restoreCB As Long)
'restore container from String
'Declare Function PtrRestorCallback(ByRef stored As String) As Long
Register i As Long
Local items, bytes, h As Long
Local s As String
Local pl As Long Ptr
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitS(restoreCB = 0, "null callback")
PtrListClear p
If Len(stored) Then
pl = StrPtr(stored)
items = @pl : Incr pl
For i = 1 To items
bytes = @pl : Incr pl
s = Peek$(pl, bytes) : pl += bytes
Call Dword restoreCB Using PtrRestorCallback(s) To h
ExitS(h = 0,"null callback return")
PtrListAdd p, h
Next i
End If
End Sub
'----------------------------------------------------------------------
Sub PtrListFileStore(ByVal p As PtrListT Ptr, ByVal file As WString, ByVal storeCB As Long)
'store container to File
'Declare Function PtrStoreCallback(ByVal p As Long) As String
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitS(storeCB = 0, "null callback")
ExitS(Len(file) = 0, "invalid file")
FilePut file, PtrListStore(p, storeCB)
End Sub
'----------------------------------------------------------------------
Sub PtrListFileRestore(ByVal p As PtrListT Ptr, ByVal file As WString, ByVal restoreCB As Long)
'restore container from File
'Declare Function PtrRestorCallback(ByRef stored As String) As Long
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %PtrListTag, "invalid ptr")
ExitS(IsFalse IsFile(file), "invalid file" + file)
PtrListRestore p, FileGet(file), restoreCB
End Sub
'----------------------------------------------------------------------
'PRIVATE:
'----------------------------------------------------------------------
Sub PtrListNewCB(ByVal p As PtrListT Ptr) Private
'PRIVATE: list new callback
If p Then @p.tag = %PtrListTag
End Sub
'----------------------------------------------------------------------
Sub PtrListNodeFinalCB(ByVal node As PtrListNodeT Ptr)
If node Then
PtrFree(@node.value)
End If
End Sub
'----------------------------------------------------------------------
Sub PtrListNodeDelete(ByVal p As PtrListT Ptr, ByVal node As PtrListNodeT Ptr) Private
'PRIVATE: remove node from list
If node Then
If @p.cursor = node Then @p.cursor = 0
If @p.remember = node Then @p.remember = 0
If @p.first = node Then @p.first = @node.next
If @p.last = node Then @p.last = @node.prev
If @node.prev Then @node.@prev.next = @node.next
If @node.next Then @node.@next.prev = @node.prev
ExitS(@p.count = 0, "invalid count")
Decr @p.count
PtrFree(node)
End If
End Sub
'----------------------------------------------------------------------
#EndIf '%PtrList250812
#If Not %Def(%Str250724)
%Str250724 = 1
'----------------------------------------------------------------------
'Dynamic String Container
'----------------------------------------------------------------------
Declare Function StrCompareCallback(ByVal a As Long, ByVal b As Long) As Long
'a < b : return < 0 a = b : return = 0 a > b : return > 0
'----------------------------------------------------------------------
%BytSize = 1
%StrTag = 653170298
Type StrT
allocator As PtrT
tag As Long
mem As Byte Ptr
count As Long
End Type
'----------------------------------------------------------------------
Function StrNew() As Long
'allocate new instance : return container pointer : call PtrFree(p) to free pointer
Function = PtrNew(SizeOf(StrT), CodePtr(StrNewCB), CodePtr(StrClear))
End Function
'----------------------------------------------------------------------
Sub StrClear(ByVal p As StrT Ptr)
'empty container
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %StrTag, "invalid ptr")
@p.mem = MemFree(@p.mem)
@p.count = 0
End Sub
'----------------------------------------------------------------------
Function StrGet(ByVal p As StrT Ptr) As String
'get value
ExitF(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %StrTag, "invalid ptr")
Function = Peek$(@p.mem, @p.count)
End Function
'----------------------------------------------------------------------
Sub StrSet(ByVal p As StrT Ptr, ByRef value As String)
Local strlen As Long : strlen = Len(value)
Local bytes As Long : bytes = strlen * %BytSize
ExitS(p = 0 Or @p.allocator.tag <> %PtrTag Or @p.tag <> %StrTag, "invalid ptr")
@p.mem = MemFree(@p.mem) : @p.count = 0
If strlen Then
@p.mem = MemAlloc(bytes)
If @p.mem Then
@p.count = strlen
Memory Copy StrPtr(value), @p.mem, bytes
End If
End If
End Sub
'----------------------------------------------------------------------
Function StrNewValue(ByRef value As String) As Long
'allocate new instance : store value : return pointer
Local h As Long
h = StrNew()
StrSet h, value
Function = h
End Function
'----------------------------------------------------------------------
Function StrHashIndex(ByVal p As StrT Ptr, ByVal capacity As Long) As Long
'get key's one-based hash index position
Register i As Long : Local total, temp As Long
Function = 1
If p Then
For i = 0 To @p.count - 1
temp += @p.@mem[i] + total
Shift Left total, 8
total += temp
Next i
Function = Abs(total Mod capacity) + 1
End If
End Function
'----------------------------------------------------------------------
Function StrEqual(ByVal a As StrT Ptr, ByVal b As StrT Ptr) As Long
'true/false if two strings equal
Register i As Long
If a And b And @a.count = @b.count Then
For i = 0 To @a.count - 1
If @a.@mem[i] <> @b.@mem[i] Then Exit Function
Next i
Function = 1
End If
End Function
'----------------------------------------------------------------------
Function StrCompare(ByVal a As StrT Ptr, ByVal b As StrT Ptr) As Long
'compare callback : case sensitive
Register i As Long : Register compare As Long
If a And b Then
For i = 0 To Min&(@a.count, @b.count) - 1
compare = @a.@mem[i] - @b.@mem[i]
If compare Then
Function = compare : Exit Function
End If
Next i
Function = @a.count - @b.count
End If
End Function
'----------------------------------------------------------------------
Function StrCompareIgnore(ByVal a As StrT Ptr, ByVal b As StrT Ptr) As Long
'compare callback : case sensitive
Register i As Long : Register compare As Long : Local la, lb As Long
If a And b Then
For i = 0 To Min&(@a.count, @b.count) - 1
la = @a.@mem[i] : lb = @b.@mem[i]
If la > 64 And la < 91 Then la += 32
If lb > 64 And lb < 91 Then lb += 32
compare = la - lb
If compare Then
Function = compare : Exit Function
End If
Next i
Function = @a.count - @b.count
End If
End Function
'----------------------------------------------------------------------
Function StrStoreCB(ByVal p As StrT Ptr) As String
'store callback
Function = ChrToUtf8$(StrGet(p))
End Function
'----------------------------------------------------------------------
Function StrRestoreCB(ByRef value As String) As Long
'restore callback
Function = StrNewValue(Utf8ToChr$(value))
End Function
'----------------------------------------------------------------------
'PRIVATE:
'----------------------------------------------------------------------
Sub StrNewCB(ByVal p As StrT Ptr) Private
'PRIVATE: new callback
If p Then @p.tag = %StrTag
End Sub
'----------------------------------------------------------------------
#EndIf '%Str250724
#If Not %Def(%StrList250812)
%StrList250812 = 1
'----------------------------------------------------------------------
'String Doubly Linked List : Stack : Queue : Deque
'----------------------------------------------------------------------
Macro StrListT = PtrListT
'----------------------------------------------------------------------
Function StrListNew() As Long
'allocate new instance : return container pointer : call PtrFree(p) to free pointer
Function = PtrListNew()
End Function
'----------------------------------------------------------------------
Sub StrListClear(ByVal p As StrListT Ptr)
'empty container
PtrListClear p
End Sub
'----------------------------------------------------------------------
Function StrListCount(ByVal p As StrListT Ptr) As Long
'get item count
Function = PtrListCount(p)
End Function
'----------------------------------------------------------------------
Sub StrListAdd(ByVal p As StrListT Ptr, ByRef value As String)
'append value
PtrListAdd p, StrNewValue(value)
End Sub
'----------------------------------------------------------------------
Function StrListCursor(ByVal p As StrListT Ptr) As Long
'true/false if cursor valid
Function = PtrListCursor(p)
End Function
'----------------------------------------------------------------------
Function StrListFirst(ByVal p As StrListT Ptr) As Long
'move cursor to first node : true/false success
Function = PtrListFirst(p)
End Function
'----------------------------------------------------------------------
Function StrListNext(ByVal p As StrListT Ptr) As Long
'move cursor to next node : true/false success
Function = PtrListNext(p)
End Function
'----------------------------------------------------------------------
Function StrListLast(ByVal p As StrListT Ptr) As Long
'move cursor to last node : true/false success
Function = PtrListLast(p)
End Function
'----------------------------------------------------------------------
Function StrListPervious(ByVal p As StrListT Ptr) As Long
'move cursor to previous node : true/false success
Function = PtrListPervious(p)
End Function
'----------------------------------------------------------------------
Function StrListRember(ByVal p As StrListT Ptr) As Long
'remember cursor position : fail if cursor null : true/false success
Function = PtrListRember(p)
End Function
'----------------------------------------------------------------------
Function StrListReturn(ByVal p As StrListT Ptr) As Long
'return to remembered position : fail if node deleted : true/false success
Function = PtrListReturn(p)
End Function
'----------------------------------------------------------------------
Function StrListGet(ByVal p As StrListT Ptr) As String
'get value at cursor position : null if cursor null
Local h As Long
h = PtrListGet(p)
If h Then Function = StrGet(h)
End Function
'----------------------------------------------------------------------
Function StrListSet(ByVal p As StrListT Ptr, ByRef value As String) As Long
'set value at cursor position : fail if cursor null : true/false success
Local h As Long
h = PtrListGet(p)
If h Then
StrSet h, value
Function = 1
End If
End Function
'----------------------------------------------------------------------
Function StrListDeleteForward(ByVal p As StrListT Ptr) As Long
'move to next node and delete node at cursor position : fail if cursor null : true/false success
'cursor will be null if no next node
Function = PtrListDeleteForward(p)
End Function
'----------------------------------------------------------------------
Function StrListDeleteBackward(ByVal p As StrListT Ptr) As Long
'move to previous node and delete node at cursor position : fail if cursor null : true/false success
'cursor will be null if no previous node
Function = PtrListDeleteBackward(p)
End Function
'----------------------------------------------------------------------
Function StrListIsBefore(ByVal p As StrListT Ptr) As Long
'true/false if there is a node before cursor position
Function = PtrListIsBefore(p)
End Function
'----------------------------------------------------------------------
Function StrListIsAfter(ByVal p As StrListT Ptr) As Long
'true/false if there is a node after cursor position
Function = PtrListIsAfter(p)
End Function
'----------------------------------------------------------------------
Function StrListDeleteBefore(ByVal p As StrListT Ptr) As Long
'delete node before cursor position : fail if cursor null or no previous node : true/false success
Function = PtrListDeleteBefore(p)
End Function
'----------------------------------------------------------------------
Function StrListDeleteAfter(ByVal p As StrListT Ptr) As Long
'delete node after cursor position : fail if cursor null or no next node : true/false success
Function = PtrListDeleteAfter(p)
End Function
'----------------------------------------------------------------------
Function StrListPushBefore(ByVal p As StrListT Ptr, ByRef value As String) As Long
'add value before cursor position : fail if cursor null : true/false success
Local h As Long : h = StrNewValue(value)
If IsFalse PtrListPushBefore(p, h) Then PtrFree(h)
End Function
'----------------------------------------------------------------------
Function StrListPushAfter(ByVal p As StrListT Ptr, ByRef value As String) As Long
'add value after cursor position : fail if cursor null : true/false success
'add value before cursor position : fail if cursor null : true/false success
Local h As Long : h = StrNewValue(value)
If IsFalse PtrListPushAfter(p, h) Then PtrFree(h)
End Function
'----------------------------------------------------------------------
Function StrListPeekBefore(ByVal p As StrListT Ptr) As String
'get value before cursor position : null if cursor invalid or no previous node
Local h As Long : h = PtrListPeekBefore(p)
If h Then Function = StrGet(h)
End Function
'----------------------------------------------------------------------
Function StrListPeekAfter(ByVal p As StrListT Ptr) As String
'get value after cursor position : null if cursor invalid or no next node
Local h As Long : h = PtrListPeekAfter(p)
If h Then Function = StrGet(h)
End Function
'----------------------------------------------------------------------
Function StrListPopBefore(ByVal p As StrListT Ptr) As String
'get and remove value before cursor position : null if cursor invalid or no previous node
Local h As Long : h = PtrListPopBefore(p)
If h Then
Function = StrGet(h)
PtrFree(h)
End If
End Function
'----------------------------------------------------------------------
Function StrListPopAfter(ByVal p As StrListT Ptr) As String
'get and remove value after cursor position : null if cursor invalid or no next node
Local h As Long : h = PtrListPopAfter(p)
If h Then
Function = StrGet(h)
PtrFree(h)
End If
End Function
'----------------------------------------------------------------------
Sub StrListPushFirst(ByVal p As StrListT Ptr, ByRef value As String)
'insert at front
PtrListPushFirst p, StrNewValue(value)
End Sub
'----------------------------------------------------------------------
Sub StrListPushLast(ByVal p As StrListT Ptr, ByRef value As String)
'append to end
PtrListPushLast p, StrNewValue(value)
End Sub
'----------------------------------------------------------------------
Function StrListPeekFirst(ByVal p As StrListT Ptr) As String
'get fist value : null if list empty
Local h As Long : h = PtrListPeekFirst(p)
If h Then Function = StrGet(h)
End Function
'----------------------------------------------------------------------
Function StrListPeekLast(ByVal p As StrListT Ptr) As String
'get last value : null list empty
Local h As Long : h = PtrListPeekLast(p)
If h Then Function = StrGet(h)
End Function
'----------------------------------------------------------------------
Function StrListPopFirst(ByVal p As StrListT Ptr) As String
'get and remove fist value : null if list empty
Local h As Long : h = PtrListPopFirst(p)
If h Then
Function = StrGet(h)
PtrFree(h)
End If
End Function
'----------------------------------------------------------------------
Function StrListPopLast(ByVal p As StrListT Ptr) As String
'get and remove last value : null if list empty
Local h As Long : h = PtrListPopLast(p)
If h Then
Function = StrGet(h)
PtrFree(h)
End If
End Function
'----------------------------------------------------------------------
Sub StrListImport(ByVal p As StrListT Ptr, a() As String)
'import PB array
Register i As Long
StrListClear p
For i = LBound(a) To UBound(a)
StrListAdd p, a(i)
Next i
End Sub
'----------------------------------------------------------------------
Sub StrListExport(ByVal p As StrListT Ptr, a() As String)
'export to PB array
Register i As Long
Local more As Long
Erase a()
If StrListCount(p) Then
ReDim a(1 To StrListCount(p))
more = StrListFirst(p)
While more
Incr i
a(i) = StrListGet(p)
more = StrListNext(p)
Wend
End If
End Sub
'----------------------------------------------------------------------
Sub StrListSplit(ByVal p As StrListT Ptr, ByVal delimited As String, ByVal delimiter As String)
'split array on delimited string
Local items As Long
Local a() As String
StrListClear p
If Len(delimited) Then
items = ParseCount(delimited, delimiter)
If items Then
Dim a(1 To items)
Parse delimited, a(), delimiter
StrListImport p, a()
End If
End If
End Sub
'----------------------------------------------------------------------
Function StrListJoin(ByVal p As StrListT Ptr, ByVal delimiter As String) As String
'join array on delimiter
Local a() As String
StrListExport p, a()
Function = Join$(a(), delimiter)
End Function
'----------------------------------------------------------------------
Sub StrListToText(ByVal p As StrListT Ptr, ByVal file As WString)
'store list as text file
If StrListCount(p) Then
FilePut file, RTrim$(StrListJoin(p, $CrLf)) + $CrLf
End If
End Sub
'----------------------------------------------------------------------
Sub StrListFromText(ByVal p As StrListT Ptr, ByVal file As WString)
'load text file
Local contents As String
StrListClear p
contents = FileGet(file)
contents = Trim$(contents, $CrLf)
If Len(contents) Then
StrListSplit p, contents, $CrLf
End If
End Sub
'----------------------------------------------------------------------
Sub StrListFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)
'get all folders in root folder
Local folder, folderMask, rootPath As String
Local DrD As DirData
StrListClear p
ExitS(IsFalse IsFolder(rootFolder), "invalid folder")
rootPath = RTrim$(rootFolder, "\") + "\"
folderMask = rootPath
folder = Dir$(folderMask, Only %SubDir To DrD)
While Len(folder)
StrListAdd p, rootPath + folder
folder = Dir$
Wend
End Sub
'----------------------------------------------------------------------
Sub StrListFiles(ByVal p As StrListT Ptr, ByVal folder As String, ByVal mask As String)
'get all files in folder matching mask
Local file, fileMask As String
StrListClear p
ExitS(IsFalse IsFolder(folder), "invalid folder")
folder = RTrim$(folder, "\") + "\"
fileMask = folder + mask
file = Dir$(fileMask)
While Len(file)
StrListAdd p, folder + file
file = Dir$
Wend
End Sub
'----------------------------------------------------------------------
Sub StrListAllFolders(ByVal p As StrListT Ptr, ByVal rootFolder As String)
'get all folders in root folder and sub-folders, including root folder
Local folderStack As Long : folderStack = StrListNew()
Local subFolderStack As Long : subFolderStack = StrListNew()
Local currentFolder As String
StrListClear p
ExitS(IsFalse IsFolder(rootFolder), "invalid folder")
StrListPushLast folderStack, rootFolder
While StrListCount(folderStack)
currentFolder = StrListPopLast(folderStack)
StrListAdd p, currentFolder
StrListFolders subFolderStack, currentFolder
While StrListCount(subFolderStack)
StrListPushLast folderStack, StrListPopLast(subFolderStack)
Wend
Wend
folderStack = PtrFree(folderStack)
subFolderStack = PtrFree(subFolderStack)
End Sub
'----------------------------------------------------------------------
Sub StrListAllFiles(ByVal p As StrListT Ptr, ByVal rootFolder As String, ByVal mask As String)
'get all files in root folder, and sub-folders, matching mask
Local allFolderStack As Long : allFolderStack = StrListNew()
Local folderFileStack As Long : folderFileStack = StrListNew()
StrListClear p
ExitS(IsFalse IsFolder(rootFolder), "invalid folder")
StrListAllFolders allFolderStack, rootFolder
While StrListCount(allFolderStack)
StrListFiles folderFileStack, StrListPopLast(allFolderStack), mask
While StrListCount(folderFileStack)
StrListAdd p, StrListPopLast(folderFileStack)
Wend
Wend
allFolderStack = PtrFree(allFolderStack)
folderFileStack = PtrFree(folderFileStack)
End Sub
'----------------------------------------------------------------------
Function StrListStore(ByVal p As StrListT Ptr) As String
'store container to String
Function = PtrListStore(p, CodePtr(StrStoreCB))
End Function
'----------------------------------------------------------------------
Sub StrListRestore(ByVal p As StrListT Ptr, ByRef stored As String)
'restore container from String
PtrListRestore p, stored, CodePtr(StrRestoreCB)
End Sub
'----------------------------------------------------------------------
Sub StrListFileStore(ByVal p As StrListT Ptr, ByVal file As WString)
'store container to File
PtrListFileStore p, file, CodePtr(StrStoreCB)
End Sub
'----------------------------------------------------------------------
Sub StrListFileRestore(ByVal p As StrListT Ptr, ByVal file As WString)
'restore container from File
PtrListFileRestore p, file, CodePtr(StrRestoreCB)
End Sub
'----------------------------------------------------------------------
#EndIf '%StrList250812
|
|
|
|
| Hello old friends |
|
Posted by: Bern Ertl - 28.09.2025, 09:11 PM - Forum: This and that - friendly chat
- Replies (4)
|
|
Been a long while since I checked on the PB forums. Finally did a couple weeks ago and discovered it was dead. I did some internets searching and found this forum with some familiar names. I just wanted to thank y'all for keeping a door open. Cheers.
|
|
|
|
| Affinity |
|
Posted by: Patrice Terrier - 26.09.2025, 09:59 PM - Forum: This and that - friendly chat
- No Replies
|
 |
Ever wanted to use a professional graphic tool for a fraction of the PhotoShop price.
With unlimited license, you can use it on all your local computers.
Affinity Photo 2 is absolutly amazing, believe me!
|
|
|
|
| MS Power Toys |
|
Posted by: Jules Marchildon - 26.09.2025, 01:55 AM - Forum: This and that - friendly chat
- Replies (2)
|
 |
Thought I'd post this as an FYI.
I was investigating the magnification win32 API examples and eventually came across this link Magnification API Overview The first thing that jumped out was this note; "The Magnification API is not supported under WOW64; that is, a 32-bit magnifier application will not run correctly on 64-bit Windows." So started searching for alternatives. I did some more searching and came across Gary's thread Win10 Magnifier Alternative -July 2022 while I have played with Patrice's FFcapture in the past, post #3 by Hutch mentioned a 32bit MS Utility "zoomin.exe" but no source code go fish for yourself. So I went deep C fishing, I got to this site ZoomIt -Sysinternals and they have both 32 & 64bit binaries, the github link took me to the source code and I was surprised by all the other utilities available as well, here it is Microsoft PowerToys I'm still reading through it all to find the zoomin source code.
|
|
|
|
|
