Forth и другие саморасширяющиеся системы программирования Locations of visitors to this page
Текущее время: Сб дек 15, 2018 17:59

...
Google Search
Forth-FAQ Spy Grafic

Часовой пояс: UTC + 3 часа [ Летнее время ]




Начать новую тему Ответить на тему  [ Сообщений: 22 ]  На страницу 1, 2  След.
Автор Сообщение
 Заголовок сообщения: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Пт июл 02, 2010 22:49 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Кoгда у меня не получаются сложные большие алгоритмы, я по одной добавляю строки в простые игры, и вот ... за 2 месяца - вторая игрушка. Правда последние выходные и эту пятницу я посвятил только ей - увлёкся. (опять под Кварк)
Логический форт-лабиринт. Форт - потому, что присутствуют стеки - возвратов и данных. В общем - поле из квадратиков :) , на нем - цифры и логические или арифм. операции, выделен квадратик с вопросом, ходы - стрелками, при переходе на квадратик выполняется операция, которая на нем изображена, если число - оно кладётся на стек данных, если он не заполнен. Глубина обоих стеков - 8.


Со стека данных можно поместить число на стек возвратов и обратно PАGEUP PAGEDOWN.
Квадратики раскрашены - в шахматном или ином порядке и стек возвратов не может быть заполнен при смене цвета - только при переходе между одноцветными полями. Задача игры - достигнуть поля со смайликом :)) с пустым стеком возвратов и нулём на верху стека данных. Без нуля или с заполненным стеком возвратов не пустит
Понятно, что игрушка иммитирует форт в некоторой степени и подойдёт для обучения форту. Зрелый фортер может проверить, насколько виртуозно его стековое и логическое мышление. Лабиринт - потому, что решение не так просто: есть тупики и безвыходные ситуации.
Возможны 3 цвета квадратиков. При прохождении квадратика, он приобретает один из 3 оттенков серого цвета, повторно пройти квадратик невозможно, он недоступен, также при невозможном ходе подаётся сигнал.
Есть возврат хода. Из-за того, что в Кварке почему-то нет векторного слова backspaсe
это клавиши F10 F11 F12 - иммитируют широкий бекспейс. ходить обратно можно небесконечно, а до 3 раз - после первого раза на квадрате появляется крохотный залёный маркер, после второго - жёлтый, после третьего - красный "Всё - вперёд пройдёшь, а обратно не пропущу "

после загрузки нужно нажать клавишу F2 - "старт такой же игры (нулевой, если такой же не было)" стартовая игра 4х4
доступно пока ещё 2 игры ( 6х6 и 8х8) игры меняются циклически по F3

Стартовую позицию нужно придумывать, т.к. рандомизация создаёт или бессмысленно лёгкие или невыполнимые стартовые позиции (см. следующее сообщение)

Код:
" user32.dll"  LOADLIBRARY " MessageBeep" GETPROCADDRESS  VALUE MessageBeep_API
: ERROR_POS 16 MessageBeep_API 
API1 DROP ;
: END_SUCCESS 0 MessageBeep_API 
API1 DROP ;

-1 VALUE game?_value
: game? game?_value ;


HERE 32 CELLS ALLOT VALUE VSTACK
0 VALUE VSTACK_P
0 VALUE VSTACK_ERR

: >VS \ ( n --> )
\ поместить на стек
VSTACK_P 8 = IF 1 TO VSTACK_ERR ELSE VSTACK_P DUP 1 + TO VSTACK_P CELLS VSTACK + ! THEN
;

: VS> \ ( --> n )
\ снять со стека
VSTACK_P 0 = IF -1 TO VSTACK_ERR ELSE VSTACK_P 1 - DUP TO VSTACK_P CELLS VSTACK + @ THEN
;
: VSDEPTH VSTACK_P ;
: GET_VSTACK_ERR VSTACK_ERR 0 TO VSTACK_ERR ;

HERE 32 CELLS ALLOT VALUE VRSTACK
0 VALUE VRSTACK_P
0 VALUE VRSTACK_ERR

: >VRS \ ( n --> )
\ поместить на стек
VRSTACK_P 8 = IF 1 TO VRSTACK_ERR ELSE VRSTACK_P DUP 1 + TO VRSTACK_P CELLS VRSTACK + ! THEN
;

: VRS> \ ( --> n )
\ снять со стека
VRSTACK_P 0 = IF -1 TO VRSTACK_ERR ELSE VRSTACK_P 1 - DUP TO VRSTACK_P CELLS VRSTACK + @ THEN
;
: VRSDEPTH VRSTACK_P ;
: GET_VRSTACK_ERR VRSTACK_ERR 0 TO VRSTACK_ERR ;


\ 4 colors

10 10 250 RGB VALUE _RED      50 120 250 RGB VALUE _ORANGE
110 110 112 RGB VALUE _GRAY   250 250 10 RGB VALUE _LIGHTBLUE
10 250 250 RGB VALUE _YELLOW   70 250 70 RGB VALUE _GREEN
255 255 255 RGB VALUE _WHITE   40 40 40 RGB VALUE NEAR_BLACK
255 0 255 RGB VALUE _MAGENTA    173 171 172 RGB VALUE _LIGHTGRAY
218 218 211 RGB VALUE _VERYLIGHTGRAY2    218 218 211 RGB VALUE _VERYLIGHTGRAY
0 VALUE _BLACK


1 VALUE NUMBER_GREEN
2 VALUE NUMBER_YELLOW
3 VALUE NUMBER_RED
4 VALUE NUMBER_LIGHTBLUE
5 VALUE NUMBER_ORANGE
6 VALUE NUMBER_MAGENTA
7 VALUE NUMBER__VERYLIGHTGRAY2
8 VALUE NUMBER_GRAY
9 VALUE NUMBER_LIGHTGRAY
10 VALUE NUMBER_VERYLIGHTGRAY
11 VALUE NUMBER_WHITE
12 VALUE NUMBER_BLACK


: color... \ ( number --> color )
CASE
0 OF _BLACK ENDOF
NUMBER_GREEN OF GREEN ENDOF
NUMBER_RED OF _RED ENDOF
NUMBER_LIGHTBLUE OF _LIGHTBLUE ENDOF
NUMBER_YELLOW OF _YELLOW ENDOF
NUMBER_GRAY OF _GRAY ENDOF
NUMBER_LIGHTGRAY OF _LIGHTGRAY ENDOF
NUMBER_WHITE OF _WHITE ENDOF
NUMBER_BLACK OF NEAR_BLACK ENDOF
NUMBER_ORANGE OF _ORANGE ENDOF
NUMBER_MAGENTA OF _MAGENTA ENDOF
NUMBER__VERYLIGHTGRAY2 OF _VERYLIGHTGRAY ENDOF
NUMBER_VERYLIGHTGRAY OF _VERYLIGHTGRAY ENDOF
ENDCASE
;
   

100 VALUE coord_start_X   \ coordinates of game-board
170 VALUE coord_start_Y


0 VALUE potential_direction

4 VALUE board_size.tiny    
6 VALUE board_size.small    
8 VALUE board_size.medium    
10 VALUE board_size.large    
12 VALUE board_size.huge    
board_size.tiny VALUE board_size

board_size  1 - VALUE last_selected_y
0 VALUE last_selected_x   

48 VALUE sq_size_   \ size of square

0 VALUE stack_X
0 VALUE ret_X

: stack_X()
coord_start_X sq_size_ board_size * 30 + + TO stack_X
   ;

: ret_X()
coord_start_X sq_size_ board_size * 130 + + TO ret_X
   ;   
   
stack_X() ret_X()


: show_stack _YELLOW SETCOLOR
   stack_X coord_start_Y TEXTXY " DATA STACK"
   PRINT
   9 1 DO
   stack_X I 20 * 34 +  coord_start_Y +
   OVER OVER TEXTXY  "             " PRINT TEXTXY
   I 1 -
   DUP VSDEPTH < 
       IF CELLS VSTACK + @ .
      ELSE   DROP
      THEN
   LOOP
   
   GREEN SETCOLOR
   ret_X coord_start_Y TEXTXY " RETURN STACK"
   PRINT
   9 1 DO
   ret_X I 20 * 34 +  coord_start_Y + 
   OVER OVER TEXTXY  "             " PRINT TEXTXY 
   I 1 -
   DUP VRSDEPTH < 
       IF CELLS VRSTACK + @ .
      ELSE DROP
      THEN
   LOOP
   
   ;   

: VS_ERR_PRINT
   _RED SETCOLOR 0 > IF
   stack_X coord_start_Y 194 +  TEXTXY "  OVERFLOW   " PRINT
   ELSE
   stack_X coord_start_Y 54 +  TEXTXY "  UNDERFLOW  " PRINT
   THEN ;

: VRS_ERR_PRINT
   _RED SETCOLOR 0 > IF
   ret_X coord_start_Y 194 +  TEXTXY "  OVERFLOW   " PRINT
   ELSE
   ret_X coord_start_Y 54 +  TEXTXY "  UNDERFLOW  " PRINT
   THEN ;
   
: TO_RET
   VS> GET_VSTACK_ERR
   DUP
   IF ERROR_POS VS_ERR_PRINT
   ELSE
   DROP >VRS
   GET_VRSTACK_ERR
      DUP
      IF ERROR_POS VRS_ERR_PRINT >VS
      ELSE DROP show_stack
      THEN
   THEN   
   ;
   ' TO_RET TO K_PGUP
: FROM_RET
   VRS> GET_VRSTACK_ERR
   DUP
   IF ERROR_POS VRS_ERR_PRINT
   ELSE
   DROP >VS
   GET_VSTACK_ERR
      DUP
      IF ERROR_POS VS_ERR_PRINT >VRS
      ELSE DROP show_stack
      THEN
   THEN   
   ;
   ' FROM_RET TO K_PGDOWN   


0   VALUE  square_tick.tickness
0   VALUE  square_tick.size
0   VALUE  square_tick.color

: square_tick       \ ( X Y color size tick --> )
   TO square_tick.tickness TO square_tick.size
   TO square_tick.color

\ (presently: X Y  )
   OVER OVER  square_tick.size +
   square_tick.tickness 0 DO OVER OVER  I -  square_tick.size square_tick.color HLINE LOOP
   DROP square_tick.size +  OVER
   square_tick.tickness 0 DO OVER  I - OVER square_tick.size square_tick.color VLINE LOOP
   DROP DROP
   square_tick.tickness 0 DO OVER  I + OVER square_tick.size square_tick.color VLINE LOOP
   square_tick.tickness 0 DO OVER  OVER I + square_tick.size square_tick.color HLINE LOOP
   DROP DROP    
   ;
   

CREATE ARR 32 CELLS ALLOT

: elementes... SWAP CELLS ARR + ! ;

1 1 VALUE    _?      "  ?"   elementes...
2 2 VALUE    _NOT  " NOT"   elementes...
4 4 VALUE    _INVerse  " INV"   elementes...
5 5 VALUE    _OR   "  OR"  elementes...
3 3 VALUE    _XOR  " XOR"    elementes...
6 6 VALUE    _AND  " AND"  elementes...
8 8 VALUE    _DUP  " DUP"   elementes...
7 7 VALUE    _+   "  + "  elementes...
9 9 VALUE    _-    "  - "  elementes...
10 10 VALUE    _*    "  * "  elementes...
11 11 VALUE    _/    "  / "  elementes...
12 12 VALUE    _<>   " <> "  elementes...
13 13 VALUE    _<    "  < "  elementes...
14 14 VALUE    _>    "  > "  elementes...
15 15 VALUE    _=    "  = "  elementes...
16 16 VALUE    _ROT    " ROT"  elementes...
17 17 VALUE    _:))    " :))"  elementes...
17 VALUE elementes_all

: do_?  -1 ;
: do_NOT VSDEPTH 1 < IF 0 ELSE VS> NOT >VS -1 THEN ;
: do_INVerse VSDEPTH  1 < IF 0 ELSE VS> -1 XOR >VS -1 THEN ;
: do_OR VSDEPTH 2 < IF 0 ELSE VS> VS> OR >VS -1 THEN ;
: do_XOR VSDEPTH 2 < IF 0 ELSE VS> VS> XOR  >VS -1 THEN ;
: do_AND VSDEPTH 2 < IF 0 ELSE VS> VS> AND >VS -1 THEN ;
: do_DUP VSDEPTH 7 > IF 0 ELSE VS> DUP >VS >VS -1 THEN ;
: do_+ VSDEPTH 2 < IF 0 ELSE VS> VS> + >VS -1 THEN ;
: do_- VSDEPTH 2 < IF 0 ELSE VS> VS>  SWAP - >VS -1 THEN ;
: do_* VSDEPTH 2 < IF 0 ELSE VS> VS> * >VS -1 THEN ;
: do_/ VSDEPTH 2 < VS> DUP >VS  0 = OR IF 0 ELSE VS> VS>  SWAP / >VS -1 THEN ;
: do_<> VSDEPTH 2 < IF 0 ELSE VS> VS> = NOT >VS -1 THEN ;
: do_< VSDEPTH 2 < IF 0 ELSE VS> VS>  SWAP < >VS -1 THEN ;
: do_> VSDEPTH 2 < IF 0 ELSE VS> VS>  SWAP > >VS -1 THEN ;
: do_= VSDEPTH 2 < IF 0 ELSE VS> VS>  = >VS -1 THEN ;
: do_ROT VSDEPTH 3 < IF 0 ELSE VS>  VS>  VS>  SWAP >VS  SWAP >VS >VS -1 THEN ;
: do_:)) VRSTACK_P 0 = VSTACK_P 0 > AND  VS> 0 = AND IF END_SUCCESS 0 TO game?_value -1 ELSE 0 THEN ;

: element_execute

CASE
_?     OF      do_?   ENDOF
_NOT   OF      do_NOT   ENDOF
_INVerse   OF      do_INVerse   ENDOF
_OR    OF      do_OR   ENDOF
_XOR   OF      do_XOR   ENDOF
_AND   OF      do_AND   ENDOF
_DUP   OF      do_DUP   ENDOF
_+     OF      do_+   ENDOF
_-     OF      do_-   ENDOF
_*     OF      do_*   ENDOF
_/     OF      do_/   ENDOF
_<>    OF      do_<>   ENDOF
_<     OF      do_<   ENDOF
_>     OF      do_>   ENDOF
_=     OF      do_=   ENDOF
_ROT   OF      do_ROT   ENDOF
_:))   OF      do_:))   ENDOF
ENDCASE

   ;


\ board

HERE 144 CELLS ALLOT VALUE PATH_VECT 0 VALUE PATH_VECT_point
HERE 144 CELLS ALLOT VALUE PATH_BOARD
HERE 144 CELLS ALLOT VALUE GAME_BOARD
HERE 144 CELLS ALLOT VALUE COLOR_BOARD
HERE 144 CELLS ALLOT VALUE VALUES_RESULTS
HERE 576 CELLS ALLOT VALUE REVERSE_BOARD
HERE 4096 CELLS ALLOT VALUE DATASTACK_
HERE 4096 CELLS ALLOT VALUE RETSTACK_

: BOARD_ 0 PATH_BOARD 144 FILL 0 REVERSE_BOARD 144 FILL  ;

: PATH_BOARD_add 4 last_selected_x last_selected_y  board_size * + CELLS PATH_BOARD + !
   ;
: PATH_BOARD_away 0 SWAP CELLS PATH_BOARD + !
   ;
: PATH_VECT_add PATH_VECT_point DUP CELLS PATH_VECT + potential_direction  SWAP !
1 + TO PATH_VECT_point
   ;
: PATH_VECT_add_from_stack  PATH_VECT_point DUP 1 + TO PATH_VECT_point
CELLS PATH_VECT + !
   ;
: PATH_VECT_away PATH_VECT_point 1 - DUP   CELLS PATH_VECT + @ SWAP
TO   PATH_VECT_point
   ;

: stacks_store.copy_data \ ( address - )
CELLS 9 * 8 0 DO DUP I CELLS + DATASTACK_ + I CELLS VSTACK + @ SWAP ! LOOP
8 CELLS + DATASTACK_ + VSTACK_P SWAP !
;
: stacks_store.copy_ret \ ( address - )
CELLS 9 *  8 0 DO DUP I CELLS + RETSTACK_ + I CELLS VRSTACK + @ SWAP ! LOOP
8 CELLS + RETSTACK_ + VRSTACK_P SWAP !
;


: stacks_store
DUP stacks_store.copy_data
stacks_store.copy_ret
;

: stacks_cansel.copy_data \ ( address - )
CELLS 9 *  8 0 DO DUP I CELLS + DATASTACK_ + @ I CELLS VSTACK +  ! LOOP
8 CELLS + DATASTACK_ + @  TO VSTACK_P
;
: stacks_cansel.copy_ret \ ( address - )
CELLS 9 *   8 0 DO DUP I CELLS + RETSTACK_ + @ I CELLS VRSTACK +  ! LOOP
8 CELLS + RETSTACK_ + @  TO VRSTACK_P
;

: stacks_cansel
DUP stacks_cansel.copy_data
stacks_cansel.copy_ret
;


36 VALUE show_boards.color_size \ размер цвета поля (или поля цвета  )
5 VALUE show_boards.color_tick \ толщина поля цвета
7 VALUE show_boards.color_shift \ сдвиг поля цвета
42 VALUE show_boards.pos_size \ размер квадратика. обозн. позицию
4 VALUE show_boards.pos_shift \ сдвиг квадратика. обозн. позицию
5 VALUE show_boards.pos_tick  \ толщина квадратика. обозн. позицию
9 VALUE show_boards.mark_size  \  размер маркера возврата (допустимость бэк...)
5 VALUE show_boards.mark_tick \  толщина маркера возврата (допустимость бэк...)
30 VALUE show_boards.mark_shift \ сдвиг  маркера возврата

14 VALUE show_boards.text_shift




: color_board
12 0 DO
12 0 DO
J board_size * I + CELLS COLOR_BOARD +
I 2 / 2 MOD 0 =  J 2 /  2 MOD  0 = XOR IF NUMBER_LIGHTBLUE ELSE NUMBER_ORANGE THEN SWAP !

LOOP
LOOP
  NUMBER_RED board_size 1 - CELLS COLOR_BOARD + !
  NUMBER_RED board_size DUP 1 - * CELLS COLOR_BOARD + !
;
color_board


0 VALUE show_board.temp

: last_selected_abs  last_selected_y board_size * last_selected_x  +  CELLS ;

: show_board \ ( -- )
\  доску

board_size 0
   DO
   board_size 0
      DO
       sq_size_ I * coord_start_X +  sq_size_ J * coord_start_Y +
      OVER OVER  \ серый квадрат
       2 + SWAP 2 + SWAP
       _GRAY sq_size_ 2 - 2 square_tick
      
      OVER show_boards.text_shift + OVER show_boards.text_shift +
      J board_size * I + CELLS COLOR_BOARD + @
      J board_size * I + CELLS PATH_BOARD + @ +
      color...
      SETCOLOR
      TEXTXY J board_size * I + CELLS GAME_BOARD + @
      DUP ABS 256 >
      IF DUP 0 < IF  -1 * 255 AND -1 * ELSE  255 AND THEN .
      ELSE CELLS ARR + @  PRINT
      THEN
      
      OVER show_boards.color_shift + OVER  show_boards.color_shift +
      J board_size * I + CELLS COLOR_BOARD + @
      J board_size * I + CELLS PATH_BOARD + @  +
      color...
      show_boards.color_size show_boards.color_tick 
      square_tick
      
      
      J board_size * I + CELLS REVERSE_BOARD + @
      DUP 0 = IF DROP DROP DROP ELSE TO show_board.temp
      OVER  show_boards.mark_shift + 2 + OVER  show_boards.mark_shift + 2 +
      show_board.temp
      color... 
      show_boards.mark_size 2 -  show_boards.mark_tick square_tick
      SWAP show_boards.mark_shift + SWAP  show_boards.mark_shift +
      0 
      show_boards.mark_size 2 square_tick

      THEN
      LOOP
   LOOP
   
      sq_size_ last_selected_x * coord_start_X +  sq_size_ last_selected_y * coord_start_Y +
      SWAP show_boards.pos_shift + SWAP  show_boards.pos_shift +
      _WHITE
      show_boards.pos_size show_boards.pos_tick square_tick
      
      show_stack
;



: startxy
board_size  1 - TO last_selected_y
0 TO last_selected_x
;




: clear_two
last_selected_x sq_size_  * coord_start_X +  sq_size_ last_selected_y * coord_start_Y +
_BLACK sq_size_ DUP 2 / square_tick
sq_size_  * coord_start_Y + SWAP sq_size_  * coord_start_X + SWAP
_BLACK sq_size_ DUP 2 / square_tick
;

: possibility_before
   
   OVER OVER board_size * + CELLS DUP
   PATH_BOARD + @ 0 = SWAP
   COLOR_BOARD + @ last_selected_x
   last_selected_y board_size * + CELLS COLOR_BOARD + @ =
   VRSDEPTH 0 = OR AND
   ;

   
: step_to_do
last_selected_x last_selected_y board_size * + stacks_store
OVER OVER board_size * + CELLS GAME_BOARD  + @
DUP ABS 256 >
      IF DUP 0 < IF  -1 * 255 AND -1 * ELSE  255 AND THEN  >VS
      GET_VSTACK_ERR DUP IF VS_ERR_PRINT   0   ELSE DROP -1 THEN
      ELSE element_execute
      THEN      
   ;
   
: game_step
   TO potential_direction
   possibility_before
   IF  step_to_do 
      IF   PATH_BOARD_add PATH_VECT_add 
         OVER OVER
         clear_two TO last_selected_y  TO last_selected_x  show_board   
      ELSE ERROR_POS DROP DROP   
      THEN
    ELSE ERROR_POS   DROP DROP 
   THEN
   ;

: _right
game?
IF last_selected_x board_size 1 - < IF last_selected_x 1 + last_selected_y 2 game_step ELSE ERROR_POS  THEN
THEN
;
' _right TO K_RIGHT

: _left
game?
IF last_selected_x 0 > IF last_selected_x 1 - last_selected_y 4 game_step ELSE  ERROR_POS  THEN THEN
;
' _left TO K_LEFT

: _up
game?
IF last_selected_y 0 > IF last_selected_x last_selected_y 1 - 1 game_step ELSE  ERROR_POS THEN
THEN
;
' _up TO K_UP


: _down
game?
IF last_selected_y board_size 1 - < IF last_selected_x last_selected_y 1 + 3 game_step ELSE  ERROR_POS THEN
  THEN
;
' _down TO K_DOWN



: back_move

PATH_VECT_point 0 >
game?  AND
 
IF
   PATH_VECT_away DUP
   CASE
   1   OF   last_selected_x last_selected_y 1 +   ENDOF
   2   OF   last_selected_x 1 - last_selected_y   ENDOF
   3   OF   last_selected_x last_selected_y 1 -   ENDOF
   4    OF   last_selected_x 1 + last_selected_y   ENDOF
   ENDCASE 
   OVER OVER board_size * + CELLS REVERSE_BOARD + DUP @
   NUMBER_RED =
   IF 
   ERROR_POS   DROP  DROP  DROP  PATH_VECT_add_from_stack
   ELSE 
   DUP @  1 + SWAP ! OVER OVER board_size * + PATH_BOARD_away 
    OVER OVER board_size * + stacks_cansel   
    OVER OVER clear_two   
    TO last_selected_y  TO last_selected_x  DROP
    show_board 
   THEN

ELSE ERROR_POS THEN
;
' back_move DUP DUP TO K_F10 TO K_F11 TO K_F12



\  GAME BEGIN начало игры и т.п. загрузка новых игр по пути наименьшего сопротивления
0 VALUE game_map.index 0 VALUE game_map.err 0 VALUE game_map.non

: E,EXEM DROP -1 TO game_map.err ;
: E,EM game_map.err IF DROP  ELSE  TO game_map.err THEN ;
: N,EM game_map.non IF DROP  ELSE  TO game_map.non THEN ;
: E,? game_map.index DUP board_size DUP * >
IF E,EXEM ELSE DUP 1 + TO game_map.index CELLS GAME_BOARD + !  THEN ;
: E, DUP elementes_all > OVER 1 < OR IF E,EM ELSE E,?  THEN  ;
: N,? DUP 0 < IF -512 + ELSE 512 + THEN E,? ;
: N, DUP ABS 99 > IF N,EM ELSE N,?  THEN  ;

\ массив доступных игр
HERE 8 2 * CELLS ALLOT VALUE available_games 
0 VALUE available_games_point
\ 2 CELLS - строка описания игры и адрес слова-загрузчика, которое содержит (загружает) данные
: available_games.to \ ( xt c-addr -- success  number )
      available_games_point 14 >
      IF
      " слишком много элементов для available_games " PRINT 0
      ELSE
      available_games_point  CELLS available_games + !
      available_games_point 1 + CELLS available_games + ! -1
      available_games_point DUP 2 + TO available_games_point
      THEN      
      ;
      
\ игра должна определеяться словом  ????
\ :   ???? ['] game_description   " game verbal description "  available_games.to ;  ????


: example_4
board_size.tiny TO board_size     
color_board  \ стандарт, или можно определить своё
startxy  \ стандарт, или можно определить своё
\ доска
_XOR E,       -3  N,       _INVerse E,    _:)) E,
_*   E,        _OR E,       _XOR E,       _+   E,   
_=   E,       _>  E,       _INVerse E,    3    N,
_?   E,       _-  E,       _-   E,          _AND E,

\ стек так и выглядит
7 >VS
6 >VS
4 >VS
2 >VS
1 >VS
-1 >VS 
   ;
:  example_4_des ['] example_4   " простой пример маленькой игры - минимум 3 решения " 
available_games.to ;   
                        example_4_des DROP DROP
\ end example game description

VECT game.map 0 VALUE game.descr
0 VALUE game.last
0 VALUE game.lastp
: new_game   \ ( number -- )
   DUP 12 > OVER  1 + CELLS available_games + @ 0 = OR
   
   IF " ненормальный номер игры " PRINT DROP
   ELSE
   DUP TO game.lastp DUP
   CELLS available_games + @ TO game.descr 1  + CELLS  available_games + @ TO game.map
   0 TO game_map.index 0 TO game_map.err 0 TO game_map.non
   0 TO VSTACK_P 0 TO VRSTACK_P
   game.map 
   game_map.err  game_map.non OR
   last_selected_x last_selected_y board_size * + CELLS GAME_BOARD + @ _? = NOT OR
   0 = IF
      game.lastp TO game.last \ потенциальный номер игры в реально послед.
      stack_X() ret_X()
      BOARD_
      0 TO PATH_VECT_point
      CLS show_board coord_start_X  coord_start_Y  28 - TEXTXY _LIGHTGRAY SETCOLOR game.descr PRINT
      -1 TO game?_value
      ELSE
      CLS
      0 TO game?_value
      show_board 
      coord_start_X  coord_start_Y  28 - TEXTXY
      " невозможно загрузить игру: ошибка в расположении элементов либо начальной позиции"  PRINT
      THEN
   THEN
;


: game_cycle game.last 2 +
      DUP
      14 > OVER CELLS available_games + @ 0 = OR IF DROP 0  THEN
      DUP
       CELLS available_games + @ 0 = IF 160 90 TEXTXY " No available games " PRINT DROP ELSE new_game THEN
   ;
   ' game_cycle TO K_F3
   
: game_again    
   game.last DUP
   CELLS available_games + @ 0 =
   IF 160 90 TEXTXY " No available games " PRINT DROP ELSE new_game THEN
;
' game_again TO K_F2

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 

: example_6a
board_size.small TO board_size     
color_board  \ стандарт
startxy  \ стандарт
\ доска
4        N,    _-    E,    _INVerse E,    4    N,    _<>    E,    _:))    E,
_ROT     E,    4    N,    _+     E,     _-     E,    _OR     E,    _+     E,
6        N,    -3   N,    _DUP E,    3        N,     _+     E,    1  N,
_/       E,    _OR  N,    _+    E,    4   N,     2     N,    _/   E,
4        N,    -3   N,    9     N,    _NOT E,   4       N,    _<>   E,
_?       E,    4    N,    _*    E,       _AND E,         4        N,   4 N,


\ стек
1 >VS
2 >VS
3 >VS
4 >VS
4 >VS
4 >VS 
   ; 
:  example_6a_des ['] example_6a   " также простой пример игры 6х6 - обнаружено минимум 2 решений "  available_games.to ;   
                        example_6a_des  DROP DROP
                        
                        
\ -------------------------------------------------------------------------                        
: startxy8e
board_size  2 - TO last_selected_y
1 TO last_selected_x
;

: color_board8e
8 0 DO
8 0 DO
J board_size * I + CELLS COLOR_BOARD +
I board_size 1 - = J board_size 1 - = OR
I 0 = J 0 = OR
OR IF NUMBER_MAGENTA
ELSE
I 2 / 2 MOD 0 =  J 2 /  2 MOD  0 = XOR IF NUMBER_LIGHTBLUE ELSE NUMBER_ORANGE THEN THEN
SWAP !

LOOP
LOOP
  NUMBER_RED board_size 1 - CELLS COLOR_BOARD + !
  NUMBER_RED board_size DUP 2 - * 1 + CELLS COLOR_BOARD + !
;

: example_8e \ exotic
board_size.medium TO board_size     
color_board8e 
startxy8e 
\ доска
_DUP   E,   4   N,   2   N,   5   N,   2   N,   3   N,   _<>   E,   _:))   E,
5   N,   _<   E,   1   N,   7   N,   _<   E,   _=   E,   1   N,   _<>   E,
_-   E,   5   N,   _=   E,   _>   E,   3   N,   5   N,   _=   E,   3   N,
3   N,   7   N,   _<   E,   _=   E,   1   N,   7   N,   _>   E,   2   N,
_-   E,   _=   E,   3   N,   5   N,   _=   E,   _>   E,   3   N,   _NOT   E,
1   N,   _<   E,   1   N,   7   N,   _<   E,   _=   E,   1   N,   _DUP   E,
_INVerse   E,   _?   E,   _>   E,   _=   E,   3   N,   5   N,   _>   E,   4   N,
2   N,   _DUP   E,   1   N,   2   N,   4   N,   2   N,   6   N,   _ROT   E,


\ стек
1 >VS
2 >VS
2 >VS
2 >VS
2 >VS
2 >VS
   ; 
:  example_8e_des ['] example_8e    " экзотическая игра 8х8 - обнаружено минимум 1 решениe "  available_games.to ;   
                        example_8e_des  DROP DROP
\ -------------------------------------------------------------------------   

                  
            


КОД ИСПРАВЛЕН 23,00


Последний раз редактировалось вопрос Пн июл 05, 2010 07:44, всего редактировалось 3 раз(а).

Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Пт июл 02, 2010 23:02 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Итак, продолжим - стартовую позицию нужно выдумывать, или хотя бы корректировать.
На пробу 3 позиции. Для каждой найдены решения. о чём вещает строка над позицией.

Сколько решений возможно в позиции? Не могу сказать точно, число их ограничено, но как правило решение не одно (если специально не приложить усилий), хотя большая часть должна быть неплохо замаскирована. Решения могут находиться очень быстро. Собственно, удачей следует считать не просто нахождение решения, но нахождение как можно большего их количества.

С другой стороны, возможно, над поиском решения придётся поразмышлять. :?

Сложность задачи не дотягивает до шахмат, но автор пытался подражать жанру шахматной задачи в некоторых смыслах :D

предусмотрены размеры досок 4 6 8 10 12
для 10 и 12 не предложены примеры, вообще доски резались при некотором неудачном размере окна Кварка. Потому, может стоит при малом разрешении экрана поиграть рамкой окна, чтобы найти приемлемое. Также, использованы только 3-буквенные слова для форта и числа не более из 3 знаков - больше не влазило в квадратик при стандартном шрифте, хотя возможны усовершенствования INV - INVERSE ( = -1 XOR )

стартовая позиция выглядит вот так
Изображение


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Пт июл 02, 2010 23:42 
Не в сети
Аватара пользователя

Зарегистрирован: Вт мар 20, 2007 23:39
Сообщения: 1256
Благодарил (а): 3 раз.
Поблагодарили: 18 раз.
вопрос писал(а):
Из-за того, что в Кварке почему-то нет векторного слова backspaсe

Зато есть векторы KEYUP и KEYDOWN.
Строка 102. Не хватает:
Код:
QUAN last_selected_y
QUAN last_selected_x


Код:
HERE 32 CELLS ALLOT VALUE VSTACK

=
Код:
32 ARRAY VSTACK


Код:
0 VALUE VSTACK_P 

=
Код:
QUAN VSTACK_P


Код:
10 10 250 RGB VALUE _RED
...
1 VALUE NUMBER_GREEN
...
NUMBER_RED OF _RED ENDOF

Зачем кодировать 32-битный цвет 32-битным номером?

Код:
CREATE ARR 32 CELLS ALLOT

: elementes... SWAP CELLS ARR + ! ;

1 1 VALUE    _?      "  ?"   elementes...
2 2 VALUE    _NOT  " NOT"   elementes...
4 4 VALUE    _INVerse  " INV"   elementes...
...
17 VALUE elementes_all

Зачем такие сложности для обычного массива строк?

К сожалению код практически нечитаем - полностью отсутствуют комментарии, длинные непонятные названия слов. Много объемных слов. Соответвственно, понять архитектуру игры и приципы её внутреннего функционирования проблематично.

_________________
Cтоимость сопровождения программного обеспечения пропорциональна квадрату творческих способностей программиста.
Роберт Д. Блисc


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Пт июл 02, 2010 23:59 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Цитата:
Строка 102. Не хватает:
Код:
QUAN last_selected_y
QUAN last_selected_x


Да, уже заметил, удалял отладочные строки и вот такое ...
сейчас исправлю

Что касается ARRAY - то он есть не во всех фортах, а потому надёжнее так :(


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 00:09 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Цитата:
К сожалению код практически нечитаем - полностью отсутствуют комментарии, длинные непонятные названия слов. Много объемных слов. Соответственно, понять архитектуру игры и приципы её внутреннего функционирования проблематично.

Сделано на одном дыхании - потому даже без комментариев
можно поправить. Я буду рад, если кто-то заинтересуется самой игрой (ведь это моя идея :) хоть и несложная ) или её устройством... оно простое.

Например
Цитата:
Зачем кодировать 32-битный цвет 32-битным номером?

Это логический номер - номер - это роль в игре (например сдвиг при прохождении с цветного на серый или т.п.)


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 00:17 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Цитата:
Из-за того, что в Кварке почему-то нет векторного слова backspaсe

Зато есть векторы KEYUP и KEYDOWN.

Подозревая, что большинство не обновляет Кварк часто, я ориентировался на Кварк от 15.03.2009


Последний раз редактировалось вопрос Сб июл 03, 2010 00:43, всего редактировалось 1 раз.

Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 00:32 
Не в сети
Administrator
Administrator
Аватара пользователя

Зарегистрирован: Вт май 02, 2006 22:48
Сообщения: 6454
Благодарил (а): 14 раз.
Поблагодарили: 101 раз.
вопрос писал(а):
Кроме того, этих слов нет в доступных мне PDF, и меня это раздражает по правде говоря, хотя это личное дело Хищника. Компилятор, который работает не со всей клавитурой или по крайней мере из документации непонятно, что он работает со всей ( потом вытру эту фразу) (улыбайтесь)
Кроме того, любопытно, что Кварк делает с WM_PAINT - MessageBox не прорисовывается

При наличии заказа постараюсь сделать. С клавишами дело такое - что не требуется для редактирования вводимого текста (плюс что попалось на глаза), то и сделано. Сейчас обработка любой клавиши - это вектор. Минимальные тесты проведены, нужно проверить на удобство применения. С WM_PAINT можно сделать одно - постоянно выполнять, иначе не будет отрисовки. При появлении диалогового окна придется накручивать что-то поверх основного движка, чтобы WM_PAINT не перекрыл его отрисовкой основного окна, а это сделает систему зависящей от еще одного программного механизма, специфичного для ОС. Придется ставить какие-то флажки... вобщем, формально это несложно, а вот применять не так уж красиво. Я планировал использовать Quark GUI с собственным набором элементов управления.

Я тут в некотором роде уезжаю отдыхать, но с нетбуком и GPRS-модемом. Так что на запросы общественности смогу отреагировать, в пределах разумного.


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 00:41 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Хищник писал(а):
вопрос писал(а):
Кроме того, любопытно, что Кварк делает с WM_PAINT - MessageBox не прорисовывается

При наличии заказа постараюсь сделать. С клавишами дело такое - что не требуется для редактирования вводимого текста (плюс что попалось на глаза), то и сделано. Сейчас обработка любой клавиши - это вектор. С WM_PAINT можно сделать одно - постоянно выполнять, иначе не будет отрисовки.
Я тут в некотором роде уезжаю отдыхать, но с нетбуком и GPRS-модемом. Так что на запросы общественности смогу отреагировать, в пределах разумного.


Ну, При наличии заказа постараюсь сделать. это априорный заказ - он как бы существует сам по себе.

Чем векторность клавиш мешала бы вот этому
С клавишами дело такое - что не требуется для редактирования вводимого текста

Вообще - обсуждаем тут игру :| - всё-таки это форт-игра или форт в виде игры
или игра для фортеров специально


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 01:24 
Не в сети
Administrator
Administrator
Аватара пользователя

Зарегистрирован: Вт май 02, 2006 22:48
Сообщения: 6454
Благодарил (а): 14 раз.
Поблагодарили: 101 раз.
вопрос писал(а):
Ну, При наличии заказа постараюсь сделать. это априорный заказ - он как бы существует сам по себе.

Чем векторность клавиш мешала бы вот этому

VoidVolker уже писал - есть векторы KEYDOWN и KEYUP. Еще есть VARIABLE LASTKEY, там будет код нажатой/отпущенной клавиши. Если по KEYDOWN обработать код самостоятельно, а потом заменить содержимое LASTKEY на 0, клавиша окажется "проглоченной".


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 08:44 
Не в сети
Аватара пользователя

Зарегистрирован: Вт мар 20, 2007 23:39
Сообщения: 1256
Благодарил (а): 3 раз.
Поблагодарили: 18 раз.
вопрос писал(а):
Кроме того, этих слов нет в доступных мне PDF, и меня это раздражает по правде говоря, хотя это личное дело Хищника. Компилятор, который работает не со всей клавитурой или по крайней мере из документации непонятно, что он работает со всей ( потом вытру эту фразу) (улыбайтесь)

У меня есть api-файл с подсказками для SciTE. На данный момент там описано лишь 298 слов из 704, большинство из мануала. Т.к. спроса нет на него, а сам я и так помню большинство слов кварка - вот и не обновляю почти. Если кому-то нужно - могу описать все остальные.
вопрос писал(а):
Что касается ARRAY - то он есть не во всех фортах, а потому надёжнее так

Ну во-первых код - для кварка. И опять забыт один из плюсов форта - его расширяемость. ARRAY - это одна фраза:
Код:
: ARRAY CREATE CELLS ALLOT ;

И факторизация тоже местами очень сильно забыта.
вопрос писал(а):
Сделано на одном дыхании - потому даже без комментариев, можно поправить. Я буду рад, если кто-то заинтересуется самой игрой (ведь это моя идея хоть и несложная ) или её устройством... оно простое.

А разве демонстрация кода в сети на всеобщее обозрение не подразумевает, что кто-то будет исследовать его? Тем более, комментарии важны в первую очередь для самого автора. Я вот например уже давно выработал в себе привычку писать везде стековые комментарии, даже если слово из одной фразы. И обязательно описываю что делает слово. За исключением только тестового и экспериментального кода.

_________________
Cтоимость сопровождения программного обеспечения пропорциональна квадрату творческих способностей программиста.
Роберт Д. Блисc


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 09:10 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Цитата:
А разве демонстрация кода в сети на всеобщее обозрение не подразумевает, что кто-то будет исследовать его?

Хорошо, код исправим. Но демонстрируется прежде всего идея - форт в виде правил динамической интеллектуальной задачи - может, это даже не совсем игра (как и предыдущая). Но по виду - игра.


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Сб июл 03, 2010 21:36 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Итак, как устроен код
Очень просто, на самом деле.

Сначала небольшое отступление. Как должен быть описан алгоритм игры - в терминах привил и событий игры или в терминах языка реализации? Этот вопрос не пустой - в ответ на этот вопрос родились понятия "абстракция данных" и "обьектно-ориентированное программирование"
С точки зрения эффективности работы лучшим является вариант с абстракцией данных. Если это имеет хороший вид, то программист имеет дело только с логикой игры. В случае, если абстракция даных отсутствует, программист имеет дело ... нет не с логикой кода, а с двумя перемешанными логиками - логикой кода и логикой игры, причём эта логика бывает асимметрична.

В этом коде абстракция данных отсуствует.

Потому такой нечитабельный.

Если же разобраться, то ничего сложного нет.

Начнём с правил игры - игрок (решатель задачи) ходит по ячейкам. Вся игра может быть описана , если указано
1. расположение цветов на доске
2. расположение операций и чисел на доске
3. маршрут и текущее положение
4. количество возвращений через каждую ячейку

Можно уложить всё в одну доску-массив структур, но это может быть сложнее, потому сделаны

HERE 144 CELLS ALLOT VALUE PATH_VECT 0 VALUE PATH_VECT_point
HERE 144 CELLS ALLOT VALUE PATH_BOARD
HERE 144 CELLS ALLOT VALUE GAME_BOARD
HERE 144 CELLS ALLOT VALUE COLOR_BOARD
HERE 144 CELLS ALLOT VALUE VALUES_RESULTS
HERE 576 CELLS ALLOT VALUE REVERSE_BOARD
HERE 4096 CELLS ALLOT VALUE DATASTACK_
HERE 4096 CELLS ALLOT VALUE RETSTACK_

PATH_VECT показывает направление движение по ходам
1 ход - нулевой элемент массива и т.д. так удобнее. т.к. чтобы найти след. ход, мы просто используем PATH_VECT_point
PATH_BOARD отдельно от PATH_VECT, т.к. служит для подсвечивания пройденного пути серым - содержит число, на которое увеличивается номер цвета, если ячейка пройдена (всегда 4)
GAME_BOARD содержит операции форта, точнее числа, отсылающие к операциям
COLOR_BOARD содержит цвета соотв. ячеек
VALUES_RESULTS - отладочное - забыл убрать, ничего не содержит
DATASTACK_ RETSTACK_ - массивы, хранящие состояяния стеков на момент ухода из ячейки, возвратившись в ячейку, игрок находит там стеки возвращённые к нужному состоянию
Как видим, всё хранится отдельно , все массивы имеют размерность 144 * 4 кроме DATASTACK_ RETSTACK_ - они выстроены из предположения, что необходимо сохранять в каждом ходе 16 CELLS + 2 глубины

Вначале массивы нужно заполнить, для чего служат слова
color_board распределяет цвета на доске, можно было бы поячеечно, но зачем, если ясна математическая закономерность, стандартное слово создаёт "шахматную" структуру с удвоенным размером поля
startxy - устанавливает стартовое выделение в нужное положение ( должно совпасть со знаком вопроса и в стандартном слове находится в левом нижнем углу)
E, компилирует элемент - номер оператора ( вроде + - = * ) в GAME_BOARD
N, компилирует число, признаком числа является то, что оно больше 256 - предполагается, что числа вообще меньше 100 или больше -100 (чтобы ограничить количество значащих цифр)
само число прибавляется к 512, чтобы не создавать дополнительных структур
т.о. GAME_BOARD содержит операции 1-17 и числа 512 и выше, слово, изображающее доску вычитает из чисел 512 и остаток выводит на экран. На всякий случай эти слова производят проверки корректности предлагаемых данных, только потом размещают их, для этого служат слова
: E,EXEM DROP -1 TO game_map.err ;
: E,EM game_map.err IF DROP ELSE TO game_map.err THEN ;
: N,EM game_map.non IF DROP ELSE TO game_map.non THEN ;
: E,? game_map.index DUP board_size DUP * >
IF E,EXEM ELSE DUP 1 + TO game_map.index CELLS GAME_BOARD + ! THEN ;
: N,? DUP 0 < IF -512 + ELSE 512 + THEN E,? ;


Может быть это неправильно, но нет слова-загрузчика для всех игр, а есть слово-загрузчик отдельное для каждой игры.
Например example_4 - это слово-пример загрузчика - оно вызывает слова
color_board
startxy
устанавливает размер доски и заполняет доску
Загрузчик потом может быть вызван словом
new_game
при вызове новой игры

Каждому загрузчику по пятам следует вспомогательное слово (индивидуально)
которое помещает адрес загрузчика в массив available_games , откуда его достанет
new_game
при вызове новой игры
ещё строку описания
в примере это example_4_des
массив адресов - чтобы оперировать списком доступных игр - наприер менять их в цикле game_cycle

Загрузчик игры может пользоваться не стандартными словами color_board , а определить собственные, которые компилируются вместе с загрузчиком и представляют собою его часть (см. слова example_8e color_board8e startxy8e )

фактически игры не загружаются а до-компилируются,что громоздко, но очень быстро

хм. продолжение следует если интересно


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Вс июл 04, 2010 17:48 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Сама программа очень проста - она реагирует на 9 клавиш (11, т.к. одна клавиша изображается тремя )
Стрелки - движение позиции по доске, слово, вызваемое прерыванием стрелки, кладёт на стек переменные, которые обозначают положение на доске текущее, изменив их (прибавив или вычтя 1, т.к. движение только на 1 поле )
имея ввиду поле, куда предполагается пойти.
: _down
game?
IF last_selected_y board_size 1 - < IF last_selected_x last_selected_y 1 + 3 game_step ELSE ERROR_POS THEN
THEN
;

' _down TO K_DOWN

слово game? убеждается, что игра в процессе
также, это слово _down производит проверку геометрии, т.е. не идёт ли пользователь за размеры, ERROR_POS на самом деле просто звуковой сигнал
изменив координаты и положив на стек цифру, шифрующую направление (3 если вниз)
слово, вызываемое стрелкой вызывает game_step шаг игры

: game_step 
TO potential_direction
possibility_before
IF step_to_do
IF PATH_BOARD_add PATH_VECT_add
OVER OVER
clear_two TO last_selected_y TO last_selected_x show_board
ELSE ERROR_POS DROP DROP
THEN
ELSE ERROR_POS DROP DROP
THEN
;

это и вся сложность :)))
potential_direction - это переменная, хранящая код направления хода, этот код будет внесен в PATH_VECT
только в том случае, если возможен предлагаемый ход
в случае с ходом вниз, в переменную potential_direction попадёт 3ка
НА стеке остаются координаты того поля, куда попадёт пользователь, если ход закончится успешно
сначала слово game_step передаёт их в слово possibility_before , которое проверяет возможность хода исходя из правил, которые можно применить ДО попытки сделать ход

: possibility_before 

OVER OVER \ координаты будут сохранены для последующего

board_size * + CELLS DUP
PATH_BOARD + @ 0 = SWAP
COLOR_BOARD + @ last_selected_x
last_selected_y board_size * + CELLS COLOR_BOARD + @ =
VRSDEPTH 0 = OR AND
;


таких правил всего 2 - не является ли поле уже пройденным : смотрим PATH_BOARD
и не является ли ход сменой цветов а если да, то пуст ли стек возвратов
таким образом реализуются 2 правила в игре - не ходить на пройденное и
менять цвет поля толко с пустым стеком возвратов
последнее правило делает игру не такой простой и
иммитирует правило настоящего форта
т.к. нельзя забывать стек возвратов при NEXT

если эти правила соблюдены, possibility_before
возвращает -1 и game_step
вызывает step_to_do

step_to_do - попытка сделать ход - имеется ввиду не на доске, а осуществить математическое действие, предполагаемое этим ходом с данными на стеке

step_to_do может возвращать
(a) ИСТИНУ если ход получился или
(b) 0 если скажем, переполнился стек или недостаточно элементов или деление на 0х00

далее происходит вот этот фрагмент
IF	PATH_BOARD_add PATH_VECT_add  
OVER OVER
clear_two TO last_selected_y TO last_selected_x show_board
ELSE ERROR_POS DROP DROP
THEN

Если всё хорошо, то PATH_BOARD_add PATH_VECT_add внесут изменения в PATH_BOARD и PATH_VECT
координаты попадут в last_selected_y last_selected_x чем воспользуется show_board
в противном случае - звуковой сигнал и координаты будут вытерты со стека
ERROR_POS DROP DROP
и снова ждём прерываний

Действия обозначены номерами, каждому номеру соответствует строка, которая отображается на доске, переменная, которая используется при кодировании стартовой позиции, которая выглядит как строка - форт позволяет, только перед подчёркивание - действие + обозначено _+
действие вызывается по номеру в слове element_execute, где каждому номеру сопоставлено
слово, выполняющее действие _+ - do_+
и т.п.
Само номера заданы вот этим
1 1 VALUE 	_?   	"  ?"   elementes...
2 2 VALUE _NOT " NOT" elementes...
4 4 VALUE _INVerse " INV" elementes...
5 5 VALUE _OR " OR" elementes...
3 3 VALUE _XOR " XOR" elementes...
6 6 VALUE _AND " AND" elementes...
8 8 VALUE _DUP " DUP" elementes...
7 7 VALUE _+ " + " elementes...
9 9 VALUE _- " - " elementes...
10 10 VALUE _* " * " elementes...
11 11 VALUE _/ " / " elementes...
12 12 VALUE _<> " <> " elementes...
13 13 VALUE _< " < " elementes...
14 14 VALUE _> " > " elementes...
15 15 VALUE _= " = " elementes...
16 16 VALUE _ROT " ROT" elementes...
17 17 VALUE _:)) " :))" elementes...


Слово element_execute возвращает удачу
или неудачу действия, которую в свою
очередь получает от слов
: do_NOT VSDEPTH 1 < IF 0 ELSE VS> NOT >VS -1 THEN ;
: do_INVerse VSDEPTH 1 < IF 0 ELSE VS> -1 XOR >VS -1 THEN ;
: do_OR VSDEPTH 2 < IF 0 ELSE VS> VS> OR >VS -1 THEN ;
: do_XOR VSDEPTH 2 < IF 0 ELSE VS> VS> XOR >VS -1 THEN ;
: do_AND VSDEPTH 2 < IF 0 ELSE VS> VS> AND >VS -1 THEN ;
: do_DUP VSDEPTH 7 > IF 0 ELSE VS> DUP >VS >VS -1 THEN ;
: do_+ VSDEPTH 2 < IF 0 ELSE VS> VS> + >VS -1 THEN ;
: do_- VSDEPTH 2 < IF 0 ELSE VS> VS> SWAP - >VS -1 THEN ;
: do_* VSDEPTH 2 < IF 0 ELSE VS> VS> * >VS -1 THEN ;
: do_/ VSDEPTH 2 < VS> DUP >VS 0 = OR IF 0 ELSE VS> VS> SWAP / >VS -1 THEN ;
: do_<> VSDEPTH 2 < IF 0 ELSE VS> VS> = NOT >VS -1 THEN ;
: do_< VSDEPTH 2 < IF 0 ELSE VS> VS> SWAP < >VS -1 THEN ;
: do_> VSDEPTH 2 < IF 0 ELSE VS> VS> SWAP > >VS -1 THEN ;
: do_= VSDEPTH 2 < IF 0 ELSE VS> VS> = >VS -1 THEN ;
: do_ROT VSDEPTH 3 < IF 0 ELSE VS> VS> VS> SWAP >VS SWAP >VS >VS -1 THEN ;
: do_:)) VRSTACK_P 0 = VSTACK_P 0 > AND VS> 0 = AND IF END_SUCCESS 0 TO game?_value -1 ELSE 0 THEN ;
которые вызывает по номеру

каждое из этих слов либо производит действия и возвращает TRUE
либо не производит действий и возвращает FALSE


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Вт июл 13, 2010 20:50 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Заметил, что в форте ещё есть трёхбуквенные операторы (слова) MOD NIP MAX MIN
добавил их в игру :D , в этом варианте кода три стартовых позиции, в которых присутствуют эти операторы. На примере самой простой также поясняются правила игры - см. след. постинг.
ПОсле загрузки файла нужно нажать F2
Код:
" user32.dll"  LOADLIBRARY " MessageBeep" GETPROCADDRESS  VALUE MessageBeep_API
: ERROR_POS 16 MessageBeep_API 
API1 DROP ;
: END_SUCCESS 0 MessageBeep_API 
API1 DROP ;

-1 VALUE game?_value
: game? game?_value ;


HERE 32 CELLS ALLOT VALUE VSTACK
0 VALUE VSTACK_P
0 VALUE VSTACK_ERR

: >VS \ ( n --> )
\ поместить на стек
VSTACK_P 8 = IF 1 TO VSTACK_ERR ELSE VSTACK_P DUP 1 + TO VSTACK_P CELLS VSTACK + ! THEN
;

: VS> \ ( --> n )
\ снять со стека
VSTACK_P 0 = IF -1 TO VSTACK_ERR ELSE VSTACK_P 1 - DUP TO VSTACK_P CELLS VSTACK + @ THEN
;
: VSDEPTH VSTACK_P ;
: GET_VSTACK_ERR VSTACK_ERR 0 TO VSTACK_ERR ;

HERE 32 CELLS ALLOT VALUE VRSTACK
0 VALUE VRSTACK_P
0 VALUE VRSTACK_ERR

: >VRS \ ( n --> )
\ поместить на стек
VRSTACK_P 8 = IF 1 TO VRSTACK_ERR ELSE VRSTACK_P DUP 1 + TO VRSTACK_P CELLS VRSTACK + ! THEN
;

: VRS> \ ( --> n )
\ снять со стека
VRSTACK_P 0 = IF -1 TO VRSTACK_ERR ELSE VRSTACK_P 1 - DUP TO VRSTACK_P CELLS VRSTACK + @ THEN
;
: VRSDEPTH VRSTACK_P ;
: GET_VRSTACK_ERR VRSTACK_ERR 0 TO VRSTACK_ERR ;


\ 4 colors

10 10 250 RGB VALUE _RED      50 120 250 RGB VALUE _ORANGE
110 110 112 RGB VALUE _GRAY   250 250 10 RGB VALUE _LIGHTBLUE
10 250 250 RGB VALUE _YELLOW   70 250 70 RGB VALUE _GREEN
255 255 255 RGB VALUE _WHITE   40 40 40 RGB VALUE NEAR_BLACK
255 0 255 RGB VALUE _MAGENTA    173 171 172 RGB VALUE _LIGHTGRAY
218 218 211 RGB VALUE _VERYLIGHTGRAY2    218 218 211 RGB VALUE _VERYLIGHTGRAY
0 VALUE _BLACK


1 VALUE NUMBER_GREEN
2 VALUE NUMBER_YELLOW
3 VALUE NUMBER_RED
4 VALUE NUMBER_LIGHTBLUE
5 VALUE NUMBER_ORANGE
6 VALUE NUMBER_MAGENTA
7 VALUE NUMBER__VERYLIGHTGRAY2
8 VALUE NUMBER_GRAY
9 VALUE NUMBER_LIGHTGRAY
10 VALUE NUMBER_VERYLIGHTGRAY
11 VALUE NUMBER_WHITE
12 VALUE NUMBER_BLACK


: color... \ ( number --> color )
CASE
0 OF _BLACK ENDOF
NUMBER_GREEN OF GREEN ENDOF
NUMBER_RED OF _RED ENDOF
NUMBER_LIGHTBLUE OF _LIGHTBLUE ENDOF
NUMBER_YELLOW OF _YELLOW ENDOF
NUMBER_GRAY OF _GRAY ENDOF
NUMBER_LIGHTGRAY OF _LIGHTGRAY ENDOF
NUMBER_WHITE OF _WHITE ENDOF
NUMBER_BLACK OF NEAR_BLACK ENDOF
NUMBER_ORANGE OF _ORANGE ENDOF
NUMBER_MAGENTA OF _MAGENTA ENDOF
NUMBER__VERYLIGHTGRAY2 OF _VERYLIGHTGRAY ENDOF
NUMBER_VERYLIGHTGRAY OF _VERYLIGHTGRAY ENDOF
ENDCASE
;
   

100 VALUE coord_start_X   \ coordinates of game-board
170 VALUE coord_start_Y


0 VALUE potential_direction

4 VALUE board_size.tiny   
6 VALUE board_size.small   
8 VALUE board_size.medium   
10 VALUE board_size.large   
12 VALUE board_size.huge   
board_size.tiny VALUE board_size

board_size  1 - VALUE last_selected_y
0 VALUE last_selected_x   

48 VALUE sq_size_   \ size of square

0 VALUE stack_X
0 VALUE ret_X

: stack_X()
coord_start_X sq_size_ board_size * 30 + + TO stack_X
   ;

: ret_X()
coord_start_X sq_size_ board_size * 130 + + TO ret_X
   ;   
   
stack_X() ret_X()


: show_stack _YELLOW SETCOLOR
   stack_X coord_start_Y TEXTXY " DATA STACK"
   PRINT
   9 1 DO
   stack_X I 20 * 34 +  coord_start_Y +
   OVER OVER TEXTXY  "             " PRINT TEXTXY
   I 1 -
   DUP VSDEPTH < 
       IF CELLS VSTACK + @ .
      ELSE   DROP
      THEN
   LOOP
   
   GREEN SETCOLOR
   ret_X coord_start_Y TEXTXY " RETURN STACK"
   PRINT
   9 1 DO
   ret_X I 20 * 34 +  coord_start_Y + 
   OVER OVER TEXTXY  "             " PRINT TEXTXY 
   I 1 -
   DUP VRSDEPTH < 
       IF CELLS VRSTACK + @ .
      ELSE DROP
      THEN
   LOOP
   
   ;   

: VS_ERR_PRINT
   _RED SETCOLOR 0 > IF
   stack_X coord_start_Y 194 +  TEXTXY "  OVERFLOW   " PRINT
   ELSE
   stack_X coord_start_Y 54 +  TEXTXY "  UNDERFLOW  " PRINT
   THEN ;

: VRS_ERR_PRINT
   _RED SETCOLOR 0 > IF
   ret_X coord_start_Y 194 +  TEXTXY "  OVERFLOW   " PRINT
   ELSE
   ret_X coord_start_Y 54 +  TEXTXY "  UNDERFLOW  " PRINT
   THEN ;
   
: TO_RET
   VS> GET_VSTACK_ERR
   DUP
   IF ERROR_POS VS_ERR_PRINT
   ELSE
   DROP >VRS
   GET_VRSTACK_ERR
      DUP
      IF ERROR_POS VRS_ERR_PRINT >VS
      ELSE DROP show_stack
      THEN
   THEN   
   ;
   ' TO_RET TO K_PGUP
: FROM_RET
   VRS> GET_VRSTACK_ERR
   DUP
   IF ERROR_POS VRS_ERR_PRINT
   ELSE
   DROP >VS
   GET_VSTACK_ERR
      DUP
      IF ERROR_POS VS_ERR_PRINT >VRS
      ELSE DROP show_stack
      THEN
   THEN   
   ;
   ' FROM_RET TO K_PGDOWN   


0   VALUE  square_tick.tickness
0   VALUE  square_tick.size
0   VALUE  square_tick.color

: square_tick       \ ( X Y color size tick --> )
   TO square_tick.tickness TO square_tick.size
   TO square_tick.color

\ (presently: X Y  )
   OVER OVER  square_tick.size +
   square_tick.tickness 0 DO OVER OVER  I -  square_tick.size square_tick.color HLINE LOOP
   DROP square_tick.size +  OVER
   square_tick.tickness 0 DO OVER  I - OVER square_tick.size square_tick.color VLINE LOOP
   DROP DROP
   square_tick.tickness 0 DO OVER  I + OVER square_tick.size square_tick.color VLINE LOOP
   square_tick.tickness 0 DO OVER  OVER I + square_tick.size square_tick.color HLINE LOOP
   DROP DROP   
   ;
   

CREATE ARR 32 CELLS ALLOT

: elementes... SWAP CELLS ARR + ! ;

1 1 VALUE    _?      "  ?"   elementes...
2 2 VALUE    _NOT  " NOT"   elementes...
4 4 VALUE    _INVerse  " INV"   elementes...
5 5 VALUE    _OR   "  OR"  elementes...
3 3 VALUE    _XOR  " XOR"    elementes...
6 6 VALUE    _AND  " AND"  elementes...
8 8 VALUE    _DUP  " DUP"   elementes...
7 7 VALUE    _+   "  + "  elementes...
9 9 VALUE    _-    "  - "  elementes...
10 10 VALUE    _*    "  * "  elementes...
11 11 VALUE    _/    "  / "  elementes...
12 12 VALUE    _<>   " <> "  elementes...
13 13 VALUE    _<    "  < "  elementes...
14 14 VALUE    _>    "  > "  elementes...
15 15 VALUE    _=    "  = "  elementes...
16 16 VALUE    _ROT    " ROT"  elementes...
17 17 VALUE    _:))    " :))"  elementes...
18 18 VALUE    _NIP    " NIP"  elementes...
19 19 VALUE    _MOD    " MOD"  elementes...
20 20 VALUE    _MIN    " MIN"  elementes...
21 21 VALUE    _MAX    " MAX"  elementes...
21 VALUE elementes_all

: do_?  -1 ;
: do_NOT VSDEPTH 1 < IF 0 ELSE VS> NOT >VS -1 THEN ;
: do_INVerse VSDEPTH  1 < IF 0 ELSE VS> -1 XOR >VS -1 THEN ;
: do_OR VSDEPTH 2 < IF 0 ELSE VS> VS> OR >VS -1 THEN ;
: do_XOR VSDEPTH 2 < IF 0 ELSE VS> VS> XOR  >VS -1 THEN ;
: do_AND VSDEPTH 2 < IF 0 ELSE VS> VS> AND >VS -1 THEN ;
: do_DUP VSDEPTH 7 > IF 0 ELSE VS> DUP >VS >VS -1 THEN ;
: do_+ VSDEPTH 2 < IF 0 ELSE VS> VS> + >VS -1 THEN ;
: do_- VSDEPTH 2 < IF 0 ELSE VS> VS>  SWAP - >VS -1 THEN ;
: do_* VSDEPTH 2 < IF 0 ELSE VS> VS> * >VS -1 THEN ;
: do_/ VSDEPTH 2 < VS> DUP >VS  0 = OR IF 0 ELSE VS> VS>  SWAP / >VS -1 THEN ;
: do_<> VSDEPTH 2 < IF 0 ELSE VS> VS> = NOT >VS -1 THEN ;
: do_< VSDEPTH 2 < IF 0 ELSE VS> VS>  SWAP < >VS -1 THEN ;
: do_> VSDEPTH 2 < IF 0 ELSE VS> VS>  SWAP > >VS -1 THEN ;
: do_= VSDEPTH 2 < IF 0 ELSE VS> VS>  = >VS -1 THEN ;
: do_ROT VSDEPTH 3 < IF 0 ELSE VS>  VS>  VS>  SWAP >VS  SWAP >VS >VS -1 THEN ;
: do_:)) VRSTACK_P 0 = VSTACK_P 0 > AND  VS> 0 = AND IF END_SUCCESS 0 TO game?_value -1 ELSE 0 THEN ;
: do_NIP VSDEPTH 2 <  IF 0 ELSE VS>  VS>  DROP >VS -1 THEN ;
: do_MOD VSDEPTH 2 < VS> DUP >VS  0 = OR IF 0 ELSE VS> VS>  SWAP MOD >VS -1 THEN ;
: do_MIN VSDEPTH 2 <  IF 0 ELSE VS>  VS>  OVER OVER < IF DROP  >VS ELSE >VS DROP THEN -1 THEN ;
: do_MAX VSDEPTH 2 <  IF 0 ELSE VS>  VS>  OVER OVER > IF DROP  >VS ELSE >VS DROP THEN -1 THEN ;
 

: element_execute

CASE
_?     OF      do_?   ENDOF
_NOT   OF      do_NOT   ENDOF
_INVerse   OF      do_INVerse   ENDOF
_OR    OF      do_OR   ENDOF
_XOR   OF      do_XOR   ENDOF
_AND   OF      do_AND   ENDOF
_DUP   OF      do_DUP   ENDOF
_+     OF      do_+   ENDOF
_-     OF      do_-   ENDOF
_*     OF      do_*   ENDOF
_/     OF      do_/   ENDOF
_<>    OF      do_<>   ENDOF
_<     OF      do_<   ENDOF
_>     OF      do_>   ENDOF
_=     OF      do_=   ENDOF
_ROT   OF      do_ROT   ENDOF
_:))   OF      do_:))   ENDOF
_NIP   OF      do_NIP   ENDOF
_MOD   OF      do_MOD   ENDOF
_MIN   OF      do_MIN   ENDOF
_MAX   OF      do_MAX   ENDOF
ENDCASE

   ;


\ board

HERE 144 CELLS ALLOT VALUE PATH_VECT 0 VALUE PATH_VECT_point
HERE 144 CELLS ALLOT VALUE PATH_BOARD
HERE 144 CELLS ALLOT VALUE GAME_BOARD
HERE 144 CELLS ALLOT VALUE COLOR_BOARD
HERE 144 CELLS ALLOT VALUE VALUES_RESULTS
HERE 576 CELLS ALLOT VALUE REVERSE_BOARD
HERE 4096 CELLS ALLOT VALUE DATASTACK_
HERE 4096 CELLS ALLOT VALUE RETSTACK_

: BOARD_ 0 PATH_BOARD 144 FILL 0 REVERSE_BOARD 144 FILL  ;

: PATH_BOARD_add 4 last_selected_x last_selected_y  board_size * + CELLS PATH_BOARD + !
   ;
: PATH_BOARD_away 0 SWAP CELLS PATH_BOARD + !
   ;
: PATH_VECT_add PATH_VECT_point DUP CELLS PATH_VECT + potential_direction  SWAP !
1 + TO PATH_VECT_point
   ;
: PATH_VECT_add_from_stack  PATH_VECT_point DUP 1 + TO PATH_VECT_point
CELLS PATH_VECT + !
   ;
: PATH_VECT_away PATH_VECT_point 1 - DUP   CELLS PATH_VECT + @ SWAP
TO   PATH_VECT_point
   ;

: stacks_store.copy_data \ ( address - )
CELLS 9 * 8 0 DO DUP I CELLS + DATASTACK_ + I CELLS VSTACK + @ SWAP ! LOOP
8 CELLS + DATASTACK_ + VSTACK_P SWAP !
;
: stacks_store.copy_ret \ ( address - )
CELLS 9 *  8 0 DO DUP I CELLS + RETSTACK_ + I CELLS VRSTACK + @ SWAP ! LOOP
8 CELLS + RETSTACK_ + VRSTACK_P SWAP !
;


: stacks_store
DUP stacks_store.copy_data
stacks_store.copy_ret
;

: stacks_cansel.copy_data \ ( address - )
CELLS 9 *  8 0 DO DUP I CELLS + DATASTACK_ + @ I CELLS VSTACK +  ! LOOP
8 CELLS + DATASTACK_ + @  TO VSTACK_P
;
: stacks_cansel.copy_ret \ ( address - )
CELLS 9 *   8 0 DO DUP I CELLS + RETSTACK_ + @ I CELLS VRSTACK +  ! LOOP
8 CELLS + RETSTACK_ + @  TO VRSTACK_P
;

: stacks_cansel
DUP stacks_cansel.copy_data
stacks_cansel.copy_ret
;


36 VALUE show_boards.color_size \ размер цвета поля (или поля цвета  )
5 VALUE show_boards.color_tick \ толщина поля цвета
7 VALUE show_boards.color_shift \ сдвиг поля цвета
42 VALUE show_boards.pos_size \ размер квадратика. обозн. позицию
4 VALUE show_boards.pos_shift \ сдвиг квадратика. обозн. позицию
5 VALUE show_boards.pos_tick  \ толщина квадратика. обозн. позицию
9 VALUE show_boards.mark_size  \  размер маркера возврата (допустимость бэк...)
5 VALUE show_boards.mark_tick \  толщина маркера возврата (допустимость бэк...)
30 VALUE show_boards.mark_shift \ сдвиг  маркера возврата

14 VALUE show_boards.text_shift




: color_board
12 0 DO
12 0 DO
J board_size * I + CELLS COLOR_BOARD +
I 2 / 2 MOD 0 =  J 2 /  2 MOD  0 = XOR IF NUMBER_LIGHTBLUE ELSE NUMBER_ORANGE THEN SWAP !

LOOP
LOOP
  NUMBER_RED board_size 1 - CELLS COLOR_BOARD + !
  NUMBER_RED board_size DUP 1 - * CELLS COLOR_BOARD + !
;
color_board


0 VALUE show_board.temp

: last_selected_abs  last_selected_y board_size * last_selected_x  +  CELLS ;

: show_board \ ( -- )
\  доску

board_size 0
   DO
   board_size 0
      DO
       sq_size_ I * coord_start_X +  sq_size_ J * coord_start_Y +
      OVER OVER  \ серый квадрат
       2 + SWAP 2 + SWAP
       _GRAY sq_size_ 2 - 2 square_tick
     
      OVER show_boards.text_shift + OVER show_boards.text_shift +
      J board_size * I + CELLS COLOR_BOARD + @
      J board_size * I + CELLS PATH_BOARD + @ +
      color...
      SETCOLOR
      TEXTXY J board_size * I + CELLS GAME_BOARD + @
      DUP ABS 256 >
      IF DUP 0 < IF  -1 * 255 AND -1 * ELSE  255 AND THEN .
      ELSE CELLS ARR + @  PRINT
      THEN
     
      OVER show_boards.color_shift + OVER  show_boards.color_shift +
      J board_size * I + CELLS COLOR_BOARD + @
      J board_size * I + CELLS PATH_BOARD + @  +
      color...
      show_boards.color_size show_boards.color_tick 
      square_tick
     
     
      J board_size * I + CELLS REVERSE_BOARD + @
      DUP 0 = IF DROP DROP DROP ELSE TO show_board.temp
      OVER  show_boards.mark_shift + 2 + OVER  show_boards.mark_shift + 2 +
      show_board.temp
      color... 
      show_boards.mark_size 2 -  show_boards.mark_tick square_tick
      SWAP show_boards.mark_shift + SWAP  show_boards.mark_shift +
      0 
      show_boards.mark_size 2 square_tick

      THEN
      LOOP
   LOOP
   
      sq_size_ last_selected_x * coord_start_X +  sq_size_ last_selected_y * coord_start_Y +
      SWAP show_boards.pos_shift + SWAP  show_boards.pos_shift +
      _WHITE
      show_boards.pos_size show_boards.pos_tick square_tick
     
      show_stack
;



: startxy
board_size  1 - TO last_selected_y
0 TO last_selected_x
;




: clear_two
last_selected_x sq_size_  * coord_start_X +  sq_size_ last_selected_y * coord_start_Y +
_BLACK sq_size_ DUP 2 / square_tick
sq_size_  * coord_start_Y + SWAP sq_size_  * coord_start_X + SWAP
_BLACK sq_size_ DUP 2 / square_tick
;

: possibility_before
   
   OVER OVER board_size * + CELLS DUP
   PATH_BOARD + @ 0 = SWAP
   COLOR_BOARD + @ last_selected_x
   last_selected_y board_size * + CELLS COLOR_BOARD + @ =
   VRSDEPTH 0 = OR AND
   ;

   
: step_to_do
last_selected_x last_selected_y board_size * + stacks_store
OVER OVER board_size * + CELLS GAME_BOARD  + @
DUP ABS 256 >
      IF DUP 0 < IF  -1 * 255 AND -1 * ELSE  255 AND THEN  >VS
      GET_VSTACK_ERR DUP IF VS_ERR_PRINT   0   ELSE DROP -1 THEN
      ELSE element_execute
      THEN     
   ;
   
: game_step
   TO potential_direction
   possibility_before
   IF  step_to_do 
      IF   PATH_BOARD_add PATH_VECT_add 
         OVER OVER
         clear_two TO last_selected_y  TO last_selected_x  show_board   
      ELSE ERROR_POS DROP DROP   
      THEN
    ELSE ERROR_POS   DROP DROP 
   THEN
   ;

: _right
game?
IF last_selected_x board_size 1 - < IF last_selected_x 1 + last_selected_y 2 game_step ELSE ERROR_POS  THEN
THEN
;
' _right TO K_RIGHT

: _left
game?
IF last_selected_x 0 > IF last_selected_x 1 - last_selected_y 4 game_step ELSE  ERROR_POS  THEN THEN
;
' _left TO K_LEFT

: _up
game?
IF last_selected_y 0 > IF last_selected_x last_selected_y 1 - 1 game_step ELSE  ERROR_POS THEN
THEN
;
' _up TO K_UP


: _down
game?
IF last_selected_y board_size 1 - < IF last_selected_x last_selected_y 1 + 3 game_step ELSE  ERROR_POS THEN
  THEN
;
' _down TO K_DOWN



: back_move

PATH_VECT_point 0 >
game?  AND
 
IF
   PATH_VECT_away DUP
   CASE
   1   OF   last_selected_x last_selected_y 1 +   ENDOF
   2   OF   last_selected_x 1 - last_selected_y   ENDOF
   3   OF   last_selected_x last_selected_y 1 -   ENDOF
   4   OF   last_selected_x 1 + last_selected_y   ENDOF
   ENDCASE 
   OVER OVER board_size * + CELLS REVERSE_BOARD + DUP @
   NUMBER_RED =
   IF 
   ERROR_POS   DROP  DROP  DROP  PATH_VECT_add_from_stack
   ELSE 
   DUP @  1 + SWAP ! OVER OVER board_size * + PATH_BOARD_away 
    OVER OVER board_size * + stacks_cansel   
    OVER OVER clear_two   
    TO last_selected_y  TO last_selected_x  DROP
    show_board 
   THEN

ELSE ERROR_POS THEN
;
' back_move DUP DUP TO K_F10 TO K_F11 TO K_F12



\  GAME BEGIN начало игры и т.п. загрузка новых игр по пути наименьшего сопротивления
0 VALUE game_map.index 0 VALUE game_map.err 0 VALUE game_map.non

: E,EXEM DROP -1 TO game_map.err ;
: E,EM game_map.err IF DROP  ELSE  TO game_map.err THEN ;
: N,EM game_map.non IF DROP  ELSE  TO game_map.non THEN ;
: E,? game_map.index DUP board_size DUP * >
IF E,EXEM ELSE DUP 1 + TO game_map.index CELLS GAME_BOARD + !  THEN ;
: E, DUP elementes_all > OVER 1 < OR IF E,EM ELSE E,?  THEN  ;
: N,? DUP 0 < IF -512 + ELSE 512 + THEN E,? ;
: N, DUP ABS 99 > IF N,EM ELSE N,?  THEN  ;

\ массив доступных игр
HERE 8 2 * CELLS ALLOT VALUE available_games 
0 VALUE available_games_point
\ 2 CELLS - строка описания игры и адрес слова-загрузчика, которое содержит (загружает) данные
: available_games.to \ ( xt c-addr -- success  number )
      available_games_point 14 >
      IF
      " слишком много элементов для available_games " PRINT 0
      ELSE
      available_games_point  CELLS available_games + !
      available_games_point 1 + CELLS available_games + ! -1
      available_games_point DUP 2 + TO available_games_point
      THEN     
      ;
     
\ игра должна определеяться словом  ????
\ :   ???? ['] game_description   " game verbal description "  available_games.to ;  ????


: example_4
board_size.tiny TO board_size     
color_board  \ стандарт, или можно определить своё
startxy  \ стандарт, или можно определить своё
\ доска
2   N,   _NIP   E,   _<>   E,   _:))   E,
5   N,   _NIP   E,   _MOD   E,   _<>   E,
7   N,   _+   E,   _NIP   E,   _NIP   E,
_?   E,   6   N,   4   N,   3   N,


\ стек так и выглядит
11 >VS
10 >VS
9 >VS
8 >VS
1 >VS 
   ;
:  example_4_des ['] example_4   " простой пример 4x4 игры со словами NIP MOD " 
available_games.to ;   
                        example_4_des DROP DROP
\ end example game description

VECT game.map 0 VALUE game.descr
0 VALUE game.last
0 VALUE game.lastp
: new_game   \ ( number -- )
   DUP 12 > OVER  1 + CELLS available_games + @ 0 = OR
   
   IF " ненормальный номер игры " PRINT DROP
   ELSE
   DUP TO game.lastp DUP
   CELLS available_games + @ TO game.descr 1  + CELLS  available_games + @ TO game.map
   0 TO game_map.index 0 TO game_map.err 0 TO game_map.non
   0 TO VSTACK_P 0 TO VRSTACK_P
   game.map 
   game_map.err  game_map.non OR
   last_selected_x last_selected_y board_size * + CELLS GAME_BOARD + @ _? = NOT OR
   0 = IF
      game.lastp TO game.last \ потенциальный номер игры в реально последню
     \ этот номер будет использоваться циклом игр F3 и "началом той же самой заново" по F2
      stack_X() ret_X()
      BOARD_
      0 TO PATH_VECT_point
      CLS show_board coord_start_X  coord_start_Y  28 - TEXTXY _LIGHTGRAY SETCOLOR game.descr PRINT
      -1 TO game?_value
      ELSE
      CLS
      0 TO game?_value
      show_board 
      coord_start_X  coord_start_Y  28 - TEXTXY
      " невозможно загрузить игру: ошибка в расположении элементов либо начальной позиции"  PRINT
      THEN
   THEN
;


: game_cycle game.last 2 +
      DUP
      14 > OVER CELLS available_games + @ 0 = OR IF DROP 0  THEN
      DUP
       CELLS available_games + @ 0 = IF 160 90 TEXTXY " No available games " PRINT DROP ELSE new_game THEN
   ;
   ' game_cycle TO K_F3
   
: game_again   
   game.last DUP
   CELLS available_games + @ 0 =
   IF 160 90 TEXTXY " No available games " PRINT DROP ELSE new_game THEN
;
' game_again TO K_F2

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 

: example_6b
board_size.small TO board_size     
color_board  \ стандарт
startxy  \ стандарт
\ доска
3   N,   -3   N,   -4   N,   _+   E,   _MAX   E,   _:))    E,
-3   N,   3   N,   -3   N,   _NIP   E,   _XOR   E,   _MAX   E,
_OR   E,   _-   E,   4   N,   -4   N,   _NIP   E,   _-   E,
5   N,   6   N,   -4   N,   4   N,   -3   N,   -4   N,
7   N,   8   N,   10   N,   _+   E,   3   N,   -3   N,
_?   E,   9   N,   11   N,   _XOR   E,   -3   N,   3   N,



\ стек
1 >VS
2 >VS
3 >VS
4 >VS
4 >VS
4 >VS 
   ; 
:  example_6b_des ['] example_6b   " пример игры 6х6 c операторами MAX MIN NIP - обнаружено 1 решениe " 
   available_games.to ;   
                        example_6b_des  DROP DROP
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 

\ -------------------------------------------------------------------------                       

\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ 

: example_6c
board_size.small TO board_size     
color_board  \ стандарт
startxy  \ стандарт
\ доска
5   N,   0   N,   1   N,   _NIP   E,   _<>   E,   _:))   E,
2   N,   _NIP   E,   3   N,   2   N,   _NIP   E,   _<>   E,
7   N,   _NIP   E,   _NOT   E,   5      N,   3   N,   _NIP   E,
9   N,   _+   E,   _XOR   E,   _OR   E,   7   N,   4   N,
3   N,   4   N,   _NIP   E,   _NIP   E,   _NIP   E,   9   N,
_?   E,   0   N,   0   N,   1   N,   2   N,   5   N,

\ стек
10 >VS
9 >VS
8 >VS
7 >VS
6 >VS
-4 >VS 
   ; 
:  example_6c_des ['] example_6c   " пример  6х6 где интенсивно используется NIP :)  "  available_games.to ;   
                        example_6c_des  DROP DROP
                       
                       
\ -------------------------------------------------------------------------   
                 


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
 Заголовок сообщения: Re: Ещё игрушка "логический лабиринт" ,
СообщениеДобавлено: Вт июл 13, 2010 21:34 
Не в сети

Зарегистрирован: Вт май 09, 2006 12:31
Сообщения: 3438
Благодарил (а): 5 раз.
Поблагодарили: 16 раз.
Подумал - что если не все понимают правила игры - может быть, тему читают не только фортеры

поэтому иллюстрация на примере 4х4 задачи из предыдущего постинга

(прошу прощения, если рисунки велики - не было времени их аккуратно отредактировать)

Изображение
итак - стартовая позиция 1.
ЧТо если "лабиринт" проходится так просто, кратчайшим путём?
Попробуем, пойдём лесенкой вправо-вверх и так дальше
Сначала вправо - позиция 2 - мы встречаем цифру и игра, как и обычный форт в режиме интерпретации , разбирая исходник, кладёт цифру на стек
Потом вверх - позиция 3 - 6 прибавилось к 1 и получилось 7
Потом снова вправо - позиция 4 : теперь работает NIP

Однако, нас постигнет неудача в конце "лесенки"
Изображение
мы не можем перейти в верхнее правое поле, т.к. на стеке данных - не 0

Попробуем анализировать ситуацию, составить план прохождения лабиринта.
Для начала мы замечаем, что оба поля, через которые можно попасть на выиграшное поле :)) - это операторы "не равно" <>
Это означает,что 0 на стеке может образоваться, если мы перейдём на эти поля с двумя равными цифрами на вершине стека.
Т.е. если перед тем, как ступить на поле "не равно" мы будем иметь равные цифры, оператор даст 0 и дальше с этим нулём мы попадём на :))

Попробуем получить равные цифры. Предпримем опять наивную попытку. На стеке и на поле все цифры разные, т.о. чтобы получить одинаковые , нужны над ними какие-то действия (и действий на поле немного - плюс и MOD :D )
Изображение
Мы замечаем, что если сложить 2ю и 3ю на стеке цифры, то получится 9 и это приведёт к образованию 2 девяток подряд, нам мешает 6 , которую можно временно убрать на стек возвратов
получается : шаг вправо - положить 6 на стек возвратов - перейти на +
Всё хорошо, теперь нужно доставить две девятки к :)) , точнее к <>
8)
Изображение
Не тут то было, способа сделать так, чтобы эти 2 цифры оказались в нужный момент не существует.
Для начала, придётся вернуть на стек 6, иначе с заполненным стеком игра не выпустит нас за пределы бирюзового цвета, а дальше - нет оператора, который убирал бы одну цифру со стека не задевая вторую ... :D

Тем не менее, это всё-таки очень нетру дная задача и имеет множество решений.
Для того, чтобы попасть в конечную позицию, достаточно произвести 4 действия
Изображение
1. С достаточным количеством цифр любым путём подойти к полю с " не равно" , ступив на него, получить на стеке -1
1.а Вспомнить, что Х -1 MOD всегда даст 0
2. получить упомянутый 0, перейдя на MOD

Изображение
3. сохранить 0 клавишей PGUP на стек возвратов
4. перейти на другое поле с "не равно" , т.к. все три поля одного цвета

дальше понятно - 0 возвращается на стек данных и игра окончена


Вернуться к началу
 Профиль Отправить личное сообщение  
Ответить с цитатой  
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 22 ]  На страницу 1, 2  След.

Часовой пояс: UTC + 3 часа [ Летнее время ]


Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы не можете начинать темы
Вы можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
phpBB сборка от FladeX // Русская поддержка phpBB