ПОМОГИТЕ РЕБЯТА!!! НУЖНО РЕШИТЬ 3 ПРОГРАММЫ!!!

+ 0 -

Uborka

30 марта 2017 г., 0:18:14 (7 лет назад)

Универсальное решение на три задания, запись в файлы доделать самостоятельно

type
    string_array = array[1..200]of string;

var
    a: string_array;
    a_n, i, j: integer;
    s, firstlast, palindrom: string;
    p: boolean;

procedure GetWords(var sa: string_array; var sa_n: integer; s: string);
var
    i: integer; t: string;
begin
    s := s + ' ';
    for i := 1 to length(s) do
    begin
        if s[i] in [' ', ',', '.', ':', ';'] then begin
            if t <> '' then begin
                sa_n := sa_n + 1;
                sa[sa_n] := t;
                t := '';
            end;
        end
        else
            t := t + s[i];
    end;
end;

begin
    read(s);
    GetWords(a, a_n, s);
   
    for i := 1 to a_n do
    begin
        p := true;
        for j := 1 to length(a[i]) div 2 do
            p := p and (a[i][j] = a[i][length(a[i]) - j + 1]);
        if p then
            palindrom := palindrom + a[i] + ' ';
        if a[i][1] = a[i][length(a[i])] then
            firstlast := firstlast + a[i] + ' ';
    end;
   
    writeln(palindrom);
    writeln(firstlast);
end.