Талеи, тавлеи на форте ч 1.001

[viktor_ra]

Для начала выкладываю определения лок.слов
: LOC-VAR{ ( A -- ) 4 * ALLOT ;
: }LOC-VAR  (А -- )  -4 * ALLOT ;
: L-VAR ( A -- ADR ) HERE SWAP 4 * - ;

Слова выше  теперь просто выделяют и вычищают память.

: D-VAR 4 * HERE + ;

Это слово, по сути, даёт ненадёжный адрес, в который можно что-то записать. Локальным не является, в принципе. Минус защита, но можно использовать как переменную для двух слов, что не рекомендуется. Занесённое значение считается мусором  . Поэтому не рекомендуется исп. данное слово после локальных, если, конечно, оно вам уже не нужно.

Выкладываю изменения в коде тавлей

: 4DUP ( ДУБЛИРОВАТЬ ЧЕТЫРЕ ВЕРХНИХ ЭЛЕМЕНТ СТЕКА ) 3 PICK  3 PICK 3 PICK 3 PICK ;

: XOD-PEREME ( ОТКУДА КУДА -- )
                >R DUP POLE @ R> POLE !
                          0 SWAP POLE !  ;

: XOD-EMU ( A B C D - A*11+B C*11+D ) >R >R SWAP 11 * +
                R> R> SWAP 11 * + ;

: XOD-PROVV 4DUP 6 LOC-VAR{    \ проверка, чтоб по ходили только по горизонтали и вертикали
   1 L-VAR ! 2 L-VAR ! 3 L-VAR ! 4 L-VAR !
   0 5 L-VAR ! 0 6 L-VAR !
   1 L-VAR @ 3 L-VAR @ = IF 1 5 L-VAR ! THEN
   2 L-VAR @ 4 L-VAR @ = IF 1 6 L-VAR ! THEN
   5 L-VAR @ 6 L-VAR @ XOR  6 }LOC-VAR  \ слово XOR сравнивает два значения
\ если 1 1 то результат 0, если 1 0 или 0 1, то 1
;

: PRIG-VERT  \ вывод клеток в стек по вертикали

2 LOC-VAR{
      2DUP MIN 1 L-VAR !
      2DUP MAX 2 L-VAR !  
      2 L-VAR @ 1+ 1 L-VAR @ DO I POLE @ 11 +LOOP
      2 }LOC-VAR
       ;

: PRIG-GOR     \ вывод клеток в стек по горизонтали

2 LOC-VAR{
   2DUP MIN 1 L-VAR !
   2DUP MAX 2 L-VAR !
   2 L-VAR @ 1+ 1 L-VAR @ DO I POLE @ LOOP

2 }LOC-VAR
       ;

: perePRIG ( OTKYDA KYDA  -- )

2DUP - ABS  10 > IF PRIG-VERT ELSE PRIG-GOR THEN
   0 1 D-VAR !
 \ код ниже проверяет пустотность полученных клеток, если пустотны все кроме одной хорошо
 \ , нет в противном случае. Т.к. исп. слово по получению глубины стека определение м.б.  ненадёжным
  DEPTH 2 - 0 DO 0 > IF 1 D-VAR @ 1+ 1 D-VAR ! THEN LOOP
  1 D-VAR @ 1 > IF 0 ELSE 1 THEN
           ;

: xod XOD-PROVV 0 = IF ." NE-A provv " 2DROP 2DROP EXIT THEN
       XOD-EMU
       perePRIG 0 = IF ." NE-A prig " 2DROP EXIT THEN XOD-PEREME
       VIVOD-POLE ;