a Program to Search for cipher words and messages in Large text

[ron77]

Hello, here is a program mysoft has worked on today it's a program to find cipher words and messages in large text files - as you may record or remember, once in the 90s, there was a big interest in hidden ciphers and messages in holy scriptures like "the bible code" however it doesn't have to be a holy scripture as it can be any large long text file... so I'm giving the code to the program in freebasic (it runs in terminal or cmd)

you can try it on any large text file (just change the text file loaded in the code :

file "fb_main.bas: :

Code: Select all

#include "fbgfx.bi"

SUB txtfile(f AS STRING , sOutput as string)
	CLS
	'DIM AS STRING buffer
	DIM h AS LONG = FREEFILE()
	OPEN f FOR BINARY AS #h
	sOutput = SPACE(LOF(h))
	GET #h ,  , sOutput
	CLOSE #h
	'PRINT buffer
End SUB

dim b as string
dim as string sBook

input "press 1 for bible as database or press 2 for moby dick book as database", b

if b = "1" then
	txtfile("BibleKJV.txt",sBook)
elseif b = "2" then
	txtfile("moby-dick.txt",sBook)
else
	print "invalid input! error" : sleep 1000 : end
end if

dim as double dTime=timer

dim as string sBookNoSpaces = space(len(sBook))
dim as long iOutPos = 0
redim as long aPosition(len(sBook)-1)

for I as long = 0 to len(sBook)-1
	var bChar = sBook[I]
	select case bChar
		Case asc("A") to asc("Z"), asc("a") to asc("z")
			sBookNoSpaces[iOutPos] = bChar or 32
			aPosition( iOutPos ) = I
			iOutPos += 1
		case 13,10
			sBook[I] = asc(" ")
	End Select
Next I

sBookNoSpaces = left(sBookNoSpaces,iOutPos)
redim preserve aPosition( len(sBookNoSpaces)-1 )
'print cint((timer-dTime)*1000);"ms"

const MaxDistance = 256

dim as string sSearch
dim as long iFoundCount,iConWid=loword(width())

input "Word to search";sSearch
dim as long iWordLen = len(sSearch) 
dim as long SearchLimit = iOutPos-iWordLen*MaxDistance
sSearch = lcase(sSearch)

type ResultStruct
	iPosition as LONG
	iDistance as long	
End Type


redim as ResultStruct atResult(15)

dTime = timer
for I as long = 0 to iOutPos-1
	if sBookNoSpaces[I] <> sSearch[0] then continue for
	for D as long = 2 to MaxDistance
		dim as long N = any , iPos = I+D
		for N = 1 to iWordLen-1
			if sBookNoSpaces[iPos] <> sSearch[N] then exit for
			iPos += D
		Next		
		if N >= iWordLen then
			if (iFoundCount and 15)=0 then redim preserve atResult(iFoundCount+15)
			with atResult(iFoundCount)
				.iPosition = I
				.iDistance = D
			End With
			iFoundCount += 1
		EndIf
	Next
Next
print "Found " & iFoundCount & " occurances in " & csng(timer-dTime) & " seconds."
print string(iConwid-1,"-") : sleep 2000

for ResuN as long = 0 to iFoundCount-1 step 0
	
	with atResult(ResuN)		
		cls
		print "Occurrance: (" & (ResuN+1) & " of " & iFoundCount & ") Position: " & aPosition(.iPosition) & " Distance:" & .iDistance		
		print string(iConwid-1,"-")
		#if 0	 'display using the book without spaces
			scope				
				var iStart = .iPosition , iEnd = iStart+(iWordLen-1)*.iDistance
				for N = iStart to iEnd step D
					color 7,1 : print chr(sBookNoSpaces[N]);: color 7,0
					print mid(sBookNoSpaces,N+2,D-1)
				next N
			End Scope
		#else	'display using the original book
			var iStart = .iPosition , iEnd = iStart+(iWordLen-1)*.iDistance
			color 7
			for N as long = iStart to iEnd Step .iDistance
				
				var iPos = aPosition(N), iWord = iPos
				while sBook[iWord-1] <> asc(" ") : iWord -= 1 : wend								
				
				var iPos2 = aPosition(N+.iDistance)-1
				var iMaxLen = (iPos2-iWord)
				while sBook[iWord+iMaxLen] <> asc(" ") : iMaxLen += 1 : wend				
				var iLen = iMaxLen
				if iLen > (iConWid-5) then iLen = (iConWid-5)
				
				print mid(sBook,iWord+1,iLen);
				if iLen <> iMaxLen then print " ...";
				color 7,1 : locate ,(iPos-iWord)+1
				print chr(sBook[iPos]): color 7,0
				
			Next
		#endif
		print string(iConwid-1,"-") 
		do
			var sKey = inkey
			if len(sKey)=0 then sleep 1,1:continue do
			dim as long iKey = sKey[0]
			if iKey=255 then iKey = -sKey[1]
			select case iKey
			case -fb.SC_PAGEUP
				if ResuN > 0 then
					ResuN -= 50 : if ResuN < 0 then ResuN = 0
					exit do
				end if				
			case -fb.SC_PAGEDOWN
				if ResuN < (iFoundCount-1) then
					ResuN += 50: if ResuN >= iFoundCount then ResuN = iFoundCount-1
					exit do
				end if
			Case -fb.SC_UP   
				if ResuN > 0 then ResuN -= 1 : exit do
			case -fb.SC_DOWN 
				if ResuN < (iFoundCount-1) then ResuN += 1 : exit do
			case 27 'escape
				exit for
			End Select
		Loop
	end with
next

if you wish to read a bit more about it or get the original text files it used like kings James bible text file or moby dick text file you are invited to visit the link here to the original post on "retrocoders community" forum:
https://retrocoders.phatcode.net/index.php?topic=302.0

kind regards
Ron77

[grindstone]

Nice piece of code. What I don't understand is the purpose of "iDistance".

This scanning method by pointer pushing seems to work a little bit faster:

Code: Select all

#Include "fbgfx.bi"

Sub txtfile(f As String , sOutput As String)
	Cls
	Dim h As Long = FreeFile()
	Open f For Binary As #h
	sOutput = Space(Lof(h))
	Get #h ,  , sOutput
	Close #h
End Sub

Dim b As String
Dim As String sBook

Input "press 1 for bible as database or press 2 for moby dick book as database", b

If b = "1" Then
	txtfile("BibleKJV.txt",sBook)
ElseIf b = "2" Then
	txtfile("moby-dick.txt",sBook)
Else
	Print "invalid input! error" : Sleep 1000 : End
End If

Dim As Double dTime=Timer

Dim As String sBookLowcase = Space(Len(sBook))
Dim As Long iOutPos = 0
ReDim As Long aPosition(Len(sBook)-1)
Dim As Long iStart, iEnd

sBookLowcase = LCase(sBook)

ReDim Preserve aPosition(Len(sBookLowcase)-1 )

Dim As String sSearch
Dim As Long iFoundCount,iConWid=LoWord(Width())

Input "Word to search";sSearch

sSearch = LCase(sSearch)

Type ResultStruct
	iPosition As Long
	'iDistance As Long
End Type


ReDim As ResultStruct atResult(1)

dTime = Timer

'? Len(sBookLowcase)
'? sSearch

iFoundCount = -1
For iStart = 0 To Len(sBookLowcase) - Len(sSearch) - 1
	If sBookLowcase[iStart] = sSearch[0] Then '1st char match
		iEnd = iStart + 1 'set string pointer behind 1st match
		Do
			For x As Long = 1 To Len(sSearch) - 1 'scan for further matches
				Do While (sBookLowcase[iEnd] = Asc(" ") _
					        OrElse sBookLowcase[iEnd] = 10 _
					        OrElse sBookLowcase[iEnd] = 13) 'characters to skip
					iEnd += 1 'set string pointer behind skipped character
				Loop
				If sBookLowcase[iEnd] = sSearch[x] Then 'further match
					iEnd += 1
				Else 'no complete match
					Continue For, For
				EndIf
			Next
			'complete match
			iFoundCount += 1
			ReDim Preserve atResult(iFoundCount)
			With atResult(iFoundCount)
				.iPosition = iStart
				'.iDistance = D
			End With
			iStart = iEnd - 1
		Loop Until -1
	EndIf
Next

Print "Found " & iFoundCount & " occurances in " & CSng(Timer-dTime) & " seconds."
Print String(iConwid-1,"-") : Sleep '2000

For x As Long = 0 To iFoundCount
	? Mid(sBook, atResult(x).iPosition + 1, 70)
	? "---"
	Sleep
Next

[grindstone]

Alright, got it now. The intention is something complete different from my snippet above.

Anyhow, mysoft's code will work about 4 times faster if you aviod the permanent redimming of the array, just by running it twice: The first time to only determine the number of occurances and ReDim the array only once, the second time to fill the array:

Code: Select all

#Include "fbgfx.bi"

Sub txtfile(f As String , sOutput As String)
	Cls
	'DIM AS STRING buffer
	Dim h As Long = FreeFile()
	Open f For Binary As #h
	sOutput = Space(Lof(h))
	Get #h ,  , sOutput
	Close #h
	'PRINT buffer
End Sub

Dim b As String
Dim As String sBook

Input "press 1 for bible as database or press 2 for moby dick book as database", b

If b = "1" Then
	txtfile("d:\internet\bibel\kjv.txt",sBook)
ElseIf b = "2" Then
	txtfile("moby-dick.txt",sBook)
Else
	Print "invalid input! error" : Sleep 1000 : End
End If

Dim As Double dTime=Timer

Dim As String sBookNoSpaces = Space(Len(sBook))
Dim As Long iOutPos = 0
ReDim As Long aPosition(Len(sBook)-1)

For I As Long = 0 To Len(sBook)-1
	Var bChar = sBook[I]
	Select Case bChar
		Case Asc("A") To Asc("Z"), Asc("a") To Asc("z")
			sBookNoSpaces[iOutPos] = bChar Or 32
			aPosition( iOutPos ) = I
			iOutPos += 1
		Case 13,10
			sBook[I] = Asc(" ")
	End Select
Next I

sBookNoSpaces = Left(sBookNoSpaces,iOutPos)
ReDim Preserve aPosition( Len(sBookNoSpaces)-1 )
'print cint((timer-dTime)*1000);"ms"

Const MaxDistance = 256

Dim As String sSearch
Dim As Long iFoundCount,iConWid=LoWord(Width())

Input "Word to search";sSearch
Dim As Long iWordLen = Len(sSearch)
Dim As Long SearchLimit = iOutPos-iWordLen*MaxDistance
sSearch = LCase(sSearch)

Type ResultStruct
	iPosition As Long
	iDistance As Long
End Type


ReDim As ResultStruct atResult(15)

dTime = Timer
For I As Long = 0 To iOutPos-1
	If sBookNoSpaces[I] <> sSearch[0] Then Continue For
	For D As Long = 2 To MaxDistance
		Dim As Long N = Any , iPos = I+D
		For N = 1 To iWordLen-1
			If sBookNoSpaces[iPos] <> sSearch[N] Then Exit For
			iPos += D
		Next
		If N >= iWordLen Then
			iFoundCount += 1
		EndIf
	Next
Next

ReDim atResult(iFoundCount)
iFoundCount = 0

For I As Long = 0 To iOutPos-1
	If sBookNoSpaces[I] <> sSearch[0] Then Continue For
	For D As Long = 2 To MaxDistance
		Dim As Long N = Any , iPos = I+D
		For N = 1 To iWordLen-1
			If sBookNoSpaces[iPos] <> sSearch[N] Then Exit For
			iPos += D
		Next
		If N >= iWordLen Then
			With atResult(iFoundCount)
				.iPosition = I
				.iDistance = D
			End With
			iFoundCount += 1
		EndIf
	Next
Next

Print "Found " & iFoundCount & " occurances in " & CSng(Timer-dTime) & " seconds."
Print String(iConwid-1,"-") : Sleep '2000

For ResuN As Long = 0 To iFoundCount-1 Step 0

	With atResult(ResuN)
		Cls
		Print "Occurrance: (" & (ResuN+1) & " of " & iFoundCount & ") Position: " & aPosition(.iPosition) & " Distance:" & .iDistance
		Print String(iConwid-1,"-")
		#If 0	 'display using the book without spaces
		Scope
		Var iStart = .iPosition , iEnd = iStart+(iWordLen-1)*.iDistance
		For N = iStart To iEnd Step D
			Color 7,1 : Print Chr(sBookNoSpaces[N]);: Color 7,0
			Print Mid(sBookNoSpaces,N+2,D-1)
		Next N
		End Scope
		#Else	'display using the original book
		Var iStart = .iPosition , iEnd = iStart+(iWordLen-1)*.iDistance
		Color 7
		For N As Long = iStart To iEnd Step .iDistance

			Var iPos = aPosition(N), iWord = iPos
			While sBook[iWord-1] <> Asc(" ") : iWord -= 1 : Wend

			Var iPos2 = aPosition(N+.iDistance)-1
			Var iMaxLen = (iPos2-iWord)
			While sBook[iWord+iMaxLen] <> Asc(" ") : iMaxLen += 1 : Wend
			Var iLen = iMaxLen
			If iLen > (iConWid-5) Then iLen = (iConWid-5)

			Print Mid(sBook,iWord+1,iLen);
			If iLen <> iMaxLen Then Print " ...";
			Color 7,1 : Locate ,(iPos-iWord)+1
			Print Chr(sBook[iPos]): Color 7,0

		Next
		#EndIf
		Print String(iConwid-1,"-")
		Do
			Var sKey = InKey
			If Len(sKey)=0 Then Sleep 1,1:Continue Do
			Dim As Long iKey = sKey[0]
			If iKey=255 Then iKey = -sKey[1]
			Select Case iKey
				Case -fb.SC_PAGEUP
					If ResuN > 0 Then
						ResuN -= 50 : If ResuN < 0 Then ResuN = 0
						Exit Do
					End If
				Case -fb.SC_PAGEDOWN
					If ResuN < (iFoundCount-1) Then
						ResuN += 50: If ResuN >= iFoundCount Then ResuN = iFoundCount-1
						Exit Do
					End If
				Case -fb.SC_UP
					If ResuN > 0 Then ResuN -= 1 : Exit Do
				Case -fb.SC_DOWN
					If ResuN < (iFoundCount-1) Then ResuN += 1 : Exit Do
				Case 27 'escape
					Exit For
			End Select
		Loop
	End With
Next