unit Chatterbot;

interface

uses crt, sysutils;

type
	word = record
		txt : string;
		tp : string;
	end;
	
	word_array = array of word;
	
	ptr_string = ^_ptr_string;
	
	_ptr_string = record
		txt : string;
		next : ptr_string;
	end;

	ptr_word = ^_ptr_word;
	
	_ptr_word = record
		txt : string;
		tp : string;
		next : ptr_word;
	end;
	
	node = ^_node;
	
	_node = record
		txt : ptr_string;
		lc, rc : node;
	end;
	
(*	tree = class
	private
		head, curr : node;
	public
		constructor create(txt: ptr_string);
		destructor kill;
	end;*)

procedure kill(var n : node); // Database killing
function buildDB() : node; // Database loading
function queuePtr(s : string ; p : ptr_string) : ptr_string; // Ajout fin (pointeur)
function loadDB() : word_array; // Chargement dictionnaire
function chatMain(input : string ; dico : word_array ; db : node) : string; // Fonction de renvoi de message (principal)

implementation

function create(txt : ptr_string ; left, right : node) : node;
var
	tmp : node;
begin
	new(tmp);
	tmp^.rc := left;
	tmp^.lc := right;
	tmp^.txt := txt;
	create := tmp;
end;
	
procedure kill(var n : node);
var
	tmp1, tmp2 : node;
begin
	if n <> nil then
	begin
		tmp1 := n^.lc;
		tmp2 := n^.rc;
		dispose(n);
		kill(tmp1);
		kill(tmp2);
	end;
end;

function loadDB() : word_array;
// Chargement dictionnaire
var
	res : word_array;
	tmp : string;
	f : text;
	i : LongInt;
	j,l : integer;
begin
	setLength(res,58393);
	assign(f,'dicoFranType.txt');
	reset(f);
	i := 0;
	while not eof(f) do
	begin
		readln(f,tmp);
		res[i].txt := '';
		res[i].tp := '';
		j := 1;
		l := length(tmp);
		repeat
			res[i].txt := res[i].txt + tmp[j];
			j := j+1;
		until (tmp[j] = '/') or (j > l);
		if j < l then
			repeat
				j := j+1;
				res[i].tp := res[i].tp+tmp[j];
			until j = l;
		i := i+1;
	end;
	loadDB := res;
end;

function newPtr(s, t : string) : ptr_word;
var
	tmp : ptr_word;
begin
	new(tmp);
	tmp^.txt := s;
	tmp^.tp := t;
	newPtr := tmp;
end;

function topPtr(s, t : string ; p : ptr_word) : ptr_word;
var
	tmp : ptr_word;
begin
	tmp := newPtr(s,t);
	tmp^.next := nil;
	if p = nil then
		topPtr := tmp
	else
	begin
		tmp^.next := p;
		topPtr := tmp;
	end;
end;

procedure queueBis(tmp : ptr_string ; var p : ptr_string);
begin
	if (p^.next = nil) then
		p^.next := tmp
	else
		queueBis(tmp,p^.next);
end;

function queuePtr(s : string ; p : ptr_string) : ptr_string;
var
	cop, tmp : ptr_string;
begin
	cop := p;
	new(tmp);
	tmp^.txt := s;
	tmp^.next := nil;
	if (p = nil) then
		queuePtr := tmp
	else
	begin
		queueBis(tmp,cop);
		queuePtr := p;
	end;
end;

function findType(s : string ; dico : word_array) : string;
// Cherche un mot dans le dictionnaire pour en retourner un type
// Recherche dichotomique
var
	a,b,m : LongInt;
	found : boolean;
begin
	a := 0; // borne inférieure
	b := 58393; // borne supérieure
	
	found := false;
	
	while not found and (b-a > 1) do
	begin
		m := (a+b) div 2; // milieu
//		writeln(s+'::'+dico[m].txt);
		found := dico[m].txt = s;
		if (dico[m].txt < s) then // Mot du dico avant celui du string => on cherche après
			a := m
		else if (dico[m].txt > s) then // Mot du dico après celui du string => on cherche avant
			b := m;
	end;
	
	if not found then findType := ''
	else findType := dico[m].tp;
end;

function isLetter(c : char) : boolean;
var
	numc : integer;
begin
	numc := ord(c);
	isLetter := ((numc >= 65) and (numc <= 90)) or ((numc >= 97) and (numc <= 122)) or (numc = 195) or (numc = 45);
end;
	

function stringToWords(txt : string ; dico : word_array) : ptr_word;
// Sépare input string en mots+types
var
	accent : boolean; // En Pascal, un accent est ordinalement représenté par 2 caractères : 195 et un autre (i.e. c'est chiant)
	wordTmp : string;
	res : ptr_word;
	i,l : integer;
begin
	accent := false;
	res := nil;
	wordTmp := '';
	l := length(txt);
	
	for i := 1 to l+1 do
	begin
		if not accent and ((i = l+1) or not isLetter(txt[i])) and (txt[i] <> '?') then
		begin
			if (wordTmp <> '') then
			begin
				wordTmp := lowerCase(wordTmp);
				res := topPtr(wordTmp, findType(wordTmp,dico), res);
				if not (i > l) then
				begin
					if (txt[i] <> ' ') then
					begin
						res := topPtr(txt[i],'point',res);
					end;
				end;
				wordTmp := '';
			end;
		end
		else
		begin
			wordTmp := wordTmp + txt[i];
			if accent then accent := false;
			accent := (ord(txt[i]) = 195);
		end;
	end;
	
	stringToWords := res;
end;

function partMatch(txt, match : string) : boolean;
// Le match sera en '*string'
var
	i,l : integer;
	res : boolean;
begin
	i := 1;
	res := true;
	l := length(txt);
	if l > length(match) then l := length(match);
	while res and (i <= l) do
	begin
		res := txt[i] = match[i];
		i := i+1;
	end;
	partMatch := res;
end;

procedure recDB(var tree : node ; var f : text ; var acc : ptr_string ; line : string);
var
	tmp : string;
	left, right : node;
begin
	if (line = '^left') then
	begin
		tree := create(acc,nil,nil); // Ajout au milieu
		acc := nil; // Reset accumulateur
		
		if not eof(f) then
		begin
			readln(f,tmp); // Lecture ligne
			recDB(left,f,acc,tmp); // Obtention de la gauche
			tree^.lc := left; // Ajout gauche
		end;

		if not eof(f) then
		begin
			readln(f,tmp); // Lecture ligne
			recDB(right,f,acc,tmp); // Obtention de la droite
			tree^.rc := right; // Ajout droite
		end;
	end
	else if (line = '^end') then // Si line = '^end', c'est terminal
	begin
		tree := create(acc,nil,nil);
		acc := nil;
	end
	else
	begin
		acc := queuePtr(line,acc); // Ajout à l'accumulateur
		readln(f,tmp); // Ligne suivante
		recDB(tree,f,acc,tmp); // On y va encore
	end;
end;

function buildDB() : node;
// Résultat : quand res^.lc et res^.rc = nil
// Left : négatif, right : positif
var
	f : text;
	line : string;
	res : node;
	tmp : ptr_string;
begin
	assign(f,'database.txt');
	reset(f);
	tmp := nil;
	line := '';
	recDB(res,f,tmp,line);
	close(f);
	buildDB := res;
end;

function context(words : ptr_word ; db : node) : string;
// Retourne un contexte adapté à la situation
// TO DO : Système à arbre pour retrouver un contexte précis
var
	tmp : ptr_word;
	tmp2 : ptr_string;
	found : boolean;
	tmp_node : node; // Database contexte
begin
	found := false;
	tmp_node := db;
	
	while (tmp_node^.lc <> nil) or (tmp_node^.rc <> nil) do
	begin
		tmp := words;
		while (tmp <> nil) and not found do
		begin
			tmp2 := tmp_node^.txt;
			while (tmp2 <> nil) and not found do
			begin
				found := (tmp^.txt = tmp2^.txt);
				writeln(tmp2^.txt);
				tmp2 := tmp2^.next;
			end;
			tmp := tmp^.next;
		end;
		if found then 
		begin
			writeln('-> Condition remplie');
			tmp_node := tmp_node^.rc;
		end
		else
		begin
			writeln('-> Condition non remplie');
			tmp_node := tmp_node^.lc;
		end;
		found := false;
	end;
	context := tmp_node^.txt^.txt;
end;

function chatMain(input : string ; dico : word_array ; db : node) : string;
// Fonction principale de réponse
var
	f, log : text;
	res, ctx, line : string;
	words, tmp : ptr_word;
	i : integer;
begin
	i := random(3)+1; // Temporaire...
	assign(log,'contextLog.txt');
	res := '';
	words := stringToWords(input,dico); // Séparation du string en mots+types
	ctx := context(words,db); // Récupération d'un contexte donné
	
	writeln('The context is : '+ctx);
	
	if (ctx = 'previous') then
	begin
		reset(log);
		readln(log, line);
		if (line <> '') then ctx := line
		else ctx := 'inconnu';
	end;
	
	assign(f,'reponse.txt');
	reset(f);
	repeat // Parcours du fichier until contexte reached
		readln(f, line)
	until eof(f) or (line = '/'+ctx);
	
	rewrite(log);
	readln(f,line);
	if (line = 'previous') then writeln(log,ctx)
	else writeln(log,line);
	
	repeat // Parcours du fichier pour avoir une phrase
		readln(f,line);
		i := i-1;
	until eof(f) or (i = 0);
	res := line;
	
	while words <> nil do // Word disposal
	begin
//		res := res+'Le mot ' + words^.txt + ' est un ' + words^.tp + '. ';
		tmp := words^.next;
		dispose(words);
		words := tmp;
	end;
	close(f);
	close(log);
	chatMain := res;
end;

end.