DSL for level-based player touch event handling
This commit is contained in:
parent
9165b44bc7
commit
f16962f7f9
13
defs.jor
13
defs.jor
|
@ -15,6 +15,7 @@
|
||||||
<rot if r< | else r< ~ & then ( v newval )
|
<rot if r< | else r< ~ & then ( v newval )
|
||||||
swap ! ;
|
swap ! ;
|
||||||
: f@ ( v flag -- ) swap @ & ;
|
: f@ ( v flag -- ) swap @ & ;
|
||||||
|
: fnot! 2dup f@ not f! ;
|
||||||
|
|
||||||
: expile state if , else execute then ;
|
: expile state if , else execute then ;
|
||||||
|
|
||||||
|
@ -53,6 +54,18 @@
|
||||||
|
|
||||||
: links begin yield @ dup not until ;
|
: links begin yield @ dup not until ;
|
||||||
|
|
||||||
|
( usage:
|
||||||
|
: search-xy { x y -- b r: coroutine } begin 2dup search >rot drop drop ;
|
||||||
|
: test-xy { x y -- b }
|
||||||
|
search-xy 1 2 2= yield 3 4 2= yield drop drop 999 yield ;
|
||||||
|
test-xy will return 1 if x y is 1 2 or 3 4, otherwise it returns 999.
|
||||||
|
Note that it must always end with a yield, as search has no way to tell
|
||||||
|
the difference between an early termination and a final non-zero result.
|
||||||
|
)
|
||||||
|
: search
|
||||||
|
' yield , ' dup , ' not , [ ' while , ] ' drop , [ ' repeat , ]
|
||||||
|
' rdrop , ; immediate
|
||||||
|
|
||||||
: min ( x y -- x|y ) 2dup > if swap then drop ;
|
: min ( x y -- x|y ) 2dup > if swap then drop ;
|
||||||
: max ( x y -- x|y ) 2dup < if swap then drop ;
|
: max ( x y -- x|y ) 2dup < if swap then drop ;
|
||||||
|
|
||||||
|
|
BIN
entity.jim
BIN
entity.jim
Binary file not shown.
BIN
footer.jim
BIN
footer.jim
Binary file not shown.
|
@ -33,16 +33,16 @@ var textx
|
||||||
var texty
|
var texty
|
||||||
2 const textspeed
|
2 const textspeed
|
||||||
|
|
||||||
: nltext 7 textx ! 10 texty +! ;
|
: nltext 6 textx ! 10 texty +! ;
|
||||||
: inctextx
|
: inctextx
|
||||||
textx @ 1 + dup 38 <= if textx !
|
textx @ 1 + dup 38 <= if textx !
|
||||||
else drop nltext then ;
|
else drop nltext inctextx then ;
|
||||||
|
|
||||||
key \ const '\'
|
key \ const '\'
|
||||||
: statusc
|
: statusc
|
||||||
dup dup '\' = swap '\n' = or if drop nltext
|
dup dup '\' = swap '\n' = or if drop nltext
|
||||||
else dup '\r' = if drop
|
else dup '\r' = if drop
|
||||||
else textx @ texty @ <rot text-color @ textc inctextx then then ;
|
else inctextx textx @ texty @ <rot text-color @ textc then then ;
|
||||||
|
|
||||||
var texttimer
|
var texttimer
|
||||||
: textnextc ( s -- s )
|
: textnextc ( s -- s )
|
||||||
|
@ -59,7 +59,7 @@ var texttimer
|
||||||
WHITE text-color !
|
WHITE text-color !
|
||||||
s" " dup dup status0 status1 status2
|
s" " dup dup status0 status1 status2
|
||||||
text-color !
|
text-color !
|
||||||
7 textx !
|
6 textx !
|
||||||
10 texty ! ;
|
10 texty ! ;
|
||||||
|
|
||||||
: show-footer 48 10 footer-y move-to ;
|
: show-footer 48 10 footer-y move-to ;
|
||||||
|
|
25
game.jor
25
game.jor
|
@ -70,19 +70,26 @@ defer player
|
||||||
|
|
||||||
defer player-touch ( x y -- b )
|
defer player-touch ( x y -- b )
|
||||||
|
|
||||||
|
: touch-begin begin 2dup search >rot drop drop 1 - ;
|
||||||
|
: touched? if 2 else 1 then ;
|
||||||
|
: touched-more? if 2 else 0 then ;
|
||||||
|
: touch-next ' touched-more? , ' yield , ; immediate
|
||||||
|
: touch-last ' touched? , ' yield , ; immediate
|
||||||
|
: ;touch [ ' touch-last , ' [ , ] ; immediate
|
||||||
|
|
||||||
: check-player-touch ( x y -- b )
|
: check-player-touch ( x y -- b )
|
||||||
2dup entity-at dup if EVTOUCH entity>do drop drop 1 else drop
|
touch-begin entity-at dup if EVTOUCH entity>do 1 then
|
||||||
2dup player-touch if drop drop 1 else
|
touch-next player-touch
|
||||||
2dup out-of-bounds if drop drop 1 else
|
touch-next out-of-bounds
|
||||||
player.canmove? if 0 else 1 then then then then ;
|
touch-next player.canmove? not ;touch
|
||||||
|
|
||||||
: try-move-player
|
: try-move-player
|
||||||
player entity-dst check-player-touch not if move-player then ;
|
player entity-dst check-player-touch not if move-player then ;
|
||||||
|
|
||||||
: check-entity-touch ( x y -- b )
|
: check-entity-touch
|
||||||
2dup entity-at if drop drop 1 else
|
touch-begin entity-at
|
||||||
2dup out-of-bounds if 1 else
|
touch-next out-of-bounds
|
||||||
WALKABLE mapflag? if 0 else 1 then then then ;
|
touch-next WALKABLE mapflag? ;touch
|
||||||
|
|
||||||
: try-move-entity ( e -- )
|
: try-move-entity ( e -- )
|
||||||
dup entity-dst check-entity-touch not if move-entity then ;
|
dup entity-dst check-entity-touch not if move-entity then ;
|
||||||
|
@ -100,7 +107,7 @@ player :tick
|
||||||
|
|
||||||
( S T U F F )
|
( S T U F F )
|
||||||
: hello-world
|
: hello-world
|
||||||
player.state DRIVING f@ not player.state DRIVING f! ;
|
player.state DRIVING fnot! ;
|
||||||
|
|
||||||
: mode-move
|
: mode-move
|
||||||
entities each EVTICK entity>do more
|
entities each EVTICK entity>do more
|
||||||
|
|
12
pete.jor
12
pete.jor
|
@ -12,15 +12,13 @@ car :touch
|
||||||
player.driving? not if car yield then
|
player.driving? not if car yield then
|
||||||
0 |; ' entities redefine
|
0 |; ' entities redefine
|
||||||
|
|
||||||
( TODO: DSL for touch events? )
|
:| touch-begin S leaving? player.driving? not and dup if
|
||||||
:| 2dup S leaving? player.driving? not and if
|
pete say" It's too far to walk to town." then
|
||||||
pete say" It's too far to walk to town." 1 else
|
touch-next 12 7 2= dup if
|
||||||
2dup 12 7 2= if
|
|
||||||
player.driving? not if
|
player.driving? not if
|
||||||
petehous.jor queue-level
|
petehous.jor queue-level
|
||||||
then 1
|
then then
|
||||||
else 0 then then >rot drop drop
|
touch-last |; ' player-touch redefine
|
||||||
|; ' player-touch redefine
|
|
||||||
s" pete.map" load-map
|
s" pete.map" load-map
|
||||||
; ' onload redefine
|
; ' onload redefine
|
||||||
|
|
||||||
|
|
BIN
petehous.jim
BIN
petehous.jim
Binary file not shown.
14
petehous.jor
14
petehous.jor
|
@ -3,11 +3,19 @@
|
||||||
:noname
|
:noname
|
||||||
reset-level
|
reset-level
|
||||||
16 9 tile>world player entity.pos!
|
16 9 tile>world player entity.pos!
|
||||||
:| 16 10 2= if
|
:|
|
||||||
|
touch-begin 16 10 2= dup if
|
||||||
12 8 tile>world player entity.pos!
|
12 8 tile>world player entity.pos!
|
||||||
pete.jor queue-level
|
pete.jor queue-level
|
||||||
1 else 0 then
|
then touch-next 9 4 2= dup if
|
||||||
|; ' player-touch redefine
|
pete say" The closet is a disaster.\I don't want to deal with that\right now."
|
||||||
|
then touch-next 11 4 2= dup if
|
||||||
|
pete say" I'm already dressed."
|
||||||
|
then touch-next 16 3 2= dup if
|
||||||
|
pete say" The sink's full of nasty dishes.\I'm not touching them."
|
||||||
|
then touch-next 18 3 2= dup if
|
||||||
|
pete say" Should get some more beer soon."
|
||||||
|
then touch-last |; ' player-touch redefine
|
||||||
|
|
||||||
s" petehous.map" load-map
|
s" petehous.map" load-map
|
||||||
; ' onload redefine
|
; ' onload redefine
|
||||||
|
|
Loading…
Reference in a new issue