diff --git a/boot.jim b/boot.jim index 815b51e..ce571b7 100755 Binary files a/boot.jim and b/boot.jim differ diff --git a/boot.jor b/boot.jor index 520d1d4..8d6cd67 100755 --- a/boot.jor +++ b/boot.jor @@ -49,17 +49,44 @@ key " const '"' : load-input swap-input r> r> interpreter r< r< swap-input ; : loadstring ' key-string load-input drop drop ; -: loadimage-if-uptodate ( filename -- b ) - dup image-uptodate if imagefilename open loadimage close else drop 0 then ; +( image loading ) +: noop ; -: loadjor ( filename -- ) +: defer word new-word $DODEFERRED , ' noop , ; +: redefine ( cp cpdeferred ) cell + ! ; +: definition ( cpdeferred ) cell + @ ; + +defer onload +: postload onload ' noop ' onload redefine ; + +: loadimage ( -- [0 | onload] ) + fget fget fget fget fget ( onload tasks latest size start ) + here != if tell + seek drop drop drop 0 else + dup here fread here + here! latest! tasks! then ; + +: saveimage ( herestart -- ) + ' onload definition here drop fput + tasks fput + latest fput + dup here swap - fput + dup fput + dup here swap - swap fwrite ; + +( file loading ) +: loadimage-if-uptodate ( filename -- b ) + dup image-uptodate if imagefilename open loadimage close else drop 0 then + dup if execute 1 then ; + +: interpretjor ( filename -- ) open fdeactivate ' key-file load-input drop factivate close ; +: loadjor fdeactivate swap interpretjor postload factivate ; + : loadfile ( filename -- ) ( active file is preserved for the currently-loading file, but the new file is always loaded with no active files ) fdeactivate swap dup loadimage-if-uptodate not if - dup here swap loadjor - swap imagefilename overwrite saveimage close + dup here swap interpretjor + swap imagefilename overwrite saveimage close postload else drop then factivate ; diff --git a/defs.jim b/defs.jim index 8ad65f1..ccece98 100755 Binary files a/defs.jim and b/defs.jim differ diff --git a/defs.jor b/defs.jor index a032e4d..3df7f50 100755 --- a/defs.jor +++ b/defs.jor @@ -9,8 +9,6 @@ : 2= ( a b c d -- a=c&b=d ) r> dup @ ( b v val r: flag ) @@ -26,9 +24,6 @@ : :| inline| $DOCOLON , ; immediate : |; ' ret , |inline ; immediate -: defer word new-word $DODEFERRED , ' noop , ; -: redefine ( cp cpdeferred ) cell + ! ; - : array word new-word $DOVAR , ; : create word new-word $DOCREATE , 0 , ; @@ -56,6 +51,8 @@ : dobreak yield 0 ; : break ' rdrop , ' dobreak , ; immediate +: links begin yield @ dup not until ; + : min ( x y -- x|y ) 2dup > if swap then drop ; : max ( x y -- x|y ) 2dup < if swap then drop ; @@ -76,6 +73,18 @@ : task-stack task-user-size 3 + cells + ; : task-rstack task-stack stacksize cells + ; +: .wordin ( ptr -- ) + latest links each + 2dup > if wordname type drop 0 break then + more dup if . else drop then ; + +: tasks.s + tasks links each + dup .wordin s" : " type + dup task-sp @ over task-stack ( task stackLim stack ) + begin 2dup > while dup @ . cell + repeat + cr drop drop more ; + : doactivate ( task ip -- ) over task-ip ! dup task-stack over task-sp ! @@ -89,11 +98,16 @@ ' ret , ; immediate -: send ( val task -- ) +: try-send ( val task -- b ) + mailbox dup @ if drop drop 0 else ! 1 then ; + +: wait-send ( val task -- ) mailbox begin dup @ while suspend repeat ( wait for empty mailbox ) ! ; +: send ( val task -- ) try-send drop ; + : receive ( -- val ) running mailbox begin dup @ not while suspend repeat ( wait for mail ) diff --git a/entity.jim b/entity.jim new file mode 100755 index 0000000..f69a6b0 Binary files /dev/null and b/entity.jim differ diff --git a/entity.jor b/entity.jor new file mode 100755 index 0000000..f87c75d --- /dev/null +++ b/entity.jor @@ -0,0 +1,50 @@ +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} diff --git a/footer.jim b/footer.jim new file mode 100755 index 0000000..0c9fbf9 Binary files /dev/null and b/footer.jim differ diff --git a/footer.jor b/footer.jor new file mode 100755 index 0000000..06666b0 --- /dev/null +++ b/footer.jor @@ -0,0 +1,79 @@ +( 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 dup @ text-color ! cell + @ draw-portrait ; + +0 GREEN character pete +1 MAGENTA character mary +2 BROWN character chuck + diff --git a/game.exe b/game.exe index 22bfdb0..17a61a6 100755 Binary files a/game.exe and b/game.exe differ diff --git a/game.jim b/game.jim index 4d79ccd..35c136b 100755 Binary files a/game.jim and b/game.jim differ diff --git a/game.jor b/game.jor index 0ecc60c..349b643 100755 --- a/game.jor +++ b/game.jor @@ -7,275 +7,16 @@ blah 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 ; -: range ( start end -- start range ) over - ; -: >range r< >range r< 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 ticks ( from to duration start ) - begin - 4dup lerp r@ ! - 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 + 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 ( 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 ; +:noname +s" input.jor" loadfile +s" entity.jor" loadfile +s" timer.jor" loadfile +s" footer.jor" loadfile +s" map.jor" loadfile +; execute ( J O B ) var MODE-MOVE @@ -294,6 +35,7 @@ JOB listen-for-jobs ( T I C K ) defer entities +:noname 0 ; ' entities redefine : entity-at ( x y -- entity|0 ) 0 >rot @@ -371,8 +113,6 @@ player :tick ( 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 @@ -404,24 +144,6 @@ player :tick 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 + s" pete.jor" loadfile +; ' onload redefine diff --git a/game.prj b/game.prj index 8918e13..62bd762 100755 Binary files a/game.prj and b/game.prj differ diff --git a/input.jim b/input.jim new file mode 100755 index 0000000..0295e06 Binary files /dev/null and b/input.jim differ diff --git a/input.jor b/input.jor new file mode 100755 index 0000000..6ec48a2 --- /dev/null +++ b/input.jor @@ -0,0 +1,32 @@ +( K E Y B O A R D ) +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 ; + +( 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 ; diff --git a/jorth.c b/jorth.c index 128dbfa..5119d46 100755 --- a/jorth.c +++ b/jorth.c @@ -62,6 +62,20 @@ void f_latest() { PUSHCP(LATEST); } +void f_latest_set() { + LATEST = TOP().p; + DROP(1); +} + +void f_tasks() { + PUSHCP(TASKS); +} + +void f_tasks_set() { + TASKS = TOP().p; + DROP(1); +} + void f_state() { PUSHC(STATE); } @@ -948,6 +962,9 @@ void f_init() { CDEF("here", f_here); CDEF("here!", f_here_set); CDEF("latest", f_latest); + CDEF("latest!", f_latest_set); + CDEF("tasks", f_tasks); + CDEF("tasks!", f_tasks_set); CDEF("state", f_state); CDEF("'", f_quote); f_immediate(); CDEF("`", f_revlookup); diff --git a/keyboard.jor b/keyboard.jor new file mode 100755 index 0000000..6ec48a2 --- /dev/null +++ b/keyboard.jor @@ -0,0 +1,32 @@ +( K E Y B O A R D ) +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 ; + +( 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 ; diff --git a/map.jim b/map.jim new file mode 100755 index 0000000..4572e79 Binary files /dev/null and b/map.jim differ diff --git a/map.jor b/map.jor new file mode 100755 index 0000000..20cc6fd --- /dev/null +++ b/map.jor @@ -0,0 +1,66 @@ +( M A P ) +: +pos ( x1 y1 x2 y2 -- x y ) + 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 ( 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 ; diff --git a/pete.jim b/pete.jim new file mode 100755 index 0000000..41fffe7 Binary files /dev/null and b/pete.jim differ diff --git a/pete.jor b/pete.jor new file mode 100755 index 0000000..0263573 --- /dev/null +++ b/pete.jor @@ -0,0 +1,24 @@ +( P E T E ) + +8 8 E ' {car} defentity car + +var cartimer +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 + + cartimer now! + s" pete.map" load-map +; ' onload redefine + diff --git a/timer.jim b/timer.jim new file mode 100755 index 0000000..0c21a15 Binary files /dev/null and b/timer.jim differ diff --git a/timer.jor b/timer.jor new file mode 100755 index 0000000..f5b2d08 --- /dev/null +++ b/timer.jor @@ -0,0 +1,37 @@ +( 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 ; +: range ( start end -- start range ) over - ; +: >range r< >range r< 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 ticks ( from to duration start ) + begin + 4dup lerp r@ ! + rot suspend + repeat rdrop drop drop drop drop ; + +: sleep ( count -- ) + ticks swap begin over ticks udelta over u< while suspend repeat drop drop ;