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

[Poma][a]

var
    txt : string;
    dict  : array [1..2000] of string;
    p, temp : 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, tc : 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-1]) 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 count do
				for j := 1 to cnt do
					p[k*cnt+j] := p[j];

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

            temp := p;
            tc := cnt;

            for j := 1 to cnt-1 do
                if (Pos(DeleteSpace(temp[j]), txt) = 0) or
                   (temp[j] = temp[j+1]) then begin
						temp[j] := '';
                        Dec (tc)
                end;

            for j := 1 to cnt do
                if temp[j] <> '' then
                    p[j] := temp[j];

            cnt := tc;

 			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;

var
        i : integer;

begin
        Init;
	Solution;
	PrintSolution
end.

И так..
Вот я снова чуть-чуть доработал код.. и.. ошибок больше нет, но проходит только 4 теста
Попытаюсь чуть-чуть объяснить соль моего решения.. :
<...>
Возьмем 1-ый символ строки, посмотрим кол-во слов на этот 1-ый символ и выпишем эти слова. (строка "1123", словарь "1", "11", "12", "3"). Получаем массив 1,11, 12.
Возьмем 2-ой символ и выпишем для него в том и только в том случаем, если его место не занято им самим же..
Возьмем i-тый символ. Если он один словаре, то просто прибавим его к каждой строке, иначе скопируем массив N раз (N = кол-во слов в словаре, начинающихся на эту букву) и заполним одну часть 1-ым вариант, 2-ую часть 2-ым.. N -ую часть - N-ыи вариантов..

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

[BDA]

Не было времени раньше написать.
После словесного объяснения стало понятнее, но все равно не могу понять до конца весь код. Могу отметить только огромное потребление памяти. Давайте-ка напишу словесное описание своего алгоритма:
В массиве c хранятся номера первых слов словаря, начинающихся на букву-индекс массива или -1. В массиве b окажутся номера слов, из которых состоит предложение. Сам разбор происходит так:
1) ищем следующее слово для массива b - если в массиве b еще не было слова, то берем букву по текущей позиции и по ней определяем номер первого слова, начинающегося на эту букву, а если уже были варианты слов, то переходим к следующему слову по словарю;
2) проверка - нашли ли слово по первой букве или перешли ли к слову, у которого первая буква не совпадает с текущей (перебрали все подходящие слова):

Если не нашли по первой букве или перешли к неподходящему слову, то нужно вернуться на шаг назад и попробовать подобрать другое слово на нем

Если нашли слово по первой букве или перешли к слову, у которого первая буква совпадает, то сравниваем само слово и кусок исходного предложения нужной длины (находится ли там это слово с текущей позиции) - если подошло слово, то передвигаем текущую позицию на длину слова, фиксируем номер слова в массиве b

[Poma][a]

Могу отметить только огромное потребление памяти.

Это есть.. Чуть-чуть эту огромность.. Но всё-таки она осталась.. Если бы найти тесты, которые я завалил, и подправить коэффициенты в индексах (думаю ошибка там, но навскидку всё верно), то по времени будет очень даже супер.. А вот память..

но все равно не могу понять до конца весь код.

Хорошо..
Думаю тебе не очень ясно только Solution..

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


begin
        i := 1;
        while i <= Length(txt) do begin // бежим по исходной строке
			count := 0; // кол-во слов на I-ую букву
			t := txt[i]; // 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 // если кол-во слов на итую букву = 1
                for j := 1 to cnt do // для каждого элемента массива P (где хранятся результаты)
                        if (a[1][1] <> DeleteSpace(p[j])[i-1]) or // если  1-ая буква подходящего слова ЕЩЕ НЕ стоит в строке
                        (Length(DeleteSpace(p[j])) < Length(a[1])+i-2) // или длина строки (результирующей) меньше длины всей строки до a[1] включительно
                        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 // если кол-во слов на итую букву больше 1
				for  k := 1 to count do // копируем массив count раз (где каунт - кол-во слов на итую букву)
					for j := 1 to cnt do
						p[k*cnt+j] := p[j];

                                for k := 1 to count do
                                        for j := 1 to cnt do
                                                if a[k][1] <> DeleteSpace(p[(k-1)*cnt+j])[i] then
                                                        p[(k-1)*cnt+j] := p[(k-1)*cnt+j] + ' ' + a[k]; // если на i-той позиции еще нет символа, то тогда вставляем
				cnt := count*cnt;
{ // удаляем лишку
                        temp := p;
                        tc := cnt;

                        for j := 1 to cnt-1 do
                                if (Pos(DeleteSpace(temp[j]), txt) = 0) or
                                   (temp[j] = temp[j+1]) then begin
                                        temp[j] := '';
                                        Dec (tc)
                                   end;

                        for j := 1 to cnt do
                                if temp[j] <> '' then
                                        p[j] := temp[j];

                        cnt := tc;

 }

{			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;

Давайте-ка напишу словесное описание своего алгоритма:

Спасибо, глянем

[BDA]

 if (a[1][1] <> DeleteSpace(p[j])[i-1]) or // если  1-ая буква подходящего слова ЕЩЕ НЕ стоит в строке
(Length(DeleteSpace(p[j])) < Length(a[1])+i-2) // или длина строки (результирующей) меньше длины всей строки до a[1] включительно
or (Length(DeleteSpace(p[j])) = 0)then // (или вообще строка пустая)
  p[j] := p[j] + ' ' + a[1];

Не понял, зачем нужны первые 2 проверки.
Никак не пойму до конца Ваш алгоритм.

Чуть подправил:

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

procedure Init;
var
  i: Integer;

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

  for i := 1 to 20000 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, tc: 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 - 1]) 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 count - 1 do
        for j := 1 to cnt do
          p[k * cnt + j] := p[j];

      for k := 1 to count do
        for j := 1 to cnt do
          //if a[k][1] <> DeleteSpace(p[(k - 1) * cnt + j])[i] then
            p[(k - 1) * cnt + j] := p[(k - 1) * cnt + j] + ' ' + a[k];

      cnt := count * cnt;
      
      temp := p;

      for j := 1 to cnt - 1 do
        if (Pos(DeleteSpace(temp[j]), txt) <> 1) or (temp[j] = temp[j + 1]) then
          temp[j] := '';
          
        if Pos(DeleteSpace(temp[cnt]), txt) <> 1 then
          temp[cnt] := '';

      tc := 0;

      for j := 1 to cnt do
        if temp[j] <> '' then
        begin
          Inc(tc);
          p[tc] := temp[j];
        end;

      cnt := tc;

      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);

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

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

end;

var
  i: Integer;

begin
  Init;
  Solution;
  PrintSolution

end.

6 тестов.

[Poma][a]

if (a[1][1] <> DeleteSpace(p[j])[i-1]) or // если 1-ая буква подходящего слова ЕЩЕ НЕ стоит в строке
(Length(DeleteSpace(p[j])) < Length(a[1])+i-2) // или длина строки (результирующей) меньше длины всей строки до a[1] включительно
or (Length(DeleteSpace(p[j])) = 0)then // (или вообще строка пустая)
p[j] := p[j] + ' ' + a[1];

Нужность первой строки - пример :

33221
3
332
221
33

Если не поставить строку, то получим такие вариант
4
332 332 221
33 332 221
332 33 221
33 33 221
Для продолжения нажмите любую клавишу . . . Как видите, среди них нет нужного..

//if a[k][1] <> DeleteSpace(p[(k - 1) * cnt + j])[i] then

Эта строка делает тоже самое, но шифка в том что без неё проходим 6 тестов, а с ней 4..
Хотя пример (см. выше) без этой строки программка заваливает..

(Length(DeleteSpace(p[j])) < Length(a[1])+i-2)

Здесь примерно такой же вариант, как 1-ая строка, но отличие в том, что строка еще не заполнена..

[BDA]

7 тестов:

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

procedure Init;
var
  i: Integer;
begin
  ReadLn(txt);
  ReadLn(n);
  cnt := 1;
  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] <> ' ' then
      r := r + s[i];
  DeleteSpace := r
end;

procedure Solution;
var
  t: char;
  i, j, k, count, tc: Integer;
  a: array [1 .. 2000] of string;
begin
  for i := 1 to 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 > 0 then
    begin
      setlength(p, cnt * count);
        
      for k := 1 to count - 1 do
        for j := 0 to cnt - 1 do
          if Length(DeleteSpace(p[j])) + 1 = i then
            p[k * cnt + j] := p[j] + a[k + 1] + ' ';

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

      cnt := count * cnt;

      for j := 0 to cnt - 2 do
        if (Pos(DeleteSpace(p[j]), txt) <> 1) or (p[j] = p[j + 1]) then
          p[j] := '';

      if Pos(DeleteSpace(p[cnt - 1]), txt) <> 1 then
        p[cnt - 1] := '';

      tc := 0;

      for j := 0 to cnt - 1 do
        if p[j] <> '' then
        begin
          p[tc] := p[j];
          Inc(tc);
        end;

      cnt := tc;
    end;
  end;
end;

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

begin
  Init;
  Solution;
  PrintSolution
end.

На остальных "ошибка выполнения" - похоже, упираемся в память.

[Poma][a]

7 тестов:

Супер..

На остальных "ошибка выполнения" - похоже, упираемся в память.

Возможно в память, но не везде.. Ваш вариант со статическим массивом проходил тесты 7, 9. В которых теперь ошибка..

[AnutaPr]

Всем спасибо за ответы) Разбираюсь в вариантах проги.

Сама попробовала так решить:

program slovar515;
var i,j,N: integer;
    s1,s3:string[100];
    Type
    slova=array [1..100] of string;
var    s2: slova;

begin
     readln(s1);
     readln(N);
     s3:='';
     j:=1;
     for i:=1 to N do readln(s2[i]);
        i:=1;
     for i:=1 to length(s1) do
         for j:=1 to N do
             if (copy(s1,i,length(s2[j])) = s2[j]) then
                begin
                     s3:=s3 + s2[j]+ ' ' ;
                     i:=i+length(s2[j])-1;
                end;
writeln(s3);
end.

Проходит моя программа только 4 теста, но хоть что то)

[BDA]

AnutaPr, у Вас пока не учитывается случай:
мамамылапол

при словаре:
мама
мыл
мыла
пол

разбор сделает "мама мыл", а "апол" не найдет в словаре

for i:=1 to length(s1) do
...
i:=i+length(s2[j])-1;

Так делать крайне не рекомендуется (изменять переменную цикла внутри цикла). Сделайте этот цикл через while, если хотите менять i внутри.

[Kix.IV]

Было немного лишнего времени, решил попробовать себя. Итог 7/12. Вот код:

program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  sstring = string[20];
  string2 = string[100];

var
  n: integer;
  str: string2;
  m: array of sstring;
  i, j: integer;

function recurse(s, s2: string2): string2;
var
  i: integer;
begin
  result := '';
  for i := 0 to n-1 do
    if copy(s, 1, length(m[i])) = m[i] then
    begin
      result := recurse(copy(s, length(m[i])+1, length(s)), s2 + m[i] + ' ');
      if length(result) > 1 then exit;
    end;
  if s = '' then result := s2;
end;


procedure swapp(var s1, s2: sstring);
var
  s3: string;
begin
  s3 := s1;
  s1 := s2;
  s2 := s3;
end;

begin
  readln(str, n);
  setlength(m, n);
  for i := 1 to n do readln(m[i-1]);

  for i := n-2 downto 0 do
    for j := 0 to i do
      if length(m[j]) > length(m[j + 1]) then swapp(m[j], m[j + 1]);

  str := recurse(str, '');
  writeln(str);
  readln;
end.

Тут ещё многое нужно изменить, может и пройдёт все 12 тестов.