job refactoring

This commit is contained in:
Jeremy Penner 2020-02-01 10:07:46 -05:00
parent 71b45c35ef
commit e3ab556b8d
4 changed files with 104 additions and 19 deletions

View file

@ -22,6 +22,8 @@
: f@ ( v flag -- b ) swap @ & ; : f@ ( v flag -- b ) swap @ & ;
: fnot! ( v flag -- ) over @ ^ swap ! ; : fnot! ( v flag -- ) over @ ^ swap ! ;
: @! ( newval v -- oldval ) dup @ >rot ! ;
: userword 1 latest wordflags F_USERWORD f! ; : userword 1 latest wordflags F_USERWORD f! ;
: expile state if , else execute then ; : expile state if , else execute then ;
@ -50,6 +52,8 @@
: next : next
' <r , ' r@ , ' +towards , ( from+1 r: to ) ' <r , ' r@ , ' +towards , ( from+1 r: to )
[ ' repeat , ] ' drop , ' rdrop , ; immediate [ ' repeat , ] ' drop , ' rdrop , ; immediate
: breakfor
' rdrop , ' rdrop , 0 lit ' >r , 1 lit ' >r , ; immediate
: yield rswap ; : yield rswap ;
: done rdrop 0 >r rswap ; : done rdrop 0 >r rswap ;
@ -143,6 +147,9 @@
' ret , ' ret ,
; immediate ; immediate
: >task ( val task -- )
task-sp >r r@ @ ! r@ @ cell + r> ! ;
: try-send ( val task -- b ) : try-send ( val task -- b )
mailbox dup @ if drop drop 0 else ! 1 then ; mailbox dup @ if drop drop 0 else ! 1 then ;

View file

@ -1,17 +1,6 @@
( J O B )
var MODE-MOVE var MODE-MOVE
var MODE-WAIT 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 ) ( T I C K )
defer party defer party
@ -65,16 +54,18 @@ var player.prevdir
12 9 N ' {player} defentity player 12 9 N ' {player} defentity player
: sched-move-entity ( entity -- ) :| jobdata move-entity |; sched-with ;
: move-player : move-player
1 player.state MOVING f! :| 1 player.state MOVING f!
player move-entity player move-entity
0 player.state MOVING f!
|; sched
player.prevdir @ party each player.prevdir @ party each
dup player != if dup player != if
dup entity.dir @ >r dup entity.dir @ >r
dup >rot entity.dir ! dup >rot entity.dir !
move-entity <r sched-move-entity <r
else entity.dir @ player.prevdir ! then more drop else entity.dir @ player.prevdir ! then more drop ;
0 player.state MOVING f! ;
: out-of-bounds ( x y -- b ) : out-of-bounds ( x y -- b )
2dup 0 < swap 0 < or >rot mapsize ( b x y w h ) 2dup 0 < swap 0 < or >rot mapsize ( b x y w h )
@ -124,7 +115,7 @@ player :tick
^RIGHT key-down if drop 1 E 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 ^UP key-down if drop 1 N player entity.dir ! then
^DOWN key-down if drop 1 S player entity.dir ! then ^DOWN key-down if drop 1 S player entity.dir ! then
if ' try-move-player JOB send then if ' try-move-player sched then
;entity ;entity
( S T U F F ) ( S T U F F )
@ -183,5 +174,6 @@ var glitchlevel
player.state ISMARY f@ if p_jeanne yield then player.state ISMARY f@ if p_jeanne yield then
CHUCK-FOLLOW flag@ if p_chuck yield then CHUCK-FOLLOW flag@ if p_chuck yield then
done |; ' party redefine done |; ' party redefine
:| MODE-WAIT @ ' tick redefine |; ' any-job-started redefine
:| MODE-MOVE @ ' tick redefine hide-footer |; ' all-jobs-complete redefine
; ' onload redefine ; ' onload redefine

View file

@ -23,6 +23,7 @@ s" footer.jor" loadfile
s" map.jor" loadfile s" map.jor" loadfile
s" state.jor" loadfile s" state.jor" loadfile
s" jiles.jor" loadfile s" jiles.jor" loadfile
s" job.jor" loadfile
s" game.jor" loadfile s" game.jor" loadfile
; execute ; execute

85
job.jor Executable file
View file

@ -0,0 +1,85 @@
defer any-job-started
defer all-jobs-complete
var JOBSTATE
array JOBTASKS 4 cells allot
array JOBS 8 cells allot
array JOBDATA 8 cells allot
: by-jobid ( jobid p -- p ) swap 1 - cells + ;
: jobdata ( jobid -- jobid data ) dup JOBDATA by-jobid @ ;
: jobdata! ( data jobid -- ) JOBDATA by-jobid ! ;
: ijobtask-running ( -- i )
0 0 4 for JOBTASKS i cells + @ running = if drop i then next ;
: jobtask-busy-flag ( ijobtask -- v f )
1 swap << JOBSTATE swap ;
: job-scheduled-flag ( jobid -- v f )
0x08 swap << JOBSTATE swap ;
: next-matching-jobid ( matcher -- jobid )
0 0 8 for dup not if
over i swap execute if drop i 1 + then
then next swap drop ;
: job-unscheduled+xp ( jobid -- b xp )
dup job-scheduled-flag f@ not
swap JOBS by-jobid @ ;
: next-unused-jobid ( -- jobid )
:| job-unscheduled+xp not and |; next-matching-jobid ;
: next-waiting-jobid ( -- jobid )
:| job-unscheduled+xp and |; next-matching-jobid ;
: on-job-complete ( jobid -- )
0 swap job-scheduled-flag f!
next-waiting-jobid dup if
dup running send
1 swap job-scheduled-flag f!
else ( 0 ) ijobtask-running jobtask-busy-flag f!
JOBSTATE @ not if all-jobs-complete then
then ;
: listen-for-jobs activate blah
begin receive ( jobid )
any-job-started
dup JOBS by-jobid 0 swap @!
execute
on-job-complete
again ;
: start-jobtask ( i -- )
task dup listen-for-jobs swap cells JOBTASKS + ! ;
: next-free-job-task ( -- task )
0 0 4 for dup not if
JOBSTATE 1 i << f@ not if
drop JOBTASKS i cells + @
then
then next ;
: enqueue-job ( xp -- jobid )
next-unused-jobid dup if dup >rot 1 - cells JOBS + ! then ;
: try-run-job ( jobid -- )
0 4 for i jobtask-busy-flag f@ not if
1 i jobtask-busy-flag f!
1 over job-scheduled-flag f!
JOBTASKS i cells + @ send breakfor
then next ;
: sched ( xp -- ) enqueue-job try-run-job ;
: sched-with ( data xp -- ) enqueue-job dup >rot jobdata! try-run-job ;
:noname
0 start-jobtask
1 start-jobtask
2 start-jobtask
3 start-jobtask
; ' onload redefine