diff --git a/boot.jim b/boot.jim index d6b484f..897643d 100755 Binary files a/boot.jim and b/boot.jim differ diff --git a/boot.jor b/boot.jor index 003c392..c42d0c5 100755 --- a/boot.jor +++ b/boot.jor @@ -1,8 +1,8 @@ +0 const 0 +1 const 1 2 const cell : cells cell * ; -key ) const ')' - 10 const '\n' 13 const '\r' key const sp @@ -23,8 +23,8 @@ key const sp : again ' GOTO_ , , ; immediate : until ' BZ_ , , ; immediate -: ( begin key ')' = until ; immediate : lit ' LIT_ , , ; +: ( begin key [ key ) lit ] = until ; immediate : inline| ' INLINEDATA_ , here 0 , ; : |inline [ ' then , ] ; @@ -33,10 +33,8 @@ key const sp : :| inline| $DOCOLON , ; immediate : |; ' ret , |inline ; immediate -key " const '"' - : s" state if inline| else here then - begin key dup '"' != over 0 != and while b, repeat drop 0 b, + begin key dup [ key " lit ] != over 0 != and while b, repeat drop 0 b, state if |inline else dup here! then ; immediate : interpretword F_IMMEDIATE & state not or if execute else , then ; diff --git a/defs.jim b/defs.jim index ebeda2c..c9f7d4c 100755 Binary files a/defs.jim and b/defs.jim differ diff --git a/defs.jor b/defs.jor index 3a31a5e..0f782c9 100755 --- a/defs.jor +++ b/defs.jor @@ -114,6 +114,11 @@ then more ; +: lazy here $DODEFERRED , ' noop , ; +: >lazy! latest codepointer swap redefine ; + +: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate + ( tasks ) : mailbox 2 cells + ; : task-ip task-user-size cells + ; diff --git a/end.jim b/end.jim index bb50e46..6074149 100755 Binary files a/end.jim and b/end.jim differ diff --git a/entity.jim b/entity.jim index caa7cdb..f0c5ecd 100755 Binary files a/entity.jim and b/entity.jim differ diff --git a/footer.jim b/footer.jim index 64226a0..6d2834d 100755 Binary files a/footer.jim and b/footer.jim differ diff --git a/game.jim b/game.jim index 21d925e..719de3d 100755 Binary files a/game.jim and b/game.jim differ diff --git a/game.jor b/game.jor index c8883c5..57ff227 100755 --- a/game.jor +++ b/game.jor @@ -2,6 +2,8 @@ defer party defer entities var objects +var ticking-objects +var visible-objects : obj-entity ( optr -- entity ) cell + @ ; @@ -26,13 +28,14 @@ var posessed-rexx : isneut? isprog? posessed-rexx @ not and ; userword : isjaye? isprog? not ; userword : isrexx? isprog? posessed-rexx @ and ; userword +: gord-follow? player.state HASGORD f@ ; : {jaye} isjaye? player.state MOVING f@ and if {jaye-walk} else {jaye-stand} then ; : {gord} - player.state HASGORD f@ if + gord-follow? if isjaye? player.state MOVING f@ and player.state GORDSIT f@ or if {gord-walk} else {gord-stand} then else player.state GORDSIT f@ if {gord-sit} else {gord-floor} then then ; @@ -117,7 +120,7 @@ defer touch-override ( x y -- b ) defer on-gord-sit : do-gord-sit ( x y -- b ) - player.state HASGORD f@ isjaye? and if + isjaye? gord-follow? and if tile b@ CHAIR = if 1 player.state GORDSIT f! player.prevdir @ Gord entity.dir ! @@ -171,13 +174,15 @@ var q-level : queue-level q-level ! ; userword : player-tick - ^SPACE key-pressed player.state HASNEUT f@ and if + ^SPACE key-pressed if player.state HASNEUT f@ if player.state ISPROG fnot! isprog? if prog-view else human-view then - then - ^Z key-pressed player.state GORDSIT f@ and isjaye? and if + then then + ^Z key-pressed if player.state GORDSIT f@ if + isprog? 0 player.state ISPROG f! activate-gord - then + player.state ISPROG f! + then then 0 ^LEFT key-down if drop 1 W player entity.dir ! then ^RIGHT key-down if drop 1 E player entity.dir ! then ^UP key-down if drop 1 N player entity.dir ! then @@ -190,8 +195,12 @@ defer reset-level userword : mode-move player-tick -( objects @ if objects @ links each dup obj-entity EVTICK entity>do more - entities each EVTICK entity>do more + ticking-objects @ if + ticking-objects @ links + each dup obj-entity EVTICK entity>do more + then + +( entities each EVTICK entity>do more party each EVTICK entity>do more Neut EVTICK entity>do ) @@ -210,6 +219,11 @@ defer reset-level userword r@ entity.dir @ sprite sprite-bob draw-sprite ; +0 const rubber-on? +: rubber rubber-on? not ' rubber-on? redefine ; +: {tileent} rubber-on? if {duck} else {blank} then ; +: visible-objects@ rubber-on? if objects else visible-objects then @ ; + var glitchlevel var quaking @@ -225,8 +239,8 @@ var quaking party each dup Jaye != if draw-entity else drop then more Jaye draw-entity player.state HASNEUT f@ if Neut draw-entity then - objects @ if - objects @ links each dup obj-entity draw-entity more + visible-objects@ if + visible-objects@ links each dup obj-entity draw-entity more then entities each draw-entity more @@ -239,15 +253,23 @@ var quaking var defining-objects-head var defining-objects-ptr -: objects: create here 0 , +: objects: create here 0 , 0 , 0 , 0 defining-objects-head ! defining-objects-ptr ! -does> @ objects ! ; +does> + dup @ objects ! + dup cell + @ ticking-objects ! + dup 2 cells + @ visible-objects ! ; + +: obj-link-head! ( index -- ) + cells defining-objects-ptr @ + defining-objects-head @ swap ! ; : link-object ( entity -- ) - here defining-objects-head @ , swap , - dup defining-objects-head ! - defining-objects-ptr @ ! ; + here defining-objects-head @ , swap , defining-objects-head ! + 0 obj-link-head! ; + +: obj-ticking! 1 obj-link-head! ; +: obj-visible! 2 obj-link-head! ; : entity>tile ( entity -- tile ) entity>pos world>tile tile ; : entity>tile? ( entity expected - b ) swap entity>tile b@ = ; @@ -259,16 +281,20 @@ does> @ objects ! ; : respondertile! ( tile -- ) responder entity>tile b! invalidate-map ; -var _dorubber -: rubber _dorubber @ not _dorubber ! ; -: {tileent} _dorubber @ if {duck} else {blank} then ; - : blankentity array here >r N ' {tileent} allotentity count ( e -- count ) entity.user cell + @ ; userword +: timer.start ( e -- p ) entity.user 2 cells + ; userword +: timer>donewaiting? ( e -- b ) + dup timer>count swap timer.start @ still-waiting? not ; userword + : create-object blankentity dup link-object ; : create-linked-object blankentity swap , dup link-object ; +: create-timed-object blankentity swap , swap , 0 , + dup link-object obj-ticking! ; + : listener! ( entity listener ) swap ! ; : handle-onoff ( ev on off -- ) @@ -288,7 +314,7 @@ var _dorubber : exitdoor create-linked-object :| dup door-listener entering-door? if - player.state HASGORD f@ not gord-present? and if + gord-follow? not gord-present? and if jaye say" I'm not leaving Gord behind." else responder entity.user @ queue-level @@ -304,14 +330,31 @@ var _dorubber linked-entity swap entity>do else drop then ; -: switch create-linked-object - :| dup EVTOUCH = isneut? and if move-player then - dup EVTOUCH = isrexx? not and if - responder EVTOG entity>do - isjaye? if wait-for-arrow-up then - then - dup SWITCH-ON SWITCH-OFF handle-onoff - SWITCH-ON handle-link |; listener! ; +: handle-switch-touch ( ev -- ) + dup EVTOUCH = isneut? and if move-player then + dup EVTOUCH = isrexx? not and if + responder EVTOG entity>do + isjaye? if wait-for-arrow-up then + then + dup SWITCH-ON SWITCH-OFF handle-onoff + SWITCH-ON handle-link ; + +: switch create-linked-object ' handle-switch-touch listener! ; + +: timedswitch create-timed-object + :| dup EVTICK = if SWITCH-ON responder>tile? if + drop responder timer>donewaiting? if + EVDEACT + else ret then + then then + dup EVTOUCH = over EVACT = or if SWITCH-ON responder>tile? if + dup EVTOUCH = isneut? and if move-player then + drop EVNOP + then then + dup handle-switch-touch + statechange? if SWITCH-ON responder>tile? if + ticks responder timer.start ! + then then |; listener! ; : computer-on? ( entity -- b ) COMP-ON entity>tile? ; @@ -339,7 +382,7 @@ var _dorubber SCAN-ON handle-link |; listener! ; : defrexx array here >r S ' {rexx} allotentity +#include #include #include #include @@ -1072,6 +1073,10 @@ void f_taskusersize() { PUSHU(TASK_USER_SIZE); } +void f_rand() { + PUSHI(rand()); +} + void f_init(char *exe) { f_calc_imagemagic(exe); @@ -1202,6 +1207,7 @@ void f_init(char *exe) { CDEF("stacksize", f_stacksize); CDEF("rstacksize", f_rstacksize); CDEF("task-user-size", f_taskusersize); + CDEF("rand", f_rand); PCONST("$DOCREATE", f_docreate); PCONST("$DOVAR", f_dovar); PCONST("$DODEFERRED", f_dodeferred); diff --git a/lev00001.jim b/lev00001.jim deleted file mode 100755 index 40210bd..0000000 Binary files a/lev00001.jim and /dev/null differ diff --git a/lev00002.jim b/lev00002.jim deleted file mode 100755 index a84524d..0000000 Binary files a/lev00002.jim and /dev/null differ diff --git a/lev00003.jim b/lev00003.jim deleted file mode 100755 index 0e869e4..0000000 Binary files a/lev00003.jim and /dev/null differ diff --git a/lev00004.jim b/lev00004.jim deleted file mode 100755 index fa97c8d..0000000 Binary files a/lev00004.jim and /dev/null differ diff --git a/lev00005.jim b/lev00005.jim index c912c69..83f1e3d 100755 Binary files a/lev00005.jim and b/lev00005.jim differ diff --git a/lev00005.jor b/lev00005.jor index 0b4b087..0c97f69 100755 --- a/lev00005.jor +++ b/lev00005.jor @@ -2,25 +2,96 @@ objects: O +lazy 60 over 19 9 timedswitch ts + 16 7 defrexx Rexx +9 3 defrexx Rexx2 + +13 6 door d1 +10 9 door d2 +5 6 door d3 >lazy! +10 2 door d4 +end.jor 5 12 exitdoor dx + +lazy dup 11 3 computer c1 +' c1 7 11 computer c2 >lazy! +lazy dup 7 5 computer c3 +' c3 2 11 computer c4 >lazy! + +' d2 10 10 scanner s1 +' dx 4 12 scanner sx + +' d4 7 1 switch b1 +' d1 19 3 switch b2 :noname 0 MAXTILE for i tileflags + b@ RUBBLE & if i b, then next ; array rubbletiles execute here rubbletiles - 1 - const MAXRUBBLE -: randomrubble ticks MAXRUBBLE % rubbletiles + b@ ; +: randomrubble rand MAXRUBBLE % rubbletiles + b@ ; : rexx-pos ( -- x y ) Rexx entity>pos world>tile ; : rexx-dest ( -- x y ) rexx-pos Rexx entity.dir @ dir>pos +pos ; -: can-drop-rubble? ( -- b ) rexx-pos tile b@ CARPET = ; +: can-drop-rubble? ( -- b ) + rexx-pos tile b@ CARPET = + rexx-dest tile b@ CARPET = and ; + : not-picking-up? ( -- b ) rexx-dest RUBBLE mapflag? not ; : touch ( x y -- b ) - drop drop - not-picking-up? can-drop-rubble? and isrexx? and if - randomrubble rexx-pos tile b! invalidate-map - then 0 ; + drop 13 <= isrexx? and posessed-rexx @ Rexx = and if + 3 glitchlevel ! + rexx say" PaRiTy ErrRor!!" + 0 glitchlevel ! + 1 + else + not-picking-up? can-drop-rubble? and isrexx? and if + randomrubble rexx-pos tile b! invalidate-map + then 0 + then ; + +var first-rexx-touch +Rexx :noname + dup EVTOUCH = isneut? and first-rexx-touch @ not and if + 1 first-rexx-touch ! + rexx say" bOSssS..." + rexx say" i doN'T fEEl so\gooOO00dddDdDd..." + then chain-listener ; + +var first-rexx2-touch +Rexx2 :noname + dup EVTOUCH = isneut? and first-rexx2-touch @ not and if + 1 first-rexx2-touch ! + neut say" REXX UNIT\PERFORM FULL DIAGNOSTIC SCAN" + rexx say" I'm in tip-top shape, boss!" + neut say" ACTIVATING RELIEF SUBROUTINE" + then chain-listener ; + +: mr ( dir -- ) Rexx entity.dir ! Rexx move-entity ; + +d2 :noname + dup entering-door? + isjaye? and + gord-follow? not and + Rexx entity>pos drop 0 > and + if + move-player + W mr + rexx say" daaAiisSyyy, daAAIIsYY..." hide-footer + W mr + W mr + rexx say" gIVe mE YOur AnSwerR\doOO0OO0o0oooOO..." hide-footer + N mr + N mr + rexx say" uh oh" hide-footer + Rexx entity>pos world>tile -1 -1 +pos + dup 3 + for dup over 3 + i >rot for i over ( x y ) + tile randomrubble swap b! invalidate-map 1 sleep + next drop next drop + -100 -100 Rexx entity.pos! + drop EVNOP + then chain-listener ; :noname O diff --git a/lev00005.map b/lev00005.map index 645c44b..3720bf1 100755 Binary files a/lev00005.map and b/lev00005.map differ diff --git a/map.jim b/map.jim index cf151ea..3acdaa0 100755 Binary files a/map.jim and b/map.jim differ diff --git a/neuttowr.exe b/neuttowr.exe index c395399..445aa39 100755 Binary files a/neuttowr.exe and b/neuttowr.exe differ diff --git a/neuttowr.prj b/neuttowr.prj index e45e016..2a1aa1e 100755 Binary files a/neuttowr.prj and b/neuttowr.prj differ diff --git a/state.jim b/state.jim index 57a8b84..6468bfe 100755 Binary files a/state.jim and b/state.jim differ diff --git a/testbed.c b/testbed.c index b117807..5b16a84 100755 --- a/testbed.c +++ b/testbed.c @@ -3,6 +3,8 @@ #include #include #include +#include +#include #include "video.h" #include "kbd.h" @@ -742,6 +744,7 @@ int main(int argc, char *argv[]) { if (argc > 1) { bootjor = argv[1]; } + randomize(); ser_init(SER_COM2, BAUD_19200, SER_8N1); game_init(); game_f_init(argv[0], bootjor); diff --git a/timer.jim b/timer.jim index 7cc4849..7272b3b 100755 Binary files a/timer.jim and b/timer.jim differ diff --git a/timer.jor b/timer.jor index 31fa9f0..c0e5004 100755 --- a/timer.jor +++ b/timer.jor @@ -33,5 +33,6 @@ >rot suspend repeat rdrop drop drop drop drop ; +: still-waiting? ( count ticks-start -- ) ticks udelta u> ; : sleep ( count -- ) - ticks swap begin over ticks udelta over u< while suspend repeat drop drop ; + ticks begin 2dup still-waiting? while suspend repeat drop drop ;