: 2* SHL ;
: 2/ SHR ;

" kernel32.dll" LOADLIBRARY
" GetTickCount" GETPROCADDRESS CONSTANT 'GetTickCount

: GetTickCount \ ( -- ticks )
'GetTickCount API0 ;

VARIABLE RND

: RANDOMIZE GetTickCount RND ! ;
RANDOMIZE

: SGN \ ( u -- -1 | 0 | 1 )
DUP 0 = IF ELSE
DUP 0 MAX 0 = IF DROP -1 ELSE
DROP 1 THEN THEN ;

: NEGATE \ ( x -- -x )
0 SWAP - ;

: ABS \ ( x -- u )
DUP SGN -1 = IF NEGATE THEN ;


: RANDOM \  ( -- u )
RND @ 69069 * 31415 + 278720333 MOD DUP RND ! ;

: CHOOSE  \ ( u1 -- u2 )
   278720333 SWAP /
   RANDOM ABS SWAP /
;

: DUPS // Arr[1..M] M --> Arr[1..M] Arr[1..M]
DUP 0 DO
  DUP PICK SWAP
LOOP
DROP
;

: DROPS // Arr[1..M] M -->
0 DO DROP LOOP
;

// Графика
: RGB-> // Color --> R G B
65536 /MOD
256 /MOD
ROT ROT SWAP
;

: Gradient // Percent Color1 Color2 --> Color
           // Переход от цвета1 к цвету2
           // Percent - 0..100
SWAP RGB->
3 PICK RGB-> // DS: Percent Color2 R1 G1 B1 R2 G2 B2
3 PICK - 7 PICK * 100 / 3 PICK + 3 XCHG DROP // DS: Percent Color2 R1 G1 Bnew R2 G2
3 PICK - 6 PICK * 100 / 3 PICK + 3 XCHG DROP // DS: Percent Color2 R1 Gnew Bnew R2
3 PICK - 5 PICK * 100 / 3 PICK + 3 XCHG DROP // DS: Percent Color2 Rnew Gnew Bnew
RGB
2 XCHG DROP DROP
;

: FillBox // x y ширина высота цвет -->
3 PICK 2 PICK + 4 PICK DO
  4 PICK I 4 PICK 3 PICK HLINE
LOOP
5 DROPS
;

: GradientBox // x y ширина высота цвет1 цвет2 -->
  4 PICK 3 PICK + 5 PICK DO
  5 PICK I // x i
  5 PICK   // ширина
  OVER 8 PICK - 100 * 6 PICK / // Percent=(i-y)/высота
  5 PICK 5 PICK Gradient // Percent цвет1 цвет2 --> color
  HLINE
LOOP
6 DROPS
;
// Графика кончилась

// Кнопки
: FIELD
CREATE
  OVER , +
DOES>
@ +
;

: int
4 FIELD
;

0
int ->кнХ
int ->кнУ
int ->кнШирина
int ->кнВысота
int ->кнРаботай
int ->кнНадпись
int ->кнЦвет1
int ->кнЦвет2
CONSTANT Кнопка

100 VALUE MaxButtons
QUAN CurButtons
CREATE Buttons[] MaxButtons 4 * ALLOT

: СоздатьКнопку // addr -->
Кнопка ALLOT
25 OVER ->кнХ !
25 OVER ->кнУ !
96 OVER ->кнШирина !
32 OVER ->кнВысота !
0xBFBFBF  OVER ->кнЦвет1 !
0x707070  OVER ->кнЦвет2 !
" Button" OVER ->кнНадпись !
['] NOOP  OVER ->кнРаботай !
CurButtons
  SWAP OVER 4 * Buttons[] + !
1+ TO CurButtons
;

0 CONSTANT обычную
1 CONSTANT подсвеченую
2 CONSTANT нажатую

QUAN кнАдрес
QUAN dbLigth
: КнопкуРисуй // addr Подсвечивать? -->
TO dbLigth
TO кнАдрес

кнАдрес ->кнХ @
кнАдрес ->кнУ @
кнАдрес ->кнШирина @
кнАдрес ->кнВысота @
dbLigth обычную = NOT IF
  0xFFFFFF
ELSE
  50
  кнАдрес ->кнЦвет1 @
  кнАдрес ->кнЦвет2 @
  Gradient
THEN
FillBox

кнАдрес ->кнХ @ 3 +
кнАдрес ->кнУ @ 3 +
кнАдрес ->кнШирина @ 6 -
кнАдрес ->кнВысота @ 6 -
кнАдрес ->кнЦвет1 @
кнАдрес ->кнЦвет2 @
dbLigth нажатую = IF SWAP THEN
GradientBox

// Надпись на кнопке
кнАдрес ->кнХ @ 15 +
кнАдрес ->кнУ @ кнАдрес ->кнВысота @ SHR SHR +
TEXTXY
50 кнАдрес ->кнЦвет1 @ кнАдрес ->кнЦвет2 @ Gradient SETBGCOLOR
0x000000 SETCOLOR
  кнАдрес ->кнНадпись @ PRINT
0x000000 SETBGCOLOR
0x00FF00 SETCOLOR
;

: ПроверитьКнопку // addr --> 0 | -1
TO кнАдрес
0
MOUSE-X @
кнАдрес ->кнХ @ DUP
кнАдрес ->кнШирина @ +
WITHIN IF
  MOUSE-Y @
  кнАдрес ->кнУ @ DUP
  кнАдрес ->кнВысота @ +
  WITHIN IF
   DROP -1
  THEN
THEN
;

: Нажата? // addr -->
DUP ПроверитьКнопку IF
  DUP нажатую КнопкуРисуй
  ->кнРаботай @ EXECUTE
ELSE DROP THEN
;

: Подсветить? // addr -->
DUP ПроверитьКнопку IF
  подсвеченую КнопкуРисуй
ELSE DROP THEN
;

: РисоватьКнопки
CurButtons 0 DO
  Buttons[] I 4 * + @ обычную КнопкуРисуй
LOOP
;

: ЧтоНажато? // -->
CurButtons 0 DO
  Buttons[] I 4 * + @ Нажата?
LOOP
;

: ЧтоПодсветить? // -->
CurButtons 0 DO
  Buttons[] I 4 * + @ Подсветить?
LOOP
;
//  Кнопки кончились

CREATE кнЗаново
кнЗаново DUP СоздатьКнопку
  450 OVER ->кнХ !
  50  OVER ->кнУ !
  " Начать" OVER ->кнНадпись !
  DROP

20 VALUE Ширина
20 VALUE Высота
20 VALUE РазмерКвадрата
CREATE Поле Ширина Высота * ALLOT

: SetПоле // s x y -->
Ширина * + Поле + C!
;

: GetПоле // x y --> s
Ширина * + Поле + C@
;

CREATE ЦветКлетки[] 12 ALLOT
0 CONSTANT Стена RED ЦветКлетки[] !
1 CONSTANT Пусто WHITE ЦветКлетки[] 4 + !
2 CONSTANT Яблоко 0x7FFF ЦветКлетки[] 8 + !

: СоздатьПоле
Высота 0 DO
  Ширина 0 DO
   I Ширина 1- = I 0 = OR
   J Высота 1- = J 0 = OR OR IF Стена ELSE Пусто THEN
   I J SetПоле
  LOOP
LOOP
;

: СтирайПоле
0 0
Ширина РазмерКвадрата * Высота РазмерКвадрата *
0
FillBox
;

: КакойЦвет? // i --> color
4 * ЦветКлетки[] + @
;

: РисуйПоле
Высота 0 DO
  Ширина 0 DO
   I РазмерКвадрата *
   J РазмерКвадрата *
   РазмерКвадрата DUP
   I J GetПоле КакойЦвет?
   FillBox
  LOOP
LOOP
;

50 VALUE MaxLen
CREATE Змея MaxLen 2 * ALLOT
QUAN CurLen
-1 CONSTANT ТутЗмея

QUAN ВзглядЗмеи
0 CONSTANT Вверх
1 CONSTANT Вправо
2 CONSTANT Вниз
3 CONSTANT Влево

: ЗмеяSetXY // x y i -->
2* Змея +
2 PICK OVER C!
1+ C!
DROP
;

: ЗмеяGetXY // i --> x y
2* Змея +
DUP C@
SWAP
1+ C@
;

: УбитьИВозродитьЗмею
MaxLen 0 DO
  -1 DUP I ЗмеяSetXY
LOOP
3 TO CurLen
CurLen 0 DO
  CurLen 2 + I -
  Высота 2/
  I ЗмеяSetXY
LOOP
Вправо TO ВзглядЗмеи
;

: РисуйЗмею
CurLen 0 DO
  I ЗмеяGetXY
  SWAP РазмерКвадрата *
  SWAP РазмерКвадрата *
  РазмерКвадрата DUP
  I 0 = IF 0x00FF00 ELSE 0xFF0000 THEN
  FillBox
LOOP
;

: ГдеГолова? // --> x y
0 ЗмеяGetXY
;

QUAN есть?
: ТутЗмея? // x y --> 0|-1
0 TO есть?
CurLen 0 DO
  2 DUPS
  I ЗмеяGetXY
  ROT =
  ROT ROT = AND IF -1 TO есть? THEN
LOOP
2 DROPS
есть?
;

: КудаСмотрит? // --> dx dy
ВзглядЗмеи Вверх  = IF 0 -1 THEN  // dx dy
ВзглядЗмеи Вправо = IF 1  0 THEN
ВзглядЗмеи Вниз   = IF 0  1 THEN
ВзглядЗмеи Влево  = IF -1 0 THEN
;

: СледующаяКлетка // x y dx dy --> x y
ROT +
ROT ROT +
SWAP
;

: ЧтоТам? // x y --> i
2 DUPS
  ТутЗмея? // x y x y
  IF
   2 DROPS
   ТутЗмея
  ELSE
   GetПоле
  THEN
;

: СоздатьЯблоко // -->
Яблоко
0 0
BEGIN
  2 DROPS
  Ширина CHOOSE Высота CHOOSE
  2 DUPS
ЧтоТам? Пусто = UNTIL
SetПоле
;

: СъестьЯблоко // x y -->
Пусто ROT ROT SetПоле
CurLen 1+ TO CurLen
СоздатьЯблоко
;

: Ползи! // x y -->
CurLen 1 DO
  CurLen I - 1- ЗмеяGetXY
  CurLen I -    ЗмеяSetXY
LOOP
0 ЗмеяSetXY
;

: РисуйВсе
РисуйПоле
РисуйЗмею
;

: GameOver
РазмерКвадрата Ширина * 10 TEXTXY
" GAME OVER!!!" PRINT
['] NOOP TO <TIMER>
;

: развернуться // направление(0..3) -->
DUP ВзглядЗмеи + 2 MOD 0 = IF
  DROP
ELSE
  TO ВзглядЗмеи
THEN
;

: Игра
ГдеГолова?
КудаСмотрит?
СледующаяКлетка 2 DUPS ЧтоТам?
  DUP Стена  =
  OVER ТутЗмея = OR IF GameOver THEN
      Яблоко = IF 2 DUPS СъестьЯблоко THEN
Ползи!
РисуйВсе
;

: Заново
СоздатьПоле
УбитьИВозродитьЗмею
СоздатьЯблоко

РисуйВсе

100 TIMER_INTERVAL !
['] Игра TO <TIMER>
;
' Заново кнЗаново ->кнРаботай !

: Вверх!
Вверх развернуться
;

: Вправо!
Вправо развернуться
;

: Вниз!
Вниз развернуться
;

: Влево!
Влево развернуться
;

CREATE кнВверх
кнВверх DUP СоздатьКнопку
  490 OVER ->кнХ !
  160 OVER ->кнУ !
  32  OVER ->кнШирина !
  " ^" OVER ->кнНадпись !
  ' Вверх! SWAP ->кнРаботай !
' Вверх! TO K_UP

CREATE кнВправо
кнВправо DUP СоздатьКнопку
  530 OVER ->кнХ !
  200  OVER ->кнУ !
  32  OVER ->кнШирина !
  " >" OVER ->кнНадпись !
  ' Вправо! SWAP ->кнРаботай !
' Вправо! TO K_RIGHT

CREATE кнВниз
кнВниз DUP СоздатьКнопку
  490 OVER ->кнХ !
  200  OVER ->кнУ !
  32  OVER ->кнШирина !
  " v" OVER ->кнНадпись !
  ' Вниз! SWAP ->кнРаботай !
' Вниз! TO K_DOWN

CREATE кнВлево
кнВлево DUP СоздатьКнопку
  450 OVER ->кнХ !
  200 OVER ->кнУ !
  32  OVER ->кнШирина !
  " <" OVER ->кнНадпись !
  ' Влево! SWAP ->кнРаботай !
' Влево! TO K_LEFT

: LeftClick
РисоватьКнопки
ЧтоНажато?
;
' LeftClick TO <MOUSE_LEFT>

: MouseMove
РисоватьКнопки
ЧтоПодсветить?
;
' MouseMove TO <MOUSE_MOVE>

CLS
РисоватьКнопки