diff --git a/boot.jor b/boot.jor index 3c94606..eb75bbd 100755 --- a/boot.jor +++ b/boot.jor @@ -50,7 +50,7 @@ key " const '"' then ; : interpreter begin word dup b@ while compileword repeat drop ; -: load-input swap-input r> r> interpreter r< r< swap-input ; +: load-input swap-input >r >r interpreter execute r< factivate ; +: preservefp ( xt -- ) fdeactivate >r execute r> interpretjor - r< r< imagefilename overwrite saveimage close postload + here over >r >r interpretjor + rot 2dup r@ >rot r< ; -: 4dup r> r> 2dup r@ >rot rswap r@ >rot r< r< swap ; +: 3dup >r 2dup r@ >rot r >r 2dup r@ >rot rswap r@ >rot r >rot r< >rot ; + >r >rot rot ; : negate 0 swap - ; : abs dup 0 < if negate then ; : ~ -1 ^ ; : f! ( b v flag -- ) - >rot r> r@ @ >rot ( val flag b r: v ) - if | else ~ & then r< ! ; + >rot >r r@ @ >rot ( val flag b r: v ) + if | else ~ & then if 1 + else 1 - then ; : for ( from to -- ) - ' r> , [ ' begin , ] ( from r: to ) + ' >r , [ ' begin , ] ( from r: to ) ' dup , ' r@ , ' != , [ ' while , ] - ' r> , ; immediate ( r: to from ) + ' >r , ; immediate ( r: to from ) : i ' r@ , ; immediate : next - ' r< , ' r@ , ' +towards , ( from+1 r: to ) + ' rswap ; +: done rdrop 0 >r rswap ; : ;done ' done , ] ; immediate : each [ ' begin , ] ' r@ , [ ' while , ] ; immediate : more ' yield , [ ' repeat , ] ' rdrop , ; immediate @@ -76,9 +76,9 @@ : intern create latest wordname , does> @ ; : preserving ( cp 0 vars... -- ) - 0 r> begin dup while dup @ r> r> repeat drop + 0 >r begin dup while dup @ >r >r repeat drop execute - begin r@ while r< r< swap ! repeat rdrop ; + begin r@ while rot - entities each r> 2dup ( 0 x y x y r:e ) + 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 break ( e x y ) + if rot break ( e x y ) else rdrop then ( 0 x y ) more drop drop ; @@ -49,8 +49,8 @@ defer player 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 ; + >r r@ entity.dir @ dir>pos + r@ entity.x @ tile +pos ; : move-entity ( e -- ) dup entity.dir @ dir>pos ( e dx dy ) @@ -63,9 +63,9 @@ defer player player move-entity player.prevdir @ party each dup player != if - dup entity.dir @ r> + dup entity.dir @ >r dup >rot entity.dir ! - move-entity r< + move-entity r@ entity.x @ r@ entity.y @ - r@ entity.dir @ r< entity>sprite + >r r@ entity.x @ r@ entity.y @ + r@ entity.dir @ sprite draw-sprite ; var showmouse diff --git a/game.prj b/game.prj index f65f3d2..f55542b 100755 Binary files a/game.prj and b/game.prj differ diff --git a/jopl.exe b/jopl.exe index 400eb97..dd18bb1 100755 Binary files a/jopl.exe and b/jopl.exe differ diff --git a/jopl.jor b/jopl.jor index a99ee86..ba523a7 100755 --- a/jopl.jor +++ b/jopl.jor @@ -1,7 +1,7 @@ ' putc task-emit ! s" jopl.log" open seekend fdeactivate const LOGFILE : emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ; -: quit LOGFILE factivate close s" C:\src\game" chdir _quit ; +: quit LOGFILE factivate close _quit ; : DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ; : DTYPE ' type DBG ; @@ -45,7 +45,7 @@ var op ar-flags adlib! ; : readop ( v -- ) - r> r@ 4 + b@ r@ 3 + b@ r@ 2 + b@ r@ 1 + b@ r< b@ loadop ; + >r r@ 4 + b@ r@ 3 + b@ r@ 2 + b@ r@ 1 + b@ @@ -129,7 +129,7 @@ array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , : track ( i -- p ) cells tracks + ; : dotrack ( ip -- ip ) - dup if dup 1 + swap ub@ r> + dup if dup 1 + swap ub@ >r r@ 0xff = if dup @ swap cell + swap execute then r@ 0xfe = if @ dotrack then r@ 0xfd = if noteoff then @@ -265,13 +265,13 @@ var stopkeys 77 key-pressed if 1 +voice! then ; : dokeys ( cp -- ) - r> 0 stopkeys ! key-start begin + >r 0 stopkeys ! key-start begin key-debounce r@ execute suspend stopkeys @ until key-end rdrop ; : nextnote ( ip -- ip ) dup if - dup ub@ r> + dup ub@ >r r@ 0xff = if drop 0 else r@ 0xfe = if 1 + @ nextnote then then rdrop @@ -328,13 +328,17 @@ defer onselect : change-selection ( dy -- ) deselect-menu menuy +!pos select-menu onselect ; + +: page-selection ( redraw dy -- 1 ) + dup menuscroll +!pos menuy +!pos drop 1 ; + : key-menu ( -- redraw ) :| 0 ( redraw ) 72 key-pressed if -1 change-selection then 80 key-pressed if 1 change-selection then - 73 key-pressed if drop 1 r> -10 menuscroll +!pos then - 81 key-pressed if drop 1 r> 10 menuscroll +!pos then + 73 key-pressed if -10 page-selection then + 81 key-pressed if 10 page-selection then |; draw-menu ; : draw-filemenu ( glob -- ) @@ -352,9 +356,10 @@ defer onselect |; dokeys |; 66 1 13 menu-at ; +: dune ( -- ) s" dune" chdir inst s" .." chdir ; + :noname 9 -1 for i voice ! default next startt2 ' emit-direct task-emit ! - s" dune" chdir ; ' onload redefine diff --git a/jopl.prj b/jopl.prj index 9d1b09f..19fab05 100755 Binary files a/jopl.prj and b/jopl.prj differ diff --git a/jorth.c b/jorth.c index 4e63e4a..a124805 100755 --- a/jorth.c +++ b/jorth.c @@ -1143,8 +1143,8 @@ void f_init(char *exe) { CDEF("drop", f_drop); CDEF("swap", f_swap); CDEF("", f_rput); - CDEF("r<", f_rtake); + CDEF(">r", f_rput); + CDEF(" ( oldw neww r: 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 ) + swap mapsize >r ( newh neww oldw r: oldh ) + 2dup < if 1 ( dx dy r: h ) + maph over abs - >r ( dx dy r: h ) swap mapw over abs - >rot ( w dy dx r: h ) 2dup map swap offset-map swap mapw * offset-map >rot ( w end dy dx r: h ) map swap negate offset-map swap mapw * negate offset-map ( w end start r: h ) 2dup > if r@ mapw * + swap r@ mapw * + swap then - r< 0 for + range ( start end -- start range ) over - ; : >range r< r >range >range r< ratio lerpr ; + >r >range 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 ; + dup >r @ ticks udelta ( duration delta ) + 2dup <= if drop @ >rot ticks ( from to duration start ) + dup >r @ >rot ticks ( from to duration start ) begin 4dup lerp r@ !