'===========================================================================
' Subject: IMITATION LANGUAGE SPEAKER         Date: 12-12-98 (16:39)       
'  Author: Antoni Gual                        Code: QB, PDS                
'  Origin: agual@eic.ictnet.es              Packet: AI.ABC
'===========================================================================
DECLARE FUNCTION filesel$ (prompt$, new%)
'----------------------------------------------------------------------------
'POLYGLOT.BAS
'SILLY "INTELLIGENT" PROGRAM THAT PRETENDS TO SPEAK LANGUAGES
'FROM AN ARTICLE IN A 80'S ISSUE OF SCIENTIFIC AMERICAN
'----------------------------------------------------------------------------
'this program scans a sample file in a given language, collecting the frequences
'of each group of 3 characters.
'after it generates a random sequence of characters with the same relative
'frequences for each group as the sample.

'it works better with unformatted pieces of nontechnical texts.
'Computer related texts are full of numbers and english-born terms that corrupt
'the statistics. Also, formatting add multple spaces to statistics.
'It needs a huge array of NxNxN integers to hold the statistics.
'so start quick basic with /ah /l options
'to run it in qbasic, remove the interrupt call that allows to change drive...
'it converts everything to lowercase to keep the array small

'public domain
'I can be contacted at agual@eic.ictnet.es
'----------------------------------------------------------------------------
DEFINT A-Z
'variables
'groupsize
CONST groupsize = 3    'if you want to modify it you must change the number
					   'of dimensions of sample()           
' $DYNAMIC
' $INCLUDE: 'qb.bi'
ON ERROR GOTO errorhandler
DIM SHARED virhe AS INTEGER
DIM SHARED inreg AS RegTypeX, outreg AS RegTypeX

DIM sample$(10)
DIM GROUP(groupsize)



CLS

MS = INT((FRE(-1) \ 2) ^ (1 / groupsize)) - 2

PRINT "                       Here i'am!!"
PRINT "I'm inteligent enough to write long texts in any language"
PRINT "provided you give me a sample text so i can scan it and learn"
PRINT "It can be serbo-croatian, swahili, or anything that can be written in ASCII characters."
PRINT "Don't believe me??"
PRINT "OK!! Press a key to select a sample file... "
a$ = INPUT$(1)

'scanning
OPEN filesel$("Sample.. ", 0) FOR INPUT AS #1
ON ERROR GOTO 0

PRINT "building the charmap"
CHARMAP$ = " "
DO WHILE NOT EOF(1)
	LINE INPUT #1, sample$
	FOR I = 1 TO LEN(sample$)
	 a$ = LCASE$(MID$(sample$, I, 1)):
	 IF INSTR(CHARMAP$, a$) = 0 THEN CHARMAP$ = CHARMAP$ + a$: PRINT LEN(CHARMAP$)
	 IF LEN(CHARMAP$) = MS THEN GOTO FUERA
	NEXT
LOOP
FUERA:

PRINT "collecting info "
nchar = LEN(CHARMAP$)
REDIM stats(1 TO nchar, 1 TO nchar, 1 TO nchar)
SEEK #1, 1
CNT = 1
DO WHILE NOT EOF(1)
	LINE INPUT #1, sample$
	'PRINT CNT: CNT = CNT + 1
	FOR I = 1 TO LEN(sample$)
	  a$ = LCASE$(MID$(sample$, I, 1))
	  OK = INSTR(CHARMAP$, a$)
	  IF OK THEN
		GROUP(1) = GROUP(2): GROUP(2) = GROUP(3): GROUP(3) = OK
		IF GROUP(1) THEN stats(GROUP(1), GROUP(2), GROUP(3)) = stats(GROUP(1), GROUP(2), GROUP(3)) + 1
	  END IF
	NEXT
LOOP
CLOSE #1


PRINT "Adding up frequences"
empty& = 0
FOR I = 1 TO nchar: FOR j = 1 TO nchar: FOR k = 2 TO nchar
	IF stats(I, j, k) = 0 THEN empty& = empty& + 1
	stats(I, j, k) = stats(I, j, k) + stats(I, j, k - 1)
NEXT:
'PRINT MID$(charmap$, i, 1); MID$(charmap$, J, 1); STATS(i, J, nchar),

NEXT
 '   PRINT : a$ = INPUT$(1)
NEXT
'PRINT "empty combinations "; empty& / nchar / nchar / nchar * 100; "%"

PRINT "Here it goes... "
RANDOMIZE TIMER
DO
	DO
		FOR I = 1 TO groupsize - 1
			GROUP(I) = (nchar - 1) * RND + 1
		NEXT
	LOOP UNTIL stats(GROUP(1), GROUP(2), nchar)
	CNT = 0
	DO
		index = stats(GROUP(1), GROUP(2), nchar) * RND
	   
		I = 1: DO WHILE stats(GROUP(1), GROUP(2), I) < index: I = I + 1: LOOP
		GROUP(groupsize) = I
		PRINT MID$(CHARMAP$, I, 1);
		FOR I = 2 TO groupsize: GROUP(I - 1) = GROUP(I): NEXT
		CNT = CNT + 1
	LOOP UNTIL CNT = 1000
	PRINT : INPUT "More? "; a$
LOOP UNTIL UCASE$(a$) = "N"

END

errorhandler: virhe = ERR: RESUME NEXT

REM $STATIC
FUNCTION filesel$ (prompt$, new%)
CLS
DO
	FILES
askdrive:
	PRINT prompt$ + "Select Drive [Enter:Current] > "; : INPUT drive$
	'if no input, go ask path
	IF LEN(drive$) THEN
		'---CHDRIVE drive$ in PDS-----------------------
R3:
		inreg.ax = &HE00
		driv% = ASC(UCASE$(drive$)) - ASC("A")
		inreg.dx = driv%
		CALL INTERRUPTX(&H21, inreg, inreg)
	
		inreg.ax = &H1900
		CALL INTERRUPTX(&H21, inreg, inreg)
		'probably the drive we asked for does'nt exist
		IF (inreg.ax AND &HFF) <> driv% THEN ERROR 68
		IF virhe = 68 THEN PRINT "drive does not exist": GOTO askdrive
		IF virhe = 71 THEN
			virhe = 0: PRINT "DRIVE NOT READY [RETRY/ABORT]?"
			a$ = UCASE$(INPUT$(1)): IF a$ = "R" THEN GOTO R3 ELSE GOTO askdrive
		END IF

	END IF
askpath:
	'what is in?  Here we trap the no disk error
r4:
	FILES
	IF virhe = 71 THEN
		virhe = 0: PRINT "DRIVE NOT READY [RETRY/ABORT]?"
		a$ = UCASE$(INPUT$(1)): IF a$ = "R" THEN GOTO r4 ELSE GOTO askdrive
	END IF
	PRINT prompt$ + " Select Path [Enter:Current] > "; : INPUT path$
	'if no input go ask filename
	IF LEN(path$) THEN
R1:
		CHDIR path$
		IF virhe = 53 OR virhe = 76 THEN PRINT "path not found": virhe = 0: GOTO askpath
		IF virhe = 71 THEN
			virhe = 0: PRINT "DRIVE NOT READY [RETRY/ABORT]?"
			a$ = UCASE$(INPUT$(1)): IF a$ = "R" THEN GOTO R1 ELSE GOTO askdrive
		END IF
		GOTO askpath
	END IF
askname:
	PRINT prompt$ + "Select Name [Enter:New path] > "; : INPUT name$
	'does it exist?
R2:
	FILES name$
	IF virhe = 53 OR virhe = 64 THEN
	 IF new% = 0 THEN PRINT "FILE NOT FOUND"; virhe = 0: GOTO askname ELSE GOTO r5
	END IF
	IF virhe = 71 THEN
		virhe = 0: PRINT "DRIVE NOT READY [RETRY/ABORT]?"
		a$ = UCASE$(INPUT$(1)): IF a$ = "R" THEN GOTO R2 ELSE GOTO askdrive
	END IF
r5:
LOOP UNTIL LEN(name$)

filesel$ = name$
VIEW PRINT
CLS
END FUNCTION