CREATE SYMS 256 ALLOT

CREATE CODE  10 ALLOT
CREATE COUNT 10 ALLOT
CREATE Str 10 ALLOT
VARIABLE Всего
VARIABLE Длина
VARIABLE Вариантов

: StrLen \ ( addr --> len )
-1
BEGIN
  1+
  OVER OVER + C@ 0 =
UNTIL
SWAP DROP
;

: Очистить \ ( num addr --> )
SWAP OVER + SWAP DO
  0 I C!
LOOP
;

: Scan \ ( addr --> )
256 SYMS Очистить

Длина @ 0 DO
  DUP I + C@ SYMS + DUP C@ 1+ SWAP C!
LOOP
DROP
;

: Compress
0 Всего !
256 0 DO
  SYMS I + C@ IF
   I CODE Всего @ + C!
   SYMS I + C@ COUNT Всего @ + C!
   Всего @ 1+ Всего !
  THEN
LOOP
;

: ClearStr
10 0 DO
  0 Str I + C!
LOOP
;

: Print
Str PRINT CR
;

: Recurs \ (i глубина --> )
OVER
  CODE + C@
  OVER Str + C!

OVER COUNT + DUP C@ 1- SWAP C!

DUP Длина @ 1- = IF
  Print
  Вариантов @ 1+ Вариантов !
ELSE
  Всего @ 0 DO
   COUNT I + C@ IF
    I OVER 1+ Recurs
   THEN
  LOOP
THEN

OVER COUNT + DUP C@ 1+ SWAP C!

DROP DROP
;

: variants \ ( asc# --> n )
DUP StrLen Длина !

Длина @ 0 = IF 0
ELSE

  CLS 0 0 GOTOXY
  Scan Compress
  ClearStr
  0 Вариантов !
  Всего @ 0 DO
   I 0 Recurs
  LOOP

  Вариантов @
THEN
;

\ -----------------------------------------------------------------------------
\   Sequence Permutation Generator (C) Thu 24 Jan 14:24:23 2008
\ -----------------------------------------------------------------------------
: (cswap) ( a1 a2 --> )
    2DUP 2>R C@ SWAP C@ R> C! R> C!
;

\ -----------------------------------------------------------------------------
: (cnotfind) ( c s2 s1 --> t/f )
    1 -ROT ?DO OVER I C@ = IF 0 AND LEAVE THEN LOOP
    SWAP DROP
;

\ -----------------------------------------------------------------------------
: (variants) ( 0 s2 s1 str len --> count s2 s1' str len )

    2>R 2DUP - 1 < IF
        2>R 1+ 2R>
        ." > " 2R> 2DUP TYPE CR
        EXIT
    THEN

    DUP >R BEGIN 2DUP > WHILE

        DUP C@ OVER R@ (cnotfind) IF

            DUP R@ (cswap)

            R> 1+ SWAP 2R> ROT >R
            RECURSE
            R> -ROT 2>R SWAP 1- >R

            DUP R@ (cswap)
        THEN

    1+
    REPEAT DROP R> 2R>
;

\ -----------------------------------------------------------------------------
: variants ( asc # --> n )
    DUP 0 = IF 2DROP 0 EXIT THEN

    2DUP 2>R OVER + SWAP 0 -ROT 2R> (variants) 2DROP 2DROP
;

\ -----------------------------------------------------------------------------
S" aabcaaa" 2DUP variants .( ] variants: ) . TYPE CR CR
\ S" aabb" 2DUP variants .( ] variants: ) . TYPE CR
\ S" abababab" 2DUP variants .( ] variants: ) . TYPE CR
\ S" abc" 2DUP variants .( ] variants: ) . TYPE CR

: (cnotfind) ( c s2 s1 --> t/f ) 2DROP DROP 1 ;