\ Это самый простой текстовый редактор, написанный на Форте
\ Пока, далеко не полный
\ Forth editor for texts
\ (c) Ivan Mak aka WingLion
\ Временное название - LionEdit или LE
\ 12.06.2003

VARIABLE SHL \ смещение экрана <-вправо-влево->
CREATE TABLE-ADR 200 ALLOT \ пока до 128-х строк
15 CONSTANT V-S \ вертикальный размер окна
4C CONSTANT H-S \ горизонтальный размер окна
70 CONSTANT MCol \ общий цвет
30 CONSTANT ECol \ цвет редактируемой строки
96 CONSTANT MAX-Lines \ максимальное число строк
60 CONSTANT MAX-Len \ резерв длины строки
0202 CONSTANT SH-WIN \ Смещение положения окна редактирования
CREATE BUFER 100 ALLOT
VARIABLE BEGIN-TXT \ начало текста
VARIABLE LEN-TXT \ длина текста
VARIABLE LINE-EDIT \ текущая строка
VARIABLE LINE-BEG \ начальная строка экрана
VARIABLE входной-файл

: DEL-CR-X  OVER C@  ( DUP) 0A = ( SWAP 0D = OR ) IF 1- SWAP 1+ SWAP THEN
\        2DUP + 1- C@ DUP 0D = SWAP 0A = OR IF 1- THEN
        DUP 0 < IF DROP 0 THEN
        DEL-CR -TRAILING
        ;

: в-следующую-строку
        DEL-CR-X
        LINE-BEG @ 2* TABLE-ADR + @
        SWAP DUP 0<> IF CMOVE ELSE DROP 2DROP THEN 1 LINE-BEG +! ;

: открыть-файл " lef.frt" OPEN-FILE ?I/O входной-файл ! ;

: закрыть-файл входной-файл @ CLOSE-FILE ?I/O ;

: copy-в-буфер LINE-BEG 0!
        открыть-файл
        BEGIN BUFER 80 входной-файл @ READ-LINE ?I/O
        DUP 0<> LINE-BEG @ MAX-Lines < AND WHILE
                BUFER SWAP в-следующую-строку
        REPEAT
        закрыть-файл ;

: LOAD-TEXT C000 3800 ERASE ;

: INIT-SPACE C000 BEGIN-TXT ! LEN-TXT 0!
        BEGIN-TXT @ TABLE-ADR
        MAX-Lines 0 DO 2DUP ! SWAP MAX-Len + SWAP 2 + LOOP 2DROP
        LINE-EDIT 0! LINE-BEG 0! LOAD-TEXT copy-в-буфер
        LINE-EDIT 0! LINE-BEG 0! ;

\ : TYPE-M OVER C@ IF 0D (WORD) TYPE 1+ THEN NIP SPACES ;
: TYPE-M TYPE ;

: LINE-ADR LINE-BEG @ + 2* TABLE-ADR + @ SHL @ + ;

: S-LINE >< SH-WIN + SET_POS ;

: OUT-LINE DUP S-LINE LINE-ADR H-S TYPE-M ;

: OUT-SCR GET_POS >R 0 SET_POS
        V-S 0 DO I OUT-LINE LOOP R> SET_POS ;

: PG_1 LINE-BEG 0! ; : PG_E MAX-Lines V-S - 1- LINE-BEG ! ;

: LB-TEST LINE-BEG @ 0 < IF LINE-BEG 0! THEN
          LINE-BEG @ MAX-Lines V-S - 1- SWAP OVER >
                        IF LINE-BEG ! ELSE DROP THEN ;

: UP-TXT  1 LINE-BEG +! LB-TEST ; : DN-TXT -1 LINE-BEG +! LB-TEST ;

: LE-TEST LINE-EDIT @ 0 < IF LINE-EDIT 0! DN-TXT THEN
        LINE-EDIT @ V-S 1- > IF V-S 1- LINE-EDIT ! UP-TXT THEN ;

: LN_DN 1 LINE-EDIT +! LE-TEST ; : LN_UP -1 LINE-EDIT +! LE-TEST ;
: PG_UP V-S 0 DO LN_UP LOOP ; : PG_DN V-S 0 DO LN_DN LOOP ;

: TEST-S GET_POS >R 1740 SET_POS L-KEY @ H.
        LINE-BEG @ LINE-EDIT @ + . R> SET_POS ;

: TEST-XD L-KEY @ TEST-S
        DUP FF AND 0D = IF DROP LN_DN TRUE TEST-S EXIT THEN
        DUP 5000 = IF DROP LN_DN TRUE TEST-S EXIT THEN
        DUP 4800 = IF DROP LN_UP TRUE TEST-S EXIT THEN
        DUP 4900 = IF DROP PG_UP TRUE TEST-S EXIT THEN
        DUP 5100 = IF DROP PG_DN TRUE TEST-S EXIT THEN
        DUP 8400 = IF DROP PG_1 TRUE TEST-S EXIT THEN
        DUP 7600 = IF DROP PG_E TRUE TEST-S EXIT THEN
        DROP TEST-S FALSE ;

: EXPECT-LOOP' BEGIN TYPE-X W-CURS 0 ERROR ! DIR-KEY TEST-XD UNTIL ;
: EXPECT' POSN 0! 2DUP EDGE ! LINE ! EXPECT-LOOP' 2DROP ;

: PushCol COLOR @ R> SWAP >R >R COLOR ! ; : PopCol R> R> SWAP >R COLOR ! ;

: LINE-R ECol PushCol LINE-EDIT @ DUP S-LINE LINE-ADR H-S EXPECT' PopCol ;

VARIABLE ESC-Ret VARIABLE ESC-Ret2

: TEST1 INIT-SPACE ESC-Ret2 @ ESC-W !
        MCol PushCol 07 PushCol CLS PopCol
        DECIMAL BEGIN OUT-SCR LINE-R AGAIN PopCol ;

: FORTH-RET ESC-Ret @ ESC-W ! FORTH-SYSTEM ;

BL WORD TEST1 FIND DROP NAME> ESC-Ret !
BL WORD BY FIND DROP NAME> ESC-Ret2 !

07 COLOR !
MAKE TEST1
SAVE-SYSTEM le.com
BYE

FORTH.COM le.f

FORTH.COM FORTH.FRT

SAVE-SYSTEM FORTHF.COM

FORTHF.COM le.f