~rabbits/orca-toy

bdc9b4465310deea8aa26358aa639da608f1127b — Devine Lu Linvega a month ago f68d7ec 
Optimized library to make use of Call opcodes
patch browse .tar.gz 
2 files changed, 201 insertions(+), 245 deletions(-)

M src/library.tal
M src/orca.tal

M src/library.tal => src/library.tal +198 -242
@@ 7,443 7,399 @@
	=op-bang/? =op-comment/? =op-synth/? 
	=op-midi/? =op-pitch/? =op-byte/? =op-self/?

@op-a-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-a-lc get-bang ?&* POP2 JMP2r &*
@op-a ( add )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( a-val ) #0001 SUB2 ;get-port-left-value JSR2
	( b-raw ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2
	( a-val ) #0001 SUB2 get-port-left-value
	( b-raw ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36
	( res ) ADD
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "A "Outputs 20 "sum 20 "of 20 "inputs $1

@op-b-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-b-lc get-bang ?&* POP2 JMP2r &*
@op-b ( subtract )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get a ) #0001 SUB2 ;get-port-left-value JSR2
	( get b ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2
	( res ) SUB DUP #80 LTH ,&bounce JCN #24 SWP SUB &bounce
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( get a ) #0001 SUB2 get-port-left-value
	( get b ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36
	( res ) SUB DUP #80 LTH ?&bounce #24 SWP SUB &bounce
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "B "Outputs 20 "difference 20 "of 20 "inputs $1

@op-c-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-c-lc get-bang ?&* POP2 JMP2r &*
@op-c ( clock )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get rate ) #0001 SUB2 ;get-port-left-value JSR2 DUP #00 EQU ADD
	( get mod ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2 DUP #00 EQU ADD
	( get rate ) #0001 SUB2 get-port-left-value DUP #00 EQU ADD
	( get mod ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36 DUP #00 EQU ADD
	( res ) #00 SWP ROT #00 SWP .timer/frame LDZ2 SWP2 DIV2 SWP2 ( MOD2 ) [ DIV2k MUL2 SUB2 ] NIP
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "C "Outputs 20 "modulo 20 "of 20 "frame $1

@op-d-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-d-lc get-bang ?&* POP2 JMP2r &*
@op-d ( delay )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get rate ) #0001 SUB2 ;get-port-left-value JSR2 DUP #00 EQU ADD
	( get mod ) STH2kr INC2 ;get-port-right-value JSR2 DUP #00 EQU ADD
	( get rate ) #0001 SUB2 get-port-left-value DUP #00 EQU ADD
	( get mod ) STH2kr INC2 get-port-right-value DUP #00 EQU ADD
	( res ) MUL #00 SWP .timer/frame LDZ2 SWP2 ( MOD2 ) [ DIV2k MUL2 SUB2 ] #0000 EQU2
	( bang on equal ) #fc MUL LIT ". ADD
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( output ) STH2r !set-port-output-below
	&? "D "Bangs 20 "on 20 "modulo 20 "of 20 "frame $1

@op-e-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-e-lc get-bang ?&* POP2 JMP2r &*
@op-e ( east )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	;data/cells ADD2 LDA ,&self STR
	( wall ) .head/x LDZ INC .grid/width LDZ EQU ,&collide JCN
	( cell ) STH2kr INC2 ;data/cells ADD2 LDA LIT ". NEQ ,&collide JCN
	( write new ) [ LIT &self $1 ] STH2kr INC2 ;set-port-raw JSR2
	( erase old ) LIT ". STH2r ;set-port-raw JMP2
	( wall ) .head/x LDZ INC .grid/width LDZ EQU ?&collide
	( cell ) STH2kr INC2 ;data/cells ADD2 LDA LIT ". NEQ ?&collide
	( write new ) [ LIT &self $1 ] STH2kr INC2 set-port-raw
	( erase old ) LIT ". STH2r !set-port-raw
	&collide
	( output ) LIT "* STH2r ;set-port-output ( .. )

JMP2
	( output ) LIT "* STH2r !set-port-output
	&? "E "Moves 20 "eastward 20 "or 20 "bangs $1

@op-f-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-f-lc get-bang ?&* POP2 JMP2r &*
@op-f ( if )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get a ) #0001 SUB2 ;get-port-left-raw JSR2
	( get b ) STH2kr INC2 ;get-port-right-raw JSR2
	( get a ) #0001 SUB2 get-port-left-raw
	( get b ) STH2kr INC2 get-port-right-raw
	( bang on equal ) EQU [ #fc MUL LIT ". ADD ]
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( output ) STH2r !set-port-output-below
	&? "F "Bangs 20 "if 20 "inputs 20 "are 20 "equal $1

@op-g-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-g-lc get-bang ?&* POP2 JMP2r &*
@op-g ( generator )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( x ) STH2kr #0003 SUB2 ;get-port-left-value JSR2
	( x ) STH2kr #0003 SUB2 get-port-left-value
		( load ) #00 SWP ADD2
	( y ) STH2kr #0002 SUB2 ;get-port-left-value JSR2
	( y ) STH2kr #0002 SUB2 get-port-left-value
		( load ) #00 SWP INC2 [ #00 .grid/width LDZ MUL2 ] ADD2
	,&save STR2
	( len ) STH2kr #0001 SUB2 ;get-port-left-value JSR2 DUP #00 EQU ADD
	( len ) STH2kr #0001 SUB2 get-port-left-value DUP #00 EQU ADD
	#00
	&loop
		( load ) #00 OVR STH2kr INC2 ADD2 ;get-port-right-raw JSR2
		( save ) OVR #00 SWP [ LIT2 &save $2 ] ADD2 ;set-port-output JSR2
		INC GTHk ,&loop JCN
	&l
		( load ) #00 OVR STH2kr INC2 ADD2 get-port-right-raw
		( save ) OVR #00 SWP [ LIT2 &save $2 ] ADD2 set-port-output
		INC GTHk ?&l
	POP2
	POP2r

JMP2r
	&? "G "Writes 20 "operands 20 "with 20 "offset $1

@op-h-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-h-lc get-bang ?&* POP2 JMP2r &*
@op-h ( hold )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get cell ) #00 .grid/width LDZ ADD2 ;data/cells ADD2 LDA
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( output ) STH2r !set-port-output-below
	&? "H "Holds 20 "southward 20 "operand $1

@op-i-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-i-lc get-bang ?&* POP2 JMP2r &*
@op-i ( increment )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( step ) #0001 SUB2 ;get-port-left-value JSR2
	( mod ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2 DUP #00 EQU ADD
	( res ) SWP STH2kr #00 .grid/width LDZ ADD2 [ ;data/cells ADD2 LDA ;chrb36 JSR2 ] ADD SWP ( MOD ) [ DIVk MUL SUB ]
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( step ) #0001 SUB2 get-port-left-value
	( mod ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36 DUP #00 EQU ADD
	( res ) SWP STH2kr #00 .grid/width LDZ ADD2 [ ;data/cells ADD2 LDA chrb36 ] ADD SWP ( MOD ) [ DIVk MUL SUB ]
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "I "Increments 20 "southward 20 "operand $1

@op-j-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-j-lc get-bang ?&* POP2 JMP2r &*
@op-j ( jumper )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get above ) #00 .grid/width LDZ SUB2 ;get-port-left-raw JSR2
	( get above ) #00 .grid/width LDZ SUB2 get-port-left-raw
	( ignore cable )
	DUP ;chrb36 JSR2 #13 NEQ ,&no-wire JCN
	DUP chrb36 #13 NEQ ?&no-wire
		POP POP2r JMP2r &no-wire
	( skip down )
	STH2r
	&while
		#00 .grid/width LDZ ADD2 DUP2 ;data/cells ADD2 LDA ;chrb36 JSR2 #13 EQU
		,&while JCN
	( set below ) ;set-port-output ( .. )

JMP2
		#00 .grid/width LDZ ADD2 DUP2 ;data/cells ADD2 LDA chrb36 #13 EQU
		?&while
	( set below ) !set-port-output
	&? "J "Outputs 20 "northward 20 "operand $1

@op-k-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-k-lc get-bang ?&* POP2 JMP2r &*
@op-k ( konkat )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	#0001 SUB2 ;get-port-left-value JSR2 #00
	&loop
		#00 OVR STH2kr INC2 ADD2 STH2k ;get-port-right-raw JSR2
		DUP LIT ". EQU ,&skip JCN
			( load ) DUP ;chrb36 JSR2 .variables ADD LDZ
			( save ) STH2kr #00 .grid/width LDZ ADD2 ;set-port-output JSR2
	#0001 SUB2 get-port-left-value #00
	&l
		#00 OVR STH2kr INC2 ADD2 STH2k get-port-right-raw
		DUP LIT ". EQU ?&skip
			( load ) DUP chrb36 .variables ADD LDZ
			( save ) STH2kr #00 .grid/width LDZ ADD2 set-port-output
			&skip
		POP
		POP2r
		INC GTHk ;&loop JCN2
		INC GTHk ?&l
	POP2
	POP2r

JMP2r
	&? "K "Reads 20 "multiple 20 "variables $1

@op-l-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-l-lc get-bang ?&* POP2 JMP2r &*
@op-l ( lesser )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get a ) #0001 SUB2 ;get-port-left-value JSR2
	( get b ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2
	( get a ) #0001 SUB2 get-port-left-value
	( get b ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36
	( res ) [ LTHk JMP SWP POP ]
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "L "Outputs 20 "smallest 20 "of 20 "inputs $1

@op-m-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-m-lc get-bang ?&* POP2 JMP2r &*
@op-m ( multiply )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get a ) #0001 SUB2 ;get-port-left-value JSR2
	( get b ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2
	( get a ) #0001 SUB2 get-port-left-value
	( get b ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36
	( res ) MUL
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "M "Outputs 20 "product 20 "of 20 "inputs $1

@op-n-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-n-lc get-bang ?&* POP2 JMP2r &*
@op-n ( north )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	;data/cells ADD2 LDA ,&self STR
	( wall ) .head/y LDZ #01 SUB #ff EQU ,&collide JCN
	( cell ) STH2kr #00 .grid/width LDZ SUB2 ;data/cells ADD2 LDA LIT ". NEQ ,&collide JCN
	( write new ) [ LIT &self $1 ] STH2kr #00 .grid/width LDZ SUB2 ;set-port-raw JSR2
	( erase old ) LIT ". STH2r ;set-port-raw JMP2
	( wall ) .head/y LDZ #01 SUB #ff EQU ?&collide
	( cell ) STH2kr #00 .grid/width LDZ SUB2 ;data/cells ADD2 LDA LIT ". NEQ ?&collide
	( write new ) [ LIT &self $1 ] STH2kr #00 .grid/width LDZ SUB2 set-port-raw
	( erase old ) LIT ". STH2r !set-port-raw
	&collide
	( output ) LIT "* STH2r ;set-port-output ( .. )

JMP2
	( output ) LIT "* STH2r !set-port-output
	&? "N "Moves 20 "Northward 20 "or 20 "bangs $1

@op-o-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-o-lc get-bang ?&* POP2 JMP2r &*
@op-o ( read )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( x ) STH2kr #0002 SUB2 ;get-port-left-value JSR2 INC #00 SWP ADD2
	( y ) STH2kr #0001 SUB2 ;get-port-left-value JSR2 #00 SWP #00 .grid/width LDZ MUL2 ADD2
	( val ) ;get-port-right-raw JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( x ) STH2kr #0002 SUB2 get-port-left-value INC #00 SWP ADD2
	( y ) STH2kr #0001 SUB2 get-port-left-value #00 SWP #00 .grid/width LDZ MUL2 ADD2
	( val ) get-port-right-raw
	( output ) STH2r !set-port-output-below
	&? "O "Reads 20 "operand 20 "with 20 "offset $1

@op-p-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-p-lc get-bang ?&* POP2 JMP2r &*
@op-p ( push )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( key ) #0002 SUB2 ;get-port-left-value JSR2
	( len ) STH2kr #0001 SUB2 ;get-port-left-value JSR2 DUP #00 EQU ADD
	( key ) #0002 SUB2 get-port-left-value
	( len ) STH2kr #0001 SUB2 get-port-left-value DUP #00 EQU ADD
	#00
	&loop
	&l
		#00 OVR STH2kr #00 .grid/width LDZ ADD2 ADD2 STH2
		( lock ) #01 STH2kr ;data/locks ADD2 STA
		( type ) .types/locked STH2r ;data/types ADD2 STA
		INC GTHk ,&loop JCN
		INC GTHk ?&l
	POP
	( read ) STH2kr INC2 ;get-port-right-raw JSR2
	( read ) STH2kr INC2 get-port-right-raw
	( output ) ROT ROT ( MOD ) [ DIVk MUL SUB ] #00 SWP STH2r #00 .grid/width LDZ ADD2 ADD2
		;set-port-output ( .. )

JMP2
		!set-port-output
	&? "P "Writes 20 "eastward 20 "operand $1

@op-q-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-q-lc get-bang ?&* POP2 JMP2r &*
@op-q ( query )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( x ) STH2kr #0003 SUB2 ;get-port-left-value JSR2
	( x ) STH2kr #0003 SUB2 get-port-left-value
		( load ) #00 SWP INC2 ADD2
	( y ) STH2kr #0002 SUB2 ;get-port-left-value JSR2
	( y ) STH2kr #0002 SUB2 get-port-left-value
		( load ) #00 SWP [ #00 .grid/width LDZ MUL2 ] ADD2
	,&load STR2
	( len ) STH2kr #0001 SUB2 ;get-port-left-value JSR2 DUP #00 EQU ADD
	( len ) STH2kr #0001 SUB2 get-port-left-value DUP #00 EQU ADD
		( save ) #00 OVR STH2kr #00 .grid/width LDZ ADD2 SWP2 SUB2 INC2 ,&save STR2
	#00
	&loop
		( load ) #00 OVR [ LIT2 &load $2 ] ADD2 ;get-port-right-raw JSR2
		( save ) OVR #00 SWP [ LIT2 &save $2 ] ADD2 ;set-port-output JSR2
		INC GTHk ,&loop JCN
	&l
		( load ) #00 OVR [ LIT2 &load $2 ] ADD2 get-port-right-raw
		( save ) OVR #00 SWP [ LIT2 &save $2 ] ADD2 set-port-output
		INC GTHk ?&l
	POP2
	POP2r

JMP2r
	&? "Q "Reads 20 "operands 20 "with 20 "offset $1

@op-r-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-r-lc get-bang ?&* POP2 JMP2r &*
@op-r ( random )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( a-min ) #0001 SUB2 ;get-port-left-value JSR2
	( b-max ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2 DUP #00 EQU ADD
	( mod ) OVR SUB ;prng JSR2 ADD SWP DUP #00 EQU ADD ( MOD ) [ DIVk MUL SUB ] ADD
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( a-min ) #0001 SUB2 get-port-left-value
	( b-max ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36 DUP #00 EQU ADD
	( mod ) OVR SUB prng ADD SWP DUP #00 EQU ADD ( MOD ) [ DIVk MUL SUB ] ADD
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "R "Outputs 20 "random 20 "value $1

@op-s-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-s-lc get-bang ?&* POP2 JMP2r &*
@op-s ( south )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	;data/cells ADD2 LDA ,&self STR
	( wall ) .head/y LDZ INC .grid/height LDZ EQU ,&collide JCN
	( cell ) STH2kr #00 .grid/width LDZ ADD2 ;data/cells ADD2 LDA LIT ". NEQ ,&collide JCN
	( write new ) [ LIT &self $1 ] STH2kr #00 .grid/width LDZ ADD2 ;set-port-raw JSR2
	( erase old ) LIT ". STH2r ;set-port-raw JMP2
	( wall ) .head/y LDZ INC .grid/height LDZ EQU ?&collide
	( cell ) STH2kr #00 .grid/width LDZ ADD2 ;data/cells ADD2 LDA LIT ". NEQ ?&collide
	( write new ) [ LIT &self $1 ] STH2kr #00 .grid/width LDZ ADD2 set-port-raw
	( erase old ) LIT ". STH2r !set-port-raw
	&collide
	( output ) LIT "* STH2r ;set-port-output ( .. )

JMP2
	( output ) LIT "* STH2r !set-port-output
	&? "S "Moves 20 "southward 20 "or 20 "bangs $1

@op-t-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-t-lc get-bang ?&* POP2 JMP2r &*
@op-t ( track )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( key ) #0002 SUB2 ;get-port-left-value JSR2
	( len ) STH2kr #0001 SUB2 ;get-port-left-value JSR2 DUP #00 EQU ADD
	( key ) #0002 SUB2 get-port-left-value
	( len ) STH2kr #0001 SUB2 get-port-left-value DUP #00 EQU ADD
	#00
	&loop
	&l
		#00 OVR STH2kr INC2 ADD2 STH2
		( lock ) #01 STH2kr ;data/locks ADD2 STA
		( type ) .types/locked STH2r ;data/types ADD2 STA
		INC GTHk ,&loop JCN
		INC GTHk ?&l
	POP
	( read ) ( MOD ) [ DIVk MUL SUB ] #00 SWP STH2kr INC2 ADD2 ;get-port-right-raw JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( read ) ( MOD ) [ DIVk MUL SUB ] #00 SWP STH2kr INC2 ADD2 get-port-right-raw
	( output ) STH2r !set-port-output-below
	&? "T "Reads 20 "eastward 20 "operand $1

@op-u-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-u-lc get-bang ?&* POP2 JMP2r &*
@op-u ( Uclid )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( step ) #0001 SUB2 ;get-port-left-value JSR2
	( max ) STH2kr INC2 ;get-port-right-value JSR2 DUP #00 EQU ADD STH2
	( step ) #0001 SUB2 get-port-left-value
	( max ) STH2kr INC2 get-port-right-value DUP #00 EQU ADD STH2
	( frame ADD max SUB 1 ) .timer/frame LDZ2 STHkr #00 SWP ADD2 #0001 SUB2
	( MUL step ) OVRr STHr #00 SWP MUL2
	( % max ) STHkr #00 SWP ( MOD2 ) [ DIV2k MUL2 SUB2 ]
	( ADD step ) SWPr STHr #00 SWP ADD2
	( bucket GTH= max ) STHr #00 SWP LTH2 #01 NEQ
	( bang if equal ) #fc MUL LIT ". ADD
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( output ) STH2r !set-port-output-below
	&? "U "Bangs 20 "on 20 "Euclidean 20 "rhythm $1

@op-v-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-v-lc get-bang ?&* POP2 JMP2r &*
@op-v ( variable )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( key ) #0001 SUB2 ;get-port-left-raw JSR2
	( val ) STH2kr INC2 ;get-port-right-raw JSR2
	DUP LIT ". EQU ,&idle JCN
	OVR ;chrb36 JSR2 ,&save JCN
	( key ) #0001 SUB2 get-port-left-raw
	( val ) STH2kr INC2 get-port-right-raw
	DUP LIT ". EQU ?&idle
	OVR chrb36 ?&save
	( load )
		NIP ;chrb36 JSR2 .variables ADD LDZ STH2r #00 .grid/width LDZ ADD2 ;set-port-output JMP2
		NIP chrb36 .variables ADD LDZ STH2r #00 .grid/width LDZ ADD2 !set-port-output
	&save
		SWP ;chrb36 JSR2 .variables ADD STZ POP2r JMP2r
		SWP chrb36 .variables ADD STZ POP2r JMP2r
	&idle
		POP2 POP2r

JMP2r
	&? "V "Reads 20 "and 20 "writes 20 "variable $1

@op-w-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-w-lc get-bang ?&* POP2 JMP2r &*
@op-w ( west )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	;data/cells ADD2 LDA ,&self STR
	( wall ) .head/x LDZ #01 SUB #ff EQU ,&collide JCN
	( cell ) STH2kr #0001 SUB2 ;data/cells ADD2 LDA LIT ". NEQ ,&collide JCN
	( write new ) [ LIT &self $1 ] STH2kr #0001 SUB2 ;set-port-raw JSR2
	( erase old ) LIT ". STH2r ;set-port-raw JMP2
	( wall ) .head/x LDZ #01 SUB #ff EQU ?&collide
	( cell ) STH2kr #0001 SUB2 ;data/cells ADD2 LDA LIT ". NEQ ?&collide
	( write new ) [ LIT &self $1 ] STH2kr #0001 SUB2 set-port-raw
	( erase old ) LIT ". STH2r !set-port-raw
	&collide
	( output ) LIT "* STH2r ;set-port-output ( .. )

JMP2
	( output ) LIT "* STH2r !set-port-output
	&? "W "Moves 20 "westward 20 "or 20 "bangs $1

@op-x-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-x-lc get-bang ?&* POP2 JMP2r &*
@op-x ( write )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( x ) STH2kr #0002 SUB2 ;get-port-left-value JSR2 #00 SWP ADD2
	( y ) STH2kr #0001 SUB2 ;get-port-left-value JSR2 INC #00 SWP #00 .grid/width LDZ MUL2 ADD2
	( val ) STH2r INC2 ;get-port-right-raw JSR2
	( output ) ROT ROT ;set-port-output ( .. )

JMP2
	( x ) STH2kr #0002 SUB2 get-port-left-value #00 SWP ADD2
	( y ) STH2kr #0001 SUB2 get-port-left-value INC #00 SWP #00 .grid/width LDZ MUL2 ADD2
	( val ) STH2r INC2 get-port-right-raw
	( output ) ROT ROT !set-port-output
	&? "X "Writes 20 "operand 20 "with 20 "offset $1

@op-y-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-y-lc get-bang ?&* POP2 JMP2r &*
@op-y ( yumper )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( get above ) #0001 SUB2 ;get-port-left-raw JSR2
	( get above ) #0001 SUB2 get-port-left-raw
	( ignore cable )
	DUP ;chrb36 JSR2 #22 NEQ ,&no-wire JCN
	DUP chrb36 #22 NEQ ?&no-wire
		POP POP2r JMP2r &no-wire
	( skip down )
	STH2r
	&while
		INC2 DUP2 ;data/cells ADD2 LDA ;chrb36 JSR2 #22 EQU
		,&while JCN
	( set below ) ;set-port-output ( .. )

JMP2
		INC2 DUP2 ;data/cells ADD2 LDA chrb36 #22 EQU
		?&while
	( set below ) !set-port-output
	&? "Y "Outputs 20 "westward 20 "operand $1

@op-z-lc ;get-bang JSR2 ,&* JCN POP2 JMP2r &*
@op-z-lc get-bang ?&* POP2 JMP2r &*
@op-z ( lerp )

	STH2k
	( set type ) .types/op STH2kr ;data/types ADD2 STA
	( rate ) #0001 SUB2 ;get-port-left-value JSR2
	( target ) STH2kr INC2 ;get-port-right-raw JSR2
		( get case ) DUP ;ciuc JSR2 ,&case STR
		( to value ) ;chrb36 JSR2
	( val ) STH2kr #00 .grid/width LDZ ADD2 [ ;data/cells ADD2 LDA ;chrb36 JSR2 ]
	( res ) ;lerp JSR2
	( set case ) [ LIT &case $1 ] ;set-case JSR2
	( output ) STH2r ;set-port-output-below ( .. )

JMP2
	( rate ) #0001 SUB2 get-port-left-value
	( target ) STH2kr INC2 get-port-right-raw
		( get case ) DUP ciuc ,&case STR
		( to value ) chrb36
	( val ) STH2kr #00 .grid/width LDZ ADD2 [ ;data/cells ADD2 LDA chrb36 ]
	( res ) lerp
	( set case ) [ LIT &case $1 ] set-case
	( output ) STH2r !set-port-output-below
	&? "Z "Transitions 20 "operand 20 "to 20 "input $1

( special )


@@ 463,14 419,14 @@ JMP2r
	( get edge )
	#00 .grid/width LDZ .head/x LDZ SUB ADD2
	STH2r INC2
	&loop
	&l
		( set lock ) STH2k #01 STH2r ;data/locks ADD2 STA
		( set type if unset )
		DUP2 ;data/types ADD2 LDA ,&skip JCN
		DUP2 ;data/types ADD2 LDA ?&skip
			( set type ) STH2k .types/comment STH2r ;data/types ADD2 STA
			&skip
		( stop at hash ) DUP2 ;data/cells ADD2 LDA LIT "# EQU ,&end JCN
		INC2 GTH2k ,&loop JCN
		( stop at hash ) DUP2 ;data/cells ADD2 LDA LIT "# EQU ?&end
		INC2 GTH2k ?&l
	&end
	POP2 POP2



@@ 480,13 436,13 @@ JMP2r
@op-synth ( synth )

	STH2k
	( channel ) INC2 ;get-port-right-value JSR2 [ ,&ch STR ]
	( octave ) STH2kr INC2 INC2 ;get-port-right-value JSR2
	( note ) STH2kr #0003 ADD2 ;get-port-right-raw JSR2
	( has note ) DUP LIT ". NEQ ,&has-note JCN [ POP2 POP2r JMP2r ] &has-note
	( has bang ) ;get-bang JSR2 ,&is-bang JCN [ POP2 POP2r JMP2r ] &is-bang
	( channel ) INC2 get-port-right-value [ ,&ch STR ]
	( octave ) STH2kr INC2 INC2 get-port-right-value
	( note ) STH2kr #0003 ADD2 get-port-right-raw
	( has note ) DUP LIT ". NEQ ?&has-note [ POP2 POP2r JMP2r ] &has-note
	( has bang ) get-bang ?&is-bang [ POP2 POP2r JMP2r ] &is-bang
	( animate ) .types/io STH2r ;data/types ADD2 STA
	( get note ) ;chrmid JSR2 SWP [ #0c MUL ] ADD
	( get note ) chrmid SWP [ #0c MUL ] ADD
	( play ) .Audio0/pitch [ LIT &ch $1 ] #03 AND #40 SFT ADD DEO

JMP2r


@@ 495,26 451,26 @@ JMP2r
@op-midi ( midi )

	STH2k
	( channel ) INC2 ;get-port-right-value JSR2 [ ,&ch STR ]
	( octave ) STH2kr INC2 INC2 ;get-port-right-value JSR2
	( note ) STH2kr #0003 ADD2 ;get-port-right-raw JSR2
	( velocity ) STH2kr #0004 ADD2 ;get-port-right-raw JSR2 [ ,&vel STR ]
	( length ) STH2kr #0005 ADD2 ;get-port-right-value JSR2
	( channel ) INC2 get-port-right-value [ ,&ch STR ]
	( octave ) STH2kr INC2 INC2 get-port-right-value
	( note ) STH2kr #0003 ADD2 get-port-right-raw
	( velocity ) STH2kr #0004 ADD2 get-port-right-raw [ ,&vel STR ]
	( length ) STH2kr #0005 ADD2 get-port-right-value

	( has note ) OVR LIT ". NEQ ,&has-note JCN [ POP POP2 POP2r JMP2r ] &has-note
	( has bang ) ;get-bang JSR2 ,&is-bang JCN [ POP POP2 POP2r JMP2r ] &is-bang
	( has note ) OVR LIT ". NEQ ?&has-note [ POP POP2 POP2r JMP2r ] &has-note
	( has bang ) get-bang ?&is-bang [ POP POP2 POP2r JMP2r ] &is-bang

	( store length ) .voices ,&ch LDR DUP ADD ADD INC STZk POP [ ,&len STR ]

	( animate ) .types/io STH2r ;data/types ADD2 STA

	( get note ) ;chrmid JSR2 SWP [ #0c MUL ] ADD
	( get note ) chrmid SWP [ #0c MUL ] ADD
	( store note ) DUP .voices ,&ch LDR DUP ADD ADD STZ
	( get velocity ) [ LIT &vel $1 ]
		DUP LIT ". NEQ ,&normalize JCN
		DUP LIT ". NEQ ?&normalize
			( default to max ) POP #7f ,&continue JMP
		&normalize
		;base128 JSR2 &continue SWP
		base128 &continue SWP
	( get channel ) [ LIT &ch $1 ]

	( note on )


@@ 525,7 481,7 @@ JMP2r
	.signal/midi LDZk INC SWP STZ

	( note off immediately if 0 length )
	[ LIT &len $1 ] #00 NEQ ,&done JCN
	[ LIT &len $1 ] #00 NEQ ?&done
		( channel ) .Console/write DEO
		( note ) .Console/write DEO
		( off ) #00 .Console/write DEO


@@ 539,12 495,12 @@ JMP2r
@op-pitch ( pitch )

	STH2k
	( octave ) INC2 ;get-port-right-value JSR2
	( note ) STH2kr INC2 INC2 ;get-port-right-raw JSR2
	( has note ) DUP LIT ". NEQ ,&has-note JCN [ POP2 POP2r JMP2r ] &has-note
	( has bang ) ;get-bang JSR2 ,&is-bang JCN [ POP2 POP2r JMP2r ] &is-bang
	( octave ) INC2 get-port-right-value
	( note ) STH2kr INC2 INC2 get-port-right-raw
	( has note ) DUP LIT ". NEQ ?&has-note [ POP2 POP2r JMP2r ] &has-note
	( has bang ) get-bang ?&is-bang [ POP2 POP2r JMP2r ] &is-bang
	( animate ) .types/io STH2r ;data/types ADD2 STA
	( get note ) ;chrmid JSR2 SWP [ #0c MUL ] ADD .Console/write DEO
	( get note ) chrmid SWP [ #0c MUL ] ADD .Console/write DEO

JMP2r
	&? "; "Send 20 "a 20 "raw 20 "pitch 20 "byte $1


@@ 552,9 508,9 @@ JMP2r
@op-byte ( byte )

	STH2k
	( hn ) INC2 ;get-port-right-value JSR2
	( ln ) STH2kr INC2 INC2 ;get-port-right-value JSR2
	( has bang ) ;get-bang JSR2 ,&is-bang JCN [ POP2 POP2r JMP2r ] &is-bang
	( hn ) INC2 get-port-right-value
	( ln ) STH2kr INC2 INC2 get-port-right-value
	( has bang ) get-bang ?&is-bang [ POP2 POP2r JMP2r ] &is-bang
	( animate ) .types/io STH2r ;data/types ADD2 STA
	#0f AND SWP #0f AND #40 SFT ADD .Console/write DEO



@@ 565,10 521,10 @@ JMP2r

	STH2k
	&while
		INC2 DUP2 ;get-port-right-raw JSR2 LIT ". NEQ ,&while JCN
		INC2 DUP2 get-port-right-raw LIT ". NEQ ?&while
	POP2
	( has bang ) ;get-bang JSR2 ,&is-bang JCN [ POP2r JMP2r ] &is-bang
	.head LDZ2 INC STH2kr ;get-word JSR2 ;inject-file JSR2
	( has bang ) get-bang ?&is-bang [ POP2r JMP2r ] &is-bang
	.head LDZ2 INC STH2kr get-word inject-file
	( animate ) .types/io STH2r ;data/types ADD2 STA

JMP2r


M src/orca.tal => src/orca.tal +3 -3
@@ 49,7 49,7 @@

	( theme )
	#0f75 .System/r DEO2
	#0f7b .System/g DEO2
	#0f7c .System/g DEO2
	#0f7a .System/b DEO2

	( init random )


@@ 134,11 134,11 @@

BRK

@meta 00 &body
@meta 00
	( name ) "Orca 0a
	( details ) "A 20 "Livecoding 20 "Playground 0a
	( author ) "By 20 "Hundred 20 "Rabbits 0a
	( date ) "Jan 20 "8, 20 "2023 00
	( date ) "Jan 20 "21, 20 "2023 00
	02
		( icon ) 83 =appicon
		( mask ) 41 1705