Задача на паскале -словарь

[AnutaPr]

Не понимаю как решать данную задачу на паскале.
Из всей задачи понимаю, что придется работать с массивами, но как циклы построить правильно для перебора слов я затрудняюсь. Подскажите пожалуйста.

Текст задачи:
У Васи на клавиатуре не работает клавиша пробел. Поэтому все тексты он теперь набирает слитно. Напишите программу, которая будет разделять набранный Васей текст на слова из данного словаря.
Формат входных данных
Сначала на вход программы поступает текст, введенный Васей – одна строка из не более чем 100 латинских строчных букв. В следующей строке входных данных задается значение N – количество слов в словаре (N – натуральное число, не превосходящее 2000). В следующих N строках записаны слова из словаря – по одному слову в строке, каждое слово содержит не более 20 латинских строчных букв. Слова записаны в алфавитном порядке.
Формат выходных данных
Выведите Васин текст с пробелами между словами (пробел после последнего слова допустим). Если возможно несколько вариантов разбиения строки на слова, выведите любой их них. Гарантируется, что хотя бы один способ разбиения строки на словарные слова существует.

Заранее спасибо)

[gaw4]

N – количество слов в словаре (N – натуральное число, не превосходящее 2000)
словарь составлен ?

[Serge_Bliznykov]

Сообщение от gaw4

словарь составлен ?

коллега, ну что Вы, зачем TC составлять словарь, если он КАЖДЫЙ раз будет разный.

Это явно олимпиадная задачка. Словарь задаётся исходными данными.
"Подлянка" будет в том, что будут слова, начинающиеся одинако.
например,
МАМАМЫЛАРАМУ

будет такой словарь
АМУ
АРА
ЛАР
МА
МАМ
МАМЫ
МУ

вполне допускаю, что задачу можно решать через рекурсию (если не удалось найти очередное слово, откатываемся назад, берём следующее подходящее...), главное, чтобы хватило стека и времени...

[gaw4]

(N – натуральное число, не превосходящее 2000
тогда довольно таки забавно проверять работоспособность программы
если N=2000 и каждый раз вводить словарь

[BDA]

Тестировать можно здесь - http://informatics.mccme.ru/moodle/m...?chapterid=515.
Мб вечером попробую решить.

[BDA]

Не хватило сил додумать основной цикл вчера.
Первоначальное решение (можно, скорее всего, упростить):

var
  s: string;
  a: array [1 .. 2000] of string[20];
  c: array ['a' .. 'z'] of integer;
  i, n, k, l, m: integer;
  d: char;
  b: array [1 .. 100] of integer;

begin
  readln(s);
  readln(n);
  for d := 'a' to 'z' do
    c[d] := -1;
  for i := 1 to 100 do
    b[i] := -1;
  for i := 1 to n do
  begin
    readln(a[i]);
    if c[a[i][1]] = -1 then
      c[a[i][1]] := i;
  end;
  k := 1;
  l := length(s);
  m := 1;
  while k <= l do
  begin
    if b[m] = -1 then
      b[m] := c[s[k]]
    else
      inc(b[m]);
    if (b[m] = -1) or (a[b[m]][1] <> s[k]) then
    begin
      b[m] := -1;
      dec(m);
      dec(k, length(a[b[m]]));
    end
    else if copy(s, k, length(a[b[m]])) = a[b[m]] then
    begin
      inc(k, length(a[b[m]]));
      inc(m);
    end;
  end;
  for i := 1 to m do
    write(a[b[i]], ' ');
end.

Проходит все 12 тестов (максимум 0.372 секунды - ограничение 1 секунда).
Решение запутанное, так как вместо рекурсивной функции был реализован стек через массив. Уровень "неприятности" можно оценить хотя бы по уровню косвенности (конструкции вида c[a[i][1]] или a[b[m]]).

[Poma][a]

Добрый день..
Вот я что-то накропал.. Проходит только 2 теста.. в остальных или неправильный ответ или "Ошибка во время выполнения программы"..
Свой косяк я найти не могу.. мои тесты проходят.. прошу помощь, заранее спасибо!

var
	txt : string;
	dict, p : array [1..20000] of string;
	n, cnt : Integer;



procedure Init ;
var
	i : Integer;

begin
	ReadLn (txt);
	ReadLn (n);
	cnt := 1;

    for i := 1 to 2000 do
                p[i] := #13;

	for i := 1 to n do
		ReadLn (dict[i])
end;


function DeleteSpace (s : string) : string;
var
	i : Integer;
	r : string;

begin
	r := '';

	for i := 1 to Length(s) do
		if (s[i] <> ' ') and (s[i] <> #13) then
			r := r +s[i];

	DeleteSpace := r
end;

procedure Solution ;
var
	t, s : string;
	i, j, k, count : Integer;
	a : array [1..1000] of string;


begin
	t := '';
        i := 1;
        while i <= Length(txt) do begin
			count := 0;
			t := txt[i];
                for j := 1 to n do
                	if t = dict[j][1] then begin
		                Inc (count);
                        a[count] := dict[j];
                        end;


			if count = 1 then begin
                for j := 1 to cnt do
                        if (a[1][1] <> DeleteSpace(p[j])[i]) or
                        (Length(DeleteSpace(p[j])) < Length(a[1])+i-2)
                        or (Length(DeleteSpace(p[j])) = 0)then
							p[j] := p[j] + ' ' + a[1];

                        Inc (i, Length(a[1])-1);

			end;

			if count > 1 then begin
				for  k := 1 to cnt do
					for j := 1 to count do
						p[k*count+j] := p[j] + ' ';

				cnt := count*cnt;

				for k := 1 to cnt do
                    if a[k div count+1][1] <> DeleteSpace(p[k])[i-1] then begin
                    p[k] := p[k] + a[k div count+1]
                end;
			end;

			Inc (i)
        end;

end;


procedure PrintSolution;
var
	i, max : Integer;
begin
        max := 1;
        while DeleteSpace(p[max]) <> txt do
                Inc (max);

        for i := max+1 to cnt do
            if (Length(DeleteSpace(p[max])) < Length(DeleteSpace(p[i])))
                and (DeleteSpace(p[i]) = txt)  then
                max := i;

        i := 1;
        while p[max][i] in [' ', #13] do
            Inc (i);

        for i := i to Length(p[max]) do
            Write (p[max][i]);

end;

begin
	Init;
	Solution;
	PrintSolution
end.

Пока нашел пару косяков.. исправляю..

[BDA]

Пока прочел не весь Ваш код и не "въехал" в принцип. Замечания по ходу чтения:
Легко могу переполнить массив a;
Не вижу пока смысла в размере на 20000 массива dict.

Интересно, вернется ли ТС за решением, или тема перетечёт в обсуждение различных решений задачки.

[Poma][a]

Не вижу пока смысла в размере на 20000 массива dict.

Проблема в копирке массива p при варианте, где кол-во подходящих элементов > 1.
А раз отдельно вынести dict я уже и забыл.. Спасибо!

Легко могу переполнить массив a;

Да.. Пожалуй Вы правы.. Нужно добить его до 2000.

Пока прочел не весь Ваш код и не "въехал" в принцип.

Он достаточно прост, я из-за нехватки времени записал его не в очень удобоваримом виде.. ну ниче.. вся ночь впереди, еще успею добить

Интересно, вернется ли ТС за решением, или тема перетечёт в обсуждение различных решений задачки.

А на кой ляд Вам ТС? Система для проверки есть, что ж еще ждать?

[Poma][a]

Вот я чуть-чуть подправил..

var
	txt : string;
	p : array [1..20000] of string;
	dict : array [1..2000] of string;
	n, cnt : Integer;

procedure Init ;
var
	i : Integer;

begin
	ReadLn (txt);
	ReadLn (n);
	cnt := 1;

    for i := 1 to 2000 do
                p[i] := #13;

	for i := 1 to n do
		ReadLn (dict[i])
end;


function DeleteSpace (s : string) : string;
var
	i : Integer;
	r : string;

begin
	r := '';

	for i := 1 to Length(s) do
		if (s[i] <> ' ') and (s[i] <> #13) then
			r := r +s[i];

	DeleteSpace := r
end;

procedure Solution ;
var
	t, s : string;
	i, j, k, count : Integer;
	a : array [1..2000] of string;


begin
	t := '';
        i := 1;
        while i <= Length(txt) do begin
			count := 0;
			t := txt[i];
                for j := 1 to n do
                	if t = dict[j][1] then begin
		                Inc (count);
                        a[count] := dict[j];
                        end;


			if count = 1 then begin
                for j := 1 to cnt do
                        if (a[1][1] <> DeleteSpace(p[j])[i]) or
                        (Length(DeleteSpace(p[j])) < Length(a[1])+i-2)
                        or (Length(DeleteSpace(p[j])) = 0)then
							p[j] := p[j] + ' ' + a[1];

                        Inc (i, Length(a[1])-1);

			end;

			if count > 1 then begin
				for  k := 0 to count-1 do
					for j := 1 to cnt do
                        p[k*cnt+j] := p[j] + ' ';
				cnt := count*cnt;
                for k := 1 to count do
                    for j := 1 to cnt do
                    if a[k][1] <> DeleteSpace(p[j])[i] then
                        p[j] := p[j] + a[k];
{			for k := 1 to cnt do
                    if a[(k div count)+1][1] <> DeleteSpace(p[k])[i-1] then begin
                    p[k] := p[k] + a[k div count+1]
                end;
 }		end;

			Inc (i)
        end;

end;


procedure PrintSolution;
var
	i, max : Integer;
begin
        max := 1;
        while (DeleteSpace(p[max]) <> txt) and (max < cnt) do
                Inc (max);

        for i := max+1 to cnt do
            if (Length(DeleteSpace(p[max])) < Length(DeleteSpace(p[i])))
                and (DeleteSpace(p[i]) = txt)  then
                max := i;

        i := 1;
        while p[max][i] in [' ', #13] do
            Inc (i);

        for i := i to Length(p[max]) do
            Write (p[max][i]);

end;

begin
	Init;
	Solution;
	PrintSolution
end.

Всё осталось точно также