finish level 5, some Jorth improvements, add timed switches

This commit is contained in:
Jeremy Penner 2020-03-07 18:55:18 -05:00
parent 568eec063a
commit 750db86658
28 changed files with 173 additions and 46 deletions

BIN
boot.jim

Binary file not shown.

View file

@ -1,8 +1,8 @@
0 const 0
1 const 1
2 const cell 2 const cell
: cells cell * ; : cells cell * ;
key ) const ')'
10 const '\n' 10 const '\n'
13 const '\r' 13 const '\r'
key const sp key const sp
@ -23,8 +23,8 @@ key const sp
: again ' GOTO_ , , ; immediate : again ' GOTO_ , , ; immediate
: until ' BZ_ , , ; immediate : until ' BZ_ , , ; immediate
: ( begin key ')' = until ; immediate
: lit ' LIT_ , , ; : lit ' LIT_ , , ;
: ( begin key [ key ) lit ] = until ; immediate
: inline| ' INLINEDATA_ , here 0 , ; : inline| ' INLINEDATA_ , here 0 , ;
: |inline [ ' then , ] ; : |inline [ ' then , ] ;
@ -33,10 +33,8 @@ key const sp
: :| inline| $DOCOLON , ; immediate : :| inline| $DOCOLON , ; immediate
: |; ' ret , |inline ; immediate : |; ' ret , |inline ; immediate
key " const '"'
: s" state if inline| else here then : 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 state if |inline else dup here! then ; immediate
: interpretword F_IMMEDIATE & state not or if execute else , then ; : interpretword F_IMMEDIATE & state not or if execute else , then ;

BIN
defs.jim

Binary file not shown.

View file

@ -114,6 +114,11 @@
then then
more ; more ;
: lazy here $DODEFERRED , ' noop , ;
: >lazy! latest codepointer swap redefine ;
: dbg" [ ' s" , ] :| type bl .s cr |; expile ; immediate
( tasks ) ( tasks )
: mailbox 2 cells + ; : mailbox 2 cells + ;
: task-ip task-user-size cells + ; : task-ip task-user-size cells + ;

BIN
end.jim

Binary file not shown.

Binary file not shown.

Binary file not shown.

BIN
game.jim

Binary file not shown.

109
game.jor
View file

@ -2,6 +2,8 @@
defer party defer party
defer entities defer entities
var objects var objects
var ticking-objects
var visible-objects
: obj-entity ( optr -- entity ) cell + @ ; : obj-entity ( optr -- entity ) cell + @ ;
@ -26,13 +28,14 @@ var posessed-rexx
: isneut? isprog? posessed-rexx @ not and ; userword : isneut? isprog? posessed-rexx @ not and ; userword
: isjaye? isprog? not ; userword : isjaye? isprog? not ; userword
: isrexx? isprog? posessed-rexx @ and ; userword : isrexx? isprog? posessed-rexx @ and ; userword
: gord-follow? player.state HASGORD f@ ;
: {jaye} : {jaye}
isjaye? player.state MOVING f@ and isjaye? player.state MOVING f@ and
if {jaye-walk} else {jaye-stand} then ; if {jaye-walk} else {jaye-stand} then ;
: {gord} : {gord}
player.state HASGORD f@ if gord-follow? if
isjaye? player.state MOVING f@ and player.state GORDSIT f@ or isjaye? player.state MOVING f@ and player.state GORDSIT f@ or
if {gord-walk} else {gord-stand} then if {gord-walk} else {gord-stand} then
else player.state GORDSIT f@ if {gord-sit} else {gord-floor} then 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 defer on-gord-sit
: do-gord-sit ( x y -- b ) : do-gord-sit ( x y -- b )
player.state HASGORD f@ isjaye? and if isjaye? gord-follow? and if
tile b@ CHAIR = if tile b@ CHAIR = if
1 player.state GORDSIT f! 1 player.state GORDSIT f!
player.prevdir @ Gord entity.dir ! player.prevdir @ Gord entity.dir !
@ -171,13 +174,15 @@ var q-level
: queue-level q-level ! ; userword : queue-level q-level ! ; userword
: player-tick : player-tick
^SPACE key-pressed player.state HASNEUT f@ and if ^SPACE key-pressed if player.state HASNEUT f@ if
player.state ISPROG fnot! player.state ISPROG fnot!
isprog? if prog-view else human-view then isprog? if prog-view else human-view then
then then then
^Z key-pressed player.state GORDSIT f@ and isjaye? and if ^Z key-pressed if player.state GORDSIT f@ if
isprog? 0 player.state ISPROG f!
activate-gord activate-gord
then player.state ISPROG f!
then then
0 ^LEFT key-down if drop 1 W player entity.dir ! then 0 ^LEFT key-down if drop 1 W player entity.dir ! then
^RIGHT key-down if drop 1 E 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 ^UP key-down if drop 1 N player entity.dir ! then
@ -190,8 +195,12 @@ defer reset-level userword
: mode-move : mode-move
player-tick player-tick
( objects @ if objects @ links each dup obj-entity EVTICK entity>do more ticking-objects @ if
entities each EVTICK entity>do more ticking-objects @ links
each dup obj-entity EVTICK entity>do more
then
( entities each EVTICK entity>do more
party each EVTICK entity>do more party each EVTICK entity>do more
Neut EVTICK entity>do ) Neut EVTICK entity>do )
@ -210,6 +219,11 @@ defer reset-level userword
r@ entity.dir @ <r entity>sprite r@ entity.dir @ <r entity>sprite
sprite-bob draw-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 glitchlevel
var quaking var quaking
@ -225,8 +239,8 @@ var quaking
party each dup Jaye != if draw-entity else drop then more party each dup Jaye != if draw-entity else drop then more
Jaye draw-entity Jaye draw-entity
player.state HASNEUT f@ if Neut draw-entity then player.state HASNEUT f@ if Neut draw-entity then
objects @ if visible-objects@ if
objects @ links each dup obj-entity draw-entity more visible-objects@ links each dup obj-entity draw-entity more
then then
entities each draw-entity more entities each draw-entity more
@ -239,15 +253,23 @@ var quaking
var defining-objects-head var defining-objects-head
var defining-objects-ptr var defining-objects-ptr
: objects: create here 0 , : objects: create here 0 , 0 , 0 ,
0 defining-objects-head ! 0 defining-objects-head !
defining-objects-ptr ! 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 -- ) : link-object ( entity -- )
here defining-objects-head @ , swap , here defining-objects-head @ , swap , defining-objects-head !
dup defining-objects-head ! 0 obj-link-head! ;
defining-objects-ptr @ ! ;
: obj-ticking! 1 obj-link-head! ;
: obj-visible! 2 obj-link-head! ;
: entity>tile ( entity -- tile ) entity>pos world>tile tile ; : entity>tile ( entity -- tile ) entity>pos world>tile tile ;
: entity>tile? ( entity expected - b ) swap entity>tile b@ = ; : entity>tile? ( entity expected - b ) swap entity>tile b@ = ;
@ -259,16 +281,20 @@ does> @ objects ! ;
: respondertile! ( tile -- ) responder entity>tile b! invalidate-map ; : 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 <r ; : blankentity array here >r N ' {tileent} allotentity <r ;
: linked-entity responder entity.user @ execute ; : linked-entity responder entity.user @ execute ;
: timer>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-object blankentity dup link-object ;
: create-linked-object blankentity swap , 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 ! ; : listener! ( entity listener ) swap ! ;
: handle-onoff ( ev on off -- ) : handle-onoff ( ev on off -- )
@ -288,7 +314,7 @@ var _dorubber
: exitdoor create-linked-object : exitdoor create-linked-object
:| dup door-listener entering-door? if :| 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." jaye say" I'm not leaving Gord behind."
else else
responder entity.user @ queue-level responder entity.user @ queue-level
@ -304,14 +330,31 @@ var _dorubber
linked-entity swap entity>do linked-entity swap entity>do
else drop then ; else drop then ;
: switch create-linked-object : handle-switch-touch ( ev -- )
:| dup EVTOUCH = isneut? and if move-player then dup EVTOUCH = isneut? and if move-player then
dup EVTOUCH = isrexx? not and if dup EVTOUCH = isrexx? not and if
responder EVTOG entity>do responder EVTOG entity>do
isjaye? if wait-for-arrow-up then isjaye? if wait-for-arrow-up then
then then
dup SWITCH-ON SWITCH-OFF handle-onoff dup SWITCH-ON SWITCH-OFF handle-onoff
SWITCH-ON handle-link |; listener! ; 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? ; : computer-on? ( entity -- b ) COMP-ON entity>tile? ;
@ -339,7 +382,7 @@ var _dorubber
SCAN-ON handle-link |; listener! ; SCAN-ON handle-link |; listener! ;
: defrexx array here >r S ' {rexx} allotentity <r : defrexx array here >r S ' {rexx} allotentity <r
dup link-object dup link-object obj-visible!
:| EVTOUCH = isneut? and if :| EVTOUCH = isneut? and if
move-player move-player
responder posessed-rexx ! responder posessed-rexx !
@ -359,7 +402,7 @@ var _dorubber
: with-gord Gord follow 1 player.state HASGORD f! ; : with-gord Gord follow 1 player.state HASGORD f! ;
Gord :noname Gord :noname
dup EVTOUCH = isjaye? and player.state HASGORD f@ not and if dup EVTOUCH = isjaye? and gord-follow? not and if
player.state GORDSIT f@ if player.state GORDSIT f@ if
1 player.state HASGORD f! 1 player.state HASGORD f!
Gord player face Gord player face
@ -373,10 +416,10 @@ Gord @ const gord-listener
: chain-gord-listener gord-listener execute ; : chain-gord-listener gord-listener execute ;
:noname :noname
0 objects ! 0 objects ! 0 ticking-objects ! 0 visible-objects !
Gord gord-listener listener! Gord gord-listener listener!
' noop ' on-gord-sit redefine ' noop ' on-gord-sit redefine
:| player.state HASGORD f@ not gord-present? and if Gord yield then :| gord-follow? not gord-present? and if Gord yield then
done |; ' entities redefine done |; ' entities redefine
:| drop drop 0 |; ' touch-override redefine ; ' reset-level redefine :| drop drop 0 |; ' touch-override redefine ; ' reset-level redefine
@ -385,7 +428,7 @@ Gord @ const gord-listener
' mode-move ' tick redefine ' mode-move ' tick redefine
' full-draw ' draw redefine ' full-draw ' draw redefine
:| Jaye yield :| Jaye yield
player.state HASGORD f@ if Gord yield then gord-follow? if Gord yield then
done |; ' party redefine done |; ' party redefine
:| ' tick-debounce ' tick redefine |; ' any-job-started redefine :| ' tick-debounce ' tick redefine |; ' any-job-started redefine
:| ' mode-move ' tick redefine hide-footer |; ' all-jobs-complete redefine :| ' mode-move ' tick redefine hide-footer |; ' all-jobs-complete redefine

BIN
input.jim

Binary file not shown.

BIN
jiles.jim

Binary file not shown.

BIN
job.jim

Binary file not shown.

BIN
jopl.jim

Binary file not shown.

View file

@ -1,6 +1,7 @@
//#define TRACE //#define TRACE
#include <stdio.h> #include <stdio.h>
#include <stdlib.h>
#include <sys/stat.h> #include <sys/stat.h>
#include <dos.h> #include <dos.h>
#include <dir.h> #include <dir.h>
@ -1072,6 +1073,10 @@ void f_taskusersize() {
PUSHU(TASK_USER_SIZE); PUSHU(TASK_USER_SIZE);
} }
void f_rand() {
PUSHI(rand());
}
void f_init(char *exe) { void f_init(char *exe) {
f_calc_imagemagic(exe); f_calc_imagemagic(exe);
@ -1202,6 +1207,7 @@ void f_init(char *exe) {
CDEF("stacksize", f_stacksize); CDEF("stacksize", f_stacksize);
CDEF("rstacksize", f_rstacksize); CDEF("rstacksize", f_rstacksize);
CDEF("task-user-size", f_taskusersize); CDEF("task-user-size", f_taskusersize);
CDEF("rand", f_rand);
PCONST("$DOCREATE", f_docreate); PCONST("$DOCREATE", f_docreate);
PCONST("$DOVAR", f_dovar); PCONST("$DOVAR", f_dovar);
PCONST("$DODEFERRED", f_dodeferred); PCONST("$DODEFERRED", f_dodeferred);

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

View file

@ -2,25 +2,96 @@
objects: O objects: O
lazy 60 over 19 9 timedswitch ts
16 7 defrexx Rexx 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 ; :noname 0 MAXTILE for i tileflags + b@ RUBBLE & if i b, then next ;
array rubbletiles execute array rubbletiles execute
here rubbletiles - 1 - const MAXRUBBLE 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-pos ( -- x y ) Rexx entity>pos world>tile ;
: rexx-dest ( -- x y ) rexx-pos Rexx entity.dir @ dir>pos +pos ; : 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 ; : not-picking-up? ( -- b ) rexx-dest RUBBLE mapflag? not ;
: touch ( x y -- b ) : touch ( x y -- b )
drop drop drop 13 <= isrexx? and posessed-rexx @ Rexx = and if
not-picking-up? can-drop-rubble? and isrexx? and if 3 glitchlevel !
randomrubble rexx-pos tile b! invalidate-map rexx say" PaRiTy ErrRor!!"
then 0 ; 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 :noname O

Binary file not shown.

BIN
map.jim

Binary file not shown.

Binary file not shown.

Binary file not shown.

BIN
state.jim

Binary file not shown.

View file

@ -3,6 +3,8 @@
#include <dos.h> #include <dos.h>
#include <alloc.h> #include <alloc.h>
#include <ctype.h> #include <ctype.h>
#include <stdlib.h>
#include <time.h>
#include "video.h" #include "video.h"
#include "kbd.h" #include "kbd.h"
@ -742,6 +744,7 @@ int main(int argc, char *argv[]) {
if (argc > 1) { if (argc > 1) {
bootjor = argv[1]; bootjor = argv[1];
} }
randomize();
ser_init(SER_COM2, BAUD_19200, SER_8N1); ser_init(SER_COM2, BAUD_19200, SER_8N1);
game_init(); game_init();
game_f_init(argv[0], bootjor); game_f_init(argv[0], bootjor);

BIN
timer.jim

Binary file not shown.

View file

@ -33,5 +33,6 @@
>rot suspend >rot suspend
repeat rdrop drop drop drop drop ; repeat rdrop drop drop drop drop ;
: still-waiting? ( count ticks-start -- ) ticks udelta u> ;
: sleep ( count -- ) : 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 ;