211 lines
4.5 KiB
Plaintext
Executable file
211 lines
4.5 KiB
Plaintext
Executable file
: blah
|
|
' seremit task-emit !
|
|
' log-emit task-echo ! ;
|
|
|
|
' seremit task-emit !
|
|
|
|
: start-repl activate blah
|
|
s" .:: J O R T H ( jean forth) ::." type cr
|
|
begin receive loadstring s" ok" type cr again ;
|
|
task const REPL
|
|
REPL start-repl
|
|
|
|
1 const ^ESC
|
|
28 const ^ENTER
|
|
29 const ^CTRL
|
|
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 ;
|
|
|
|
defer tick
|
|
defer draw
|
|
|
|
: defentity var 2 cells allot ;
|
|
: entity.x ;
|
|
: entity.y cell + ;
|
|
: entity.dir 2 cells + ;
|
|
|
|
0 const W
|
|
1 const E
|
|
2 const N
|
|
3 const S
|
|
|
|
: 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 ;
|
|
|
|
: defsprite ( s n e w ) b, b, b, b, here 4 - const ;
|
|
: sprindex ( sprite dir ) + b@ ;
|
|
|
|
3 1 0 2 defsprite s_car
|
|
|
|
defentity player
|
|
|
|
128 player entity.x !
|
|
128 player entity.y !
|
|
|
|
( 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 )
|
|
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 ;
|
|
|
|
: text1 6 4 rot text ;
|
|
: text2 6 12 rot text ;
|
|
: clear s" " dup text1 text2 ;
|
|
|
|
: move-to ( p target speed -- )
|
|
rot 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 footer-y 24 10 move-to ;
|
|
: hide-footer footer-y 0 10 move-to ;
|
|
|
|
: say1 ( s -- ) clear text1 show-footer ^ENTER wait-key ;
|
|
: say2 ( s1 s2 -- ) clear text2 text1 show-footer ^ENTER wait-key ;
|
|
|
|
( M O U S E )
|
|
|
|
var prevbutton
|
|
: tick-debounce
|
|
mousebuttons prevbutton ! ;
|
|
|
|
1 const MOUSEL
|
|
: 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 rot + swap ;
|
|
|
|
var tileselect
|
|
3 const MAXTILE
|
|
|
|
: mouseworldpos mousepos scrollpos +pos ;
|
|
: mousetile mouseworldpos 4 >> swap 4 >> swap ;
|
|
: tile ( x y -- ptr ) mapsize drop * + map + ;
|
|
|
|
: 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 ;
|
|
|
|
|
|
( 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
|
|
|
|
( T I C K )
|
|
|
|
: move-player
|
|
player entity.dir @ dir>pos
|
|
dup if swap drop player entity.y ( d v -- )
|
|
else drop player entity.x then
|
|
swap 16 * over @ + 4 move-to ;
|
|
|
|
: 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 ;
|
|
|
|
: hello-world
|
|
s" Hello, world!" say1
|
|
s" How are you" s" today?" say2 ;
|
|
|
|
: mode-move
|
|
tick-player
|
|
tick-mapedit
|
|
^SPACE key-pressed if
|
|
' hello-world JOB send
|
|
then
|
|
tick-debounce ;
|
|
|
|
' mode-move MODE-MOVE !
|
|
' tick-debounce MODE-WAIT !
|
|
|
|
: draw-player
|
|
player entity.x @
|
|
player entity.y @
|
|
s_car player entity.dir @ sprindex
|
|
draw-sprite ;
|
|
|
|
: full-draw
|
|
player entity.x @ 152 -
|
|
player entity.y @ 92 -
|
|
scroll
|
|
|
|
draw-player
|
|
48 64 0 draw-sprite
|
|
640 640 2 draw-sprite
|
|
mouseworldpos 4 draw-sprite
|
|
draw-screen
|
|
draw-footer ;
|
|
|
|
MODE-MOVE @ ' tick redefine
|
|
' full-draw ' draw redefine
|