/*
    mmorph, MULTEXT morphology tool
    Version 2.3, October 1995
    Copyright (c) 1994,1995 ISSCO/SUISSETRA, Geneva, Switzerland
    Dominique Petitpierre, <petitp@divsun.unige.ch>
*/
/*
    spell.c

    handle spelling rules parsing and interpretation

    Dominique Petitpierre, ISSCO Summer 1994
*/

#include "user.h"

t_letter   *surface_letter_map;	/* map of user characters to letter */
t_letter   *lexical_letter_map;	/* map of user characters to letter */
t_letter   *current_letter_map = NULL;	/* used while parsing */

/* map of letter to user characters (only for 1 char name letters) */
unsigned char *letter_to_char_map;

t_card      max_spell_length;	/* size of the longest spelling rule */
t_card      max_left_context_length;	/* size of the longest left context */
t_card      max_rest_length;	/* size of the longest focus + right context */

t_letter    letter_any[2] = {LETTER_ANY, NUL_LETTER};
t_letter    empty_string[1] = {NUL_LETTER};
t_letter   *morpheme_boundary;
t_letter   *word_boundary;
s_pair     *morpheme_boundary_pair;
s_pair     *word_boundary_pair;
t_letter    first_lexical_letter;


e_symbol_kind current_letter_kind;
int         alphabet_size;	/* number of symbols in merged alphabets */
int         lexical_alphabet_size;	/* number of symbols in lexical
					   alphabet */
static int  spell_set_size;	/* number of rules */
static int  spell_set_chunk;	/* size of a spell rule bit map in WORDs */
static WORD_TYPE *match_pos;	/* bit array of position * alphabet * rules  */
static WORD_TYPE *applicability_map;	/* bit array of word positions *
					   rules */

static t_letter surface_tape[CONCAT_SIZE];

static s_pos_stack pos_stack[POS_STACK_SIZE];	/* remembers what was applied
						   where */

static t_letter *current_base_lex;	/* external arguments to
					   handle_result */
static s_tfs *current_tfs;	/* idem */
static t_card current_tfs_index;	/* idem */
static int  valid_surface;	/* idem */

/* point to the beginning of word in concatenation */
static t_letter *surface_word;

/* point to the beginning of word in surface_tape */
static t_letter *lexical_word;


s_pair     *
new_pair(surface, lexical, pair_flags, next)
t_letter   *surface;
t_letter   *lexical;
t_flag      pair_flags;
s_pair     *next;

{
    s_pair     *pair;

    MY_MALLOC(pair, s_pair);
    pair->pair_flags = pair_flags;
    pair->surface = surface;
    pair->lexical = lexical;
    pair->next = next;
    return (pair);
}

void
is_pair_concrete(pair)
s_pair     *pair;

{
    s_pair     *pair_member;

    pair_member = pair;
    do {
	if ((pair->pair_flags != BOTH_LETTERS)
	    || (pair->lexical == letter_any)
	    || (pair->surface == letter_any))
	    fatal_error("non concrete pair in focus");
	pair_member = pair_member->next;
    } while (pair_member != NULL);
}

/* ignore the distinction between letter class or letter string */
void
add_explicit_pair(pair, surface, lexical, pair_flags, lexical_set)
s_pair     *pair;
t_letter   *surface;
t_letter   *lexical;
t_flag      pair_flags;
s_bitmap   *lexical_set;

{
    s_pair     *insert_pair;
    int         ok;

    if (pair->surface == NULL) {	/* pair not yet defined */
	pair->pair_flags = pair_flags;
	pair->surface = surface;
	pair->lexical = lexical;
	pair->next = NULL;	/* list of one member */
	if (pair_flags & LEXICAL_IS_CLASS)
	    assign_or(lexical_set, (s_bitmap *) lexical);
	else if (lexical == letter_any)
	    fill_bitmap(lexical_set);
	else if (*lexical != NUL_LETTER)
	    set_bit(lexical_set, (long) *lexical);
    }
    else {
	insert_pair = new_pair(surface, lexical, pair_flags, pair->next);
	/* insert member: TODO: preserve order */
	pair->next = insert_pair;
	ok = TRUE;
	if (pair_flags & LEXICAL_IS_CLASS)
	    if (test_and(lexical_set, (s_bitmap *) lexical))
		ok = FALSE;
	    else
		assign_or(lexical_set, (s_bitmap *) lexical);
	else if (lexical == letter_any)
	    ok = FALSE;
	else if (*lexical != NUL_LETTER)
	    ok = set_if_not_set(lexical_set, (long) *lexical);
	else
	    fatal_error("%s %s",
			"a pair with an empty lexical part has to be",
			"alone in a Pairs definition");
	if (!ok)
	    fatal_error("%s %s",
			"cannot specify a lexical symbol",
			"more than once in a pair set");
    }
}

void
add_pair(pair, new_pair, lexical_set)
s_pair     *pair;
s_pair     *new_pair;
s_bitmap   *lexical_set;

{
    s_pair     *pair_member;

    pair_member = new_pair;
    /* copy the new pair set definition */
    do {
	add_explicit_pair(pair, pair_member->surface,
			  pair_member->lexical,
			  pair_member->pair_flags,
			  lexical_set);
	pair_member = pair_member->next;
    } while (pair_member != NULL);
}

int
lexical_width(pair)
s_pair     *pair;

{
    if (pair->pair_flags & LEXICAL_IS_CLASS)
	return (1);
    else
	return (strlen((char *) pair->lexical));
}

t_letter   *
find_letter(letter_name, letter_kind)
t_str       letter_name;
e_symbol_kind letter_kind;

{
    s_symbol   *pair_symbol;

    pair_symbol = *find_symbol(letter_name, &symbol_set[Pair]);
    if (pair_symbol->kind != letter_kind
	&& pair_symbol->kind != Pair_Letter)
	fatal_error("symbol \"%s\" is not a %s",
		    pair_symbol->name,
		    symbol_kind_str[letter_kind]);
    /* return the internalized letter */
    if (letter_kind == Surface_Letter)
	return (pair_symbol->data->pair.surface);
    else
	return (pair_symbol->data->pair.lexical);
}


/* convert a string of single chars to internal representation
   imperfect, because it should comply with &entity; notation
   and \ escapes
 */

t_boolean
map_letter(user_string, letter_string, letter_kind)
t_str       user_string;
t_letter   *letter_string;
e_symbol_kind letter_kind;

{
    register t_str current_char;
    register t_letter *current_letter;
    t_letter   *letter_map;

    if (letter_kind == Surface_Letter)
	letter_map = surface_letter_map;
    else
	letter_map = lexical_letter_map;
    current_char = user_string;
    current_letter = letter_string;
    while (letter_map[(unsigned char) *current_char]) {
	*current_letter++ = letter_map[(unsigned char) *current_char++];
    }
    if (*current_char != '\0') {
#ifdef COMMENTED_OUT
	print_warning("symbol \"%c\" occurring in \"%s\" is not a %s",
		      *current_char,
		      user_string,
		      symbol_kind_str[letter_kind]);
#endif
	return (FALSE);
    }
    else {
	*current_letter++ = letter_map[(unsigned char) *current_char++];
	return (TRUE);
    }
}

#ifdef DEBUG

static WORD_TYPE *
MATCH_POS(i, j)
int         i;
int         j;
{
    return (match_pos + ((i * lexical_alphabet_size + j) * spell_set_chunk));
}

static WORD_TYPE *
APPLICABILITY_MAP(i)
int         i;
{
    return (applicability_map + (i * spell_set_chunk));
}

static void
ASSIGN_SET(spell_set1, spell_set2)
WORD_TYPE  *spell_set1;
WORD_TYPE  *spell_set2;
{
    (void) memcpy((T_PTR) spell_set1, (T_PTR) spell_set2,
		  spell_set_chunk * WORD_SIZE);
}


static void
AND_SET(spell_set1, spell_set2)
WORD_TYPE  *spell_set1;
WORD_TYPE  *spell_set2;
{
    register int i;

    for (i = 0; i < spell_set_chunk; i++)
	spell_set1[i] &= spell_set2[i];
}

#else

#define MATCH_POS(i,j) \
	(match_pos+(((i) * lexical_alphabet_size + (j)) * spell_set_chunk))

#define APPLICABILITY_MAP(i) \
	    (applicability_map + ((i) * spell_set_chunk))

#define ASSIGN_SET(spell_set1,spell_set2) \
	(void) memcpy((T_PTR) (spell_set1), (T_PTR) (spell_set2), \
		      spell_set_chunk * WORD_SIZE)


#define AND_SET(spell_set1,spell_set2) \
	    { register int i; \
	      for (i=0; i < spell_set_chunk; i++) \
		*((spell_set1)+i) &= *((spell_set2)+i); \
	    }

#endif	/* DEBUG */



#define MARK_SPELL(spell_set,spell_index) \
    SET_BIT(*((spell_set)+WORD_OFFSET(spell_index)), (spell_index))

#define UNMARK_SPELL(spell_set,spell_index) \
    UNSET_BIT(*((spell_set)+WORD_OFFSET(spell_index)), (spell_index))


#define FOR_EACH_SPELL(spell_set, n) \
	for ((n) = 0L; (n) < spell_set_size; (n)++) \
	    if (TEST_BIT(*((spell_set)+WORD_OFFSET(n)),(n)))

#define SPELL_NAME(spell_index) \
	    (symbol_set[Spelling].ref[(spell_index)]->name)

#define COERCE(spell)	\
	    ((spell)->kind==Obligatory || (spell)->kind==Coerce)

#define RESTRICT(spell)	\
	    ((spell)->kind==Obligatory || (spell)->kind==Optional)

static void
match_any(pos_index, spell_index, start_letter)
int         pos_index;
int         spell_index;
t_letter    start_letter;

{
    t_letter    letter;

    for (letter = start_letter; (int) letter < lexical_alphabet_size; letter++)
	MARK_SPELL(MATCH_POS(pos_index, (int) letter), spell_index);
}

static void
fill_pos(pattern_chain, pos, spell_index, direction)
s_chain    *pattern_chain;
int         pos;
int         spell_index;
int         direction;

{
    s_chain    *pattern;
    s_pair     *pair;
    int         letter;
    int         pos_index;

    if (pattern_chain != NULL) {
	pos_index = pos;
	pattern = pattern_chain;
	do {
	    pattern = pattern->next;
	    pair = (s_pair *) pattern->item;
	    if (lexical_width(pair) != 0) {
		/* for the moment lexical pair width is restricted to 0 or 1 */
		do {
		    if (pair->pair_flags & LEXICAL_IS_CLASS)
			FOR_EACH_BIT((s_bitmap *) pair->lexical, letter)
			    MARK_SPELL(MATCH_POS(pos_index, letter),
				       spell_index);
		    else if (pair->lexical == letter_any)
			match_any(pos_index,
				  spell_index, first_lexical_letter);
		    else
			MARK_SPELL(MATCH_POS(pos_index, (int) *pair->lexical),
				   spell_index);
		    pair = pair->next;
		} while (pair != NULL);	/* end of pair list */
		pos_index += direction;
	    }
	} while (pattern != pattern_chain);	/* end of circular list */
    }
}

void
prepare_spell()
{
    int         spell_index;
    int         pos_index;
    int         pos_index2;

    s_spell_instance *spell;

    spell_set_size = symbol_set[Spelling].card;
    /* be blunt: bit array of positions by alphabet by rules */
    spell_set_chunk = DIV_ROUND_UP(spell_set_size, BITS(WORD_TYPE));
    MY_CALLOC(match_pos,
	      max_spell_length * lexical_alphabet_size * spell_set_chunk,
	      WORD_TYPE);
    /*
       fill this rather sparse matrix with bits corresponding to which rule
       have which letter in which position
    */
    for (spell_index = 0; spell_index < spell_set_size; spell_index++) {
	spell = symbol_set[Spelling].ref[spell_index]->data->spelling.instance;
	pos_index = max_left_context_length - spell->left_context_length;
	/*
	   the rule matches for all letter before the context even inexistant
	   ones (0)
	*/
	for (pos_index2 = 0; pos_index2 < pos_index; pos_index2++)
	    match_any(pos_index2, spell_index, NUL_LETTER);
	/* mark that the rule matches for each left context position/letter */
	fill_pos(spell->left_context, max_left_context_length - 1,
		 spell_index, -1);
	fill_pos(spell->focus, max_left_context_length,
		 spell_index, 1);
	fill_pos(spell->right_context,
		 max_left_context_length + spell->focus_length,
		 spell_index, 1);
	pos_index2 = max_left_context_length + spell->focus_length
	    + spell->right_context_length;
	/*
	   the rule matches for all letter after the context even inexistant
	   ones (0)
	*/
	for (; pos_index2 < max_spell_length; pos_index2++)
	    match_any(pos_index2, spell_index, NUL_LETTER);
    }
    MY_CALLOC(applicability_map, CONCAT_SIZE * spell_set_chunk, WORD_TYPE);
}

/*
    each member of the applicability map is the set of rule
    whose focus start at word_index and that match the lexical tape
*/
void
fill_applicability_map(word_tree, stem_length)
s_rule_instance *word_tree;
t_card      stem_length;

{
    t_letter   *word;
    int         word_length;
    t_letter   *letter;
    int         word_index;
    int         pos_index;
    WORD_TYPE  *spell_set;
    int         spell_index;
    s_chain    *start_chain;
    s_chain    *current_chain_link;
    t_boolean   licensed;
    s_tfs      *lexical_tfs;
    s_spell_instance *spell;

    word = word_tree->lex;
    word_length = word_tree->lex_length + stem_length;
    if ((letter = word - max_left_context_length) < concatenation)
	fatal_error("%s: before word=%d < max left context = %d",
		    "reached internal limits",
		    word - concatenation, max_left_context_length);
    while (letter < word)
	*letter++ = NUL_LETTER;	/* should not match any left context */
    if ((letter = word + word_length + max_rest_length - 1)
	>= concatenation + CONCAT_SIZE)
	fatal_error("%s: after word=%d < max right context = %d",
		    "reached internal limits",
		    word + word_length - concatenation,
		    max_rest_length - 1);
    while (letter >= word + word_length)
	*letter-- = NUL_LETTER;	/* should not match any right context */
    if (spell_trace_level >= TRACE_LEXICAL_MATCH) {
	print_log("lexical applicability map for word: \"");
	print_string_l(logfile, word, word_length);
	print_log("\"\n");
    }
    for (word_index = 0; word_index < word_length; word_index++) {
	letter = word + word_index - max_left_context_length;
	spell_set = APPLICABILITY_MAP(word_index);
	ASSIGN_SET(spell_set, MATCH_POS(0, (int) *letter++));
	/* TODO: stop when spell_set is empty */
	for (pos_index = 1; pos_index < max_spell_length; pos_index++)
	    AND_SET(spell_set, MATCH_POS(pos_index, (int) *letter++));
	FOR_EACH_SPELL(spell_set, spell_index) {
	    spell = symbol_set[Spelling].ref[spell_index]
		->data->spelling.instance;
	    if (spell->constraint != NULL) {
		lexical_tfs = get_tfs(word_tree,
				      word + word_index +
				      ((spell->concat_pos == NO_CONCAT)
				       ? 0 : spell->concat_pos),
				      spell->concat_pos != NO_CONCAT,
				      stem_length);
		licensed = FALSE;
		start_chain = spell->constraint->next;
		current_chain_link = start_chain;
		do {	/* at least one constraint's tfs has to be less
			   specific than the tfs of the relevant leaf */
		    licensed = subsume_tfs((s_tfs *) current_chain_link->item,
					   lexical_tfs);
		    current_chain_link = current_chain_link->next;
		} while (current_chain_link != start_chain && !licensed);
		if (!licensed)
		    UNMARK_SPELL(spell_set, spell_index);
	    }
	}
	if (spell_trace_level >= TRACE_LEXICAL_MATCH) {
	    print_log("%2d ", word_index);
	    if (word[word_index] != NUL_LETTER)
		print_letter(logfile, word[word_index]);
	    FOR_EACH_SPELL(APPLICABILITY_MAP(word_index), spell_index) {
		print_log("\t%s ",
			  symbol_set[Spelling].ref[spell_index]->name);
	    }
	    print_log("\n");
	}
    }
}

static      t_boolean
match_left_context(lexical_pos, surface_pos, spell_index)
int         lexical_pos;	/* position of beginning of focus on lexical
				   tape */
int         surface_pos;	/* position of beginning of focus on surface
				   tape */
int         spell_index;	/* applied spelling rule index */
{
    s_chain    *left_context;
    s_chain    *pattern;
    t_boolean   match;
    t_letter   *surface_letter;
    t_letter   *lexical_letter;
    t_letter   *current_lexical;
    t_letter   *letter;
    s_pair     *pair;

    if (spell_index < 0)
	return (TRUE);	/* default rule: no context */
    left_context
	= symbol_set[Spelling].ref[spell_index]->data->spelling.instance
	->left_context;
    if (left_context == NULL)
	return (TRUE);	/* empty context */
    pattern = left_context;
    /* start before focus */
    surface_letter = surface_word + surface_pos - 1;
    lexical_letter = lexical_word + lexical_pos - 1;
    do {
	pattern = pattern->next;
	pair = (s_pair *) pattern->item;
	do {	/* find which pair is matching the lexical tape */
	    current_lexical = lexical_letter;
	    if (pair->pair_flags & LEXICAL_IS_CLASS)
		match = test_bit((s_bitmap *) pair->lexical,
				 (long) *current_lexical--);
	    else if (pair->lexical == letter_any)
		match = (*current_lexical-- != NUL_LETTER);
	    else {
		letter = pair->lexical;
		match = TRUE;
		while (*letter != NUL_LETTER && match)
		    match = (*letter++ == *current_lexical--);
	    }
	    if (match)
		break;
	    else
		pair = pair->next;
	} while (pair != NULL);	/* end of pair list */
	lexical_letter = current_lexical;
	if (!match)
	    fatal_error("program bug: lexical left context does not match");
	/* check surface */
	if (pair->pair_flags & SURFACE_IS_CLASS)
	    match = test_bit((s_bitmap *) pair->surface,
			     (long) *surface_letter--);
	else if (pair->surface == letter_any)
	    match = (*surface_letter-- != NUL_LETTER);
	else {
	    letter = pair->surface;
	    while (*letter != NUL_LETTER && match)
		match = (*letter++ == *surface_letter--);
	}
    } while (match && pattern != left_context);
    return (match);
}

static      t_boolean
match_right_context(lexical_pos, surface_pos, spell_index)
int         lexical_pos;	/* position of end of focus on lexical tape */
int         surface_pos;	/* position of end of focus on surface tape */
int         spell_index;	/* applied spelling rule index */
{
    s_chain    *right_context;
    s_chain    *pattern;
    t_boolean   match;
    t_letter   *surface_letter;
    t_letter   *lexical_letter;
    t_letter   *current_lexical;
    s_pair     *pair;
    t_letter   *letter;

    if (spell_index < 0)
	return (TRUE);	/* default rule: no context */
    right_context
	= symbol_set[Spelling].ref[spell_index]->data->spelling.instance
	->right_context;
    if (right_context == NULL)
	return (TRUE);	/* empty context */
    pattern = right_context;
    surface_letter = surface_word + surface_pos;
    lexical_letter = lexical_word + lexical_pos;
    do {
	pattern = pattern->next;
	pair = (s_pair *) pattern->item;
	current_lexical = lexical_letter;
	do {	/* find which pair is matching the lexical tape */
	    current_lexical = lexical_letter;
	    if (pair->pair_flags & LEXICAL_IS_CLASS)
		match = test_bit((s_bitmap *) pair->lexical,
				 (long) *current_lexical++);
	    else if (pair->lexical == letter_any)
		match = (*current_lexical++ != NUL_LETTER);
	    else {
		letter = pair->lexical;
		match = TRUE;
		while (*letter != NUL_LETTER && match)
		    match = (*letter++ == *current_lexical++);
	    }
	    if (match)
		break;
	    else
		pair = pair->next;
	} while (pair != NULL);	/* end of pair list */
	lexical_letter = current_lexical;
	if (!match)
	    fatal_error("program bug: lexical right context does not match");
	/* check surface */
	if (pair->pair_flags & SURFACE_IS_CLASS)
	    match = test_bit((s_bitmap *) pair->surface,
			     (long) *surface_letter++);
	else if (pair->surface == letter_any)
	    match = (*surface_letter++ != NUL_LETTER);
	else {
	    letter = pair->surface;
	    while (*letter != NUL_LETTER && match)
		match = (*letter++ == *surface_letter++);
	}
    } while (match && pattern != right_context);
    return (match);
}

static      t_boolean
match_focus(lexical_pos, surface_pos, spell_index,
	    lexical_focus_end, surface_focus_end)
int         lexical_pos;	/* position of beginning of focus on lexical
				   tape */
int         surface_pos;	/* position of beginning of focus on surface
				   tape */
int         spell_index;	/* applied spelling rule index */
int         lexical_focus_end;	/* position of end of focus on lexical tape */
int         surface_focus_end;	/* position of end of focus on surface tape */
{
    s_chain    *focus;
    s_chain    *pattern;
    t_boolean   match;
    t_letter   *surface_letter;
    t_letter   *lexical_letter;
    t_letter   *current_lexical;
    t_letter   *letter;
    s_pair     *pair;

    if (spell_index < 0)
	fatal_error("program_bug: trying to match a default rule's focus");
    focus = symbol_set[Spelling].ref[spell_index]->data->spelling.instance
	->focus;
    if (focus == NULL) {	/* TODO: empty focus. Allowed? */
	return ((lexical_pos == lexical_focus_end)
		&& (surface_pos == surface_focus_end));
    }
    pattern = focus;
    surface_letter = surface_word + surface_pos;
    lexical_letter = lexical_word + lexical_pos;
    do {
	pattern = pattern->next;
	pair = (s_pair *) pattern->item;
	do {	/* find which pair is matching the lexical tape */
	    current_lexical = lexical_letter;
	    if ((pair->pair_flags & LEXICAL_IS_CLASS)
		|| (pair->lexical == letter_any))
		fatal_error("program bug: non concrete focus");
	    letter = pair->lexical;
	    match = TRUE;
	    while (*letter != NUL_LETTER && match)
		match = (*letter++ == *current_lexical++);
	    if (match)
		break;
	    else
		pair = pair->next;
	} while (pair != NULL);	/* end of pair list */
	lexical_letter = current_lexical;
	if (!match)
	    fatal_error("program bug: lexical focus does not match");
	/* check surface */
	if ((pair->pair_flags & SURFACE_IS_CLASS)
	    || (pair->surface == letter_any))
	    fatal_error("program bug: non concrete focus");
	letter = pair->surface;
	while (*letter != NUL_LETTER && match)
	    match = (*letter++ == *surface_letter++);
    } while (match && pattern != focus);
    if (match && lexical_focus_end != lexical_letter - lexical_word)
	fatal_error("program bug: lexical focus length does not match");
    return (match && (surface_focus_end == (surface_letter - surface_word)));
}

/*
   concretise surface part of the focus.
   may fail if spell_index corresponds to lexical symbol without a
   surface counterpart.
*/
static      t_boolean
copy_focus(lexical_pos, surface_pos, spell_index,
	   new_lexical_pos, new_surface_pos)
int         lexical_pos;	/* position of beginning of focus on lexical
				   tape */
int         surface_pos;	/* position of beginning of focus on surface
				   tape */
int        *spell_index;	/* applied spelling rule index */
int        *new_lexical_pos;	/* position of end of focus on lexical tape */
int        *new_surface_pos;	/* position of end of focus on surface tape */
{
    s_chain    *focus;
    s_chain    *pattern;
    t_boolean   match;
    t_letter   *surface_letter;
    t_letter   *lexical_letter;
    t_letter   *current_lexical;
    t_letter   *letter;
    s_pair     *pair;

    surface_letter = surface_word + surface_pos;
    lexical_letter = lexical_word + lexical_pos;
    if (*spell_index < 0) {
	/* default rule */
	*spell_index = -*lexical_letter;	/* just for remembering */
	if ((*lexical_letter == *morpheme_boundary)
	    || (*lexical_letter == *word_boundary))
	    lexical_letter++;	/* corresponds to empty surface */
	else if (symbol_set[Pair].ref[*lexical_letter]->kind != Pair_Letter)
	    return (FALSE);
	else {
	    if (surface_letter >= surface_tape + CONCAT_SIZE - 1)
		fatal_error("reached internal limit:%s %d symbols",
			    "surface word is longer than ",
			    CONCAT_SIZE - 2);	/* - initial and final NUL */
	    *surface_letter++ = *lexical_letter++;
	}
    }
    else {
	focus = symbol_set[Spelling].ref[*spell_index]->data->spelling.instance
	    ->focus;
	if (focus != NULL) {	/* TODO: should an empty focus be allowed? */
	    pattern = focus;
	    do {
		pattern = pattern->next;
		pair = (s_pair *) pattern->item;
		do {	/* find which pair is matching the lexical tape */
		    current_lexical = lexical_letter;
		    if ((pair->pair_flags & LEXICAL_IS_CLASS)
			|| (pair->lexical == letter_any))
			fatal_error("program bug: non concrete focus");
		    letter = pair->lexical;
		    match = TRUE;
		    while (*letter != NUL_LETTER && match)
			match = (*letter++ == *current_lexical++);
		    if (match)
			break;
		    else
			pair = pair->next;
		} while (pair != NULL);	/* end of pair list */
		lexical_letter = current_lexical;
		if (!match)
		    fatal_error("program bug: lexical focus does not match");
		/* copy to surface */
		if ((pair->pair_flags & SURFACE_IS_CLASS)
		    || (pair->surface == letter_any))
		    fatal_error("program bug: non concrete focus");
		letter = pair->surface;
		while (*letter != NUL_LETTER) {
		    if (surface_letter >= surface_tape + CONCAT_SIZE - 1)
			fatal_error("reached internal limit:%s %d symbols",
				    "surface word is longer than ",
				    CONCAT_SIZE - 2);	/* - start and end NUL */
		    *surface_letter++ = *letter++;
		}
	    } while (pattern != focus);
	}
    }
    *new_lexical_pos = lexical_letter - lexical_word;
    *new_surface_pos = surface_letter - surface_word;
    return (TRUE);
}

static void
handle_result(surface_end)
int         surface_end;

{
    valid_surface++;
    if (spell_trace_level >= TRACE_VALID_SURFACE) {
	print_log("\"");
	print_string(logfile, surface_word);
	print_log("\" = \"");
	print_string(logfile, current_base_lex);
	print_log("\" ");
	print_tfs(current_tfs);
    }
    if ((db_operation & Lookup) && (db_operation & (Create | Update))) {
	if (current_tfs_index < 0)
	    /* if we don't know if it is already stored */
	    current_tfs_index = (t_card) add_tfs(current_tfs);
	db_store_form(surface_word, (int) surface_end,
		      current_base_lex, (int) current_tfs_index);
    }
}

static void
print_partition(lexical_pos, surface_pos, lexical_focus_end, surface_focus_end)
int         lexical_pos;
int         surface_pos;
int         lexical_focus_end;
int         surface_focus_end;

{
    print_log("%2d ", lexical_pos);
    print_string_l(logfile, surface_word, surface_pos);
    print_log("|");
    print_string_l(logfile, surface_word + surface_pos,
		   surface_focus_end - surface_pos);
    print_log("|");
    print_string(logfile, surface_word + surface_focus_end);
    print_log(" / ");
    print_string_l(logfile, lexical_word, lexical_pos);
    print_log("|");
    print_string_l(logfile, lexical_word + lexical_pos,
		   lexical_focus_end - lexical_pos);
    print_log("|");
    print_string(logfile, lexical_word + lexical_focus_end);
}

/*
    this the core of the spelling mechanism
*/
static void
spell(pos_stack_top)
int         pos_stack_top;

{
    int         spell_index;	/* applied spelling rule index */
    int         block_index;	/* obligatory (blocking) rule index */
    t_boolean   match;	/* true if surface tape is valid */
    int         lexical_pos;	/* position of beginning of focus on lexical
				   tape */
    int         surface_pos;	/* position of beginning of focus on surface
				   tape */
    int         pos_stack_index;	/* cursor on the positions stack */
    int         lexical_focus_end;
    int         surface_focus_end;
    int         i;	/* see guys! I can write short identifiers !! :-) */
    WORD_TYPE  *spell_set;
    s_spell_instance *blocker;
    t_boolean   match_right;
    t_boolean   match_left;

    if (lexical_word[pos_stack[pos_stack_top].lexical_pos] == NUL_LETTER) {
	surface_word[pos_stack[pos_stack_top].surface_pos] = NUL_LETTER;
	if (spell_trace_level > TRACE_LEFT_MATCH) {
	    print_log("checking validity of surface \"");
	    print_string(logfile, surface_word);
	    print_log("\"\n");
	}
	/* end of lexical_tape */
	match = TRUE;
	pos_stack_index = 0;
	/* foreach position on the stack */
	for (; match && pos_stack_index < pos_stack_top; pos_stack_index++) {
	    /* check if their right context matches */
	    lexical_pos = pos_stack[pos_stack_index].lexical_pos;
	    surface_pos = pos_stack[pos_stack_index].surface_pos;
	    spell_index = pos_stack[pos_stack_index].spell_index;
	    lexical_focus_end = pos_stack[pos_stack_index + 1].lexical_pos;
	    surface_focus_end = pos_stack[pos_stack_index + 1].surface_pos;
	    match = match_right_context(lexical_focus_end, surface_focus_end,
					spell_index);
	    if (match) {
		if (spell_trace_level >= TRACE_NON_BLOCKING
		    && spell_index >= 0) {
		    print_partition(lexical_pos, surface_pos,
				    lexical_focus_end, surface_focus_end);
		    print_log("\t%s ", SPELL_NAME(spell_index));
		    print_log("surface right context matches\n");
		}
		spell_set = APPLICABILITY_MAP(lexical_pos);
		/* for each obligatory rule check if they don't block */
		FOR_EACH_SPELL(spell_set, block_index) {
		    blocker = symbol_set[Spelling].ref[block_index]
			->data->spelling.instance;
		    if (block_index != spell_index && COERCE(blocker)) {
			lexical_focus_end = lexical_pos
			    + blocker->focus_length;
			/* find the corresponding surface partitions */
			/* include zero interval */
			for (i = pos_stack_index;
			     i <= pos_stack_top
			     && (lexical_focus_end
				 >= pos_stack[i].lexical_pos)
			     && match;
			     i++)
			    if (lexical_focus_end
				== pos_stack[i].lexical_pos) {
				surface_focus_end = pos_stack[i].surface_pos;
				match_right = FALSE;
				match_left = FALSE;
				match = !(!match_focus(lexical_pos,
						       surface_pos,
						       block_index,
						       lexical_focus_end,
						       surface_focus_end)
					  && (match_left =
					      match_left_context(lexical_pos,
								 surface_pos,

							       block_index))
					  && (match_right =
					      match_right_context(
							  lexical_focus_end,
							  surface_focus_end,

							     block_index)));
				if ((!match
				     && (spell_trace_level
					 >= TRACE_BLOCKING))
				    || (spell_trace_level
					>= TRACE_NON_BLOCKING)) {
				    print_partition(lexical_pos,
						    surface_pos,
						    lexical_focus_end,
						    surface_focus_end);
				    print_log("\t%s ",
					      SPELL_NAME(block_index));
				    if (match && match_left && match_right)
					print_log("licenses\n");
				    else if (match)
					print_log("doesn't block\n");
				    else
					print_log("blocks\n");
				}
			    }
			if (!match) {
			    break;	/* FOR_EACH_SPELL */
			}
		    }
		}
	    }
	    else if (spell_trace_level >= TRACE_BLOCKING) {
		print_partition(lexical_pos, surface_pos,
				lexical_focus_end, surface_focus_end);
		print_log("\t%s ", SPELL_NAME(spell_index));
		print_log("surface right context mismatch\n");
	    }
	}
	if (match)
	    handle_result(pos_stack[pos_stack_top].surface_pos);
    }
    else {	/* try all applicable rules */
	lexical_pos = pos_stack[pos_stack_top].lexical_pos;
	surface_pos = pos_stack[pos_stack_top].surface_pos;
	spell_set = APPLICABILITY_MAP(lexical_pos);
	FOR_EACH_SPELL(spell_set, spell_index) {
	    /* check left context */
	    if (RESTRICT(symbol_set[Spelling].ref[spell_index]
			 ->data->spelling.instance)
	     && match_left_context(lexical_pos, surface_pos, spell_index)) {
		/* put rule and new positions on stack */
		if (pos_stack_top >= (int) POS_STACK_SIZE - 1)
		    fatal_error("reached internal limit:%s%d",
				"max spell stack=", POS_STACK_SIZE);
		(void) copy_focus(lexical_pos, surface_pos, &spell_index,
				  &pos_stack[pos_stack_top + 1].lexical_pos,
				  &pos_stack[pos_stack_top + 1].surface_pos);
		pos_stack[pos_stack_top].spell_index = spell_index;
		/* recurse to write the rest of the surface tape */
		if (spell_trace_level >= TRACE_LEFT_MATCH) {
		    surface_word[pos_stack[pos_stack_top + 1].surface_pos]
			= NUL_LETTER;
		    print_partition(lexical_pos, surface_pos,
				    pos_stack[pos_stack_top + 1].lexical_pos,
				  pos_stack[pos_stack_top + 1].surface_pos);
		    print_log("\t%s ", SPELL_NAME(spell_index));
		    print_log("surface left context matches\n");
		}
		spell(pos_stack_top + 1);
	    }
	}
	/* apply default rule */
	spell_index = -1;	/* indicate a default rule */
	if (copy_focus(lexical_pos, surface_pos, &spell_index,
		       &pos_stack[pos_stack_top + 1].lexical_pos,
		       &pos_stack[pos_stack_top + 1].surface_pos)) {
	    /* recurse to write the rest of the surface tape */
	    pos_stack[pos_stack_top].spell_index = spell_index;
	    if (spell_trace_level >= TRACE_LEFT_MATCH) {
		surface_word[pos_stack[pos_stack_top + 1].surface_pos]
		    = NUL_LETTER;
		print_partition(lexical_pos, surface_pos,
				pos_stack[pos_stack_top + 1].lexical_pos,
				pos_stack[pos_stack_top + 1].surface_pos);
		print_log("\tdefault\n");
	    }
	    spell(pos_stack_top + 1);
	}
    }
}

void
do_spell(lex, base_lex, tfs, tfs_index)
t_letter   *lex;
t_letter   *base_lex;
s_tfs      *tfs;
t_card     *tfs_index;	/* in & out */

{
    /* pass base_lex and  tfs as external arguments to handle_result */
    current_base_lex = base_lex;
    current_tfs = tfs;
    current_tfs_index = *tfs_index;
    surface_tape[0] = NUL_LETTER;	/* prevent any context to match */
    lexical_word = lex;
    surface_word = surface_tape + 1;
    pos_stack[0].lexical_pos = 0;
    pos_stack[0].surface_pos = 0;
    if (spell_trace_level >= TRACE_LEFT_MATCH) {
	print_log("constructing surface string:\n");
    }
    valid_surface = 0;
    spell(0);
    *tfs_index = current_tfs_index;
    if (valid_surface < 1
	&& spell_trace_level >= TRACE_VALID_SURFACE) {
	print_log("warning: no valid surface form for \"");
	print_string(logfile, lexical_word);
	print_log("\"\n");
    }
}