pete286/game.jor

: blah ' seremit task-emit ! ;
blah

: 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

0 const EVTICK
1 const EVTOUCH

: defentity ( x y dir anim -- ) array ' drop , , , 4 << , 4 << , ;
: entity.x 4 cells + ;
: entity.y 3 cells + ;
: entity.dir 2 cells + ;
: entity>sprite cell + @ execute ;
: entity>do ( entity event ) swap @ execute ;

var entity-defstate
: entitydo-ev ( [cp ifhere] ev -- )
  entity-defstate @ if swap [ ' then , ]
  else 1 entity-defstate ! :noname swap then
  ' dup , lit ' = , [ ' if , ] ;
: :touch EVTOUCH entitydo-ev ; immediate
: :tick EVTICK entitydo-ev ; immediate
: ;entity ( entity cp ifhere -- )
  [ ' then , ] ' drop , [ ' ; , ]
  0 entity-defstate ! swap ! ; immediate

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 ;

: 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 )
  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 rdrop 0 then ;

: now! ( timer -- ) ticks swap ! ;
: advance! ( timer -- delta )
  dup @ ticks udelta ( timer delta )
  dup <rot +! ;

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

: statusy 7 swap <rot text-color @ text ;
: status0 10 statusy ;
: status1 20 statusy ;
: status2 30 statusy ;

var textx
var texty
2 const textspeed

: nltext 7 textx ! 10 texty +! ;
: inctextx
  textx @ 1 + dup 38 <= if textx !
  else drop nltext then ;

key \ const '\'
: statusc
  dup dup '\' = swap '\n' = or if drop nltext
  else dup '\r' = if drop
  else textx @ texty @ <rot text-color @ textc inctextx then then ;

var texttimer
: textnextc ( s -- s )
  dup b@ dup if statusc 1 + else drop then ;

: slowtext ( s -- )
  texttimer now!
  begin dup b@ while
    texttimer advance! textspeed * 0 for textnextc next
  suspend repeat drop ;

: clear
  text-color @
  WHITE text-color !
  s"                                 " dup dup status0 status1 status2
  text-color !
  7 textx !
  10 texty ! ;

: 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 ;

: say ( s -- ) clear show-footer slowtext footer-wait ;
: say" [ ' s" , ] ' say expile ; immediate

: character ( iportrait color ) create , ,
  does> dup @ text-color ! cell + @ draw-portrait ;

0 GREEN character pete
1 MAGENTA character mary
2 BROWN character chuck

( M O U S E )

var prevbutton
: tick-debounce
  mousebuttons prevbutton ! ;

1 const MOUSEL
2 const MOUSER
: 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 ;
: world>tile 4 >> swap 4 >> swap ;
: mousetile mouseworldpos world>tile ;
: 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? ;

: 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 ;

: 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 ;

( 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 )
defer entities

: 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? ;

12 9 N ' {player} defentity player

: entity-dst ( e -- x y )
  r> r@ entity.dir @ dir>pos
  r@ entity.x @ r< entity.y @ world>tile +pos ;

: 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 ;

: move-player
  1 player.state MOVING f!
  player move-entity
  0 player.state MOVING f! ;

: out-of-bounds ( x y -- b )
  2dup 0 < swap 0 < or >rot mapsize ( b x y w h )
  <rot <= >rot ( b b x w )
  >= or or ;

: no-touch drop drop 0 ;
defer player-touch ( x y -- b )
' no-touch ' player-touch redefine

: check-player-touch ( x y -- b )
  2dup entity-at dup if EVTOUCH entity>do drop drop 1 else drop
  2dup player-touch if drop drop 1 else
  2dup out-of-bounds if drop drop 1 else
  player.canmove? if 0 else 1 then then then then ;

: try-move-player
  player entity-dst check-player-touch not if move-player then ;

: check-entity-touch ( x y -- b )
  2dup entity-at if drop drop 1 else
  2dup out-of-bounds if 1 else
  WALKABLE mapflag? if 0 else 1 then then then ;

: try-move-entity ( e -- )
  dup entity-dst check-entity-touch not if move-entity then ;

player :tick
  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 ' try-move-player JOB send then
;entity

( S T U F F )
: hello-world
  mary say" Hello, world!"
  say" How are you\today?"
  player.state DRIVING f@ not player.state DRIVING f! ;

: mode-move
  entities each EVTICK entity>do more
  tick-mapedit
  ^SPACE key-pressed if
    ' hello-world JOB send
  then
  tick-debounce ;

' mode-move MODE-MOVE !
' tick-debounce MODE-WAIT !

: draw-entity
  r> r@ entity.x @ r@ entity.y @
  r@ entity.dir @ r< entity>sprite
  draw-sprite ;

: full-draw
  player entity.x @ 152 -
  player entity.y @ 92 -
  scroll

  entities each draw-entity more
  mouseworldpos 4 draw-sprite
  draw-screen
  draw-footer ;

MODE-MOVE @ ' tick redefine
' full-draw ' draw redefine

( P E T E )

8 8 E ' {car} defentity car

var cartimer
cartimer now!
car :tick 60 cartimer triggered if
  :| car entity.dir @ E = if W else E then car entity.dir !
  car try-move-entity |; JOB send
then
:touch pete say" What an old rustbucket.
Hasn't driven in years."
;entity

:noname
  player yield
  car yield
  0 ;
' entities redefine

s" pete.map" load-map