\ REQUIRE стек ~profit/lib/stacks.f
REQUIRE U.R lib/include/core-ext.f
REQUIRE /TEST ~profit/lib/testing.f
REQUIRE ON lib/ext/onoff.f
REQUIRE буффер ~profit/lib/collectors.f

\ Автомат, принимающий поток символов. Слово "состояние" создаёт
\ одно состояние этого автомата с 256-ю выходами, где каждый выход
\ -- реакция на ввод в автомат символа. Действие может включать
\ в себя и переключение автомата в другое состояние. При входе
\ автомата в состояние может быть выполнено какое-нибудь действие ("на-входе:")
\ Чтобы запустить автомат, нужно установить-курсор, запустить какое-нибудь уже
\ созданное состояние, и только потом запускать словом "-символов-обработать" с
\ кол-вом символов на стеке (см. слово пустить-автомат в примере).
\ Идеально для реализации сканеров языков программирования.

\ Кроме того, определяется также слово "таблица" создающее только одно
\ состояние, но с произвольным кол-м выходов. Его удобно использовать
\ как замену CASE.

MODULE: chartable

USER-VALUE текущее-состояние
USER-VALUE граница-обработки

USER /символ

EXPORT

: символ ( -- c ) /символ @ ; \ выдаёт текущий символ

' NOOP CONSTANT отдыхают

DEFINITIONS

: кол-во-случаев ( -- n ) текущее-состояние CELL - @ ;

 \ n -- номер символа, addr -- соотв. ему ячейка в состоянии
: адрес-символа ( n -- addr ) CELLS текущее-состояние + ;

: -й-символ ( xt c -- ) адрес-символа ! ;
: установить-диапазон ( xt start end  -- ) 1+ SWAP DO DUP I -й-символ LOOP DROP ;
: все-символы ( xt -- ) 0 кол-во-случаев 1+ установить-диапазон ;
: очистить-все-символы ( -- )  отдыхают все-символы ;

0 VALUE последняя-реакция
0 VALUE предпоследняя-реакция
: :n ( "name" -- xt ) последняя-реакция TO предпоследняя-реакция  :NONAME  DUP TO последняя-реакция ;

EXPORT

: символ:  ( "z" -- ) :n CHAR -й-символ ;
: выполняет: ( n -- ) :n SWAP -й-символ ;
: asc: ( n -- ) выполняет: ;

: все: ( -- ) :n  все-символы ;
: диапазон: ( a b -- ) :n -ROT установить-диапазон ;

: пробел: ( -- ) :n BL -й-символ ;
: перевод-строки: ( -- ) отдыхают 13 -й-символ  :n 10 -й-символ ;
: разделители: ( -- ) :n 0 32 установить-диапазон ;
: цифры: ( -- ) [CHAR] 0 [CHAR] 9 диапазон: ;

: латинские-буквы: ( -- ) [CHAR] a [CHAR] z диапазон:
последняя-реакция [CHAR] A [CHAR] Z установить-диапазон ;

: all-asc: ( addr u -- ) :n -ROT OVER + SWAP DO DUP I C@ -й-символ LOOP DROP 	;

: символы: ( "ABCZ" -- ) ParseWord all-asc: ;

: тоже-самое ( -- ) предпоследняя-реакция COMPILE, ; IMMEDIATE

USER-VALUE сигнал

DEFINITIONS

: случаи ( число-случаев -- addr )
DUP , \ кол-во случаев
HERE TO текущее-состояние
1+ 0 DO отдыхают , LOOP
отдыхают , \ действие по-умолчанию, для случаев номера которых превышают кол-во состояний
;

: номер-случая-на-входе кол-во-случаев 1+ 1 + ;
: номер-случая-окончания-потока кол-во-случаев 1+ 2 + ;

EXPORT

: таблица ( число-случаев "имя" -- )
CREATE случаи
DOES> DUP @ 1+ ROT DUP TO сигнал MIN 1+ CELLS + @ EXECUTE ;

: состояние ( -- )
CREATE 256 случаи
отдыхают , \ действие на входе
отдыхают , \ реакция на окончание текстового потока
DOES> CELL+ TO текущее-состояние
номер-случая-на-входе адрес-символа @ EXECUTE ;

: на-входе: ( -- ) :n номер-случая-на-входе адрес-символа ! ;
: строка-кончилась: ( -- ) :n номер-случая-окончания-потока адрес-символа ! ;

VECT обработчик-каждого-символа

: код-для-символа ( -- xt ) символ кол-во-случаев 1+ MIN адрес-символа @ ;
: выполнить-символ   обработчик-каждого-символа код-для-символа EXECUTE ;

: выполнить-один-раз ( c -- ) /символ ! выполнить-символ ;
: закончить-обработку номер-случая-окончания-потока адрес-символа @ EXECUTE ;

: взять-из-таблицы ( "tbl -- )
очистить-все-символы
' >BODY DUP @ кол-во-случаев MIN 1+ CELLS
SWAP CELL+ SWAP текущее-состояние SWAP MOVE ;
\ Копирует реакции таблицы tbl в текущую
\ ВНИМАНИЕ: реакции "на-входе" и "окончание-входного-потока" не копируются!


5 таблица взять-букву ( -- c )
все: TRUE ABORT" Неверный размер символа!" ;
1 выполняет: C@ ;
2 выполняет: W@ ;
3 выполняет: @ 0xFFFFFF AND ;
4 выполняет: @ ;

VARIABLE курсор-в-тексте
: отсюда ( -- addr ) курсор-в-тексте @ ;
: пропустить-букву ( -- ) размер-символа курсор-в-тексте +! ;
: дать-букву ( -- c ) отсюда размер-символа взять-букву  пропустить-букву ;
: вернуть-букву ( -- ) размер-символа NEGATE курсор-в-тексте +! ;
: поставить-курсор ( адрес -- ) курсор-в-тексте ! ;

:NONAME CR символ EMIT ."  | " отсюда 10 U.R ."  | " текущее-состояние WordByAddr TYPE ; CONSTANT отладка-автомата
: включить-отладку-автомата  отладка-автомата TO обработчик-каждого-символа ;
: отключить-отладку-автомата  NOOP TO обработчик-каждого-символа ;

VARIABLE продолжать-обработку
: обрабатывать-до-сигнала ( -- )
продолжать-обработку ON
BEGIN продолжать-обработку @  WHILE
дать-букву выполнить-один-раз REPEAT
закончить-обработку ;

: остановить-автомат  ( -- ) отсюда 1- TO граница-обработки ;

: запустить ( end -- )
продолжать-обработку ON
TO граница-обработки          BEGIN
отсюда граница-обработки U<
продолжать-обработку @        AND WHILE
дать-букву выполнить-один-раз REPEAT
закончить-обработку ;

: -символов-обработать ( n -- ) ?DUP IF отсюда + запустить THEN ;
\ сколько нужно символов обработать начиная от текущего
\ кроме того, можно выходить из обработки ставя переменную в
\ продолжать-обработку OFF

\ синонимы на латинице
: state состояние ;
: symbol: символ: ;
: all: все: ;
: symbol символ ;
: rollback1 вернуть-букву ;
: on-enter: на-входе: ;
: current-state chartable::текущее-состояние ;
: current-state! chartable::TO текущее-состояние ;
: execute-one выполнить-один-раз ;
: state-table таблица ;
: range: диапазон: ;
: end-input: строка-кончилась: ;
: input-position отсюда ;
: signal сигнал ;

;MODULE

/TEST

REQUIRE ENUM ~nn/lib/enum.f

0
ENUM I`
ENUM II
ENUM III
ENUM IV-IX
DROP


9 таблица nine
все: IV-IX ; 
1 выполняет: I` ;
2 выполняет: II ;
3 выполняет: III ;


REQUIRE TESTCASES ~ygrek/lib/testcase.f

TESTCASES state-table correctness

(( 1 nine -> I` ))
(( 2 nine -> II ))
(( 3 nine -> III ))
(( 4 nine -> IV-IX ))
(( 100 nine -> IV-IX ))
(( 0 nine -> IV-IX ))

END-TESTCASES

0
ENUM unknown`
ENUM delimiter
ENUM space`
ENUM unknown
ENUM cr`
ENUM digit`
ENUM letter
DROP

256 таблица char-groups \ таблица обработчиков символов 
все: unknown` ; 
разделители: delimiter ;
пробел:  space` ;
перевод-строки: cr` ;
CHAR 0 CHAR 9 диапазон: digit` ;
CHAR a CHAR z диапазон: letter ;
CHAR A CHAR Z диапазон: тоже-самое ;
CHAR а CHAR я диапазон: тоже-самое ;
CHAR А CHAR Я диапазон: тоже-самое ;


TESTCASES ranges state-table correctness

(( CHAR 2 char-groups -> digit` ))
(( CHAR г char-groups -> letter ))
(( BL char-groups -> space` ))
(( 10000 char-groups -> unknown` ))
(( 10 char-groups -> cr` ))
\ (( 13 char-groups -> cr` )) \ пока неопределённая ситуация с перевод-строки -- одну или две реакции?
END-TESTCASES

VARIABLE счётчик

состояние не-считать 
состояние прибавлять 
состояние отнимать 

не-считать
символ: | не-считать ;
символ: +  прибавлять ;
символ: -  отнимать ; 

прибавлять
взять-из-таблицы не-считать \ копируем обработчики |+-
цифры:  счётчик 1+! ;

отнимать
взять-из-таблицы не-считать
цифры:  -1 счётчик +! ;

: пустить-автомат ( a u — ) 
1 TO размер-символа SWAP поставить-курсор 
не-считать -символов-обработать ;

\ включить-отладку-автомата
: подсчитать ( addr u -- n ) счётчик 0!  пустить-автомат  счётчик @ ;

TESTCASES fsa text scanner
(( S" 1234567890" подсчитать -> 0 )) \ =10*0 , изначально положение нейтральное, поэтому ничего не считается
(( S" 12+345|67890" подсчитать -> 3 )) \ =2*0+3*1+5*0
(( S" 12+345-67|90" подсчитать -> 1 )) \ =2*0+3*1+2*(-1)+2*0
(( S" +12+345-6|790" подсчитать -> 4 )) \ =2*1+3*1+1*(-1)+3*0
(( S" -12345+6790" подсчитать -> -1 )) \ =5*(-1)+4*1
END-TESTCASES

0
ENUM all
ENUM enter
ENUM end
ENUM lastVal
DROP

300 state-table corner-values
all: all ;
300 asc: lastVal ;

TESTCASES state-table corner cases
(( 200 corner-values -> all ))
(( 260 corner-values -> all ))
(( 300 corner-values -> lastVal ))
(( 1000 corner-values -> all ))
END-TESTCASES


state corner-fsa
on-enter: enter ;
end-input: end ;
all: all ;
255 asc: lastVal ;
256 asc: lastVal ;


TESTCASES fsa state corner cases
(( corner-fsa -> enter ))
(( 1 execute-one -> all ))
(( 1000 execute-one -> all ))
(( 255 execute-one -> lastVal ))
(( 256 execute-one -> lastVal ))
(( закончить-обработку -> end ))
END-TESTCASES

state template2copy
on-enter: enter ;
end-input: end ;
10 asc: 10 ;
255 asc: lastVal ;
256 asc: lastVal ;

состояние new-state взять-из-таблицы template2copy

TESTCASES fsa state copying
(( template2copy -> enter ))
(( 1 execute-one -> )) 
(( 10 execute-one -> 10 )) 
(( 255 execute-one -> lastVal ))
(( 256 execute-one -> lastVal ))
(( закончить-обработку -> end ))
(( new-state -> )) \ взять-из-таблицы не должен копировать реакции на-входе
(( 1 execute-one -> )) 
(( 10 execute-one -> 10 )) \ а обычные реакции -- должен
(( 255 execute-one -> lastVal ))
(( 256 execute-one -> lastVal ))
(( закончить-обработку -> )) \ реакции по окончанию потока копировать тоже нельзя
END-TESTCASES