Forth http://fforum.winglion.ru/ |
|
Game-марафон http://fforum.winglion.ru/viewtopic.php?f=33&t=1457 |
Страница 2 из 3 |
Автор: | Hishnik [ Вс авг 31, 2008 23:59 ] |
Заголовок сообщения: | |
luxor.fpm Код: " kernel32.dll" LOADLIBRARY
DUP " Sleep" GETPROCADDRESS CONSTANT SLEEP " GetTickCount" GETPROCADDRESS CONSTANT GetTickCount VARIABLE RND : RANDOMIZE GetTickCount RND ! ; RANDOMIZE : RANDOM \ ( -- u ) RND @ 69069 * 31415 + 278720333 MOD DUP RND ! ; 80 CONSTANT PATH 40 VALUE X 2 VALUE MAXCOLORS 80 VALUE MAXLUXORS 0 VALUE LUXORS QUAN BALLX QUAN BALLY QUAN BALLC CREATE COLORS[] 0 , 0xFF0000 , 0x00FF00 , 0x0000FF , CREATE LUXORS[] PATH 1 + ALLOT : CLEAR-LUXORS 0 LUXORS[] PATH CFILL ; : SHIFT-LUXORS PATH 1+ 1 DO LUXORS[] PATH I - + C@ LUXORS[] PATH I - + 1 + C! LOOP LUXORS MAXLUXORS < IF 1 +TO LUXORS RANDOM ABS 3 MOD 1 + 1 3 RANGE ELSE 0 THEN LUXORS[] C! BALLY 0 > IF BALLX BALLY GOTOXY 32 EMIT -2 +TO BALLY BALLX BALLY GOTOXY " $" PRINT THEN BALLY 11 < IF -1 TO BALLY THEN ; : START-LEVEL CLEAR-LUXORS 10 0 DO SHIFT-LUXORS LOOP ; : DRAW-LUXORS PATH 0 DO I 10 GOTOXY LUXORS[] I + C@ 4 * COLORS[] + @ SETCOLOR LOOP ; : ERASE-THING X 20 GOTOXY 32 EMIT ; : DRAW-THING X 20 GOTOXY 0x00FF00 SETCOLOR " ^" PRINT ; : MOUSING ERASE-THING MOUSE-X @ 8 / 1 80 RANGE TO X DRAW-THING DRAW-LUXORS 0x00FF00 SETCOLOR ; : GO SHIFT-LUXORS DRAW-LUXORS 0x00FF00 SETCOLOR ; : FIRE BALLY 0 < IF X TO BALLX 20 TO BALLY THEN ; ' MOUSING TO <MOUSE_MOVE> ' FIRE TO <MOUSE_LEFT> START-LEVEL 100 TIMER_INTERVAL ! ' GO TO <TIMER> |
Автор: | Hishnik [ Вс авг 31, 2008 23:59 ] |
Заголовок сообщения: | |
platformgame.fpm Код: QUAN JUMP
1 VALUE X 1 VALUE Y 5 VALUE XENEMY 1 VALUE YENEMY 10 VALUE LEVH 40 VALUE LEVW VARIABLE PTR : MAPLINE // S -- BEGIN DUP C@ 0 = NOT WHILE DUP C@ PTR @ C! PTR @ 1+ PTR ! 1+ REPEAT DROP ; CREATE LEVEL1[] LEVEL1[] PTR ! " 1111111111111111111111111111111111111111" MAPLINE " 1000000000000000000000000000000000000001" MAPLINE " 1000001111111111100011111111111111111111" MAPLINE " 1000000000000000000000000000000000000001" MAPLINE " 1000000000000000111100000000000001110001" MAPLINE " 1111100000000011111100001111111101110101" MAPLINE " 1100000111111111111111111111111100000101" MAPLINE " 1100000000000000000000000000000000000001" MAPLINE " 1100000000000000000000000000000000000001" MAPLINE " 1111111111111111111111111111111111111111" MAPLINE : XY->LEV LEVW * + LEVEL1[] + ; : SHOWLEVEL LEVH 0 DO LEVW 0 DO I J 5 + GOTOXY LEVEL1[] J LEVW * + I + C@ DUP 49 = IF 0x2A EMIT ELSE DUP 50 = IF 0x2B EMIT ELSE 32 EMIT THEN THEN DROP LOOP LOOP X Y 5 + GOTOXY " A" PRINT XENEMY YENEMY 5 + GOTOXY " x" PRINT ; QUAN ISDONE : DONE 1 TO ISDONE ; : GOENEMY 0 TO ISDONE XENEMY X > XENEMY 1 - YENEMY XY->LEV C@ 49 < AND IF -1 +TO XENEMY DONE THEN XENEMY X < XENEMY 1 + YENEMY XY->LEV C@ 49 < AND ISDONE 0 = AND IF 1 +TO XENEMY DONE THEN YENEMY Y > XENEMY YENEMY 1 - XY->LEV C@ 49 < AND ISDONE 0 = AND IF -1 +TO YENEMY DONE THEN YENEMY Y < XENEMY YENEMY 1 + XY->LEV C@ 49 < AND ISDONE 0 = AND IF 1 +TO YENEMY DONE THEN ; : GOLEFT X 1 - Y XY->LEV C@ 49 < IF -1 +TO X THEN GOENEMY SHOWLEVEL ; : GORIGHT X 1 + Y XY->LEV C@ 49 < IF 1 +TO X THEN GOENEMY SHOWLEVEL ; : GOUP X Y 1 - XY->LEV C@ 49 < IF -1 +TO Y THEN GOENEMY SHOWLEVEL ; : GODOWN X Y 1 + XY->LEV C@ 49 < IF 1 +TO Y THEN GOENEMY SHOWLEVEL ; SHOWLEVEL ' GOLEFT TO K_LEFT ' GORIGHT TO K_RIGHT ' GOUP TO K_UP ' GODOWN TO K_DOWN |
Автор: | Hishnik [ Пн сен 01, 2008 00:00 ] |
Заголовок сообщения: | |
spacetravel.fpm Код: 0x000080 VALUE COLOR
: BOX // X1, Y1, X2, Y2 --> 3 PICK 2 PICK 2DUP > IF SWAP THEN 4 PICK 3 PICK 2DUP > IF SWAP THEN ROT SWAP 3 PICK 3 PICK 3 PICK 6 PICK - COLOR HLINE 3 PICK 3 PICK 2 PICK 5 PICK - COLOR VLINE 1 PICK 3 PICK 2 PICK 5 PICK - 1+ COLOR VLINE 3 PICK 1 PICK 3 PICK 6 PICK - COLOR HLINE 8 0 DO DROP LOOP ; FLOAT X FLOAT Y FLOAT XHEADING FLOAT YHEADING FLOAT VX 0.0 VX F! FLOAT VY 0.0 VY F! FLOAT AX FLOAT AY 100 VALUE PX 100 VALUE PY : PM 100.0 ; 500 CONSTANT XSCR 400 CONSTANT YSCR : THRUST 1.0 ; : CALC-V VX F@ AX F@ F+ 10.0 FMIN -10.0 FMAX VX F! VY F@ AY F@ F+ 10.0 FMIN -10.0 FMAX VY F! ; : CALC-COORD X F@ VX F@ F+ X F! Y F@ VY F@ F+ Y F! ; : TO-MOUSE MOUSE-X @ XSCR - S>F X F@ F- FDUP F* YSCR MOUSE-Y @ - S>F Y F@ F- FDUP F* F+ FSQRT ; : TO-PLANET PX XSCR - S>F X F@ F- FDUP F* YSCR PY - S>F Y F@ F- FDUP F* F+ FSQRT 0.01 FMAX ; : ENGINE-FORWARD MOUSE-X @ XSCR - S>F X F@ F- TO-MOUSE F/ XHEADING F! YSCR MOUSE-Y @ - S>F Y F@ F- TO-MOUSE F/ YHEADING F! THRUST XHEADING F@ F* AX F+! THRUST YHEADING F@ F* AY F+! ; : ENGINE-BACK MOUSE-X @ XSCR - S>F X F@ F- TO-MOUSE F/ XHEADING F! YSCR MOUSE-Y @ - S>F Y F@ F- TO-MOUSE F/ YHEADING F! THRUST -1.0 F* XHEADING F@ F* AX F+! THRUST -1.0 F* YHEADING F@ F* AY F+! ; : PLANET X F@ PX S>F F- TO-PLANET F/ XHEADING F! Y F@ PY S>F F- TO-PLANET F/ YHEADING F! PM TO-PLANET FDUP F* F/ XHEADING F@ F* AX F+! PM TO-PLANET FDUP F* F/ XHEADING F@ F* AX F+! ; : ERASE-SHIP X F@ F>S XSCR + YSCR Y F@ F>S - 0 PIXEL ; : DRAW-SHIP X F@ F>S XSCR + YSCR Y F@ F>S - 0x00FF00 PIXEL ; : MAIN 0 0 1000 800 BOX ERASE-SHIP PLANET CALC-V CALC-COORD DRAW-SHIP X F@ F>S -500 500 WITHIN NOT Y F@ F>S -400 400 WITHIN NOT OR IF ['] NOOP TO <TIMER> CLS 30 20 GOTOXY " Crash!!!" PRINT THEN ; ' ENGINE-FORWARD TO <MOUSE_LEFT> ' ENGINE-BACK TO <MOUSE_RIGHT> 100 TIMER_INTERVAL ! ' MAIN TO <TIMER> |
Автор: | Hishnik [ Пн сен 01, 2008 00:01 ] |
Заголовок сообщения: | |
ugadai.fpm Код: VARIABLE RND
: RANDOMIZE 2345 RND ! ; RANDOMIZE : RANDOM \ ( -- u ) RND @ 69069 * 31415 + 278720333 MOD DUP RND ! ; VARIABLE X VARIABLE Y QUAN ATTEMPTS : GAME 0 TO ATTEMPTS RANDOM ABS 100 MOD 1+ Y ! 10 10 GOTOXY " Угадайте число от 1 до 100" PRINT ; : STEP X ! CAN-DISPATCH OFF 1 +TO ATTEMPTS CAN-DISPATCH ON X @ Y @ > IF " Введенное число больше" PRINT THEN X @ Y @ < IF " Введенное число меньше" PRINT THEN X @ Y @ = IF " Угадано!!!!!" PRINT CAN-DISPATCH OFF THEN CR ATTEMPTS . ; GAME ' STEP TO DISPATCH-NUMBER CAN-DISPATCH ON |
Автор: | вопрос [ Пн сен 01, 2008 19:10 ] |
Заголовок сообщения: | |
а отчего автору никто ничего не говорит Нужно похвалить. И где остальные участники? |
Автор: | makrus [ Вт сен 02, 2008 08:44 ] |
Заголовок сообщения: | |
вопрос Цитата: И где остальные участники? Если я сегодня выложу - это будет являться соблюдением правил?
Игра (крестики-нолики) была написАна в основном за два последних выходных, но оставались мелкие недочеты - это не позволило уложиться в срок... Там и щас в коде (даже существующем) много чего еще много оптимизировать и "причесать" и конечно же добавить, но это будет потом, а так, играть уже можно... И если прийдется выкладывать архив - файлообменник для этого подойдет? Здесь вроде нет возможности прикреплять файлы, своего сайта нет... А автору темы - Хищник'у, действительно - спасибо . Мне, как "долго начинающему" , эта тема помогла начать и, можно сказать - завершить, что-то более существенное чем задачки на nnCron'е. |
Автор: | Hishnik [ Вт сен 02, 2008 10:39 ] |
Заголовок сообщения: | |
makrus писал(а): Если я сегодня выложу - это будет являться соблюдением правил? Хотя промежуточный этап и завершился, марафон продолжается! makrus писал(а): Мне, как "долго начинающему" , эта тема помогла начать и, можно сказать - завершить, что-то более существенное чем задачки на nnCron'е.
Вот это, на мой взгляд, главный итог! |
Автор: | вопрос [ Вт сен 02, 2008 10:56 ] |
Заголовок сообщения: | |
Цитата: марафон продолжается!
Это психология - начинать что-то новое в последние выходные отпуска! Сужу по себе |
Автор: | makrus [ Ср сен 03, 2008 00:20 ] |
Заголовок сообщения: | |
Итак, игра "Крестики-Нолики", размер файла 6305 байт, готовые к "употреблению" файлы (exe и две иконки) лежат здесь, или же запустить: (иконки все-таки надо взять с архива) spf4.exe Crest0.f Содержимое Crest0.f: Код: 0 VALUE win
0 VALUE win-grid 0 VALUE #but 0 VALUE f_grid 0 VALUE hide_grid 0 VALUE #step 0 VALUE comp_first? 0 VALUE tmp 1 CONSTANT CREST 2 CONSTANT NULL CREST VALUE USER-PRESS NULL VALUE COPM-PRESS 0 VALUE c_font CREATE link_table 6 C, 7 C, 8 C, 3 C, 4 C, 5 C, 0 C, 1 C, 2 C, CREATE field 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, CREATE line-sets 1 C, 2 C, 3 C, 4 C, 5 C, 6 C, 7 C, 8 C, 9 C, 1 C, 4 C, 7 C, 2 C, 5 C, 8 C, 3 C, 6 C, 9 C, 1 C, 5 C, 9 C, 3 C, 5 C, 7 C, REQUIRE WINDOWS... devel\~yz\lib\winlib.f REQUIRE button devel\~yz\lib\winctl.f REQUIRE CHOOSE lib\ext\rnd.f : game-msg ( z z2 -- ) 64 message-box DROP ; : win-game ( -- z ) " Крестики-нолики" ; : info-msg ( -- ) win-game " Для управления используйте цифровую клавиатуру" game-msg ; : win-text ( idpic -- -->msg ) win-game SWAP USER-PRESS = IF " Поздравляю!!!\n Вы победили!" ELSE " В этот раз вы проиграли...\n Попробуйте еще раз." THEN game-msg BYE ; : pat ( -- ) win-game " Ничья" game-msg ; WINAPI: LoadImageA USER32.DLL : load-sized-icon { x y z -- hicon } W: Lr_LoadFromFile x y W: Image_Icon z IMAGE-BASE LoadImageA ; : load-icon ( z -- hicon ) >R 0 0 R> load-sized-icon ; : null-ico ( -- hicon ) " Null.ico" load-icon ; : crst-ico ( -- hicon ) " Crest.ico" load-icon ; : null-btn ( -- ctrl ) null-ico icon-button (/ -size 30 30 /) ; : crst-btn ( -- ctrl ) crst-ico icon-button (/ -size 30 30 /) ; : #button ( d. -- ctrl ) (D.) DROP button (/ -size 5 5 -font c_font -align center /) ; : ?crst/0 ( idpic -- ctrl ) USER-PRESS = IF crst-btn ELSE null-btn THEN ; : set-btn ( d. idpic -- ctrl ) DUP IF NIP NIP ?crst/0 ELSE DROP #button THEN ; : #cell ( n -- addr ) 1- field + ; : btn-cell@ ( #btn -- idpic ) #cell C@ ; : load-btn ( d. -- ctrl ) OVER btn-cell@ set-btn ; : false-grid ( -- ) GRID filler | GRID; ; : field_grid ( -- ) GRID -boxed filler (/ -size 1 2 /) | === 7. load-btn | 8. load-btn | 9. load-btn | === 4. load-btn | 5. load-btn | 6. load-btn | === 1. load-btn | 2. load-btn | 3. load-btn | GRID; TO f_grid ; : border_grid ( -- ) field_grid GRID f_grid -center -middle | GRID; TO win-grid ; : link ( n -- addr ) link_table + C@ field + ; : CELL@ ( n -- idpic ) link C@ ; : CELL! ( idpic n -- -->comp ) link C! ; : step-done ( -- ) #step 1+ TO #step ; : center-is-free? ( -- ? ) #step 0= comp_first? AND ; : set-center ( -- ) COPM-PRESS 4 CELL! ; : snap-center ( -- ) center-is-free? IF step-done set-center THEN ; : draw_win ( -- ) snap-center border_grid win-grid winmain -grid@ ?DUP IF winmain winhide del-grid false-grid winmain -grid! winmain -grid@ del-grid winmain winshow THEN winmain -grid! ; : line-set ( n -- addr ) 1 - 3 * line-sets + ; : win-set? ( addr - 0 | idpic 1 ) DUP C@ 1- CELL@ ?DUP IF TO tmp DUP 3 + SWAP DO I C@ 1- CELL@ tmp = 0= IF 0 TO tmp LEAVE THEN LOOP tmp ?DUP IF 1 ELSE 0 THEN ELSE DROP 0 THEN ; : LineIs? ( -- 0 | idpic 1 ) 9 1 DO I line-set win-set? IF 1 LEAVE THEN I 8 = IF 0 THEN LOOP ; : free-is? ( -- ? ) 9 0 DO I CELL@ 0= IF TRUE LEAVE THEN I 8 = IF FALSE THEN LOOP ; : find-free ( -- #cell ) free-is? IF BEGIN 8 CHOOSE DUP CELL@ IF DROP 0 ELSE 1 THEN UNTIL ELSE LineIs? IF win-text ELSE pat THEN BYE THEN ; : set-cell ( -- ) find-free COPM-PRESS SWAP CELL! ; : comp-step ( -- ) LineIs? IF win-text ELSE 4 CELL@ IF set-cell step-done LineIs? IF win-text THEN ELSE set-center THEN step-done THEN ; : press-key ( n -- ) #cell DUP C@ IF win-game " Это поле уже занято.\nПопробуйте еще раз." game-msg DROP ELSE step-done USER-PRESS SWAP C! comp-step draw_win THEN ; : about " О программе" " Игра Крестики-Нолики.\nПервый работоспособный релиз :) \n v 0.102\n\n автор: makrus" game-msg ; PROC: 1key 1 press-key PROC; PROC: 2key 2 press-key PROC; PROC: 3key 3 press-key PROC; PROC: 4key 4 press-key PROC; PROC: 5key 5 press-key PROC; PROC: 6key 6 press-key PROC; PROC: 7key 7 press-key PROC; PROC: 8key 8 press-key PROC; PROC: 9key 9 press-key PROC; PROC: quit winmain W: wm_close ?send DROP PROC; PROC: help " Справка" " В начале игры вы видите поле из 9-ти ячеек с изображением цифр.\nРасположение цифр соотвествует их расположению на дополнительной цифровой\nклавиатуре (для клавиатур со стандартной раскладкой).\nНажимая клавиши на клавиатуре вы ставите крестик в соотвестующую ячейку,\nкомпьютер делает свой ход и т.д. пока либо кто-то не выйграет либо не будет ничья.\nВыход из игры либо по ее завершению, либо через меню (Alt+x)\n\nPS AI программы настолько примитивен (пока) что у программы проще выйграть чем проиграть :)\nPSS Не надо нажимать на кнопки программы мышкой, это не смертельно, это бесполезно :) " game-msg PROC; PROC: about_menu about PROC; MENU: filemenu quit MENUITEM &Выход\tAlt-X MENU; MENU: helpmenu help MENUITEM Вызов справки LINE about_menu MENUITEM О программе MENU; MENU: mainmenu filemenu SUBMENU Файл helpmenu SUBMENU Справка MENU; WINAPI: WinHelpA USER32.DLL MESSAGES: my M: wm_help about TRUE M; MESSAGES; KEYTABLE quit ONKEY alt+X 1key ONKEY VK_NUMPAD1 2key ONKEY VK_NUMPAD2 3key ONKEY VK_NUMPAD3 4key ONKEY VK_NUMPAD4 5key ONKEY VK_NUMPAD5 6key ONKEY VK_NUMPAD6 7key ONKEY VK_NUMPAD7 8key ONKEY VK_NUMPAD8 9key ONKEY VK_NUMPAD9 KEYTABLE; : run WINDOWS... 0 dialog-window TO win win TO winmain " КреНолики" win -text! " Arial" 13 bold create-font TO c_font mainmenu win attach-menubar my win -wndproc! draw_win win wincenter info-msg win winshow ...WINDOWS c_font delete-font BYE ; TRUE TO ?GUI ' run MAINX ! S" Crest0.exe" SAVE BYE |
Автор: | вопрос [ Ср сен 03, 2008 00:48 ] |
Заголовок сообщения: | |
хм, работает ... и занимает 5 кВ |
Автор: | Hishnik [ Ср сен 03, 2008 00:50 ] |
Заголовок сообщения: | |
Хе! А не устроить ли турнирчик между такими программами? |
Автор: | вопрос [ Ср сен 03, 2008 00:57 ] |
Заголовок сообщения: | |
протоколы обмена данными были всегда для игровых программ камнем преткновения, для шахмат существует 3 или 4 общеупотребительных протокола, из них 2, кажется - наиболее употребительны. это позволяет устраивать турниры, для Го - как минимум 2 "текст протокол" и "модем протокол", но, реально, думаю больше. Если бы Форт таки кого-то интересовал ... ведь программа может передать другой программе протокол в виде исходника (лишь бы движёк мог реагировать) (фантазии) |
Автор: | Pretorian [ Ср сен 03, 2008 05:51 ] |
Заголовок сообщения: | |
Я чет не увидел крестиков и ноликов, просто пустые кнопки остаются после моего хода или хода компьютера. |
Автор: | makrus [ Ср сен 03, 2008 07:17 ] |
Заголовок сообщения: | |
Pretorian Цитата: Я чет не увидел крестиков и ноликов... Из архива надо взять два файла иконки и положить рядом с f/exe, а можно их и самому нарисовать...
|
Автор: | VoidVolker [ Ср сен 03, 2008 11:14 ] |
Заголовок сообщения: | |
А зачем иконки, когда надо только керстик "Х" и нолик "О"? |
Страница 2 из 3 | Часовой пояс: UTC + 3 часа [ Летнее время ] |
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group http://www.phpbb.com/ |