REQUIRE {  lib\ext\locals.f
REQUIRE LIKE ~pinka\lib\like.f

: similar { aa uu \ [ 66 ] tb }
  CONTEXT @ @
  BEGIN
    DUP KEY? 0= AND
  WHILE
    DUP DUP >R COUNT [CHAR] * tb C! aa tb 1+ uu CMOVE [CHAR] * tb 1+ uu + C!
    tb uu 2+ LIKE IF R> ID. SPACE ELSE RDROP THEN
    CDR
  REPEAT DROP
;

\ EOF

: DROP2 NIP ;

STARTLOG
S" DROP" similar
ENDLOG

DROP2 RDROP DROP-EXC-HANDLER FDROP C-RDROP 2DROP DROP

\ File:         tools.spf
\ Author:       Nicholas Nemtsev
\ Date:         14.07.2002
\ Description:  Console tools
\ Usage: WORDS-LIKE piece-of-word
\        TASKS
\ Modified: 14.07.03
\   new words: TABS TASK-DELETE TDEL TADD

C" CRON-TOOLS" FIND NIP [IF] CRON-TOOLS [THEN]

MARKER CRON-TOOLS

: WORDS-LIKE ( -- )
  BL WORD COUNT 2>R
  CONTEXT @ @
  BEGIN
    ?DUP
  WHILE
    DUP COUNT 2R@ SEARCH NIP NIP
    IF
       DUP ID. SPACE
    THEN
    CDR
  REPEAT
  2R> 2DROP
  CR
;

?DUP D?UP DU?P DUP? ?UP(здесь "?"-не включает D)  D?P(без U) DU?(без P) UP DP DU

REQUIRE LIKE ~pinka\lib\like.f

0 VALUE a 0 VALUE u 0 VALUE sm 0 VALUE CA-WORD  CREATE am 65 ALLOT

: WORD. CA-WORD COUNT 2SWAP LIKE IF a u CA-WORD COUNT LIKE FALSE = IF CA-WORD ID. CR THEN THEN ;
: cut    u 0  DO 0 TO sm u 0 DO I J = IF 1 TO sm ELSE a I + C@ am I + sm - C! THEN LOOP am u 1- WORD. LOOP ;
: paste  u 0  DO 0 TO sm u 1+ 0 DO I J = IF [CHAR] ?  ELSE a I + C@ THEN am I + C! LOOP am u  WORD. LOOP ;
: insert u 1+ 0 DO 0 TO sm u 1+ 0 DO I J = IF [CHAR] ? 1 TO sm ELSE a I + sm - C@  THEN am I + C! LOOP am u 1+ WORD. LOOP ;

: similar TO u TO a CONTEXT @ @ BEGIN DUP WHILE DUP TO CA-WORD cut paste insert CDR REPEAT DROP ;

\ EOF
STARTLOG
S" DUP" similar
ENDLOG

ЛОГ

?DUP
DP
DUMP
FDUP
2DUP

\ 24-10-2007 ~mOleg
\ Copyright [C] 2007 mOleg mininoleg@yahoo.com
\ задачка с конкурса форума http://fforum.winglion.ru/index.php
\ http://fforum.winglion.ru/viewtopic.php?t=994

\ В верхнем контекстном словаре (CONTEXT) словаре найти все имена
\ слов, отличающиеся в одной букве (то есть похожие слова). Cлова
\ могут отличаться по длинне (на один символ) либо по содержимому
\ (в одной символьной позиции).

\ удалить с вершины стека указанное число параметров
\ если нужен контроль переопустошения стека раскоментировать содержимое скобок
: nDrop ( [ .. ] n --> ) 1 + CELLS SP@ + ( S0 @ MIN) SP! ;

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

\ сравнить два символа, находящихся по указанным адресам
\ вернуть указатели, смещенные на один символ вправо, и флаг
: (comp) ( 'asc1 'asc2 --> 'asc1++ 'asc2++ flag )
         2DUP 1 1 D+
         2SWAP C@ SWAP C@ = ;

\ сравнить две строки одинаковой длины,
\ выдать true, если различие не более, чем в один символ
: ?like ( asc1 asc2 # --> flag )
        >R BEGIN R@ WHILE
                 -1 R+
                 (comp) WHILE
             REPEAT
               BEGIN R@ WHILE   \ чтобы не возиться со счетчиком несовпадений
                     -1 R+
                     (comp) WHILE
                 REPEAT
                   RDROP 2DROP FALSE EXIT
               THEN
           THEN
        RDROP 2DROP TRUE ;

\ содержит ли длинная строка короткую как подстроку?
: ?substr ( asc1 asc2 #2 #1 --> flag )
          2DUP < IF -ROT ELSE -ROT 2SWAP THEN
          SEARCH NIP NIP ;

\ сравнить две строки на похожесть
: ?resemble ( asc1 # asc2 # --> flag )
            ROT 2DUP - DUP
            IF -1 2 WITHIN
               IF ?substr
                ELSE 4 nDrop FALSE
               THEN
             ELSE 2DROP ?like
            THEN ;

\ для заданного слова asc # найти все слова в верхнем контекстном
\ словаре, отличающиеся от заданного слова в одной символьной
\ позиции. Результат вывести на экран.
: similar ( asc # --> )
          CONTEXT @ @ >R
          BEGIN R@ WHILE
                2DUP R@ COUNT ?resemble
                IF R@ ID. SPACE THEN
            R> CDR >R
          REPEAT RDROP 2DROP ;

\ ----------------------------------------------------------------------
S" LOOP" similar \ пример использования

: alll ( --> )
       CONTEXT @ @ >R
       BEGIN R@ WHILE
             CR R@ COUNT similar
         R> CDR >R
       REPEAT RDROP ;

\ для получения всех подобий в словаре FORTH наберите к командной строке
\ spf4.exe smp.f alll BYE >smp.log

REQUIRE ?DEFINED       devel\~moleg\lib\util\ifdef.f
?DEFINED similar CR .( use: spd.bat sample.f |enter ) BYE

REQUIRE ResetProfiles  devel\~pinka\lib\Tools\profiler.f


: SIMILAR similar ;

: alll ( --> )
       CONTEXT @ @ >R
       BEGIN R@ WHILE
             CR R@ COUNT SIMILAR
         R> CDR >R
       REPEAT RDROP
       ;

: test  ResetProfiles alll alll alll CR CR .AllStatistic ;