Announcement

**Doug Hitchens** · 28 Feb 2015, 08:52 PM

Enlighten me, please, what is this used for?

**Larry Charlton** · 28 Feb 2015, 09:02 PM

Tends to have tons of uses, but a few might be:
Testing for existence in a set like is this a keyword
Counting words
Find record by key
Translating one word to another.
Have I processed this item before?
etc

Basically places you might use a binary lookup or array scan.

**Larry Charlton** · 1 Mar 2015, 06:55 AM

Here's some reference data:

Code:

Operation            Tix   Tix/Op        Ops/Sec
Compare      106,639,077   106.64     30,117,648 
Loop          19,376,109     1.94  1,666,666,667

Compare shows how fast a simple compare is. Loop shows how fast an empty loop is. I'd guess the StringBag is currently running at about 1/2 to 1/4 the speed it could.

Another way to think of a hashtable is: it's a bit like a magic trick. Imagine you had a pile of a million things. Imagine you could reach into that pile an pull a rabbit out of the pile 100% of the time as fast as the average person could pull one random item.

**Wayne Diamond** · 1 Mar 2015, 07:19 AM

for further speed you could implement a hash table lookup algorithm such as Murmur, FNV, Pearsons, etc etc

**Larry Charlton** · 1 Mar 2015, 09:32 AM

I think the next area for improvement might be the string compare. Hashes are running 31 clock cycles per hash. Compares are running 150. On the sample data. I'd like to see compare hit 40 cycles or less. Off to work on that

**Larry Charlton** · 2 Mar 2015, 04:14 PM

Updated the code a bit. It's a bit faster. I'd be interested in any bugs that are found or suggestions for improvement.

**Larry Charlton** · 2 Mar 2015, 06:06 PM

Added a fixed string stringbag version.

Adding entries and clearing the bag is faster.
Retrieving an item from the bag is slower but seems like an uncommon operation.

The rest of the routines are about a wash. The fixed string version had some optimizations removed that I believe account for the other differences.

**Michael Mattias** · 3 Mar 2015, 09:14 AM

> think the next area for improvement might be the string compare.

1. This is for fixed strings but the idea is easily extensible

Code:

' compare two varibles byte by byte for length iLen
' returns:  -1   A1 is less than A2
'           +1   A1 is greater then A2
'            0   A1 = A2
MACRO FUNCTION m_CompareFixedStringAbsolute (a1, A2, iLen)

  MACROTEMP iChar, iRet, p1, p2
  DIM iChar AS LONG, iRet AS LONG, p1 AS BYTE PTR, p2 AS BYTE PTR

  p1      = VARPTR(A1)
  p2      = VARPTR(A2)
  iRet    =  %FALSE       ' default = equal, we set when > or < condition actually occurs

  FOR ichar = 1& TO ilen
    IF @p2 < @p1  THEN      ' this character is less, so string cannot be greater
        iRet =  1&          ' a1 is greater than A2
        EXIT FOR             ' with iRet = %FALSE
    ELSEIF @p2 > @p1 THEN    ' as soon as any character in 2 is greater than corresponding char in one
      iRet = -1&             ' A1 is less than A2
      EXIT FOR
    ELSE                    ' must be eqaul, so we have to keep on going.
      INCR p1
      INCR p2
    END IF
  NEXT
  ' if no greater or less condition was found, must be equal which
  ' means iRet was already set to correct result of zero.
END MACRO = iRet

2. Consider sorting the strings and using a binary search..
Binary Search of an array February 14 2000, July 15 2003

MCM

**Larry Charlton** · 3 Mar 2015, 11:12 AM

Thanks MCM, keep em coming.

1) The fixed string version does essentially that. The dynamic string version extends it a bit by comparing 4 bytes at a time. They're just using assembler to speed up the process. Turns out fixed strings and dynamic strings work identically other than getting that initial pointer.

2) Binary searches tend to be orders of magnitude slower. With hashtables you reach in the pile once an pull out what you want (see the reference to the magic trick

). With binary searches you have to look at the square root of entries in general, possibly a few less if you get lucky. Also with a hashtable in the event there's a collision, the loops to find your match or orders of magnitude quicker because you only rarely have to actually compare a string due to the hashcodes. The other cool thing about hashtables is there's no need to sort (not that you can't, you just don't need to). That lends a second cool feature in that the added indexes are stable so you can use it as an index directly into other data.

**Michael Mattias** · 3 Mar 2015, 01:04 PM

Turns out fixed strings and dynamic strings work identically other than getting that initial pointer.

Um, not quite if you are coding using native PowerBASIC syntax.

In my mapping engine I needed to do "many" (can be literally millions although typically it's only thousands) of comparisons of fixed-string UDT members, in real time. It turns out that the code..

Code:

  IF udt1.member  = udt2.member THEN 
   ...

.. is implemented in PB by creating and destroying a couple of dynamic strings which are then compared using standard PB rtl functions. (I got this from pb support when I asked. I never found it in the help).

That's why I wrote the MACRO FUNCTIONs... to eliminate that create/destroy overhead.

In version two of the mapping engine I did the same thing you did, ensuring all my string keys were multiples of four bytes so I could compare in pieces as integers ("LONG PTR").

MCM

**Chris Holbrook** · 4 Mar 2015, 03:47 PM

How does performance compare with Collections, using the key attribute to contain the string? ISTR that Collections use a hash table.

**Larry Charlton** · 4 Mar 2015, 05:42 PM

If you're asking about the speed difference between StringBag and iPowerCollection, it's a bit hard to compare. If you're collection is small <10,000 items the non-optimized StringBag is between 30 - 40 times faster. If you collection grows the difference grows, at 100,000 items it's maybe 450x faster or so. There's clearly some differences between the collections, but here's the tests I ran if you want to compare them or try something different.

PowerCollection.bas

Code:

#Compiler PBCC 6, PBWin 10
#Compile Exe
#Dim All
#Optimize Speed
#If %Def( %PB_CC32 )
#Console Off
#EndIf
 
#Include "win32api.inc"
 
%COUNT = 100000
 
Function PBMain () As Long
  ConInit
  ConCls 9, 15
  Local a As IPowerCollection
  a = Class "PowerCollection"
  Test a
  ConWrite "Finished"
  ConClose
End Function
 
Sub Test( b As IPowerCollection )
  Local i, c As Long
  Local hWin As Dword
  Local vr As Variant
  Local ws As WString
  Local qe, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, tot As Quad
  Local s, e As Single
  Local v(), u As WString
  ReDim v(%COUNT)
 
  ConWriteln "Running test..."
  ConWriteln "Formatting..."
  Tix q1
  For i=1 To %COUNT
    v(i) = Format$(i)
  Next
  Tix End q1
 
  Tix tot
  s = Timer
 
  ConWriteln "Adding..."
  Tix q2
  For i=1 To %COUNT
    b.Add v(i), v(i)
  Next
  Tix End q2
 
  ConWriteln "Entry..."
  Tix q3
  For i=1 To %COUNT
    b.Entry( i, ws, vr )
    If ws<>v(i) Then ConWriteln Using$( "Item # is &", i, u )
  Next
  Tix End q3
 
  ' No equivalent
  ConWriteln "IndexOf..."
  Tix q4
  For i=1 To %COUNT
    If b.Contains( v(i) )<>i Then
      ConWriteln Using$( "Contains & = #, not #,", v(i), b.Contains( v(i) ), i )
    End If
  Next
  Tix End q4
 
  ConWriteln "Contains..."
  Tix q5
  For i=1 To %COUNT
    If IsFalse( b.Contains( v(i) ) )  Then ConWriteln "Find missed '" + Format$(i) + "'"
  Next
  Tix End q5
 
  ConWriteln "Count..."
  Tix q6
  For i=0 To %COUNT-1
    c = b.Count()
  Next
  Tix End q6
 
 
  ConWriteln "Adding..."
  Tix q7
  For i=1 To %COUNT
    b.Add( v(i), v(i) )
  Next
  Tix End q7
 
  ConWriteln "Clear..."
  Tix q8
  b.Clear()
  Tix End q8
 
  ConWriteln "Adding..."
  Tix q9
  For i=1 To %COUNT
    b.Add( v(i), v(i) )
  Next
  Tix End q9
 
  ConWriteln "Iterate...."
  Tix q10
  b.First()
  While ObjResult=%S_Ok
    b.Next()
  Wend
  Tix End q10
 
  ConWriteln "Remove..."
  Tix q11
  For i=1 To %COUNT
    ws = v(i)
    b.Remove( ws )
  Next
  Tix End q11
 
  ConWriteln "Clear..."
  Tix q12
  b.Clear()
  Tix End q12
 
  Tix End tot
 
  e = Timer
 
  Local tixPerSec As Single
  Local tests As Long
  tests = 11
  tixPerSec = (tot) / (e-s)
  Open "PowerColl.txt" For Output As #1
  Print #1,  "Finished";    $Tab; %COUNT; $Tab; "Tix/Op"; $Tab; "Ops/Sec"
  Print #1,  "Format";      $Tab; q1;   $Tab; q1/%COUNT;  $Tab; tixPerSec/q1*%COUNT
  Print #1,  "Add";         $Tab; q2;   $Tab; q2/%COUNT;  $Tab; tixPerSec/q2*%COUNT
  Print #1,  "Entry";       $Tab; q3;   $Tab; q3/%COUNT;  $Tab; tixPerSec/q3*%COUNT
  Print #1,  "IndexOf";     $Tab; q4;   $Tab; q4/%COUNT;  $Tab; tixPerSec/q4*%COUNT
  Print #1,  "Contains";    $Tab; q5;   $Tab; q5/%COUNT;  $Tab; tixPerSec/q5*%COUNT
  Print #1,  "Count";       $Tab; q6;   $Tab; q6/%COUNT;  $Tab; tixPerSec/q6*%COUNT
  Print #1,  "Add";         $Tab; q7;   $Tab; q7/%COUNT;  $Tab; tixPerSec/q7*%COUNT
  Print #1,  "Clear";       $Tab; q8;   $Tab; q8/%COUNT;  $Tab; tixPerSec/q8*%COUNT
  Print #1,  "Add";         $Tab; q9;   $Tab; q9/%COUNT;  $Tab; tixPerSec/q9*%COUNT
  Print #1,  "Iterate";     $Tab; q10;  $Tab;q10/%COUNT;  $Tab; tixPerSec/q10*%COUNT
  Print #1,  "Remove";      $Tab; q11;  $Tab; q11/%COUNT; $Tab; tixPerSec/q11*%COUNT
  Print #1,  "Clear";       $Tab; q12;  $Tab; q12/%COUNT; $Tab; tixPerSec/q12*%COUNT
  Print #1,  "Total";       $Tab; tot
  Print #1,  "Elapsed";     $Tab; e-s
  Print #1,  "Tix/Sec";     $Tab; (tot) / (e-s)
  Print #1,  "Tests";       $Tab; tests
  Print #1,  "Ops/Sec";     $Tab; (%COUNT*tests) / (e-s)
  Close #1
End Sub
 
 
'==============================================
' Super simple console routines
'==============================================
Global constdout As Dword
Global constdin As Dword
Global conattached As Long
 
Sub ConInit()
  If AttachConsole( %ATTACH_PARENT_PROCESS ) = 0 Then
    AllocConsole()
  Else
    conattached = 1
  End If
  ConStdOut = GetStdHandle(%STD_OUTPUT_HANDLE)
  ConStdIn = GetStdHandle(%STD_INPUT_HANDLE)
  If conattached Then ConWriteln ""
End Sub
 
Sub ConClose()
  Local e As INPUT_RECORD
  Local r As Long
 
  If conattached Then
    e.EventType = %KEY_EVENT
    e.KeyEvent.bKeyDown = 1
    e.KeyEvent.wRepeatCount = 1
    e.KeyEvent.wVirtualKeyCode = %VK_RETURN
    e.KeyEvent.wVirtualScanCode = VkKeyScan(%VK_RETURN)
    e.KeyEvent.AsciiChar = Chr$(13)
    WriteConsoleInput( ConStdIn, ByRef e, 1, r )
 
    e.KeyEvent.bKeyDown = 0
    WriteConsoleInput( ConStdIn, ByRef e, 1, r )
    FreeConsole
  End If
End Sub
 
Function ConGetch() As Byte
  Local r As Long
  Local buf As AsciiZ*2
  While r=0
    ReadConsole( ConStdIn, buf, 1, r, ByVal 0 )
    If r=0 Then Sleep 50
  Wend
  Function = Asc( buf )
End Function
 
Function ConLineInput() As String
  Local ch As Byte
  Local v As String
  Do
    ch = conGetch()
    Select Case Const ch
      Case 13: Exit Loop
      Case 8: If v<>"" Then v=Left$( v, Len(v)-1 )
      Case Else
        If ch>=32 And ch<128 Then v += Chr$( ch )
    End Select
  Loop
  Function = v
End Function
 
Sub ConWrite( msg As String )
  Local w As Long
  WriteConsole( ConStdOut, ByVal StrPtr( msg ), Len(msg ), w, 0 )
End Sub
 
Sub ConWriteln( msg As String )
  ConWrite( msg )
  ConWrite( $CrLf )
End Sub
 
Sub ConGetCell( r As Long, c As Long )
  Local v As CONSOLE_SCREEN_BUFFER_INFO
  GetConsoleScreenBufferInfo ConStdOut, v
  c = v.dwCursorPosition.x
  r = v.dwCursorPosition.y
End Sub
 
Sub ConSetCell( ByVal r As Long, ByVal c As Long )
  SetConsoleCursorPosition ConStdOut, Mak(Dword, c, r )
End Sub
 
Sub ConColor( ByVal fg As Long, ByVal bg As Long )
  Shift Left bg, 4
  fg Or= bg
  SetConsoleTextAttribute ConStdOut, fg
End Sub
 
Function ConWidth() As Long
    Local buf As CONSOLE_SCREEN_BUFFER_INFO
    GetConsoleScreenBufferInfo ConStdOut, buf
    Function = buf.dwSize.X
End Function
 
Sub ConCls( ByVal fg As Long, ByVal bg As Long )
    Local buf As CONSOLE_SCREEN_BUFFER_INFO
    Local conSize, written As Dword
    Local p As Dword
 
    GetConsoleScreenBufferInfo ConStdOut, buf
    conSize = buf.dwSize.X * buf.dwSize.Y
 
    FillConsoleOutputCharacter ConStdOut, 32, conSize, p, written
 
    Shift Left bg, 4
    fg Or= bg
    SetConsoleTextAttribute ConStdOut, fg
 
    FillConsoleOutputAttribute ConStdOut, fg, conSize, p, written
 
    ConSetCell 0, 0
End Sub
 
'==============================================

StringBagDynamic.inc

Code:

#Include This Once
 
#Include Once "windows.inc"
 
Type tStringEntry
  hashcode_ As Long               ' Hashcode for entry (0=Deleted)
  next_ As tStringEntry Ptr       ' next entries_
  key_ As Long                    ' String (Stolen from PB)
End Type
 
Type tStringBag
  table_ As Long Ptr              ' Array of Pointers to entries_
  entries_ As tStringEntry Ptr    ' Array of bagEntries
  highwater_ As Long              ' # of items in entries_
  tableCount_ As Long             ' total # of slots in table_
  entryCount_ As Long             ' total # of slots in entries_
  freeCount_ As Long              ' Shouldn't really count these...
  free_ As Long                   ' first free entries_ offset (+1)
  compare_ As Long                ' FastProc compare routine
  hash_ As Long                   ' FastProc Hash routine
 
End Type
 
AsmData StringRndBlock
DD &hA39C, &h455F, &h780A, &h3CF8, &h2B21, &h6B59, &hD08E, &h786E, &h43A6, &hA7C5, &h348F, &h99C7, &h6BBF, &h10BE, &hE490, &hBD3A
DD &h30E5, &h2BC8, &h0710, &h19F6, &hB87A, &hCB09, &hEABB, &hFD04, &h161E, &hECC5, &h53D3, &hFC63, &hBB32, &h1919, &h40DE, &h7E5E
DD &h8BAC, &hF9FA, &hD292, &hF132, &h641B, &h296E, &h42FF, &h4EDF, &h1CFA, &h720A, &h17FC, &hC94B, &h573B, &hFDAC, &hFCD5, &hBA9F
DD &h9E0C, &h2E7B, &hEF34, &h35DB, &hA9ED, &h1E1E, &hAB4E, &hD3BC, &hD0F6, &hFF3A, &h834F, &h97D1, &hF063, &hDD2F, &h0E08, &h09D9
DD &h5B61, &h7614, &h58D8, &hDF61, &h9B1D, &h2AF1, &h88D9, &hD19C, &h0C0B, &h423C, &h174E, &h7B82, &hA475, &hF898, &h154A, &h5C2E
DD &h7046, &h1BCA, &h22A2, &h5972, &h8E16, &h2BFD, &h0415, &h5EBC, &hB976, &h3F38, &h04BB, &hF42F, &hAE7E, &h231E, &h8EAD, &hE9FA
DD &hF295, &h78E6, &hA6F4, &h73FD, &hCE81, &hC79A, &h38B5, &h519D, &h85B1, &hC095, &h5B9B, &hDDE5, &h16C7, &h3238, &h0185, &h23DE
DD &h116A, &h64ED, &hB771, &h5331, &h4D4B, &hDE5F, &h65AA, &h30FD, &h8E77, &hC6F8, &h3B2F, &h60F3, &h62DD, &h6D9D, &h3064, &hA2B9
DD &hC520, &hA5A7, &hCCFD, &h5F7E, &h509F, &hFB22, &h1D28, &h23DA, &h12C3, &hF94B, &h01FB, &hE1EA, &h4589, &hFF44, &h491F, &h17A9
DD &h7F51, &h5F1B, &h37BB, &h3592, &h23E6, &hC2FB, &h74A3, &hE175, &h22CF, &h14B2, &h7DC3, &hF197, &h4ED7, &h6365, &h14C7, &h3C0E
DD &hDAD8, &h8390, &h4F0D, &h965C, &hC7CD, &h6541, &h34CD, &hA14B, &h5018, &h5C96, &h1B88, &h3D0A, &h9C12, &hD875, &h27AF, &hC187
DD &h4BD1, &h438C, &hA196, &h570C, &hA23F, &h0B8A, &h0999, &h0B1D, &h5D59, &h0A9D, &h178E, &h7D92, &h87C4, &hCF2D, &h116C, &h41F1
DD &hCF97, &h7DD8, &h253A, &h5110, &h2E65, &h49AE, &hB23B, &h26E9, &hEE8B, &hBEAF, &hAD58, &h68BD, &h59BA, &h5A83, &h8CCF, &h2F6E
DD &h9CC5, &h2F79, &h671B, &h5217, &hACAC, &h8DC4, &h3124, &h4CEE, &h38EA, &hEEF2, &h47A9, &hA05C, &hF6FD, &h9FAE, &hAFEC, &hC45A
DD &hD335, &hE3B8, &hBB9D, &h0C10, &hD2BF, &h9022, &hFC09, &h15AA, &hB2F1, &h57CD, &hB084, &hA27C, &h91D9, &h4625, &h1C15, &hF357
DD &h2C02, &h241A, &h6E62, &h052B, &h7B87, &hC360, &h2BDC, &h49DE, &hC45C, &h6BE8, &h412C, &hB96D, &h59D9, &hE79F, &h2DDE, &h5742
End AsmData
 
Macro StringBag_HashCode(hc,value)
  MacroTemp i
  Local i As Long
  hc =  2477664281
  For i=1 To Len(value)
    hc *= 1647726497
    hc += Asc( value, i )
  Next
  hc And= &h7fffffff
End Macro
 
 
'Macro StringBag_HashCode(hc,value)
'  macrotemp p, i
'  local p as dword ptr
'  local i as long
'  p = codeptr( StringRndBlock )
'  hc =  2477664281
'  for i=1 to len(value)
'    hc = hc xor @p[ hc And &hff ] + asc( value, i )
'  Next
'  hc and= &h7fffffff
'  Prefix "!"
'  mov eax, hc
'  End Prefix
'End Macro
 
' Modified Pearson, sample from Wayne Diamond (http://web.archive.org/web/200803281...m/pbcrypto.php)
'Macro StringBag_HashCode(hc,value)
'  MacroTemp StrHash_Loop
'  Prefix "!"
'  mov   esi, value
'  mov   eax, 0                  ; set to 0 for FNV-0, or 2166136261 for FNV-1
'  mov   esi, [esi]              ; esi = StrPtr( value )
'  ;mov   edi, &h01000193         ; FNV_32_PRIME = 16777619
'  mov   edi, 1647726497         ; FNV_32_PRIME = 16777619
'  mov   ecx, [esi-4]            ; edi = StrLen(value)
'  xor   ebx, ebx
'StrHash_Loop:
'  movzx ebx,  byte ptr [esi]     ; bl = byte from esi
'  inc   esi
'  mul   edi                     ; eax = eax * FNV_32_PRIME
'  xor   eax, ebx                ; al = al xor bl
'  sub   ecx, 1
'  jnz   StrHash_Loop            ; if ecx is 0, jmp to NextByte
'StrHash_Loop4:
'  and   eax, &h7fffffff
'  mov   hc, eax
'  End Prefix
'End Macro
 
' Modified Pearson, sample from Wayne Diamond (http://web.archive.org/web/200803281...m/pbcrypto.php)
'Macro StringBag_HashCode(hc,value)
'  MacroTemp StrHash_Loop
'  Prefix "!"
'  mov   esi, value
'  mov   eax, 2166136261         ; set to 0 for FNV-0, or 2166136261 for FNV-1
'  mov   esi, [esi]              ; esi = StrPtr( value )
'  mov   edi, &h01000193         ; FNV_32_PRIME = 16777619
'  mov   ecx, [esi-4]            ; edi = StrLen(value)
'  shr   ecx, 2                  ; DWORDS
'  jz    StrHash_Loop2
'StrHash_Loop:
'  mov   ebx,  [esi]             ; bl = byte from esi
'  add   esi, 4                  ; next dword
'  mul   edi                     ; eax = eax * FNV_32_PRIME
'  xor   eax, ebx                ; al = al xor bl
'  sub   ecx, 1
'  jnz   StrHash_Loop            ; if ecx is 0, jmp to NextByte
'StrHash_Loop2:                  ; tail bytes
'  mov   ecx, value
'  mov   ecx, [ecx]              ; ecx = StrPtr( value )
'  mov   ecx, [ecx-4]            ; ecx = Len( value )
'  and   ecx, 3
'  jz    StrHash_Loop4
'StrHash_Loop3:
'  movzx ebx, byte ptr [esi+0]   ; bl = byte from esi
'  mul   edi                     ; eax = eax * FNV_32_PRIME
'  xor   eax, ebx                ; al = al xor bl
'  sub   ecx, 1
'  jz   StrHash_Loop4            ; if ecx is 0, jmp to NextByte
'  movzx ebx, byte ptr [esi+1]   ; bl = byte from esi
'  mul   edi                     ; eax = eax * FNV_32_PRIME
'  xor   eax, ebx                ; al = al xor bl
'  sub   ecx, 1
'  jz   StrHash_Loop4            ; if ecx is 0, jmp to NextByte
'  movzx ebx, byte ptr [esi+2]   ; bl = byte from esi
'  mul   edi                     ; eax = eax * FNV_32_PRIME
'  xor   eax, ebx                ; al = al xor bl
'StrHash_Loop4:
'  and   eax, &h7fffffff
'  mov   hc, eax
'  End Prefix
'End Macro
 
'Macro StringBag_HashCode(hc,value)
'  MacroTemp StrHash_Loop, StrHash_Remainder, StrHash_Loop2, StrHash_End
'  Prefix "!"
'  mov   esi, value
'  mov   eax, 1647726497         ; eax = 1
'  mov   esi, [esi]              ; esi = StrPtr( value )
'  mov   edi, [esi-4]            ; edi = StrLen(value)
'  shr   edi, 2                  ; len( value ) / 4
'  jz    StrHash_Remainder       ; if edi=0 No full dwords (<4 bytes)
'  align 4
'StrHash_Loop:
'  mov   ebx, [esi]              ; Load word
'  add   esi, 4                  ; esi += 4
'  mov   ecx, eax
'  rol   eax, 7
'  xor   eax, ecx
'  add   eax, ebx                ; eax += @pValue[ i ]
'  sub   edi, 1
'  jnz   StrHash_Loop
'StrHash_Remainder:
'  mov   edi, value
'  mov   edi, [edi]              ; edi = StrPtr( value )
'  mov   edi, [edi-4]            ; edi = Len( value )
'  and   edi, 3                  ; StrLen( value ) Mod 4
'  jz    StrHash_End             ; No remainder!
'StrHash_Loop2:
'  movzx ebx, byte ptr [esi]
'  mov   ecx, eax
'  rol   eax, 7
'  xor   eax, ecx
'  add   eax, ebx                ; eax += @pValue[ i ]
'  sub   edi, 1
'  jz   StrHash_End
'  movzx ebx, byte ptr [esi+1]
'  mov   ecx, eax
'  rol   eax, 7
'  xor   eax, ecx
'  add   eax, ebx                ; eax += @pValue[ i ]
'  sub   edi, 1
'  jz   StrHash_End
'  movzx ebx, byte ptr [esi+2]
'  mov   ecx, eax
'  rol   eax, 7
'  xor   eax, ecx
'  add   eax, ebx                ; eax += @pValue[ i ]
'StrHash_End:
'  and   eax, &H7fffffff         ; eax = Abs( eax )
'  mov   hc, eax                 ; hc = hash
'  End Prefix
'End Macro
 
Sub StringBag_Alloc( obj As Dword )
#Register None
  Static heap As Long
  If IsFalse(heap) Then heap = GetProcessHeap()
  obj = HeapAlloc( heap, %HEAP_ZERO_MEMORY, SizeOf( tStringBag ) )
  StringBag_Init ByVal obj
End Sub
 
Sub StringBag_Free( obj As Dword )
#Register None
  Local o As tStringBag Ptr
  Static heap As Long
 
  If IsFalse(heap) Then heap = GetProcessHeap()
  o = obj
  StringBag_Release @o
  If obj Then HeapFree heap, 0, obj
  obj = 0
End Sub
 
Sub StringBag_Init( obj As tStringBag, Optional ByVal requestedSize As Long )
#Register None
  If obj.entries_ Then StringBag_Release obj
  StringBag_Expand obj, requestedSize
End Sub
 
Sub StringBag_Expand( obj As tStringBag, Optional ByVal requestedSize As Long )
#Register None
  Local i As Long
  Local e As tStringEntry Ptr
  Local index As Long
  Local entryCount, tableCount, memSize, entrySize, tableSize As Long
  Static heap As Long
 
  If requestedSize=0 Then requestedSize=obj.tableCount_
  If IsFalse(heap) Then heap = GetProcessHeap()
  tableCount = BagGetNextCollectionSize( requestedSize )
  entryCount = CLng( tableCount * .75! )
  'Use the following if you make small increases to the tableCount
  'If entryCount<=obj.highwater_ Then entryCount = obj.highwater_+1
  tableSize = tableCount * SizeOf( entrySize )
  entrySize = entryCount * SizeOf( tStringEntry )
  memSize = tableSize + entrySize
 
  ' Single allocation: Layout Entries followed by hashtable
  ' Reason: Existing entries need to be retained while new values and the hashtable need to be zero'ed.
  If obj.entries_ Then
    obj.entries_ = HeapReAlloc( heap, 0, obj.entries_, memSize )
    If IsFalse( obj.entries_ ) Then
      ? "Failed allocation"
      End
    End If
    ' Zero bag entries after active ones and all of hashtable
    Local sz, ofs As Long
    sz = (entryCount-obj.highwater_) * SizeOf( tStringEntry )
    ofs = obj.highwater_ * SizeOf( tStringEntry )
    If sz<0 Then
      ofs = entrySize
      sz = 0
    End If
 
    Memory Fill obj.entries_+ofs, tableSize+sz, Byte 0
  Else
    obj.entries_ = HeapAlloc( heap, %HEAP_ZERO_MEMORY, memSize )
    If IsFalse( obj.entries_ ) Then
      ? "Failed allocation"
      End
    End If
  End If
  obj.table_ = obj.entries_ + entrySize
 
  ' Redistribute hashes
  e = obj.entries_
  For i = 0 To obj.highwater_ - 1
    If @e.hashCode_ Then
      index = @e.hashCode_ Mod tableCount
      @e.next_ = obj.@table_[ index ]
      obj.@table_[ index ] = e
    End If
    e += SizeOf( tStringEntry )
  Next
  obj.tableCount_ = tableCount
  obj.entryCount_ = entryCount
End Sub
 
Function StringBag_Contains ( obj As tStringBag, value As String ) As Long
#Register None
  Local hc As Long
  Local e As tStringEntry Ptr
  Local sp As String Ptr
 
   StringBag_HashCode(hc,value)
 
   If IsFalse( obj.table_ ) Then Exit Function
 
   e = obj.@table_[ hc Mod obj.tableCount_ ]
   While e
     If @e.hashCode_ = hc Then
       sp = VarPtr( @e.key_ )
       If @sp = value Then
         Function = -1
         Exit Function
       End If
     End If
     e = @e.next_
   Wend
End Function
 
Function StringBag_Add( obj As tStringBag, value As String ) As Long
#Register None
  Local index, hc As Long
  Local e As tStringEntry Ptr
  Local sp As String Ptr
 
 
  StringBag_HashCode(hc,value)
 
  If obj.table_ Then
    index = hc Mod obj.tableCount_
    e = obj.@table_[ index ]
    While e
      If @e.hashCode_ = hc Then
        sp = VarPtr( @e.key_ )
        If @sp = value Then
          Function = 0
          Exit Function
        End If
      End If
      e = @e.next_
    Wend
  End If
 
  If obj.free_ Then
    ' Use freed items first
    e = obj.free_
    obj.free_ = @e.next_
    Decr obj.freeCount_
  Else
    If obj.highwater_ >= obj.entryCount_ Then
      StringBag_Expand obj
      index = hc Mod obj.tableCount_
    End If
    If IsFalse( obj.table_ ) Or IsFalse( obj.entries_ ) Then
      ? "Alloc failed"
      End
    End If
    e = VarPtr( obj.@entries_[ obj.highwater_ ] )
    Incr obj.highwater_
  End If
 
  'StringEntry_Init
  sp = VarPtr( @e.key_ )
  @sp = value
  @e.hashCode_ = hc
 
  @e.next_ = obj.@table_[ index ]   ' 1-n, or 0 if no next
  obj.@table_[ index ] = e
 
  Function = -1
End Function
 
' Empty the bag
Sub StringBag_Release( obj As tStringBag, Optional ByVal requestedSize As Long )
#Register None
  Register i As Long
  Static heap As Long
  Local sp As String Ptr
 
  If obj.entries_ Then
    If IsFalse(heap) Then heap = GetProcessHeap()
    For i=0 To obj.highwater_- 1
      sp = VarPtr( obj.@entries_[i].key_ )
      @sp = ""
    Next
    HeapFree heap, 0, obj.entries_
    Reset obj
  End If
  If requestedSize>0 Then
    StringBag_Expand obj, requestedSize
  End If
End Sub
 
Function StringBag_IndexOf( obj As tStringBag, value As String ) As Long
#Register None
  Local hc As Long
  Local e As tStringEntry Ptr
  Local sp As String Ptr
 
  If obj.table_  Then
    StringBag_HashCode(hc,value)
    e = obj.@table_[ hc Mod obj.tableCount_ ]
    While e
      If @e.hashCode_ = hc Then
        sp = VarPtr( @e.key_ )
        If @sp = value Then
          Function = (e-obj.entries_) \ SizeOf( tStringEntry )
          Exit Function
        End If
      End If
      e = @e.next_
    Wend
  End If
  Function = -1
End Function
 
' Number of items in the bag
Function StringBag_Count( obj As tStringBag ) As Long
  Function = obj.highwater_ - obj.freeCount_
End Function
 
' Max Index # can go
Function StringBag_HighWater( obj As tStringBag ) As Long
  Function = obj.highwater_
End Function
 
Function StringBag_Remove ( obj As tStringBag, value As String ) As Long
  Function = StringBag_RemoveAt( obj, StringBag_IndexOf( obj, value ) )
End Function
 
Function StringBag_RemoveAt ( obj As tStringBag, ByVal i As Long ) As Long
#Register None
  Register index As Long
  Register j As Long
  Local e, f As tStringEntry Ptr
 
 
  If i<0 Or i>=obj.highwater_ Then  Exit Function   ' Out of bounds
  e = VarPtr( obj.@entries_[i] )
  If IsFalse( @e.hashCode_ ) Then Exit Function ' Already deleted
 
  index = @e.hashCode_ Mod obj.tableCount_
 
  If obj.@table_[ index ] = e Then
    obj.@table_[ index ] = @e.next_: ' First item in list
  Else
    ' Have prior entry's next point past the entry to remove
    f = obj.@table_[ index ]
    Do While f
      If @f.next_ = e Then
        @f.next_ = @e.next_
        Exit Loop
      End If
      f = @f.next_
    Loop
  End If
  ' Reuse the free entries (Leaving string alone, we'll free it when reusing or clearing)
  @e.hashCode_ = 0
  @e.next_ = obj.free_
  obj.free_ = e
  Incr obj.freeCount_
  Function =-1
End Function
 
Sub StringBag_Clear( obj As tStringBag )
  Local i As Long
  Local e, n As tStringEntry Ptr
 
  If IsFalse( obj.highwater_ ) Then Exit Sub
  e = obj.entries_
  obj.free_ = e
  For i=0 To obj.highwater_-2
    @e.next_ = e + SizeOf( tStringEntry )
    @e.hashCode_ = 0
    e = @e.next_
  Next
  @e.next_ = 0
  @e.hashCode_ = 0
  obj.freeCount_ = obj.highWater_
  If obj.tableCount_ Then Memory Fill obj.table_, obj.tableCount_*SizeOf(i), Byte 0
End Sub
 
Sub StringBag_RemoveAll( obj As tStringBag )
  Local i As Long
  Local e, n As tStringEntry Ptr
 
  If IsFalse( obj.highwater_ ) Then Exit Sub
  e = obj.entries_
  obj.free_ = e
  For i=0 To obj.highwater_-2
    @e.next_ = e + SizeOf( tStringEntry )
    @e.hashCode_ = 0
    e = @e.next_
  Next
  @e.next_ = 0
  @e.hashCode_ = 0
  obj.freeCount_ = obj.highWater_
  If obj.tableCount_ Then Memory Fill obj.table_, obj.tableCount_*SizeOf(i), Byte 0
End Sub
 ' Get an item by index, returns empty string if out of bounds
Sub StringBag_Item( obj As tStringBag, ByVal index As Long, v As String )
  Local sp As String Ptr
  If index>=0 And index<obj.highwater_ And obj.@entries_[ index ].hashCode_ Then
    sp = VarPtr( obj.@entries_[ index ].key_ )
    v = @sp
  Else
    v = ""
  End If
End Sub
 
Function BagGetNextCollectionSize( ByVal tableCount As Long ) Common As Long
  Static vPrimes() As Long
  Static vInit As Long
  Local i As Long
 
  If Not vInit Then
    ReDim vPrimes(25)
    Array Assign vPrimes() = _
            53, 97, 193, 389, 769, 1543, 3079, 6151, 12289 _
            , 24593, 49157, 98317, 196613, 393241, 786433 _
            , 1572869, 3145739, 6291469, 12582917, 25165843 _
            , 50331653, 100663319, 201326611, 402653189 _
            , 805306457, 1610612741
    vInit = -1
  End If
 
  Incr tableCount
  For i=0 To 24
    If vPrimes(i)>=tableCount Then
      Function = vPrimes(i)
      Exit Function
    End If
  Next
 
  Function = vPrimes(25)
End Function

TestCmpPowCol.bas

Code:

#Compiler PBCC 6, PBWin 10
#Compile Exe
#Dim All
#Optimize Speed
#If %Def( %PB_CC32 )
#Console Off
#EndIf
 
#Include "StringBagDynamic.inc"
 
%COUNT = 100000
' Comment out the line below to use a local (stack based) stringbag variable
' With it uncommented, it will use a dynamically allocated stringbag
%DYNAMIC = 1
 
Function PBMain () As Long
  ConInit
  ConCls 9, 15
#If %Def( %DYNAMIC )
  Local a As tStringBag Ptr
  StringBag_Alloc a
  Test @a
  StringBag_Free a
#Else
  Local a As tStringBag
  Test a
#EndIf
  ConWrite "Finished"
  ConClose
End Function
 
Sub Test( b As tStringBag )
  Local i, c As Long
  Local hWin As Dword
  Local qe, q1, q2, q3, q4, q5, q6, q7, q8, q9, q10, q11, q12, tot As Quad
  Local s, e As Single
  Local v(), u As String
  ReDim v(%COUNT)
 
  ConWrite "Running "
#If %Def( %DYNAMIC )
  ConWrite "dynamic "
#Else
  ConWrite "local "
#EndIf
  ConWriteln "test..."
  ConWriteln "Formatting..."
  Tix q1
  For i=1 To %COUNT
    v(i) = Format$(i)
  Next
  Tix End q1
 
  Tix tot
  s = Timer
 
  ConWriteln "Initing..."
  StringBag_Init b, %COUNT
 
  ConWriteln "Adding..."
  Tix q2
  For i=1 To %COUNT
    StringBag_Add b, v(i)
  Next
  Tix End q2
 
  ConWriteln "Entry..."
  Tix q3
  For i=0 To StringBag_Count(b)-1
    StringBag_Item( b, i, u )
    If u<>v(i+1) Then ConWriteln Using$( "Item # is &", i, u )
  Next
  Tix End q3
 
  ConWriteln "IndexOf..."
  Tix q4
  For i=1 To %COUNT
    If StringBag_IndexOf( b, v(i) )<>i-1 Then
      ConWriteln Using$( "IndexOf & = #, not #,", v(i), StringBag_IndexOf( b, v(i) ), i-1 )
    End If
  Next
  Tix End q4
 
  ConWriteln "Contains..."
  Tix q5
  For i=1 To %COUNT
    If IsFalse( StringBag_Contains( b, v(i) ) ) Then ConWriteln "Find missed '" + Format$(i) + "'"
  Next
  Tix End q5
 
  ConWriteln "Count..."
  Tix q6
  For i=0 To %COUNT-1
    c = StringBag_Count( b )
  Next
  Tix End q6
 
 
  ConWriteln "Adding..."
  Tix q7
  For i=1 To %COUNT
    StringBag_Add b, v(i)
  Next
  Tix End q7
 
  ConWriteln "RemoveAll..."
  Tix q8
  StringBag_RemoveAll b
  Tix End q8
 
  ConWriteln "Adding..."
  Tix q9
  For i=1 To %COUNT
    StringBag_Add b, v(i)
  Next
  Tix End q9
 
  ConWriteln "Iterate..."
  Tix q10
  For i = 1 To %COUNT
    StringBag_Item b, i, u
  Next
  Tix End q10
 
 
  ConWriteln "Remove..."
  Tix q11
  For i=0 To %COUNT-1
    StringBag_Remove( b, v(i+1) )
  Next
  Tix End q11
 
  ConWriteln "Clear..."
  Tix q12
  StringBag_Release b
  Tix End q12
 
  Tix End tot
 
  e = Timer
  Local tixPerSec As Single
  Local tests As Long
  tests = 11
  tixPerSec = (tot) / (e-s)
  Open "Time.txt" For Output As #1
  Print #1,  "Finished";    $Tab; %COUNT; $Tab; "Tix/Op"; $Tab; "Ops/Sec"
  Print #1,  "Format";      $Tab; q1;   $Tab; q1/%COUNT;  $Tab; tixPerSec/q1*%COUNT
  Print #1,  "Add";         $Tab; q2;   $Tab; q2/%COUNT;  $Tab; tixPerSec/q2*%COUNT
  Print #1,  "Entry";       $Tab; q3;   $Tab; q3/%COUNT;  $Tab; tixPerSec/q3*%COUNT
  Print #1,  "IndexOf";     $Tab; q4;   $Tab; q4/%COUNT;  $Tab; tixPerSec/q4*%COUNT
  Print #1,  "Contains";    $Tab; q5;   $Tab; q5/%COUNT;  $Tab; tixPerSec/q5*%COUNT
  Print #1,  "Count";       $Tab; q6;   $Tab; q6/%COUNT;  $Tab; tixPerSec/q6*%COUNT
  Print #1,  "Add";         $Tab; q7;   $Tab; q7/%COUNT;  $Tab; tixPerSec/q7*%COUNT
  Print #1,  "Clear";       $Tab; q8;   $Tab; q8/%COUNT;  $Tab; tixPerSec/q8*%COUNT
  Print #1,  "Add";         $Tab; q9;   $Tab; q9/%COUNT;  $Tab; tixPerSec/q9*%COUNT
  Print #1,  "Iterate";     $Tab; q10;  $Tab;q10/%COUNT;  $Tab; tixPerSec/q10*%COUNT
  Print #1,  "Remove";      $Tab; q11;  $Tab; q11/%COUNT; $Tab; tixPerSec/q11*%COUNT
  Print #1,  "Clear";       $Tab; q12;  $Tab; q12/%COUNT; $Tab; tixPerSec/q12*%COUNT
  Print #1,  "Total";       $Tab; tot
  Print #1,  "Elapsed";     $Tab; e-s
  Print #1,  "Tix/Sec";     $Tab; (tot) / (e-s)
  Print #1,  "Tests";       $Tab; tests
  Print #1,  "Ops/Sec";     $Tab; (%COUNT*tests) / (e-s)
  Close #1
End Sub
 
 
'==============================================
' Super simple console routines
'==============================================
Global constdout As Dword
Global constdin As Dword
Global conattached As Long
 
Sub ConInit()
  If AttachConsole( %ATTACH_PARENT_PROCESS ) = 0 Then
    AllocConsole()
  Else
    conattached = 1
  End If
  ConStdOut = GetStdHandle(%STD_OUTPUT_HANDLE)
  ConStdIn = GetStdHandle(%STD_INPUT_HANDLE)
  If conattached Then ConWriteln ""
End Sub
 
Sub ConClose()
  Local e As INPUT_RECORD
  Local r As Long
 
  If conattached Then
    e.EventType = %KEY_EVENT
    e.KeyEvent.bKeyDown = 1
    e.KeyEvent.wRepeatCount = 1
    e.KeyEvent.wVirtualKeyCode = %VK_RETURN
    e.KeyEvent.wVirtualScanCode = VkKeyScan(%VK_RETURN)
    e.KeyEvent.AsciiChar = Chr$(13)
    WriteConsoleInput( ConStdIn, ByRef e, 1, r )
 
    e.KeyEvent.bKeyDown = 0
    WriteConsoleInput( ConStdIn, ByRef e, 1, r )
    FreeConsole
  End If
End Sub
 
Function ConGetch() As Byte
  Local r As Long
  Local buf As AsciiZ*2
  While r=0
    ReadConsole( ConStdIn, buf, 1, r, ByVal 0 )
    If r=0 Then Sleep 50
  Wend
  Function = Asc( buf )
End Function
 
Function ConLineInput() As String
  Local ch As Byte
  Local v As String
  Do
    ch = conGetch()
    Select Case Const ch
      Case 13: Exit Loop
      Case 8: If v<>"" Then v=Left$( v, Len(v)-1 )
      Case Else
        If ch>=32 And ch<128 Then v += Chr$( ch )
    End Select
  Loop
  Function = v
End Function
 
Sub ConWrite( msg As String )
  Local w As Long
  WriteConsole( ConStdOut, ByVal StrPtr( msg ), Len(msg ), w, 0 )
End Sub
 
Sub ConWriteln( msg As String )
  ConWrite( msg )
  ConWrite( $CrLf )
End Sub
 
Sub ConGetCell( r As Long, c As Long )
  Local v As CONSOLE_SCREEN_BUFFER_INFO
  GetConsoleScreenBufferInfo ConStdOut, v
  c = v.dwCursorPosition.x
  r = v.dwCursorPosition.y
End Sub
 
Sub ConSetCell( ByVal r As Long, ByVal c As Long )
  SetConsoleCursorPosition ConStdOut, Mak(Dword, c, r )
End Sub
 
Sub ConColor( ByVal fg As Long, ByVal bg As Long )
  Shift Left bg, 4
  fg Or= bg
  SetConsoleTextAttribute ConStdOut, fg
End Sub
 
Function ConWidth() As Long
    Local buf As CONSOLE_SCREEN_BUFFER_INFO
    GetConsoleScreenBufferInfo ConStdOut, buf
    Function = buf.dwSize.X
End Function
 
Sub ConCls( ByVal fg As Long, ByVal bg As Long )
    Local buf As CONSOLE_SCREEN_BUFFER_INFO
    Local conSize, written As Dword
    Local p As Dword
 
    GetConsoleScreenBufferInfo ConStdOut, buf
    conSize = buf.dwSize.X * buf.dwSize.Y
 
    FillConsoleOutputCharacter ConStdOut, 32, conSize, p, written
 
    Shift Left bg, 4
    fg Or= bg
    SetConsoleTextAttribute ConStdOut, fg
 
    FillConsoleOutputAttribute ConStdOut, fg, conSize, p, written
 
    ConSetCell 0, 0
End Sub
 
'==============================================

**Chris Holbrook** · 4 Mar 2015, 06:15 PM

Looks as if you are halfway towards a faster Collection class!

**Larry Charlton** · 4 Mar 2015, 07:06 PM

You can do collections as is. Here's a small sample, your collection can be any type you can stick in an array. this works because the indexes of items are stable, at least until you remove them. Removing an item won't affect the stability of the other items.

Collection.bas

Code:

#Compiler PBCC 6, PBWin 10
#Compile Exe
#Dim All
#Optimize Speed
#If %Def( %PB_CC32 )
#Console Off
#EndIf
 
#Include "StringBagDynamic.inc"
 
%COUNT = 1000
Function PBMain () As Long
  Local i As Long
  Local v As String
  ConInit
  ConCls 9, 15
 
  Randomize
 
  For i=1 To %COUNT
    MapAdd Format$(i), "My test value is " + Format$(i+1000)
  Next
 
  Local msg As String
  For i = 1 To 20
    v = Format$( Rnd(1,%COUNT) )
    msg += v + "=" + MapItem(v) + $CrLf
  Next
  ? msg
  ConWrite "Finished"
  ConClose
End Function
 
Global values() As String
Global bag As tStringBag
 
Sub MapAdd( key As String, value As String )
  Local index As Long
  StringBag_Add bag, key
  index = StringBag_IndexOf( bag, key )
  If bag.entryCount_ > UBound(values())+1 Then
    ReDim Preserve values( bag.entryCount_-1 )
  End If
  values( index ) = value
End Sub
 
Function MapItem( key As String ) As String
  Local index As Long
  index = StringBag_IndexOf( bag, key )
  If index>-1 Then Function = values(index)
End Function
 
'==============================================
' Super simple console routines
'==============================================
Global constdout As Dword
Global constdin As Dword
Global conattached As Long
 
Sub ConInit()
  If AttachConsole( %ATTACH_PARENT_PROCESS ) = 0 Then
    AllocConsole()
  Else
    conattached = 1
  End If
  ConStdOut = GetStdHandle(%STD_OUTPUT_HANDLE)
  ConStdIn = GetStdHandle(%STD_INPUT_HANDLE)
  If conattached Then ConWriteln ""
End Sub
 
Sub ConClose()
  Local e As INPUT_RECORD
  Local r As Long
 
  If conattached Then
    e.EventType = %KEY_EVENT
    e.KeyEvent.bKeyDown = 1
    e.KeyEvent.wRepeatCount = 1
    e.KeyEvent.wVirtualKeyCode = %VK_RETURN
    e.KeyEvent.wVirtualScanCode = VkKeyScan(%VK_RETURN)
    e.KeyEvent.AsciiChar = Chr$(13)
    WriteConsoleInput( ConStdIn, ByRef e, 1, r )
 
    e.KeyEvent.bKeyDown = 0
    WriteConsoleInput( ConStdIn, ByRef e, 1, r )
    FreeConsole
  End If
End Sub
 
Function ConGetch() As Byte
  Local r As Long
  Local buf As AsciiZ*2
  While r=0
    ReadConsole( ConStdIn, buf, 1, r, ByVal 0 )
    If r=0 Then Sleep 50
  Wend
  Function = Asc( buf )
End Function
 
Function ConLineInput() As String
  Local ch As Byte
  Local v As String
  Do
    ch = conGetch()
    Select Case Const ch
      Case 13: Exit Loop
      Case 8: If v<>"" Then v=Left$( v, Len(v)-1 )
      Case Else
        If ch>=32 And ch<128 Then v += Chr$( ch )
    End Select
  Loop
  Function = v
End Function
 
Sub ConWrite( msg As String )
  Local w As Long
  WriteConsole( ConStdOut, ByVal StrPtr( msg ), Len(msg ), w, 0 )
End Sub
 
Sub ConWriteln( msg As String )
  ConWrite( msg )
  ConWrite( $CrLf )
End Sub
 
Sub ConGetCell( r As Long, c As Long )
  Local v As CONSOLE_SCREEN_BUFFER_INFO
  GetConsoleScreenBufferInfo ConStdOut, v
  c = v.dwCursorPosition.x
  r = v.dwCursorPosition.y
End Sub
 
Sub ConSetCell( ByVal r As Long, ByVal c As Long )
  SetConsoleCursorPosition ConStdOut, Mak(Dword, c, r )
End Sub
 
Sub ConColor( ByVal fg As Long, ByVal bg As Long )
  Shift Left bg, 4
  fg Or= bg
  SetConsoleTextAttribute ConStdOut, fg
End Sub
 
Function ConWidth() As Long
    Local buf As CONSOLE_SCREEN_BUFFER_INFO
    GetConsoleScreenBufferInfo ConStdOut, buf
    Function = buf.dwSize.X
End Function
 
Sub ConCls( ByVal fg As Long, ByVal bg As Long )
    Local buf As CONSOLE_SCREEN_BUFFER_INFO
    Local conSize, written As Dword
    Local p As Dword
 
    GetConsoleScreenBufferInfo ConStdOut, buf
    conSize = buf.dwSize.X * buf.dwSize.Y
 
    FillConsoleOutputCharacter ConStdOut, 32, conSize, p, written
 
    Shift Left bg, 4
    fg Or= bg
    SetConsoleTextAttribute ConStdOut, fg
 
    FillConsoleOutputAttribute ConStdOut, fg, conSize, p, written
 
    ConSetCell 0, 0
End Sub
 
'==============================================

**Chris Holbrook** · 5 Mar 2015, 11:50 AM

Yes that would work, but I would see it as a step on the road to a Collection which contained and managed the items itself. Not that the performance of PowerCollections (which I have used a lot) has ever held me back, but there is probably a speed freak or two around here...

**Michael Mattias** · 5 Mar 2015, 12:42 PM

>..but there is probably a speed freak or two around here...

Ya think?

**Larry Charlton** · 12 Mar 2015, 03:35 AM

Added a bag that can store most of the PowerBASIC data types here.

Each instance of a bag stores a single data type, but different bags can be created to store different types. The types that can be stored are:
String, WString, StringZ, WStringZ, Long, DWord, Word, Quad, Integer, Byte, Extended, Double, Single, Currency, CurrencyX, UDT types.

For bags containing strings you can make them either case sensitive or case insensitive with the provided collations. It uses binary collations and you can create your own custom collations as well.

The case insensitive collation is folds the lower case letters lexigraphically into the upper case letters. From a comparison perspective all letters are treated as having ascii values in the range 65 to 90.

**Chris Holbrook** · 12 Mar 2015, 03:49 AM

Yes, I had wondered about putting code inside some of those strings too. Just for a laugh.

Dont know where that smilie sprang from, but I'm sending this from a 3" screen, anything's possible.

**Michael Mattias** · 12 Mar 2015, 09:01 AM

>Yes, I had wondered about putting code inside some of those strings too. Just for a laugh.

You can do that. There is a demo here somewhere which shows how to execute a piece of code (machine code, not source code) stored in a block of memory. You need to allocate a block of memory with execute permission and call it by address (CALL DWORD), but it can be done.

IIRC You can search here for 'VirtualAllocEx' because that what was used in the demo.

No, I am not endorsing this as good programming practice.

FWIW... you could also execute code stored in a string in MS-DOS GW-BASIC using the 'CALL ABSOLUTE' statement. This technique was often used to call MS-DOS interrupts, for which there is no native support in GW-BASIC.

MCM

Announcement

Discussion for StringBag Pointer

Discussion for StringBag Pointer

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment

Comment