QB / QB64 Discussion Forum     RULES     Other Subforums, Links and Downloads    Index of Threads

 


  << Previous Topic | Next Topic >>Return to Index  

ProgramList Dustinian

September 29 2005 at 4:14 PM
  (no login)

 


    
This message has been edited by iorr5t on May 18, 2007 1:39 PM


 
 Respond to this message   
AuthorReply

(no login)

QBFilter

September 29 2005, 4:22 PM 

'QBFilter - Dustinian Camburides - 2005
'http://www.dustinian.com/software.html

'This program, set up to run as a demo right now, is intended
'to read input strings for text-based games, remove non-alphanumeric
'characters (except spaces) from them, remove multiple spaces from
'them, lcase them, separate them into individual words, and them
'elminate unneccessary words (prepositions [on, in, etc.] and
'determiners [a, the, etc.], so that only the important words in
'the command (hopefully: verb, direct object, indirect object)
'survive to be processed. This allows text-based games to be way
'more flexible about the input it can accept. Check out the demo.

DECLARE SUB FilterCommand (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
DECLARE FUNCTION AlphaNumeric$ (strString AS STRING)
DECLARE FUNCTION PrepareString$ (strString AS STRING)
DECLARE FUNCTION RemoveDoubleSpaces$ (strString AS STRING)
DECLARE SUB GetWords (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
DECLARE SUB FilterExtraWords (strWords() AS STRING, intNumWords AS INTEGER)
DECLARE SUB ListDeterminers (strDeterminers() AS STRING, intNumDeterminers AS INTEGER)
DECLARE SUB ListPrepositions (strPrepositions() AS STRING, intNumPrepositions AS INTEGER)
DECLARE SUB RemoveWord (strWords() AS STRING, intNumWords AS INTEGER, intWord AS INTEGER)
'DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)

'Dimension bounds:
DIM intNumWords AS INTEGER
DIM intNumObjects AS INTEGER

'Initialize bounds:
intNumWords = 1
intNumObjects = 1

'Initialize Variables:
DIM strString AS STRING
DIM strWords(1 TO intNumWords) AS STRING

'Demo Code:

'Get a string form the user.
INPUT ">", strString

'Filter the user's string into an array of words (strWords()).
CALL FilterCommand(strString, strWords(), intNumWords)

'Output the array of words for the user to see.
DIM I AS INTEGER
FOR I = 1 TO intNumWords
PRINT I, strWords(I)
NEXT I

END

FUNCTION AlphaNumeric$ (strString AS STRING)


'SUMMARY:
'AlphaNumeric$ filters all punctuation and symbols out
'of string, leaving only letters (Aa-Zz), numerals
'(0-9), and spaces.

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'AlphaNumeric$: Returns only the input string's
'alphanumeric characters and spaces.


'Dimension Variables:
DIM intI AS INTEGER 'Increment Variable.
DIM intStringLength AS INTEGER 'The length of the string.
DIM strCharacter AS STRING * 1 'The character currently being tested.
DIM strOutput AS STRING 'The new string, with only AlphaNumeric characters.


'Preprocessing:
strOutput = ""
intStringLength = LEN(strString)

'Processing:
FOR intI = 1 TO intStringLength

'Get the next character to be tested.
strCharacter = MID$(strString, intI, 1)


'Add the current character to the output if:

' 1. It belongs to (a-z).
IF ((strCharacter >= "a") AND (strCharacter <= "z")) THEN
strOutput = strOutput + strCharacter

' 2. It belongs to (A-Z).
ELSEIF ((strCharacter >= "A") AND (strCharacter <= "Z")) THEN
strOutput = strOutput + strCharacter

' 3. It belongs to (0-9).
ELSEIF ((strCharacter >= "0") AND (strCharacter <= "9")) THEN
strOutput = strOutput + strCharacter

' 4. It is a space.
ELSEIF (strCharacter = " ") THEN
strOutput = strOutput + strCharacter
END IF
NEXT intI

'Output:
AlphaNumeric$ = strOutput

END FUNCTION

SUB FilterCommand (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
strString = AlphaNumeric$(strString)
strString = PrepareString$(strString)
strString = RemoveDoubleSpaces$(strString)
CALL GetWords(strString, strWords(), intNumWords)
CALL FilterExtraWords(strWords(), intNumWords)
END SUB

SUB FilterExtraWords (strWords() AS STRING, intNumWords AS INTEGER)
DIM intNumFilter AS INTEGER
intNumFilter = 1
DIM strFilter(1 TO intNumFilter) AS STRING
DIM intI AS INTEGER
DIM intJ AS INTEGER
DIM intFound AS INTEGER

CALL ListPrepositions(strFilter(), intNumFilter)

FOR intH = 1 TO 2
IF intH = 1 THEN
CALL ListPrepositions(strFilter(), intNumFilter)
ELSEIF intH = 2 THEN
CALL ListDeterminers(strFilter(), intNumFilter)
END IF

intI = 1
WHILE (intI <= intNumWords)
intJ = 1
WHILE (intJ <= intNumFilter) AND (intFound = 0)
IF strWords(intI) = strFilter(intJ) THEN
CALL RemoveWord(strWords(), intNumWords, intI)
intFound = 1
END IF
intJ = intJ + 1

WEND
IF (NOT intFound) THEN intI = intI + 1
intFound = 0
WEND
NEXT intH

END SUB

SUB GetWords (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
'Getwords extracts individual words from the input string.

'Dimension Variables:
DIM intLocation AS INTEGER
DIM intStart AS INTEGER

'Preprocessing:
strString = strString + " "
intNumWords = 0
intStart = 1
intLocation = INSTR(intStart, strString, " ")

'Processing:
WHILE (intLocation > 0)
intNumWords = intNumWords + 1
CALL ResizeArrayOfStrings(strWords(), intNumWords)
strWords(intNumWords) = MID$(strString, intStart, (intLocation - intStart))
intStart = intLocation + 1
intLocation = INSTR(intStart, strString, " ")
WEND

END SUB

SUB ListDeterminers (strDeterminers() AS STRING, intNumDeterminers AS INTEGER)
intNumDeterminers = 19
CALL ResizeArrayOfStrings(strDeterminers(), intNumDeterminers)
strDeterminers(1) = "the"
strDeterminers(2) = "a"
strDeterminers(3) = "an"
strDeterminers(4) = "another"
strDeterminers(5) = "no"
strDeterminers(6) = "some"
strDeterminers(7) = "any"
strDeterminers(8) = "my"
strDeterminers(9) = "our"
strDeterminers(10) = "their"
strDeterminers(11) = "her"
strDeterminers(12) = "his"
strDeterminers(13) = "its"
strDeterminers(14) = "each"
strDeterminers(15) = "every"
strDeterminers(16) = "certain"
strDeterminers(17) = "another"
strDeterminers(18) = "this"
strDeterminers(19) = "that"
END SUB

SUB ListPrepositions (strPrepositions() AS STRING, intNumPrepositions AS INTEGER)
intNumPrepositions = 43
CALL ResizeArrayOfStrings(strPrepositions(), intNumPrepositions)
strPrepositions(1) = "about"
strPrepositions(2) = "above"
strPrepositions(3) = "across"
strPrepositions(4) = "after"
strPrepositions(5) = "against"
strPrepositions(6) = "around"
strPrepositions(7) = "at"
strPrepositions(8) = "before"
strPrepositions(9) = "behind"
strPrepositions(10) = "below"
strPrepositions(11) = "beneath"
strPrepositions(12) = "beside"
strPrepositions(13) = "besides"
strPrepositions(14) = "between"
strPrepositions(15) = "beyond"
strPrepositions(16) = "down"
strPrepositions(17) = "during"
strPrepositions(18) = "except"
strPrepositions(19) = "for"
strPrepositions(10) = "from"
strPrepositions(21) = "in"
strPrepositions(22) = "inside"
strPrepositions(23) = "into"
strPrepositions(24) = "like"
strPrepositions(25) = "near"
strPrepositions(26) = "of"
strPrepositions(27) = "off"
strPrepositions(28) = "on"
strPrepositions(29) = "out"
strPrepositions(20) = "outside"
strPrepositions(31) = "over"
strPrepositions(32) = "since"
strPrepositions(33) = "through"
strPrepositions(34) = "throughout"
strPrepositions(35) = "till"
strPrepositions(36) = "to"
strPrepositions(37) = "toward"
strPrepositions(38) = "under"
strPrepositions(39) = "until"
strPrepositions(30) = "up"
strPrepositions(41) = "upon"
strPrepositions(42) = "with"
strPrepositions(43) = "without"
END SUB

FUNCTION PrepareString$ (strString AS STRING)
'Processing:
strString = LCASE$(strString)
strString = LTRIM$(strString)
strString = RTRIM$(strString)

'Output:
PrepareString$ = strString

END FUNCTION

FUNCTION RemoveDoubleSpaces$ (strString AS STRING)
'RemoveDouble" "s$ removes all " " instances until there are only " " instances.

'Dimension Variables:
DIM intLocation AS INTEGER


'Preprocessing:
intLocation = INSTR(strString, " ")

'Processing:
WHILE (intLocation > 0)
strString = MID$(strString, 1, intLocation) + MID$(strString, (intLocation + 2), (LEN(strString) - (intLocation + 1)))

intLocation = INSTR(strString, " ")
WEND

'Output:
RemoveDoubleSpaces$ = strString


END FUNCTION

SUB RemoveWord (strWords() AS STRING, intNumWords AS INTEGER, intWord AS INTEGER)
DIM intI AS INTEGER

intI = intWord
strWords(intI) = ""

WHILE (intI < intNumWords)
strWords(intI) = strWords(intI + 1)
intI = intI + 1
WEND

intNumWords = intNumWords - 1
CALL ResizeArrayOfStrings(strWords(), intNumWords)
END SUB

SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)

'DIMENSION VARIABLES:
DIM intI AS INTEGER
DIM intJ AS INTEGER

'PREPROCESSING:
'Dimension the temporary array:
DIM TempArray(1 TO intNewSize) AS STRING

'Determine the lesser bound to avoid reading/writing past the end of one of the arrays:
IF (intNewSize < UBOUND(strArray)) THEN
intJ = intNewSize
ELSE
intJ = UBOUND(strArray)
END IF

'PROCESSING:
'Copy the array to the temporary array:
FOR intI = 1 TO intJ
TempArray(intI) = strArray(intI)
NEXT intI

'Redimension the array:
REDIM strArray(1 TO intNewSize) AS STRING

'Copy the temporary array to the array:
FOR intI = 1 TO intJ
strArray(intI) = TempArray(intI)
NEXT intI
END SUB

 
 Respond to this message   
mennonite
(no login)

*incredibly, beautifully coded, although i doubt i'd really appreciate it w/o coding rpgs

October 1 2005, 1:21 AM 


 
 Respond to this message   
Anonymous
(no login)

Re: QBFilter

October 1 2005, 9:10 AM 

'QBFilter

'Dustinian Camburides - (c)2005
'http://www.dustinian.com/software.html

'SUMMARY:
'QBFilter cleans up input strings for text-based adventures.

'LICENSE:
'Feel free to use this code in your own applications. But I'd
'appreciate it if you credited my work.

'Declare Subs/Functions:
DECLARE SUB FilterCommand (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
DECLARE FUNCTION AlphaNumeric$ (strString AS STRING)
DECLARE FUNCTION PrepareString$ (strString AS STRING)
DECLARE FUNCTION RemoveDoubleSpaces$ (strString AS STRING)
DECLARE SUB GetWords (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
DECLARE SUB RemoveExtraWords (strWords() AS STRING, intNumWords AS INTEGER)
DECLARE SUB GetDeterminers (strDeterminers() AS STRING, intNumDeterminers AS INTEGER)
'DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
DECLARE SUB GetPrepositions (strPrepositions() AS STRING, intNumPrepositions AS INTEGER)
'DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
DECLARE SUB RemoveWord (strWords() AS STRING, intNumWords AS INTEGER, intWord AS INTEGER)
'DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)

'Dimension variables:
DIM strString AS STRING 'Input variable.
DIM intNumWords AS INTEGER 'The number of words in the strWords() array.

'Initialize dynamic array bounds:
intNumWords = 1

'Dimension dynamic array:
DIM strWords(1 TO intNumWords) AS STRING 'Output array.

'Demo Code:
'Get a string form the user.
INPUT ">", strString

'Filter the user's string into an array of words (strWords()).
IF strString <> "" THEN
CALL FilterCommand(strString, strWords(), intNumWords)
END IF

'Output the array of words for the user to see.
DIM i AS INTEGER
FOR i = 1 TO intNumWords
PRINT i, strWords(i)
NEXT i

END

FUNCTION AlphaNumeric$ (strString AS STRING)

'SUMMARY:
'AlphaNumeric$ filters all punctuation and symbols out
'of string, leaving only letters (Aa-Zz), numerals
'(0-9), and spaces.

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'AlphaNumeric$: Returns only the input string's
'alphanumeric characters and spaces.


'Dimension Variables:
DIM intI AS INTEGER 'Increment Variable.
DIM intStringLength AS INTEGER 'The length of the string.
DIM strCharacter AS STRING * 1 'The character currently being tested.
DIM strOutput AS STRING 'The new string, with only AlphaNumeric characters.

'Preprocessing:
strOutput = ""
intStringLength = LEN(strString)

'Processing:
FOR intI = 1 TO intStringLength

'Get the next character to be tested.
strCharacter = MID$(strString, intI, 1)

'Add the current character to the output if:

'1. It belongs to (a-z).
IF ((strCharacter >= "a") AND (strCharacter <= "z")) THEN
strOutput = strOutput + strCharacter

'2. It belongs to (A-Z).
ELSEIF ((strCharacter >= "A") AND (strCharacter <= "Z")) THEN
strOutput = strOutput + strCharacter

'3. It belongs to (0-9).
ELSEIF ((strCharacter >= "0") AND (strCharacter <= "9")) THEN
strOutput = strOutput + strCharacter

'4. It is a space.
ELSEIF (strCharacter = " ") THEN
strOutput = strOutput + strCharacter
END IF
NEXT intI

'Output:
AlphaNumeric$ = strOutput

END FUNCTION

SUB FilterCommand (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)

'SUMMARY:
'FilterCommand accepts a string from the main module and uses
'the Functions AlphaNumeric$, PrepareString$, RemoveDoubleSPaces$,
'and calls the Subs GetWords and FilterExtraWords to "clean up" the
'input string.

'SUBS/FUNCTIONS:
'FUNCTION AlphaNumeric$
'FUNCTION PrepareString$
'FUNCTION RemoveDoubleSpaces$
'SUB GetWords
'SUB RemoveExtraWords

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.


'Processing:
strString = AlphaNumeric$(strString)
strString = PrepareString$(strString)
strString = RemoveDoubleSpaces$(strString)

CALL GetWords(strString, strWords(), intNumWords)
CALL RemoveExtraWords(strWords(), intNumWords)
END SUB

SUB GetDeterminers (strDeterminers() AS STRING, intNumDeterminers AS INTEGER)

'SUMMARY:
'GetDeterminers puts a list of 43 derterminers into an array so that
'RemoveExtraWords can use them to eliminate determiners from a user-
'input command.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strDeterminers(): A dynamic array.

'OUTPUT:
'strDeterminers(): A dynamic array of determiners.
'intNumDeterminers: The number of determiners in the dynamic array strDeterminers().

'Initialize bounds of the dynamic array:
intNumDeterminers = 19

'Resize the dynamic array to fit the new bounds:
CALL ResizeArrayOfStrings(strDeterminers(), intNumDeterminers)

'Input the list of determiners into the array:
strDeterminers(1) = "the"
strDeterminers(2) = "a"
strDeterminers(3) = "an"
strDeterminers(4) = "another"
strDeterminers(5) = "no"
strDeterminers(6) = "some"
strDeterminers(7) = "any"
strDeterminers(8) = "my"
strDeterminers(9) = "our"
strDeterminers(10) = "their"
strDeterminers(11) = "her"
strDeterminers(12) = "his"
strDeterminers(13) = "its"
strDeterminers(14) = "each"
strDeterminers(15) = "every"
strDeterminers(16) = "certain"
strDeterminers(17) = "another"
strDeterminers(18) = "this"
strDeterminers(19) = "that"
END SUB

SUB GetPrepositions (strPrepositions() AS STRING, intNumPrepositions AS INTEGER)

'SUMMARY:
'GetPrepositions puts a list of 43 prepositions into an array so that
'RemoveExtraWords can use them to eliminate prepositions from a user-
'input command.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strPrepositions(): A dynamic array.

'OUTPUT:
'strPrepositions(): A dynamic array of prepositions.
'intNumPrepositions: The number of prepositions in the dynamic array strPrepositions().

'Initialize bounds of the dynamic array:
intNumPrepositions = 43

'Resize the dynamic array to fit the new bounds:
CALL ResizeArrayOfStrings(strPrepositions(), intNumPrepositions)


'Input the list of prepositions into the array:
strPrepositions(1) = "about"
strPrepositions(2) = "above"
strPrepositions(3) = "across"
strPrepositions(4) = "after"
strPrepositions(5) = "against"
strPrepositions(6) = "around"
strPrepositions(7) = "at"
strPrepositions(8) = "before"
strPrepositions(9) = "behind"
strPrepositions(10) = "below"
strPrepositions(11) = "beneath"
strPrepositions(12) = "beside"
strPrepositions(13) = "besides"
strPrepositions(14) = "between"
strPrepositions(15) = "beyond"
strPrepositions(16) = "down"
strPrepositions(17) = "during"
strPrepositions(18) = "except"
strPrepositions(19) = "for"
strPrepositions(10) = "from"
strPrepositions(21) = "in"
strPrepositions(22) = "inside"
strPrepositions(23) = "into"
strPrepositions(24) = "like"
strPrepositions(25) = "near"
strPrepositions(26) = "of"
strPrepositions(27) = "off"
strPrepositions(28) = "on"
strPrepositions(29) = "out"
strPrepositions(20) = "outside"
strPrepositions(31) = "over"
strPrepositions(32) = "since"
strPrepositions(33) = "through"
strPrepositions(34) = "throughout"
strPrepositions(35) = "till"
strPrepositions(36) = "to"
strPrepositions(37) = "toward"
strPrepositions(38) = "under"
strPrepositions(39) = "until"
strPrepositions(30) = "up"
strPrepositions(41) = "upon"
strPrepositions(42) = "with"
strPrepositions(43) = "without"
END SUB

SUB GetWords (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)

'SUMMARY:
'GetWords removes individual words from a string in which words are
'separated by one space and puts them into an array of words.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.

'Dimension Variables:
DIM intLocation AS INTEGER
DIM intStart AS INTEGER

'Preprocessing:
strString = strString + " "
intNumWords = 0
intStart = 1
intLocation = INSTR(intStart, strString, " ")

'Processing:
WHILE (intLocation > 0)
intNumWords = intNumWords + 1
CALL ResizeArrayOfStrings(strWords(), intNumWords)
strWords(intNumWords) = MID$(strString, intStart, (intLocation - intStart))
intStart = intLocation + 1
intLocation = INSTR(intStart, strString, " ")
WEND

END SUB

FUNCTION PrepareString$ (strString AS STRING)

'SUMMARY:
'PrepareString$ converts the input string to all lower-case
'letters, and it removes any leading and/or trailing spaces
'that may be in the string.

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'PrepareString$: Returns the lcased, ltrimed, rtrimed string.

'Processing:
strString = LCASE$(strString)
strString = LTRIM$(strString)
strString = RTRIM$(strString)

'Output:
PrepareString$ = strString

END FUNCTION

FUNCTION RemoveDoubleSpaces$ (strString AS STRING)
'SUMMARY:
'RemoveDoubleSpace$ removes all instances of " " (two spaces in a row)
'until there is only one space between each word in the string.

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'RemoveDoubleSpaces$: Returns the string with one space between words.

'Dimension Variables:
DIM intLocation AS INTEGER

'Preprocessing:
intLocation = INSTR(strString, " ")

'Processing:
WHILE (intLocation > 0)
strString = MID$(strString, 1, intLocation) + MID$(strString, (intLocation + 2), (LEN(strString) - (intLocation + 1)))
intLocation = INSTR(strString, " ")
WEND

'Output:
RemoveDoubleSpaces$ = strString

END FUNCTION

SUB RemoveExtraWords (strWords() AS STRING, intNumWords AS INTEGER)

'SUMMARY:
'RemoveExtraWords removes determiners (a, the, etc.) and prepositions
'(in, on, etc.) from the strWords() array.

'SUBS/FUNCTIONS:
'SUB GetPrepositions
'SUB GetDeterminers
'SUB RemoveWord

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.

'Dimension variables:
DIM intNumFilter AS INTEGER 'The number of entries in the strFilter() array.
DIM intH AS INTEGER 'An increment variable.
DIM intI AS INTEGER 'An increment variable.
DIM intJ AS INTEGER 'An increment variable.

'Initialize dynamic array bounds:
intNumFilter = 1

'Dimension dynamic array:
DIM strFilter(1 TO intNumFilter) AS STRING

'Processing:
FOR intH = 1 TO 2
'Check for prepositions first, then determiners.
IF intH = 1 THEN
CALL GetPrepositions(strFilter(), intNumFilter)
ELSEIF intH = 2 THEN
CALL GetDeterminers(strFilter(), intNumFilter)
END IF

'Starting at the end of strWords() and working foward,
'eliminate entries from strWords() that match entries
'in strFilter()
intI = intNumWords
WHILE (intI > 1)
intJ = 1
WHILE (intJ <= intNumFilter) AND (intFound = 0)
IF strWords(intI) = strFilter(intJ) THEN
CALL RemoveWord(strWords(), intNumWords, intI)
intFound = 1
END IF
intJ = intJ + 1
WEND
intI = intI - 1
intFound = 0
WEND
NEXT intH
END SUB

SUB RemoveWord (strWords() AS STRING, intNumWords AS INTEGER, intWord AS INTEGER)

'SUMMARY:
'RemoveWord removes an entry from an array of strings by moving all
'entries after the entry to be removed up one slot, leaving the last
'entry blank. Then RemoveWord calls ResizeArrayOfStrings to cut off
'the last, now blank, entry.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.
'intWord: The position of the word in strWords() to be removed.

'OUTPUT:
'strWords():
'intNumWords:

'Dimension Variables:
DIM intI AS INTEGER

'Processing
intI = intWord
strWords(intI) = ""

WHILE (intI < intNumWords)
strWords(intI) = strWords(intI + 1)
intI = intI + 1
WEND

intNumWords = intNumWords - 1
CALL ResizeArrayOfStrings(strWords(), intNumWords)
END SUB

SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)

'SUMMARY:
'ResizeArrayOfStrings redimensions an array of strings as entries are
'added or removed.

'INPUT:
'strArray(): The array of strings to be resized.
'intNewSize: The size the array needs to be.

'OUTPUT:
'strArray(): The resized array.

'Dimension Variables:
DIM intI AS INTEGER
DIM intJ AS INTEGER

'Preprocessing:
'Dimension the temporary array:
DIM TempArray(1 TO intNewSize) AS STRING

'Determine the lesser bound to avoid reading/writing past the end of one of the arrays:
IF (intNewSize < UBOUND(strArray)) THEN
intJ = intNewSize
ELSE
intJ = UBOUND(strArray)
END IF

'Processing:
'Copy the array to the temporary array:
FOR intI = 1 TO intJ
TempArray(intI) = strArray(intI)
NEXT intI

'Redimension the array:
REDIM strArray(1 TO intNewSize) AS STRING

'Copy the temporary array to the array:
FOR intI = 1 TO intJ
strArray(intI) = TempArray(intI)
NEXT intI
END SUB

 
 Respond to this message   

(no login)

QBFilter edited, please replace the main QBFilter post with this one, Mac.

October 1 2005, 3:32 PM 

'QBFilter

'Dustinian Camburides - (c)2005
'http://www.dustinian.com/software.html

'SUMMARY:
'QBFilter cleans up input strings for text-based adventures.

'LICENSE:
'Feel free to use this code in your own applications.  But I'd
'appreciate it if you credited my work.

'Declare Subs/Functions:
        DECLARE SUB FilterCommand (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
                DECLARE FUNCTION AlphaNumeric$ (strString AS STRING)
                DECLARE FUNCTION PrepareString$ (strString AS STRING)
                DECLARE FUNCTION RemoveDoubleSpaces$ (strString AS STRING)
                DECLARE SUB GetWords (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)
                        DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
                DECLARE SUB RemoveExtraWords (strWords() AS STRING, intNumWords AS INTEGER)
                        DECLARE SUB GetDeterminers (strDeterminers() AS STRING, intNumDeterminers AS INTEGER)
                                'DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
                        DECLARE SUB GetPrepositions (strPrepositions() AS STRING, intNumPrepositions AS INTEGER)
                                'DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
                        DECLARE SUB RemoveWord (strWords() AS STRING, intNumWords AS INTEGER, intWord AS INTEGER)
                                'DECLARE SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)

'Dimension variables:
        DIM strString AS STRING         'Input variable.
        DIM intNumWords AS INTEGER      'The number of words in the strWords() array.

'Initialize dynamic array bounds:
        intNumWords = 1

'Dimension dynamic array:      
        DIM strWords(1 TO intNumWords) AS STRING        'Output array.

'Demo Code:
        'Get a string form the user.
                INPUT ">", strString

        'Filter the user's string into an array of words (strWords()).
                IF strString <> "" THEN
                        CALL FilterCommand(strString, strWords(), intNumWords)
                END IF

        'Output the array of words for the user to see.
                DIM i AS INTEGER
                FOR i = 1 TO intNumWords
                        PRINT i, strWords(i)
                NEXT i

END

FUNCTION AlphaNumeric$ (strString AS STRING)

'SUMMARY:
'AlphaNumeric$ filters all punctuation and symbols out
'of string, leaving only letters (Aa-Zz), numerals
'(0-9), and spaces.

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'AlphaNumeric$: Returns only the input string's
'alphanumeric characters and spaces.

      
        'Dimension Variables:
        DIM intI AS INTEGER             'Increment Variable.
        DIM intStringLength AS INTEGER  'The length of the string.
        DIM strCharacter AS STRING * 1  'The character currently being tested.
        DIM strOutput AS STRING         'The new string, with only AlphaNumeric characters.

        'Preprocessing:
        strOutput = ""
        intStringLength = LEN(strString)

        'Processing:
        FOR intI = 1 TO intStringLength

                'Get the next character to be tested.
                        strCharacter = MID$(strString, intI, 1)

                'Add the current character to the output if:
              
                        '1. It belongs to (a-z).
                                IF ((strCharacter >= "a") AND (strCharacter <= "z")) THEN
                                        strOutput = strOutput + strCharacter

                        '2. It belongs to (A-Z).
                                ELSEIF ((strCharacter >= "A") AND (strCharacter <= "Z")) THEN
                                        strOutput = strOutput + strCharacter
              
                        '3. It belongs to (0-9).
                                ELSEIF ((strCharacter >= "0") AND (strCharacter <= "9")) THEN
                                        strOutput = strOutput + strCharacter

                        '4. It is a space.
                                ELSEIF (strCharacter = " ") THEN
                                        strOutput = strOutput + strCharacter
                END IF
        NEXT intI

        'Output:
        AlphaNumeric$ = strOutput

END FUNCTION

SUB FilterCommand (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)

'SUMMARY:
'FilterCommand accepts a string from the main module and uses
'the Functions AlphaNumeric$, PrepareString$, RemoveDoubleSPaces$,
'and calls the Subs GetWords and FilterExtraWords to "clean up" the
'input string.

'SUBS/FUNCTIONS:
'FUNCTION AlphaNumeric$
'FUNCTION PrepareString$
'FUNCTION RemoveDoubleSpaces$
'SUB GetWords
'SUB RemoveExtraWords

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.

      
        'Processing:
                strString = AlphaNumeric$(strString)
                strString = PrepareString$(strString)
                strString = RemoveDoubleSpaces$(strString)

                CALL GetWords(strString, strWords(), intNumWords)
                CALL RemoveExtraWords(strWords(), intNumWords)
END SUB

SUB GetDeterminers (strDeterminers() AS STRING, intNumDeterminers AS INTEGER)
      
'SUMMARY:
'GetDeterminers puts a list of 43 derterminers into an array so that
'RemoveExtraWords can use them to eliminate determiners from a user-
'input command.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strDeterminers(): A dynamic array.

'OUTPUT:
'strDeterminers(): A dynamic array of determiners.
'intNumDeterminers: The number of determiners in the dynamic array strDeterminers().
      
        'Initialize bounds of the dynamic array:
                intNumDeterminers = 19

        'Resize the dynamic array to fit the new bounds:
                CALL ResizeArrayOfStrings(strDeterminers(), intNumDeterminers)
      
        'Input the list of determiners into the array:
                strDeterminers(1) = "the"
                strDeterminers(2) = "a"
                strDeterminers(3) = "an"
                strDeterminers(4) = "another"
                strDeterminers(5) = "no"
                strDeterminers(6) = "some"
                strDeterminers(7) = "any"
                strDeterminers(8) = "my"
                strDeterminers(9) = "our"
                strDeterminers(10) = "their"
                strDeterminers(11) = "her"
                strDeterminers(12) = "his"
                strDeterminers(13) = "its"
                strDeterminers(14) = "each"
                strDeterminers(15) = "every"
                strDeterminers(16) = "certain"
                strDeterminers(17) = "another"
                strDeterminers(18) = "this"
                strDeterminers(19) = "that"
END SUB

SUB GetPrepositions (strPrepositions() AS STRING, intNumPrepositions AS INTEGER)

'SUMMARY:
'GetPrepositions puts a list of 43 prepositions into an array so that
'RemoveExtraWords can use them to eliminate prepositions from a user-
'input command.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strPrepositions(): A dynamic array.

'OUTPUT:
'strPrepositions(): A dynamic array of prepositions.
'intNumPrepositions: The number of prepositions in the dynamic array strPrepositions().
      
        'Initialize bounds of the dynamic array:
                intNumPrepositions = 43

        'Resize the dynamic array to fit the new bounds:
                CALL ResizeArrayOfStrings(strPrepositions(), intNumPrepositions)
      
      
        'Input the list of prepositions into the array:
                strPrepositions(1) = "about"
                strPrepositions(2) = "above"
                strPrepositions(3) = "across"
                strPrepositions(4) = "after"
                strPrepositions(5) = "against"
                strPrepositions(6) = "around"
                strPrepositions(7) = "at"
                strPrepositions(8) = "before"
                strPrepositions(9) = "behind"
                strPrepositions(10) = "below"
                strPrepositions(11) = "beneath"
                strPrepositions(12) = "beside"
                strPrepositions(13) = "besides"
                strPrepositions(14) = "between"
                strPrepositions(15) = "beyond"
                strPrepositions(16) = "down"
                strPrepositions(17) = "during"
                strPrepositions(18) = "except"
                strPrepositions(19) = "for"
                strPrepositions(10) = "from"
                strPrepositions(21) = "in"
                strPrepositions(22) = "inside"
                strPrepositions(23) = "into"
                strPrepositions(24) = "like"
                strPrepositions(25) = "near"
                strPrepositions(26) = "of"
                strPrepositions(27) = "off"
                strPrepositions(28) = "on"
                strPrepositions(29) = "out"
                strPrepositions(20) = "outside"
                strPrepositions(31) = "over"
                strPrepositions(32) = "since"
                strPrepositions(33) = "through"
                strPrepositions(34) = "throughout"
                strPrepositions(35) = "till"
                strPrepositions(36) = "to"
                strPrepositions(37) = "toward"
                strPrepositions(38) = "under"
                strPrepositions(39) = "until"
                strPrepositions(30) = "up"
                strPrepositions(41) = "upon"
                strPrepositions(42) = "with"
                strPrepositions(43) = "without"
END SUB

SUB GetWords (strString AS STRING, strWords() AS STRING, intNumWords AS INTEGER)

'SUMMARY:
'GetWords removes individual words from a string in which words are
'separated by one space and puts them into an array of words.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.

        'Dimension Variables:
                DIM intLocation AS INTEGER
                DIM intStart AS INTEGER

        'Preprocessing:
                strString = strString + " "
                intNumWords = 0
                intStart = 1
                intLocation = INSTR(intStart, strString, " ")

        'Processing:
                WHILE (intLocation > 0)
                        intNumWords = intNumWords + 1
                        CALL ResizeArrayOfStrings(strWords(), intNumWords)
                        strWords(intNumWords) = MID$(strString, intStart, (intLocation - intStart))
                        intStart = intLocation + 1
                        intLocation = INSTR(intStart, strString, " ")
                WEND
          
END SUB

FUNCTION PrepareString$ (strString AS STRING)

'SUMMARY:
'PrepareString$ converts the input string to all lower-case
'letters, and it removes any leading and/or trailing spaces
'that may be in the string.

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'PrepareString$: Returns the lcased, ltrimed, rtrimed string.
      
        'Processing:
                strString = LCASE$(strString)
                strString = LTRIM$(strString)
                strString = RTRIM$(strString)

        'Output:
                PrepareString$ = strString

END FUNCTION

FUNCTION RemoveDoubleSpaces$ (strString AS STRING)
'SUMMARY:
'RemoveDoubleSpace$ removes all instances of "  " (two spaces in a row)
'until there is only one space between each word in the string.

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'RemoveDoubleSpaces$: Returns the string with one space between words.

        'Dimension Variables:
                DIM intLocation AS INTEGER
      
        'Preprocessing:
                intLocation = INSTR(strString, "  ")

        'Processing:
                WHILE (intLocation > 0)
                        strString = MID$(strString, 1, intLocation) + MID$(strString, (intLocation + 2), (LEN(strString) - (intLocation + 1)))
                        intLocation = INSTR(strString, "  ")
                WEND

        'Output:
                RemoveDoubleSpaces$ = strString

END FUNCTION

SUB RemoveExtraWords (strWords() AS STRING, intNumWords AS INTEGER)
      
'SUMMARY:
'RemoveExtraWords removes determiners (a, the, etc.) and prepositions
'(in, on, etc.) from the strWords() array.

'SUBS/FUNCTIONS:
'SUB GetPrepositions
'SUB GetDeterminers
'SUB RemoveWord

'INPUT:
'strString: The input string being filtered.

'OUTPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.

        'Dimension variables:    
                DIM intNumFilter AS INTEGER     'The number of entries in the strFilter() array.
                DIM intH AS INTEGER             'An increment variable.
                DIM intI AS INTEGER             'An increment variable.
                DIM intJ AS INTEGER             'An increment variable.

        'Initialize dynamic array bounds:    
                intNumFilter = 1

        'Dimension dynamic array:
                DIM strFilter(1 TO intNumFilter) AS STRING
      
        'Processing:  
                FOR intH = 1 TO 2
                        'Check for prepositions first, then determiners.
                                IF intH = 1 THEN
                                        CALL GetPrepositions(strFilter(), intNumFilter)
                                ELSEIF intH = 2 THEN
                                        CALL GetDeterminers(strFilter(), intNumFilter)
                                END IF

                        'Starting at the end of strWords() and working foward,
                         'eliminate entries from strWords() that match entries
                         'in strFilter()
                                intI = intNumWords
                                WHILE (intI > 1)
                                        intJ = 1
                                        WHILE (intJ <= intNumFilter) AND (intFound = 0)
                                                IF strWords(intI) = strFilter(intJ) THEN
                                                        CALL RemoveWord(strWords(), intNumWords, intI)
                                                        intFound = 1
                                                END IF
                                                intJ = intJ + 1
                                        WEND
                                        intI = intI - 1
                                        intFound = 0
                                WEND
                NEXT intH
END SUB

SUB RemoveWord (strWords() AS STRING, intNumWords AS INTEGER, intWord AS INTEGER)
      
'SUMMARY:
'RemoveWord removes an entry from an array of strings by moving all
'entries after the entry to be removed up one slot, leaving the last
'entry blank.  Then RemoveWord calls ResizeArrayOfStrings to cut off
'the last, now blank, entry.

'SUBS/FUNCTIONS:
'SUB ResizeArrayOfStrings

'INPUT:
'strWords(): An array of strings, one entry for each word in the command.
'intNumWords: The number of words in the strWords() array.
'intWord: The position of the word in strWords() to be removed.

'OUTPUT:
'strWords():
'intNumWords:

        'Dimension Variables:
                DIM intI AS INTEGER

        'Processing
                intI = intWord
                strWords(intI) = ""

                WHILE (intI < intNumWords)
                        strWords(intI) = strWords(intI + 1)
                        intI = intI + 1
                WEND
        
                intNumWords = intNumWords - 1
                CALL ResizeArrayOfStrings(strWords(), intNumWords)
END SUB

SUB ResizeArrayOfStrings (strArray() AS STRING, intNewSize AS INTEGER)
      
'SUMMARY:
'ResizeArrayOfStrings redimensions an array of strings as entries are
'added or removed.

'INPUT:
'strArray(): The array of strings to be resized.
'intNewSize: The size the array needs to be.

'OUTPUT:
'strArray(): The resized array.

        'Dimension Variables:
                DIM intI AS INTEGER
                DIM intJ AS INTEGER
      
        'Preprocessing:
                'Dimension the temporary array:
                DIM TempArray(1 TO intNewSize) AS STRING

                'Determine the lesser bound to avoid reading/writing past the end of one of the arrays:
                IF (intNewSize < UBOUND(strArray)) THEN
                        intJ = intNewSize
                ELSE
                        intJ = UBOUND(strArray)
                END IF

        'Processing:
                'Copy the array to the temporary array:
                FOR intI = 1 TO intJ
                        TempArray(intI) = strArray(intI)
                NEXT intI

                'Redimension the array:
                REDIM strArray(1 TO intNewSize) AS STRING

                'Copy the temporary array to the array:
                FOR intI = 1 TO intJ
                        strArray(intI) = TempArray(intI)
               NEXT intI
END SUB


 
 Respond to this message   
Current Topic - ProgramList Dustinian
  << Previous Topic | Next Topic >>Return to Index  
 Copyright © 1999-2014 Network54. All rights reserved.   Terms of Use   Privacy Statement