API tools faq
paste
Advertisement
jalih

Snake game in PL/I

jalih
Mar 30th, 2012
261
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 14.53 KB | None | 0 0
raw download clone embed print report
  1. *PROCESS MARGINS(1,160) LANGLVL(SAA2) pp(macro);
  2. *PROCESS LIMITS(EXTNAME(100) fixedbin(63) fixeddec(31) name(100) );
  3. *PROCESS NOT('ยช^') DFT(BYVALUE);
  4. *PROCESS INCLUDE (EXT('CPY','INC'));
  5.  
  6. Snake: package;
  7.  
  8. /* Include win32 stuff */
  9. %include winbase;
  10. %include wingdi;
  11. %include winuser;
  12. %include commctrl;
  13.  
  14. %include snake; /* application include file */
  15.  
  16. dcl MAP_SIZE type INT value (24);
  17. dcl TILE_SIZE type INT value (16);
  18. dcl CRASH_ADD type INT value (4);
  19. dcl ID_TIMER type INT value (1);
  20. dcl TIMER_DELAY type INT value (180);
  21.  
  22. dcl (addr, binvalue, mod, iand, inot, ior, length, null, sysnull, size, time, random) builtin;
  23.  
  24.  
  25. /* Prototypes and constants*/
  26.  
  27. dcl 1 point_type based,
  28. 2 x type INT,
  29. 2 y type INT;
  30.  
  31. dcl 1 ZERO,
  32. 2 x type INT value (0),
  33. 2 y type INT value (0);
  34.  
  35. dcl 1 LEFT,
  36. 2 x type INT value (-1),
  37. 2 y type INT value (0);
  38.  
  39. dcl 1 RIGHT,
  40. 2 x type INT value (1),
  41. 2 y type INT value (0);
  42.  
  43. dcl 1 UP,
  44. 2 x type INT value (0),
  45. 2 y type INT value (-1);
  46.  
  47. dcl 1 DOWN,
  48. 2 x type INT value (0),
  49. 2 y type INT value (1);
  50.  
  51.  
  52. define ordinal MAP_ID (EMPTY, SNAKE, FOOD, CRASH);
  53.  
  54. dcl IDC_MAIN_STATUS type INT value (103);
  55.  
  56. /******************************************************************************************************/
  57. /* global variables */
  58. dcl g_hbmBuffer type HBITMAP init (sysnull());
  59.  
  60. dcl g_hGreenPen type HPEN;
  61. dcl g_hRedPen type HPEN;
  62. dcl g_hYellowPen type HPEN;
  63. dcl g_hGreenBrush type HBRUSH;
  64. dcl g_hRedBrush type HBRUSH;
  65. dcl g_hYellowBrush type HBRUSH;
  66.  
  67. dcl g_hFont type HFONT;
  68.  
  69. dcl g_map (0:MAP_SIZE - 1, 0:MAP_SIZE - 1) type INT;
  70.  
  71. dcl g_snake (0:((MAP_SIZE - 1)*(MAP_SIZE - 1))) like point_type;
  72. dcl g_len_snake type INT;
  73.  
  74. dcl g_dir like point_type;
  75. dcl g_ndir like point_type;
  76.  
  77. dcl g_food like point_type;
  78. dcl g_crash like point_type;
  79.  
  80. dcl g_leave_it type BOOL;
  81. dcl g_crashed type BOOL;
  82.  
  83. dcl g_szScore char (12) varz init (' SCORE: ');
  84. dcl g_score pic '9999' init ('0000');
  85.  
  86.  
  87. dcl wndclass type WNDCLASSEX;
  88. dcl hInstance type HINSTANCE;
  89.  
  90. /******************************************************************************************************/
  91. /* main procedure */
  92. WinMain: proc (hInstance, hPrevInstance, szCmdLine, iCmdShow) returns(type INT) options (winmain);
  93. dcl hInstance type HINSTANCE;
  94. dcl hPrevInstance type HINSTANCE;
  95. dcl szCmdLine ptr;
  96. dcl iCmdShow type INT;
  97.  
  98. /* local variables */
  99. dcl hwnd type HWND;
  100. dcl msg type MSG;
  101. dcl szAppName char (50) varz init ('Snake');
  102. dcl szAppTitle char (50) varz init ('Simple Snake Game in Windows PL/I!');
  103.  
  104. /* initialize */
  105. wndclass.cbSize = size(wndclass);
  106. wndclass.style = ior(CS_HREDRAW, CS_VREDRAW);
  107. wndclass.lpfnWndProc = WinProc;
  108. wndclass.cbClsExtra = 0;
  109. wndclass.cbWndExtra = 0;
  110. wndclass.hInstance = hInstance;
  111. wndclass.hCursor = LoadCursor(sysnull(), pli_b2z(binvalue(IDC_ARROW)));
  112. wndclass.hIcon = LoadIcon(hInstance, pli_b2z(IDI_BALL));
  113. wndclass.hbrBackground = GetStockObject(WHITE_BRUSH);
  114. wndclass.lpszMenuName = sysnull();
  115. wndclass.lpszClassName = addr(szAppName);
  116. wndclass.hIconSm = LoadIcon(hInstance, pli_b2z(IDI_SBALL));
  117.  
  118. /* register class */
  119. call RegisterClassEx (wndclass);
  120.  
  121. /* Create a window */
  122. hwnd = CreateWindow(szAppName, /* window class name */
  123. szAppTitle, /* window caption */
  124. ior(WS_OVERLAPPED, WS_SYSMENU), /* window style */
  125. CW_USEDEFAULT, /* x pos */
  126. CW_USEDEFAULT, /* y pos */
  127. 0, /* x size */
  128. 0, /* y size */
  129. sysnull(), /* parent window hand*/
  130. sysnull(), /* window menu hand */
  131. hInstance, /* pgm instance hand */
  132. sysnull() ); /* creation params */
  133.  
  134. /* Show the window */
  135. call ShowWindow(hwnd, iCmdShow) ;
  136. call UpdateWindow(hwnd);
  137.  
  138. /* Message Loop */
  139. do while (GetMessage(msg, sysnull(), 0, 0) ^= 0);
  140. call TranslateMessage(msg);
  141. call DispatchMessage(msg);
  142. end; /* of do */
  143.  
  144. return (msg.wParam);
  145. end WinMain; /* of program */
  146.  
  147. /******************************************************************************************************/
  148. /* Window procedure */
  149. WinProc: proc (hwnd, msg, mp1, mp2) options(byvalue, linkage (stdcall)) returns (type LRESULT);
  150. dcl hwnd type HWND;
  151. dcl msg type UINT;
  152. dcl mp1 type WPARAM;
  153. dcl mp2 type LPARAM;
  154.  
  155. /* local variables */
  156. dcl hdc type HDC;
  157. dcl hStatus type HWND;
  158. dcl ps type PAINTSTRUCT;
  159. dcl (rectl, rcStatus) type RECT;
  160. dcl lfHeight type INT;
  161. dcl iStatusHeight type INT;
  162. dcl szScore char (20) varz;
  163.  
  164. select (msg);
  165. when (WM_CREATE)
  166. do;
  167. /* Create statusbar for score info */
  168. hStatus = CreateWindowEx(0, STATUSCLASSNAME, '',
  169. ior(WS_CHILD, WS_VISIBLE),
  170. 0, 0, 0, 0, hwnd,
  171. cast(:HMENU, IDC_MAIN_STATUS:), hInstance, sysnull());
  172. call GetWindowRect(hStatus, rcStatus);
  173. iStatusHeight = rcStatus.bottom - rcStatus.top;
  174. call ResizeClient(hwnd, MAP_SIZE * TILE_SIZE, MAP_SIZE * TILE_SIZE + iStatusHeight);
  175. call SendMessage(hStatus, WM_SIZE, 0, 0);
  176. szScore = g_szScore || g_score;
  177. call SetWindowText(hStatus, szScore);
  178.  
  179. /* Init pens and brushes */
  180. g_hGreenPen = CreatePen(PS_SOLID, 1, RGB(0,255,0));
  181. g_hGreenBrush = CreateSolidBrush(RGB(0,255,0));
  182. g_hRedPen = CreatePen(PS_SOLID, 1, RGB(255,0,0));
  183. g_hRedBrush = CreateSolidBrush(RGB(255,0,0));
  184. g_hYellowPen = CreatePen(PS_SOLID, 1, RGB(255,255,0));
  185. g_hYellowBrush = CreateSolidBrush(RGB(255,255,0));
  186.  
  187. /* Init game over font */
  188. hdc = GetDC(sysnull());
  189. lfHeight = -MulDiv(32, GetDeviceCaps(hdc, LOGPIXELSY), 72);
  190. call ReleaseDC(sysnull(), hdc);
  191. g_hFont = CreateFont(lfHeight, 0, 0, 0, 0, TRUE, 0, 0, 0, 0, 0, 0, 0, 'Times New Roman');
  192.  
  193. /* Init and start the game */
  194. call InitSnake;
  195. call SetTimer(hwnd, ID_TIMER, TIMER_DELAY);
  196. end; /* of when */
  197. when (WM_KEYDOWN)
  198. select (mp1);
  199. when (VK_LEFT)
  200. g_ndir = (LEFT);
  201. when (VK_RIGHT)
  202. g_ndir = (RIGHT);
  203. when (VK_UP)
  204. g_ndir = (UP);
  205. when (VK_DOWN)
  206. g_ndir = (DOWN);
  207. when (VK_SPACE)
  208. if g_crashed = TRUE then
  209. do;
  210. call InitSnake;
  211. call SetTimer(hwnd, ID_TIMER, TIMER_DELAY);
  212. end;
  213. end; /* of select (mp1) */
  214. when (WM_TIMER)
  215. do;
  216. /* Update game and force redraw */
  217. call UpdateSnake;
  218. call GetClientRect(hwnd, rectl);
  219. hStatus = GetDlgItem(hwnd, IDC_MAIN_STATUS);
  220. call GetWindowRect(hStatus, rcStatus);
  221. iStatusHeight = rcStatus.bottom - rcStatus.top;
  222. rectl.bottom = rectl.bottom - iStatusHeight;
  223. call InvalidateRect(hwnd, rectl, FALSE);
  224. szScore = g_szScore || g_score;
  225. call SetWindowText(hStatus, szScore);
  226. if g_crashed = TRUE then call KillTimer(hwnd, ID_TIMER);
  227. end; /* of when */
  228. when (WM_PAINT)
  229. do;
  230. hdc = BeginPaint(hwnd, ps);
  231. call GetClientRect(hwnd, rectl);
  232. hStatus = GetDlgItem(hwnd, IDC_MAIN_STATUS);
  233. call GetWindowRect(hStatus, rcStatus);
  234. iStatusHeight = rcStatus.bottom - rcStatus.top;
  235. rectl.bottom = rectl.bottom - iStatusHeight;
  236. if g_hbmBuffer = sysnull() then
  237. g_hbmBuffer = CreateCompatibleBitmap(hdc, rectl.right, rectl.bottom);
  238. call DrawSnake(hdc, rectl, g_hbmBuffer);
  239. call EndPaint(hwnd, ps);
  240. end; /* of when */
  241. when (WM_DESTROY)
  242. do;
  243. /* Terminate the application */
  244. call KillTimer(hwnd, ID_TIMER);
  245. /* Delete used GDI objects */
  246. call DeleteObject(g_hGreenPen);
  247. call DeleteObject(g_hRedPen);
  248. call DeleteObject(g_hYellowPen);
  249. call DeleteObject(g_hGreenBrush);
  250. call DeleteObject(g_hRedBrush);
  251. call DeleteObject(g_hYellowBrush);
  252. call DeleteObject(g_hFont);
  253. call DeleteObject(g_hbmBuffer);
  254. call PostQuitMessage(0);
  255. end; /* of when */
  256. otherwise
  257. return (DefWindowProc(hwnd,msg,mp1,mp2));
  258. end; /* of select (msg) */
  259. return (0);
  260. end WinProc; /* of procedure */
  261.  
  262. /******************************************************************************************************/
  263. /* Resize client rectangle */
  264. ResizeClient: proc (hwnd, nWidth, nHeight);
  265. dcl hwnd type HWND;
  266. dcl (nWidth, nHeight) type INT;
  267.  
  268. dcl (rcClient, rcWindow) type RECT;
  269. dcl ptDiff type POINT;
  270.  
  271. call GetClientRect(hwnd, rcClient);
  272. call GetWindowRect(hwnd, rcWindow);
  273. ptDiff.x = (rcWindow.right - rcWindow.left) - rcClient.right;
  274. ptDiff.y = (rcWindow.bottom - rcWindow.top) - rcClient.bottom;
  275. call MoveWindow(hwnd, rcWindow.left, rcWindow.top, nWidth + ptDiff.x, nHeight + ptDiff.y, TRUE);
  276. end ResizeClient;
  277.  
  278. /******************************************************************************************************/
  279. /* Init snake procedure */
  280. InitSnake: proc;
  281. dcl (i, j) type INT;
  282. dcl start like point_type;
  283. dcl seed float bin (53) static init (0);
  284.  
  285. if seed = 0 then seed = random(time());
  286.  
  287. g_score = '0000';
  288.  
  289. do i = 0 to MAP_SIZE - 1;
  290. do j = 0 to MAP_SIZE - 1;
  291. g_map (i, j) = binvalue(EMPTY);
  292. end;
  293. end;
  294.  
  295. g_len_snake = 3;
  296. g_dir = (RIGHT);
  297. g_ndir = g_dir;
  298.  
  299. start.x = (MAP_SIZE - 1) * random();
  300. start.y = (MAP_SIZE - 1) * random();
  301.  
  302. do i = 0 to g_len_snake;
  303. g_snake(i) = start;
  304. end;
  305.  
  306. g_map(start.y, start.x) = binvalue(SNAKE);
  307.  
  308. g_crash = (ZERO);
  309.  
  310. g_leave_it = FALSE;
  311. g_crashed = FALSE;
  312.  
  313. g_food.x = (MAP_SIZE - 1) * random();
  314. g_food.y = (MAP_SIZE - 1) * random();
  315.  
  316. g_map(g_food.y, g_food.x) = binvalue(FOOD);
  317.  
  318. end InitSnake;
  319.  
  320. /******************************************************************************************************/
  321. /* Update snake procedure */
  322. UpdateSnake: proc;
  323. dcl i type INT;
  324. dcl np like point_type;
  325.  
  326. if (g_dir.x * (-1) ^= g_ndir.x) & (g_dir.y * (-1) ^= g_ndir.y) then g_dir = g_ndir;
  327.  
  328. np = g_snake(g_len_snake) + g_dir;
  329. np = mod(np + MAP_SIZE, MAP_SIZE);
  330.  
  331. if g_map(np.y, np.x) = binvalue(SNAKE) then
  332. do;
  333. g_crashed = TRUE;
  334. g_map(np.y, np.x) = binvalue(CRASH);
  335. g_crash = np;
  336. g_leave_it = TRUE;
  337. end;
  338. else if g_map(np.y, np.x) = binvalue(FOOD) then
  339. do;
  340. do loop;
  341. g_food.x = (MAP_SIZE - 1) * random();
  342. g_food.y = (MAP_SIZE - 1) * random();
  343. if g_map(g_food.y, g_food.x) = binvalue(EMPTY) then leave;
  344. end;
  345. g_map(g_food.y, g_food.x) = binvalue(FOOD);
  346. g_score += 1;
  347. g_leave_it = TRUE;
  348. end;
  349.  
  350. if g_leave_it = TRUE then
  351. do;
  352. g_len_snake += 1;
  353. g_leave_it = FALSE;
  354. end;
  355. else do;
  356. g_map(g_snake(0).y, g_snake(0).x) = binvalue(EMPTY);
  357. do i = 0 to g_len_snake - 1;
  358. g_snake(i) = g_snake(i+1);
  359. end;
  360. end;
  361.  
  362. g_snake(g_len_snake) = np;
  363. g_map(np.y, np.x) = binvalue(SNAKE);
  364.  
  365. end UpdateSnake;
  366.  
  367. /******************************************************************************************************/
  368. /* Draw snake procedure */
  369. DrawSnake: proc (hdc, prc, hbuffer);
  370. dcl hdc type HDC;
  371. dcl prc type RECT;
  372. dcl hbuffer type HBITMAP;
  373.  
  374. /* static variables */
  375. dcl szGameOver char (12) varz static init ('GAME OVER');
  376.  
  377. /* local variables */
  378. dcl hdcBuffer type HDC;
  379. dcl hbmOldBuffer type HBITMAP;
  380. dcl hOldPen type HPEN;
  381. dcl hOldBrush type HBRUSH;
  382. dcl hOldFont type HFONT;
  383. dcl i type INT;
  384.  
  385. hdcBuffer = CreateCompatibleDC(hdc);
  386. hbmOldBuffer = SelectObject(hdcBuffer, g_hbmBuffer);
  387.  
  388. /* Clear game screen */
  389. call FillRect(hdcBuffer, prc, GetStockObject(WHITE_BRUSH));
  390.  
  391. /* Draw snake */
  392. hOldPen = SelectObject(hdcBuffer, g_hGreenPen);
  393. hOldBrush = SelectObject(hdcBuffer, g_hGreenBrush);
  394.  
  395. do i = 0 to g_len_snake;
  396. call Rectangle(hdcBuffer, g_snake(i).x * TILE_SIZE, g_snake(i).y * TILE_SIZE,
  397. g_snake(i).x * TILE_SIZE + TILE_SIZE, g_snake(i).y * TILE_SIZE + TILE_SIZE);
  398. end;
  399.  
  400. /* Draw food */
  401. call SelectObject(hdcBuffer, g_hRedPen);
  402. call SelectObject(hdcBuffer, g_hRedBrush);
  403.  
  404. call Ellipse(hdcBuffer, g_food.x * TILE_SIZE, g_food.y * TILE_SIZE,
  405. g_food.x * TILE_SIZE + TILE_SIZE, g_food.y * TILE_SIZE + TILE_SIZE);
  406.  
  407. /* Draw crash image and GAME OVER text if snake crashed */
  408. if g_crashed = TRUE then
  409. do;
  410. call SelectObject(hdcBuffer, g_hYellowPen);
  411. call SelectObject(hdcBuffer, g_hYellowBrush);
  412. call Ellipse(hdcBuffer, g_crash.x * TILE_SIZE - CRASH_ADD, g_crash.y * TILE_SIZE - CRASH_ADD,
  413. g_crash.x * TILE_SIZE + TILE_SIZE + CRASH_ADD, g_crash.y * TILE_SIZE + TILE_SIZE + CRASH_ADD);
  414. hOldFont = SelectObject(hdcBuffer, g_hFont);
  415. call SetBkMode(hdcBuffer, TRANSPARENT);
  416. call DrawText(hdcBuffer, szGameOver, -1, prc, ior(DT_SINGLELINE, DT_CENTER, DT_VCENTER));
  417. call SelectObject(hdcBuffer, hOldFont);
  418. end;
  419.  
  420. /* Blit memory buffer to screen */
  421. call BitBlt(hdc, 0, 0, prc.right, prc.bottom, hdcBuffer, 0, 0, SRCCOPY);
  422.  
  423. /* Clean up and restore default GDI objects */
  424. call SelectObject(hdcBuffer, hOldPen);
  425. call SelectObject(hdcBuffer, hOldBrush);
  426. call SelectObject(hdcBuffer, hbmOldBuffer);
  427. call DeleteDC(hdcBuffer);
  428. end DrawSnake;
  429.  
  430. /******************************************************************************************************/
  431. end Snake; /* of package */
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!