ладно, мне лень ждать остальных, поэтому выкладываю свой вариант.
код написан для форка (
последней версии)
тут лежит нужная, но отсутствующая в форке библиотека spells.fts
<pre>
\ 09.06.2009 ~mOleg
\ Сopyright [C] 2009 mOleg
mininoleg@yahoo.com
\ поиск часто встречающихся последовательностей слов длиной от двух и более
os/ spells.fts
os/ file-add.fts
memory/ buff.fts
branch/ for-next.fts
vocs/ vocadd.fts
transl/ numbers.fts
2 VALUE chains# \ определяет сколько слов в цепочке должно быть(минимум)
2 VALUE replies# \ определяет сколько повторов надо искать
0 VALUE pbuff \ буфер для хранения просматриваемого текста
VARIABLE obtained \ количество полученных совпадений в текущем проходе
\ создать промежуточный буфер
: crBuff ( --> ) SOURCE NIP 2 * Buffer TO pbuff ;
\ создать словарь в хипе с именем asc # сделать его текущим и контекстным
: HVOC ( asc # --> ) ALSO HEAP DEFINITIONS DDUP SVOCAB EVAL-TOKEN DEFINITIONS ;
\ добавить новое слово с именем, определяемым asc # в текущем словаре
\ при выполнении имя должно возвращать количество повторов и собственно само имя
: new-word ( asc # --> xt )
CREATED 1 , LAST A@ DUP ID>ASC , ,
LINK>C
( # addr --> )
DOES> OVER IFNOT NIP CELL + D@ TYPE SPACE ;THEN
TUCK @ > IFNOT DUP @ N. SPACE CELL + D@ TYPE CR ;THEN DROP ;
\ добавить в текущий словарь определение с именем asc #
\ если слово уже есть в словаре, увеличить счетчик на 1
: +word ( asc # --> xt )
DDUP GET-CURRENT SEARCH-WORDLIST
IF 1 OVER CFL + +! NIP NIP ;THEN
new-word ;
\ преобразовать последовательность токенов в последовательность слов,
\ вывести в STDOUT
: ~chain ( addr # --> ) ADDR / FOR 0 OVER A@ EXECUTE ADDR + TILL DROP ;
\ создание слова с именем, содержащим последовательность слов
: new-chain ( addr # --> )
CREATED 1 , LAST A@ ID>ASC , ,
( # addr --> )
DOES> TUCK @ > IFNOT 1 obtained +!
DUP @ N. CELL + D@ ~chain CR
;THEN DROP ;
\
: +chain ( addr # --> )
DDUP GET-CURRENT SEARCH-WORDLIST \ addr # xt imm | 0
IF CFL + 1 SWAP +! DDROP ;THEN
new-chain ;
\ поиск одинаковых последовательностей
: search ( # --> )
DUP >L 0x0A {# S>D #S s" REPS" HOLDS #> HVOC \ --> #
pbuff Buffer> CELL / L@ - 1 + 0 MAX
FOR DUP L@ CELLS +chain
CELL +
TILL DROP
LDROP ;
\ вывести собранную статистику
: ~ws ( # --> u )
obtained OFF
>R GET-CURRENT LAST-NAME
BEGIN *WHILE
R@ OVER LINK>C EXECUTE
LINK>
REPEAT RDROP DROP
obtained @ ;
\ собрать статистику по количеству повторений и вывести ее на экран
: stat ( --> )
pbuff Buffer> NIP CELL / 1 -
chains# BEGIN OVER WHILE
DUP search replies# ~ws DUP WHILE
." \n\r всего найдено: " N.
." совпадений для последовательностей длиной в: " DUP N.
." слов\n\r"
UMOUNT \ освобождение памяти
-1 0 D+
REPEAT
THEN DROP
BYE ;
VOCABULARY RMCOMM \ словарь с коментариями
ALSO RMCOMM DEFINITIONS
ALIAS ( ( IMMEDIATE
ALIAS \ \ IMMEDIATE
\ сюда можно добавлять и другие варианты коментариев
RECENT
\ уборка встречаемых коментариев
: skip-comments ( asc # --> asc # TRUE | FALSE )
DDUP [ ALSO RMCOMM CONTEXT A@ LIT, ] SEARCH-WORDLIST
IF EXECUTE DDROP FALSE ;THEN TRUE ;
VECT -COMMENTS ' TRUE IS -COMMENTS
\ разобрать входной поток на слова
\ собрать статистику по частоте употребления слов (и самим словам)
:> transform ( --> )
crBuff
s" dict" HVOC
BEGIN NEXT-WORD *WHILE
-COMMENTS IF +word SP@ 4 pbuff >Buffer DDROP THEN
REPEAT DDROP ;
\ -- опции командной строки ----------------------------------------------------
\ взять десятичное число из входного потока, вернуть его численное значение
: getnum ( / number --> n )
NEXT-WORD 0x0A S>VAL IFNOT ERROR" Ожидается числовой параметр!" THEN
DROP ;
\ неопознанный ключ считаем именем входного файла
SECRET: NOTFOUND ( / asc # --> )
<BACK ParseFileName
DDUP ." \n\rОткрываю: " TYPE CR
['] FileSource CATCH IF ERROR" Неверное имя файла!" THEN
transform EvalSrcWith
;S
\ определить минимальное количество повторов
SPELL: -r ( / number --> ) getnum TO replies# ;S
\ определить минимальное количество слов в цепочке
SPELL: -c ( / number --> ) getnum TO chains# ;S
\ если не надо учитывать коментарии в тексте (Форт-коментарии!)
SPELL: -f ( --> ) ['] skip-comments IS -COMMENTS ;S
\ помощь по использованию программы
SPELL: /? ( --> )
." \n\rreplyes.exe [-f] [-c n] [-r n] filename [>outfile]"
." \n\rв квадратных скобках необязательные параметры."
." \n\r -f - говорит о том, что из текста надо убирать коментарии"
." \n\r -r n - используется с числовым параметром, определяющим"
." \n\r\t с какого количества повторов собирать статистику"
." \n\r -c n - используется с числовым параметром, определяющим"
." \n\r\t минимальное количество слов в искомой последовательности"
." \n\r outfile нужен, если результат работы хочется сохранить в файл"
BYE ;S
\ EOF -- дальше сохранение кода идет -------------------------------------------
SET-OPTIONS
' stat IS Completion \ задать действие по завершению обработки коммандной строки
s" Сохранение " TYPE
s" replyes.exe" DDUP TYPE SAVE
s" завершено успешно.\n\r" TYPE
BYE
</pre>
Вход
Регистрация
Благодарности
Forth-FAQ
Повторов то > 1
