Постановка задачи.

Написать слово, преобразующее входную строку в текст, выровненный
по  ширине  экрана, таким образом, чтобы каждая новая строка на экране
отделялась  от  предыдущей  символами  CRLF  (0x0D 0x0A), а промежутки
между   словами   были  заполнены  необходимым  количеством  пробелов,
достаточным  для  выравнивания  правого  края  строки в одну линию, не
пересекающую  позицию  p.  Первый  символ  первого слова строки обязан
находиться  в  начале  строки,  а количество дополнительных пробелов в
строке  не  должно  превышать  по длинне, первое слово перенесенное на
следующую  строку.  Разрывать слова на части нельзя - можно переносить
на  следующую  строку  целиком,  либо,  если  слово  оказывается  шире
требуемой  ширины  строки,  оставлять  в строке целиком. Каждый символ
занимает  один  байт  пространства  в  памяти.  Каждый символ, включая
пробельные   и   знаки   препинания,   имеет   одинаковую  ширину  при
отображении.   Получаемая   на   входе   строка   может   состоять  из
произвольного  количества  слов,  отделенных  пробельными  символами и
символами  переноса  на  следующую  строку. Знаки препинания считаются
частью слов.

\ на входе слово получает строку в виде адрес + длинна
\ и требуемую ширину строк в символах.
\ на выходе должен быть получен адрес области в памяти, хранящей
\ полученный набор строк.
: format-text ( asc # p --> asc # )

              ;

\ gl0 SPF4.18
lib/ext/locals.f
\ выбрать блок не пробелов
: >sp ( adr u -- adr u1 )
   OVER
   BEGIN
   1+ SWAP 1- SWAP DUP C@ 32 = >R SWAP DUP 0= >R SWAP R> R> +
   UNTIL
   NIP OVER -
;
\ выбрать блок пробелов,   
: >nsp ( adr u -- adr u1 )
   OVER  \ u adr   
   BEGIN
   1+ SWAP 1- SWAP DUP C@ 32 <> >R SWAP DUP 0= >R SWAP R> R> +
   UNTIL
   NIP OVER -
;

\ из adr u выбрать первое слово или блок пробелов
: getfwrd ( adr u -- adr u1 )
   OVER C@ 32 =
   IF \ если первый символ пробел ищем блок пробелов
   >nsp
   ELSE \ если первый символ не пробел ищем блок не пробелов
   >sp
   THEN
;


\ перебрать adr u по строкам длиной p  с заполнением хвостов
: format-text ( adr u p -- adr u )
   { adr u p \ p1 }
   p -> p1                                \ длина свободной строки
   adr u                                  \ строка со словами
   BEGIN
   2DUP getfwrd 2DUP                      \ выберем первое слово или блок пробелов из массива
   DUP p1 >
     IF
     p1                                   \ если он не умещаеться в остатке строки
     0 ?DO S" -" TYPE LOOP \  SPACES      \ выводит тире для наглядности
     OVER C@ 32 = IF 2DROP S" " THEN      \ подстановка для вывода слова нулевой длинны если вывод на следующую строку начнется с блока пробелов
     CR DUP p SWAP - -> p1
     ELSE                                 \ если он умещаеться в остатке строки
     DUP p1 SWAP - -> p1
     THEN
   TYPE                                   \ вывести слово
   NIP >R R@ - SWAP R> + SWAP DUP 0=      \ проверить не кончился ли массив
   UNTIL
   p1
   0 ?DO S" -" TYPE LOOP \  SPACES        \ вывести при необходимости дополнение последней строки ( тире для наглядности)
   2DROP                                  \ очистить стек
   adr u
;

\ тест
S" 11111    22222 33333 11111 22222 33333 11111 22222 33333 11111 22222 33333 11111 22222 33333 11111 22222 33333 11111 22222   33333 11111 22222 33333 11111 22222 33333 11111 22222 33333 11111 22222 33333" 15 format-text

S" A large flying craft moved swiftly across the surface of an astoundingly beautiful sea." 15 fl2cns

A large flying
craft moved ---
swiftly across
the surface of
an astoundingly
beautiful sea.

\ Для запуска нужен дистрибутив SPF:
\ http://sourceforge.net/project/showfiles.php?group_id=17919

\ И апрельское обновление:
\ http://sourceforge.net/project/shownotes.php?release_id=497972&group_id=17919

REQUIRE /TEST ~profit/lib/testing.f
REQUIRE PRO ~profit/lib/bac4th.f
REQUIRE split ~profit/lib/bac4th-str.f
REQUIRE arr{ ~profit/lib/bac4th-sequence.f
REQUIRE LOCAL ~profit/lib/static.f
REQUIRE __ ~profit/lib/cellfield.f

: TAKE-THREE PRO *> <*> BSWAP <*> ROT BACK -ROT TRACKING <* CONT ;

0
__ wordsInLine
__ spacesBetween
__ lastSpace
CONSTANT elem

: format-text ( addr u w --> addr u \ <-- ) PRO
LOCAL charsInLine
DUP charsInLine !
LOCAL charsLeft
1+ charsLeft !

LOCAL wordsEntered
concat{ byRows split DUP STR@
charsLeft KEEP
wordsEntered 0!
arr{
*>
2DUP BL byChar split notEmpty \ DUP STR@ TYPE KEY DROP
DUP STR@ NIP DUP 1+ DROPB NEGATE charsLeft +!
\ charsLeft @ CR ." {" .
wordsEntered 1+!
charsLeft @ 0< ONTRUE BACK
1 wordsEntered !
charsInLine @ OVER - \ DUP . ." ^^"
charsLeft !        TRACKING

-1 wordsEntered +!

charsLeft @ OVER + 1+ wordsEntered @ 1- \ CR 2DUP . .
DUP IF
/MOD TUCK + SWAP \ ." :" 2DUP . .
ELSE 2DROP 0. THEN 2DROPB

wordsEntered @ DROPB
TAKE-THREE <*>
0. 2DROPB 1000000 DROPB TAKE-THREE <* \ добавляем elem в массив для не успевшей обработаться строки
}arr
\ 2DUP DUMP EXIT
DROP

LOCAL runner \ бегунок
runner !

concat{ BL byChar split notEmpty DUP STR@
*> <*>
-1 runner @ wordsInLine +! BACK
runner @ wordsInLine @
0= IF elem runner +! THEN  TRACKING

START{ PRO

runner @ wordsInLine @ 1 = IF
runner @ lastSpace @       ELSE
runner @ spacesBetween @   THEN

runner @ wordsInLine @ IF
-1 ?DO S"  " CONT LOOP ELSE
DROP BACK \ S" |" CONT
LT LTL @ CONT TRACKING THEN

}EMERGE <* }concat
DUP STR@ *> <*> LT LTL @ <* }concat DUP STR@ CONT ;

/TEST

$> S" A large flying craft moved swiftly across the surface of an astoundingly beautiful sea." 20 format-text CR TYPE

CR CR .( Input from 'in.txt'. Press any key) KEY DROP
$> S" in.txt" FILE 24 format-text TYPE

A  large  flying   craft
moved swiftly across the
surface      of       an
astoundingly   beautiful
sea.  From   mid-morning
onwards  it  plied  back
and   forth   in   great
widening  arcs,  and  at
last    attracted    the
attention of the   local
islanders,  a  peaceful,
sea-food  loving  people
who  gathered  on    the
beach  and  squinted  up
into the blinding   sun,
trying to see what   was
there.

Any        sophisticated
knowledgeable    person,
who had knocked   about,
seen a few things, would
probably  have  remarked
on how much the    craft
looked  like  a   filing
cabinet - a large    and
recently burgled  filing
cabinet  lying  on   its
back with its drawers in
the air and flying.

\ 05-05-2007 ~mOleg
\ Copyright [C] 2007 mOleg mininoleg@yahoo.com
\ решение задачи с конкурса открытого на форуме
\ (http://fforum.winglion.ru/viewtopic.php?p=7274#7274)

\ -- просто набор необходимых слов ------------------------------------------

\ слово откатывает >IN назад, на начало непонятого слова
: <back ( ASC # --> ) DROP TIB - >IN ! ;

\ добавить пробел в PAD - работает в пределах <# #>
: BLANK  ( --> ) BL HOLD ;

\ добавить указанное кол-во пробелов в PAD
: BLANKS ( n --> ) BEGIN DUP WHILE BLANK 1 - REPEAT DROP ;

\ добавить число к находящемуся на стеке возвратов
: R+ ( r: a d: b --> r: a+b ) 2R> -ROT + >R >R ;

\ вернуть TRUE если выполняется условие a < или = b, иначе FALSE
: >= ( a b --> flag ) < 0= ;

\ возвращает адрес и длинну строки, содержащей символ(ы) перевода строки
: nl ( --> asc # ) LT LTL @ ;

\ -- формирование результирующей строки -------------------------------------

        USER-VALUE buffer \ адрес временного буфера
        USER-VALUE out>   \ позиция с которой можно добавлять данные в буфер

\ добавление в буфер строки asc # к уже имеющимся
: >out ( asc # --> ) out> SWAP 2DUP + TO out> CMOVE ;

\ добавление строки с добавлением перевода строки
: save-result ( asc # --> ) >out nl >out ;

\ получить адрес и длинну собранной в буфере строки
: result> ( --> asc # ) buffer out> OVER - ;

\ освобождение буфера
: free-result ( --> ) buffer IF buffer FREE THROW 0 TO buffer THEN ;

\ инициализация буфера
: init-buffer ( # --> )
              free-result
              CELLS ALLOCATE THROW
              DUP TO buffer TO out> ;

\ -- собственно само решение ------------------------------------------------

        USER-VALUE regular  \ кол-во необходимых пробелов между словами
        USER-VALUE addons   \ кол-во дополнительных пробелов

\ добавить необходимое кол-во пробельных символов между слов
\ стратегии добавления пробелов могут быть различны.
: add-blanks ( --> )
             addons IF BLANK addons 1 - TO addons THEN
             regular BLANKS ;

\ сформировать строку из n строк, вставив между каждой строкой необходимое
\ количество пробельных символов.
: prepare ( [ asc # ] n str# p --> asc # )
          SWAP - OVER 1 = IF 2DROP EXIT THEN     \ если слово одно в строке

          OVER 1 - /MOD 1 + TO regular TO addons \ считаем необходимые пробелы

          >R <# BEGIN R@ WHILE   \ пока есть слова
                      HOLDS
                   -1 R+
                      R@ WHILE   \ если слово не последнее в строке
                      add-blanks
                  REPEAT
                THEN
          R@ R> #> ;

        USER words# \ счетчик слов для текущей строки

\ собрать слова для одной строки
: collect ( asc # p --> [ asc # ] n str# p )
          >R DUP >R  1 words# !
          BEGIN NextWord DUP WHILE  \ пока есть слова во входном потоке
                DUP 1 + 2R@ ROT +
                TUCK >= WHILE       \ пока длина суммы слов короче p
                RDROP >R
                words# 1+!
              REPEAT
                DROP <back          \ если взято лишнее слово - откат
                words# @ R> R> EXIT
          THEN
          2DROP words# @ R> DUP RDROP ;

\ форматировать поток, результат сохраняется в buffer
: format-stream ( p --> )
                >R BEGIN NextWord DUP WHILE
                      R@ collect prepare
                      save-result
                   REPEAT 2DROP
                RDROP ;

\ форматировать текст
: format-text ( asc # p --> asc # )
              SAVE-SOURCE N>R
               >R DUP init-buffer SOURCE!
               R> format-stream
              NR> RESTORE-SOURCE
              result> ;

\ EOF -- test sectin --------------------------------------------------------

: ~- ( n --> ) BEGIN DUP WHILE ." -" 1 - REPEAT DROP CR ;

\ это простой пример форматирования текста.
: ft S" simple sample string with the simple sample text." 20
     DUP ~- format-text TYPE
     S" inside string can contain_very_long words larger than 'p' " 13
     DUP ~- format-text TYPE
     ;

\ загрузить содержимое файла в буффер
: source ( FileName # --> addr # )
         R/O OPEN-FILE THROW >R
           R@ FILE-SIZE THROW DROP
              DUP ALLOCATE THROW
           TUCK SWAP R@ READ-FILE THROW
         R> CLOSE-FILE THROW ;

S" in.txt" source 60 format-text TYPE

CR
ft

\ gl0 SPF4.18
STARTLOG
lib/ext/locals.f

\ создать строку
: crtstr ( u -- adr ) 4 + ALLOCATE THROW DUP 0 SWAP ! ;
\ получить из adr -- adr u
: au ( adr -- adr u ) DUP 4 + SWAP @ ;

\ прибавить к строке
: str+ ( adr adr1 u1 -- adr )
   { adr adr1 u1 }
   adr DUP @ 4 + u1 + RESIZE THROW -> adr
   adr DUP @ 4 + + adr1 SWAP u1 MOVE adr @ u1 + adr ! adr ;

\ пропустить блок пробелов если они есть
: sp ( adr u -- adr1 u1 )
   SWAP BEGIN DUP C@ 32 = WHILE 1+ SWAP 1- SWAP REPEAT SWAP ;

\ из adr u выбрать первое слово игнорируя предшествующие пробелы длиной не более p
: getfwrd ( adr u p -- adr u1 )
   { p }
   sp DUP
   IF
     OVER
     BEGIN
     DUP C@ 32 = >R OVER 0= R> + p 1 < + 0= 
     WHILE
     1+ SWAP 1- SWAP p 1- -> p
     REPEAT
     NIP OVER -
   THEN ;

\ считать файл, adr u - имя файла adr1 - строка с текстом файла
: in_fl ( adr u -- adr1 )
   { \ hndl adr u }
   R/O OPEN-FILE  THROW DUP -> hndl FILE-SIZE THROW D>S -> u
   u 4 + ALLOCATE THROW DUP -> adr 4 + u hndl READ-FILE THROW DROP
   hndl CLOSE-FILE THROW u adr ! adr ;

\ перебрать строку установив между словами раздилитель 0 байт на слова не длиннее p
\ тоесть если попадеться слово длинее строки его порубят на части не привышающие p
: pr1 ( adr p -- adr )
   { p \ s }
   0 crtstr -> s
   s S"  " OVER 0 SWAP C! str+ -> s
   au BEGIN DUP WHILE
   2DUP p getfwrd 2DUP s ROT ROT str+ -> s \ CR TYPE 
   s S"  " OVER 0 SWAP C! str+ -> s
   2DUP + >R ROT SWAP - >R SWAP - R> SWAP - R> SWAP
   REPEAT 2DROP s
;

\  в строке adr u начиная от конца найти первыйнуль байт и оставить u1 длину строки от adr до последнего нуль байта
: pr2.1 ( adr u -- u1 )
   2DUP + NIP 1+
   BEGIN
   1- DUP C@ 0 = >R  2DUP = R> +
   UNTIL
   2DUP SWAP - NIP
;

\ получить количество нульбайт в строке adr u
: k0? ( adr u -- n )
   { \ n }
   0
   DO
   DUP I + C@ 0 = IF n 1+ -> n THEN
   LOOP DROP n ;

\ проиизвести форматную печать строки "adr u" c количеством груп пробелов "k"
\ и небходимым к распределению "n" пробелов
: fprint ( adr u k n -- )
   { adr u k n }
   n k + -> n k 1+ 0
   ?DO
   adr ASCIIZ> u MIN DUP >R TYPE
   n k 1 MAX / DUP n SWAP - -> n k 1- -> k SPACES
   R@ u SWAP - 1- -> u R> adr + 1+  -> adr
   LOOP
;
\ разложить входную строку по строкам
: pr2 ( adr p -- adr )
   { p \ s }
   0 crtstr -> s
   au 1-
   BEGIN
   1 - SWAP 1 + SWAP 0 MAX DUP
   WHILE
   DUP p >
     IF
     OVER p pr2.1
     ELSE
     2DUP
     THEN
     2DUP 2DUP DUP p SWAP - >R k0? R> 
     fprint CR
     NIP DUP ROT SWAP - SWAP ROT + SWAP
   REPEAT 2DROP
; 

\ TEST
80 VALUE fp \ ширина форматирования
S" in.txt" in_fl fp pr1 fp pr2 \EOF