pete286/game.jor

: 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 ( 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 24 10 footer-y move-to ;
: hide-footer 0 10 footer-y 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 + swap ;

var tileselect
8 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 ;

: 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 tell .
  fget tell . fget tell . cr .s
  2dup * map fread
  mapsize!
  factivate ;

( 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 <rot 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

s" pete.map" load-map