SpindleyQ/pete286
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

jopl: interactive instrument loading

Browse source
This commit is contained in:
Jeremy Penner 2019-05-09 21:30:21 -04:00
parent 38db6f71f3
commit aa8cd6f770
1 changed files with 37 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

59
jopl.jor
View file

@ -1,8 +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 _quit ;
: quit LOGFILE factivate close s" C:\src\game" chdir _quit ;
: DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ;
: DTYPE ' type DBG ;
@ -165,6 +164,8 @@ array tracks 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
'name :track type bl swap type bl
begin dup ub@ emit-cmd while 1 + repeat drop ;
( T E X T )
var textx
var texty
var textattr
@ -198,6 +199,11 @@ var textleft
: rpad ( n -- )
textleft @ + textx @ for bl next ;
: read-direct ( x y -- s )
80 * + here swap
begin dup 1 << 0xb800 b@far dup sp != while b, 1 + repeat
0 b, drop drop dup here! ;
: status
0 textx ! 0 texty ! 0 textleft !
s" V: " type voice @ .
@ -293,35 +299,42 @@ var stopkeys
var menuscroll
var menuy
var menuw
: menu-at ( cp x y -- )
:| texty ! dup textx ! textleft ! ' emit-direct task-emit !
defer onselect
: menu-at ( cp x y w -- )
:| menuw ! texty ! dup textx ! textleft ! ' emit-direct task-emit !
0 menuscroll ! 0 menuy !
execute |;
execute ' noop ' onselect redefine |;
0 textleft task-emit preserving ;
: menu-lines ( -- count ) 24 texty @ - ;
: menu-skip menuscroll @ 0 max ;
: menu-selectedy menuy @ menu-skip - texty @ + ;
: draw-menu ( cp -- ) 0 texty textattr preserving ;
: menuitem-bg ( w attr -- )
: menuitem-bg ( attr -- )
:| menu-selectedy texty !
textleft @ textx !
textattr ! setattr-to |;
textattr ! menuw @ setattr-to |;
0 texty textx textattr preserving ;
: deselect-menu ( w -- ) 0x1f menuitem-bg ;
: select-menu ( w -- ) 0x30 menuitem-bg ;
: deselect-menu ( -- ) 0x1f menuitem-bg ;
: select-menu ( -- ) 0x30 menuitem-bg ;
: key-menu ( w -- redraw )
: selected-text textx @ menu-selectedy read-direct ;
: draw-menu ( cp -- ) 0 texty textattr preserving select-menu ;
: change-selection ( dy -- )
deselect-menu menuy +!pos select-menu onselect ;
: key-menu ( -- redraw )
:|
0 r>
72 key-pressed if dup deselect-menu -1 menuy +!pos dup select-menu then
80 key-pressed if dup deselect-menu 1 menuy +!pos dup select-menu then
73 key-pressed if rdrop 1 r> -10 menuscroll +!pos then
81 key-pressed if rdrop 1 r> 10 menuscroll +!pos then
drop r<
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
|; draw-menu ;
: draw-filemenu ( glob -- )
@ -330,16 +343,18 @@ var menuy
menu-lines 0 for dup if type else drop then 13 rpad cr nextfile next
drop |; draw-menu ;
: filemenu ( glob -- filename )
:| dup draw-filemenu 13 select-menu
: inst ( -- )
:| selected-text loadsbi |; ' onselect redefine
:| s" *.sbi" draw-filemenu
:| jamkeys
13 key-menu if dup draw-filemenu then
28 key-pressed if ( todo: get filename ) 1 stopkeys ! then
key-menu if s" *.sbi" draw-filemenu then
28 key-pressed if 1 stopkeys ! then
|; dokeys
|; 66 1 menu-at ;
|; 66 1 13 menu-at ;
:noname
9 -1 for i voice ! default next
startt2
' emit-direct task-emit !
s" dune" chdir
; ' onload redefine