pete286/game.jor

366 lines
8.2 KiB
Plaintext
Raw Normal View History

: blah
' seremit task-emit !
' log-emit task-echo ! ;
2019-02-16 00:39:50 +00:00
' seremit task-emit !
: start-repl activate blah
s" .:: J O R T H ( jean forth) ::." type cr
2019-02-11 00:17:58 +00:00
begin receive loadstring s" ok" type cr again ;
task const REPL
REPL start-repl
1 const ^ESC
28 const ^ENTER
29 const ^CTRL
2019-02-18 01:14:56 +00:00
51 const ^<
52 const ^>
56 const ^ALT
57 const ^SPACE
72 const ^UP
75 const ^LEFT
77 const ^RIGHT
80 const ^DOWN
: wait-key ( k -- ) begin dup key-pressed not while suspend repeat drop ;
: udelta ( u u -- u )
2dup u> if
swap -1 swap - + 1 +
else
swap -
then ;
: sleep ( count -- )
ticks swap begin over ticks udelta over u< while suspend repeat drop drop ;
2019-02-11 00:17:58 +00:00
defer tick
defer draw
: defentity ( x y dir anim do -- ) array , , , 4 << , 4 << , ;
: entity.x 4 cells + ;
: entity.y 3 cells + ;
: entity.dir 2 cells + ;
: entity>sprite cell + @ execute ;
: entity>do ( entity event ) swap @ execute ;
2019-02-11 00:17:58 +00:00
0 const W
1 const E
2 const N
3 const S
2019-02-18 01:14:56 +00:00
: dir>pos ( dir -- dx dy )
dup W = if drop -1 0 ret then
dup E = if drop 1 0 ret then
N = if 0 -1
else 0 1 then ;
: frame ( s n e w ) b, b, b, b, ;
array frames
( 0: car ) 3 1 0 2 frame
( 1: pete stand ) 11 9 7 5 frame
( 2: pete walk ) 12 10 8 6 frame
: sprindex ( dir frame ) 2 << frames + + b@ ;
: defstatic ( frame -- ) create b, does> b@ sprindex ;
: defanim ( frame... framecount ticks-per-frame -- )
create b, dup b, 0 for b, next
does> ( dir a -- )
dup dup 1 + b@ swap b@ ( dir a count tpf )
ticks swap / swap % ( dir a index )
2 + + b@ sprindex ;
0 defstatic {car}
1 defstatic {pete-stand}
1 2 2 5 defanim {pete-walk}
( timer + lerping )
: clamp0 ( range val -- i )
2dup <= if drop else
dup 0 <= if drop drop 0 else
swap drop then then ;
: >ratio ( range value -- f )
2019-02-18 01:14:56 +00:00
over swap clamp0 swap />ratio ;
: <ratio ( range ratio -- v ) *<ratio ;
: >range ( start end -- start range ) over - ;
: <range ( start range -- start end ) over + ;
: lerpr ( start end ratio ) r> >range r< <ratio + ;
: lerpn ( start1 end1 start2 end2 val )
r> >range r< <rot - >ratio lerpr ;
: lerp ( start end duration start -- i )
ticks udelta ( start end duration delta )
>ratio lerpr ;
: triggered ( duration timer -- b )
dup r> @ ticks udelta ( duration delta )
2dup <= if drop r< +! 1 else drop drop 0 then ;
: now! ( timer -- ) ticks swap ! ;
( F O O T E R )
var footer-y
0 footer-y !
: draw-footer footer-y @ split-screen ;
0 const BLACK
1 const BLUE
2 const GREEN
3 const CYAN
4 const RED
5 const MAGENTA
6 const BROWN
7 const LGRAY
8 const DGRAY
9 const LBLUE
10 const LGREEN
11 const LCYAN
12 const PINK
13 const LMAGENTA
14 const YELLOW
15 const WHITE
var text-color
WHITE text-color !
: texty 7 swap <rot text-color @ text ;
: text0 10 texty ;
: text1 20 texty ;
: text2 30 texty ;
: clear
text-color @
WHITE text-color !
s" " dup dup text0 text1 text2
text-color ! ;
: move-to ( target speed p -- )
dup r> @ >rot ticks ( from to duration start )
begin
4dup lerp r@ !
<rot dup r@ @ != ( from duration start to !done )
while
>rot suspend
repeat rdrop drop drop drop drop ;
: show-footer 48 10 footer-y move-to ;
: hide-footer 0 10 footer-y move-to ;
: footer-wait show-footer ^ENTER wait-key ;
( todo: generic say" that handles newlines, gradual text display )
: say1 ( s -- ) clear text1 footer-wait ;
: say2 ( s1 s2 -- ) clear text1 text0 footer-wait ;
: say3 ( s1 s2 s3 -- ) clear text2 text1 text0 footer-wait ;
: character ( iportrait color ) create , ,
does> dup @ text-color ! cell + @ draw-portrait ;
0 GREEN character pete
1 MAGENTA character mary
2 BROWN character chuck
2019-02-18 01:14:56 +00:00
( M O U S E )
var prevbutton
: tick-debounce
mousebuttons prevbutton ! ;
1 const MOUSEL
2 const MOUSER
2019-02-18 01:14:56 +00:00
: mousedown ( button -- bool ) mousebuttons & ;
: clicked ( button -- bool )
dup mousedown not swap
prevbutton @ & and ;
( M A P )
: +pos ( x1 y1 x2 y2 -- x y )
<rot + >rot + swap ;
2019-02-18 01:14:56 +00:00
var tileselect
2019-02-24 22:26:28 +00:00
8 const MAXTILE
2019-02-18 01:14:56 +00:00
: mouseworldpos mousepos scrollpos +pos ;
: world>tile 4 >> swap 4 >> swap ;
: mousetile mouseworldpos world>tile ;
2019-02-18 01:14:56 +00:00
: tile ( x y -- ptr ) mapsize drop * + map + ;
1 const WALKABLE
2 const DRIVABLE
array tileflags
( grass ) WALKABLE b,
( dirt ) WALKABLE b,
( water ) 0 b,
( pavement ) WALKABLE DRIVABLE | b,
( brick ) 0 b,
( forest ) 0 b,
( roof ) 0 b,
( brick ) 0 b,
( window ) 0 b,
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
: walkable? ( x y -- b ) WALKABLE mapflag? ;
: drivable? ( x y -- b ) DRIVABLE mapflag? ;
2019-02-18 01:14:56 +00:00
: tick-mapedit
tileselect @
^< key-pressed if 1 - then
^> key-pressed if 1 + then
dup 0 < if drop MAXTILE then
dup MAXTILE > if drop 0 then
tileselect !
MOUSEL mousedown if tileselect @ mousetile tile b! then
MOUSER clicked if mouseworldpos world>tile swap . . then ;
2019-02-24 22:26:28 +00:00
: copy-mapseg ( neww oldw y -- )
r> ( oldw neww r: y )
2dup min >rot ( copyw neww oldw )
r@ * map + ( copyw neww src )
swap r< * map + ( copyw src dst )
swap <rot memmove ;
: resize-map ( neww newh -- )
swap mapsize r> ( newh neww oldw r: oldh )
2dup < if 1 r< else r< 1 - 0 then ( newh neww copyw ystart ylim )
for 2dup i copy-mapseg next
drop swap mapsize! ;
: save-map ( filename -- )
fdeactivate swap overwrite
mapsize swap fput fput
mapsize * map fwrite
factivate ;
: load-map ( filename -- )
fdeactivate swap open
fget fget
2dup * map fread
mapsize!
factivate ;
2019-02-11 00:17:58 +00:00
2019-02-18 01:14:56 +00:00
( J O B )
var MODE-MOVE
var MODE-WAIT
: listen-for-jobs activate blah
begin receive
MODE-WAIT @ ' tick redefine
execute
hide-footer
MODE-MOVE @ ' tick redefine
again ;
task const JOB
JOB listen-for-jobs
2019-02-18 01:14:56 +00:00
( T I C K )
defer entities
0 const EVTICK
1 const EVTOUCH
: entity-at ( x y -- entity|0 )
0 >rot
entities each r> 2dup ( 0 x y x y r:e )
r@ entity.x @ r@ entity.y @ world>tile 2= ( 0 x y eq r:e )
if <rot drop r< >rot break ( e x y )
else rdrop then ( 0 x y )
more drop drop ;
( P L A Y E R )
var player.state
defer player
1 const MOVING
2 const DRIVING
: {player}
player.state DRIVING f@ if {car}
else player.state MOVING f@ if {pete-walk}
else {pete-stand} then then ;
: player.canmove? ( x y -- )
player.state DRIVING f@ if DRIVABLE else WALKABLE then mapflag? ;
2019-02-18 01:14:56 +00:00
: move-entity ( e -- )
dup entity.dir @ dir>pos ( e dx dy )
dup if swap drop swap entity.y
else drop swap entity.x then
swap 16 * over @ + 4 <rot move-to ;
2019-02-18 01:14:56 +00:00
: move-player
player entity.dir @ dir>pos
player entity.x @ player entity.y @ world>tile +pos ( x y )
2dup entity-at r> player.canmove? if r< ( entity )
( touch entity if exists )
dup if
EVTOUCH entity>do
else drop
( move the player )
1 player.state MOVING f!
player move-entity
0 player.state MOVING f!
then
else rdrop then ;
2019-02-18 01:14:56 +00:00
: tick-player
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
^DOWN key-down if drop 1 S player entity.dir ! then
if ' move-player JOB send then ;
: think-player
EVTICK = if tick-player then ;
12 9 N ' {player} ' think-player defentity _player
' _player ' player redefine
( S T U F F )
2019-02-18 01:14:56 +00:00
: hello-world
s" Hello, world!" say1
s" How are you" s" today?" say2
player.state DRIVING f@ not player.state DRIVING f! ;
: mode-move
entities each EVTICK entity>do more
2019-02-18 01:14:56 +00:00
tick-mapedit
^SPACE key-pressed if
' hello-world JOB send
2019-02-18 01:14:56 +00:00
then
tick-debounce ;
' mode-move MODE-MOVE !
2019-02-18 01:14:56 +00:00
' tick-debounce MODE-WAIT !
: draw-entity
r> r@ entity.x @ r@ entity.y @
r@ entity.dir @ r< entity>sprite
2019-02-11 00:17:58 +00:00
draw-sprite ;
: full-draw
player entity.x @ 152 -
player entity.y @ 92 -
scroll
entities each draw-entity more
2019-02-18 01:14:56 +00:00
mouseworldpos 4 draw-sprite
draw-screen
draw-footer ;
2019-02-11 00:17:58 +00:00
MODE-MOVE @ ' tick redefine
' full-draw ' draw redefine
2019-02-24 22:26:28 +00:00
( P E T E )
8 8 E ' {car}
:noname EVTOUCH = if pete s" What an old rustbucket." say1 then ;
defentity car
:noname
player yield
car yield
0 ;
' entities redefine
2019-02-24 22:26:28 +00:00
s" pete.map" load-map