Keskustelu: Koodit: PL/I: Matopeli

*PROCESS MARGINS(1,160) LANGLVL(SAA2) pp(macro);
*PROCESS LIMITS(EXTNAME(100) fixedbin(63) fixeddec(31) name(100) );
*PROCESS NOT('ª^') DFT(BYVALUE);
*PROCESS INCLUDE (EXT('CPY','INC'));

Snake: package;

   /* Include win32 stuff */
   %include winbase;
   %include wingdi;
   %include winuser;
   %include commctrl;

   %include snake;  /* application include file */

 dcl MAP_SIZE    type INT value (24);
 dcl TILE_SIZE   type INT value (16);
 dcl CRASH_ADD   type INT value (4);
 dcl ID_TIMER    type INT value (1);
 dcl TIMER_DELAY type INT value (180);

 dcl (addr, binvalue, mod, iand, inot, ior, length, null, sysnull, size, time, random) builtin;


/* Prototypes and constants*/

 dcl 1 point_type based,
       2 x type INT,
       2 y type INT;

 dcl 1 ZERO,
       2 x type INT value (0),
       2 y type INT value (0);

 dcl 1 LEFT,
       2 x type INT value (-1),
       2 y type INT value (0);

 dcl 1 RIGHT,
       2 x type INT value (1),
       2 y type INT value (0);

 dcl 1 UP,
       2 x type INT value (0),
       2 y type INT value (-1);

 dcl 1 DOWN,
       2 x type INT value (0),
       2 y type INT value (1);


 define ordinal MAP_ID (EMPTY, SNAKE, FOOD, CRASH);

 dcl IDC_MAIN_STATUS type INT value (103);

/******************************************************************************************************/
/* global variables */
 dcl g_hbmBuffer   type HBITMAP init (sysnull());

 dcl g_hGreenPen      type HPEN;
 dcl g_hRedPen        type HPEN;
 dcl g_hYellowPen     type HPEN;
 dcl g_hGreenBrush    type HBRUSH;
 dcl g_hRedBrush      type HBRUSH;
 dcl g_hYellowBrush   type HBRUSH;

 dcl g_hFont          type HFONT;

 dcl g_map (0:MAP_SIZE - 1, 0:MAP_SIZE - 1) type INT;

 dcl g_snake (0:((MAP_SIZE - 1)*(MAP_SIZE - 1))) like point_type;
 dcl g_len_snake type INT;

 dcl g_dir  like point_type;
 dcl g_ndir like point_type;

 dcl g_food  like point_type;
 dcl g_crash like point_type;

 dcl g_leave_it type BOOL;
 dcl g_crashed  type BOOL;

 dcl g_szScore char (12) varz init ('  SCORE:  ');
 dcl g_score pic '9999' init ('0000');


 dcl wndclass  type WNDCLASSEX;
 dcl hInstance type HINSTANCE;

/******************************************************************************************************/
/* main procedure */
 WinMain: proc (hInstance, hPrevInstance, szCmdLine, iCmdShow) returns(type INT) options (winmain);
   dcl hInstance     type HINSTANCE;
   dcl hPrevInstance type HINSTANCE;
   dcl szCmdLine     ptr;
   dcl iCmdShow      type INT;

   /* local variables */
   dcl hwnd type HWND;
   dcl msg type MSG;
   dcl szAppName char (50) varz init ('Snake');
   dcl szAppTitle char (50) varz init ('Simple Snake Game in Windows PL/I!');

   /* initialize */
    wndclass.cbSize        = size(wndclass);
    wndclass.style         = ior(CS_HREDRAW, CS_VREDRAW);
    wndclass.lpfnWndProc   = WinProc;
    wndclass.cbClsExtra    = 0;
    wndclass.cbWndExtra    = 0;
    wndclass.hInstance     = hInstance;
    wndclass.hCursor       = LoadCursor(sysnull(), pli_b2z(binvalue(IDC_ARROW)));
    wndclass.hIcon         = LoadIcon(hInstance, pli_b2z(IDI_BALL));
    wndclass.hbrBackground = GetStockObject(WHITE_BRUSH);
    wndclass.lpszMenuName  = sysnull();
    wndclass.lpszClassName = addr(szAppName);
    wndclass.hIconSm       = LoadIcon(hInstance, pli_b2z(IDI_SBALL));

   /* register class */
   call RegisterClassEx (wndclass);

   /* Create a window */
   hwnd = CreateWindow(szAppName,                        /* window class name */
                        szAppTitle,                      /* window caption    */
                        ior(WS_OVERLAPPED, WS_SYSMENU),  /* window style      */
                        CW_USEDEFAULT,                   /* x pos             */
                        CW_USEDEFAULT,                   /* y pos             */
                        0,                               /* x size            */
                        0,                               /* y size            */
                        sysnull(),                       /* parent window hand*/
                        sysnull(),                       /* window menu hand  */
                        hInstance,                       /* pgm instance hand */
                        sysnull() );                     /* creation params   */

   /* Show the window */
   call ShowWindow(hwnd, iCmdShow) ;
   call UpdateWindow(hwnd);

   /* Message Loop */
   do while (GetMessage(msg, sysnull(), 0, 0) ^= 0);
      call   TranslateMessage(msg);
      call   DispatchMessage(msg);
   end;  /* of do */

   return (msg.wParam);
 end WinMain;  /* of program */

/******************************************************************************************************/
/* Window procedure */
 WinProc: proc (hwnd, msg, mp1, mp2) options(byvalue, linkage (stdcall)) returns (type LRESULT);
   dcl hwnd    type HWND;
   dcl msg     type UINT;
   dcl mp1     type WPARAM;
   dcl mp2     type LPARAM;

   /* local variables    */
   dcl hdc               type HDC;
   dcl hStatus           type HWND;
   dcl ps                type PAINTSTRUCT;
   dcl (rectl, rcStatus) type RECT;
   dcl lfHeight          type INT;
   dcl iStatusHeight     type INT;
   dcl szScore char (20) varz;

    select (msg);
      when (WM_CREATE)
        do;
          /* Create statusbar for score info */
          hStatus = CreateWindowEx(0, STATUSCLASSNAME, '',
                                    ior(WS_CHILD, WS_VISIBLE),
                                    0, 0, 0, 0, hwnd,
                                    cast(:HMENU, IDC_MAIN_STATUS:), hInstance, sysnull());
          call GetWindowRect(hStatus, rcStatus);
          iStatusHeight = rcStatus.bottom - rcStatus.top;
          call ResizeClient(hwnd, MAP_SIZE * TILE_SIZE, MAP_SIZE * TILE_SIZE + iStatusHeight);
          call SendMessage(hStatus, WM_SIZE, 0, 0);
          szScore = g_szScore || g_score;
          call SetWindowText(hStatus, szScore);

          /* Init pens and brushes */
          g_hGreenPen = CreatePen(PS_SOLID, 1, RGB(0,255,0));
          g_hGreenBrush = CreateSolidBrush(RGB(0,255,0));
          g_hRedPen = CreatePen(PS_SOLID, 1, RGB(255,0,0));
          g_hRedBrush = CreateSolidBrush(RGB(255,0,0));
          g_hYellowPen = CreatePen(PS_SOLID, 1, RGB(255,255,0));
          g_hYellowBrush = CreateSolidBrush(RGB(255,255,0));

          /* Init game over font */
          hdc = GetDC(sysnull());
          lfHeight = -MulDiv(32, GetDeviceCaps(hdc, LOGPIXELSY), 72);
          call ReleaseDC(sysnull(), hdc);
          g_hFont = CreateFont(lfHeight, 0, 0, 0, 0, TRUE, 0, 0, 0, 0, 0, 0, 0, 'Times New Roman');

          /* Init and start the game */
          call InitSnake;
          call SetTimer(hwnd, ID_TIMER, TIMER_DELAY);
        end; /* of when */
      when (WM_KEYDOWN)
          select (mp1);
            when (VK_LEFT)
              g_ndir = (LEFT);
            when (VK_RIGHT)
              g_ndir = (RIGHT);
            when (VK_UP)
              g_ndir = (UP);
            when (VK_DOWN)
              g_ndir = (DOWN);
            when (VK_SPACE)
              if g_crashed = TRUE then
              do;
                call InitSnake;
                call SetTimer(hwnd, ID_TIMER, TIMER_DELAY);
              end;
          end; /* of select (mp1) */
      when (WM_TIMER)
        do;
          /* Update game and force redraw */
          call UpdateSnake;
          call GetClientRect(hwnd, rectl);
          hStatus = GetDlgItem(hwnd, IDC_MAIN_STATUS);
          call GetWindowRect(hStatus, rcStatus);
          iStatusHeight = rcStatus.bottom - rcStatus.top;
          rectl.bottom = rectl.bottom - iStatusHeight;
          call InvalidateRect(hwnd, rectl, FALSE);
          szScore = g_szScore || g_score;
          call SetWindowText(hStatus, szScore);
          if g_crashed = TRUE then call KillTimer(hwnd, ID_TIMER);
        end; /* of when */
      when (WM_PAINT)
        do;
          hdc = BeginPaint(hwnd, ps);
          call GetClientRect(hwnd, rectl);
          hStatus = GetDlgItem(hwnd, IDC_MAIN_STATUS);
          call GetWindowRect(hStatus, rcStatus);
          iStatusHeight = rcStatus.bottom - rcStatus.top;
          rectl.bottom = rectl.bottom - iStatusHeight;
          if g_hbmBuffer = sysnull() then
            g_hbmBuffer = CreateCompatibleBitmap(hdc, rectl.right, rectl.bottom);
          call DrawSnake(hdc, rectl, g_hbmBuffer);
          call EndPaint(hwnd, ps);
        end; /* of when */
      when (WM_DESTROY)
        do;
          /* Terminate the application */
          call KillTimer(hwnd, ID_TIMER);
          /* Delete used GDI objects */
          call DeleteObject(g_hGreenPen);
          call DeleteObject(g_hRedPen);
          call DeleteObject(g_hYellowPen);
          call DeleteObject(g_hGreenBrush);
          call DeleteObject(g_hRedBrush);
          call DeleteObject(g_hYellowBrush);
          call DeleteObject(g_hFont);
          call DeleteObject(g_hbmBuffer);
          call PostQuitMessage(0);
        end; /* of when */
      otherwise
        return (DefWindowProc(hwnd,msg,mp1,mp2));
    end; /* of select (msg) */
   return (0);
 end WinProc; /* of procedure */

/******************************************************************************************************/
/* Resize client rectangle */
 ResizeClient: proc (hwnd, nWidth, nHeight);
   dcl hwnd type HWND;
   dcl (nWidth, nHeight) type INT;

   dcl (rcClient, rcWindow) type RECT;
   dcl ptDiff type POINT;

   call GetClientRect(hwnd, rcClient);
   call GetWindowRect(hwnd, rcWindow);
   ptDiff.x = (rcWindow.right - rcWindow.left) - rcClient.right;
   ptDiff.y = (rcWindow.bottom - rcWindow.top) - rcClient.bottom;
   call MoveWindow(hwnd, rcWindow.left, rcWindow.top, nWidth + ptDiff.x, nHeight + ptDiff.y, TRUE);
 end ResizeClient;

/******************************************************************************************************/
/* Init snake procedure */
 InitSnake: proc;
   dcl (i, j) type INT;
   dcl start like point_type;
   dcl seed float bin (53) static init (0);

   if seed = 0 then seed = random(time());

   g_score = '0000';

   do i = 0 to MAP_SIZE - 1;
     do j = 0 to MAP_SIZE - 1;
       g_map (i, j) = binvalue(EMPTY);
     end;
   end;

   g_len_snake = 3;
   g_dir = (RIGHT);
   g_ndir = g_dir;

   start.x = (MAP_SIZE - 1) * random();
   start.y = (MAP_SIZE - 1) * random();

   do i = 0 to g_len_snake;
     g_snake(i) = start;
   end;

   g_map(start.y, start.x) = binvalue(SNAKE);

   g_crash = (ZERO);

   g_leave_it = FALSE;
   g_crashed = FALSE;

   g_food.x = (MAP_SIZE - 1) * random();
   g_food.y = (MAP_SIZE - 1) * random();

   g_map(g_food.y, g_food.x) = binvalue(FOOD);

 end InitSnake;

/******************************************************************************************************/
/* Update snake procedure */
 UpdateSnake: proc;
   dcl i type INT;
   dcl np like point_type;

   if (g_dir.x * (-1) ^= g_ndir.x) & (g_dir.y * (-1) ^= g_ndir.y) then g_dir = g_ndir;

   np = g_snake(g_len_snake) + g_dir;
   np  = mod(np + MAP_SIZE, MAP_SIZE);

   if g_map(np.y, np.x) = binvalue(SNAKE) then
     do;
       g_crashed = TRUE;
       g_map(np.y, np.x) = binvalue(CRASH);
       g_crash = np;
       g_leave_it = TRUE;
     end;
   else if g_map(np.y, np.x) = binvalue(FOOD) then
     do;
       do loop;
         g_food.x = (MAP_SIZE - 1) * random();
         g_food.y = (MAP_SIZE - 1) * random();
         if g_map(g_food.y, g_food.x) = binvalue(EMPTY) then leave;
       end;
       g_map(g_food.y, g_food.x) = binvalue(FOOD);
       g_score += 1;
       g_leave_it = TRUE;
     end;

   if g_leave_it = TRUE then
     do;
       g_len_snake += 1;
       g_leave_it = FALSE;
     end;
   else do;
       g_map(g_snake(0).y, g_snake(0).x) = binvalue(EMPTY);
       do i = 0 to g_len_snake - 1;
         g_snake(i) = g_snake(i+1);
       end;
   end;

   g_snake(g_len_snake) = np;
   g_map(np.y, np.x) = binvalue(SNAKE);

 end UpdateSnake;

/******************************************************************************************************/
/* Draw snake procedure */
 DrawSnake: proc (hdc, prc, hbuffer);
   dcl hdc          type HDC;
   dcl prc          type RECT;
   dcl hbuffer      type HBITMAP;

   /* static variables */
   dcl szGameOver char (12) varz static init ('GAME OVER');

   /* local variables */
   dcl hdcBuffer    type HDC;
   dcl hbmOldBuffer type HBITMAP;
   dcl hOldPen      type HPEN;
   dcl hOldBrush    type HBRUSH;
   dcl hOldFont     type HFONT;
   dcl i type INT;

   hdcBuffer = CreateCompatibleDC(hdc);
   hbmOldBuffer = SelectObject(hdcBuffer, g_hbmBuffer);

   /* Clear game screen */
   call FillRect(hdcBuffer, prc, GetStockObject(WHITE_BRUSH));

   /* Draw snake */
   hOldPen = SelectObject(hdcBuffer, g_hGreenPen);
   hOldBrush = SelectObject(hdcBuffer, g_hGreenBrush);

   do i = 0 to g_len_snake;
     call Rectangle(hdcBuffer, g_snake(i).x * TILE_SIZE, g_snake(i).y * TILE_SIZE,
       g_snake(i).x * TILE_SIZE + TILE_SIZE, g_snake(i).y * TILE_SIZE + TILE_SIZE);
   end;

   /* Draw food */
   call SelectObject(hdcBuffer, g_hRedPen);
   call SelectObject(hdcBuffer, g_hRedBrush);

   call Ellipse(hdcBuffer, g_food.x * TILE_SIZE, g_food.y * TILE_SIZE,
     g_food.x * TILE_SIZE + TILE_SIZE, g_food.y * TILE_SIZE + TILE_SIZE);

   /* Draw crash image and GAME OVER text if snake crashed */
   if g_crashed = TRUE then
     do;
       call SelectObject(hdcBuffer, g_hYellowPen);
       call SelectObject(hdcBuffer, g_hYellowBrush);
       call Ellipse(hdcBuffer, g_crash.x * TILE_SIZE - CRASH_ADD, g_crash.y * TILE_SIZE - CRASH_ADD,
         g_crash.x * TILE_SIZE + TILE_SIZE + CRASH_ADD, g_crash.y * TILE_SIZE + TILE_SIZE + CRASH_ADD);
       hOldFont = SelectObject(hdcBuffer, g_hFont);
       call SetBkMode(hdcBuffer, TRANSPARENT);
       call DrawText(hdcBuffer, szGameOver, -1, prc, ior(DT_SINGLELINE, DT_CENTER, DT_VCENTER));
       call SelectObject(hdcBuffer, hOldFont);
     end;

   /* Blit memory buffer to screen */
   call BitBlt(hdc, 0, 0, prc.right, prc.bottom, hdcBuffer, 0, 0, SRCCOPY);

   /* Clean up and restore default GDI objects */
   call SelectObject(hdcBuffer, hOldPen);
   call SelectObject(hdcBuffer, hOldBrush);
   call SelectObject(hdcBuffer, hbmOldBuffer);
   call DeleteDC(hdcBuffer);
 end DrawSnake;

/******************************************************************************************************/
end Snake; /* of package */