/* OTGrammar.c
 *
 * Copyright (C) 1997-2003 Paul Boersma
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 * See the GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

/*
 * pb 2002/05/28
 * pb 2002/07/16 GPL
 * pb 2002/11/04 randomize in case of equal candidates
 * pb 2003/05/08 better superset violation warning
 * pb 2003/05/23 made superset violation warning conditional
 */

#include "OTGrammar.h"

#include "oo_DESTROY.h"
#include "OTGrammar_def.h"
#include "oo_COPY.h"
#include "OTGrammar_def.h"
#include "oo_EQUAL.h"
#include "OTGrammar_def.h"
#include "oo_WRITE_BINARY.h"
#include "OTGrammar_def.h"
#include "oo_READ_BINARY.h"
#include "OTGrammar_def.h"
#include "oo_DESCRIPTION.h"
#include "OTGrammar_def.h"

static void info (I) {
	iam (OTGrammar);
	long numberOfCandidates = 0, itab, numberOfViolations = 0, icand, icons;
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		numberOfCandidates += my tableaus [itab]. numberOfCandidates;
		for (icand = 1; icand <= my tableaus [itab]. numberOfCandidates; icand ++)
			for (icons = 1; icons <= my numberOfConstraints; icons ++)
				numberOfViolations += my tableaus [itab]. candidates [icand]. marks [icons];
	}
	Melder_info ("Number of constraints: %ld", my numberOfConstraints);
	Melder_info ("Number of tableaus: %ld", my numberOfTableaus);
	Melder_info ("Number of candidates: %ld", numberOfCandidates);
	Melder_info ("Number of violation marks: %ld", numberOfViolations);
}

static int writeAscii (I, FILE *f) {
	iam (OTGrammar);
	long icons, irank, itab, icand;
	const char *p;
	fprintf (f, "\n%ld constraints", my numberOfConstraints);
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [icons];
		fprintf (f, "\nconstraint [%ld]: \"", icons);
		for (p = & constraint -> name [0]; *p; p ++) { if (*p =='\"') fputc (*p, f); fputc (*p, f); }
		fprintf (f, "\" %.17g %.17g ! ", constraint -> ranking, constraint -> disharmony);
		for (p = & constraint -> name [0]; *p; p ++) {
			if (*p == '\n') fputc (' ', f);
			else if (*p == '\\' && p [1] == 's' && p [2] == '{') p += 2;
			else if (*p == '}') { }
			else fputc (*p, f);
		}
	}
	fprintf (f, "\n\n%ld fixed rankings", my numberOfFixedRankings);
	for (irank = 1; irank <= my numberOfFixedRankings; irank ++) {
		OTGrammarFixedRanking fixedRanking = & my fixedRankings [irank];
		fprintf (f, "\n   %ld %ld", fixedRanking -> higher, fixedRanking -> lower);
	}
	fprintf (f, "\n\n%ld tableaus", my numberOfTableaus);
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		OTGrammarTableau tableau = & my tableaus [itab];
		fprintf (f, "\ninput [%ld]: \"", itab);
		for (p = & tableau -> input [0]; *p; p ++) { if (*p =='\"') fputc (*p, f); fputc (*p, f); }
		fprintf (f, "\" %ld", tableau -> numberOfCandidates);
		for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
			OTGrammarCandidate candidate = & tableau -> candidates [icand];
			fprintf (f, "\n   candidate [%ld]: \"", icand);
			for (p = & candidate -> output [0]; *p; p ++) { if (*p =='\"') fputc (*p, f); fputc (*p, f); }
			fprintf (f, "\"");
			for (icons = 1; icons <= candidate -> numberOfConstraints; icons ++)
				fprintf (f, " %d", candidate -> marks [icons]);
		}
	}
	return 1;
}

void OTGrammar_checkIndex (OTGrammar me) {
	int icons;
	if (my index) return;
	my index = NUMlvector (1, my numberOfConstraints);
	for (icons = 1; icons <= my numberOfConstraints; icons ++) my index [icons] = icons;
	OTGrammar_sort (me);
}

static int readAscii (I, FILE *f) {
	iam (OTGrammar);
	long icons, irank, itab, icand;
	if (! inherited (OTGrammar) readAscii (me, f)) return 0;
	if ((my numberOfConstraints = ascgeti4 (f)) < 1) return Melder_error ("No constraints.");
	if (! (my constraints = NUMstructvector (OTGrammarConstraint, 1, my numberOfConstraints))) return 0;
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [icons];
		if (! (constraint -> name = ascgets2 (f))) return 0;
		constraint -> ranking = ascgetr8 (f);
		constraint -> disharmony = ascgetr8 (f);
	}
	if ((my numberOfFixedRankings = ascgeti4 (f)) >= 1) {
		if (! (my fixedRankings = NUMstructvector (OTGrammarFixedRanking, 1, my numberOfFixedRankings))) return 0;
		for (irank = 1; irank <= my numberOfFixedRankings; irank ++) {
			OTGrammarFixedRanking fixedRanking = & my fixedRankings [irank];
			fixedRanking -> higher = ascgeti4 (f);
			fixedRanking -> lower = ascgeti4 (f);
		}
	}
	if ((my numberOfTableaus = ascgeti4 (f)) < 1) return Melder_error ("No tableaus.");
	if (! (my tableaus = NUMstructvector (OTGrammarTableau, 1, my numberOfTableaus))) return 0;
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		OTGrammarTableau tableau = & my tableaus [itab];
		if (! (tableau -> input = ascgets2 (f))) return 0;
		if ((tableau -> numberOfCandidates = ascgeti4 (f)) < 1) return Melder_error ("No candidates in tableau %ld.", itab);
		if (! (tableau -> candidates = NUMstructvector (OTGrammarCandidate, 1, tableau -> numberOfCandidates))) return 0;
		for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
			OTGrammarCandidate candidate = & tableau -> candidates [icand];
			if (! (candidate -> output = ascgets2 (f))) return 0;
			candidate -> numberOfConstraints = my numberOfConstraints;   /* Redundancy, needed for writing binary. */
			if (! (candidate -> marks = NUMivector (1, candidate -> numberOfConstraints))) return 0;
			for (icons = 1; icons <= candidate -> numberOfConstraints; icons ++)
				candidate -> marks [icons] = ascgeti2 (f);
		}
	}
	OTGrammar_checkIndex (me);
	return 1;
}

class_methods (OTGrammar, Data)
	class_method_local (OTGrammar, destroy)
	class_method (info)
	class_method_local (OTGrammar, description)
	class_method_local (OTGrammar, copy)
	class_method_local (OTGrammar, equal)
	class_method (writeAscii)
	class_method (readAscii)
	class_method_local (OTGrammar, writeBinary)
	class_method_local (OTGrammar, readBinary)
class_methods_end

void OTGrammar_sort (OTGrammar me) {
	long i, j, n = my numberOfConstraints;
	OTGrammar_checkIndex (me);
	for (i = 1; i < n; i ++) {
		OTGrammarConstraint ci = & my constraints [my index [i]];
		double maximum = ci -> disharmony;
		long jmax = i, dummy;
		for (j = i + 1; j <= n; j ++) {
			OTGrammarConstraint cj = & my constraints [my index [j]];
			double disharmonyj = cj -> disharmony;
			if (disharmonyj > maximum || disharmonyj == maximum && NUMrandomInteger (1, 2) == 2) {
				maximum = disharmonyj;
				jmax = j;
			}
		}
		dummy = my index [i]; my index [i] = my index [jmax]; my index [jmax] = dummy;   /* Swap. */
	}
}

void OTGrammar_newDisharmonies (OTGrammar me, double spreading) {
	long icons;
	OTGrammar_checkIndex (me);
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [icons];
		constraint -> disharmony = constraint -> ranking + NUMrandomGauss (0, spreading)
			/*NUMrandomUniform (-spreading, spreading)*/;
	}
	OTGrammar_sort (me);
}

long OTGrammar_getTableau (OTGrammar me, const char *input) {
	long i, n = my numberOfTableaus;
	OTGrammar_checkIndex (me);
	for (i = 1; i <= n; i ++) if (strequ (my tableaus [i]. input, input)) return i;
	return Melder_error ("Input \"%s\" not in list of tableaus.", input);
}

long OTGrammar_getWinner (OTGrammar me, long itab) {
	OTGrammarTableau tableau = & my tableaus [itab];
	long ibest = 1, icand, icons, numberOfEqualCandidates = 1;
	OTGrammarCandidate best = & tableau -> candidates [1];
	OTGrammar_checkIndex (me);
	for (icand = 2; icand <= tableau -> numberOfCandidates; icand ++) {
		OTGrammarCandidate cand = & tableau -> candidates [icand];
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int bestMarks = best -> marks [my index [icons]], currentMarks = cand -> marks [my index [icons]];
			if (bestMarks < currentMarks) break;
			if (bestMarks > currentMarks) { ibest = icand; best = cand; break; }
		}
		if (icons > my numberOfConstraints) {
			numberOfEqualCandidates += 1;
			if (NUMrandomUniform (0.0, numberOfEqualCandidates) < 1.0) {
				ibest = icand; best = cand;
			}
		} else {
			numberOfEqualCandidates = 1;
		}
	}
	return ibest;
}

OTGrammarCandidate OTGrammar_getInterpretiveParse (OTGrammar me, const char *overtForm, long *bestInput, long *bestOutput) {
	OTGrammarCandidate best = NULL;
	long itab, icand, icons, numberOfEqualCandidates = 1;
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		OTGrammarTableau tableau = & my tableaus [itab];
		for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
			OTGrammarCandidate cand = & tableau -> candidates [icand];
			if (strstr (cand -> output, overtForm)) {   /* T&S idea of surface->overt mapping */
				if (best == NULL) {
					best = cand;
					if (bestInput) *bestInput = itab;
					if (bestOutput) *bestOutput = icand;
				} else {
					for (icons = 1; icons <= my numberOfConstraints; icons ++) {
						int bestMarks = best -> marks [my index [icons]], currentMarks = cand -> marks [my index [icons]];
						if (bestMarks < currentMarks) break;
						if (bestMarks > currentMarks) {
							best = cand;
							if (bestInput) *bestInput = itab;
							if (bestOutput) *bestOutput = icand;
							break;
						}
					}
					if (icons > my numberOfConstraints) {
						numberOfEqualCandidates += 1;
						if (NUMrandomUniform (0.0, numberOfEqualCandidates) < 1.0) {
							best = cand;
							if (bestInput) *bestInput = itab;
							if (bestOutput) *bestOutput = icand;
						}
					} else {
						numberOfEqualCandidates = 1;
					}
				}
			}
		}
	}
	if (best == NULL) {
		Melder_error ("Overt form \"%s\" does not match any candidate for any underlying form.", overtForm);
		goto end;
	}
end:
	iferror Melder_error ("(OTGrammar: Get interpretive parse:) Not performed.");
	return best;
}

static int OTGrammar_crucialCell (OTGrammar me, long itab, long icand, long iwinner) {
	int icons;
	OTGrammarTableau tableau = & my tableaus [itab];
	OTGrammar_checkIndex (me);
	if (tableau -> numberOfCandidates < 2) return 0;   /* If there is only one candidate, all cells can be greyed. */
	if (icand == iwinner) {
		long jcand, secondBest = iwinner == 1 ? 2 : 1;
		for (jcand = 1; jcand <= tableau -> numberOfCandidates; jcand ++) if (jcand != iwinner) {
			int *secondBestMarks = tableau -> candidates [secondBest]. marks;
			int *currentMarks = tableau -> candidates [jcand]. marks;
			for (icons = 1; icons <= my numberOfConstraints; icons ++) {
				int index = my index [icons];
				if (secondBestMarks [index] < currentMarks [index]) break;
				if (secondBestMarks [index] > currentMarks [index]) { secondBest = jcand; break; }
			}
		}
		return OTGrammar_crucialCell (me, itab, secondBest, iwinner);
	} else {
		OTGrammarCandidate cand = & tableau -> candidates [icand], winner = & tableau -> candidates [iwinner];
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int index = my index [icons];
			if (cand -> marks [index] > winner -> marks [index])
				return icons;
		}
	}
	return my numberOfConstraints + 1;
}

static double OTGrammar_constraintWidth (OTGrammar me, Graphics g, const char *name) {
	char text [100], *newLine;
	OTGrammar_checkIndex (me);
	strcpy (text, name);
	newLine = strchr (text, '\n');
	if (newLine) {
		double firstWidth, secondWidth;
		*newLine = '\0';
		firstWidth = Graphics_textWidth (g, text);
		secondWidth = Graphics_textWidth (g, newLine + 1);
		return firstWidth > secondWidth ? firstWidth : secondWidth;
	}
	return Graphics_textWidth (g, text);
}

void OTGrammar_drawTableau (OTGrammar me, Graphics g, const char *input) {
	long itab, icand, icons, imark, winner;
	OTGrammarTableau tableau;
	double candWidth, margin, fingerWidth, doubleLineDx, doubleLineDy;
	double tableauWidth, rowHeight, headerHeight, descent, x, y, fontSize = Graphics_inqFontSize (g);
	char text [200];
	OTGrammar_checkIndex (me);
	itab = OTGrammar_getTableau (me, input);
	if (! itab) { Melder_flushError ("This grammar accepts no input \"%s\".", input); return; }
	winner = OTGrammar_getWinner (me, itab);
	
	Graphics_setWindow (g, 0.0, 1.0, 0.0, 1.0);
	margin = Graphics_dxMMtoWC (g, 1.0);
	fingerWidth = Graphics_dxMMtoWC (g, 7.0) * fontSize / 12.0;
	doubleLineDx = Graphics_dxMMtoWC (g, 0.9);
	doubleLineDy = Graphics_dyMMtoWC (g, 0.9);
	rowHeight = Graphics_dyMMtoWC (g, 1.5 * fontSize * 25.4 / 72);
	descent = rowHeight * 0.5;
	/*
	 * Compute height of header row.
	 */
	headerHeight = rowHeight;
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [icons];
		if (strchr (constraint -> name, '\n')) {
			headerHeight *= 1.6;
			break;
		}
	}
	/*
	 * Compute longest candidate string.
	 */
	candWidth = Graphics_textWidth (g, input);
	tableau = & my tableaus [itab];
	for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
		double width = Graphics_textWidth (g, tableau -> candidates [icand]. output);
		if (icand == winner) width += fingerWidth;
		if (width > candWidth) candWidth = width;
	}
	candWidth += margin * 3;
	/*
	 * Compute tableau width.
	 */
	tableauWidth = candWidth + doubleLineDx;
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [icons];
		tableauWidth += OTGrammar_constraintWidth (me, g, constraint -> name);
	}
	tableauWidth += margin * 2 * my numberOfConstraints;
	/*
	 * Draw box.
	 */
	x = doubleLineDx;   /* Left side of tableau. */
	y = 1.0 - doubleLineDy;
	Graphics_rectangle (g, x, x + tableauWidth,
		y - headerHeight - tableau -> numberOfCandidates * rowHeight - doubleLineDy, y);
	/*
	 * Draw input.
	 */
	y -= headerHeight;
	Graphics_setTextAlignment (g, Graphics_CENTRE, Graphics_HALF);
	Graphics_printf (g, x + 0.5 * candWidth, y + 0.5 * headerHeight, "%s", input);
	Graphics_rectangle (g, x, x + candWidth, y, y + headerHeight);
	/*
	 * Draw constraint names.
	 */
	x += candWidth + doubleLineDx;
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [my index [icons]];
		double width = OTGrammar_constraintWidth (me, g, constraint -> name) + margin * 2;
		if (strchr (constraint -> name, '\n')) {
			char *newLine;
			strcpy (text, constraint -> name);
			newLine = strchr (text, '\n');
			*newLine = '\0';
			Graphics_setTextAlignment (g, Graphics_CENTRE, Graphics_TOP);
			Graphics_text (g, x + 0.5 * width, y + headerHeight, text);
			Graphics_setTextAlignment (g, Graphics_CENTRE, Graphics_BOTTOM);
			Graphics_text (g, x + 0.5 * width, y, newLine + 1);
		} else {
			Graphics_setTextAlignment (g, Graphics_CENTRE, Graphics_HALF);
			Graphics_text (g, x + 0.5 * width, y + 0.5 * headerHeight, constraint -> name);
		}
		Graphics_rectangle (g, x, x + width, y, y + headerHeight);
		x += width;
	}
	/*
	 * Draw candidates.
	 */
	y -= doubleLineDy;
	for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
		long crucialCell = OTGrammar_crucialCell (me, itab, icand, winner);
		/*
		 * Draw candidate transcription.
		 */
		x = doubleLineDx;
		y -= rowHeight;
		Graphics_setTextAlignment (g, Graphics_RIGHT, Graphics_HALF);
		Graphics_text (g, x + candWidth - margin, y + descent, tableau -> candidates [icand]. output);
		if (icand == winner) {
			Graphics_setTextAlignment (g, Graphics_LEFT, Graphics_HALF);
			Graphics_setFontSize (g, 1.5 * fontSize);
			Graphics_text (g, x + margin, y + descent - Graphics_dyMMtoWC (g, 1.0) * fontSize / 12.0, "\\pf");
			Graphics_setFontSize (g, fontSize);
		}
		Graphics_rectangle (g, x, x + candWidth, y, y + rowHeight);
		/*
		 * Draw mark cells.
		 */
		x = candWidth + 2 * doubleLineDx;
		Graphics_setGrey (g, 0.9);
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int index = my index [icons];
			OTGrammarConstraint constraint = & my constraints [index];
			double width = OTGrammar_constraintWidth (me, g, constraint -> name) + margin * 2;
			if (icons > crucialCell)
				Graphics_fillRectangle (g, x, x + width, y, y + rowHeight);
			x += width;
		}
		Graphics_setGrey (g, 0.0);
		x = candWidth + 2 * doubleLineDx;
		Graphics_setTextAlignment (g, Graphics_CENTRE, Graphics_HALF);
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int index = my index [icons];
			OTGrammarConstraint constraint = & my constraints [index];
			double width = OTGrammar_constraintWidth (me, g, constraint -> name) + margin * 2;
			char markString [40];
			markString [0] = '\0';
			if (icons == crucialCell && icand != winner) {
				int winnerMarks = tableau -> candidates [winner]. marks [index];
				for (imark = 1; imark <= winnerMarks + 1; imark ++)
					strcat (markString, "*");
				strcat (markString, "!");
				for (imark = winnerMarks + 2; imark <= tableau -> candidates [icand]. marks [index]; imark ++)
					strcat (markString, "*");
			} else {
				for (imark = 1; imark <= tableau -> candidates [icand]. marks [index]; imark ++)
					strcat (markString, "*");
			}
			Graphics_text (g, x + 0.5 * width, y + descent, markString);
			Graphics_rectangle (g, x, x + width, y, y + rowHeight);
			x += width;
		}
	}
}

Strings OTGrammar_generateInputs (OTGrammar me, long numberOfTrials) {
	long i;
	Strings thee = new (Strings); cherror
	thy strings = NUMpvector (1, thy numberOfStrings = numberOfTrials); cherror
	for (i = 1; i <= numberOfTrials; i ++) {
		long itab = NUMrandomInteger (1, my numberOfTableaus);
		thy strings [i] = Melder_strdup (my tableaus [itab]. input); cherror
	}
end:	iferror forget (thee);
	return thee;
}

Strings OTGrammar_getInputs (OTGrammar me) {
	long i;
	Strings thee = new (Strings); cherror
	thy strings = NUMpvector (1, thy numberOfStrings = my numberOfTableaus); cherror
	for (i = 1; i <= my numberOfTableaus; i ++) {
		thy strings [i] = Melder_strdup (my tableaus [i]. input); cherror
	}
end:	iferror forget (thee);
	return thee;
}

int OTGrammar_inputToOutput (OTGrammar me, const char *input, char *output, double rankingSpreading) {
	long itab, winner;
	OTGrammar_checkIndex (me);
	OTGrammar_newDisharmonies (me, rankingSpreading);
	itab = OTGrammar_getTableau (me, input); cherror
	winner = OTGrammar_getWinner (me, itab);
	if (! winner) { Melder_error ("No winner"); goto end; }
	strcpy (output, my tableaus [itab]. candidates [winner]. output);
end:
	iferror return Melder_error ("(OTGrammar_inputToOutput:) Not performed.");
	return 1;
}

Strings OTGrammar_inputsToOutputs (OTGrammar me, Strings inputs, double rankingSpreading) {
	Strings outputs = new (Strings);
	long i, n = inputs -> numberOfStrings;
	cherror
	OTGrammar_checkIndex (me);
	outputs -> numberOfStrings = n;
	outputs -> strings = NUMpvector (1, n); cherror
	for (i = 1; i <= n; i ++) {
		char output [100];
		OTGrammar_inputToOutput (me, inputs -> strings [i], output, rankingSpreading); cherror
		outputs -> strings [i] = Melder_strdup (output); cherror
	}
end:
	iferror { forget (outputs); return Melder_errorp ("(OTGrammar_inputsToOutputs:) Not performed."); }
	return outputs;
}

Strings OTGrammar_inputToOutputs (OTGrammar me, const char *input, long n, double rankingSpreading) {
	Strings outputs = new (Strings);
	long i;
	cherror
	OTGrammar_checkIndex (me);
	outputs -> numberOfStrings = n;
	outputs -> strings = NUMpvector (1, n); cherror
	for (i = 1; i <= n; i ++) {
		char output [100];
		OTGrammar_inputToOutput (me, input, output, rankingSpreading); cherror
		outputs -> strings [i] = Melder_strdup (output); cherror
	}
end:
	iferror return Melder_errorp ("(OTGrammar_inputToOutputs:) Not performed.");
	return outputs;
}

Distributions OTGrammar_to_Distribution (OTGrammar me, long trialsPerInput, double noise) {
	Distributions thee;
	long totalNumberOfOutputs = 0, nout = 0, itab, icand, itrial;
	OTGrammar_checkIndex (me);
	/*
	 * Count the total number of outputs.
	 */
	for (itab = 1; itab <= my numberOfTableaus; itab ++)
		totalNumberOfOutputs += my tableaus [itab]. numberOfCandidates;
	/*
	 * Create the distribution. One row for every output form.
	 */
	if ((thee = Distributions_create (totalNumberOfOutputs, 1)) == NULL) return NULL;
	/*
	 * Measure every input form.
	 */
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		OTGrammarTableau tableau = & my tableaus [itab];
		if (! Melder_progress ((itab - 0.5) / my numberOfTableaus, "Measuring input \"%s\"", tableau -> input))
			{ forget (thee); return NULL; }
		/*
		 * Set the row labels to the output strings.
		 */
		for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
			char rowTitle [1000];
			sprintf (rowTitle, "%s \\-> %s", tableau -> input, tableau -> candidates [icand]. output);
			thy rowLabels [nout + icand] = Melder_strdup (rowTitle);
		}
		/*
		 * Compute a number of outputs and store the results.
		 */
		for (itrial = 1; itrial <= trialsPerInput; itrial ++) {
			long iwinner;
			OTGrammar_newDisharmonies (me, noise);
			iwinner = OTGrammar_getWinner (me, itab);
			thy data [nout + iwinner] [1] += 1;
		}
		/*
		 * Update the offset.
		 */
		nout += tableau -> numberOfCandidates;
	}
	Melder_progress (1.0, NULL);
	return thee;
}

PairDistribution OTGrammar_to_PairDistribution (OTGrammar me, long trialsPerInput, double noise) {
	PairDistribution thee;
	PairProbability *p;
	long totalNumberOfOutputs = 0, nout = 0, itab, icand, itrial;
	OTGrammar_checkIndex (me);
	/*
	 * Count the total number of outputs.
	 */
	for (itab = 1; itab <= my numberOfTableaus; itab ++)
		totalNumberOfOutputs += my tableaus [itab]. numberOfCandidates;
	/*
	 * Create the distribution. One row for every output form.
	 */
	if ((thee = PairDistribution_create ()) == NULL) return NULL;
	/*
	 * Measure every input form.
	 */
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		OTGrammarTableau tableau = & my tableaus [itab];
		if (! Melder_progress ((itab - 0.5) / my numberOfTableaus, "Measuring input \"%s\"", tableau -> input))
			{ forget (thee); return NULL; }
		/*
		 * Copy the input and output strings to the target object.
		 */
		for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
			PairDistribution_add (thee, tableau -> input, tableau -> candidates [icand]. output, 0);
		}
		/*
		 * Compute a number of outputs and store the results.
		 */
		p = (PairProbability *) thy pairs -> item;   /* May have changed after PairDistribution_add !!! */
		for (itrial = 1; itrial <= trialsPerInput; itrial ++) {
			long iwinner;
			OTGrammar_newDisharmonies (me, noise);
			iwinner = OTGrammar_getWinner (me, itab);
			p [nout + iwinner] -> weight += 1;
		}
		/*
		 * Update the offset.
		 */
		nout += tableau -> numberOfCandidates;
	}
	Melder_progress (1.0, NULL);
	return thee;
}

static int honoursFixedRankings (OTGrammar me) {
	long i, icons;
	for (i = 1; i <= my numberOfFixedRankings; i ++) {
		long higher = my fixedRankings [i]. higher, lower = my fixedRankings [i]. lower;
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			if (my index [icons] == higher) break;   /* Detected higher before lower: OK. */
			if (my index [icons] == lower) return FALSE;
		}
	}
	return TRUE;
}

Distributions OTGrammar_measureTypology (OTGrammar me) {
	Distributions thee;
	long totalNumberOfOutputs = 0, nout = 0, itab, icand, ncons = my numberOfConstraints, icons, nperm, iperm, factorial [1+12];
	OTGrammar_checkIndex (me);
	if (ncons > 12)
		return Melder_errorp ("(OTGrammar_measureTypology:) Cannot handle more than 12 constraints.");
	factorial [0] = 1;
	for (icons = 1; icons <= ncons; icons ++) {
		factorial [icons] = factorial [icons - 1] * icons;
	}
	nperm = factorial [ncons];
	/*
	 * Count the total number of outputs.
	 */
	for (itab = 1; itab <= my numberOfTableaus; itab ++)
		totalNumberOfOutputs += my tableaus [itab]. numberOfCandidates;
	/*
	 * Create the distribution. One row for every output form.
	 */
	if ((thee = Distributions_create (totalNumberOfOutputs, 1)) == NULL) return NULL;
	/*
	 * Measure every input form.
	 */
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		OTGrammarTableau tableau = & my tableaus [itab];
		if (! Melder_progress ((itab - 0.5) / my numberOfTableaus, "Measuring input \"%s\"", tableau -> input))
			{ forget (thee); return NULL; }
		/*
		 * Set the row labels to the output strings.
		 */
		for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
			char rowTitle [1000];
			sprintf (rowTitle, "%s \\-> %s", tableau -> input, tableau -> candidates [icand]. output);
			thy rowLabels [nout + icand] = Melder_strdup (rowTitle);
		}
		/*
		 * Compute a number of outputs and store the results.
		 */
		for (iperm = 0; iperm < nperm; iperm ++) {
			long permleft = iperm, iwinner;
			/* Initialize to 12345 before permuting. */
			for (icons = 1; icons <= ncons; icons ++) {
				my index [icons] = icons;
			}
			for (icons = 1; icons < ncons; icons ++) {
				long fac = factorial [ncons - icons], shift = permleft / fac, dummy;
				/*
				 * Swap constraint with the one at a distance 'shift'.
				 */
				dummy = my index [icons];
				my index [icons] = my index [icons + shift];
				my index [icons + shift] = dummy;
				permleft %= fac;
			}
			if (honoursFixedRankings (me)) {
				iwinner = OTGrammar_getWinner (me, itab);
				thy data [nout + iwinner] [1] += 1;
			}
		}
		/*
		 * Update the offset.
		 */
		nout += tableau -> numberOfCandidates;
	}
	Melder_progress (1.0, NULL);
	return thee;
}

static double demotionStep (double mean, double relativeSpreading) {
	return relativeSpreading == 0.0 ? mean : NUMrandomGauss (mean, relativeSpreading * mean);
}

int OTGrammar_learnOne (OTGrammar me, const char *underlyingForm, const char *adultOutput,
	double rankingSpreading, int strategy, int honourLocalRankings,
	double demotionMean, double relativeDemotionSpreading, int newDisharmonies, int warnIfStalled)
{
	long icons, iwinner, iloser, itab;
	OTGrammarTableau tableau;
	OTGrammarCandidate winner, loser;
	double step;
	OTGrammar_checkIndex (me);
	if (newDisharmonies) OTGrammar_newDisharmonies (me, rankingSpreading);

	/*
	 * Evaluate the input in the learner's hypothesis.
	 */
	itab = OTGrammar_getTableau (me, underlyingForm); cherror
	tableau = & my tableaus [itab];
	iwinner = OTGrammar_getWinner (me, itab);
	winner = & tableau -> candidates [iwinner];

	/*
	 * Error-driven: compare the adult winner (the correct candidate) and the learner's winner.
	 */
	if (strequ (winner -> output, adultOutput)) goto end;

	/*
	 * Find adult winner in own tableau.
	 */
	for (iloser = 1; iloser <= tableau -> numberOfCandidates; iloser ++) {
		loser = & tableau -> candidates [iloser];
		if (strequ (loser -> output, adultOutput)) break;
	}
	if (iloser > tableau -> numberOfCandidates)
		{ Melder_error ("Cannot generate adult output \"%s\".", adultOutput); goto end; }

	/*
	 * Now we know that the current hypothesis prefers the (wrong) learner's winner over the (correct) adult output.
	 * The grammar will have to change.
	 */
	if (strategy == OTGrammar_SYMMETRIC_ONE) {
		int icons = NUMrandomInteger (1, my numberOfConstraints);
		int winnerMarks = winner -> marks [icons];
		int loserMarks = loser -> marks [icons];
		step = demotionStep (demotionMean, relativeDemotionSpreading);
		if (loserMarks > winnerMarks) my constraints [icons]. ranking -= step;
		if (winnerMarks > loserMarks) my constraints [icons]. ranking += step;
	} else if (strategy == OTGrammar_SYMMETRIC_ALL) {
		step = demotionStep (demotionMean, relativeDemotionSpreading);
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [icons];
			int loserMarks = loser -> marks [icons];
			if (loserMarks > winnerMarks) my constraints [icons]. ranking -= step;
			if (winnerMarks > loserMarks) my constraints [icons]. ranking += step;
		}
	} else if (strategy == OTGrammar_WEIGHTED_UNCANCELLED) {
		int winningConstraints = 0, losingConstraints = 0;
		step = demotionStep (demotionMean, relativeDemotionSpreading);
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [icons];
			int loserMarks = loser -> marks [icons];
			if (loserMarks > winnerMarks) losingConstraints ++;
			if (winnerMarks > loserMarks) winningConstraints ++;
		}
		if (winningConstraints != 0) for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [icons];
			int loserMarks = loser -> marks [icons];
			if (loserMarks > winnerMarks) my constraints [icons]. ranking -= step / losingConstraints;
			if (winnerMarks > loserMarks) my constraints [icons]. ranking += step / winningConstraints;
		}
	} else if (strategy == OTGrammar_WEIGHTED_ALL) {
		int winningConstraints = 0, losingConstraints = 0;
		step = demotionStep (demotionMean, relativeDemotionSpreading);
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [icons];
			int loserMarks = loser -> marks [icons];
			if (loserMarks > 0) losingConstraints ++;
			if (winnerMarks > 0) winningConstraints ++;
		}
		if (winningConstraints != 0) for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [icons];
			int loserMarks = loser -> marks [icons];
			if (loserMarks > 0) my constraints [icons]. ranking -= step / losingConstraints;
			if (winnerMarks > 0) my constraints [icons]. ranking += step / winningConstraints;
		}
	} else if (strategy == OTGrammar_EDCD) {
		/*
		 * Determine the crucial winner mark.
		 */
		double pivotRanking;
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [my index [icons]];   /* Order is important, so indirect. */
			int loserMarks = loser -> marks [my index [icons]];
			if (loserMarks < winnerMarks) break;
		}
		if (icons > my numberOfConstraints) {   /* Completed the loop? */
			if (warnIfStalled)
				Melder_warning ("(OTGrammar_step:) Adult form has superset violations! EDCD stalls.\n"
					"Underlying form: %s\nAdult output: %s\nWinner output: %s", underlyingForm, adultOutput, winner -> output);
			goto end;
		}
		/*
		 * Determine the stratum into which some constraints will be demoted.
		 */
		pivotRanking = my constraints [my index [icons]]. ranking;
		step = demotionStep (demotionMean, relativeDemotionSpreading);
		/*
		 * Demote all the uniquely violated constraints in the loser
		 * that have rankings not lower than the pivot.
		 */
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [icons];
			int loserMarks = loser -> marks [icons];
			if (loserMarks > winnerMarks) {
				OTGrammarConstraint constraint = & my constraints [icons];
				if (constraint -> ranking >= pivotRanking)
					constraint -> ranking = pivotRanking - step;
			}
		}
	} else {
		/*
		 * Determine the crucial loser mark.
		 */
		long crucialLoserMark;
		OTGrammarConstraint offendingConstraint;
		for (icons = 1; icons <= my numberOfConstraints; icons ++) {
			int winnerMarks = winner -> marks [my index [icons]];   /* Order is important, so indirect. */
			int loserMarks = loser -> marks [my index [icons]];
			if (loserMarks < winnerMarks)
				{ Melder_error ("(OTGrammar_step:) Loser wins! Can never happen."); goto end; }
			if (loserMarks > winnerMarks) break;
		}
		if (icons > my numberOfConstraints)   /* Completed the loop? */
			{ Melder_error ("(OTGrammar_step:) Loser equals correct candidate."); goto end; }
		crucialLoserMark = icons;
		/*
		 * Demote the highest uniquely violated constraint in the loser.
		 */
		offendingConstraint = & my constraints [my index [crucialLoserMark]];
		step = demotionStep (demotionMean, relativeDemotionSpreading);
		offendingConstraint -> ranking -= step;
	}

	if (honourLocalRankings && my numberOfFixedRankings) {
		int improved;
		do {
			long irank;
			improved = FALSE;
			for (irank = 1; irank <= my numberOfFixedRankings; irank ++) {
				OTGrammarFixedRanking fixedRanking = & my fixedRankings [irank];
				OTGrammarConstraint higher = & my constraints [fixedRanking -> higher], lower = & my constraints [fixedRanking -> lower];
				while (higher -> ranking < lower -> ranking) {
					lower -> ranking -= demotionStep (demotionMean, relativeDemotionSpreading);
					improved = TRUE;
				}
			}
		} while (improved);
	}
end:
	iferror return 0;
	return 1;
}

int OTGrammar_learn (OTGrammar me, Strings inputs, Strings outputs,
	double rankingSpreading, int strategy, int honourLocalRankings,
	double demotionMean, double relativeDemotionSpreading, long chews)
{
	long n = inputs -> numberOfStrings, i, chew;
	OTGrammar_checkIndex (me);
	if (! inputs) inputs = outputs;
	if (outputs -> numberOfStrings != n)
		{ Melder_error ("Numbers of strings in input and output do not match."); goto end; }
	for (i = 1; i <= n; i ++)
		for (chew = 1; chew <= chews; chew ++)
			if (! OTGrammar_learnOne (me, inputs -> strings [i], outputs -> strings [i],
				rankingSpreading, strategy, honourLocalRankings,
				demotionMean, relativeDemotionSpreading, TRUE, TRUE)) return 0;
end:
	iferror return Melder_error ("(OTGrammar_learn:) Not completed.");
	return 1;
}

int OTGrammar_PairDistribution_learn (OTGrammar me, PairDistribution thee,
	double evaluationNoise, int strategy, int honourLocalRankings,
	double initialPlasticity, long replicationsPerPlasticity, double plasticityDecrement,
	long numberOfPlasticities, double relativePlasticityNoise, long numberOfChews)
{
	long iplasticity, ireplication, ichew;
	double plasticity = initialPlasticity;
	OTGrammar_checkIndex (me);
	for (iplasticity = 1; iplasticity <= numberOfPlasticities; iplasticity ++) {
		for (ireplication = 1; ireplication <= replicationsPerPlasticity; ireplication ++) {
			char *input, *output;
			if (! PairDistribution_peekPair (thee, & input, & output)) goto end;
			for (ichew = 1; ichew <= numberOfChews; ichew ++) {
				if (! OTGrammar_learnOne (me, input, output,
					evaluationNoise, strategy, honourLocalRankings,
					plasticity, relativePlasticityNoise, TRUE, TRUE)) goto end;
			}
		}
		plasticity *= plasticityDecrement;
	}
end:
	iferror return Melder_error ("(OTGrammar_PairDistribution_learn:) Not completed.");
	return 1;
}

int OTGrammar_PairDistribution_getFractionCorrect (OTGrammar me, PairDistribution thee,
	double evaluationNoise, long numberOfInputs, double *fractionCorrect)
{
	long ireplication, numberOfCorrect = 0;
	OTGrammar_checkIndex (me);
	for (ireplication = 1; ireplication <= numberOfInputs; ireplication ++) {
		char *input, *adultOutput, output [100];
		PairDistribution_peekPair (thee, & input, & adultOutput); cherror
		OTGrammar_inputToOutput (me, input, & output [0], evaluationNoise);
		if (strequ (output, adultOutput))
			numberOfCorrect ++;
	}
end:
	iferror return Melder_error ("(OTGrammar_PairDistribution_getFractionCorrect:) Not completed.");
	*fractionCorrect = (double) numberOfCorrect / numberOfInputs;
	return 1;
}

void OTGrammar_reset (OTGrammar me, double ranking) {
	long icons;
	OTGrammar_checkIndex (me);
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [icons];
		constraint -> disharmony = constraint -> ranking = ranking;
	}
	OTGrammar_sort (me);
}

int OTGrammar_setRanking (OTGrammar me, long constraint, double ranking, double disharmony) {
	if (constraint < 1 || constraint > my numberOfConstraints)
		return Melder_error ("(OTGrammar_setRanking): No constraint %ld.", constraint);
	OTGrammar_checkIndex (me);
	my constraints [constraint]. ranking = ranking;
	my constraints [constraint]. disharmony = disharmony;
	OTGrammar_sort (me);
	return 1;
}

int OTGrammar_learnOneFromPartialOutput (OTGrammar me, const char *partialAdultOutput,
	double rankingSpreading, int strategy, int honourLocalRankings,
	double demotionMean, double relativeDemotionSpreading, int warnIfStalled)
{
	long bestInput;
	OTGrammarCandidate candidate;
	OTGrammar_checkIndex (me);
	OTGrammar_newDisharmonies (me, rankingSpreading);
	candidate = OTGrammar_getInterpretiveParse (me, partialAdultOutput, & bestInput, NULL);
	cherror
	OTGrammar_learnOne (me, my tableaus [bestInput]. input, candidate -> output,
		rankingSpreading, strategy, honourLocalRankings,
		demotionMean, relativeDemotionSpreading, FALSE, warnIfStalled);
end:
	iferror return 0;
	return 1;
}

int OTGrammar_learnFromPartialOutputs (OTGrammar me, Strings partialOutputs,
	double rankingSpreading, int strategy, int honourLocalRankings,
	double demotionMean, double relativeDemotionSpreading, long chews)
{
	long n = partialOutputs -> numberOfStrings, i, chew;
	OTGrammar_checkIndex (me);
	for (i = 1; i <= n; i ++)
		for (chew = 1; chew <= chews; chew ++)
			if (! OTGrammar_learnOneFromPartialOutput (me, partialOutputs -> strings [i],
				rankingSpreading, strategy, honourLocalRankings,
				demotionMean, relativeDemotionSpreading, FALSE)) return 0;
	iferror return Melder_error ("(OTGrammar_learnFromPartialOutputs:) Not completed.");
	return 1;
}

int OTGrammar_removeConstraint (OTGrammar me, const char *constraintName) {
	long icons, ifixed, jfixed, itab, icand, removed = 0;

	if (my numberOfConstraints <= 1)
		return Melder_error ("Cannot remove last constraint.");
	OTGrammar_checkIndex (me);

	/*
	 * Look for the constraint to be removed.
	 */
	for (icons = 1; icons <= my numberOfConstraints; icons ++) {
		OTGrammarConstraint constraint = & my constraints [icons];
		if (strequ (constraint -> name, constraintName)) {
			removed = icons;
			break;
		}
	}
	if (removed == 0)
		return Melder_error ("No constraint \"%s\".", constraintName);
	/*
	 * Remove the constraint while reusing the memory space.
	 */
	my numberOfConstraints -= 1;
	/*
	 * Shift constraints.
	 */
	Melder_free (my constraints [removed]. name);
	for (icons = removed; icons <= my numberOfConstraints; icons ++) {
		my constraints [icons] = my constraints [icons + 1];
	}
	/*
	 * Remove or shift fixed rankings.
	 */
	for (ifixed = my numberOfFixedRankings; ifixed > 0; ifixed --) {
		OTGrammarFixedRanking fixed = & my fixedRankings [ifixed];
		if (fixed -> higher == removed || fixed -> lower == removed) {
			/*
			 * Remove fixed ranking.
			 */
			my numberOfFixedRankings -= 1;
			if (my numberOfFixedRankings == 0) {
				NUMstructvector_free (OTGrammarFixedRanking, my fixedRankings, 1);
			}
			for (jfixed = ifixed; jfixed <= my numberOfFixedRankings; jfixed ++) {
				my fixedRankings [jfixed] = my fixedRankings [jfixed + 1];
			}
		} else {
			/*
			 * Shift fixed ranking.
			 */
			if (fixed -> higher > removed) fixed -> higher -= 1;
			if (fixed -> lower > removed) fixed -> lower -= 1;
		}
	}
	/*
	 * Shift tableau rows.
	 */
	for (itab = 1; itab <= my numberOfTableaus; itab ++) {
		OTGrammarTableau tableau = & my tableaus [itab];
		for (icand = 1; icand <= tableau -> numberOfCandidates; icand ++) {
			OTGrammarCandidate candidate = & tableau -> candidates [icand];
			candidate -> numberOfConstraints -= 1;
			for (icons = removed; icons <= my numberOfConstraints; icons ++) {
				candidate -> marks [icons] = candidate -> marks [icons + 1];
			}
		}
	}
	/*
	 * Rebuild index.
	 */
	for (icons = 1; icons <= my numberOfConstraints; icons ++) my index [icons] = icons;
	OTGrammar_sort (me);
	return 1;
}

/* End of file OT.c */