News:

Welcome to RetroCoders Community

Main Menu

chatbot aviv version 2

Started by ron77_db, Apr 08, 2022, 02:44 PM

Previous topic - Next topic
Print
Go Down Pages1
User actions

ron77_db

Apr 08, 2022, 02:44 PM
hello everyone...

I've been looking into a way of creating different algorithms for chatbots... what I used so far for many years is the ELIZA chatbot algorithm of fixed keys->replies with randomness... so now that I found a way to parse text input of strings I coded a very basic chatbot demo that stores the input from the user and the output are random words from the user own input...

here is the code so far...

redim shared as string sSentence(any)
redim shared as string sArrReplys(any)


'APPEND TO the STRING array the STRING item
SUB sAppend(arr() AS STRING , Item AS STRING)
	'if the array is empty make it start as the lbound index not ubound (or 0 or 1, whatever...)
	var iUbound = iif( ubound(arr)<lbound(arr) , lbound(arr) , ubound(arr) ) 
	REDIM PRESERVE arr(LBOUND(arr) TO iUbound+1) AS STRING
	arr(UBOUND(arr)) = Item
END SUB

sub generate(arr() as string, iCount as integer, sOutput() as string)
	dim as string sReplys(any)
	dim currentCaracter as STRING
	Dim WordSize as Integer
	for i as integer = 1 to len(arr(iCount))
		currentCaracter = mid(arr(iCount), i, 1)
		select case currentCaracter
			Case " "
				if not WordSize = 0 then
					sappend(sOutput(), mid(arr(iCount), i - WordSize, WordSize))
				endif
				wordSize = 0
			case else
				WordSize += 1
		End Select
		if i = len(arr(iCount)) then
			WordSize = WordSize - 1
			sappend( sOutput(), mid(arr(iCount), i - WordSize, WordSize + 1))
		EndIf
	Next i
	'return sReplys()
End sub


randomize()

'dim sReply as string
dim ICountReply as INTEGER = 1
dim ans as STRING
do
	input "you: ", ans
	sappend(sSentence(), ans)
	generate(sSentence(), ICountReply, sArrReplys())
	
	iCountReply += 1
	print "ChatBot Aviv: " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & _
		sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1))
	'for i as integer = 1 to ubound(sArrReplys)
		'print sArrReplys(i)
	'Next
Loop until lcase(ans) = "quit"

'for i as integer = 1 to ubound(sSentence)
	'print sSentence(i)
'Next

sleep

now I hope to do in the next step is to somehow make the bot reply by some sort of rules instead of just randomness like either the most common words in the user's input or to try to identify the words and rearrange them according to English grammar

I'll keep you updated :)

ron77

ron77_db

#1
Apr 08, 2022, 05:07 PM
okay... now I added and experimented with sorting the parsed word from the input array - I used a simple bubble sorting sub but I hope someone will help me with the binary query function that I added to it (but not used yet (didn't call it yet)

here is the updated code for the chatbot:

#Include "crt.bi"

redim shared as string sSentence(any)
redim shared as string sArrReplys(any)

Function BinaryQuery( Array() As String , sQuery As String ) As Integer
   Dim As Integer iFirst=0 , iLast=UBound(Array)
   Var sQueryL = LCase(sQuery)
   
   Dim As Integer iAttempts
   
   While iLast>=iFirst
      
      iAttempts += 1
      
      Dim As Integer iMid = (iFirst+iLast+1)\2 'cint((iFirst+iLast)/2)
      Dim As Integer iResult = strcmp( sQueryL , Array(iMid) )
      If iResult = 0 Then 
         'AttemptPrint "Attempts: " & iAttempts,
         Return iMid
      EndIf
      If iResult > 0 Then iFirst = iMid+1 : Continue While
      iLast = iMid-1      
   Wend
   'AttemptPrint "Attempts: " & iAttempts,
   Return -1
End Function


'APPEND TO the STRING array the STRING item
SUB sAppend(arr() AS STRING , Item AS STRING)
	'if the array is empty make it start as the lbound index not ubound (or 0 or 1, whatever...)
	var iUbound = iif( ubound(arr)<lbound(arr) , lbound(arr) , ubound(arr) ) 
	REDIM PRESERVE arr(LBOUND(arr) TO iUbound+1) AS STRING
	arr(UBOUND(arr)) = Item
END SUB

sub generate(arr() as string, iCount as integer, sOutput() as string)
	dim as string sReplys(any)
	dim currentCaracter as STRING
	Dim WordSize as Integer
	for i as integer = 1 to len(arr(iCount))
		currentCaracter = mid(arr(iCount), i, 1)
		select case currentCaracter
			Case " "
				if not WordSize = 0 then
					sappend(sOutput(), mid(arr(iCount), i - WordSize, WordSize))
				endif
				wordSize = 0
			case else
				WordSize += 1
		End Select
		if i = len(arr(iCount)) then
			WordSize = WordSize - 1
			sappend( sOutput(), mid(arr(iCount), i - WordSize, WordSize + 1))
		EndIf
	Next i
	'return sReplys()
End sub

sub sorting(sArray() as string)
	do
		
		var bSorted = 0
		for N as long = 0 to ubound(sArray) - 1
			
			if sArray(N) > sArray(N+1) then swap sArray(N),sArray(N+1): bSorted = 1
		Next N
		if bSorted = 0 then exit do
	Loop
	
End Sub

randomize()

'dim sReply as string
dim ICountReply as INTEGER = 1
dim ans as STRING
do
	input "you: ", ans
	sappend(sSentence(), ans)
	generate(sSentence(), ICountReply, sArrReplys())
	
	iCountReply += 1
	sorting(sArrReplys())
	print sArrReplys(1) & " " & sArrReplys(2) & " " & sArrReplys(3) & " " & sArrReplys(4) & " " & sArrReplys(5) 
	'print "ChatBot Aviv: " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & _
		'sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1))
	'for i as integer = 1 to ubound(sArrReplys)
		'print sArrReplys(i)
	'Next
Loop until lcase(ans) = "quit"

'for i as integer = 1 to ubound(sSentence)
	'print sSentence(i)
'Next

sleep

mysoft

#2
Apr 13, 2022, 05:00 PM Last Edit: Apr 13, 2022, 06:45 PM by mysoft
ok i've improved the functions you used a bunch, and added the optional code to load a .txt file sorting the sentences for a better speed test, after our last changes , i added the missing "insertion sort" which is the "fastest :)" (it could be speed up to store stuff on trees or blocks if too much items were required)

19821 words added in 0.4455244967762155s
sort took 0.0007545143039351387s (usage only)
the project gutenberg ebook of moby bleep! or whale by herman melville this
a' a'lee a'low a'most--i a'ready a'shiver a'top a-begging a-calling a-going
the(14547)of(6704)and(6448)to(4663)in(4207)that(2966)his(2523)it(2406)

mysoft

#3
Apr 13, 2022, 06:41 PM Last Edit: Apr 15, 2022, 03:28 PM by mysoft 
#define fbc -gen gcc -O 3 -Wc "-march=native -mtune=native"
'-exx

#define UseInsertionSort
#define AllowDuplicatedWords

#Include "crt.bi"
type ReplyStruct
  sWord as string 'word itself
  iUses as long   'how many times it was used?
  'adding cross indexes for usage here would speed it up
end type

type ReplyList
  redim tReplys(any) as ReplyStruct 'word list
  redim iUsageIndex(any) as long    'order of words by usage (rank)
  redim iAlphaIndex(any) as long    'alphabetical order or
  iStorage as integer               'theres space reserved for how many entries?
  iCount   as integer               'how many word are in total?
end type

redim shared as string sSentence(any)
static shared tReplys as ReplyList

sub SortListAlpha( byref tList as ReplyList )
	dim as integer iIterations=0
  with tList
    do		
      var bSorted = 0 : iIterations += 1
      for N as long = 0 to .iCount-2
        #define _s(_N) .tReplys(.iAlphaIndex(_N)).sWord
        if _s(N) > _s(N+1) then swap .iAlphaIndex(N),.iAlphaIndex(N+1): bSorted = 1
      next N
      if bSorted = 0 then exit do
    loop
    'print "Sorted (alphabetically) in " & iIterations & " iterations." & " words=" & .iCount
  end with  
end sub
sub SortListUsage( byref tList as ReplyList )
	dim as integer iIterations=0
  with tList
    do		
      var bSorted = 0 : iIterations += 1
      for N as long = 0 to .iCount-2
        #define _s(_N) .tReplys(.iUsageIndex(_N)).iUses
        if _s(N) < _s(N+1) then swap .iUsageIndex(N),.iUsageIndex(N+1): bSorted = 1
      next N
      if bSorted = 0 then exit do
    loop
    print "Sorted (by usage) in " & iIterations & " iterations." & " words=" & .iCount
  end with  
end sub

function QSortListAlpha cdecl ( pI1 as long ptr , pI2 as long ptr ) as long	  
  with tReplys
    return strcmp( .tReplys(*pI1).sWord , .tReplys(*pI2).sWord )  
  end with
end function
function QSortListUsage cdecl ( pI1 as long ptr , pI2 as long ptr ) as long	  
  with tReplys            
    return .tReplys(*pI2).iUses - .tReplys(*pI1).iUses
  end with
end function

'**** locate query on list linearly ****
function LinearQueryList( byref tList as ReplyList , sQuery as string ) as integer
  with tList
    for N as integer = 0 to .iCount-1
      if strcmp( sQuery , .tReplys(N).sWord ) = 0 then
        return N
      end if
    next N
    return -1
  end with
end function
'**** !!! REQUIRES SORTED LIST !!! *****
function BinaryQueryList( byref tList as ReplyList , sQuery as string ) as integer
  with tList
    dim as integer iFirst=0 , iLast=.iCount-1
    
    #define sQueryL sQuery
    'Var sQueryL = lcase(sQuery)
    
    dim as integer iAttempts
    
    while iLast>=iFirst
      iAttempts += 1     
      var iMid = (iFirst+iLast+1)\2 'cint((iFirst+iLast)/2)
      var iResult = strcmp( sQueryL , .tReplys(.iAlphaIndex(iMid)).sWord )
      if iResult = 0 then
         'AttemptPrint "Attempts: " & iAttempts,
         return .iAlphaIndex(iMid)
      endif
      if iResult > 0 then iFirst = iMid+1 : continue while
      iLast = iMid-1     
    wend
    'AttemptPrint "Attempts: " & iAttempts
    return not ((iFirst+iLast+1)\2)
  end with
end function

'Add a word to a list
sub AddWord( byref tList as ReplyList , sWord as string )
  var sNewWord = lcase(sWord)
  with tList
    
    #if 0
      print "------------------------------------"
      for N as integer = 0 to .iCount-1
        print .tReplys(.iAlphaIndex(N)).sWord , .tReplys(.iAlphaIndex(N)).iUses
      next N
      sleep
    #endif
    
    #ifdef AllowDuplicatedWords      
      var iIndex = -1
    #else
      #ifdef UseInsertionSort
        var iIndex = BinaryQueryList( tList , sNewWord )
      #else
        var iIndex = LinearQueryList( tList , sNewWord )
      #endif    
    #endif
    
    if iIndex < 0 then 'new word
      
      #if 0 'buffered new word list output
        scope 'buffered new word list output
          static as string sBuffer
          sBuffer += sNewWord+"'"
          if len(sBuffer)>(80*25) then
            print sBuffer : sBuffer = ""          
          end if
        end scope
      #endif
      
      if .iCount >= .iStorage then 
        'if theres no more reserved entries then enlarge the array
        .iStorage = .iStorage+(.iStorage\2)+15 '15,37,70,120,195...
        redim preserve .tReplys(.iStorage)
        redim preserve .iUsageIndex(.iStorage)
        redim preserve .iAlphaIndex(.iStorage)
      end if
      .tReplys(.iCount).sWord = sNewWord 'word
      .tReplys(.iCount).iUses = 1
      .iUsageIndex(.iCount) = .iCount    'set new positon on indexes
      
      #ifdef UseInsertionSort
        iIndex = not iIndex      
        memmove(@.iAlphaIndex(iIndex+1) , @.iAlphaIndex(iIndex) , (.iCount-iIndex)*sizeof(.iAlphaIndex(0)))
        .iAlphaIndex(iIndex) = .iCount
      #else      
        .iAlphaIndex(.iCount) = .iCount
      #endif
      
      .iCount += 1 'one string added :)
      
    else 'world already exist
      .tReplys(iIndex).iUses += 1
    end if
  end with
end sub
'APPEND TO the STRING array the STRING item
sub sAppend(arr() as string , Item as string)
	'if the array is empty make it start as the lbound index not ubound (or 0 or 1, whatever...)
	var iUbound = iif( ubound(arr)<lbound(arr) , lbound(arr) , ubound(arr) )  
	redim preserve arr(lbound(arr) to iUbound+1) as string
	arr(ubound(arr)) = Item
end sub

sub ParseSentence( byref tList as ReplyList , sSentence as string )	
	dim currentCaracter as ubyte
	dim WordSize as integer
	for i as integer = 0 to len(sSentence) 'reaches the \0 at the end
		'less slower with ascii :)
    currentCaracter = sSentence[i] 'mid(arr(iCount), i, 1)
		select case as const currentCaracter			
    case asc("A") to asc("Z"),asc("a") to asc("z")       'characteres anywhere on the word
      WordSize += 1
    case asc("0") to asc("9"),asc("-"),asc("_"),asc("'") 'cant start with those
      if WordSize then WordSize += 1        
    case else 'case asc(" "),0
      if WordSize > 1 then
        var sWord = mid(sSentence, (i-WordSize)+1, WordSize)        
        AddWord( tList , sWord )
      endif
      wordSize=0      
		end select		
	next i 
end sub

randomize()

#if 0
  ' --------------------------- in this mode it loads the text file --------------------
  var f = freefile(), sLine = ""
  dim as double TMR = timer
  open "MobyDick.txt" for input as #f
  while not eof(f)
    line input #f, sLine
    if len(sLine) then        
      ParseSentence( tReplys , sLine )        
      if abs(timer-TMR) > 10 then exit while
    end if
  wend
  close #f
  
  print
  print tReplys.iCount & " words added in " & timer-TMR & "s"
  
  TMR = timer
  with tReplys
    #ifndef UseInsertionSort
      qSort(@.iAlphaIndex(0),.iCount,sizeof(.iAlphaIndex(0)),cast(any ptr,@QSortListAlpha))
      'SortListAlpha( tReplys )
    #endif
    qSort(@.iUsageIndex(0),.iCount,sizeof(.iUsageIndex(0)),cast(any ptr,@QSortListUsage))  
    'SortListUsage( tReplys )
  end with
  print "sort took " & timer-TMR & "s"
  
  with tReplys
    var iWords = .iCount-1
    for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
      print .tReplys(N).sWord;" ";
      if Pos() > 70 then exit for
    next N
    print    
    for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
      print .tReplys(.iAlphaIndex(N)).sWord;" ";
      if Pos() > 70 then exit for
    next N
    print
    for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
      print .tReplys(.iUsageIndex(N)).sWord;"(" & .tReplys(.iUsageIndex(N)).iUses & ")";
      if Pos() > 70 then exit for
    next N
    print
  end with
  
#else

  'in this mode it read from keyboard input

  'dim sReply as string
  dim ICountReply as integer = 1
  dim ans as string
  do  
    line input "you: ", ans
    cls
    if len(ans)=0 then print "why the silence?": continue do
    
    sappend( sSentence() , ans )	
    ParseSentence( tReplys , ans )
    
    iCountReply += 1	
    
    #ifndef UseInsertionSort
      qSort(@tReplys.iAlphaIndex(0),tReplys.iCount,sizeof(tReplys.iAlphaIndex(0)),cast(any ptr,@QSortListAlpha))
      'SortListAlpha( tReplys ) 'bubble sort
    #endif
    
    qSort(@tReplys.iUsageIndex(0),tReplys.iCount,sizeof(tReplys.iUsageIndex(0)),cast(any ptr,@QSortListUsage))  
    'SortListUsage( tReplys ) 'bubble sort

    with tReplys
      var iWords = .iCount-1
      for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
        print .tReplys(N).sWord;" ";
        if Pos() > 70 then exit for
      next N
      print    
      for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
        print .tReplys(.iAlphaIndex(N)).sWord;" ";
        if Pos() > 70 then exit for
      next N
      print    
      for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
        print .tReplys(.iUsageIndex(N)).sWord;"(" & .tReplys(.iUsageIndex(N)).iUses & ")";
        if Pos() > 70 then exit for
      next N    
      print
    end with
    
    'print sArrReplys(1) & " " & sArrReplys(2) & " " & sArrReplys(3) & " " & sArrReplys(4) & " " & sArrReplys(5)
    'print "ChatBot Aviv: " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & _
      'sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1))
    'for i as integer = 1 to ubound(sArrReplys)
      'print sArrReplys(i)
    'Next
  loop until lcase(ans) = "quit"
  
#endif

'for i as integer = 1 to ubound(sSentence)
	'print sSentence(i)
'Next

sleep

ron77_db

#4
Apr 14, 2022, 10:56 AM 
Aborting due to runtime error 6 (out of bounds array access) at line 56 of file::QSORTLISTALPHA()

mysoft

#5
Apr 14, 2022, 06:42 PM Last Edit: Apr 14, 2022, 10:42 PM by mysoft
what you did to achieve the error? because that function is not even called with the #define UseInsertionSort

ron77_db

#6
Apr 15, 2022, 09:47 AM Last Edit: Apr 15, 2022, 10:12 AM by ron77
well I tried the mode to talk with the bot it crashed (runtime error 6) then I tried to read from a text file (kings James bible text file) it also crashed - so I found a fix to use instead the bubble sort on all modes and now it doesn't crash anymore not when talking to bot mode (user input) nor on reading from a text file (kings James bible) I compile it with -exx build command

'#define fbc -s console -gen gcc -Wc -Ofast -Wc -Wno-maybe-uninitialized -exx -w all
'-exx

#define UseInsertionSort
'#define AllowDuplicatedWords

#Include "crt.bi"
type ReplyStruct
  sWord as string 'word itself
  iUses as long  'how many times it was used?
  'adding cross indexes for usage here would speed it up
end type

type ReplyList
  redim tReplys(any) as ReplyStruct 'word list
  redim iUsageIndex(any) as long    'order of words by usage (rank)
  redim iAlphaIndex(any) as long    'alphabetical order or
  iStorage as integer              'theres space reserved for how many entries?
  iCount  as integer              'how many word are in total?
end type

redim shared as string sSentence(any)
static shared tReplys as ReplyList

sub SortListAlpha( byref tList as ReplyList )
    dim as integer iIterations=0
  with tList
    do        
      var bSorted = 0 : iIterations += 1
      for N as long = 0 to .iCount-2
        #define _s(_N) .tReplys(.iAlphaIndex(_N)).sWord
        if _s(N) > _s(N+1) then swap .iAlphaIndex(N),.iAlphaIndex(N+1): bSorted = 1
      next N
      if bSorted = 0 then exit do
    loop
    'print "Sorted (alphabetically) in " & iIterations & " iterations." & " words=" & .iCount
  end with 
end sub
sub SortListUsage( byref tList as ReplyList )
    dim as integer iIterations=0
  with tList
    do        
      var bSorted = 0 : iIterations += 1
      for N as long = 0 to .iCount-2
        #define _s(_N) .tReplys(.iUsageIndex(_N)).iUses
        if _s(N) < _s(N+1) then swap .iUsageIndex(N),.iUsageIndex(N+1): bSorted = 1
      next N
      if bSorted = 0 then exit do
    loop
    print "Sorted (by usage) in " & iIterations & " iterations." & " words=" & .iCount
  end with 
end sub

function QSortListAlpha cdecl ( pI1 as integer ptr , pI2 as integer ptr ) as long    
  with tReplys  
    return strcmp( .tReplys(*pI1).sWord , .tReplys(*pI2).sWord ) 
  end with
end function
function QSortListUsage cdecl ( pI1 as integer ptr , pI2 as integer ptr ) as long    
  with tReplys          
    return .tReplys(*pI2).iUses - .tReplys(*pI1).iUses
  end with
end function

'**** locate query on list linearly ****
function LinearQueryList( byref tList as ReplyList , sQuery as string ) as integer
  with tList
    for N as integer = 0 to .iCount-1
      if strcmp( sQuery , .tReplys(N).sWord ) = 0 then
        return N
      end if
    next N
    return -1
  end with
end function
'**** !!! REQUIRES SORTED LIST !!! *****
function BinaryQueryList( byref tList as ReplyList , sQuery as string ) as integer    
  with tList
    dim as integer iFirst=0 , iLast=.iCount-1
  
    #define sQueryL sQuery
    'Var sQueryL = lcase(sQuery)
  
    dim as integer iAttempts
  
    while iLast>=iFirst
      iAttempts += 1    
      var iMid = (iFirst+iLast+1)\2 'cint((iFirst+iLast)/2)
      var iResult = strcmp( sQueryL , .tReplys(.iAlphaIndex(iMid)).sWord )
      if iResult = 0 then
        'AttemptPrint "Attempts: " & iAttempts,
        return .iAlphaIndex(iMid)
      endif
      if iResult > 0 then iFirst = iMid+1 : continue while
      iLast = iMid-1    
    wend
    'AttemptPrint "Attempts: " & iAttempts
    return not ((iFirst+iLast+1)\2)
  end with
end function

'Add a word to a list
sub AddWord( byref tList as ReplyList , sWord as string )
  var sNewWord = lcase(sWord)  
  with tList
  
    #if 0
      print "------------------------------------"
      for N as integer = 0 to .iCount-1
        print .tReplys(.iAlphaIndex(N)).sWord , .tReplys(.iAlphaIndex(N)).iUses
      next N
      sleep
    #endif
  
    #ifdef AllowDuplicatedWords    
      var iIndex = -1
    #else
      #ifdef UseInsertionSort
        var iIndex = BinaryQueryList( tList , sNewWord )
      #else
        var iIndex = LinearQueryList( tList , sNewWord )
      #endif  
    #endif
  
    if iIndex < 0 then 'new word
    
      #if 0 'buffered new word list output
        scope 'buffered new word list output
          static as string sBuffer
          sBuffer += sNewWord+"'"
          if len(sBuffer)>(80*25) then
            print sBuffer : sBuffer = ""        
          end if
        end scope
      #endif
    
      if .iCount >= .iStorage then
        'if theres no more reserved entries then enlarge the array
        .iStorage = .iStorage+(.iStorage\2)+15 '15,37,70,120,195...
        redim preserve .tReplys(.iStorage)
        redim preserve .iUsageIndex(.iStorage)
        redim preserve .iAlphaIndex(.iStorage)
      end if
      .tReplys(.iCount).sWord = sNewWord 'word
      .tReplys(.iCount).iUses = 1
      .iUsageIndex(.iCount) = .iCount    'set new positon on indexes
    
      #ifdef UseInsertionSort
        iIndex = not iIndex    
        memmove(@.iAlphaIndex(iIndex+1) , @.iAlphaIndex(iIndex) , (.iCount-iIndex)*sizeof(.iAlphaIndex(0)))
        .iAlphaIndex(iIndex) = .iCount
      #else    
        .iAlphaIndex(.iCount) = .iCount
      #endif
    
      .iCount += 1 'one string added :)
    
    else 'world already exist
      .tReplys(iIndex).iUses += 1
    end if
  end with
end sub
'APPEND TO the STRING array the STRING item
sub sAppend(arr() as string , Item as string)
    'if the array is empty make it start as the lbound index not ubound (or 0 or 1, whatever...)
    var iUbound = iif( ubound(arr)<lbound(arr) , lbound(arr) , ubound(arr) ) 
    redim preserve arr(lbound(arr) to iUbound+1) as string
    arr(ubound(arr)) = Item
end sub

sub ParseSentence( byref tList as ReplyList , sSentence as string )    
    dim currentCaracter as ubyte
    dim WordSize as integer
    for i as integer = 0 to len(sSentence) 'reaches the \0 at the end
        'less slower with ascii :)
    currentCaracter = sSentence[i] 'mid(arr(iCount), i, 1)
        select case as const currentCaracter            
    case asc("A") to asc("Z"),asc("a") to asc("z")      'characteres anywhere on the word
      WordSize += 1
    case asc("0") to asc("9"),asc("-"),asc("_"),asc("'") 'cant start with those
      if WordSize then WordSize += 1      
    case else 'case asc(" "),0
      if WordSize > 1 then
        var sWord = mid(sSentence, (i-WordSize)+1, WordSize)      
        AddWord( tList , sWord )
      endif
      wordSize=0    
        end select        
    next i
end sub

randomize()

#if 0
  ' --------------------------- in this mode it loads the text file --------------------
  var f = freefile(), sLine = ""
  dim as double TMR = timer
  open "BibleKJV.txt" for input as #f
  while not eof(f)
    line input #f, sLine
    if len(sLine) then      
      ParseSentence( tReplys , sLine )      
      if abs(timer-TMR) > 1 then exit while
    end if
  wend
  close #f
 
  print
  print tReplys.iCount & " words added in " & timer-TMR & "s"
 
  TMR = timer
  with tReplys
    #ifndef UseInsertionSort
      'qSort(@.iAlphaIndex(0),.iCount,sizeof(.iAlphaIndex(0)),cast(any ptr,@QSortListAlpha)) ' runtime error
      SortListAlpha( tReplys )
    #endif
    'qSort(@.iUsageIndex(0),.iCount,sizeof(.iUsageIndex(0)),cast(any ptr,@QSortListUsage)) ' runtime error
    SortListUsage( tReplys )
  end with
  print "sort took " & timer-TMR & "s"
 
  with tReplys
    var iWords = .iCount-1
    for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
      print .tReplys(N).sWord;" ";
      if Pos() > 70 then exit for
    next N
    print  
    for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
      print .tReplys(.iAlphaIndex(N)).sWord;" ";
      if Pos() > 70 then exit for
    next N
    print
    for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
      print .tReplys(.iUsageIndex(N)).sWord;"(" & .tReplys(.iUsageIndex(N)).iUses & ")";
      if Pos() > 70 then exit for
    next N
    print
  end with
 
#else

  'in this mode it read from keyboard input

  'dim sReply as string
  dim ICountReply as integer = 1
  dim ans as string
  do 
    line input "you: ", ans
    cls
    if len(ans)=0 then print "why the silence?": continue do
  
    sappend( sSentence() , ans )    
    ParseSentence( tReplys , ans )
  
    iCountReply += 1    
  
    #ifdef UseInsertionSort
      'qSort(@tReplys.iAlphaIndex(0),tReplys.iCount,sizeof(tReplys.iAlphaIndex(0)),cast(any ptr,@QSortListAlpha)) ' runtime error !
      SortListAlpha( tReplys ) 'bubble sort
    #endif
  
    'qSort(@tReplys.iUsageIndex(0),tReplys.iCount,sizeof(tReplys.iUsageIndex(0)),cast(any ptr,@QSortListUsage)) ' runtime error!
    SortListUsage( tReplys ) 'bubble sort

    with tReplys
      var iWords = .iCount-1
      for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
        print .tReplys(N).sWord;" ";
        if Pos() > 70 then exit for
      next N
      print  
      for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
        print .tReplys(.iAlphaIndex(N)).sWord;" ";
        if Pos() > 70 then exit for
      next N
      print  
      for N as integer = 0 to iWords 'iif(iWords>4,4,iWords)
        print .tReplys(.iUsageIndex(N)).sWord;"(" & .tReplys(.iUsageIndex(N)).iUses & ")";
        if Pos() > 70 then exit for
      next N  
      print
    end with
  
    'print sArrReplys(1) & " " & sArrReplys(2) & " " & sArrReplys(3) & " " & sArrReplys(4) & " " & sArrReplys(5)
    'print "ChatBot Aviv: " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & _
      'sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1)) & " " & sArrReplys(int(rnd*(ubound(sArrReplys))+1))
    'for i as integer = 1 to ubound(sArrReplys)
      'print sArrReplys(i)
    'Next
  loop until lcase(ans) = "quit"
 
#endif

'for i as integer = 1 to ubound(sSentence)
    'print sSentence(i)
'Next

sleep

mysoft

#7
Apr 15, 2022, 03:29 PM
ok i updated my post with the whole code reflecting the changes... indeed qsort must use "long ptr" instead of "integer ptr"
Print
Go Up Pages1
User actions