job refactoring

defs.jor

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

game.jor

@@ -1,17 +1,6 @@
-( 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 party
@@ -65,16 +54,18 @@ var player.prevdir
 
 12 9 N ' {player} defentity player
 
+: sched-move-entity ( entity -- ) :| jobdata move-entity |; sched-with ;
 : 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
     dup player != if
       dup entity.dir @ >r
       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 )
   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
   ^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
+  if ' try-move-player sched then
 ;entity
 
 ( S T U F F )
@@ -183,5 +174,6 @@ var glitchlevel
      player.state ISMARY f@ if p_jeanne yield then
      CHUCK-FOLLOW flag@ if p_chuck yield then
   done |; ' party redefine
-
+  :| MODE-WAIT @ ' tick redefine |; ' any-job-started redefine
+  :| MODE-MOVE @ ' tick redefine hide-footer |; ' all-jobs-complete redefine
 ; ' onload redefine

gameboot.jor

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

job.jor

@@ -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
+