A$="123,45,1,89,22" how do I get column 4, which is 89?

[pagetelegram]

A$="123,45,1,89,22" how do I get column 4, which is 89? Is there a function to specify columns built in or do I need to create this function?

Using -lang qb flag

Thanks

[badidea]

A$="123,45,1,89,22" how do I get column 4, which is 89? Is there a function to specify columns built in or do I need to create this function?
Using -lang qb flag

Freebasic has no build-in split function, but several can be found here (on the forum) in the default freebasic syntax.
For example, this one from MrSwiss: viewtopic.php?f=2&t=28410&p=269935#p269942
Example use:

Code: Select all

' this is part of my: String_Procs.bi -- (c) 2019, MrSwiss
#Include "crt/string.bi"                ' needed for: SplitString()

Private Function SplitString( _         ' uses CRT's strtok() Function
    ByRef ssrc  As Const String, _      ' string to be searched
    ByRef chrs  As Const String, _      ' character(s), to search for
          res() As String _             ' result String array (ByRef, implicit!)
    ) As Long                           ' negative = error | >= 0 = OK
    Dim As Long     retv = 0            ' to hold return value

    If Len(chrs) = 0 Then retv -= 2     ' nothing to search for, set err
    If Len(ssrc) = 0 Then retv -= 1     ' no source string, set err
    If retv < 0 Then Return retv        ' return ERROR code (negative value)

    Erase(res)                          ' delete dyn. array's content (if any)
    Dim As String       s = ssrc        ' local variables: s = keeps ssrc
    Dim As ZString Ptr  psz = 0         ' result ptr (from strtok())
    Dim As UInteger     i = 0           ' counter, used as: array-index

    psz = strtok(s, chrs)               ' destroys s (must be reset! before reuse)
    While psz                           ' just to get required array size
        i += 1 : psz = strtok(0, chrs)  ' i - 1 = UBound(res)
    Wend

    retv = i - 1                        ' set arrays upper bound (return value)
    ReDim res(0 To retv)                ' size array (using retv)
    i = 0 : s = ssrc : psz = 0          ' reset i, s and psz (for next run)

    psz = strtok(s, chrs)               ' get first token (string-part)
    While psz                           ' run until psz is = 0
        res(i) = *psz                   ' assign token to array
        psz = strtok(0, chrs)           ' get next token (string-part)
        i += 1                          ' increment index
    Wend

    Return retv                         ' upper array bound (lower = 0 = default)
End Function

'example use

dim as string inputStr = "123, 45, 1 ,89,   22; 111, 222"
dim as string splitChars = ",; " 'comma, semi-colon, space
dim as string outputStr()

SplitString(inputStr, splitChars, outputStr())
for i as integer = 0 to ubound(outputStr)
    print "Index " & i & " = '" & outputStr(i) & "'"
next

[Lost Zergling]

Using #Lang FB

Code: Select all

' this is part of my: String_Procs.bi -- (c) 2019, MrSwiss
 #Include "crt/string.bi"                ' needed for: SplitString()
'# Lang "qb"


Private Function SplitString( _         ' uses CRT's strtok() Function
    ByRef ssrc  As Const String, _      ' string to be searched
    ByRef chrs  As Const String, _      ' character(s), to search for
          res() As String _             ' result String array (ByRef, implicit!)
    ) As Long                           ' negative = error | >= 0 = OK
    Dim As Long     retv = 0            ' to hold return value

    If Len(chrs) = 0 Then retv -= 2     ' nothing to search for, set err
    If Len(ssrc) = 0 Then retv -= 1     ' no source string, set err
    If retv < 0 Then Return retv        ' return ERROR code (negative value)

    Erase(res)                          ' delete dyn. array's content (if any)
    Dim As String       s = ssrc        ' local variables: s = keeps ssrc
    Dim As ZString Ptr  psz = 0         ' result ptr (from strtok())
    Dim As UInteger     i = 0           ' counter, used as: array-index

    psz = strtok(s, chrs)               ' destroys s (must be reset! before reuse)
    While psz                           ' just to get required array size
        i += 1 : psz = strtok(0, chrs)  ' i - 1 = UBound(res)
    Wend

    retv = i - 1                        ' set arrays upper bound (return value)
    ReDim res(0 To retv)                ' size array (using retv)
    i = 0 : s = ssrc : psz = 0          ' reset i, s and psz (for next run)

    psz = strtok(s, chrs)               ' get first token (string-part)
    While psz                           ' run until psz is = 0
        res(i) = *psz                   ' assign token to array
        psz = strtok(0, chrs)           ' get next token (string-part)
        i += 1                          ' increment index
    Wend

    Return retv                         ' upper array bound (lower = 0 = default)
End Function

Declare Function StrToArray(STR_LigneFichier As String, MyStrArray() As String, sep As String=";", MaxFields As uShort=65535) As Byte
Function StrToArray(STR_LigneFichier As String, MyStrArray() As String, sep As String=";", MaxFields As uShort=65535) As Byte
    Dim As zString Ptr Pz1=StrPtr(STR_LigneFichier), Pz2=Pz1
    Dim As uInteger iLen=Len(STR_LigneFichier), iCumul=0, iCumul2=0
    Dim As uShort NbFields=Ubound(MyStrArray)+1, i=0    
    Dim As uByte ubSep=Asc(sep)
    If NbFields=0 Then : Redim MyStrArray(10) : End If
    While iLen>iCumul2
        While iLen>iCumul2+iCumul And (*Pz1)[0]<>ubSep : Pz1+=1 : iCumul+=1 : Wend
        (*Pz1)[0] = 0 ' ? i & " -- " & NbFields : sleep
        If NbFields=i Then : Redim Preserve MyStrArray(i+10) : NbFields=i+10 : End If
        MyStrArray(i)=*Pz2 : i+=1
        (*Pz1)[0] = ubSep
        If MaxFields=i Then : Return 1 : End If
        Pz1+=1 : iCumul+=1 : Pz2+=iCumul
        iCumul2+=iCumul : iCumul=0
    Wend
    Return 1
End Function

'example use

Dim as String inputStr = "123, 45, 1 ,89,   22, 111, 222"
Dim as String splitChars = ",; " 'comma, semi-colon, space
Dim as String outputStr() ' use only var size arrays or implement exception handling 
Dim as Integer i
Dim as Double Start
? "-------------------------------"
Start=Timer
For i=1 To 50000
    SplitString(inputStr, splitChars, outputStr())
Next i

For i as integer = 0 to ubound(outputStr)
    print "Index " & i & " = '" & outputStr(i) & "'"
    outputStr(i) =""
Next
? "Using StrTok = " & Timer-Start
? "-------------------------------"
Start=Timer
For i=1 To 50000
    StrToArray(inputStr, outputStr(), splitChars)
Next i

for i as integer = 0 to ubound(outputStr)
    print "Index " & i & " = '" & outputStr(i) & "'"
next
? "Using FB Pointers = " & Timer-Start
? "-------------------------------"
sleep

Using #Lang "QB"

Code: Select all

# Lang "qb"
'Renvoi le nombre de ";"+1
Declare Function StrUbound(STR_LigneFichier As String, STR_Motif As String=";") As Integer
Function StrUbound(STR_LigneFichier As String, STR_Motif As String=";") As Integer
    Dim As Integer t,k, Posi
    t=0 : k=1 :  posi=1
    While k<>0 : k=Instr(Posi,STR_LigneFichier, STR_Motif) : Posi=k+1 : t+=1 : Wend
    StrUbound = t
End Function
'Renvoie la valeur n° Posi de la chaine STR_LigneFichier séparé par SEPAR (;) le premier champs est indicé 0 (comme les colonnes)
Declare Function GetField(STR_LigneFichier As String="", Posi As Integer, sep As String=";") As String
Function GetField(STR_LigneFichier As String="", Posi As Integer, sep As String=";") As String
    Dim As Integer i, i_prev, NumField, NumPos
    i=0 : NumField=0 : NumPos = Posi+1 
    Do : i_prev=i : i=Instr(i_prev+1, STR_LigneFichier, sep) : NumField +=1 : Loop Until NumField=NumPos Or i=0    
    If i=0 Then : i=Len(STR_LigneFichier)+1 : End If 
    If NumField=NumPos Then 
        GetField= Right$( Left$(STR_LigneFichier, i-1), i-i_prev-1) 
    Else 
        GetField = ""                
    End If
End Function

Dim as string inputStr : inputStr= "123, 45, 1 ,89,   22, 111, 222"
Dim as string splitChars:  splitChars= "," 'comma, only

Dim as Integer i, i_Ubound, k

Start=Timer
? "-------------------------------"
For k=1 To 5000
    i_Ubound=StrUbound(inputStr,",")
    Redim outputStr(i_Ubound-1) As String
    For i=0 To i_Ubound-1
        outputStr(i)=GetField(inputStr, i, ",")
    Next i
Next k

For i=0 to i_Ubound-1
    print "Index " & i & " = '" & outputStr(i) & "'"
Next
? "Using QB dialect = " & Timer-Start
? "-------------------------------"
sleep

Added : this one (#Lang "FB") is doing trim on spaces on the fly
Bugged - see new version below - re-edited

Code: Select all

Private Function StrToArray(STR_LigneFichier As String, MyStrArray() As String, sep As String=";", MaxFields As uShort=65535) As Byte
    Dim As zString Ptr Pz1=StrPtr(STR_LigneFichier), Pz2=Pz1, Pz3
    Dim As uInteger iLen=Len(STR_LigneFichier), iCumul=0, iCumul2=0, k=0, l=0
    Dim As uShort NbFields=Ubound(MyStrArray)+1, i=0    
    Dim As uByte ubSep=Asc(sep), uBtmp=0
    If NbFields=0 Then : Redim MyStrArray(10) : End If
    While iLen>iCumul2        
        While iLen>iCumul2+iCumul And (*Pz1)[0]<>ubSep : Pz1+=1 : iCumul+=1 : Wend
        Pz3=Pz1 : Pz1-=1 : If (*Pz1)[0] = 32 Then : uBtmp=1 : End If
        While  (*Pz1)[0] = 32 :  Pz1-=1 : iCumul2+=1 : l+=1 : Wend : Pz1+=1
        If uBtmp=1 Then : uBtmp=(*Pz1)[0] : End If
        (*Pz1)[0] = 0
        If NbFields=i Then : Redim Preserve MyStrArray(i+10) : NbFields=i+10 : End If
        While (*Pz2)[0] = 32 : Pz2+=1 : k+=1 : Wend
        MyStrArray(i)=*Pz2 : i+=1
        If uBtmp=0 Then : (*Pz1)[0] = ubSep : Else : (*Pz1)[0] = uBtmp : End If        
        Pz1=Pz3 
        If MaxFields=i Then : Return 1 : End If
        Pz1+=1  : iCumul+=1-k : Pz2+=iCumul
        iCumul2+=iCumul-l : iCumul=0 : k=0 : l=0 : uBtmp=0
    Wend
    Return 1
End Function

(significantly faster)

[MrSwiss]

@Lost Zergling,

if you have to make comparisons then, try to stay fair:

• compare only: apples vs. apples (stuff with the same functionality)
• make a sensible comparison (NOT: apples vs. oranges)

Yours is only taking a single 'separator', mine can take multiple 'separators' at once.

[Lost Zergling]

Hello Mr Swiss. Nice to see you. :-)

[dodicat]

If your separator is always a comma then perhaps a custom function would do.

Code: Select all

#lang "qb"

Function column(SomeString As String,num As Long) As String
  Dim As Long count
  count=1
  Dim As Long position,p
  position=Instr(SomeString,",")
  If position=0 Then column= ""
  If num=1 Then 
  column= Mid$(Somestring,1,position-1)
  else
  position=0
  Do
    count+=1
    position=Instr(position+1,SomeString,",")
    If position=0 Then Exit Do
    If count=num Then
      p=position
      position=Instr(position+1,SomeString,",") 
      column= Mid$(Somestring,p+1,position-p-1):exit function
    End If
  Loop 
  end if
End Function

For n As Long = 1 To 8
  Print n,column("123,45,1,89,22,-543,0,finished",n)
Next n

sleep
 

[jevans4949]

You could use the C function sscanf (in crt/stdio library) and ingnore the first three values

[Lost Zergling]

Previous StrToArray bugged, new one :

Code: Select all

Declare Function StrUbound(STR_LigneFichier As String, STR_Motif As String=";") As Integer
Function StrUbound(STR_LigneFichier As String, STR_Motif As String=";") As Integer
    Dim As Integer t,k, Posi
    t=0 : k=1 :  posi=1
    While k<>0 : k=Instr(Posi,STR_LigneFichier, STR_Motif) : Posi=k+1 : t+=1 : Wend
    StrUbound = t
End Function

Function column(SomeString As String,num As uShort) As String
  Dim As uShort count
  count=1
  Dim As uShort position,p
  position=Instr(SomeString,",")
  If position=0 Then column= ""
  If num=1 Then
  column= Mid(Somestring,1,position-1)
  else
  position=0
  Do
    count+=1
    position=Instr(position+1,SomeString,",")
    If position=0 Then Exit Do
    If count=num Then
      p=position
      position=Instr(position+1,SomeString,",")
      column= Trim( Mid(Somestring,p+1,position-p-1) ) : exit function
    End If
  Loop
  end if
End Function

Private Function StrToArray(STR_LigneFichier As String, MyStrArray() As String, sep As String=";", MaxFields As uShort=65535) As Byte
    Dim As zString Ptr Pz1=StrPtr(STR_LigneFichier), Pz2=Pz1, Pz3
    Dim As uInteger iLen=Len(STR_LigneFichier), iCumul=0, iCumul2=0, k=0 ' , l=0
    Dim As uShort NbFields=Ubound(MyStrArray)+1, iTmp=0    
    Dim As uByte ubSep=Asc(sep), uBtmp=0
    If NbFields=0 Then : Redim MyStrArray(1) : End If
    While iLen>iCumul2
        While iLen>iCumul2+iCumul And (*Pz1)[0]<>ubSep : Pz1+=1 : iCumul+=1 : Wend
        Pz3=Pz1 : Pz1-=1
        While  (*Pz1)[0] = 32 :  Pz1-=1 : uBtmp=1: Wend : Pz1+=1  ' iCumul2+=1 : l+=1 :          
        If uBtmp=1 Then : uBtmp=(*Pz1)[0] : End If
        (*Pz1)[0] = 0       
        While (*Pz2)[0] = 32 : Pz2+=1 : k+=1 : Wend        
        MyStrArray(iTmp)=*Pz2 : 
        If Ubound(MyStrArray)=iTmp Then : Redim Preserve MyStrArray(iTmp+1) : End If
        iTmp+=1 : 
        If uBtmp=0 Then : (*Pz1)[0] = ubSep 
        Else : (*Pz1)[0] = uBtmp : uBtmp=0 
        End If        
        Pz1=Pz3 
        If MaxFields=iTmp Then : Return 0 : End If
        Pz1+=1  : iCumul+=1-k : Pz2+=iCumul
        iCumul2+=iCumul+k : iCumul=0 : k=0 :'  l=0 : 
    Wend
    Return 1
End Function


Dim as String inputStr : inputStr = "123, 45, 1 ,89,   22      , 111, 222      ,                         123   ,    45, 1 ,   123   ,   45                         , 1,123, 45, 1,               89            ,   22         , 111, 222    ,    KOPMLN654         ,                           PMLN65KOPMLN65KOPMLN65JOK         "
Dim as string splitChars:  splitChars= "," 'comma, only
Dim as String outputStr() 
Dim as Double Start
Dim as Integer i, i_Ubound, k
Dim As Double FBptr, Colums

Start=Timer
? "-------------------------------"
 ' i_Ubound=StrUbound(inputStr,",")
 ' Redim outputStr(i_Ubound-1) As String
For i=1 To 50000    
    StrToArray(inputStr, outputStr(), splitChars)    
Next i
for i=0 to ubound(outputStr)
    print "Index " & i & " = '" & outputStr(i)  & "'" ' & " len=" & Len(outputStr(i))
next
FBptr=Timer-Start
? "Using FB Pointers = " & FBptr
? "-------------------------------"

Start=Timer
? "-------------------------------"

i_Ubound=StrUbound(inputStr,",")
Redim outputStr(i_Ubound-1) As String
For k=1 To 5000
    For i=0 To i_Ubound-1
        outputStr(i)= column(inputStr, i+1) 
    Next i
Next k

For i=0 to ubound(outputStr)
    print "Index " & i & " = '" & outputStr(i) & "'"
Next
Colums=Timer-Start
? "Using QB dialect (column) = " & Colums
? "-------------------------------"

If Colums<FBptr Then : ? "Dodi wins" : Else : ? "Contest" : End If

sleep
system

The more % spaces to remove compared to not empty placeholders, the more Dodicat's code faster than Ptr one.
The more fields and not empty, the faster Ptr vs Dodicat's code.

[Lost Zergling]

Finally, here is my latest version of StrToArray (#Lang FB), I added support for Chr (0). It is interesting to compete with the integrated functions of the language and I can trust Dodicat to use them at best.

Code: Select all

Function StrToArray(STR_LigneFichier As String, MyStrArray() As String, sep As String=";", MaxFields As uShort=65535) As Byte
    Dim As zString Ptr Pz1=StrPtr(STR_LigneFichier), Pz2=Pz1, Pz3
    Dim As uInteger iLen=Len(STR_LigneFichier), iCumul=0, iCumul2=0, k=0 , itot
    Dim As uShort NbFields=Ubound(MyStrArray)+1, iTmp=0    
    Dim As uByte ubSep=Asc(sep), uBtmp=0
    If NbFields=0 Then : Redim MyStrArray(1) : End If
    While iLen>iCumul2
        itot=iCumul2+iCumul
        While iLen>itot And (*Pz1)[0]<>ubSep : Pz1+=1 : If (*Pz1)[0] = 0 Then : (*Pz1)[0] = 32 : End If : itot+=1 : Wend
        iCumul=itot-iCumul2
        Pz3=Pz1 : Pz1-=1
        While  (*Pz1)[0] = 32 :  Pz1-=1 : uBtmp=1: Wend : Pz1+=1 :  If (*Pz1)[0] = 0 Then : (*Pz1)[0] = 32 : End If
        If uBtmp=1 Then : uBtmp=(*Pz1)[0] : End If
        (*Pz1)[0] = 0       
        While (*Pz2)[0] = 32 : Pz2+=1 : k+=1 : Wend
        MyStrArray(iTmp)=*Pz2 : 
        If Ubound(MyStrArray)=iTmp Then : Redim Preserve MyStrArray(iTmp+1) : End If
        iTmp+=1 : 
        If uBtmp=0 Then : (*Pz1)[0] = ubSep 
        Else : (*Pz1)[0] = uBtmp : uBtmp=0 
        End If        
        Pz1=Pz3 
        If MaxFields=iTmp Then : Return 0 : End If
        Pz1+=1  : iCumul+=1-k : Pz2+=iCumul       
        iCumul2+=iCumul+k : iCumul=0 : k=0 
    Wend
    Return 1
End Function

I did a few tests, and here are my findings:
The compliant qb code is faster for removing white spaces and processing repetitive data (the compiler must be able to better optimize the use of the memory cache), the code with pointers regains the advantage as soon as the input data is differentiated and complete. It should be noted that the test always loops on the same character string, a case which perhaps favors the code "qb"
Otherwise :
- Mixing Mid or Instr type functions with pointers in the same block seems to cause pointer code to slow down, I think that the compiler can better find an optimization on homogeneous code.
- Conversely, I was able to note at times a slowdown (x3) in the "qb" code, but that seems fairly inexplicable!
The measurements seem a bit random and dependent on the input data and the optimization at that time.
The philosophy of use is different: to take a comparison, the standard basic code (qb) is a bit of a small turbo, the c-like code (pointers) is precision mechanics.
Fb is a powerful language that brings the two together by limiting the damage. In fact, all this, we already knew, it's just that we don't always think about it.

[fxm]

Maybe @pagetelegram was just looking for a simple and short code, in -lang qb.

Example of code using recursion:

Code: Select all

#Lang "qb"  '' useless if compiled with option -lang qb

Function ExtractNthItem (Byref s As String, Byval n As Integer) As String
    Dim As Integer d
    d = Instr(s, ",")
    If n = 0 Then
        If d = 0 Then ExtractNthItem = s Else ExtractNthItem = Left$(s, d - 1)
    Else
        If d = 0 Then ExtractNthItem = "" Else ExtractNthItem = ExtractNthItem(Mid$(s, d + 1), n - 1)
    End If
End Function

Print ExtractNthItem("123,45,1,89,22", 3)

Sleep

[edit]
Similar code but works with any string separating the items:

Code: Select all

#Lang "qb"  '' useless if compiled with option -lang qb

Function ExtractNthItem (Byref s As String, Byval n As Integer, Byref sep As String = ",") As String
    Dim As Integer d
    d = Instr(s, sep)
    If n = 0 Then
        If d = 0 Then ExtractNthItem = s Else ExtractNthItem = Left$(s, d - 1)
    Else
        If d = 0 Then ExtractNthItem = "" Else ExtractNthItem = ExtractNthItem(Mid$(s, d + Len(sep)), n - 1, sep)
    End If
End Function

Print ExtractNthItem("123,45,1,89,22", 3), ExtractNthItem("123;,:45;,:1;,:89;,:22", 3, ";,:")

Sleep

[paul doe]

@fxm: nice. A non-recursive version, along with some test code:

Code: Select all

#lang "qb"

'' Enable return from procedures
option nogosub

/'
  Returns the number of elements in a string, using
  'sep' as character separators.
'/
function _
  elementsOf( _
    byref s as const string, _
    byref sep as const string => ";,:" ) _
  as integer
  
  dim as integer _
    count, sp, ep
  
  count => 0
  sp => 1
  ep => 0
  
  ep => inStr( sp, s, any sep )
  
  do while( ep > 0 )
    count +=> 1
    
    sp => ep + 1
    ep => inStr( sp, s, any sep )
  loop
  
  return( __iif( len( s ), count + 1, 0 ) )
end function

/'
  Returns the Nth element of a string separated with
  any of the 'sep' characters.
 
  0 based, non recursive.
'/
function _
  Nth( _
    byval index as integer, _
    byref s as const string, _
    byref sep as const string => ";,:" ) _
  as string
 
  dim as integer _
    sp, ep, count
 
  sp => 1
  ep => 0
  count => 0
 
  ep => inStr( sp, s, any sep )
 
  do while( ep > 0 )
    count +=> 1
   
    if( count - 1 = index ) then
      return( mid$( s, sp, ep - sp ) )
    end if
   
    sp => ep + 1
    ep => inStr( sp, s, any sep )
  loop
 
  return( __iif( index <= count, _
    mid$( s, sp, len( s ) - sp + 1 ), "" ) )
end function

'' Disable return from procedures
option gosub

/'
  Test code
'/
dim as string _
  s
s => "foo,bar;baz:foobar"

? "Testing..."
? "Elements: " & elementsOf( s )

? Nth( -1, s ) '' The string as-is (any negative index)
? Nth( 0, s )  '' First element
? Nth( 1, s )  '' Second element
? Nth( 2, s )  '' Third element
? Nth( 3, s )  '' Fourth element
? Nth( 4, s )  '' Empty string, out of range

?

s => "foo"

? Nth( 0, s ) '' The string as-is; no separators
? Nth( 1, s ) '' Empty string

?

s => ""

? Nth( -1, s ) '' Empty string
? Nth( 0, s ) '' Empty string
? Nth( 1, s ) '' Empty string

sleep()