program adjust (input, output); const DEBUGGING = true; MINLENGTH = 20; MAXLENGTH = 80; BLANK = ' '; type LineType = packed array [1..MAXLENGTH] of char; var line: LineType; desiredLength, actualLength: integer; procedure GetDesired (var desiredLength: integer); begin write ('How long do you want the line to be? '); readln (desiredLength); while not (desiredLength in [MINLENGTH..MAXLENGTH]) do begin writeln ('Sorry, that''s not a legal line length.'); write ('Please type a number between ', MINLENGTH:1, ' and ', MAXLENGTH:1, '.'); write ('How long do you want the line to be? '); readln (desiredLength); end; end; procedure GetLine (var line: LineType; var length: integer); var ch: char; k: integer; begin writeln ('Please type a line.'); length := 0; for k := 1 to MAXLENGTH do begin line [k] := BLANK; end; while not eoln do begin read (ch); length := length + 1; if length <= MAXLENGTH then begin line [length] := ch; end; end; readln; end; function CountGaps (line: LineType; length: integer): integer; var k, numWords: integer; prevWasBlank: boolean; begin numWords := 0; prevWasBlank := true; for k := 1 to length do begin if line [k] <> BLANK then begin if prevWasBlank then begin numWords := numWords + 1; end; prevWasBlank := false; end else begin prevWasBlank := true; end; end; CountGaps := numWords - 1; end; procedure CopyToNonBlank (line: LineType; var lineIndex: integer; var newLine: LineType; var newLineIndex: integer); begin while line [lineIndex] = BLANK do begin newLine [newLineIndex] := line [lineIndex]; newLineIndex := newLineIndex + 1; lineIndex := lineIndex + 1; end; end; procedure CopyToBlank (line: LineType; var lineIndex: integer; var newLine: LineType; var newLineIndex: integer); begin while line [lineIndex] <> BLANK do begin newLine [newLineIndex] := line [lineIndex]; newLineIndex := newLineIndex + 1; lineIndex := lineIndex + 1; end; end; procedure CopyRest (line: LineType; var lineIndex: integer; length: integer; var newLine: LineType; var newLineIndex: integer); begin while lineIndex <= length do begin newLine [newLineIndex] := line [lineIndex]; newLineIndex := newLineIndex + 1; lineIndex := lineIndex + 1; end; end; procedure IncreaseGap (var line: LineType; var lineIndex: integer; howMany: integer); var k: integer; begin for k := 1 to howMany do begin line [lineIndex] := BLANK; lineIndex := lineIndex + 1; end; end; procedure InsertBlanks (var line: LineType; var actualLength: integer; desiredLength: integer); var lineIndex, newLineIndex, k: integer; newLine: LineType; numBlanks, numGaps, numPerGap, numExtras: integer; begin lineIndex := 1; newLineIndex := 1; numBlanks := desiredLength - actualLength; numGaps := CountGaps (line, actualLength); if numGaps > 0 then begin numPerGap := numBlanks div numGaps; numExtras := numBlanks mod numGaps; for k := 1 to numGaps do begin CopyToNonBlank (line, lineIndex, newLine, newLineIndex); CopyToBlank (line, lineIndex, newLine, newLineIndex); IncreaseGap (newLine, newLineIndex, numPerGap); if k <= numExtras then begin IncreaseGap (newLine, newLineIndex, 1); end; end; CopyRest (line, lineIndex, actualLength, newLine, newLineIndex); line := newLine; actualLength := desiredLength; end; end; procedure PrintLine (line: LineType; length: integer); var k: integer; begin if DEBUGGING then begin for k := 1 to length do begin write (k mod 10: 1); end; end; writeln; for k := 1 to length do begin write (line [k]); end; writeln; end; begin GetDesired (desiredLength); GetLine (line, actualLength); while actualLength > 0 do begin if line [1] = BLANK then begin writeln ('Line shouldn''t start with a blank.'); end else if line [actualLength] = BLANK then begin writeln ('Line shouldn''t end with a blank.'); end else if actualLength < desiredLength then begin InsertBlanks (line, actualLength, desiredLength); end; PrintLine (line, actualLength); GetLine (line, actualLength); end; end.