'===========================================================================
' Subject: Word Hashing                       Date: 03-16-03 (  :  )       
'  Author: Antoni Gual et.al.                 Code: QB, PDS                
'  Origin: agual@eic.ictnet.es              Packet: TEXT.ABC
'===========================================================================
DECLARE SUB fastsort ()
DECLARE FUNCTION getaword2$ (a$, ENDED%)
DECLARE FUNCTION updatefreq% (a$)
DECLARE FUNCTION funFirstPrime% (threshold%)
'
'----------------------------------------------------------------------------
'WORDHASH.BAS v1.10 By Rich Geldreich 1992
'Tweaked by Quinn Tyler Jackson       1993 for a FAQ
'Boosted by Antoni Gual               2003              agual@eic.ictnet.es
'----------------------------------------------------------------------------
'Uses hashing to QUICKLY tally up the frequency of all of the words in a
'text file.
'
'(This program assumes that words are separated by anything else than a letter
'Also, words are converted to uppercase and clipped to 10 chars before search)
'----------------------------------------------------------------------------
'
'LOAD QB WITH THE /AH OPTION ENABLED
'----------------------------------------------------------------------------
'What Antoni Gual did (not so much):
'
'-Original program used variable length strings. It ran out of string space
'   at ~700 strings. I changed to fixed length 10 char strings, this allows
'  to dimension approx 13000 strings provided you load qb with /ah.
'  It truncates words but you still can guess them from the first 10 chars
'  (I can anticipate problems with german QB users..:)

'-Added a non recursive quicksort (QB version by by Cornel Huth) for the
' results so they can be printed ordered to "result.txt" a file so the
' results can be checked with a text viewer.

'-Increased speed by changing the word fetcher, the first one built a string
'  letter by letter, mine just creates the string  when the word is parsed.
'  Now it parses a 1.4Mb text (26000 lines) in less than 6.5 seconds.
'
'-A hash table full does'nt simply stop the program, the incomplete table is
'  still sorted and printed to file.
'
'----------------------------------------------------------------------------
' Don't try it only in IT texts, go to Project Gutenberg
'           http://www.promo.net/pg/
' and download true texts from classical authors..
'
' Some examples of word counts:
'  ENGLISH
'   The Psalms of King James' Bible ~3000 words
'   Shakespeare's  Othello          ~4500 words
'  GERMAN
'   Goethe's Faust (First part)     ~6500 words (must be true. I can't read it :)             
'  SPANISH
'   Cervantes'  Don Quijote  overflowed the 13000 words array at half text.
'
'   (Spanish uses a lot of suffixes making multiple table entries for what
'   would be a single word in a true dictionnary)
'----------------------------------------------------------------------------
' The theory: (Skip it and run the program!)  :)
'
'You may know binary search as a fast search method,but it has some drawbacks:
'- If you are builing the table on the fly, you must reorder it for each new
'    key addition or next search can fail.
'- The number of searches grow with the size of the table. A big table is slow.
'
' Hash tables don't need sorting and the number of comparisons is kept
'  low independantly of the table size!
'
' The trick is to use a simple formula to calculate a position in the table
'   from the key value you are searching,then
' 1   check the value in the calculated position:
'     if empty the key is not in the table.        <just a single compare!
'     if not empty you have a collision
'        compare the value stored with your key. If it matches you found it!
'        if no match
'          use a further formula to calculate a new position
'          goto 1
'
'     (loop repeats until you fall on an empty place or you find your key)
'
'The idea is easy to catch, but it requires some tricks to work
'- Table size must be a prime number 30% bigger than the max nr of entries
'- Formulas to find positions must be easy to calculate and distribute
'    entries evenly. See code..
'
'The drawbacks:
'- Table can't be resized without changing the position formulas and re-hashing
'   all entries.
'-Table entries are not ordered, so you can only check for a full match, not
'  for the previous or following key.
'-----------------------------------------------------------------------------

DEFINT A-Z
CONST TRUE = -1, FALSE = 0
CONST empty$ = "          "

TYPE stacktype
 low AS INTEGER
 hi AS INTEGER
END TYPE


DIM SHARED aa$
DIM SHARED tablesize
DIM SHARED new.words


Main:
 CLS
 LOCATE 1, 1
 PRINT "WORDHASH.BAS By Rich Geldreich      1992"
 PRINT "     Tweaked by Quinn Tyler Jackson 1993"
 PRINT "         and by Antoni Gual         2003"


 filename$ = RTRIM$(COMMAND$)
 IF LEN(filename$) = 0 THEN
	PRINT
	PRINT "USE: WORDHASH  textfilename"
	PRINT "Results outputted to result.txt"
	END
 END IF




 OPEN filename$ FOR INPUT AS #1 LEN = 16384


'Dont set directly the table size, for a fast hash it must be 30% bigger
' than nr of entries and be a prime number. That's what the function finds.
tablesize = funFirstPrime(10001)


REDIM SHARED wordtable(tablesize) AS STRING * 10
REDIM SHARED counts(tablesize)
T! = TIMER

 PRINT
 PRINT "Processing "; filename$; " with a "; tablesize; " elements table"
 aa$ = SPACE$(10)
 bb$ = aa$
 FOR I = 0 TO tablesize: LSET wordtable(I) = SPACE$(10): NEXT
 DO UNTIL EOF(1)
	 LINE INPUT #1, a$
		a$ = LTRIM$(RTRIM$(a$))
		IF LEN(a$) THEN
		'PRINT A$
		a$ = UCASE$(a$)
		DO
		 b$ = getaword2$(a$, ENDED)
		 IF LEN(b$) THEN
			'PRINT B$; "<"
			LSET bb$ = b$
			wRD& = wRD& + 1
			IF updatefreq(bb$) THEN GOTO exitit
		 END IF
		LOOP UNTIL ENDED
	 END IF
	 N = N + 1
	 LOCATE 7, 1: PRINT USING "######## words ##### lines : ##### new words"; wRD&; N; new.words;
 LOOP
exitit:
	 PRINT " in "; TIMER - T!; " sec."
	 CLOSE
	 fastsort
	 GOSUB printtable
	 ERASE wordtable, counts
	 PRINT
	 PRINT "Done. You can check the results in  RESULT.TXT"
	 a$ = INPUT$(1)
END

printtable:
	 OPEN "RESULT.TXT" FOR OUTPUT AS #1
	 PRINT #1, "Wordcount of the file:"; COMMAND$
	 'CLS
	 j = 0
	 FOR I = 0 TO tablesize
	 IF ASC(wordtable(I)) <> 32 THEN
	 PRINT #1, USING "#### , \        \  "; counts(I); wordtable(I)
	
	 'use this for CSV output to view results with MS Excel
	 'WRITE #1, counts(I), wordtable(I)
	 j = j + 1
	 END IF
	 NEXT
	 PRINT #1, j; "different words"; new.words
	 CLOSE
RETURN

SUB fastsort
	'QuickSort iterative (rather than recursive) by Cornel Huth
	DIM Lstack(1 TO 128) AS stacktype   'our stack
	DIM Sp AS INTEGER                   'out stack pointer
	Sp = 1
	Lstack(Sp).low = 0
	Lstack(Sp).hi = tablesize
	Sp = Sp + 1
	DO
		Sp = Sp - 1
		low = Lstack(Sp).low
		hi = Lstack(Sp).hi
		DO
			I = low
			j = hi
			mid = (low + hi) \ 2
			GOSUB sortcounts
			IF j - low < hi - I THEN
				IF I < hi THEN
					Lstack(Sp).low = I
					Lstack(Sp).hi = hi
					Sp = Sp + 1
				END IF
				hi = j
			ELSE
				IF low < j THEN
					Lstack(Sp).low = low
					Lstack(Sp).hi = j
					Sp = Sp + 1
				END IF
				low = I
			END IF
		LOOP WHILE low < hi
	LOOP WHILE Sp <> 1
EXIT SUB

sortcounts:
compare = counts(mid)
DO
	WHILE counts(I) > compare: I = I + 1: WEND
	WHILE counts(j) < compare: j = j - 1: WEND
	IF I <= j THEN
		SWAP wordtable(I), wordtable(j)
		SWAP counts(I), counts(j)
		I = I + 1
		j = j - 1
	END IF
LOOP WHILE I <= j
RETURN

sortwords:
compare$ = wordtable(mid)
DO
	WHILE wordtable(I) > compare$: I = I + 1: WEND
	WHILE wordtable(j) < compare$: j = j - 1: WEND
	IF I <= j THEN
		SWAP wordtable(I), wordtable(j)
		SWAP counts(I), counts(j)
		I = I + 1
		j = j - 1
	END IF
LOOP WHILE I <= j
RETURN





END SUB

' This FUNCTION returns a prime number that is at least 30% greater than
' threshold.  It will TRY to return a prime number that also fits into the
' form 4K+3, where k is any integer, but if the prime number is twice the
' size of the threshold, it will ignore this criterion.
'
'       Written by Charles Graham, Tweaked by Quinn Tyler Jackson
'
FUNCTION funFirstPrime (threshold)
CONST TRUE = -1
CONST FALSE = NOT TRUE

tp30 = INT((threshold * 1.3))
IF tp30 / 2 = tp30 \ 2 THEN
	tp30 = tp30 + 1
END IF
c = tp30 - 2
IF c < 1 THEN
	c = 1
END IF
t2 = threshold * 2
DO
	c = c + 2
	FOR z = 3 TO SQR(c)
		ind = TRUE
		IF c / z = c \ z THEN
			ind = FALSE
			EXIT FOR
		END IF
	NEXT z
	IF ind THEN
		IF (c - 3) / 4 = INT((c - 3) / 4) OR c > t2 THEN
			funFirstPrime = c
			EXIT DO
		END IF
	END IF
LOOP
END FUNCTION

FUNCTION getaword2$ (a$, ENDED)
 'Uses only a single string assign at the end so it's fast!
 'Needs the line passed to be uppercase!
 'Very buggy! Should be reworked!
 'Takes all chars>128 as valid in a word!
 '

 STATIC ptr
 IF LEN(a$) = 0 THEN ENDED = -1: EXIT FUNCTION
 ENDED = 0
 DEF SEG
 wptr& = CLNG(SADD(a$)) + ptr - 1
 DO
	 ptr = ptr + 1
	 wptr& = wptr& + 1
	 c = PEEK(wptr&)
 LOOP WHILE (c < 65 OR (c > 90 AND c < 129)) AND (ptr < LEN(a$))
 IF ptr = LEN(a$) THEN GETWORD2$ = "": ENDED = -1: ptr = 0: EXIT FUNCTION
 ptr1 = ptr
 DO
	 ptr = ptr + 1
	 wptr& = wptr& + 1
	 c = PEEK(wptr&)
 LOOP UNTIL c < 65 OR (c > 90 AND c < 129) OR ptr > LEN(a$)
 IF ptr > LEN(a$) THEN
	getaword2$ = MID$(a$, ptr1, ptr - ptr1)
	ENDED = -1: ptr = 0
 ELSE
	getaword2$ = MID$(a$, ptr1, ptr - ptr1)
 END IF
END FUNCTION

FUNCTION updatefreq (a$)
STATIC collisions AS LONG
 
	N = 0
	FOR I = 1 TO 10 STEP 2
	N = N XOR CVI(MID$(a$, I, 2))
	NEXT
	KEYINDEX = N AND &H7FFF
	
	'adjust the keyindex so its within the table
	KEYINDEX = KEYINDEX MOD tablesize
	'calculate an offset for retries
	IF KEYINDEX = 0 THEN
		Offset = 1
	ELSE
		Offset = tablesize - KEYINDEX
	END IF
	'main loop of hashing
	DO
		'is this entry empty?
		IF wordtable(KEYINDEX) = empty$ THEN
			'add this entry to the hash table
			LSET wordtable(KEYINDEX) = a$
			counts(KEYINDEX) = 1
			new.words = new.words + 1
			IF new.words = tablesize THEN
				updatefreq = 1
				EXIT FUNCTION
			END IF
			EXIT FUNCTION
		'is this what we're looking for?
		ELSEIF wordtable(KEYINDEX) = a$ THEN
			'increment the frequency of the entry
			counts(KEYINDEX) = counts(KEYINDEX) + 1
			EXIT FUNCTION
		'this entry contains a string other than what we're looking for:
		'adjust the KeyIndex and try again
		ELSE
			collisions = collisions + 1
			KEYINDEX = KEYINDEX - Offset
			'wrap back the keyindex if it's <0
			IF KEYINDEX < 0 THEN
				KEYINDEX = KEYINDEX + tablesize
			END IF
		END IF
	LOOP

END FUNCTION