// 2011.06.30 # Doj
// Главный файлы игры "snake journey" на конкурс IGDC

include" units\statements\switch.de"

include" units\headers\windows.de"
include" units\headers\gl.de"

27 constant KEY_ESCAPE
VK_LEFT constant KEY_LEFT
VK_RIGHT constant KEY_RIGHT
VK_UP constant KEY_UP
VK_DOWN constant KEY_DOWN

include" graph.de"
include" lab.de"
include" level.de"
include" audio.de"

include" text.de"
include" fonts\common.de"


// 0 player-x !
// 0 player-y !

pchar" DEMBRO_WND" constant DEMBRO_WND
  WS_VISIBLE
  // WS_OVERLAPPEDWINDOW or
  // WS_POPUP or 
  // WS_CAPTION or 
  constant DEMBRO_STYLE
800 constant WIDTH
600 constant HEIGHT
variable *exit?
variable *handle
variable *dc
variable *rc
variable *pixel-format
variable *lastrender

create *window-rect
  0 , // left
  0 , // top
  0 , // right
  0 , // bottom

: window-x *window-rect @ ;
: window-y *window-rect cell+ @ ;
: window-width *window-rect 2 cells + @ ;
: window-height *window-rect 3 cells + @ ;
// Изначально в *window-rect записываются координаты верхнего левого и нижнего
// правого углов. Эта команда преобразует координаты нижнего правого угла в
// размеры окна
: calc-window-size 
                     window-width  window-x - *window-rect 2 cells + ! 
                     window-height window-y - *window-rect 3 cells + ! 
;
: update-window-rect *handle @ *window-rect GetWindowRect drop
                     calc-window-size
;

create *mouse
  0 , // x
  0 , // y

: update-mouse-pos *mouse GetCursorPos drop
                   update-window-rect
                   *mouse @ *window-rect @ - *mouse ! 
                   *mouse cell+ @ *window-rect cell+ @ - *mouse cell+ ! 
;
: mouse-x *mouse @ ;
: mouse-y *mouse cell+ @ ;

: Quit *exit? on 0 PostQuitMessage ;

: OnKeyDown ( i-) 
  switch
    KEY_LEFT of ( do-left) KEY_LEFT *last-arrow ! \of
    KEY_RIGHT of ( do-right) KEY_RIGHT *last-arrow ! \of
    KEY_DOWN of ( do-down) KEY_DOWN *last-arrow ! \of
    KEY_UP of ( do-up) KEY_UP *last-arrow ! \of
    KEY_ESCAPE of Quit \of
  \switch
;
: OnKeyUp ( i-) drop
  // *last-arrow @ = if *last-arrow off then
  // timer *last-step-time !
;
: OnChar ( i-) drop ;
: OnLButtonDown ( -) ." Left mouse " update-mouse-pos mouse-x . mouse-y .
                     *window-rect @ . cr ;
: OnLButtonDoubleClick ( -) ;
: OnRButtonDown ( -) ;
: OnMButtonDown ( -) ;
: OnMoving ( p-) *window-rect 4 cells move calc-window-size ;

// Функция WindowsProc, в неё будут передаваться сообщения, приходящие
// окну из системы.
:noname  ( hWnd:uint Msg:uint wParam:int lParam:int -- )
     3 pick switch 
       WM_DESTROY       of drop drop drop drop Quit \of
       WM_KEYDOWN       of drop OnKeyDown drop drop \of
       WM_KEYUP         of drop OnKeyUp drop drop \of
       WM_CHAR          of drop OnChar drop drop \of
       WM_LBUTTONDOWN   of drop drop drop drop OnLButtonDown \of
       WM_LBUTTONDBLCLK of drop drop drop drop OnLButtonDoubleClick \of
       WM_RBUTTONDOWN   of drop drop drop drop OnRButtonDown \of
       WM_MBUTTONDOWN   of drop drop drop drop OnMButtonDown \of
       WM_MOVING        of OnMoving drop drop drop \of
       DefWindowProcA 
     \switch
; :c WindowProc t_WindowProc c;

: keys-update
  *last-arrow @ switch
    KEY_LEFT of do-left \of
    KEY_RIGHT of do-right \of
    KEY_DOWN of do-down \of
    KEY_UP of do-up \of
  \switch
;

// Структура WNDCLASSEX
0 value hCursor
0 value hIcon
0 value lpszClassName
create WNDCLASSEX
    here // см. в конце подсчёт размера
    0 , // cbSize
    CS_HREDRAW 
    CS_VREDRAW or 
    CS_OWNDC or , // style
    WindowProc , // WndProc
    0 , // cbClsExtra
    0 , // cbWndExtra
    0 , // hInstance
    here to hIcon 0 ,
    here to hCursor 0 ,
    0 , // hbrBackground
    0 , // lpszMenuName
    here to lpszClassName 0 ,
    0 , // hIconSm
    here swap - WNDCLASSEX ! // заполняем cbSize


// Функция, создающая новый класс окна
// На выходе — флаг успеха
: CreateWindowClass ( -f) 0 IDC_ARROW       LoadCursorA  hCursor !
                          0 pchar" Icon_1"  LoadIconA    hIcon   !
                          DEMBRO_WND               lpszClassName !
                          WNDCLASSEX RegisterClassExA ;

// Функция, создающая окно
// Возвращает HANDLE окна. Если он равен 0, то при создании окна произошла
// ошибка
: CreateWindow ( -i) WS_EX_APPWINDOW ( WS_EX_WINDOWEDGE or) 
                     DEMBRO_WND pchar" snake journey by Doj for IGDC" DEMBRO_STYLE
                     160 0 WIDTH HEIGHT ( xywh) 0 0 0 0
                     CreateWindowExA ;

: as-uint32, uint->uint32 uint32, ;
: as-uint16, uint->uint16 uint16, ;
: as-uint8, uint->uint8 uint8, ;
// : as-uint32, , ;
// : as-uint16, , ;
// : as-uint8,  , ;

// Структура PIXELFORMATDESCRIPTOR
0 value dwFlags
0 value hIcon
0 value lpszClassName
create PIXELFORMATDESCRIPTOR
    here // см. в конце подсчёт размера
    0 as-uint16, // nSize
    2 as-uint16, // nVersion
      PFD_DRAW_TO_WINDOW 
      PFD_SUPPORT_OPENGL or 
      PFD_DOUBLEBUFFER or as-uint32, // dwFlags uint32
    PFD_TYPE_RGBA as-uint8, // iPixelType
    32 as-uint8, // cColorBits
    0  as-uint8, // cRedBits 
    0  as-uint8, // cRedShift 
    0  as-uint8, // cGreenBits 
    0  as-uint8, // cGreenShift 
    0  as-uint8, // cBlueBits 
    0  as-uint8, // cBlueShift 
    0  as-uint8, // cAlphaBits 
    0  as-uint8, // cAlphaShift 
    0  as-uint8, // cAccumBits 
    0  as-uint8, // cAccumRedBits 
    0  as-uint8, // cAccumGreenBits 
    0  as-uint8, // cAccumBlueBits 
    0  as-uint8, // cAccumAlphaBits 
    24 as-uint8, // cDepthBits
    8  as-uint8, // cStencilBits
    0  as-uint8, // cAuxBuffers 
    PFD_MAIN_PLANE as-uint8, // iLayerType
    0  as-uint8, // bReserved 
    0  , // dwLayerMask
    0  , // dwVisibleMask
    0  , // dwDamageMask
    here swap - uint->uint16 PIXELFORMATDESCRIPTOR uint16! // заполняем cbSize

// Функция, инициализирующая OpenGL
: grInit
       *handle @ GetDC dup *dc !
       ." GetDC: " . cr
       *dc @ PIXELFORMATDESCRIPTOR ChoosePixelFormat dup *pixel-format !
       ." ChoosePixelFormat: " . cr
       *dc @ *pixel-format @ PIXELFORMATDESCRIPTOR SetPixelFormat
       ." SetPixelFormat: " . GetLastError uint. cr
       *dc @ wglCreateContext dup *rc !
       ." wglCreateContext: " . cr
       *dc @ *rc @ wglMakeCurrent
       ." wglMakeCurrent: " . cr
       // *handle @ SW_SHOW ShowWindow
       GL_SMOOTH glShadeModel 
       ." glShadeModel done"cr
;
// 2d режим
: gr2D 
       0 0 WIDTH HEIGHT      glViewport
       GL_PROJECTION         glMatrixMode
                             glLoadIdentity
       0      int->double 
       WIDTH  int->double
       HEIGHT int->double 
       0      int->double
       -1     int->double
       1      int->double    glOrtho
       GL_MODELVIEW          glMatrixMode
                             glLoadIdentity
;

: float-random frandom float-f>w ;

// очистить экран
: grClear
       ( 
       timer int->float float-w>f 1000 int->float float-w>f f/ 
       fdup fsin float-f>w 
       fdup fcos float-f>w
            fsin float-f>w
              f1 float-f>w) 
       0 int->float dup dup dup glClearColor
       GL_COLOR_BUFFER_BIT glClear
;

// *msg* — сюда будем получать инфу о приходящих сообщениях
create *msg*
    0 , // hWnd
    0 , // message
    0 , // wParam
    0 , // lParam
    0 , // time
    0 , // pt.x
    0 , // pt.y

// Проверяет произошла ли ошибка, сравнивая i с нулём. Если равна, то печатает
// на консоль строку s и код, возвращённый вызовом GetLastError, иначе нет. 
// На консоль кладёт флаг ошибки, выставленный если ошибка имела место.
: check' ( i B: s - f) if bdrop false else ." ! Failed " str. 
                         ."  " GetLastError . cr true then ;
// Слово немедленного исполнения. Выполняет check' и если была ошибка,
// то выходит из текущей команды если возвращённый командой check' флаг выставлен
// в true
: check ( C:) ( B: s R: i) compile check' ['] if execute compile exit 
                                          ['] then execute ; immediate

include" levels\list.de"
  LEVEL *last-level @ next ^

// Главная функция, точка входа в программу
:noname
  windows-load // загружаем WinApi функции
  CreateWindowClass [str]" creating window class" check
  CreateWindow dup *handle ! dup [str]" creating window" check
  opengl-load // загружаем OpenGL функции
  init-audio // инициализируем звуковую подсистему
  pchar" data\music\sun.xm" music drop
  grInit
  gr2D
  *exit? off
  begin
    check-next-level
    // wp . cr
    ( timer *lastrender @ - 50 >) true if
      grClear
      gr2D
      update
      // 0 0 640 480 draw-line2i
        // player-x @ x->global
        // player-last-x @ x->global player-x @ x->global delta-linear-comb
        // player-y @ y->global
        // player-last-y @ y->global player-y @ y->global delta-linear-comb
        // do-player-render
        snake-render
        // 16 16 draw-recti
      do-render-maze
      // 0 int->float 0 int->float 640 int->float 480 int->float draw-line2f
      // glFlush
      // glFinish
      *dc @ SwapBuffers drop // not if ." SwapBuffers error" cr exit then
      timer *lastrender !
    then
    begin
      *msg* 0 0 0 PM_REMOVE PeekMessageA
    while
      *msg* TranslateMessage drop
      *msg* DispatchMessageA drop
    repeat
    // keys-update
  *exit? @ until
  *handle @ DestroyWindow 0= if ." Destroying windows failed" cr then
; execute
