Переписать содержимое исходного текстового файла в файл-результат_1 - Turbo Pascal - Ответ 8579769

program task;
type
    list = ^chain;
    chain = record
        item: char;
        next: list
    end;
var
    t1, t2: text;
    l: list;
    k, spacecount: integer;
    c: char;
    flag: boolean;
    
function makelist( var t: text; var l: list; 
    var spacecount: integer; flag: boolean ): integer;
{ Формирую список из букв слова. Значение функции - количество
  букв в слове. В переменной spacecount -  количество пробелов
  перед словом. В переменной flag - false, если указатель установлен
  на начало строки и true иначе }
var
    q: list;
    count: integer;
begin
    count := 0;
    if flag then
        if c = ' ' then spacecount := spacecount + 1;
    if not eoln( t ) then begin
        read( t, c );
        while ( c = ' ' ) and not eoln( t ) do begin
            read( t,c );
            spacecount := spacecount + 1;
        end;
        if c = ' ' then spacecount := spacecount + 1;
        if c <> ' ' then begin
            count := 1;
            new( l );
            l^.item := c;
            l^.next := nil;
            q := l;
            while not eoln( t ) and ( c <> ' ' )  do begin
                read( t, c );
                if c <> ' ' then begin
                    count := count + 1;
                    new( q^.next );
                    q := q^.next;
                    q^.item := c;
                    q^.next := nil
                end;
            end;
        end;
        makelist := count;
    end
    else
        makelist := 0;
end;
 
procedure writelisttofile( var t: text; l: list; k: integer );
{ Переписываю слово в файл t2 согласно условию }
var
    i: integer;
begin
    i := 1;
    if k mod 2 = 1 then begin
        while i < ( k + 1 ) div 2 do begin
            write( t, l^.item );
            l := l^.next;
            i := i + 1;
        end;
        i := i + 1;
        l := l^.next;
        while i <= k do begin
            write( t, l^.item );
            l := l^.next;
            i := i + 1;
        end;
    end
    else 
        while i <= k do begin
            write( t, l^.item );
            l := l^.next;
            i := i + 1;
        end;
end;
 
procedure writespace( var t: text; n: integer );
begin
    while n <> 0 do begin
        write( t, ' ' );
        n := n - 1;
    end;
end;
 
procedure deletelist( var l: list );
begin
    if l <> nil then begin
        deletelist( l^.next );
        dispose( l );
        l := nil;
    end;
end;
    
begin
assign( t1, 'u: t1.txt' );
assign( t2, 'u: t2.txt' );
reset( t1 );
rewrite( t2 );
l := nil;
spacecount := 0;
flag := false;
while not eof( t1 ) do begin
    k := makelist( t1, l, spacecount, flag );
    flag := true;
    writespace( t2, spacecount );
    writelisttofile( t2, l, k );
    deletelist( l );
    if eoln( t1 ) then begin
        flag := false;
        readln( t1 );
        writeln( t2 );
    end;
    spacecount := 0;
end;
writeln( 'Complete' );
close( t1 );
close( t2 );
end.