Compare commits
1 Commits
| Author | SHA1 | Date |
|---|---|---|
erik
|
0b18bf4539 |
|
|
@ -1,16 +0,0 @@
|
|||
# use glob syntax.
|
||||
syntax: glob
|
||||
*.pyc
|
||||
*.pyo
|
||||
*~
|
||||
TAGS
|
||||
*.rom
|
||||
img
|
||||
etc
|
||||
test-roms
|
||||
junk
|
||||
img
|
||||
.theme
|
||||
.snarf
|
||||
*.sym
|
||||
wave
|
||||
100
audio-v2.md
100
audio-v2.md
|
|
@ -1,100 +0,0 @@
|
|||
# UXN Audio Proposal (v2)
|
||||
|
||||
*(Updated with input from bd and neauoire)*
|
||||
|
||||
## Problems
|
||||
|
||||
Currently the UXN audio device doesn't work very well for playing
|
||||
complex music. There are a few reasons for this:
|
||||
|
||||
* Note duration is conflated with envelope shape
|
||||
* Envelope resolution (67ms) limits tempos/subdivisions
|
||||
* Using audio callback requires scheduling pauses/silence
|
||||
|
||||
## Proposal outline
|
||||
|
||||
One way to improve the situation is to disentangle the envelope
|
||||
specification from the note duration, and more generally make it
|
||||
easier to specify things that a composer will frequently need to
|
||||
change (pitch, articulation, duration) without having to change the
|
||||
underlying voice (waveform/envelope settings).
|
||||
|
||||
This proposal makes four changes:
|
||||
|
||||
1. Add a two-byte `duration` port that configures a note's duration
|
||||
in milliseconds. The longest possible note is about 66 seconds.
|
||||
|
||||
2. Double the size of the `adsr` port. This means replacing the
|
||||
existing two-byte port with four one-byte ports for `attack`,
|
||||
`decay`, `sustain`, and `release`. Since we have 4 extra bits per
|
||||
stage, we will reduce the resolution of each stage from 66ms to
|
||||
10ms (so 0x01 means 10ms). The longest envelope stage is now about
|
||||
2.6s (up from 1s previously). We special-case `sustain` and
|
||||
instead treat its value as a fraction `x/255` (i.e. 0.0 to 1.0).
|
||||
|
||||
3. Move various ports around, both to improve the layout and prepare
|
||||
for future additions. In particular an `expansion` port for
|
||||
possible MIDI operations and a `detune` port for microtonal music
|
||||
are likely (but are left unspecified by this proposal).
|
||||
|
||||
4. Recommends that emulators use a separate `wst` and `rst` for
|
||||
evaluating the audio vector (when possible). Code run from the
|
||||
audio vector should not expect to read existing values from `wst`
|
||||
or `rst` (and should not leave values behind). This allows
|
||||
emulators to use a separate audio thread for evaluating callbacks
|
||||
without needing to pause other execution.
|
||||
|
||||
## Note duration and tempo
|
||||
|
||||
The `duration` and `vector` ports precisely specify the audio device
|
||||
behavior. The given note should be played for a number of milliseconds
|
||||
specified by `duration`, at which point the `vector` should be called
|
||||
to play the next note (or next silence). For example if the duration
|
||||
is `0x04b0` then the note should play for 1.2 seconds (1200 ms).
|
||||
|
||||
## More flexible envelope settings
|
||||
|
||||
The ADSR ports determine how loud the pitch should be at any given
|
||||
moment. The ADR ports (`attack`, `decay`, and `release`) are all
|
||||
specified in 10ms increments (e.g. `0x03` is 30ms). The S port for
|
||||
`sustain` behaves differently: it specifies what how much of the
|
||||
"leftover" duration to use before the release as a fraction `x/255`.
|
||||
So with a value of `0xff` the note would hold as long as possible, and
|
||||
with `0x00` the release would occur just after the decay ends.
|
||||
|
||||
(If the duration is short parts of the envelope may be truncated.)
|
||||
|
||||
Since each component has its own port, it's also much easier to adjust
|
||||
one without having to fiddle with bit masks, shifting, etc.
|
||||
|
||||
## Appendix A: proposed specification:
|
||||
|
||||
|
||||
ADDR SIZE NAME DESCRIPTION
|
||||
0x30 2 bytes vector callback address to use when note finishes playing
|
||||
0x32 2 bytes duration duration to play sound in fractional seconds (1ms resolution)
|
||||
0x34 1 byte attack envelope: attack duration (vol 0-100%, 10ms resolution)
|
||||
0x35 1 byte decay envelope: decay duration (vol 100-50%, 10ms resolution)
|
||||
0x36 1 byte sustain envelope: sustain fraction (vol 50%, x/255 of free time)
|
||||
0x37 1 byte release envelope: release duration (vol 50-0%, 10ms resolution)
|
||||
0x38 2 bytes addr address to read waveform data from
|
||||
0x3a 2 bytes length length of waveform data to read (in bytes)
|
||||
0x3c 1 byte volume 4-bit volumes for left/right channels (6.7% resolution)
|
||||
0x3d 1 byte (unused - reserved for expansion)
|
||||
0x3e 1 byte pitch 1-bit loop and 7-bit MIDI note (0x00 gives silence)
|
||||
0x3f 1 byte (unused - reserved for detune)
|
||||
|
||||
## Appendix B: existing specification
|
||||
|
||||
ADDR SIZE NAME DESCRIPTION
|
||||
0x30 2 bytes vector callback address to use when note finishes playing
|
||||
0x32 2 bytes position read current position in sample
|
||||
0x34 1 byte output read envelope loudness at this moment (0x000 to 0x888)
|
||||
0x35 (unused)
|
||||
0x36 (unused)
|
||||
0x37 (unused)
|
||||
0x38 2 bytes adsr four 4-bit envelope values (attack/decay/sustain/release)
|
||||
0x3a 2 bytes length length of waveform data to read in bytes
|
||||
0x3c 2 bytes addr address to read waveform data from
|
||||
0x3e 1 byte volume 4-bit volumes for left/right channels
|
||||
0x3f 1 byte pitch 1-bit loop and 7-bit MIDI note
|
||||
|
|
@ -149,7 +149,7 @@
|
|||
STH2kr STA2 ( end* [pos*] ; pos<-n )
|
||||
STH2r INC2 INC2 ( end pos+2* )
|
||||
GTH2k ?&loop ( end* pos+2* )
|
||||
POP2 POP2 LIT2r =cards/last ( [last*] )
|
||||
POP2 POP2 LIT2r :cards/last ( [last*] )
|
||||
LIT2 [ &card $2 ] ( c* [last*] )
|
||||
STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c )
|
||||
LIT2 [ &xy $2 ] ( xy* [last+2*] )
|
||||
|
|
@ -212,7 +212,7 @@
|
|||
|
||||
( returns top card at coords, or 0000 if no card. )
|
||||
@find-card ( x* y* -> addr* )
|
||||
LIT2r =cards LIT2r =cards/last ( x* y* [limit* first*] )
|
||||
LIT2r :cards LIT2r :cards/last ( x* y* [limit* first*] )
|
||||
&loop ( x* y* [limit* pos*] )
|
||||
OVR2 OVR2 STH2kr ( x* y* x* y* pos* [limit* pos*] )
|
||||
intersects ?&done ( x* y* [limit* pos*] )
|
||||
|
|
@ -249,7 +249,7 @@
|
|||
@draw-all-cards ( draw* -> )
|
||||
,&draw STR2 ( )
|
||||
held-end-offset STH2 ( [limit*] )
|
||||
LIT2r =cards ( [limit* pos*] )
|
||||
LIT2r :cards ( [limit* pos*] )
|
||||
&loop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] )
|
||||
|
|
@ -257,7 +257,7 @@
|
|||
LIT2 [ &draw $2 ] JSR2 ( [limit* pos+4] )
|
||||
GTH2kr STHr ?&loop ( [limit* pos+4] )
|
||||
POP2r POP2r ( )
|
||||
LIT2r =cards/end ( [limit*] )
|
||||
LIT2r :cards/end ( [limit*] )
|
||||
held-end-offset STH2 ( [limit* offset*] )
|
||||
&mloop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
|
|
|
|||
176
fix16.tal
176
fix16.tal
|
|
@ -22,17 +22,12 @@
|
|||
( #0700 1792/256 7.0000 )
|
||||
( #7f00 32512/256 127.0000 )
|
||||
( #7fff 32767/256 127.9961 )
|
||||
( #8000 invalid invalid )
|
||||
( #8000 -32768/256 -128.0000 )
|
||||
( #8001 -32767/256 -127.9961 )
|
||||
( #8100 -32767/256 -127.0000 )
|
||||
( #ff00 -256/256 -1.0000 )
|
||||
( #ffff -1/256 -0.0039 )
|
||||
( )
|
||||
( due to the limited range operations saturate at the )
|
||||
( terminal values (i.e. #7fff and #8001). #8000 should )
|
||||
( never be generated through valid arithmetic, and can be )
|
||||
( considered an error if present. )
|
||||
( )
|
||||
( many 8.8 operations are equivalent to unsigned int16: )
|
||||
( * addition )
|
||||
( * subtraction )
|
||||
|
|
@ -65,7 +60,7 @@
|
|||
( - tan() is mostly supported )
|
||||
( - tan(#0192) and tan(#04b6) throw an error )
|
||||
( - a few tan() values are inaccurate due to range )
|
||||
( + values "next to" pi/2 and 3pi/2 are affected )
|
||||
( + values "next to" pi/2 and 3pi/2 are affected )
|
||||
( + tan(#0191) returns 127.996 not 227.785 )
|
||||
( + tan(#0193) returns -127.996 not -292.189 )
|
||||
( + etc. )
|
||||
|
|
@ -113,20 +108,21 @@
|
|||
%x16-pi/2 { #0192 } ( 1.57079... )
|
||||
%x16-pi { #0324 } ( 3.14159... )
|
||||
%x16-3pi/2 { #04b6 } ( 4.71239... )
|
||||
%x16-2pi { #0648 } ( 6.28318... )
|
||||
%x16-pi*2 { #0648 } ( 6.28318... )
|
||||
%x16-e { #02b8 } ( 2.71828... )
|
||||
%x16-phi { #019e } ( 1.61803... )
|
||||
%x16-sqrt-2 { #016a } ( 1.41421... )
|
||||
%x16-sqrt-3 { #01bb } ( 1.73205... )
|
||||
%x16-epsilon { #0001 } ( 0.00390... )
|
||||
%x16-minimum { #8001 } ( -127.99609... )
|
||||
%x16-minimum { #8000 } ( -128.0 )
|
||||
%x16-maximum { #7fff } ( 127.99609... )
|
||||
%x16-error { #8000 } ( not a number )
|
||||
%x16-max-whole { #7f00 } ( 127.0 )
|
||||
|
||||
( utils )
|
||||
@x16-is-non-neg ( x* -> bool^ ) x16-minimum LTH2 JMP2r
|
||||
@x16-is-neg ( x* -> bool^ ) x16-maximum GTH2 JMP2r
|
||||
@x16-emit-dec-digit ( d^ -> ) #30 ADD #18 DEO JMP2r
|
||||
@error [ #0000 DIV ]
|
||||
|
||||
@x16-emit ( x* -> )
|
||||
DUP2 #8000 EQU2 ?&is-min
|
||||
|
|
@ -202,66 +198,43 @@
|
|||
@x16-mul ( x* y* -- xy* )
|
||||
;x16-mul-unsigned !x16-signed-op
|
||||
|
||||
@x16-mul8 ( x^ y^ -> xy* )
|
||||
#0000 SWP2 ROT SWP MUL2 JMP2r
|
||||
@x16-mul-unsigned ( x* y* -- xy* )
|
||||
DUP #00 EQU ?x16-mul-unsigned-rhs-whole
|
||||
SWP2 DUP #00 EQU ?x16-mul-unsigned-rhs-whole
|
||||
,&y0 STR2 ,&x0 STR2
|
||||
#00 ,&x0 LDR #00 ,&y0 LDR MUL2 ( acc* )
|
||||
OVR ?&overflow SWP ( acc* )
|
||||
#00 ,&x1 LDR #00 ,&y0 LDR MUL2 ADD2 ( acc* )
|
||||
#00 ,&x0 LDR #00 ,&y1 LDR MUL2 ADD2 ( acc* )
|
||||
#00 ,&x1 LDR #00 ,&y1 LDR MUL2 #08 SFT2 ADD2 ( acc* )
|
||||
DUP2 #7fff GTH2 ?&overflow
|
||||
JMP2r [ &x0 $1 &x1 $1 &y0 $1 &y1 $1 ]
|
||||
&overflow POP2 #7fff JMP2r
|
||||
|
||||
@x16-mul-unsigned ( ab* cd* -> ac+ad+bc+bd* )
|
||||
OVR2 OVR2 STH2 STH2 ROT SWPr ROTr ( a c d b [c b a d] )
|
||||
SWP2 x16-mul8 DUP2 #007f GTH2 ?&o1 SWP ( d b acc* [c b a d] )
|
||||
SWP2 x16-mul8 #08 SFT2 ADD2 ( acc* [c b a d] )
|
||||
STH2r x16-mul8 ADD2 OVR #7f GTH ?&o3 ( acc* [c d] )
|
||||
STH2r x16-mul8 ADD2 OVR #7f GTH ?&o4 JMP2r ( acc* )
|
||||
&o1 POP2 POP2r &o3 POP2r &o4 POP2 #7fff JMP2r ( ; handle overflow )
|
||||
@x16-mul-unsigned-rhs-whole ( x0_x1* y0_00* -- xy* )
|
||||
#08 SFT2 MUL2 #7fff !unsigned-min
|
||||
|
||||
@x16-div ( x* y* -- x/y* )
|
||||
;x16-div-unsigned !x16-signed-op
|
||||
|
||||
( The idea here is a bit complicated. )
|
||||
( )
|
||||
( First we look at `x y DIV2`. If that is >255 then we are )
|
||||
( going to overflow and we can return 7fff and be done. )
|
||||
( )
|
||||
( If not, we multiply that result by 256 and start looking )
|
||||
( for smaller and smaller fractions of y to star chipping )
|
||||
( away at the remainder, if any. )
|
||||
( )
|
||||
( However we want to avoid rounding errors caused by needlessly )
|
||||
( truncating y. For that reason, if the remainder is less than )
|
||||
( 0x8000 we will double it rather than diving y. Once it cannot )
|
||||
( be safely multiplied we will start dividing y by 2. After 16 )
|
||||
( rounds of multiplying the remainder or dividing the quotient )
|
||||
( we get our final answer. )
|
||||
@x16-div-unsigned ( x* y* -> x/y* )
|
||||
DIV2k DUP2 #007f GTH2 ?&o ( x* y* x/y* )
|
||||
STH2k LITr 80 SFT2r ( x* y* x/y* [div=(x/y)<<8*] )
|
||||
OVR2 STH2 ( x* y* x/y* [div* y*] )
|
||||
MUL2 SUB2 ( x%y* [div* y*] )
|
||||
STH2r LIT2r 0100 ( x%y* y* [div* 0100*] )
|
||||
|
||||
( We know rem < y, so start left-shifting rem. )
|
||||
&ploop ( rem* y* [div* s*] )
|
||||
STH2kr #0000 EQU2 ?&done ( rem* y* [div* s*] ; done when s=0 )
|
||||
OVR2 #7fff GTH2 ?&loop ( rem* y* [div* s*] ; rem too big, start shifting y )
|
||||
SWP2 #10 SFT2 SWP2 ( rem<<1* y* [div* s*] )
|
||||
LITr 01 SFT2r ( rem<<1* y* [div* s>>1*] )
|
||||
LTH2k ?&ploop ( rem<<1* y* [div* s>>1*] ; rem too small )
|
||||
SWP2 OVR2 SUB2 SWP2 ( rem<<1-y* y* [div* s>>1*] )
|
||||
DUP2r ROT2r ADD2r SWP2r ( rem<<1-y* y* [div+s>>1* s>>1*] )
|
||||
!&ploop ( rem<<1-y* y* [div+s>>1* s>>1*] )
|
||||
|
||||
( We know rem < y, so start right-shifting y. )
|
||||
&loop ( rem* y* [div* s*] )
|
||||
STH2kr #0000 EQU2 ?&done ( rem* y* [div* s*] ; done when s=0 )
|
||||
#01 SFT2 LITr 01 SFT2r ( rem* y>>1* [div* s>>1*] )
|
||||
LTH2k ?&loop ( rem* y>>1* [div* s>>1**] ; rem too small )
|
||||
SWP2 OVR2 SUB2 SWP2 ( rem-y>>1* y>>1* [div* s>>1*] )
|
||||
DUP2r ROT2r ADD2r SWP2r ( rem-y>>1* y>>1* [div+s>>1* s>>1*] )
|
||||
!&loop ( rem-y>>1* y>>1* [div+s>>1* s>>1*] )
|
||||
DIV2k STH2k ( x y x/y [x/y] )
|
||||
LITr 80 SFT2r ( x y x/y [div=(x/y)<<8] )
|
||||
OVR2 STH2 ( x y x/y [y div] )
|
||||
MUL2 SUB2 ( x%y [y div] )
|
||||
STH2r LIT2r 0100 ( x%y y [0100 div] )
|
||||
|
||||
( We know x%y < y, so start right-shifting y. )
|
||||
&loop DUP2 #0000 EQU2 ?&done
|
||||
#01 SFT2 LITr 01 SFT2r ( rem yi [shifti div] )
|
||||
LTH2k ,&loop JCN ( rem yi [shifti div] )
|
||||
SWP2 OVR2 SUB2 SWP2 ( rem-yi yi [shifti div] )
|
||||
DUP2r ROT2r ADD2r SWP2r ( rem-yi yi [shifti div+shifti] )
|
||||
!&loop ( rem-yi yi [shifti div+shifti] )
|
||||
&done
|
||||
POP2 POP2 POP2r STH2r ( div* )
|
||||
DUP2 #7fff GTH2 ?&oo JMP2r ( div* )
|
||||
&o POP2 POP2 &oo POP2 #7fff JMP2r ( 7fff ; saturate on overflow )
|
||||
|
||||
POP2 POP2 ( [shiftk div] )
|
||||
POP2r STH2r JMP2r ( div )
|
||||
|
||||
@x16-signed-op ( x* y* f* -> f(x,y)* )
|
||||
STH2 LIT2r 0001
|
||||
|
|
@ -272,11 +245,7 @@
|
|||
JMP2r
|
||||
|
||||
@x16-quotient ( x* y* -> x//y* )
|
||||
;x16-quot-unsigned !x16-signed-op
|
||||
|
||||
@x16-quot-unsigned ( x* y* -> x//y* )
|
||||
DIV2 DUP2 #007f GTH2 ?{ #80 SFT2 JMP2r }
|
||||
POP2 #7fff JMP2r
|
||||
DIV2 #80 SFT2 JMP2r
|
||||
|
||||
@x16-remainder ( x* y* -> x%y* )
|
||||
DIV2k MUL2 SUB2 JMP2r
|
||||
|
|
@ -286,10 +255,9 @@
|
|||
|
||||
@x16-from-s16 ( n* -> x* )
|
||||
DUP2 #ff80 GTH2 ?&neg
|
||||
DUP2 #007f GTH2 ?&error
|
||||
DUP2 #007f GTH2 ?error
|
||||
NIP #00 SWP JMP2r
|
||||
&neg NIP #ff SWP JMP2r
|
||||
&error POP2 #8000 JMP2r
|
||||
|
||||
( 1.5 -> 1, 0.5 -> 0, -1.5 -> -1 )
|
||||
@x16-to-s16 ( x* -> whole* )
|
||||
|
|
@ -342,31 +310,30 @@
|
|||
&done ( x* s1* [c* 2*] )
|
||||
POP2r POP2r NIP2 JMP2r ( s1* )
|
||||
|
||||
@x16-unit-circle ( x* -> x'* )
|
||||
x16-2pi STH2 ( x* [2pi*] )
|
||||
DUP2 STH2kr x16-quotient ( x* x/2pi* [2pi*] )
|
||||
DUP2 #1400 DIV2 STH2 SWP2r ( x* x/2pi* [adj* 2pi*] )
|
||||
STH2r x16-mul SUB2 ( x-x/2pi* [adj*] )
|
||||
STH2r LTH2k ?{ SUB2 JMP2r } ( x'* ; 0 <= x' < 2pi )
|
||||
POP2 POP2 #0000 JMP2r ( x'* ; 0 <= x' < 2pi )
|
||||
|
||||
@x16-cos ( x* -> cos[x]* )
|
||||
x16-unit-circle x16-pi/2 ADD2 ( fall-through )
|
||||
x16-pi/2 ADD2 ( fall-thru )
|
||||
|
||||
@x16-sin ( x* -> sin[x]* )
|
||||
DUP2 #8000 LTH2 ?&positive x16-negate x16-sin/positive !x16-negate
|
||||
&positive x16-unit-circle
|
||||
DUP2 x16-3pi/2 LTH2 ?{ x16-2pi SWP2 SUB2 x16-sin/q !x16-negate }
|
||||
DUP2 x16-pi LTH2 ?{ x16-pi SUB2 x16-sin/q !x16-negate }
|
||||
DUP2 x16-pi/2 LTH2 ?{ x16-pi SWP2 SUB2 }
|
||||
&q DUP2 ADD2 ;x16-sin-table ADD2 LDA2 JMP2r
|
||||
DUP2 #8000 LTH2 ?&non-negative
|
||||
x16-negate x16-sin/non-negative !x16-negate
|
||||
&non-negative
|
||||
x16-pi*2 STH2 ( x [2pi] )
|
||||
DUP2 STH2kr x16-quotient ( x x/2pi [2pi] )
|
||||
STH2r x16-mul SUB2 ( x' ; 0 <= x' < 2pi )
|
||||
|
||||
DUP2 x16-3pi/2 LTH2 ?&c1
|
||||
( -sin(2pi - x) ) x16-pi*2 SWP2 SUB2 x16-sin-q !x16-negate
|
||||
&c1 DUP2 x16-pi LTH2 ?&c2
|
||||
( -sin(x - pi) ) x16-pi SUB2 x16-sin-q !x16-negate
|
||||
&c2 DUP2 x16-pi/2 LTH2 ?&c3
|
||||
( sin(pi - x) ) x16-pi SWP2 SUB2 !x16-sin-q
|
||||
&c3
|
||||
( sin[x] ) ( fall-thru )
|
||||
|
||||
( 0 <= x < 2pi )
|
||||
@x16-sin-q ( x* -> sin[x] )
|
||||
DUP2 ADD2 ;x16-sin-table ADD2 LDA2 JMP2r
|
||||
|
||||
( there are 1608 8.8 fixed point values between 0 and 2pi. )
|
||||
( )
|
||||
( we use 402 tables entries x 4 quadants to get 1608 values. )
|
||||
( )
|
||||
( note that the table actually has 403 values just to make )
|
||||
( boundary conditions a bit easier to deal with. )
|
||||
@x16-sin-table
|
||||
0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f
|
||||
0010 0011 0012 0013 0014 0015 0016 0017 0018 0019 001a 001b 001c 001d 001e 001f
|
||||
|
|
@ -396,15 +363,26 @@
|
|||
0100 0100 0100
|
||||
|
||||
@x16-tan ( x* -> tan[x]* )
|
||||
x16-unit-circle
|
||||
x16-pi*2 STH2 ( x [2pi] )
|
||||
DUP2 STH2kr x16-quotient ( x x/2pi [2pi] )
|
||||
STH2r x16-mul SUB2 ( x' ; 0 <= x' < 2pi )
|
||||
|
||||
( tan(pi/2) = tan(3pi/2) = error )
|
||||
DUP2 x16-3pi/2 EQU2 ?&error
|
||||
DUP2 x16-pi/2 EQU2 ?&error
|
||||
DUP2 x16-3pi/2 LTH2 ?{ x16-2pi SWP2 SUB2 x16-tan/q !x16-negate }
|
||||
DUP2 x16-pi LTH2 ?{ x16-pi SUB2 !x16-tan/q }
|
||||
DUP2 x16-pi/2 LTH2 ?{ x16-pi SWP2 SUB2 x16-tan/q !x16-negate }
|
||||
&q DUP2 ADD2 ;x16-tan-table ADD2 LDA2 JMP2r
|
||||
&error POP2 #8000 JMP2r
|
||||
DUP2 x16-3pi/2 EQU2 ?error
|
||||
DUP2 x16-pi/2 EQU2 ?error
|
||||
|
||||
DUP2 x16-3pi/2 LTH2 ?&c1
|
||||
( -tan(2pi - x) ) x16-pi*2 SWP2 SUB2 x16-tan-q !x16-negate
|
||||
&c1 DUP2 x16-pi LTH2 ?&c2
|
||||
( tan(x - pi) ) x16-pi SUB2 !x16-tan-q
|
||||
&c2 DUP2 x16-pi/2 LTH2 ?&c3
|
||||
( -tan(pi - x) ) x16-pi SWP2 SUB2 x16-tan-q !x16-negate
|
||||
&c3
|
||||
( tan[x] ) ( fall-thru )
|
||||
|
||||
( 0 <= x < 2pi )
|
||||
@x16-tan-q ( x* -> sin[x] )
|
||||
DUP2 ADD2 ;x16-tan-table ADD2 LDA2 JMP2r
|
||||
|
||||
@x16-tan-table
|
||||
0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f
|
||||
|
|
@ -438,7 +416,7 @@
|
|||
|
||||
[ DUP2 #0000 GTH2 ] STH
|
||||
[ DUP2 #8000 LTH2 ] STHr AND ?&0<x<128
|
||||
( error ) POP2 #8000 JMP2r ( error )
|
||||
( error ) !error
|
||||
|
||||
&0<x<128 DUP2 #0800 GTH2 ?&8<x<128
|
||||
( 0<x<=8 ) DUP2 #0200 GTH2 ?&2<x<=8
|
||||
|
|
|
|||
186
icn_to_bmp.tal
186
icn_to_bmp.tal
|
|
@ -1,186 +0,0 @@
|
|||
( icn_to_bmp.tal )
|
||||
( )
|
||||
( converts ICN files to BMP files. )
|
||||
( )
|
||||
( USAGE: icn_to_bmp.rom $tile-w $tile-h $in-file $out-file )
|
||||
( )
|
||||
( EXAMPLE: icn_to_bmp.rom 8 8 icon.icn icon.bmp # convert a 64x64 pixel image )
|
||||
|
||||
@System [ |0f &state $1 ]
|
||||
@Console [ |18 &w $1 ]
|
||||
|a0 @File1 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|b0 @File2 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|
||||
|0000
|
||||
@tile-w $2
|
||||
@adj-tile-w $2
|
||||
@tile-h $2
|
||||
@icn-size $2
|
||||
@in-file $2
|
||||
@out-file $2
|
||||
@row-size-bytes $2
|
||||
@adj-row-size-bytes $2
|
||||
|
||||
|0100
|
||||
;after-args #0000 arg/init BRK
|
||||
|
||||
( load argument parsing )
|
||||
~arg.tal
|
||||
|
||||
( exit immediately )
|
||||
@exit ( -> BRK )
|
||||
#01 .System/state DEO BRK
|
||||
|
||||
( write null-terminated string to stdout )
|
||||
@emit ( buf* -> )
|
||||
LITr -Console/w ( buf* [dev^] )
|
||||
&loop LDAk ?&ok POP2 POPr JMP2r ( )
|
||||
&ok LDAk STHkr DEO INC2 !&loop ( buf+1* [dev^] )
|
||||
|
||||
@msg
|
||||
&wrote "wrote 20 00
|
||||
&bytes-to 20 "bytes 20 "to 20 00
|
||||
&invalid-width "Invalid 20 "tile 20 "width 00
|
||||
&invalid-height "Invalid 20 "tile 20 "height 00
|
||||
&invalid-size "Invalid 20 "size: 20 "ICN 20 "too 20 "large
|
||||
&write-error "Failed 20 "to 20 "write 20 "data 00
|
||||
&wrong-number-of-args "Wrong 20 "number 20 "of 20 "args; 20 "expected 20 "four 00
|
||||
|
||||
@usage ( reason* -> )
|
||||
;usage/error emit emit ;usage/message emit !exit
|
||||
&error "ERROR: 20 00
|
||||
&message
|
||||
0a 0a "USAGE: 20 "icn_to_bmp.rom 20 "WIDTH 20 "HEIGHT 20 "ICN 20 "BMP 0a
|
||||
20 20 "WIDTH 20 "and 20 "HEIGHT 20 "are 20 "given 20 "in 20 "tiles 20 "(each 20 "tile 20 "is 20 "8x8 20 "pixels) 0a
|
||||
20 20 "maximum 20 "WIDTH/HEIGHT 20 "is 20 "255 20 "tiles 0a
|
||||
20 20 "ICN/BMP 20 "should 20 "be 20 "paths 20 "(that 20 "are 20 "readable/writable) 0a
|
||||
20 20 "maximum 20 "ICN 20 "size 20 "is 20 "49152 20 "bytes 0a
|
||||
0a 00
|
||||
|
||||
@str-to-int ( s* -> n* )
|
||||
LIT2r 0000
|
||||
&loop LDAk ?&non-null POP2 STH2r JMP2r
|
||||
&non-null LDAk LIT "0 SUB DUP #09 GTH ?&bad
|
||||
LIT2r 000a MUL2r LITr 00 STH ADD2r INC2 !&loop
|
||||
&bad POP2 POP2r #0000 JMP2r
|
||||
|
||||
( emit a short as a decimal )
|
||||
@emit-dec2 ( n* -> )
|
||||
LITr 00 ( n [0] )
|
||||
&read ( n [k] )
|
||||
#000a DIV2k STH2k MUL2 SUB2 STH2r INCr ( n%10 n/10 [k+1] )
|
||||
DUP2 ORA ,&read JCN
|
||||
POP2 ( top element was 0000 )
|
||||
&write ( n0 n1 ... nk [k+1] )
|
||||
NIP #30 ADD #18 DEO LITr 01 SUBr ( n0 ... n{k-1} [k] )
|
||||
STHkr ,&write JCN
|
||||
POPr JMP2r
|
||||
|
||||
@after-args ( -> )
|
||||
;arg/count LDA #04 EQU ?{ ;msg/wrong-number-of-args !usage }
|
||||
#00 arg/read str-to-int .tile-w STZ2
|
||||
#01 arg/read str-to-int .tile-h STZ2
|
||||
#02 arg/read .in-file STZ2
|
||||
#03 arg/read .out-file STZ2
|
||||
.tile-w LDZ2 .tile-h LDZ2 MUL2 #30 SFT2 .icn-size STZ2
|
||||
.tile-w LDZ2 #30 SFT2 .row-size-bytes STZ2
|
||||
.tile-w LDZ2 #0008 MUL2 #001f ADD2 #0020 DIV2 #0004 MUL2 .adj-tile-w STZ2
|
||||
.adj-tile-w LDZ2 #30 SFT2 .adj-row-size-bytes STZ2
|
||||
validate
|
||||
write-header
|
||||
read-icn
|
||||
write-body
|
||||
;msg/wrote emit
|
||||
;bmp-header/total-size LDA2 SWP emit-dec2
|
||||
;msg/bytes-to emit .out-file LDZ2 emit
|
||||
#0a .Console/w DEO
|
||||
!exit
|
||||
|
||||
@read-icn ( -> ok^ )
|
||||
.in-file LDZ2 .File1/name DEO2
|
||||
.icn-size LDZ2 STH2k .File1/len DEO
|
||||
;icn-dat .File1/r DEO2
|
||||
.File1/ok DEI2 STH2r EQU2 JMP2r
|
||||
|
||||
@convert-tile-row ( src* -> )
|
||||
.row-size-bytes LDZ2 ( src* size* )
|
||||
OVR2 ADD2 SWP2 LIT2r =bmp-buf ( limit* src* [dst*] )
|
||||
&loop ( limit* src* [dst*] )
|
||||
DUP2 STH2kr convert-row ( limit* src* [dst*] )
|
||||
#0008 ADD2 INC2r ( limit* src+8* [dst+1*] )
|
||||
GTH2k ?&loop ( limit* src+8* [dst+1*] )
|
||||
POP2 POP2 POP2r JMP2r ( )
|
||||
|
||||
@convert-row ( src* dst* -> )
|
||||
LITr -adj-tile-w LDZ2r STH2 ( src* [w* dst*] )
|
||||
#0001 SUB2 DUP2 #0008 ADD2 ( lim* src+7* [w* dst*] )
|
||||
&loop ( lim* pos* [w* dst*] )
|
||||
LDAk STH2kr STA OVR2r ADD2r ( src* pos* [w* dst+w*] ; dst<-pos )
|
||||
#0001 SUB2 LTH2k ?&loop ( src* pos-1* [w* dst+w*] )
|
||||
POP2 POP2 POP2r POP2r JMP2r ( )
|
||||
|
||||
@write-tile-row ( -> ok^ )
|
||||
.adj-row-size-bytes LDZ2 STH2k .File2/len DEO2
|
||||
;bmp-buf .File2/w DEO2
|
||||
.File2/ok DEI2 STH2r EQU2 JMP2r
|
||||
|
||||
@validate ( -> )
|
||||
.tile-w LDZ2 #0001 SUB2 #00ff LTH2 ?&tile-w-ok ;msg/invalid-width !usage &tile-w-ok
|
||||
.tile-h LDZ2 #0001 SUB2 #00ff LTH2 ?&tile-h-ok ;msg/invalid-height !usage &tile-h-ok
|
||||
.icn-size LDZ2 #c001 LTH2 ?&size-ok ;msg/invalid-size !usage &size-ok
|
||||
JMP2r
|
||||
|
||||
( colors are provided in RGB order, written to BMP header in reverse )
|
||||
@write-color ( r^ g^ b^ addr* -> )
|
||||
STH2k STA INC2r ( ; addr+0<-b )
|
||||
STH2kr STA INC2r ( ; addr+1<-g )
|
||||
STH2r STA JMP2r ( ; addr+2<-r )
|
||||
|
||||
@write-header ( -> )
|
||||
( NOTE: you'll see some swaps just before stores )
|
||||
( this is because the BMP header uses a little-endian byte order )
|
||||
.adj-tile-w LDZ2 .tile-h LDZ2 MUL2 ( aw*h )
|
||||
#30 SFT2 #0020 ADD2 ( 32+aw*h*8 )
|
||||
SWP ;bmp-header/total-size STA2 ( ; write total-size )
|
||||
.tile-h LDZ2 #30 SFT2 SWP ;bmp-header/pixel-h STA2 ( ; write height )
|
||||
.tile-w LDZ2 #30 SFT2 SWP ;bmp-header/pixel-w STA2 ( ; write width )
|
||||
|
||||
( these colors are specified in RGB order )
|
||||
#ff #ff #ff ;bmp-header/color0 write-color ( ; write color 0 )
|
||||
#00 #00 #00 ;bmp-header/color1 write-color ( ; write color 1 )
|
||||
|
||||
( actually write out the BMP header now )
|
||||
.out-file LDZ2 .File2/name DEO2
|
||||
#0020 .File2/len DEO2
|
||||
;bmp-header .File2/w DEO2
|
||||
.File2/ok DEI2 #0020 EQU2 ?&ok ;msg/write-error !usage
|
||||
&ok JMP2r
|
||||
|
||||
@write-body ( -> )
|
||||
;icn-dat ( dat* )
|
||||
.icn-size LDZ2 OVR2 ADD2 ( dat* dat+size* )
|
||||
.row-size-bytes LDZ2 STH2k SUB2 ( dat* dat+size-row* [row*] )
|
||||
&loop
|
||||
DUP2 convert-tile-row
|
||||
write-tile-row ?&ok2 ;msg/write-error !usage &ok2
|
||||
STH2kr SUB2 GTH2k ?&done !&loop
|
||||
&done POP2r POP2 POP2 JMP2r
|
||||
|
||||
( fields marked "MOD" will be updated; others will stay the same )
|
||||
@bmp-header
|
||||
"BM ( 0: identify bitmap )
|
||||
&total-size 00 00 00 00 ( 2: total file size in bytes, includes header, MOD )
|
||||
00 00 ( 6: reserved, zero )
|
||||
00 00 ( 8: reserved, zero )
|
||||
20 00 00 00 ( 10: pixel data offset, 32 bytes )
|
||||
0c 00 00 00 ( 14: header size, 12 bytes )
|
||||
&pixel-w 00 00 ( 18: width in pixels, MOD )
|
||||
&pixel-h 00 00 ( 20: height in pixels, MOD )
|
||||
01 00 ( 22: color planes, 1 )
|
||||
01 00 ( 24: bits per pixel, 1 )
|
||||
&color0 ff ff ff ( 26: color 0, blue/green/red MOD )
|
||||
&color1 00 00 00 ( 29: color 1, blue/green/red MOD )
|
||||
( 32: start of pixel data MOD )
|
||||
|
||||
@bmp-buf $7f8 ( 2040 bytes: buffer for one BMP row )
|
||||
@icn-dat $c000 ( 49152 bytes: buffer for the entire ICN file )
|
||||
185
julia.tal
185
julia.tal
|
|
@ -1,185 +0,0 @@
|
|||
( julia.tal )
|
||||
( )
|
||||
( based on mandelbrot.tal by alderwick and d_m )
|
||||
( )
|
||||
( uses 4.12 fixed point arithmetic. )
|
||||
|
||||
( SCALE LOGICAL SCREENSIZE )
|
||||
( #0001 21x16 42x32 )
|
||||
( #0002 42x32 84x64 )
|
||||
( #0004 84x64 168x128 )
|
||||
( #0008 168x128 336x256 )
|
||||
( #0010 336x256 672x512 )
|
||||
( #0020 672x512 1344x1024 )
|
||||
|
||||
%SCALE { #0009 } ( 32 )
|
||||
%WIDTH { #0015 } ( 21 )
|
||||
%HEIGHT { #0010 } ( 16 )
|
||||
%XMIN { #de69 } ( -8601 => -8601/4096 => -2.100 )
|
||||
%XMAX { #0b33 } ( 2867 => 2867/4096 => 0.700 )
|
||||
%YMIN { #ecc7 } ( -4915 => -4915/4096 => -1.200 )
|
||||
%YMAX { #1333 } ( 4915 => 4915/4096 => 1.200 )
|
||||
|
||||
|00 @System &vector $2 &wst $1 &rst $1 &eaddr $2 &ecode $1 &pad $1 &r $2 &g $2 &b $2 &debug $1 &halt $1
|
||||
|20 @Screen &vector $2 &width $2 &height $2 &auto $1 &pad $1 &x $2 &y $2 &addr $2 &pixel $1 &sprite $1
|
||||
|
||||
|0100 ( -> )
|
||||
|
||||
( set colors )
|
||||
#00ff .System/r DEO2
|
||||
#0ff0 .System/g DEO2
|
||||
#0f0f .System/b DEO2
|
||||
|
||||
( set window size )
|
||||
width #10 SFT2 .Screen/width DEO2
|
||||
height #10 SFT2 .Screen/height DEO2
|
||||
|
||||
( starting c values )
|
||||
#0630 ;evaluate/cx STA2 #f5e0 ;evaluate/cy STA2
|
||||
|
||||
;on-screen .Screen/vector DEO2
|
||||
BRK
|
||||
|
||||
@on-screen ( -> BRK )
|
||||
#0000 DUP2 .Screen/x DEO2 .Screen/y DEO2
|
||||
draw-julia
|
||||
|
||||
;evaluate/cx LDA2
|
||||
DUP2 #2000 LTH2 ?&upx
|
||||
DUP2 #e000 GTH2 ?&upx
|
||||
#0000 ,&dx LDR2 SUB2 ,&dx STR2
|
||||
&upx [ LIT2 &dx 0040 ] ADD2 SWP2 STA2
|
||||
|
||||
;evaluate/cy LDA2k
|
||||
DUP2 #2000 LTH2 ?&upy
|
||||
DUP2 #e000 GTH2 ?&upy
|
||||
#0000 ,&dy LDR2 SUB2 ,&dy STR2
|
||||
&upy [ LIT2 &dy 0040 ] ADD2 SWP2 STA2
|
||||
BRK
|
||||
|
||||
( logical width )
|
||||
@width ( -> w* )
|
||||
WIDTH SCALE MUL2 JMP2r
|
||||
|
||||
( logical height )
|
||||
@height ( -> h* )
|
||||
HEIGHT SCALE MUL2 JMP2r
|
||||
|
||||
( draw the julia set using 4.12 fixed point numbers )
|
||||
@draw-julia ( -> )
|
||||
XMAX XMIN SUB2 width DIV2 ,&dx STR2 ( ; &dx<-{xmax-min}/width )
|
||||
YMAX YMIN SUB2 height DIV2 ,&dy STR2 ( ; &dy<-{ymax-ymin}/height )
|
||||
[ LIT2 01 -Screen/auto ] DEO ( ; auto<-1 )
|
||||
LIT2r 8000 ( [8000] )
|
||||
YMAX YMIN ( ymax* ymin* [8000] )
|
||||
&yloop ( ymax* y* [8000] )
|
||||
XMAX XMIN ( ymax* y* xmax* xmin* [8000] )
|
||||
&xloop ( ymax* y* xmax* x* [8000] )
|
||||
ROT2k evaluate ( ymax* y* xmax* x* xmax* count^ [8000] )
|
||||
draw-px POP2 ( ymax* y* xmax* x* [8000] )
|
||||
[ LIT2 &dx $2 ] ADD2 ( ymax* y* xmax* x+dx* [8000] )
|
||||
OVR2 STH2kr ADD2 ( ymax* y* xmax* x+dx* 8000+xmax* [8000] )
|
||||
OVR2 STH2kr ADD2 ( ymax* y* xmax* x+dx* 8000+xmax* 8000+x+dx* [8000] )
|
||||
GTH2 ?&xloop ( ymax* y* xmax* x+dx* [8000] )
|
||||
POP2 POP2 ( ymax* y* [8000] )
|
||||
#0000 .Screen/x DEO2 ( ymax* y* [8000] ; sc/x<-0 )
|
||||
.Screen/y ;inc2 adjust ( ymax* y* [8000] ; sc/y<-sy+1 )
|
||||
[ LIT2 &dy $2 ] ADD2 ( ymax* y+dy* [8000] )
|
||||
OVR2 STH2kr ADD2 ( ymax* y+dy* 8000+ymax* [8000] )
|
||||
OVR2 STH2kr ADD2 ( ymax* y+dy* 8000+ymax* 8000+y+dy* [8000] )
|
||||
GTH2 ?&yloop ( ymax* y+dy* [8000] )
|
||||
POP2 POP2 POP2r JMP2r ( )
|
||||
|
||||
( dithering pattern for 2x2 pixels: )
|
||||
( )
|
||||
( |o o| -> |x o| -> |x o| -> |x x| -> |x x| )
|
||||
( |o o| -> |o o| -> |o x| -> |o x| -> |x x| )
|
||||
( )
|
||||
( |[p+3]/4 [px+1]/4| )
|
||||
( |[p+0]/4 [px+2]/4| )
|
||||
@draw-px ( px^ -> )
|
||||
INCk INCk INC ( p+0 p+1 p+3 )
|
||||
draw-quad draw-quad ( p+0 ; draw NW, NE )
|
||||
.Screen/y ;inc1 adjust ( ; y<-y+1 )
|
||||
.Screen/x ;sub2 adjust ( ; x<-x-2 )
|
||||
INCk INC SWP ( p+2 p+0 )
|
||||
draw-quad draw-quad ( ; draw SW, SE )
|
||||
.Screen/y ;sub1 !adjust ( ; y<-y-1 )
|
||||
|
||||
( draw one quadrant of a 2x2 area )
|
||||
@draw-quad ( p^ -> )
|
||||
#02 SFT .Screen/pixel DEO JMP2r ( ; pixel<-p/4 )
|
||||
|
||||
( evaluate the julia function at one point )
|
||||
@evaluate ( x* y* -> count^ )
|
||||
LIT2r 20 00 ( x* y* [20 00] )
|
||||
&loop ( x1* y1* [20 n^] )
|
||||
OVR2 square STH2 ( x1* y1* [20 n^ xx1*] )
|
||||
DUP2 square STH2 ( x1* y1* [20 n^ xx1* yy1*] )
|
||||
ADD2kr STH2r ( x1* y1* xx1+yy1* [20 n^ xx1* yy1*] )
|
||||
#4000 GTH2 ?&end2 ( x1* y1* [20 n^ xx1* yy1*] )
|
||||
smul2 DUP2 ADD2 ( 2x1y1* [20 n^ xx1* yy1*] )
|
||||
LIT2 [ &cy $2 ] ADD2 ( y2=2x1y1+cy* [20 n^ xx1* yy1*] )
|
||||
SUB2r STH2r ( y2* xx1-yy1* [20 n^] )
|
||||
LIT2 [ &cx $2 ] ADD2 ( y2* x2=xx1-yy1+cx* [20 n^] )
|
||||
SWP2 INCr GTHkr STHr ?&loop ( x2* y2* [20 n+1^] )
|
||||
!&end1 ( x2* y2* [20 n+1^] )
|
||||
&end2 POP2r POP2r ( x* y* [20 count^] )
|
||||
&end1 POP2 POP2 NIPr STHr JMP2r ( count^ )
|
||||
|
||||
( is x a non-negative signed value? )
|
||||
@non-negative ( x* -> x* x>=0^ )
|
||||
DUP2 #8000 LTH2 JMP2r
|
||||
|
||||
( multiply two signed 4.12 fixed point numbers )
|
||||
@smul2 ( a* b* -> ab* )
|
||||
LIT2r 0001 non-negative ?{ negate SWPr } ( a* |b|* [sign*] )
|
||||
SWP2 non-negative ?{ negate SWPr } ( |b|* |a|* [sign*] )
|
||||
smul2-pos STHr ?{ negate } POPr JMP2r ( ab* )
|
||||
|
||||
( multiply two non-negative fixed point numbers )
|
||||
( )
|
||||
( a * b = {a0/16 + a1/4096} * {b0/16 + b1/4096} )
|
||||
( = a0b0/256 + a1b0/65536 + a0b1/65536 + a1b1/16777216 )
|
||||
( = x + y + z + 0 ; the last term is too small to represent, i.e. zero )
|
||||
( )
|
||||
( x = a0b0 << 4 )
|
||||
( y = a1b0 >> 4 )
|
||||
( z = a0b1 >> 4 )
|
||||
@smul2-pos ( a* b* -> ab* )
|
||||
aerate ROT2 aerate ( b0* b1* a0* a1* )
|
||||
STH2 ROT2k STH2 MUL2r ( b0* b1* a0* b1* a0* [a1b0*] )
|
||||
MUL2 STH2 ADD2r ( b0* b1* a0* [a1b0+a0b1*] )
|
||||
NIP2 MUL2 #07ff min #40 SFT2 ( a0b0* [y+z*] )
|
||||
STH2r #04 SFT2 ADD2 ( x* [y+z*] )
|
||||
#7fff !min ( ab* )
|
||||
|
||||
( equivalent to DUP2 smul2 but faster )
|
||||
@square ( a* -> aa* )
|
||||
non-negative ?{ negate } ( |a|* )
|
||||
aerate ( 00 ahi^ 00 alo^ )
|
||||
OVR2 MUL2 #03 SFT2 SWP2 ( yz* ahi* )
|
||||
DUP2 MUL2 #07ff min #40 SFT2 ( x* yz* )
|
||||
ADD2 #7fff !min ( aa* )
|
||||
|
||||
( update a device d^ given a function f: x* -> f[x]* )
|
||||
@adjust ( d^ f* -> )
|
||||
STH2 DEI2k STH2r JSR2 ROT DEO2 JMP2r
|
||||
|
||||
( return the minimum of two non-negative numbers. )
|
||||
@min ( x* y* )
|
||||
GTH2k [ JMP SWP2 ] NIP2 JMP2r
|
||||
|
||||
( convert each byte of a a short into a short )
|
||||
@aerate ( x* -> 00 xhi^ 00 xlo^ )
|
||||
SWP #0000 ROT SWP2 SWP JMP2r
|
||||
|
||||
( negate a fixed point number. doesn't work for #8000 )
|
||||
@negate ( x* -> -x* )
|
||||
DUP2k EOR2 SWP2 SUB2 JMP2r
|
||||
|
||||
( useful arithmetic operations )
|
||||
@inc2 ( n* -> n+2* ) INC2
|
||||
@inc1 ( n* -> n+1* ) INC2 JMP2r
|
||||
@sub1 ( n* -> n-1* ) #0001 SUB2 JMP2r
|
||||
@sub2 ( n* -> n-2* ) #0002 SUB2 JMP2r
|
||||
103
math-notes.txt
103
math-notes.txt
|
|
@ -1,103 +0,0 @@
|
|||
Some questions and answers about doing math in UXN
|
||||
--------------------------------------------------
|
||||
|
||||
Q: How can I handle negative integers in UXN?
|
||||
|
||||
A: Uxn doesn't have any built-in support for signed integers. However, you can
|
||||
emulate signed numbers using unsigned numbers by treating some of the values
|
||||
as having different (negative) values from their unsigned values.
|
||||
|
||||
For example, treating unsigned bytes as signed results in the following:
|
||||
|
||||
unsigned unsigned signed
|
||||
hex decimal decimal
|
||||
#00 0 0
|
||||
#01 1 1
|
||||
#02 2 2
|
||||
... ... ...
|
||||
#7e 126 126
|
||||
#7f 127 127
|
||||
#80 128 -128
|
||||
#81 129 -127
|
||||
#82 130 -126
|
||||
... ... ...
|
||||
#fd 253 -3
|
||||
#fe 254 -2
|
||||
#ff 255 -1
|
||||
|
||||
The first 128 integers (0-127) are represented the same as unsigned and signed,
|
||||
but the latter 128 are different. The basic idea here is that for values
|
||||
greater than #7f (127) we subtract 256 to get their "signed value":
|
||||
|
||||
signed(n) = if n > 127 then n else n - 256
|
||||
|
||||
It turns out that many unsigned operations "work" even when treating the values
|
||||
as signed. (In other words, you get the same result as you would have using a
|
||||
language with signed integer types.) The following arithmetic instructions work
|
||||
correctly with "signed" values:
|
||||
|
||||
EQU and NEQ
|
||||
ADD (example: `#13 #ff ADD` returns #12)
|
||||
SUB (exampel: `#02 #03 SUB` returns #ff)
|
||||
MUL (example: `#02 #ff MUL` returns #fe)
|
||||
|
||||
Other instructions will not handle "negative" integers correctly:
|
||||
|
||||
GTH and LTH:
|
||||
|
||||
1. these work correctly when comparing values with the same sign
|
||||
(example: `#80 #ff LTH` returns #01)
|
||||
|
||||
2. however, LTH will consider negative values greater than non-negative
|
||||
values, which is incorrect.
|
||||
(example: `#ff #00 GTH` returns #01, but -1 is less than 0)
|
||||
|
||||
These implementations will safely compare "signed" bytes:
|
||||
|
||||
@signed-lth ( x^ y^ -- x<y^ )
|
||||
DUP2 #8080 AND2 EQU ?&diff LTH JMP2r &diff LTH #00 NEQ JMP2r
|
||||
|
||||
@signed-gth ( x^ y^ -- x<y^ )
|
||||
DUP2 #8080 AND2 EQU ?&diff GTH JMP2r &diff GTH #00 NEQ JMP2r
|
||||
|
||||
DIV:
|
||||
|
||||
Similarly, division will not correctly handle signed values. The simplest
|
||||
way to handle this is to make both values non-negative, do unsigned
|
||||
division (i.e. DIV) and then set the correct sign at the end.
|
||||
|
||||
@abs-sign ( x^ -- abs-x^ sign^ )
|
||||
DUP #7f GTH #fe MUL INC STHk MUL STHr JMP2r
|
||||
|
||||
@signed-div ( x^ y^ -- x/y^ )
|
||||
abs-sign STH SWP abs-sign STH SWP DIV MULr STHr MUL JMP2r
|
||||
|
||||
Be careful! The smallest negative value (-128 for bytes, -32768 for shorts)
|
||||
has no corresponding positive value. This means that some operations will
|
||||
not work as expected:
|
||||
|
||||
`#80 #ff MUL` returns #80 (-128 * -1 = -128)
|
||||
`#00 #80 SUB` returns #80 (0 - (-128) = -128)
|
||||
|
||||
Also, negative and positive values will "wrap around" in the usual way when
|
||||
dealing with two's-complement representations:
|
||||
|
||||
`#7f #01 ADD` returns #80 (127 + 1 = -128)
|
||||
`#80 #01 SUB` returns #7f (-128 - 1 = 127)
|
||||
`#80 #80 ADD` returns #00 (-128 + (-128) = 0)
|
||||
|
||||
SFT:
|
||||
|
||||
The unsigned shift operator treats the sign bit like any other. This means
|
||||
shifting left will lose the sign bit (reversing the sign) and that shifting
|
||||
right will convert the sign bit into a value bit.
|
||||
|
||||
If you need a sign-aware shift you'll likely want to convert negatives to
|
||||
positive values, perform a shift, and then restore the sign. Keep in mind
|
||||
that -128 cannot be converted to a positive value, and may require special
|
||||
treatment.
|
||||
|
||||
Signed numbers will also need their own routines for decimal input and output,
|
||||
if those are required by your program.
|
||||
|
||||
Good luck!
|
||||
394
math32.tal
394
math32.tal
|
|
@ -27,7 +27,7 @@
|
|||
( div32 x** y** -> q** x / y )
|
||||
( mod32 x** y** -> r** x % y )
|
||||
( divmod32 x** y** -> q** r** x / y, x % y )
|
||||
( gcd32 x** y** -> z** gcd[x, y] )
|
||||
( gcd32 x** y** -> z** gcd(x, y) )
|
||||
( negate32 x** -> z** -x )
|
||||
( lshift32 x** n^ -> z** x<<n )
|
||||
( rshift32 x** n^ -> z** x>>n )
|
||||
|
|
@ -43,31 +43,64 @@
|
|||
( gt32 x** y** -> bool^ x > y )
|
||||
( lteq32 x** y** -> bool^ x <= y )
|
||||
( gteq32 x** y** -> bool^ x >= y )
|
||||
( bitcount8 x^ -> bool^ floor[log2[x]]+1 )
|
||||
( bitcount16 x* -> bool^ floor[log2[x]]+1 )
|
||||
( bitcount32 x** -> bool^ floor[log2[x]]+1 )
|
||||
( bitcount8 x^ -> bool^ floor(log2(x))+1 )
|
||||
( bitcount16 x* -> bool^ floor(log2(x))+1 )
|
||||
( bitcount32 x** -> bool^ floor(log2(x))+1 )
|
||||
( )
|
||||
( bitcount: number of bits needed to represent the number. )
|
||||
( this is equivalent to floor[log2[x]] + 1 )
|
||||
( In addition to the code this file uses 44 bytes of registers )
|
||||
( to store temporary state: )
|
||||
( )
|
||||
( - shared memory, 16 bytes )
|
||||
( - mul32 memory, 12 bytes )
|
||||
( - _divmod32 memory, 16 bytes )
|
||||
|
||||
( bitcount: number of bits needed to represent number )
|
||||
( equivalent to floor[log2[x]] + 1 )
|
||||
|
||||
@bitcount8 ( x^ -> n^ )
|
||||
LITr 00 &loop DUP ?{ POP STHr JMP2r } #01 SFT INCr !&loop
|
||||
#00 SWP ( n x )
|
||||
&loop
|
||||
DUP #00 EQU ( n x x=0 )
|
||||
,&done JCN ( n x )
|
||||
#01 SFT ( n x>>1 )
|
||||
SWP INC SWP ( n+1 x>>1 )
|
||||
,&loop JMP
|
||||
&done
|
||||
POP ( n )
|
||||
JMP2r
|
||||
|
||||
@bitcount16 ( x* -> n^ )
|
||||
LITr 00 &loop ORAk ?{ POP2 STHr JMP2r } #01 SFT2 INCr !&loop
|
||||
SWP ( xlo xhi )
|
||||
;bitcount8 JSR2 ( xlo nhi )
|
||||
DUP #00 NEQ ( xlo nhi nhi!=0 )
|
||||
,&hi-set JCN ( xlo nhi )
|
||||
SWP ;bitcount8 JSR2 ADD ( nhi+nlo )
|
||||
JMP2r
|
||||
&hi-set
|
||||
NIP #08 ADD ( nhi+8 )
|
||||
JMP2r
|
||||
|
||||
@bitcount32 ( x** -> n^ )
|
||||
SWP2 bitcount16 DUP ?{ POP !bitcount16 } #10 NIP2 ADD JMP2r
|
||||
SWP2 ( xlo* xhi* )
|
||||
;bitcount16 JSR2 ( xlo* nhi )
|
||||
DUP #00 NEQ ( xlo* nhi nhi!=0 )
|
||||
,&hi-set JCN ( xlo* nhi )
|
||||
ROT ROT ;bitcount16 JSR2 ADD JMP2r ( nhi+nlo )
|
||||
&hi-set
|
||||
ROT ROT POP2 #10 ADD ( nhi+16 )
|
||||
JMP2r
|
||||
|
||||
( -- equality )
|
||||
( equality )
|
||||
|
||||
( x == y )
|
||||
@eq32 ( xhi* xlo* yhi* ylo* -> bool^ )
|
||||
ROT2 EQU2 STH EQU2 STHr AND JMP2r
|
||||
ROT2 EQU2 STH
|
||||
EQU2 STHr AND JMP2r
|
||||
|
||||
( x != y )
|
||||
@ne32 ( xhi* xlo* yhi* ylo* -> bool^ )
|
||||
ROT2 NEQ2 STH NEQ2 STHr ORA JMP2r
|
||||
ROT2 NEQ2 STH
|
||||
NEQ2 STHr ORA JMP2r
|
||||
|
||||
( x == 0 )
|
||||
@is-zero32 ( x** -> bool^ )
|
||||
|
|
@ -77,28 +110,44 @@
|
|||
@non-zero32 ( x** -> bool^ )
|
||||
ORA2 ORA JMP2r
|
||||
|
||||
( -- comparisons )
|
||||
( comparisons )
|
||||
|
||||
( x < y )
|
||||
@lt32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 LTH2 ?{ LTH2 JMP2r } GTH2 #00 EQU JMP2r
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
LTH2 ,<-lo JCN ( xhi yhi )
|
||||
LTH2 JMP2r
|
||||
<-lo
|
||||
GTH2 #00 EQU JMP2r
|
||||
|
||||
( x <= y )
|
||||
@lteq32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 GTH2 ?{ GTH2 #00 EQU JMP2r } LTH2 JMP2r
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
GTH2 ,>-lo JCN ( xhi yhi )
|
||||
GTH2 #00 EQU JMP2r
|
||||
>-lo
|
||||
LTH2 JMP2r
|
||||
|
||||
( x > y )
|
||||
@gt32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 GTH2 ?{ GTH2 JMP2r } LTH2 #00 EQU JMP2r
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
GTH2 ,>-lo JCN ( xhi yhi )
|
||||
GTH2 JMP2r
|
||||
>-lo
|
||||
LTH2 #00 EQU JMP2r
|
||||
|
||||
( x > y )
|
||||
@gteq32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 LTH2 ?{ LTH2 #00 EQU JMP2r } GTH2 JMP2r
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
LTH2 ,<-lo JCN ( xhi yhi )
|
||||
LTH2 #00 EQU JMP2r
|
||||
<-lo
|
||||
GTH2 JMP2r
|
||||
|
||||
( -- bitwise operations )
|
||||
( bitwise operations )
|
||||
|
||||
( x & y )
|
||||
@and32 ( xhi* xlo* yhi* ylo* -> xhi&yhi* xlo&ylo* )
|
||||
@and32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
|
||||
ROT2 AND2 STH2 AND2 STH2r JMP2r
|
||||
|
||||
( x | y )
|
||||
|
|
@ -106,178 +155,271 @@
|
|||
ROT2 ORA2 STH2 ORA2 STH2r JMP2r
|
||||
|
||||
( x ^ y )
|
||||
@xor32 ( xhi* xlo* yhi* ylo* -> xhi^yhi* xlo^ylo* )
|
||||
@xor32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
|
||||
ROT2 EOR2 STH2 EOR2 STH2r JMP2r
|
||||
|
||||
( ~x )
|
||||
@complement32 ( x** -> ~xhi* ~xlo* )
|
||||
@complement32 ( x** -> ~x** )
|
||||
SWP2 #ffff EOR2 SWP2 #ffff EOR2 JMP2r
|
||||
|
||||
( -- bit-shifting )
|
||||
( temporary registers )
|
||||
( shared by most operations, except mul32 and div32 )
|
||||
@m32 [ &x0 $1 &x1 $1 &x2 $1 &x3 $1
|
||||
&y0 $1 &y1 $1 &y2 $1 &y3 $1
|
||||
&z0 $1 &z1 $1 &z2 $1 &z3 $1
|
||||
&w0 $1 &w1 $1 &w2 $2 ]
|
||||
|
||||
( bit shifting )
|
||||
|
||||
( x >> n )
|
||||
@rshift32 ( x** n^ -> x>>n )
|
||||
DUP #08 LTH ?shift32-0 ( x n )
|
||||
DUP #10 LTH ?rshift32-1 ( x n )
|
||||
DUP #18 LTH ?rshift32-2 ( x n )
|
||||
!rshift32-3 ( x n )
|
||||
@rshift32 ( x** n^ -> x<<n )
|
||||
DUP #08 LTH ;rshift32-0 JCN2 ( x n )
|
||||
DUP #10 LTH ;rshift32-1 JCN2 ( x n )
|
||||
DUP #18 LTH ;rshift32-2 JCN2 ( x n )
|
||||
;rshift32-3 JMP2 ( x n )
|
||||
|
||||
( shift by 0-7 bits; used by both lshift and rshift )
|
||||
@shift32-0 ( x** n^ -> x>>n )
|
||||
STH DUP2 STHkr SFT2 ,&z2 STR2
|
||||
POP DUP2 STHkr SFT2 ,&z2 LDR ORA ,&z2 STR ,&z1 STR
|
||||
POP STHr SFT2 ,&z1 LDR ORA ,&z1 STR
|
||||
LIT [ &z1 $1 ] LIT2 [ &z2 $2 ] JMP2r
|
||||
( shift right by 0-7 bits )
|
||||
@rshift32-0 ( x** n^ -> x<<n )
|
||||
STHk SFT ;m32/z3 STA ( write z3 )
|
||||
#00 STHkr SFT2 #00 ;m32/z3 LDA ORA2 ;m32/z2 STA2 ( write z2,z3 )
|
||||
#00 STHkr SFT2 #00 ;m32/z2 LDA ORA2 ;m32/z1 STA2 ( write z1,z2 )
|
||||
#00 STHr SFT2 #00 ;m32/z1 LDA ORA2 ( compute z0,z1 )
|
||||
;m32/z2 LDA2
|
||||
JMP2r
|
||||
|
||||
( shift right by 8-15 bits )
|
||||
@rshift32-1 ( x** n^ -> x>>n )
|
||||
#08 SUB STH ( stash [n>>8] )
|
||||
POP DUP2 STHkr SFT2 ,&z2 STR2
|
||||
POP STHr SFT2 ,&z2 LDR ORA ,&z2 STR
|
||||
#00 SWP LIT2 [ &z2 $2 ] JMP2r
|
||||
@rshift32-1 ( x** n^ -> x<<n )
|
||||
#08 SUB STH POP
|
||||
STHkr SFT ;m32/z3 STA ( write z3 )
|
||||
#00 STHkr SFT2 #00 ;m32/z3 LDA ORA2 ;m32/z2 STA2 ( write z2,z3 )
|
||||
#00 STHr SFT2 #00 ;m32/z2 LDA ORA2 ( compute z1,z2 )
|
||||
#00 ROT ROT ;m32/z3 LDA
|
||||
JMP2r
|
||||
|
||||
( shift right by 16-23 bits )
|
||||
@rshift32-2 ( x** n^ -> x>>n )
|
||||
#10 SUB STH ( stash [n>>16] )
|
||||
POP2 STHr SFT2 #0000 SWP2 JMP2r
|
||||
@rshift32-2 ( x** n^ -> x<<n )
|
||||
#10 SUB STH POP2
|
||||
STHkr SFT ;m32/z3 STA ( write z3 )
|
||||
#00 STHr SFT2 #00 ;m32/z3 LDA ORA2 ( compute z2,z3 )
|
||||
#0000 SWP2
|
||||
JMP2r
|
||||
|
||||
( shift right by 16-23 bits )
|
||||
@rshift32-3 ( x** n^ -> x>>n )
|
||||
#18 SUB STH ( stash [n>>24] )
|
||||
POP2 POP STH SWPr SFTr #00 #0000 STHr JMP2r
|
||||
@rshift32-3 ( x** n^ -> x<<n )
|
||||
#18 SUB STH POP2 POP ( x0 )
|
||||
#00 SWP #0000 SWP2 ( 00 00 00 x0 )
|
||||
STHr SFT
|
||||
JMP2r
|
||||
|
||||
( x << n )
|
||||
@lshift32 ( x** n^ -> x<<n )
|
||||
DUP #08 LTH ?lshift32-0 ( x n )
|
||||
DUP #10 LTH ?lshift32-1 ( x n )
|
||||
DUP #18 LTH ?lshift32-2 ( x n )
|
||||
!lshift32-3 ( x n )
|
||||
DUP #08 LTH ;lshift32-0 JCN2 ( x n )
|
||||
DUP #10 LTH ;lshift32-1 JCN2 ( x n )
|
||||
DUP #18 LTH ;lshift32-2 JCN2 ( x n )
|
||||
;lshift32-3 JMP2 ( x n )
|
||||
|
||||
( shift left by 0-7 bits )
|
||||
@lshift32-0 ( x** n^ -> x<<n )
|
||||
#40 SFT !shift32-0
|
||||
#40 SFT STH ( stash n<<4 )
|
||||
#00 SWP STHkr SFT2 ;m32/z2 STA2 ( store z2,z3 )
|
||||
#00 SWP STHkr SFT2 #00 ;m32/z2 LDA ORA2 ;m32/z1 STA2 ( store z1,z2 )
|
||||
#00 SWP STHkr SFT2 #00 ;m32/z1 LDA ORA2 ;m32/z0 STA2 ( store z0,z1 )
|
||||
STHr SFT ;m32/z0 LDA ORA ( calculate z0 )
|
||||
;m32/z1 LDA ;m32/z2 LDA2
|
||||
JMP2r
|
||||
|
||||
( shift left by 8-15 bits )
|
||||
@lshift32-1 ( x** n^ -> x<<n )
|
||||
#08 SUB #40 SFT STH ( stash [n-8]<<4 )
|
||||
DUP2 STHkr SFT2 ,&z1 STR2
|
||||
POP STHr SFT2 ,&z1 LDR ORA ,&z1 STR
|
||||
NIP LIT2 [ &z1 $1 &z2 $1 ] #00 JMP2r
|
||||
#00 SWP STHkr SFT2 ;m32/z1 STA2 ( store z1,z2 )
|
||||
#00 SWP STHkr SFT2 #00 ;m32/z1 LDA ORA2 ;m32/z0 STA2 ( store z0,z1 )
|
||||
STHr SFT ;m32/z0 LDA ORA ( calculate z0 )
|
||||
NIP ( x0 unused )
|
||||
;m32/z1 LDA2 #00
|
||||
JMP2r
|
||||
|
||||
( shift left by 16-23 bits )
|
||||
@lshift32-2 ( x** n^ -> x<<n )
|
||||
#10 SUB #40 SFT STH ( stash [n-16]<<4 )
|
||||
NIP2 STHr SFT2 #0000 JMP2r
|
||||
#00 SWP STHkr SFT2 ;m32/z0 STA2 ( store z0,z1 )
|
||||
STHr SFT ;m32/z0 LDA ORA ( calculate z0 )
|
||||
STH POP2 STHr
|
||||
;m32/z1 LDA #0000
|
||||
JMP2r
|
||||
|
||||
( shift left by 24-31 bits )
|
||||
@lshift32-3 ( x** n^ -> x<<n )
|
||||
#18 SUB #40 SFT ( stash [n-24]<<4 )
|
||||
SFT NIP2 NIP #0000 #00 JMP2r
|
||||
#18 SUB #40 SFT ( x0 x1 x2 x3 r=[n-24]<<4 )
|
||||
SFT ( x0 x1 x2 x3<<r )
|
||||
NIP2 NIP #0000 #00
|
||||
JMP2r
|
||||
|
||||
( -- arithmetic )
|
||||
( arithmetic )
|
||||
|
||||
( x + y )
|
||||
@add32 ( xhi* xlo* yhi* ylo* -> zhi* zlo* )
|
||||
ROT2 STH2k ADD2 STH2k ROT2 ROT2 GTH2r #00 STHr ADD2 ADD2 SWP2 JMP2r
|
||||
;m32/y2 STA2 ;m32/y0 STA2 ( save ylo, yhi )
|
||||
;m32/x2 STA2 ;m32/x0 STA2 ( save xlo, xhi )
|
||||
#0000 DUP2 ;m32/z0 STA2 ;m32/z2 STA2 ( reset zhi, zlo )
|
||||
|
||||
( x3 + y3 => z2z3 )
|
||||
#00 ;m32/x3 LDA #00 ;m32/y3 LDA ADD2 ;m32/z2 STA2
|
||||
|
||||
( x2 + y2 + z2 => z1z2 )
|
||||
#00 ;m32/x2 LDA ;m32/z1 LDA2 ADD2 ;m32/z1 STA2
|
||||
#00 ;m32/y2 LDA ;m32/z1 LDA2 ADD2 ;m32/z1 STA2
|
||||
|
||||
( x1 + y1 + z1 => z0z1 )
|
||||
#00 ;m32/x1 LDA ;m32/z0 LDA2 ADD2 ;m32/z0 STA2
|
||||
#00 ;m32/y1 LDA ;m32/z0 LDA2 ADD2 ;m32/z0 STA2
|
||||
|
||||
( x0 + y0 + z0 => z0 )
|
||||
;m32/x0 LDA ;m32/z0 LDA ADD ;m32/z0 STA
|
||||
;m32/y0 LDA ;m32/z0 LDA ADD ;m32/z0 STA
|
||||
|
||||
( load zhi,zlo )
|
||||
;m32/z0 LDA2 ;m32/z2 LDA2
|
||||
JMP2r
|
||||
|
||||
( -x )
|
||||
@negate32 ( x** -> -x** )
|
||||
complement32 INC2 ORAk ?{ SWP2 INC2 SWP2 } JMP2r
|
||||
;complement32 JSR2 ( ~x** )
|
||||
INC2 ( ~xhi -xlo )
|
||||
ORAk ( ~xhi -xlo non-zero? )
|
||||
,&done JCN ( xlo non-zero => don't inc hi )
|
||||
SWP2 INC2 SWP2 ( -xhi -xlo )
|
||||
&done
|
||||
JMP2r
|
||||
|
||||
( x - y )
|
||||
@sub32 ( x** y** -> z** )
|
||||
ROT2 STH2k SWP2 SUB2 STH2k ROT2 ROT2 LTH2r #00 STHr ADD2 SUB2 SWP2 JMP2r
|
||||
;negate32 JSR2 ;add32 JMP2
|
||||
|
||||
( 16-bit multiplication )
|
||||
@mul16 ( x* y* -> z** )
|
||||
,&y1 STR ,&y0 STR ( save ylo, yhi )
|
||||
,&x1 STR ,&x0 STR ( save xlo, xhi )
|
||||
#0000 ,&z1 STR ,&w0 STR ( reset z1 and w0 )
|
||||
;m32/y1 STA ;m32/y0 STA ( save ylo, yhi )
|
||||
;m32/x1 STA ;m32/x0 STA ( save xlo, xhi )
|
||||
#0000 #00 ;m32/z1 STA2 ;m32/z3 STA ( reset z1,z2,z3 )
|
||||
#0000 #00 ;m32/w0 STA2 ;m32/w2 STA ( reset w0,w1,w2 )
|
||||
|
||||
( x1 * y1 => z1z2 )
|
||||
LIT2 00 [ &x1 $1 ] LIT2 00 [ &y1 $1 ] MUL2 ,&z3 STR ,&z2 STR
|
||||
#00 ;m32/x1 LDA #00 ;m32/y1 LDA MUL2 ;m32/z2 STA2
|
||||
|
||||
( x0 * y1 => z0z1 )
|
||||
#00 ,&x0 LDR #00 ,&y1 LDR MUL2 ,&z1 LDR2 ADD2 ,&z1 STR2
|
||||
#00 ;m32/x0 LDA #00 ;m32/y1 LDA MUL2 ;m32/z1 LDA2 ADD2 ;m32/z1 STA2
|
||||
|
||||
( x1 * y0 => w1w2 )
|
||||
#00 ,&x1 LDR #00 ,&y0 LDR MUL2 ,&w2 STR ,&w1 STR
|
||||
#00 ;m32/x1 LDA #00 ;m32/y0 LDA MUL2 ;m32/w1 STA2
|
||||
|
||||
( x0 * y0 => w0w1 )
|
||||
LIT2 00 [ &x0 $1 ] LIT2 00 [ &y0 $1 ] MUL2 ,&w0 LDR2 ADD2 ,&w0 STR2
|
||||
#00 ;m32/x0 LDA #00 ;m32/y0 LDA MUL2 ;m32/w0 LDA2 ADD2 ;m32/w0 STA2
|
||||
|
||||
( add z and a<<8 )
|
||||
#00 LIT2 [ &z1 $1 &z2 $1 ] LIT [ &z3 $1 ]
|
||||
LIT2 [ &w0 $1 &w1 $1 ] LIT [ &w2 $1 ] #00
|
||||
!add32
|
||||
#00 ;m32/z1 LDA2 ;m32/z3 LDA
|
||||
;m32/w0 LDA2 ;m32/w2 LDA #00
|
||||
;add32 JMP2
|
||||
|
||||
( x * y )
|
||||
@mul32 ( x** y** -> z** )
|
||||
ROT2k ( x0* x1* y0* y1* y0* y1* x1* )
|
||||
mul16 ,&z1 STR2 ,&z0 STR2 POP2 ( x0* x1* y0* y1* ; sum = [x1*y1] )
|
||||
STH2 ROT2 STH2 ( x1* y0* [y1* x0*] )
|
||||
MUL2r MUL2 STH2r ADD2 ( x1*y0+y1*x0* )
|
||||
,&y1 STR2 ,&y0 STR2 ( save ylo, yhi )
|
||||
,&x1 STR2 ,&x0 STR2 ( save xlo, xhi )
|
||||
,&y1 LDR2 ,&x1 LDR2 ;mul16 JSR2 ( [x1*y1] )
|
||||
,&z1 STR2 ,&z0 STR2 ( sum = x1*y1, save zlo, zhi )
|
||||
,&y1 LDR2 ,&x0 LDR2 MUL2 ( [x0*y1]<<16 )
|
||||
,&y0 LDR2 ,&x1 LDR2 MUL2 ( [x1*y0]<<16 )
|
||||
( [x0*y0]<<32 will completely overflow )
|
||||
LIT2 [ &z0 $2 ] ADD2 ( sum += [x0*y1+x1*y0]<<16 )
|
||||
LIT2 [ &z1 $2 ] JMP2r
|
||||
ADD2 ,&z0 LDR2 ADD2 ( sum += x0*y1<<16 + x1*y0<<16 )
|
||||
,&z1 LDR2
|
||||
JMP2r
|
||||
[ &x0 $2 &x1 $2
|
||||
&y0 $2 &y1 $2
|
||||
&z0 $2 &z1 $2 ]
|
||||
|
||||
( x / y )
|
||||
@div32 ( x** y** -> q** )
|
||||
z_divmod32 ;z_divmod32/quo0 LDA2 ;z_divmod32/quo1 LDA2 JMP2r
|
||||
|
||||
( x % y )
|
||||
@mod32 ( x** y** -> r** )
|
||||
z_divmod32 ;z_divmod32/rem0 LDA2 ;z_divmod32/rem1 LDA2 JMP2r
|
||||
|
||||
( x / y, x % y )
|
||||
@divmod32 ( x** y** -> q** r** )
|
||||
z_divmod32
|
||||
;z_divmod32/quo0 LDA2 ;z_divmod32/quo1 LDA2
|
||||
;z_divmod32/rem0 LDA2 ;z_divmod32/rem1 LDA2
|
||||
;_divmod32 JSR2
|
||||
;_divmod32/quo0 LDA2 ;_divmod32/quo1 LDA2
|
||||
JMP2r
|
||||
|
||||
( private: calculate and store x / y and x % y )
|
||||
@z_divmod32 ( x** y** -> )
|
||||
( ; store y and x for repeated use )
|
||||
#0000 DUP2 ,&quo0 STR2 ,&quo1 STR2 ( x** y** ; quo<-0 )
|
||||
STH2k ,&div1 STR2 STH2k ,&div0 STR2 ( x** [ylo* yhi*] ; div<-y )
|
||||
OVR2 OVR2 ,&rem1 STR2 ,&rem0 STR2 ( x** [ylo* yhi*] ; rem<-x )
|
||||
OVR2 OVR2 STH2r STH2r ( x** x** y** )
|
||||
OVR2 OVR2 STH2 STH2 ( x** x** y** [ylo* yhi*] )
|
||||
gteq32 ?{ POP2 POP2 POP2r POP2r JMP2r } ( x** [ylo* yhi*] ; return if x < y )
|
||||
@mod32 ( x** y** -> r** )
|
||||
;_divmod32 JSR2
|
||||
;_divmod32/rem0 LDA2 ;_divmod32/rem1 LDA2
|
||||
JMP2r
|
||||
|
||||
( ; bitcount[x] - bitcount[y] determines largest multiple of y to try )
|
||||
bitcount32 STH2r STH2r bitcount32 SUB ( shift=rbits-dits^ )
|
||||
#00 DUP2 ( shift^ 0^ shift^ 0^ )
|
||||
#0000 INC2k ROT2 POP ( shift^ 0^ 0* 1* shift^ )
|
||||
lshift32 ,&cur1 STR2 ,&cur0 STR2 ( shift^ 0^ ; cur<-1<<shift )
|
||||
,&div0 LDR2 ,&div1 LDR2 ROT2 POP ( div** shift^ )
|
||||
lshift32 ,&div1 STR2 ,&div0 STR2 ( ; div<-div<<shift )
|
||||
@divmod32 ( x** y** -> q** r** )
|
||||
;_divmod32 JSR2
|
||||
;_divmod32/quo0 LDA2 ;_divmod32/quo1 LDA2
|
||||
;_divmod32/rem0 LDA2 ;_divmod32/rem1 LDA2
|
||||
JMP2r
|
||||
|
||||
( calculate and store x / y and x % y )
|
||||
@_divmod32 ( x** y** -> )
|
||||
( store y and x for repeated use )
|
||||
,&div1 STR2 ,&div0 STR2 ( y -> div )
|
||||
,&rem1 STR2 ,&rem0 STR2 ( x -> rem )
|
||||
|
||||
( if x < y then the answer is 0 )
|
||||
,&rem0 LDR2 ,&rem1 LDR2
|
||||
,&div0 LDR2 ,&div1 LDR2
|
||||
;lt32 JSR2 ,&is-zero JCN ,¬-zero JMP
|
||||
&is-zero
|
||||
#0000 ,&quo0 STR2 #0000 ,&quo1 STR2 JMP2r
|
||||
|
||||
( x >= y so the answer is >= 1 )
|
||||
¬-zero
|
||||
#0000 ,&quo0 STR2 #0000 ,&quo1 STR2 ( 0 -> quo )
|
||||
|
||||
( bitcount[x] - bitcount[y] determines the largest multiple of y to try )
|
||||
,&rem0 LDR2 ,&rem1 LDR2 ;bitcount32 JSR2 ( rbits^ )
|
||||
,&div0 LDR2 ,&div1 LDR2 ;bitcount32 JSR2 ( rbits^ dbits^ )
|
||||
SUB ( shift=rbits-dits )
|
||||
#00 DUP2 ( shift 0 shift 0 )
|
||||
|
||||
( 1<<shift -> cur )
|
||||
#0000 INC2k ROT2 POP
|
||||
;lshift32 JSR2 ,&cur1 STR2 ,&cur0 STR2
|
||||
|
||||
( div<<shift -> div )
|
||||
,&div0 LDR2 ,&div1 LDR2 ROT2 POP
|
||||
;lshift32 JSR2 ,&div1 STR2 ,&div0 STR2
|
||||
|
||||
,&loop JMP
|
||||
|
||||
[ &div0 $2 &div1 $2
|
||||
&rem0 $2 &rem1 $2
|
||||
&quo0 $2 &quo1 $2
|
||||
&cur0 $2 &cur1 $2 ]
|
||||
|
||||
&loop
|
||||
( ; if rem >= cur [current divisor], we can subtract it and add to quotient )
|
||||
( ; otherwise, skip that iteration and reduce cur. )
|
||||
LIT2 [ &rem0 $2 ] LIT2 [ &rem1 $2 ] ,&div0 LDR2 ,&div1 LDR2
|
||||
lt32 ?{
|
||||
( ; since rem >= div, we have found a multiple of y that divides x )
|
||||
,&rem0 LDR2 ,&rem1 LDR2 ( rem** )
|
||||
LIT2 [ &div0 $2 ] LIT2 [ &div1 $2 ] ( rem** div** )
|
||||
sub32 ,&rem1 STR2 ,&rem0 STR2 ( ; rem<-rem-div** )
|
||||
LIT2 [ &quo0 $2 ] LIT2 [ &quo1 $2 ] ( quo** )
|
||||
LIT2 [ &cur0 $2 ] LIT2 [ &cur1 $2 ] ( quo** cur** )
|
||||
add32 ,&quo1 STR2 ,&quo0 STR2 ( ; quo<-quo+cur** )
|
||||
}
|
||||
,&div0 LDR2 ,&div1 LDR2 #01 rshift32 ( div>>1** )
|
||||
,&div1 STR2 ,&div0 STR2 ( ; div<-div>>1 )
|
||||
,&cur0 LDR2 ,&cur1 LDR2 #01 rshift32 ( cur>>1** )
|
||||
OVR2 OVR2 ,&cur1 STR2 ,&cur0 STR2 ( cur>>1** ; cur<-cur>>1 )
|
||||
non-zero32 ?&loop JMP2r ( ; loop if cur>0, else we're done )
|
||||
( if rem >= the current divisor, we can subtract it and add to quotient )
|
||||
,&rem0 LDR2 ,&rem1 LDR2 ,&div0 LDR2 ,&div1 LDR2 ;lt32 JSR2 ( is rem < div? )
|
||||
,&rem-lt JCN ( if rem < div skip this iteration )
|
||||
|
||||
( since rem >= div, we have found a multiple of y that divides x )
|
||||
,&rem0 LDR2 ,&rem1 LDR2 ,&div0 LDR2 ,&div1 LDR2 ;sub32 JSR2 ,&rem1 STR2 ,&rem0 STR2 ( rem -= div )
|
||||
,&quo0 LDR2 ,&quo1 LDR2 ,&cur0 LDR2 ,&cur1 LDR2 ;add32 JSR2 ,&quo1 STR2 ,&quo0 STR2 ( quo += cur )
|
||||
|
||||
&rem-lt
|
||||
,&div0 LDR2 ,&div1 LDR2 #01 ;rshift32 JSR2 ,&div1 STR2 ,&div0 STR2 ( div >>= 1 )
|
||||
,&cur0 LDR2 ,&cur1 LDR2 #01 ;rshift32 JSR2 ,&cur1 STR2 ,&cur0 STR2 ( cur >>= 1 )
|
||||
,&cur0 LDR2 ,&cur1 LDR2 ;non-zero32 JSR2 ,&loop JCN ( if cur>0, loop. else we're done )
|
||||
JMP2r
|
||||
|
||||
( greatest common divisor - euclidean algorithm )
|
||||
@gcd32 ( x** y** -> z** )
|
||||
&loop OVR2 OVR2 is-zero32 ?{ ( x** y** )
|
||||
OVR2 OVR2 STH2 STH2 ( x** y** [y**] )
|
||||
mod32 ( r=x%y** [y**] )
|
||||
STH2r ROT2 ROT2 ( yhi* rhi* rlo* [ylo*] )
|
||||
STH2r ROT2 ROT2 !&loop ( y** r** )
|
||||
} POP2 POP2 JMP2r ( z** )
|
||||
&loop ( x y )
|
||||
OVR2 OVR2 ( x y y )
|
||||
;is-zero32 JSR2 ( x y y=0? )
|
||||
,&done JCN ( x y )
|
||||
OVR2 OVR2 ( x y y )
|
||||
STH2 STH2 ( x y [y] )
|
||||
;mod32 JSR2 ( r=x%y [y] )
|
||||
STH2r ( rhi rlo yhi [ylo] )
|
||||
ROT2 ( rlo yhi rhi [ylo] )
|
||||
ROT2 ( yhi rhi rlo [ylo] )
|
||||
STH2r ( yhi rhi rlo ylo )
|
||||
ROT2 ( yhi rlo ylo rhi )
|
||||
ROT2 ( yhi ylo rhi rlo )
|
||||
,&loop JMP
|
||||
&done
|
||||
POP2 POP2 ( x )
|
||||
JMP2r
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
#!/bin/sh
|
||||
|
||||
for STEM in audio audio-v2; do
|
||||
cp $STEM.md $STEM.txt
|
||||
done
|
||||
cp audio.md audio.txt
|
||||
|
||||
for NAME in about.txt asma.rom math32.tal test-math32.tal test-math32.py \
|
||||
primes32.tal regex.tal repl-regex.tal test-regex.tal grep.tal \
|
||||
|
|
@ -17,8 +15,6 @@ for NAME in about.txt asma.rom math32.tal test-math32.tal test-math32.py \
|
|||
deck.tal cards.tal card-sprites.tal mask-sprites.tal \
|
||||
testing.tal type-abc.tal tar.tal \
|
||||
audio.md audio.txt synthdemo.tal \
|
||||
audio-v2.md audio-v2.txt \
|
||||
math-notes.txt \
|
||||
; do
|
||||
echo "-> $NAME"
|
||||
cp $NAME /var/www/plastic-idolatry.com/html/erik/nxu
|
||||
|
|
|
|||
69
primes32.tal
69
primes32.tal
|
|
@ -26,15 +26,18 @@
|
|||
( Smaller primes also run fairly quickly: 0x17b5d was )
|
||||
( determined to be prime in 0.02 seconds. )
|
||||
|
||||
%SP { #2018 DEO }
|
||||
%NL { #0a18 DEO }
|
||||
%EXIT { #ff0f DEO BRK }
|
||||
%DUP4 { OVR2 OVR2 }
|
||||
%POP4 { POP2 POP2 }
|
||||
|
||||
|0100
|
||||
#ffff #fffb ( n** ; number to check )
|
||||
DUP4 is-prime32 ( n** is-prime^ ; test for primality )
|
||||
STH emit/long #2018 DEO ( [is-prime^] ; emit n )
|
||||
STHr emit/byte #0a18 DEO ( ; emit boolean )
|
||||
#ff0f DEO BRK ( ; exit )
|
||||
( number to check comes first )
|
||||
#ffff #fffb
|
||||
DUP4 ;is-prime32 JSR2 ( test for primality )
|
||||
STH ;emit/long JSR2 SP STHr ;emit/byte JSR2 NL
|
||||
EXIT
|
||||
|
||||
( include 32-bit math library )
|
||||
~math32.tal
|
||||
|
|
@ -42,29 +45,37 @@
|
|||
( return 01 if x is a prime number, else 00 )
|
||||
( works for x >= 2 )
|
||||
@is-prime32 ( x** -> bool^ )
|
||||
DUP4 ,&x1 STR2 ,&x0 STR2 ( x** ; store x )
|
||||
DUP4 #0000 #0002 ne32 ?{ POP4 #01 JMP2r } ( x** ; return if 2 )
|
||||
DUP #01 AND ?{ POP4 #00 JMP2r } ( x** ; return if even )
|
||||
DUP4 #0000 #0003 ne32 ?{ POP4 #01 JMP2r } ( x** ; return if 3 )
|
||||
#0002 ,&inc STR2 ( x** ; inc<-2 )
|
||||
#0000 #0005 DUP4 ,&i1 STR2 ,&i0 STR2 ( x** i** ; i<-5 )
|
||||
&loop ( x** i** )
|
||||
LIT2 [ &x0 $2 ] LIT2 [ &x1 $2 ] ( x** i** x** )
|
||||
LIT2 [ &i0 $2 ] LIT2 [ &i1 $2 ] ( x** i** x** i** )
|
||||
DUP4 mul32 lt32 ( x** i** x<ii^ )
|
||||
STH DUP2 #ffff EQU2 STHr ORA ( x** i** x<ii|i=0xffff^ )
|
||||
?{ ( x** i** )
|
||||
,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x** i** x** i** )
|
||||
mod32 is-zero32 ( x** i** x//i^ )
|
||||
STH #0000 ,&inc LDR2 add32 ( x** i+2** [x//i^] )
|
||||
LIT2 [ &inc $2 ] #0006 EOR2 ,&inc STR2 ( x** i+2** [x//i^] ; inc<-inc^6 )
|
||||
DUP4 ,&i1 STR2 ,&i0 STR2 STHr ( x** i+2** x//i^ ; i<-i+2 )
|
||||
?{ !&loop } ( x** i+2** ; if x<j*j, loop )
|
||||
POP4 POP4 #00 JMP2r ( 0^ ; since i divides x, not prime )
|
||||
} POP4 POP4 #01 JMP2r ( 1^ ; didn't find divisors, prime )
|
||||
,&x1 STR2 ,&x0 STR2 ,&x0 LDR2 ,&x1 LDR2 ( store and reload x )
|
||||
DUP4 #0000 LIT2 &two 0002 ;ne32 JSR2 ( x is 2? )
|
||||
,¬-two JCN POP4 #01 JMP2r ( 2 is prime )
|
||||
¬-two DUP #01 AND ( x x&1 )
|
||||
,¬-even JCN POP4 #00 JMP2r ( x is even: not prime )
|
||||
¬-even DUP4 #0000 #0003 ;ne32 JSR2 ( x is 3? )
|
||||
,¬-three JCN POP4 #01 JMP2r ( 3 is prime )
|
||||
¬-three #0000 ,&i0 STR2 #0005 ,&i1 STR2 ( x i<-5 )
|
||||
,&two LDR2 ,&inc STR2
|
||||
,&i0 LDR2 ,&i1 LDR2 ( load our candidate, i )
|
||||
,&loop JMP ( jump over register data to loop label )
|
||||
[ &i0 0000 &i1 0000 &x0 0000 &x1 0000 &inc 0000 &mask 0006 ] ( registers )
|
||||
&loop ( x i )
|
||||
,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x i x i )
|
||||
DUP4 ;mul32 JSR2 ;lt32 JSR2 ( x i x<i*i )
|
||||
STH DUP2 #ffff EQU2 STHr ORA ( x i x<i*i||i=0xffff )
|
||||
,&finished JCN ( x i )
|
||||
,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x i x i )
|
||||
;mod32 JSR2 ;is-zero32 JSR2 ( x i x//i^ )
|
||||
STH #0000 ,&inc LDR2 ;add32 JSR2 ( x i+2 )
|
||||
,&inc LDR2 ,&mask LDR2 EOR2 ,&inc STR2 ( inc<-inc^6 )
|
||||
,&i1 STR2 ,&i0 STR2 ,&i0 LDR2 ,&i1 LDR2 ( write i+2 to register )
|
||||
STHr ( x i+2 x//i^ )
|
||||
,&i-divides-x JCN ( x j )
|
||||
,&loop JMP ( if x<j*j, loop )
|
||||
&i-divides-x POP4 POP4 #00 JMP2r ( since i divides x, not prime )
|
||||
&finished POP4 POP4 #01 JMP2r ( didn't find divisors, prime )
|
||||
|
||||
@emit
|
||||
&long SWP2 emit/short
|
||||
&short SWP emit/byte
|
||||
&byte DUP #04 SFT emit/char
|
||||
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO JMP2r
|
||||
&long SWP2 ,&short JSR
|
||||
&short SWP ,&byte JSR
|
||||
&byte DUP #04 SFT ,&char JSR
|
||||
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO
|
||||
JMP2r
|
||||
|
|
|
|||
402
regex.tal
402
regex.tal
|
|
@ -97,10 +97,10 @@
|
|||
|
||||
( using error! will print the given message before causing )
|
||||
( the interpreter to halt. )
|
||||
@errorm ( msg* -> )
|
||||
@error!! ( msg* -> )
|
||||
LIT "! emit! space
|
||||
&loop LDAk #00 EQU ?&done
|
||||
LDAk emit! INC2 !&loop
|
||||
&loop LDAk #00 EQU ,&done JCN
|
||||
LDAk emit! INC2 ,&loop JMP
|
||||
&done POP2 newline #ff0e DEO #010f DEO BRK
|
||||
|
||||
( error messages )
|
||||
|
|
@ -126,34 +126,34 @@
|
|||
@rx-match ( str* regex* -> bool^ )
|
||||
#01 ;match-multiline STA
|
||||
#00 ;search-mode STA
|
||||
rx-reset
|
||||
!loop
|
||||
;rx-reset JSR2
|
||||
;loop JMP2
|
||||
|
||||
@rx-search-multiline ( str* regex* -> bool^ )
|
||||
#01 ;match-multiline STA
|
||||
#01 ;search-mode STA
|
||||
!rx-search/main
|
||||
,rx-search/main JMP
|
||||
|
||||
@rx-search ( str* regex* -> bool^ )
|
||||
#00 ;match-multiline STA
|
||||
#01 ;search-mode STA
|
||||
&main STH2 ( s* [r*] )
|
||||
DUP2 ;string-start STA2 ( s* [r*] )
|
||||
&loop LDAk #00 EQU ?&eof ( s* [r*] )
|
||||
rx-reset ( s* [r*] )
|
||||
&loop LDAk #00 EQU ,&eof JCN ( s* [r*] )
|
||||
;rx-reset JSR2 ( s* [r*] )
|
||||
DUP2 ;search-start STA2 ( s* [r*] )
|
||||
DUP2 STH2kr loop ( s* b^ [r*] )
|
||||
?&found ( s* [r*] )
|
||||
INC2 !&loop ( s+1* [r*] )
|
||||
DUP2 STH2kr ;loop JSR2 ( s* b^ [r*] )
|
||||
,&found JCN ( s* [r*] )
|
||||
INC2 ,&loop JMP ( s+1* [r*] )
|
||||
&found POP2 POP2r #01 JMP2r ( 01 )
|
||||
&eof rx-reset ( s* [r*] )
|
||||
&eof ;rx-reset JSR2 ( s* [r*] )
|
||||
DUP2 ;search-start STA2 ( s* [r*] )
|
||||
STH2r !loop ( b^ )
|
||||
STH2r ;loop JMP2 ( b^ )
|
||||
|
||||
( reset all "runtime" memory allocated during match/search )
|
||||
@rx-reset ( -> )
|
||||
reset-stack
|
||||
!subgroup-reset
|
||||
;reset-stack JSR2
|
||||
;subgroup-reset JMP2
|
||||
|
||||
( loop used during matching )
|
||||
( )
|
||||
|
|
@ -163,87 +163,87 @@
|
|||
( return a boolean, which is where the stack )
|
||||
( effects signature comes from. )
|
||||
@loop ( s* r* -> bool^ )
|
||||
LDAk #01 EQU ?do-empty
|
||||
LDAk #02 EQU ?do-dot
|
||||
LDAk #03 EQU ?do-literal
|
||||
LDAk #04 EQU ?do-or
|
||||
LDAk #05 EQU ?do-or ( same code as the or case )
|
||||
LDAk #06 EQU ?do-caret
|
||||
LDAk #07 EQU ?do-dollar
|
||||
LDAk #08 EQU ?do-lpar
|
||||
LDAk #09 EQU ?do-rpar
|
||||
LDAk #0a EQU ?do-ccls
|
||||
LDAk #0b EQU ?do-ncls
|
||||
LDAk #dd ;unknown-node-type errorm
|
||||
LDAk #01 EQU ;do-empty JCN2
|
||||
LDAk #02 EQU ;do-dot JCN2
|
||||
LDAk #03 EQU ;do-literal JCN2
|
||||
LDAk #04 EQU ;do-or JCN2
|
||||
LDAk #05 EQU ;do-or JCN2 ( same code as the or case )
|
||||
LDAk #06 EQU ;do-caret JCN2
|
||||
LDAk #07 EQU ;do-dollar JCN2
|
||||
LDAk #08 EQU ;do-lpar JCN2
|
||||
LDAk #09 EQU ;do-rpar JCN2
|
||||
LDAk #0a EQU ;do-ccls JCN2
|
||||
LDAk #0b EQU ;do-ncls JCN2
|
||||
LDAk #dd ;unknown-node-type ;error!! JSR2
|
||||
|
||||
( used when we hit a dead-end during matching. )
|
||||
( )
|
||||
( if stack is non-empty we have a point we can resume from. )
|
||||
@goto-backtrack ( -> bool^ )
|
||||
stack-exist ?&has-stack ( do we have stack? )
|
||||
;stack-exist JSR2 ,&has-stack JCN ( do we have stack? )
|
||||
#00 JMP2r ( no, return false )
|
||||
&has-stack
|
||||
pop4
|
||||
subgroup-backtrack
|
||||
!goto-next ( yes, resume from the top )
|
||||
;pop4 JSR2
|
||||
;subgroup-backtrack JSR2
|
||||
;goto-next JMP2 ( yes, resume from the top )
|
||||
|
||||
( follow the given address (next*) to continue matching )
|
||||
@goto-next ( str* next* -> bool^ )
|
||||
DUP2 #0000 GTH2 ?&has-next
|
||||
POP2 LDAk #00 EQU ?&end-of-string
|
||||
;search-mode LDA ?&end-of-search
|
||||
POP2 !goto-backtrack
|
||||
DUP2 #0000 GTH2 ,&has-next JCN
|
||||
POP2 LDAk #00 EQU ,&end-of-string JCN
|
||||
;search-mode LDA ,&end-of-search JCN
|
||||
POP2 ;goto-backtrack JMP2
|
||||
&end-of-search DUP2 ;search-end STA2
|
||||
&end-of-string POP2 #01 JMP2r
|
||||
&has-next !loop
|
||||
&has-next ;loop JMP2
|
||||
|
||||
( handle the empty node -- just follow the next pointer )
|
||||
@do-empty ( str* regex* -> bool^ )
|
||||
INC2 LDA2 ( load next )
|
||||
!goto-next ( jump to next )
|
||||
;goto-next JMP2 ( jump to next )
|
||||
|
||||
( FIXME: not currently used )
|
||||
@do-lpar ( str* regex* -> bool^ )
|
||||
STH2 DUP2 ( s s [r] )
|
||||
INC2r LDA2kr STH2r ( s s i [r+1] )
|
||||
subgroup-start ( s [r+1] )
|
||||
;subgroup-start JSR2 ( s [r+1] )
|
||||
STH2r INC2 INC2 ( s r+3 )
|
||||
LDA2 !goto-next ( jump to next )
|
||||
LDA2 ;goto-next JMP2 ( jump to next )
|
||||
|
||||
( FIXME: not currently used )
|
||||
@do-rpar ( str* regex* -> bool^ )
|
||||
STH2 DUP2 ( s s [r] )
|
||||
INC2r LDA2kr STH2r ( s s i [r+1] )
|
||||
subgroup-finish ( s [r+1] )
|
||||
;subgroup-finish JSR2 ( s [r+1] )
|
||||
STH2r INC2 INC2 ( s r+3 )
|
||||
LDA2 !goto-next ( jump to next )
|
||||
LDA2 ;goto-next JMP2 ( jump to next )
|
||||
|
||||
( handle dot -- match any one character )
|
||||
@do-dot ( str* regex* -> bool^ )
|
||||
INC2 LDA2 STH2 ( load and stash next )
|
||||
LDAk #00 NEQ ?&non-empty ( is there a char? )
|
||||
&backtrack POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack )
|
||||
&non-empty LDAk #0a NEQ ?&match ( yes, match unless \n in search-mode )
|
||||
;search-mode LDA ?&backtrack ( if \n and search-mode, treat as EOF )
|
||||
&match INC2 STH2r !goto-next ( on match: inc s, restore and jump )
|
||||
LDAk #00 NEQ ,&non-empty JCN ( is there a char? )
|
||||
&backtrack POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
|
||||
&non-empty LDAk #0a NEQ ,&match JCN ( yes, match unless \n in search-mode )
|
||||
;search-mode LDA ,&backtrack JCN ( if \n and search-mode, treat as EOF )
|
||||
&match INC2 STH2r ;goto-next JMP2 ( on match: inc s, restore and jump )
|
||||
|
||||
( hande caret -- match string start (or possibly after newline) without advancing )
|
||||
@do-caret ( str* regex* -> bool^ )
|
||||
INC2 LDA2 STH2 ( load and stash next )
|
||||
DUP2 ;string-start LDA2 EQU2 ?&at-start ( at string start? )
|
||||
;match-multiline LDA ?&no-match ( are we in multi-line mode? )
|
||||
DUP2 #0001 SUB2 LDA #0a EQU ?&at-start ( just after newline? )
|
||||
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack )
|
||||
&at-start STH2r !goto-next ( go to next without advancing )
|
||||
DUP2 ;string-start LDA2 EQU2 ,&at-start JCN ( at string start? )
|
||||
;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
|
||||
DUP2 #0001 SUB2 LDA #0a EQU ,&at-start JCN ( just after newline? )
|
||||
&no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
|
||||
&at-start STH2r ;goto-next JMP2 ( go to next without advancing )
|
||||
|
||||
( hande dollar -- match string end (or possibly before newline) without advancing )
|
||||
@do-dollar ( str* regex* -> bool^ )
|
||||
INC2 LDA2 STH2 ( load and stash next )
|
||||
LDAk #00 EQU ?&at-end ( at string end? )
|
||||
;match-multiline LDA ?&no-match ( are we in multi-line mode? )
|
||||
LDAk #0a EQU ?&at-end ( at newline? )
|
||||
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack )
|
||||
&at-end STH2r !goto-next ( go to next without advancing )
|
||||
LDAk #00 EQU ,&at-end JCN ( at string end? )
|
||||
;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
|
||||
LDAk #0a EQU ,&at-end JCN ( at newline? )
|
||||
&no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
|
||||
&at-end STH2r ;goto-next JMP2 ( go to next without advancing )
|
||||
|
||||
( handle literal -- match one specific character )
|
||||
@do-literal ( str* regex* -> bool^ )
|
||||
|
|
@ -251,23 +251,23 @@
|
|||
LDAk STH ( store c )
|
||||
INC2 LDA2 STH2 ROTr ( store next, move c to top )
|
||||
LDAk
|
||||
STHr EQU ?&matches ( do we match this char? )
|
||||
POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack )
|
||||
STHr EQU ,&matches JCN ( do we match this char? )
|
||||
POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
|
||||
&matches
|
||||
INC2 STH2r !goto-next ( yes, inc s, restore and jump )
|
||||
INC2 STH2r ;goto-next JMP2 ( yes, inc s, restore and jump )
|
||||
|
||||
( handle or -- try the left branch but backtrack to the right if needed )
|
||||
( )
|
||||
( this also handles asteration, since it ends up having the same structure )
|
||||
@do-or ( str* regex* -> bool^ )
|
||||
INC2 OVR2 OVR2 #0002 ADD2 ( s r+1 s r+3 )
|
||||
LDA2 push4 ( save (s, right) in the stack for possible backtracking )
|
||||
LDA2 !loop ( continue on left branch )
|
||||
LDA2 ;push4 JSR2 ( save (s, right) in the stack for possible backtracking )
|
||||
LDA2 ;loop JMP2 ( continue on left branch )
|
||||
|
||||
@matches-cls ( str* regex* -> bool^ )
|
||||
OVR2 LDA ?¬-null
|
||||
OVR2 LDA ,¬-null JCN
|
||||
( needs to have a character to match )
|
||||
POP2 POP2 !goto-backtrack
|
||||
POP2 POP2 ;goto-backtrack JMP2
|
||||
¬-null
|
||||
DUP2 INC2 LDA2 STH2 ( str regex [next] )
|
||||
OVR2 INC2 STH2 ( str regex [str+1 next] )
|
||||
|
|
@ -275,24 +275,24 @@
|
|||
#0003 ADD2 LDAk #00 SWP #0002 MUL2 ( r+3 len*2 [c str+1 next] )
|
||||
SWP2 INC2 STH2k ADD2 STH2r ( r+4+len*2 r+4 [c str+1 next] )
|
||||
&loop ( limit addr [c str+1 next] )
|
||||
EQU2k ?&missing
|
||||
LDAk STHkr GTH ?&next1 INC2
|
||||
LDAk STHkr LTH ?&next2 !&found
|
||||
EQU2k ,&missing JCN
|
||||
LDAk STHkr GTH ,&next1 JCN INC2
|
||||
LDAk STHkr LTH ,&next2 JCN ,&found JMP
|
||||
&next1 INC2
|
||||
&next2 INC2 !&loop
|
||||
&missing POP2 POP2 POPr ,&negated LDR ?&match
|
||||
&no-match POP2r POP2r !goto-backtrack
|
||||
&found POP2 POP2 POPr ,&negated LDR ?&no-match
|
||||
&match STH2r STH2r !goto-next
|
||||
&next2 INC2 ,&loop JMP
|
||||
&missing POP2 POP2 POPr ,&negated LDR ,&match JCN
|
||||
&no-match POP2r POP2r ;goto-backtrack JMP2
|
||||
&found POP2 POP2 POPr ,&negated LDR ,&no-match JCN
|
||||
&match STH2r STH2r ;goto-next JMP2
|
||||
[ &negated $1 ]
|
||||
|
||||
( )
|
||||
@do-ccls ( str* regex* -> bool^ )
|
||||
#00 ,matches-cls/negated STR !matches-cls
|
||||
#00 ,matches-cls/negated STR ,matches-cls JMP
|
||||
|
||||
( )
|
||||
@do-ncls ( str* regex* -> bool^ )
|
||||
#01 ,matches-cls/negated STR !matches-cls
|
||||
#01 ,matches-cls/negated STR ,matches-cls JMP
|
||||
|
||||
( REGEX PARSING )
|
||||
|
||||
|
|
@ -325,9 +325,9 @@
|
|||
@read ( -> c^ )
|
||||
;pos LDA2k ( pos s )
|
||||
LDAk STHk #00 EQU ( pos s c=0 [c] )
|
||||
?&is-eof ( pos s [c] )
|
||||
,&is-eof JCN ( pos s [c] )
|
||||
INC2 ( pos s+1 [c] )
|
||||
SWP2 STA2 !&return ( [c] )
|
||||
SWP2 STA2 ,&return JMP ( [c] )
|
||||
&is-eof POP2 POP2
|
||||
&return STHr ( c )
|
||||
JMP2r
|
||||
|
|
@ -370,8 +370,8 @@
|
|||
@compile ( expr* -> regex* )
|
||||
;pos STA2
|
||||
#0000 ;parens STA2
|
||||
rx-reset
|
||||
!compile-region
|
||||
;rx-reset JSR2
|
||||
;compile-region JMP2
|
||||
|
||||
( the basic strategy here is to build a stack of non-or )
|
||||
( expressions to be joined together at the end of the )
|
||||
|
|
@ -385,24 +385,24 @@
|
|||
( by #ffff #ffff. above that we start with #0000 #0000 )
|
||||
( to signal an empty node. )
|
||||
@compile-region ( -> r2* )
|
||||
#ffff #ffff push4 ( stack delimiter )
|
||||
#0000 #0000 push4 ( stack frame start )
|
||||
#ffff #ffff ;push4 JSR2 ( stack delimiter )
|
||||
#0000 #0000 ;push4 JSR2 ( stack frame start )
|
||||
@compile-region-loop
|
||||
read
|
||||
DUP #00 EQU ?c-done
|
||||
DUP LIT "| EQU ?c-or
|
||||
DUP LIT ". EQU ?c-dot
|
||||
DUP LIT "^ EQU ?c-caret
|
||||
DUP LIT "$ EQU ?c-dollar
|
||||
DUP LIT "( EQU ?c-lpar
|
||||
DUP LIT ") EQU ?c-rpar
|
||||
DUP LIT "[ EQU ?c-lbrk
|
||||
DUP LIT "] EQU ?c-rbrk
|
||||
DUP LIT "\ EQU ?c-esc
|
||||
DUP LIT "* EQU ?c-star
|
||||
DUP LIT "+ EQU ?c-plus
|
||||
DUP LIT "? EQU ?c-qmark
|
||||
!c-char
|
||||
;read JSR2
|
||||
DUP #00 EQU ;c-done JCN2
|
||||
DUP LIT "| EQU ;c-or JCN2
|
||||
DUP LIT ". EQU ;c-dot JCN2
|
||||
DUP LIT "^ EQU ;c-caret JCN2
|
||||
DUP LIT "$ EQU ;c-dollar JCN2
|
||||
DUP LIT "( EQU ;c-lpar JCN2
|
||||
DUP LIT ") EQU ;c-rpar JCN2
|
||||
DUP LIT "[ EQU ;c-lbrk JCN2
|
||||
DUP LIT "] EQU ;c-rbrk JCN2
|
||||
DUP LIT "\ EQU ;c-esc JCN2
|
||||
DUP LIT "* EQU ;c-star JCN2
|
||||
DUP LIT "+ EQU ;c-plus JCN2
|
||||
DUP LIT "? EQU ;c-qmark JCN2
|
||||
;c-char JMP2
|
||||
|
||||
( either finalize the given r0/r1 or else wrap it in )
|
||||
( a star node if a star is coming up next. )
|
||||
|
|
@ -410,14 +410,14 @@
|
|||
( we use this look-ahead approach rather than compiling )
|
||||
( star nodes directly since the implementation is simpler. )
|
||||
@c-peek-and-finalize ( r0* r1* -> r2* )
|
||||
peek-to-star ( r0 r1 next-is-star? ) ?&next-is-star
|
||||
peek-to-plus ( r0 r1 next-is-plus? ) ?&next-is-plus
|
||||
peek-to-qmark ( r0 r1 next-is-qmark? ) ?&next-is-qmark
|
||||
!&finally ( r0 r1 )
|
||||
&next-is-star skip POP2 alloc-star DUP2 !&finally
|
||||
&next-is-plus skip POP2 alloc-plus DUP2 !&finally
|
||||
&next-is-qmark skip POP2 alloc-qmark DUP2 !&finally
|
||||
&finally push-next !compile-region-loop
|
||||
;peek-to-star JSR2 ( r0 r1 next-is-star? ) ,&next-is-star JCN
|
||||
;peek-to-plus JSR2 ( r0 r1 next-is-plus? ) ,&next-is-plus JCN
|
||||
;peek-to-qmark JSR2 ( r0 r1 next-is-qmark? ) ,&next-is-qmark JCN
|
||||
,&finally JMP ( r0 r1 )
|
||||
&next-is-star ;skip JSR2 POP2 ;alloc-star JSR2 DUP2 ,&finally JMP
|
||||
&next-is-plus ;skip JSR2 POP2 ;alloc-plus JSR2 DUP2 ,&finally JMP
|
||||
&next-is-qmark ;skip JSR2 POP2 ;alloc-qmark JSR2 DUP2 ,&finally JMP
|
||||
&finally ;push-next JSR2 ;compile-region-loop JMP2
|
||||
|
||||
( called when we reach EOF of the input string )
|
||||
( )
|
||||
|
|
@ -427,9 +427,9 @@
|
|||
( this is where we detect unclosed parenthesis. )
|
||||
@c-done ( c^ -> r2* )
|
||||
POP
|
||||
;parens LDA2 #0000 GTH2 ?&mismatched-parens
|
||||
unroll-stack POP2 JMP2r
|
||||
&mismatched-parens ;mismatched-parens errorm
|
||||
;parens LDA2 #0000 GTH2 ,&mismatched-parens JCN
|
||||
;unroll-stack JSR2 POP2 JMP2r
|
||||
&mismatched-parens ;mismatched-parens ;error!! JSR2
|
||||
|
||||
( called when we read "|" )
|
||||
( )
|
||||
|
|
@ -437,8 +437,8 @@
|
|||
( we just start a new stack frame and continue. )
|
||||
@c-or ( c^ -> r2* )
|
||||
POP
|
||||
#0000 #0000 push4
|
||||
!compile-region-loop
|
||||
#0000 #0000 ;push4 JSR2
|
||||
;compile-region-loop JMP2
|
||||
|
||||
( called when we read left parenthesis )
|
||||
( )
|
||||
|
|
@ -450,7 +450,7 @@
|
|||
@c-lpar ( c^ -> r2* )
|
||||
POP
|
||||
;parens LDA2 INC2 ;parens STA2 ( parens++ )
|
||||
!compile-region
|
||||
;compile-region JMP2
|
||||
|
||||
( called when we read right parenthesis )
|
||||
( )
|
||||
|
|
@ -463,34 +463,34 @@
|
|||
( 5. continue parsing )
|
||||
@c-rpar ( c^ -> r2* )
|
||||
POP
|
||||
;parens LDA2 #0000 EQU2 ?&mismatched-parens
|
||||
;parens LDA2 #0000 EQU2 ,&mismatched-parens JCN
|
||||
;parens LDA2 #0001 SUB2 ;parens STA2 ( parens-- )
|
||||
unroll-stack
|
||||
!c-peek-and-finalize
|
||||
&mismatched-parens ;mismatched-parens errorm
|
||||
;unroll-stack JSR2
|
||||
;c-peek-and-finalize JMP2
|
||||
&mismatched-parens ;mismatched-parens ;error!! JSR2
|
||||
|
||||
( doesn't support weird things like []abc] or [-abc] or similar. )
|
||||
( doesn't currently handle "special" escapes such as \n )
|
||||
@c-lbrk ( c^ -> r2* )
|
||||
POP LITr 00 ;pos LDA2 ( pos [0] )
|
||||
LDAk LIT "^ NEQ ?&normal INCr INC2 ( pos [negated?^] )
|
||||
LDAk LIT "^ NEQ ,&normal JCN INCr INC2 ( pos [negated?^] )
|
||||
&normal
|
||||
#0a STHr ADD ( src* type^ )
|
||||
;arena-pos LDA2 STH2k ( src* type^ dst* [dst*] )
|
||||
STA LIT2r 0004 ADD2r ( src* [dst+4] )
|
||||
&left-parse ( src* [dst*] )
|
||||
LDAk LIT "] EQU ?&done
|
||||
LDAk LIT "- EQU ?&error
|
||||
LDAk LIT "\ NEQ ?&left INC2
|
||||
LDAk LIT "] EQU ,&done JCN
|
||||
LDAk LIT "- EQU ,&error JCN
|
||||
LDAk LIT "\ NEQ ,&left JCN INC2
|
||||
&left
|
||||
LDAk STH2kr STA INC2r
|
||||
DUP2 INC2 LDA LIT "- NEQ ?&pre-right INC2 INC2
|
||||
LDAk LIT "] EQU ?&error
|
||||
LDAk LIT "- EQU ?&error
|
||||
DUP2 INC2 LDA LIT "- NEQ ,&pre-right JCN INC2 INC2
|
||||
LDAk LIT "] EQU ,&error JCN
|
||||
LDAk LIT "- EQU ,&error JCN
|
||||
&pre-right
|
||||
LDAk LIT "\ NEQ ?&right INC2
|
||||
LDAk LIT "\ NEQ ,&right JCN INC2
|
||||
&right
|
||||
LDAk STH2kr STA INC2 INC2r !&left-parse
|
||||
LDAk STH2kr STA INC2 INC2r ,&left-parse JMP
|
||||
&done ( src* [dst*] )
|
||||
INC2 ;pos STA2 STH2r ( dst* )
|
||||
DUP2 ;arena-pos LDA2 ( dst dst a )
|
||||
|
|
@ -498,7 +498,7 @@
|
|||
;arena-pos LDA2 STH2k #0003 ADD2 STA ( dst [a] )
|
||||
;arena-pos STA2 STH2r ( a )
|
||||
#0000 OVR2 INC2 STA2 ( a )
|
||||
DUP2 !c-peek-and-finalize
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
&error
|
||||
#abcd #0000 DIV ( TODO error here )
|
||||
|
||||
|
|
@ -511,24 +511,24 @@
|
|||
( allocates a dot-node and continues. )
|
||||
@c-dot ( c^ -> r2* )
|
||||
POP
|
||||
#02 alloc3
|
||||
DUP2 !c-peek-and-finalize
|
||||
#02 ;alloc3 JSR2
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
|
||||
( called when we read "^" )
|
||||
( )
|
||||
( allocates a caret-node and continues. )
|
||||
@c-caret ( c^ -> r2* )
|
||||
POP
|
||||
#06 alloc3
|
||||
DUP2 !c-peek-and-finalize
|
||||
#06 ;alloc3 JSR2
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
|
||||
( called when we read "$" )
|
||||
( )
|
||||
( allocates a dollar-node and continues. )
|
||||
@c-dollar ( c^ -> r2* )
|
||||
POP
|
||||
#07 alloc3
|
||||
DUP2 !c-peek-and-finalize
|
||||
#07 ;alloc3 JSR2
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
|
||||
( called when we read "\" )
|
||||
( )
|
||||
|
|
@ -536,50 +536,50 @@
|
|||
( )
|
||||
( otherwise, allocates a literal of the next character. )
|
||||
@c-esc ( c^ -> r2* )
|
||||
POP read
|
||||
DUP LIT "a EQU ?&bel
|
||||
DUP LIT "b EQU ?&bs
|
||||
DUP LIT "t EQU ?&tab
|
||||
DUP LIT "n EQU ?&nl
|
||||
DUP LIT "v EQU ?&vtab
|
||||
DUP LIT "f EQU ?&ff
|
||||
DUP LIT "r EQU ?&cr
|
||||
&default !c-char
|
||||
&bel POP #07 !&default
|
||||
&bs POP #08 !&default
|
||||
&tab POP #09 !&default
|
||||
&nl POP #0a !&default
|
||||
&vtab POP #0b !&default
|
||||
&ff POP #0c !&default
|
||||
&cr POP #0d !&default
|
||||
POP ;read JSR2
|
||||
DUP LIT "a EQU ,&bel JCN
|
||||
DUP LIT "b EQU ,&bs JCN
|
||||
DUP LIT "t EQU ,&tab JCN
|
||||
DUP LIT "n EQU ,&nl JCN
|
||||
DUP LIT "v EQU ,&vtab JCN
|
||||
DUP LIT "f EQU ,&ff JCN
|
||||
DUP LIT "r EQU ,&cr JCN
|
||||
&default ;c-char JMP2
|
||||
&bel POP #07 ,&default JMP
|
||||
&bs POP #08 ,&default JMP
|
||||
&tab POP #09 ,&default JMP
|
||||
&nl POP #0a ,&default JMP
|
||||
&vtab POP #0b ,&default JMP
|
||||
&ff POP #0c ,&default JMP
|
||||
&cr POP #0d ,&default JMP
|
||||
|
||||
( called when we read any other character )
|
||||
( )
|
||||
( allocates a literal-node and continues. )
|
||||
@c-char ( c^ -> r2* )
|
||||
alloc-lit ( lit )
|
||||
DUP2 !c-peek-and-finalize
|
||||
;alloc-lit JSR2 ( lit )
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
|
||||
( called if we parse a "*" )
|
||||
( )
|
||||
( actually calling this means the code broke an invariant somewhere. )
|
||||
@c-star ( c^ -> regex* )
|
||||
POP
|
||||
;star-invariant errorm
|
||||
;star-invariant ;error!! JSR2
|
||||
|
||||
( called if we parse a "+" )
|
||||
( )
|
||||
( actually calling this means the code broke an invariant somewhere. )
|
||||
@c-plus ( c^ -> regex* )
|
||||
POP
|
||||
;plus-invariant errorm
|
||||
;plus-invariant ;error!! JSR2
|
||||
|
||||
( called if we parse a "?" )
|
||||
( )
|
||||
( actually calling this means the code broke an invariant somewhere. )
|
||||
@c-qmark ( c^ -> regex* )
|
||||
POP
|
||||
;qmark-invariant errorm
|
||||
;qmark-invariant ;error!! JSR2
|
||||
|
||||
( ALLOCATING REGEX NDOES )
|
||||
|
||||
|
|
@ -589,51 +589,51 @@
|
|||
|
||||
@alloc3 ( mode^ -> r* )
|
||||
#0000 ROT ( 00 00 mode^ )
|
||||
#03 alloc ( 00 00 mode^ addr* )
|
||||
#03 ;alloc JSR2 ( 00 00 mode^ addr* )
|
||||
STH2k STA ( addr <- mode )
|
||||
STH2kr INC2 STA2 ( addr+1 <- 0000 )
|
||||
STH2r JMP2r ( return addr )
|
||||
|
||||
@alloc-empty ( -> r* )
|
||||
#01 !alloc3
|
||||
#01 ;alloc3 JMP2
|
||||
|
||||
@alloc-lit ( c^ -> r* )
|
||||
#03 #0000 SWP2 ( 0000 c^ 03 )
|
||||
#04 alloc ( 0000 c^ 03 addr* )
|
||||
#04 ;alloc JSR2 ( 0000 c^ 03 addr* )
|
||||
STH2k STA ( addr <- 03 )
|
||||
STH2kr INC2 STA ( addr+1 <- c )
|
||||
STH2kr #0002 ADD2 STA2 ( addr+2 <- 0000 )
|
||||
STH2r JMP2r ( return addr )
|
||||
|
||||
@alloc-or ( right* left* -> r* )
|
||||
#05 alloc STH2 ( r l [x] )
|
||||
#05 ;alloc JSR2 STH2 ( r l [x] )
|
||||
#04 STH2kr STA ( r l [x] )
|
||||
STH2kr INC2 STA2 ( r [x] )
|
||||
STH2kr #0003 ADD2 STA2 ( [x] )
|
||||
STH2r JMP2r
|
||||
|
||||
@alloc-star ( expr* -> r* )
|
||||
#05 alloc STH2 ( expr [r] )
|
||||
#05 ;alloc JSR2 STH2 ( expr [r] )
|
||||
#05 STH2kr STA ( expr [r] )
|
||||
DUP2 STH2kr INC2 STA2 ( expr [r] )
|
||||
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
|
||||
STH2kr SWP2 ( r expr [r] )
|
||||
set-next ( [r] )
|
||||
;set-next JSR2 ( [r] )
|
||||
STH2r JMP2r
|
||||
|
||||
@alloc-plus ( expr* -> r* )
|
||||
#05 alloc STH2 ( expr [r] )
|
||||
#05 ;alloc JSR2 STH2 ( expr [r] )
|
||||
#05 STH2kr STA ( expr [r] )
|
||||
DUP2 STH2kr INC2 STA2 ( expr [r] )
|
||||
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
|
||||
STH2r SWP2 STH2k ( r expr [expr] )
|
||||
set-next ( [expr] )
|
||||
;set-next JSR2 ( [expr] )
|
||||
STH2r JMP2r
|
||||
|
||||
@alloc-qmark ( expr* -> r* )
|
||||
alloc-empty STH2k ( expr e [e] )
|
||||
OVR2 set-next ( expr [e] )
|
||||
#05 alloc STH2 ( expr [r e] )
|
||||
;alloc-empty JSR2 STH2k ( expr e [e] )
|
||||
OVR2 ;set-next JSR2 ( expr [e] )
|
||||
#05 ;alloc JSR2 STH2 ( expr [r e] )
|
||||
#04 STH2kr STA ( expr [r e] )
|
||||
STH2kr INC2 STA2 ( [r e] )
|
||||
SWP2r STH2r STH2kr ( e r [r] )
|
||||
|
|
@ -642,7 +642,7 @@
|
|||
|
||||
( if r is 0000, allocate an empty node )
|
||||
@alloc-if-null ( r* -> r2* )
|
||||
ORAk ?&return POP2 alloc-empty &return JMP2r
|
||||
ORAk ,&return JCN POP2 ;alloc-empty JSR2 &return JMP2r
|
||||
|
||||
( unroll one region of the parsing stack, returning )
|
||||
( a single node consisting of an alternation of )
|
||||
|
|
@ -651,23 +651,23 @@
|
|||
( this unrolls until it hits #ffff #ffff, which it )
|
||||
( also removes from the stack. )
|
||||
@unroll-stack ( -> start* end* )
|
||||
pop4 STH2 ( r )
|
||||
;pop4 JSR2 STH2 ( r )
|
||||
#00 STH ( count items in stack frame )
|
||||
alloc-if-null ( replace 0000 with empty )
|
||||
;alloc-if-null JSR2 ( replace 0000 with empty )
|
||||
&loop ( r* )
|
||||
pop4 POP2 ( r x )
|
||||
DUP2 #ffff EQU2 ( r x x-is-end? ) ?&done
|
||||
;pop4 JSR2 POP2 ( r x )
|
||||
DUP2 #ffff EQU2 ( r x x-is-end? ) ,&done JCN
|
||||
INCr ( items++ )
|
||||
alloc-or ( r|x ) !&loop
|
||||
;alloc-or JSR2 ( r|x ) ,&loop JMP
|
||||
&done
|
||||
( r ffff )
|
||||
POP2
|
||||
STHr ?&is-or
|
||||
STHr ,&is-or JCN
|
||||
STH2r JMP2r
|
||||
&is-or
|
||||
POP2r
|
||||
alloc-empty OVR2 OVR2 SWP2 ( r empty empty r )
|
||||
set-next-or
|
||||
;alloc-empty JSR2 OVR2 OVR2 SWP2 ( r empty empty r )
|
||||
;set-next-or JSR2
|
||||
JMP2r
|
||||
|
||||
( add r to the top of the stock. )
|
||||
|
|
@ -675,21 +675,21 @@
|
|||
( in particular, this will write r into tail.next )
|
||||
( before replacing tail with r. )
|
||||
@push-next ( r0 r1 -> )
|
||||
pop4 ( r0 r1 x0 x1 )
|
||||
DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ?&is-zero
|
||||
;pop4 JSR2 ( r0 r1 x0 x1 )
|
||||
DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ,&is-zero JCN
|
||||
STH2 ROT2 STH2r ( r1 x0 r0 x1 )
|
||||
set-next SWP2 ( x0 r1 )
|
||||
push4
|
||||
;set-next JSR2 SWP2 ( x0 r1 )
|
||||
;push4 JSR2
|
||||
JMP2r
|
||||
&is-zero POP2 POP2 !push4
|
||||
&is-zero POP2 POP2 ;push4 JMP2
|
||||
|
||||
( load the given address: )
|
||||
( )
|
||||
( 1. if it points to 0000, update it to target )
|
||||
( 2. otherwise, call set-next on it )
|
||||
@set-next-addr ( target* addr* -> )
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero
|
||||
LDA2 !set-next
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
|
||||
LDA2 ;set-next JMP2
|
||||
&is-zero STA2 JMP2r
|
||||
|
||||
( set regex.next to target )
|
||||
|
|
@ -703,18 +703,18 @@
|
|||
( back up we only bother taking the left branch. otherwise )
|
||||
( you can end up double-appending things. )
|
||||
@set-next ( target* regex* -> )
|
||||
LDAk #01 LTH ?&unknown
|
||||
LDAk #0b GTH ?&unknown
|
||||
LDAk #09 GTH ?&cc
|
||||
LDAk #01 LTH ,&unknown JCN
|
||||
LDAk #0b GTH ,&unknown JCN
|
||||
LDAk #09 GTH ,&cc JCN
|
||||
LDAk #00 SWP ;rx-node-sizes ADD2
|
||||
LDA #00 SWP ADD2 #0002 SUB2
|
||||
!set-next-addr
|
||||
&cc INC2 !set-next-addr
|
||||
&unknown LDAk #ee ;unknown-node-type errorm
|
||||
;set-next-addr JMP2
|
||||
&cc INC2 ;set-next-addr JMP2
|
||||
&unknown LDAk #ee ;unknown-node-type ;error!! JSR2
|
||||
|
||||
@set-next-or-addr ( target* addr* -> )
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero
|
||||
LDA2 !set-next-or
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
|
||||
LDA2 ;set-next-or JMP2
|
||||
&is-zero STA2 JMP2r
|
||||
|
||||
( this is used when first building or-nodes )
|
||||
|
|
@ -722,10 +722,10 @@
|
|||
( [x1, [x2, [x3, ..., [xm, xn]]]] )
|
||||
( so we recurse on the right side but not the left. )
|
||||
@set-next-or ( target* regex* -> )
|
||||
LDAk #04 NEQ ?&!4
|
||||
OVR2 OVR2 INC2 set-next-addr
|
||||
#0003 ADD2 !set-next-or-addr
|
||||
&!4 !set-next
|
||||
LDAk #04 NEQ ,&!4 JCN
|
||||
OVR2 OVR2 INC2 ;set-next-addr JSR2
|
||||
#0003 ADD2 ;set-next-or-addr JMP2
|
||||
&!4 ;set-next JMP2
|
||||
|
||||
( STACK OPERATIONS )
|
||||
( )
|
||||
|
|
@ -741,7 +741,7 @@
|
|||
|
||||
( push 4 bytes onto the stack )
|
||||
@push4 ( str* regex* -> )
|
||||
assert-stack-avail ( check for space )
|
||||
;assert-stack-avail JSR2 ( check for space )
|
||||
;stack-pos LDA2 #0002 ADD2 STA2 ( cell[2:3] <- regex )
|
||||
;stack-pos LDA2 STA2 ( cell[0:1] <- str )
|
||||
;stack-pos LDA2 #0004 ADD2 ;stack-pos STA2 ( pos += 4 )
|
||||
|
|
@ -749,7 +749,7 @@
|
|||
|
||||
( pop 4 bytes from the stack )
|
||||
@pop4 ( -> str* regex* )
|
||||
assert-stack-exist ( check for space )
|
||||
;assert-stack-exist JSR2 ( check for space )
|
||||
;stack-pos LDA2 ( load stack-pos )
|
||||
#0002 SUB2 LDA2k STH2 ( pop and stash regex )
|
||||
#0002 SUB2 LDA2k STH2 ( pop and stash str )
|
||||
|
|
@ -771,11 +771,11 @@
|
|||
|
||||
( error if stack is full )
|
||||
@assert-stack-avail ( -> )
|
||||
stack-avail ?&ok ;stack-is-full errorm &ok JMP2r
|
||||
;stack-avail JSR2 ,&ok JCN ;stack-is-full ;error!! JSR2 &ok JMP2r
|
||||
|
||||
( error is stack is empty )
|
||||
@assert-stack-exist ( -> )
|
||||
stack-exist ?&ok ;stack-is-empty errorm &ok JMP2r
|
||||
;stack-exist JSR2 ,&ok JCN ;stack-is-empty ;error!! JSR2 &ok JMP2r
|
||||
|
||||
( stack-pos points to the next free stack position (or the top if full). )
|
||||
@stack-pos :stack-bot ( the next position to insert at )
|
||||
|
|
@ -810,10 +810,10 @@
|
|||
#00 SWP ( size* )
|
||||
;arena-pos LDA2 STH2k ADD2 ( pos+size* [pos] )
|
||||
DUP2 ;arena-top GTH2 ( pos+size pos+size>top? [pos] )
|
||||
?&error ( pos+size [pos] )
|
||||
,&error JCN ( pos+size [pos] )
|
||||
;arena-pos STA2 ( pos += size [pos] )
|
||||
STH2r JMP2r ( pos )
|
||||
&error POP2 POP2r ;arena-is-full errorm
|
||||
&error POP2 POP2r ;arena-is-full ;error!! JSR2
|
||||
|
||||
@arena-pos :arena-bot ( the next position to allocate )
|
||||
@arena-bot $400 @arena-top ( holds up to 1024 bytes )
|
||||
|
|
@ -870,7 +870,7 @@
|
|||
|
||||
@subgroup-start ( s* i^ -> )
|
||||
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
|
||||
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
|
||||
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
|
||||
&next ( s* i^ [pos*] )
|
||||
STH2kr STA
|
||||
STH2r INC2 STA2
|
||||
|
|
@ -878,9 +878,9 @@
|
|||
|
||||
@subgroup-finish ( s* i^ -> )
|
||||
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
|
||||
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
|
||||
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
|
||||
&next ( s* i^ [pos*] )
|
||||
STH2kr LDA EQU ?&ok #0000 DIV ( mismatched subgroups )
|
||||
STH2kr LDA EQU ,&ok JCN #0000 DIV ( mismatched subgroups )
|
||||
&ok ( s* [pos*] )
|
||||
STH2kr #0003 ADD2 STA2
|
||||
STH2r #0005 ADD2 ;subgroup-pos STA2
|
||||
|
|
@ -888,7 +888,7 @@
|
|||
|
||||
@subgroup-branch ( -> )
|
||||
;subgroup-pos LDA2 STH2k ( pos* [pos*] )
|
||||
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
|
||||
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
|
||||
&next
|
||||
#00 STH2kr STA ( [*pos] )
|
||||
STH2r #0005 ADD2 ;subgroup-pos STA2
|
||||
|
|
@ -897,9 +897,9 @@
|
|||
@subgroup-backtrack ( -> )
|
||||
;subgroup-bot ;subgroup-pos LDA2 ( bot* pos* )
|
||||
&loop ( bot* pos* )
|
||||
EQU2k ?&done
|
||||
LDAk #00 EQU ?&done
|
||||
#0005 SUB2 !&loop
|
||||
EQU2k ,&done JCN
|
||||
LDAk #00 EQU ,&done JCN
|
||||
#0005 SUB2 ,&loop JMP
|
||||
&done ( bot* pos* )
|
||||
NIP2 ;subgroup-pos STA2
|
||||
JMP2r
|
||||
|
|
|
|||
148
term.tal
148
term.tal
|
|
@ -76,32 +76,13 @@
|
|||
( ESC [ ? 1060 l -> unset legacy keyboard emulation )
|
||||
( ESC [ ? 1061 h -> set VT220 keyboard emulation )
|
||||
|
||||
|00 @System [
|
||||
&vect $2 &expansion $2 &title $2 &metadata $2
|
||||
&r $2 &g $2 &b $2 ]
|
||||
|
||||
|10 @Console [
|
||||
&vect $2 &stdin $1 &pad1 $4 &type $1
|
||||
&stdout $1 &stderr $1 &proc-put $1 &pad2 $1 ¶m $2 &opts $1 &host-put $1 ]
|
||||
|
||||
|20 @Screen [
|
||||
&vect $2 &w $2 &h $2 &auto $1 &pad $1
|
||||
&x $2 &y $2 &addr $2 &px $1 &sprite $1 ]
|
||||
|
||||
|80 @Controller [
|
||||
&vect $2 &button $1 &key $1 &fn $1 ]
|
||||
|
||||
|90 @Mouse [
|
||||
&vect $2 &x $2 &y $2 &state $1 &pad1 $1
|
||||
&pad2 $2 &scrollx $2 &scrolly $2 &pad3 $2 ]
|
||||
|
||||
|a0 @File1 [
|
||||
&vect $2 &ok $2 &stat $2 &del $1 &append $1
|
||||
&name $2 &len $2 &r $2 &w $2 ]
|
||||
|
||||
|b0 @File2 [
|
||||
&vect $2 &ok $2 &stat $2 &del $1 &append $1
|
||||
&name $2 &len $2 &r $2 &w $2 ]
|
||||
|00 @System [ &vect $2 &expansion $2 &title $2 &metadata $2 &r $2 &g $2 &b $2 ]
|
||||
|10 @Console [ &vect $2 &r $1 &exec $2 &mode $1 &dead $1 &exit $1 &w $1 ]
|
||||
|20 @Screen [ &vect $2 &w $2 &h $2 &auto $1 &pad $1 &x $2 &y $2 &addr $2 &px $1 &sprite $1 ]
|
||||
|80 @Controller [ &vect $2 &button $1 &key $1 &fn $1 ]
|
||||
|90 @Mouse [ &vect $2 &x $2 &y $2 &state $1 &pad $3 &scrollx $2 &scrolly $2 ]
|
||||
|a0 @File1 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|b0 @File2 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|
||||
|0000
|
||||
@tint $1 ( draw mode. 01=regular, 04=inverted )
|
||||
|
|
@ -143,17 +124,13 @@
|
|||
@visual-bell $1 ( flash visual bell? otherwise do nothing )
|
||||
@border-pad $2 ( use border? should be 0000 or 0010 )
|
||||
|
||||
( subprocess )
|
||||
@put-port $1
|
||||
@get-type $1
|
||||
|
||||
|0100
|
||||
( metadata )
|
||||
;meta .System/metadata DEO2
|
||||
;meta/name .System/title DEO2
|
||||
|
||||
( user configuration defaults )
|
||||
#00 .debug STZ
|
||||
#01 .debug STZ
|
||||
#01 .show-banner STZ
|
||||
( #0010 .border-pad STZ2 )
|
||||
#0000 .border-pad STZ2
|
||||
|
|
@ -179,54 +156,23 @@
|
|||
;on-mouse .Mouse/vect DEO2 ( set up mouse callback )
|
||||
;on-read .Console/vect DEO2 ( set up stdin callback )
|
||||
|
||||
setup-shell ( set up experimental subprocess support )
|
||||
setup-subprocess ( set up experimental subprocess support )
|
||||
reset-terminal ( initialize terminal state and settings )
|
||||
setup-debugging ( set up debugging if requested )
|
||||
draw-banner ( draw banner if requested )
|
||||
|
||||
BRK
|
||||
|
||||
@env "TERM=ansi 00
|
||||
|
||||
@query
|
||||
( expansion cmd ) 03
|
||||
( console device ) 10
|
||||
( uuid ) 0123 1250 d878 4462 bc41 d092 7645 a2fa
|
||||
( version ) 00
|
||||
( flags ) &flags 0000
|
||||
|
||||
@has-subprocess ( -> bool^ )
|
||||
;query .System/expansion DEO2
|
||||
;query/flags LDA2 #00ff EQU2 JMP2r
|
||||
|
||||
( these only work with a patched uxnemu )
|
||||
( on other emulators they should be no-ops )
|
||||
@setup-shell ( -> )
|
||||
has-subprocess ?{
|
||||
( without subprocess, just use stdin/stdout )
|
||||
.Console/stdout .put-port STZ
|
||||
#01 .get-type STZ
|
||||
JMP2r
|
||||
}
|
||||
|
||||
( with subprocess, use proc put/get )
|
||||
.Console/proc-put .put-port STZ
|
||||
#21 .get-type STZ
|
||||
|
||||
( setenv 'TERM=ansi' )
|
||||
;env .Console/param DEO2
|
||||
#11 .Console/host-put DEO
|
||||
|
||||
( exec 'bash -i' )
|
||||
#81 .Console/opts DEO
|
||||
;shell .Console/param DEO2
|
||||
#01 .Console/host-put DEO
|
||||
|
||||
( TODO: run stty to communicate terminal size? )
|
||||
@setup-subprocess ( -> )
|
||||
;shell .Console/exec DEO2 ( set up bash subprocess )
|
||||
#80 .Console/mode DEO ( start bash subprocess )
|
||||
JMP2r
|
||||
|
||||
@setup-debugging ( -> )
|
||||
.debug LDZ ?&continue JMP2r &continue
|
||||
#99 #010e DEO ( put 99 in wst so #010e DEO reliably logs )
|
||||
;debug-log .File1/name DEO2
|
||||
#01 .File1/append DEO
|
||||
JMP2r
|
||||
|
|
@ -278,7 +224,7 @@
|
|||
.rows LDZ2 #000c MUL2 ADD2 .Screen/h DEO2
|
||||
JMP2r
|
||||
|
||||
@shell "bash 20 "-l 20 "-i 00
|
||||
@shell "bash 00 "-i 00 00
|
||||
|
||||
@load-theme ( -> )
|
||||
;&path .File1/name DEO2
|
||||
|
|
@ -435,18 +381,18 @@
|
|||
|
||||
( send ESC [ $c )
|
||||
@arrow ( c^ -> )
|
||||
( .Console/proc-put ) .put-port LDZ STH
|
||||
.Console/w STH
|
||||
#1b STHkr DEO LIT "[ STHkr DEO STHr DEO
|
||||
JMP2r
|
||||
|
||||
@paste-from-buf ( size* -> )
|
||||
;paste-buf SWP2 OVR2 ADD2 SWP2 ( limit* start* )
|
||||
&loop ( limit* pos* )
|
||||
LDAk ( .Console/proc-put ) .put-port LDZ DEO INC2 ( limit* pos+1* )
|
||||
LDAk .Console/w DEO INC2 ( limit* pos+1* )
|
||||
GTH2k ?&loop POP2 POP2 JMP2r
|
||||
|
||||
@bracket-paste ( c^ -> )
|
||||
( .Console/proc-put ) .put-port LDZ STH
|
||||
.Console/w STH
|
||||
#1b STHkr DEO
|
||||
LIT "[ STHkr DEO
|
||||
LIT "2 STHkr DEO
|
||||
|
|
@ -661,16 +607,16 @@
|
|||
.Controller/key DEI
|
||||
DUP #08 NEQ ?&done
|
||||
POP #7f ( send DEL instead of BS )
|
||||
&done ( .Console/proc-put ) .put-port LDZ DEO BRK
|
||||
&done .Console/w DEO BRK
|
||||
|
||||
@ctrl ( -> is-down? ) .Controller/button DEI #01 AND JMP2r
|
||||
@alt ( -> is-down? ) .Controller/button DEI #02 AND JMP2r
|
||||
|
||||
( alt-XYZ emits ESC and then emits XYZ )
|
||||
@on-alt-key ( -> BRK )
|
||||
#1b ( .Console/proc-put ) .put-port LDZ DEO
|
||||
#1b .Console/w DEO
|
||||
ctrl ?on-ctrl-key
|
||||
.Controller/key DEI ( .Console/proc-put ) .put-port LDZ DEO BRK
|
||||
.Controller/key DEI .Console/w DEO BRK
|
||||
|
||||
( control seqs: )
|
||||
( ctrl-sp -> 00 )
|
||||
|
|
@ -705,15 +651,10 @@
|
|||
&rs #1e !&done
|
||||
&us #1f !&done
|
||||
&c1 LIT "@ SUB
|
||||
&done ( .Console/proc-put ) .put-port LDZ DEO BRK
|
||||
|
||||
@read-or-brk ( -> BRK? )
|
||||
.Console/type DEI .get-type LDZ EQU ?{ BRK } JMP2r
|
||||
&done .Console/w DEO BRK
|
||||
|
||||
@on-read-priv ( -> BRK )
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
.Console/r DEI
|
||||
DUP LIT "; EQU ?next-arg
|
||||
DUP LIT "0 LTH ?end-arg-priv
|
||||
DUP LIT "9 GTH ?end-arg-priv
|
||||
|
|
@ -723,9 +664,7 @@
|
|||
POP ;on-read-priv .Console/vect DEO2 BRK
|
||||
|
||||
@on-read-csi ( -> BRK )
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
.Console/r DEI
|
||||
DUP LIT "? EQU ?start-priv
|
||||
DUP LIT "; EQU ?next-arg
|
||||
DUP LIT "0 LTH ?end-arg
|
||||
|
|
@ -733,9 +672,7 @@
|
|||
!add-to-arg
|
||||
|
||||
@on-read-osc ( -> BRK )
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
.Console/r DEI
|
||||
DUP #07 ( bell ) EQU ?&end-osc
|
||||
#9c ( esc-\ ) EQU ?&end-osc BRK
|
||||
&end-osc ;on-read .Console/vect DEO2 BRK
|
||||
|
|
@ -936,12 +873,12 @@
|
|||
|
||||
@dsr ( n* -> )
|
||||
#0006 NEQ2 ?&done
|
||||
#1b ( .Console/proc-put ) .put-port LDZ DEO
|
||||
LIT "[ ( .Console/proc-put ) .put-port LDZ DEO
|
||||
#1b .Console/w DEO
|
||||
LIT "[ .Console/w DEO
|
||||
.cur-y LDZ2 INC2 emit-dec2
|
||||
LIT "; ( .Console/proc-put ) .put-port LDZ DEO
|
||||
LIT "; .Console/w DEO
|
||||
.cur-x LDZ2 INC2 emit-dec2
|
||||
LIT "R ( .Console/proc-put ) .put-port LDZ DEO
|
||||
LIT "R .Console/w DEO
|
||||
&done BRK
|
||||
|
||||
@cnl ( n* -> ) clear-cursor #0000 .cur-x STZ2 !down-n
|
||||
|
|
@ -1011,9 +948,7 @@
|
|||
JMP2r
|
||||
|
||||
@on-read-esc ( -> BRK )
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
.Console/r DEI
|
||||
DUP debug-esc
|
||||
DUP LIT "D EQU ?exec-ind
|
||||
DUP LIT "E EQU ?exec-nel
|
||||
|
|
@ -1060,9 +995,7 @@
|
|||
POP reset-args ;on-read-osc .Console/vect DEO2 BRK
|
||||
|
||||
@on-read ( -> BRK )
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI read BRK
|
||||
.Console/r DEI read BRK
|
||||
|
||||
@read ( c^ -> )
|
||||
DUP debug-read
|
||||
|
|
@ -1290,7 +1223,7 @@
|
|||
JMP2r ( )
|
||||
|
||||
@highlight-cell ( cell* -> )
|
||||
NIP LITr 07 ( c^ [tint^] )
|
||||
NIP LITr 47 ( c^ [tint^] )
|
||||
#00 SWP #40 SFT2 ;cp437 ADD2 ( addr* [tint^] )
|
||||
.Screen/addr DEO2k ( addr* s^ [tint^] )
|
||||
STHkr .Screen/sprite DEO ( addr* s^ [tint^] )
|
||||
|
|
@ -1323,21 +1256,14 @@
|
|||
|
||||
( emit a signed short as a decimal )
|
||||
@emit-sdec2 ( n* -> )
|
||||
DUP2k #1f SFT2 EQUk ?&s LIT "- ( .Console/proc-put ) .put-port LDZ DEO
|
||||
DUP2k #1f SFT2 EQUk ?&s LIT2 "- 18 DEO
|
||||
&s MUL2 SUB2 ( fall-through to emit-dec2 )
|
||||
|
||||
( emit an unsigned short as a decimal )
|
||||
@emit-dec2 ( n* -> )
|
||||
LIT2r ff00 ( n* [ff^ 0^] )
|
||||
&read ( ... x* )
|
||||
#000a DIV2k STH2k ( x* 10* x/10* [ff^ i^ x/10*] )
|
||||
MUL2 SUB2 STH2r ( x%10* x/10* [ff^ i^] )
|
||||
INCr ORAk ?&read ( x%10* x/10* [ff^ i+1^] )
|
||||
POP2 ( x0* ... xn* [ff^ i+1^] )
|
||||
&write
|
||||
NIP #30 ADD ( .Console/proc-put ) .put-port LDZ DEO ( x0* ... xn-1* [ff^ j^] )
|
||||
OVRr ADDr STHkr ?&write ( x* ... xn-1* [ff^ j-1^] )
|
||||
POP2r JMP2r ( )
|
||||
LITr ff00 &read #000a DIV2k STH2k MUL2 SUB2 STH2r INCr ORAk ?&read
|
||||
POP2 &write NIP #30 ADD #18 DEO OVRr ADDr STHkr ?&write
|
||||
POP2r JMP2r
|
||||
|
||||
@debug-log "debug_term.log 00
|
||||
@scratch $40 &pos $2
|
||||
|
|
@ -1374,9 +1300,9 @@
|
|||
0d 0a
|
||||
20 20 c9 cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd bb 0d 0a
|
||||
20 20 ba 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ba 0d 0a
|
||||
20 20 ba 20 20 "d "e "t "e "r "m 20 20 "v "1 "2 20 20 ba 0d 0a
|
||||
20 20 ba 20 20 "d "e "t "e "r "m 20 20 "v "1 "0 20 20 ba 0d 0a
|
||||
20 20 ba 20 20 20 20 "b "y 20 "d "_ "m 20 20 20 20 20 ba 0d 0a
|
||||
20 20 ba 20 20 "1 "5 20 "d "e "c 20 "2 "0 "2 "3 20 20 ba 0d 0a
|
||||
20 20 ba 20 20 "1 "8 20 "m "a "r 20 "2 "0 "2 "3 20 20 ba 0d 0a
|
||||
20 20 ba 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ba 0d 0a
|
||||
20 20 c8 cd cd cb cd cd cd cd cd cd cd cd cd cb cd cd bc 0d 0a
|
||||
20 20 c9 cb cb ce cb cb cb cb cb cb cb cb cb ce cb cb bb 0d 0a
|
||||
|
|
|
|||
|
|
@ -4,16 +4,15 @@ from math import ceil, copysign, cos, floor, log, sin, sqrt, tan
|
|||
from os import environ
|
||||
from random import randint
|
||||
from subprocess import Popen, PIPE, run
|
||||
from sys import argv, exit
|
||||
|
||||
def tosigned(x):
|
||||
return x if x < 32768 else x - 65536
|
||||
|
||||
u8 = {'sz': 1 << 8, 'fmt': b'%02x'}
|
||||
x16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
z16 = {'sz': 1 << 16, 'fmt': b'%04x'} # non-zero
|
||||
p16 = {'sz': 1 << 16, 'fmt': b'%04x'} # positive
|
||||
t16 = {'sz': 1 << 16, 'fmt': b'%04x'} # tangent, must not be pi/2
|
||||
u16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
z16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
p16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
t16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
|
||||
def eq(got, expected):
|
||||
return got == expected
|
||||
|
|
@ -26,7 +25,7 @@ def releq(got0, expected0):
|
|||
else:
|
||||
error = abs(got - expected) / (abs(expected) + 0.001)
|
||||
return error < 0.01
|
||||
def sineq(got0, expected0):
|
||||
def abseq(got0, expected0):
|
||||
got, expected = tosigned(got0), tosigned(expected0)
|
||||
if (expected - 10) <= got and got <= (expected + 10):
|
||||
return True
|
||||
|
|
@ -46,7 +45,6 @@ def testcase(p, sym, args, out, f, eq):
|
|||
val = randint(0, g['sz'] - 1)
|
||||
while ((val == 0 and (g is z16 or g is p16)) or
|
||||
(val >= 0x8000 and g is p16) or
|
||||
(val == 0x8000 and g is x16) or
|
||||
(g is t16 and ((val >= 804) or ((val % 804) == 402)))):
|
||||
val = randint(0, g['sz'] - 1)
|
||||
vals.append((name, g, val))
|
||||
|
|
@ -81,24 +79,6 @@ def test(p, trials, sym, args, out, f, eq=eq):
|
|||
else:
|
||||
print('%s failed %d/%d trials (%r)' % (name, fails, trials, cases))
|
||||
|
||||
def fromfix(n):
|
||||
assert 0 <= n and n <= 65535
|
||||
if n >= 32768:
|
||||
res = (n - 65536) / 256
|
||||
else:
|
||||
res = n / 256
|
||||
return res
|
||||
|
||||
bound = 32767 / 256
|
||||
|
||||
def tofix(x):
|
||||
y = min(max(x, -bound), bound)
|
||||
if y < 0:
|
||||
res = int(ceil(65536 + y * 256))
|
||||
else:
|
||||
res = int(y * 256)
|
||||
return res % 65536
|
||||
|
||||
def pipe():
|
||||
return Popen(['uxncli', 'run.rom'], stdin=PIPE, stdout=PIPE)
|
||||
|
||||
|
|
@ -107,17 +87,11 @@ def x16_add(x, y):
|
|||
def x16_sub(x, y):
|
||||
return (x - y) % 65536
|
||||
def x16_mul(x, y):
|
||||
return tofix(fromfix(x) * fromfix(y))
|
||||
return ((x * y) // 256) % 65536
|
||||
def x16_div(x, y):
|
||||
return tofix(fromfix(x) / fromfix(y))
|
||||
return ((x * 256) // y) % 65536
|
||||
def x16_quot(x, y):
|
||||
n = x16_div(x, y)
|
||||
if n < 0x7fff:
|
||||
return n & 0xff00
|
||||
elif n > 0x8001:
|
||||
return (n + 255) & 0xff00
|
||||
else:
|
||||
return n
|
||||
return x16_div(x, y) & 0xff00
|
||||
def x16_rem(x, y):
|
||||
return x % y
|
||||
def x16_is_whole(x):
|
||||
|
|
@ -173,38 +147,33 @@ def x16_trunc8(x):
|
|||
return floor(x / 256)
|
||||
|
||||
def main():
|
||||
trials = int(argv[1]) if argv[1:] else 100
|
||||
e = run(['uxnasm', 'test-fix16.tal', 'run.rom'])
|
||||
if e.returncode != 0:
|
||||
print('the command `uxnasm test-fix16.tal run.rom` failed!')
|
||||
exit(e.returncode)
|
||||
trials = 1000
|
||||
run(['uxnasm', 'test-fix16.tal', 'run.rom'])
|
||||
p = pipe()
|
||||
test(p, trials, b'+', [('x', x16), ('y', x16)], x16, x16_add)
|
||||
test(p, trials, b'-', [('x', x16), ('y', x16)], x16, x16_sub)
|
||||
test(p, trials, b'*', [('x', x16), ('y', x16)], x16, x16_mul)
|
||||
test(p, trials, b'/', [('x', x16), ('y', z16)], x16, x16_div)
|
||||
test(p, trials, b'\\', [('x', x16), ('y', z16)], x16, x16_quot)
|
||||
test(p, trials, b'%', [('x', x16), ('y', z16)], x16, x16_rem)
|
||||
test(p, trials, b'w', [('x', x16)], u8, x16_is_whole, eq=booleq)
|
||||
test(p, trials, b'N', [('x', x16)], x16, x16_negate)
|
||||
test(p, trials, b'=', [('x', x16), ('y', x16)], u8, x16_eq)
|
||||
test(p, trials, b'!', [('x', x16), ('y', x16)], u8, x16_ne)
|
||||
test(p, trials, b'<', [('x', x16), ('y', x16)], u8, x16_lt)
|
||||
test(p, trials, b'>', [('x', x16), ('y', x16)], u8, x16_gt)
|
||||
test(p, trials, b'{', [('x', x16), ('y', x16)], u8, x16_lteq)
|
||||
test(p, trials, b'}', [('x', x16), ('y', x16)], u8, x16_gteq)
|
||||
test(p, trials, b'F', [('x', x16)], x16, x16_floor)
|
||||
test(p, trials, b'C', [('x', x16)], x16, x16_ceil)
|
||||
test(p, trials, b'R', [('x', x16)], x16, x16_round)
|
||||
test(p, trials, b'8', [('x', x16)], x16, x16_trunc8)
|
||||
test(p, trials, b'T', [('x', x16)], x16, x16_trunc16)
|
||||
# the next five are known to be somewhat inaccurate and use
|
||||
# a "relaxed" equality predicate for testing purposes.
|
||||
test(p, trials, b'r', [('x', p16)], x16, x16_sqrt, eq=releq)
|
||||
test(p, trials, b's', [('x', p16)], x16, x16_sin, eq=sineq)
|
||||
test(p, trials, b'c', [('x', p16)], x16, x16_cos, eq=sineq)
|
||||
test(p, trials, b't', [('x', t16)], x16, x16_tan, eq=taneq)
|
||||
test(p, trials, b'l', [('x', p16)], x16, x16_log, eq=releq)
|
||||
test(p, trials, b'+', [('x', u16), ('y', u16)], u16, x16_add)
|
||||
test(p, trials, b'-', [('x', u16), ('y', u16)], u16, x16_sub)
|
||||
test(p, trials, b'*', [('x', u16), ('y', u16)], u16, x16_mul)
|
||||
test(p, trials, b'/', [('x', u16), ('y', z16)], u16, x16_div, eq=releq)
|
||||
test(p, trials, b'\\', [('x', u16), ('y', z16)], u16, x16_quot)
|
||||
test(p, trials, b'%', [('x', u16), ('y', z16)], u16, x16_rem)
|
||||
test(p, trials, b'w', [('x', u16)], u8, x16_is_whole, eq=booleq)
|
||||
test(p, trials, b'N', [('x', u16)], u16, x16_negate)
|
||||
test(p, trials, b'=', [('x', u16), ('y', u16)], u8, x16_eq)
|
||||
test(p, trials, b'!', [('x', u16), ('y', u16)], u8, x16_ne)
|
||||
test(p, trials, b'<', [('x', u16), ('y', u16)], u8, x16_lt)
|
||||
test(p, trials, b'>', [('x', u16), ('y', u16)], u8, x16_gt)
|
||||
test(p, trials, b'{', [('x', u16), ('y', u16)], u8, x16_lteq)
|
||||
test(p, trials, b'}', [('x', u16), ('y', u16)], u8, x16_gteq)
|
||||
test(p, trials, b'r', [('x', p16)], u16, x16_sqrt, eq=releq)
|
||||
test(p, trials, b's', [('x', p16)], u16, x16_sin, eq=abseq)
|
||||
test(p, trials, b'c', [('x', p16)], u16, x16_cos, eq=abseq)
|
||||
test(p, trials, b't', [('x', t16)], u16, x16_tan, eq=taneq)
|
||||
test(p, trials, b'l', [('x', p16)], u16, x16_log, eq=releq)
|
||||
test(p, trials, b'F', [('x', u16)], u16, x16_floor)
|
||||
test(p, trials, b'C', [('x', u16)], u16, x16_ceil)
|
||||
test(p, trials, b'R', [('x', u16)], u16, x16_round)
|
||||
test(p, trials, b'8', [('x', u16)], u16, x16_trunc8)
|
||||
test(p, trials, b'T', [('x', u16)], u16, x16_trunc16)
|
||||
p.stdin.write(b'\n\n')
|
||||
p.stdin.flush()
|
||||
p.stdin.close()
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
155
uxnrepl.py
155
uxnrepl.py
|
|
@ -1,155 +0,0 @@
|
|||
#!/usr/bin/python
|
||||
|
||||
from os import system
|
||||
import re
|
||||
from socket import socket, AF_INET, SOCK_STREAM
|
||||
from subprocess import run, TimeoutExpired
|
||||
from sys import argv, stdin, stdout
|
||||
from tempfile import mkdtemp, mkstemp
|
||||
|
||||
sandbox = None
|
||||
irc = None
|
||||
|
||||
template = '''
|
||||
|0100
|
||||
;on-console #10 DEO2
|
||||
|
||||
( start ) %s ( end ) BRK
|
||||
|
||||
@on-console ( -> BRK )
|
||||
#05 DEI ,emit-wst/n STR
|
||||
;wst print
|
||||
|
||||
@dump-wst
|
||||
#04 DEI #01 GTH ?&next !emit-wst &next STH !dump-wst
|
||||
|
||||
@emit-wst
|
||||
#05 DEI LIT [ &n $1 ] GTH ?&next #0a18 DEO !start-rst
|
||||
&next STHr emit #2018 DEO !emit-wst
|
||||
|
||||
@start-rst
|
||||
;rst print
|
||||
|
||||
@dump-rst
|
||||
#05 DEI #00 GTH ?&next !emit-rst &next STHr !dump-rst
|
||||
|
||||
@emit-rst
|
||||
#04 DEI #01 GTH ?&next #0a18 DEO #800f DEO BRK
|
||||
&next emit #2018 DEO !emit-rst
|
||||
|
||||
@print ( addr* -> )
|
||||
LDAk DUP ?{ POP POP2 JMP2r } #18 DEO INC2 !print
|
||||
|
||||
@emit
|
||||
DUP #04 SFT ,&ch JSR
|
||||
&ch #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO JMP2r
|
||||
|
||||
@rst "rst 20 00
|
||||
@wst "wst 20 00
|
||||
'''
|
||||
|
||||
def write_rom(path, s):
|
||||
f = open(path, 'w')
|
||||
prog = template % s
|
||||
f.write(prog)
|
||||
f.close()
|
||||
|
||||
def execute(s, sandbox=None, timeout=2.0):
|
||||
_, tmp_tal = mkstemp(suffix='.tal', prefix='uxnrepl')
|
||||
_, tmp_rom = mkstemp(suffix='.rom', prefix='uxnrepl')
|
||||
write_rom(tmp_tal, s)
|
||||
try:
|
||||
res = run(['uxnasm', tmp_tal, tmp_rom], cwd=sandbox, capture_output=True, timeout=timeout)
|
||||
except TimeoutExpired:
|
||||
return b'uxnasm: timed out'
|
||||
if res.returncode != 0:
|
||||
return res.stderr
|
||||
try:
|
||||
res = run(['uxncli', tmp_rom, 'trigger'], cwd=sandbox, capture_output=True, timeout=timeout)
|
||||
except TimeoutExpired:
|
||||
return b'uxncli: timed out'
|
||||
return res.stdout
|
||||
|
||||
def repl():
|
||||
print('uxnrepl (ctrl-d to exit)')
|
||||
while True:
|
||||
stdout.write('> ')
|
||||
stdout.flush()
|
||||
s = stdin.readline()
|
||||
if not s:
|
||||
print('bye!')
|
||||
break
|
||||
stdout.write(execute(s).decode('utf-8'))
|
||||
stdout.flush()
|
||||
|
||||
ping_re = re.compile(br'PING (.+)$')
|
||||
|
||||
def send(msg, quiet=False):
|
||||
if not quiet:
|
||||
print('>>> %r' % msg)
|
||||
irc.send(msg + b'\r\n')
|
||||
|
||||
def recv():
|
||||
msg = irc.recv(2040)
|
||||
if not ping_re.match(msg):
|
||||
print('<<< %r' % msg)
|
||||
return msg
|
||||
|
||||
def evaluate(msg):
|
||||
output = execute(msg.decode('utf-8'), sandbox=sandbox)
|
||||
lines = [s.strip() for s in output.split(b'\n')]
|
||||
interesting = [s for s in lines if s and s != 'wst' and s != 'rst']
|
||||
result = b' | '.join(interesting)
|
||||
print('*** executing %r gave %r -> %r -> %r' % (msg, output, interesting, result))
|
||||
return result
|
||||
|
||||
def ircbot(server, nick, channel):
|
||||
global sandbox, irc
|
||||
sandbox = mkdtemp(prefix='uxnrepl')
|
||||
irc = socket(AF_INET, SOCK_STREAM)
|
||||
|
||||
irc.connect((server, 6667))
|
||||
send(b"USER %s %s %s :bot for testing uxntal code" % (nick, nick, nick))
|
||||
send(b"NICK %s" % nick)
|
||||
send(b"JOIN %s" % channel)
|
||||
|
||||
chan_msg_re = re.compile(br':([^!]+)![^ ]+ PRIVMSG ([^ ]+) :' + nick + br': (.*)$')
|
||||
priv_msg_re = re.compile(br':([^!]+)![^ ]+ PRIVMSG ' + nick + br' :(.*)$')
|
||||
|
||||
while True:
|
||||
text = recv()
|
||||
|
||||
m = ping_re.match(text)
|
||||
if m:
|
||||
send(b'PONG %s' % m.group(1).strip(), quiet=True)
|
||||
continue
|
||||
|
||||
m = chan_msg_re.match(text)
|
||||
if m and m.group(2) == channel:
|
||||
user = m.group(1)
|
||||
msg = m.group(3).strip()
|
||||
result = evaluate(msg)
|
||||
send(b'PRIVMSG %s :%s: %s' % (channel, user, result))
|
||||
continue
|
||||
|
||||
m = priv_msg_re.match(text)
|
||||
if m:
|
||||
user = m.group(1)
|
||||
msg = m.group(2).strip()
|
||||
result = evaluate(msg)
|
||||
send(b'PRIVMSG %s :%s' % (user, result))
|
||||
continue
|
||||
|
||||
def main():
|
||||
if argv[1:] == [] or argv[1:] == ["repl"]:
|
||||
repl()
|
||||
elif argv[1] == "bot" and len(argv) == 5:
|
||||
server, nick, channel = argv[2:]
|
||||
ircbot(server, nick.encode('utf-8'), channel.encode('utf-8'))
|
||||
else:
|
||||
print("usage: %s [repl]" % argv[0])
|
||||
print(" %s bot <server> <nick> <channel>" % argv[0])
|
||||
exit(1)
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
148
wave.tal
148
wave.tal
|
|
@ -37,8 +37,10 @@
|
|||
|
||||
( |00 @System [ &vec $2 &wst $1 &rst $1 &pad $4 &r $2 &g $2 &b $2 &dbg $1 &halt $1 ] )
|
||||
|10 @Console [ &vec $2 &read $1 &pad $5 &out $1 &err $1 ]
|
||||
|30 @Audio0 [ &vec $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|40 @Audio1 [ &vec $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|30 @Audio0 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|40 @Audio1 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|50 @Audio2 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|60 @Audio3 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|
||||
|a0 @File [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|
||||
|0000
|
||||
|
|
@ -75,10 +77,10 @@
|
|||
&done
|
||||
LIT2 =reload/resample STA2 ( ; save resample function )
|
||||
LIT2r =reload/sft STAr ( ; save shift size )
|
||||
#2274 .File/len DEO2
|
||||
#2274 DUP2 ;a/len STA2 DUP2 ;a/l-buf zero-buf-u8 DUP2 ;a/r-buf zero-buf-u8
|
||||
DUP2 ;b/len STA2 DUP2 ;b/l-buf zero-buf-u8 ;b/r-buf zero-buf-u8
|
||||
!play-a
|
||||
#2000 .File/len DEO2
|
||||
#2000 ;len0 STA2 #2000 ;buf0 zero-buf-u8
|
||||
#2000 ;len1 STA2 #2000 ;buf1 zero-buf-u8
|
||||
!play0
|
||||
|
||||
@zero-buf-u8 ( len* buf* -> )
|
||||
STH2k ADD2 STH2 SWP2r ( [limit=buf+len* buf*] )
|
||||
|
|
@ -103,96 +105,68 @@
|
|||
@hdr-eq2 ( offset* v* -> eq^ )
|
||||
STH2 ;header ADD2 LDA2 STH2r EQU2 JMP2r
|
||||
|
||||
@reload ( l-addr* bl-addr* br-addr* -> )
|
||||
SWP2 STH2 STH2 ( l-addr* [bl-addr* br-addr*] )
|
||||
.done LDZ ?&skip ( l-addr* [bl-addr* br-addr*] )
|
||||
;scratch .File/r DEO2 ( l-addr* [bl-addr* br-addr*] )
|
||||
.File/ok DEI2 ( l-addr* read* [bl-addr* br-addr*] )
|
||||
DUP2 LIT &sft $1 SFT2 ( l-addr* read* read>>sft [bl-addr* br-addr*] )
|
||||
ROT2 STA2 ( read* [bl-addr* br-addr*] ; l-addr<-read>>sft )
|
||||
DUP2 #2274 EQU2 ?&end ( read* [bl-addr* br-addr*] ; if we read 0x2274 we are not done )
|
||||
#01 .done STZ ( read* [bl-addr* br-addr*] ; done<-1 )
|
||||
&end ( read* [bl-addr* br-addr*] )
|
||||
;scratch ( read* scratch* [bl-addr* br-addr*] )
|
||||
DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [bl-addr* br-addr*] )
|
||||
INC2 ( limit* scratch+1* [bl-addr* br-addr*] )
|
||||
&loop ( limit* pos* [bl-pos* br-pos*] )
|
||||
LIT2 [ &resample $2 ] JSR2 ( limit* pos+n* l-sample^ r-sample^ [bl-pos* br-pos*] )
|
||||
STH2kr STA INC2 SWP2r ( limit* pos+n* [br-pos+1* bl-pos*] ; br-pos<-sample )
|
||||
STH2kr STA INC2 SWP2r ( limit* pos+n* [bl-pos+1* br-pos+1*] ; bl-pos<-sample )
|
||||
GTH2k ?&loop ( limit* pos+n* [bl-pos+1* br-pos+1*] )
|
||||
POP2r POP2r POP2 POP2 JMP2r ( )
|
||||
&skip ( l-addr* [bl-addr* br-addr*] )
|
||||
#2274 DUP2 STH2r zero-buf-u8 ( l-addr* #2274 [bl-addr*] ; clear br-addr )
|
||||
DUP2 STH2r zero-buf-u8 ( l-addr* #2274 ; clear bl-addr )
|
||||
SWP2 STA2 JMP2r ( ; l-addr<-2274 )
|
||||
@reload ( l-addr* b-addr* -> )
|
||||
.done LDZ ?&skip ( l-addr* b-addr* )
|
||||
SWP2 ( b-addr* l-addr* )
|
||||
;scratch .File/r DEO2 ( b-addr* l-addr* )
|
||||
.File/ok DEI2 ( b-addr* l-addr* read* )
|
||||
DUP2 LIT &sft $1 SFT2 ( b-addr* l-addr* read* read>>sft )
|
||||
ROT2 STA2 ( b-addr* read* ; l-addr<-read>>sft )
|
||||
DUP2 #2000 EQU2 ?&end ( b-addr* read* ; if we read 0x2000 we are not done )
|
||||
#01 .done STZ ( b-addr* read* ; done<-1 )
|
||||
&end ( b-addr* read* )
|
||||
SWP2 STH2 ;scratch ( read* scratch* [b-addr*] )
|
||||
DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [b-addr*] )
|
||||
INC2 ( limit* scratch+1* [b-addr*] )
|
||||
&loop ( limit* pos* [bpos*] )
|
||||
LIT2 &resample $2 JSR2 ( limit* pos+n* sample^ [bpos*] )
|
||||
STH2kr STA ( limit* pos+n* [bpos*] ; bpos<-sample )
|
||||
INC2r GTH2k ?&loop ( limit* pos+n* [bpos+1*] )
|
||||
POP2r ( limit* pos+n* )
|
||||
POP2 POP2 JMP2r
|
||||
&skip ( )
|
||||
#2000 SWP2 zero-buf-u8 ( )
|
||||
#2000 SWP2 STA2 JMP2r ( )
|
||||
|
||||
@mono-u8-to-u8 ( pos* -> pos+1* l-sample^ r-sample^ )
|
||||
LDAk STH INC2 ( pos+1* [s^] )
|
||||
STHr DUP JMP2r ( pos+1 l-s^ r-s^ )
|
||||
@mono-u8-to-u8 ( pos* -> pos+1* sample^ )
|
||||
LDAk STH INC2 STHr JMP2r
|
||||
|
||||
@mono-s16-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ )
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+2* [s^] )
|
||||
STHr DUP JMP2r ( pos+2* l-s^ r-s^ )
|
||||
@mono-s16-to-u8 ( pos* -> pos+2* sample^ )
|
||||
LDAk #80 EOR STH INC2 INC2 STHr JMP2r
|
||||
|
||||
@stereo-u8-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ )
|
||||
INC2k SWP2 LDA STH ( pos+1* [l-s^] )
|
||||
INC2k SWP2 LDA STH ( pos+2* [l-s^ r-s^] )
|
||||
STH2r JMP2r ( pos+2* l-s^ r-s^ )
|
||||
@stereo-u8-to-u8 ( pos* -> pos+2* sample^ )
|
||||
LDAk #00 SWP STH2 INC2
|
||||
LDAk #00 SWP STH2 INC2
|
||||
ADD2r LITr 01 SFT2r NIPr STHr JMP2r
|
||||
|
||||
@stereo-s16-to-u8 ( pos* -> pos+4* sample^ )
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+2* [l-s^] )
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+4* [l-s^ r-s^] )
|
||||
STH2r JMP2r ( pos+4* l-s^ r-s^ )
|
||||
LDAk #80 EOR #00 SWP STH2 INC2 INC2
|
||||
LDAk #80 EOR #00 SWP STH2 INC2 INC2
|
||||
ADD2r LITr 01 SFT2r NIPr STHr JMP2r
|
||||
|
||||
@play-a ( -> ) ;play-b ;a !play-base
|
||||
@play-b ( -> ) ;play-a ;b !play-base
|
||||
@play0 ( -> ) ;play1 ;len0 ;buf0 !play
|
||||
@play1 ( -> ) ;play0 ;len1 ;buf1 !play
|
||||
|
||||
@play-base ( next* base* -> )
|
||||
SWP2 .Audio0/vec DEO2 ( base* ; vec<-next )
|
||||
INC2k INC2 STH2k ( l-addr* lb-addr* [lb-addr*] )
|
||||
#2274 ADD2 STH2 ( l-addr* [lb-addr* rb-addr*] )
|
||||
( LDA2k ORAk ?&non-zero ( l-addr* n* [lb-addr* rb-addr*] )
|
||||
POP2 POP2 POP2r POP2r ( ; clear stack )
|
||||
#010f BRK ( ; exit )
|
||||
&non-zero ( l-addr* n* [lb-addr* rb-addr*] ) )
|
||||
DUP2 STH2kr r-output SWP2r ( l-addr* n* [rb-addr* lb-addr*] ; play rb-addr )
|
||||
STH2kr l-output SWP2r ( l-addr* [lb-addr* rb-addr*] ; play lb-addr )
|
||||
SWP2r STH2r STH2r reload BRK ( ; load more data )
|
||||
@play ( next* l-addr* b-addr* -> )
|
||||
OVR2 LDA2 ORAk ?&nonzero ( next* l-addr* b-addr* n* )
|
||||
POP2 POP2 POP2 POP2 ( ; clear stack )
|
||||
#010f BRK ( ; exit )
|
||||
&nonzero ( next* l-addr b-addr* n* )
|
||||
OVR2 output ( next* l-addr b-addr* ; play buf1 )
|
||||
reload ( next* ; load more data )
|
||||
.Audio0/vec DEO2 ( ; Audio0/vec<-next )
|
||||
BRK ( )
|
||||
|
||||
@bytes-to-millis ( samples* -> ms* )
|
||||
#01b9 DIV2 #000a MUL2 JMP2r
|
||||
|
||||
@l-output ( len* addr* -> )
|
||||
.Audio0/addr DEO2 ( ; <- write buf addr )
|
||||
DUP2 .Audio0/len DEO2 ( ; <- write length in bytes/samples )
|
||||
bytes-to-millis .Audio0/dur DEO2 ( ; <- write duration in milliseconds )
|
||||
#00f0 .Audio0/adsr DEO2 ( ; <- write ignore envelope )
|
||||
#f0 .Audio0/vol DEO ( ; <- play 100% volume )
|
||||
#bc .Audio0/pitch DEO ( ; <- play standard sample once )
|
||||
@output ( len* addr* -> )
|
||||
.Audio0/addr DEO2 ( ; <- write buf addr )
|
||||
.Audio0/len DEO2 ( ; <- write len )
|
||||
#0000 .Audio0/adsr DEO2 ( ; <- write ignore envelope )
|
||||
#ff .Audio0/vol DEO ( ; <- play 100% volume )
|
||||
#bc .Audio0/pitch DEO ( ; <- play standard sample once )
|
||||
JMP2r
|
||||
|
||||
@r-output ( len* addr* -> )
|
||||
.Audio1/addr DEO2 ( ; <- write buf addr )
|
||||
DUP2 .Audio1/len DEO2 ( ; <- write length in bytes/samples )
|
||||
bytes-to-millis .Audio1/dur DEO2 ( ; <- write duration in milliseconds )
|
||||
#00f0 .Audio1/adsr DEO2 ( ; <- write ignore envelope )
|
||||
#0f .Audio1/vol DEO ( ; <- play 100% volume )
|
||||
#bc .Audio1/pitch DEO ( ; <- play standard sample once )
|
||||
JMP2r
|
||||
|
||||
( buffer size is 0x2274, i.e. 8820. )
|
||||
( this is an important number: 8820 = 4 * 5 * 441. )
|
||||
( since it is divisible by 4 we know that the buffer will read )
|
||||
( an exact number of samples, even with 16-bit stereo. and since )
|
||||
( it is divisble by 441 we know it will always contain a multiple )
|
||||
( 10 milliseconds of audio. these assumptions help ensure we don't )
|
||||
( end up with static, popping, or other problems. )
|
||||
@filename $100
|
||||
@header $2c
|
||||
( @len0 $2 @buf0 $2274
|
||||
@len1 $2 @buf1 $2274 )
|
||||
@scratch $2274
|
||||
|
||||
@a [ &len $2 &l-buf $2274 &r-buf $2274 ]
|
||||
@b [ &len $2 &l-buf $2274 &r-buf $2274 ]
|
||||
@len0 $2 @buf0 $2000
|
||||
@len1 $2 @buf1 $2000
|
||||
@scratch $2000
|
||||
|
|
|
|||
315
zenochat.tal
315
zenochat.tal
|
|
@ -1,315 +0,0 @@
|
|||
( zenochat.tal )
|
||||
( )
|
||||
( USAGE: uxnemu zenochat.rom ADDR PORT NICK )
|
||||
( )
|
||||
( COMMANDS DESCRIPTION )
|
||||
( /help show help message )
|
||||
( /names list the current people in the chat )
|
||||
( /rename NICK change nickname to NICK )
|
||||
( /quit exit the program )
|
||||
( )
|
||||
( DETAILS )
|
||||
( - max nickname is 8 characters long, not including null )
|
||||
( - no history, no scrolling )
|
||||
( - no direct messages, yet )
|
||||
( )
|
||||
( MESSAGES )
|
||||
( - 27 visible lines, 80 chars per line )
|
||||
( - 5 chars: time "12:34" )
|
||||
( - 1 char: space )
|
||||
( - 8 chars: username "theodore" )
|
||||
( - 1 char: space )
|
||||
( - 65 chars: message line )
|
||||
( )
|
||||
( HISTORY LINE )
|
||||
( - each history line is 80 bytes )
|
||||
( - 1 byte: flags, 0x80 is-system, 0x01 is-continued )
|
||||
( - 2 bytes: padding )
|
||||
( - 2 bytes: hour [0-23] and minute [0-59] )
|
||||
( - 9 bytes: nickname + null terminator; empty means system )
|
||||
( - 66 bytes: text + null terminator )
|
||||
( - window dimensions: 30 rows by 80 columns )
|
||||
( - 27 visible lines; 65 text columns )
|
||||
( )
|
||||
( USER LIST )
|
||||
( - 9 bytes, nickname + null terminator )
|
||||
|
||||
|00 @System [ &vect $2 &expansion $2 &title $2 &metadata $2 &r $2 &g $2 &b $2 &dbg $1 &st $1 ]
|
||||
|10 @Console [ &vect $2 &r $1 &pad $4 &type $1 &w $1 &e $1 ]
|
||||
|20 @Screen [ &vect $2 &w $2 &h $2 &auto $1 &pad $1 &x $2 &y $2 &addr $2 &px $1 &sprite $1 ]
|
||||
|80 @Controller [ &vect $2 &button $1 &key $1 &fn $1 ]
|
||||
|90 @Mouse [ &vect $2 &x $2 &y $2 &state $1 &pad $3 &scrollx $2 &scrolly $2 ]
|
||||
|a0 @File1 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|b0 @File2 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|
||||
|c0 @DateTime [ &year $2 &month $1 &day $1 &hr $1 &min $1 &sec $1 &dotw $1 &doty $2 &dst $1 ]
|
||||
|
||||
|0000
|
||||
@pos $2
|
||||
@dirty $1
|
||||
@last-sec $1
|
||||
|
||||
|0100
|
||||
( system settings )
|
||||
#0280 .Screen/w DEO2
|
||||
#0168 .Screen/h DEO2
|
||||
#27ff .System/r DEO2
|
||||
#039b .System/g DEO2
|
||||
#1107 .System/b DEO2
|
||||
|
||||
( zero page )
|
||||
#01 .dirty STZ
|
||||
;input .pos STZ2
|
||||
|
||||
( vectors )
|
||||
;on-refresh .Screen/vect DEO2
|
||||
;on-key .Controller/vect DEO2
|
||||
;read-args .Console/vect DEO2
|
||||
BRK
|
||||
|
||||
@usage "usage: 20 "zenochat.rom 20 "chat.server.net 20 "9999 20 "nick 0a 00
|
||||
|
||||
@usage-and-exit ( -> BRK )
|
||||
;usage emit #01 .System/st DEO BRK
|
||||
|
||||
@read-arg ( -> BRK )
|
||||
.Console/r DEI .pos LDZ2 STA
|
||||
.pos LDZ2k INC2 ROT STZ2 BRK
|
||||
|
||||
@save-arg ( dst* maxlen* -> )
|
||||
#00 .pos LDZ2 STA
|
||||
.pos LDZ2 ;input SUB2
|
||||
LTH2 ?usage-and-exit
|
||||
;input emit #0a18 DEO
|
||||
;input SWP2 copy
|
||||
;input .pos STZ2 JMP2r
|
||||
|
||||
@read-args ( -> BRK )
|
||||
.Console/type DEI #00 EQU ?usage-and-exit
|
||||
.Console/type DEI #01 EQU ?usage-and-exit
|
||||
.Console/type DEI #02 EQU ?read-arg
|
||||
( state is 3 or 4 )
|
||||
;addr LDA #00 EQU ?&addr
|
||||
;port LDA #00 EQU ?&port
|
||||
;nick LDA #00 EQU ?&nick
|
||||
!usage-and-exit
|
||||
&addr ;addr #00ff save-arg BRK
|
||||
&port ;port #0005 save-arg BRK
|
||||
&nick ;nick #000f save-arg
|
||||
.Console/type DEI #04 NEQ ?usage-and-exit
|
||||
;read-stdin .Console/vect DEO2
|
||||
BRK
|
||||
|
||||
@read-stdin ( -> BRK ) BRK
|
||||
|
||||
@start-client ( -> BRK ) BRK
|
||||
|
||||
@update-clock ( -> )
|
||||
LITr -last-sec STHkr LDZ ( ls^ [zp^] )
|
||||
.DateTime/sec DEI DUP STHr STZ ( ls^ s^ ; zp<-s )
|
||||
NEQ .dirty STZ JMP2r ( ; dirty<-s!=ls )
|
||||
|
||||
@on-refresh ( -> BRK )
|
||||
update-clock
|
||||
.dirty LDZ ?&refresh BRK
|
||||
&refresh
|
||||
redraw
|
||||
#00 .dirty STZ BRK
|
||||
|
||||
@on-key ( -> BRK )
|
||||
.Controller/key DEI
|
||||
DUP #0d EQU ?&enter
|
||||
DUP #08 EQU ?&backspace
|
||||
DUP #20 LTH ?&skip
|
||||
DUP #7f GTH ?&skip
|
||||
.pos LDZ2 STA
|
||||
.pos LDZ2 INC2 .pos STZ2
|
||||
#00 .pos LDZ2 STA redraw BRK
|
||||
&enter POP send-msg redraw BRK
|
||||
&skip POP BRK
|
||||
&backspace
|
||||
;input .pos LDZ2 EQU2 ?&skip
|
||||
POP
|
||||
.pos LDZ2 #0001 SUB2 .pos STZ2
|
||||
#00 .pos LDZ2 STA #0028 #015c #4b clear-line redraw BRK
|
||||
|
||||
@clear-line ( x* y* len^ -> )
|
||||
#00 SWP SUB STH ( x* y* [-len^] )
|
||||
.Screen/y DEO2 .Screen/x DEO2 ( [-len^] )
|
||||
&loop ( [-i^] )
|
||||
#03 #20 draw-char ( [-i^] )
|
||||
.Screen/x DEI2k ( dev^ x* [-i^] )
|
||||
#0008 ADD2 ROT DEO2 ( [-i^] ; dev<-x+8 )
|
||||
INCr STHkr ?&loop ( [-i+1^] )
|
||||
POPr JMP2r ( )
|
||||
|
||||
@send-msg
|
||||
( ;input .pos LDZ2 #010e DEO POP2 POP2 )
|
||||
!clear-input
|
||||
|
||||
@clear-input ( -> )
|
||||
#0028 #015c #4b clear-line
|
||||
#0000 ;input STA2
|
||||
;input .pos STZ2 JMP2r
|
||||
|
||||
( TODO: write to intermediary buffers, then write to final topbar buffer )
|
||||
( this will allow us to handle "long" strings better, e.g. hostnames )
|
||||
( also consider reorder fields, put people before address )
|
||||
( write clock last unconditionally with leading space + glyph )
|
||||
@gui
|
||||
&topbar
|
||||
20 15 20 "z "e "n "o "c "h "a "t 20
|
||||
20 02 20
|
||||
&username
|
||||
"c "a "r "o "l "i "n "e 20
|
||||
20 03 20
|
||||
&users
|
||||
"1 "2 "9 20 "p "e "o "p "l "e 20
|
||||
20 1d 20
|
||||
&server
|
||||
( 2001:0db8:85a3:0000:0000:8a2e:0370:7334 - 39 characters long )
|
||||
( fe80::3210:b3ff:fe77:c5c6/64 )
|
||||
( 123.156.189.123 - 15 characters long )
|
||||
"1 "2 "3 ". "1 "5 "6 ". "1 "8 "9 ". "1 "2 "3 20 "1 "9 "9 "9 "9 20 20 20 20 20 20
|
||||
20 0f 20
|
||||
&hour
|
||||
"2 "2 ":
|
||||
&minute
|
||||
"0 "3 ":
|
||||
&second
|
||||
"0 "9
|
||||
20 00
|
||||
|
||||
&separator
|
||||
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
|
||||
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
|
||||
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
|
||||
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
|
||||
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
|
||||
00
|
||||
|
||||
&time1 "21:58 20 00
|
||||
&u1 "alice 20 00
|
||||
&msg1 "Isn't 20 "this 20 "whole 20 "thing 20 "kind 20 "of 20 "weird? 00
|
||||
|
||||
&time2 "21:59 20 00
|
||||
&u2 "bob 20 00
|
||||
&msg2 "Nah. 00
|
||||
|
||||
&info1 20 c4 c4 20 "013 20 "has 20 "connected 20 c4 c4 00
|
||||
|
||||
&time3 "22:02 20 00
|
||||
&u3 "caroline 20 00
|
||||
&msg3 "Well, 20 "I 20 "do 20 "think 20 "it's 20 "pretty 20 "wild... 00
|
||||
|
||||
&info2 20 c4 c4 20 "013 20 "is 20 "now 20 "called 20 "danny 20 c4 c4 00
|
||||
|
||||
&say "Say: 20 00
|
||||
&edit "This 20 "is 20 "a 20 "test. 00
|
||||
|
||||
@draw-str-at ( tint^ s* x* y* -> )
|
||||
.Screen/y DEO2 .Screen/x DEO2 !draw-str
|
||||
|
||||
@two-digit-copy ( n^ s* -> )
|
||||
STH2 DUP #0a DIVk MUL SUB ( n^ n%10^ [s*] )
|
||||
LIT "0 ADD STH2kr INC2 STA ( n^ [s*] ; s+1<-asc[n%10] )
|
||||
#0a DIV LIT "0 ADD STH2r STA ( ; s<-asc[n/10] )
|
||||
JMP2r ( )
|
||||
|
||||
@redraw ( -> )
|
||||
.DateTime/hr DEI ;gui/hour two-digit-copy
|
||||
.DateTime/min DEI ;gui/minute two-digit-copy
|
||||
.DateTime/sec DEI ;gui/second two-digit-copy
|
||||
|
||||
#06 ;gui/topbar #0000 #0000 draw-str-at
|
||||
|
||||
#03 ;gui/time1 #0000 #000c draw-str-at
|
||||
#02 ;gui/u1 #0030 #000c draw-str-at
|
||||
#03 ;gui/msg1 #0078 #000c draw-str-at
|
||||
|
||||
#03 ;gui/time2 #0000 #0018 draw-str-at
|
||||
#02 ;gui/u2 #0030 #0018 draw-str-at
|
||||
#03 ;gui/msg2 #0078 #0018 draw-str-at
|
||||
|
||||
#01 ;gui/info1 #0000 #0024 draw-str-at
|
||||
|
||||
#03 ;gui/time3 #0000 #0030 draw-str-at
|
||||
#02 ;gui/u3 #0030 #0030 draw-str-at
|
||||
#03 ;gui/msg3 #0078 #0030 draw-str-at
|
||||
|
||||
#01 ;gui/info2 #0000 #003c draw-str-at
|
||||
|
||||
#03 ;gui/edit #0078 #0048 draw-str-at
|
||||
#03 ;gui/edit #0078 #0054 draw-str-at
|
||||
#03 ;gui/edit #0078 #0060 draw-str-at
|
||||
#03 ;gui/edit #0078 #006c draw-str-at
|
||||
#03 ;gui/edit #0078 #0078 draw-str-at
|
||||
#03 ;gui/edit #0078 #0084 draw-str-at
|
||||
#03 ;gui/edit #0078 #0090 draw-str-at
|
||||
#03 ;gui/edit #0078 #009c draw-str-at
|
||||
#03 ;gui/edit #0078 #00a8 draw-str-at
|
||||
#03 ;gui/edit #0078 #00b4 draw-str-at
|
||||
#03 ;gui/edit #0078 #00c0 draw-str-at
|
||||
#03 ;gui/edit #0078 #00cc draw-str-at
|
||||
#03 ;gui/edit #0078 #00d8 draw-str-at
|
||||
#03 ;gui/edit #0078 #00e4 draw-str-at
|
||||
#03 ;gui/edit #0078 #00f0 draw-str-at
|
||||
#03 ;gui/edit #0078 #00fc draw-str-at
|
||||
#03 ;gui/edit #0078 #0108 draw-str-at
|
||||
#03 ;gui/edit #0078 #0114 draw-str-at
|
||||
#03 ;gui/edit #0078 #0120 draw-str-at
|
||||
#03 ;gui/edit #0078 #012c draw-str-at
|
||||
#03 ;gui/edit #0078 #0138 draw-str-at
|
||||
#03 ;gui/edit #0078 #0144 draw-str-at
|
||||
|
||||
#01 ;gui/separator #0000 #0150 draw-str-at
|
||||
#01 ;gui/say #0000 #015c draw-str-at
|
||||
#03 ;input #0028 #015c draw-str-at
|
||||
#08 #20 draw-char ( cursor )
|
||||
JMP2r
|
||||
|
||||
@draw-lit #0000 DIV
|
||||
|
||||
@draw-str ( tint^ s* -> )
|
||||
STH2 ( tint^ [s*] )
|
||||
&loop DUP STH2kr LDA DUP ?&ok ( tint^ tint^ c^ [pos*] )
|
||||
POP POP2 POP2r JMP2r ( )
|
||||
&ok draw-char INC2r ( tint^ [pos+1*] )
|
||||
.Screen/x DEI2k #0008 ADD2 ( tint^ s/x^ x+8* [pos+1*] )
|
||||
ROT DEO2 !&loop ( tint^ [pos+1*] )
|
||||
|
||||
@draw-char ( tint^ c^ -> )
|
||||
SWP STH ( c^ [tint^] )
|
||||
#00 SWP #40 SFT2 ;cp437 ADD2 ( addr* [tint^] )
|
||||
.Screen/addr DEO2k ( addr* s/a^ [tint^] )
|
||||
STHkr .Screen/sprite DEO ( addr* s/a^ [tint^] )
|
||||
.Screen/y DEI2k #0004 ADD2 ROT DEO2 ( addr* s/a^ [tint^] )
|
||||
STH #0004 ADD2 STHr DEO2 ( [tint^] )
|
||||
STHr .Screen/sprite DEO ( )
|
||||
.Screen/y DEI2k #0004 SUB2 ROT DEO2 ( )
|
||||
JMP2r ( )
|
||||
|
||||
@history-append-msg ( user* msg* -> )
|
||||
JMP2r
|
||||
|
||||
@history-append-sys ( msg* -> )
|
||||
JMP2r
|
||||
|
||||
~zenoutil.tal
|
||||
|
||||
( 256 chars x 2 tiles/char x 8 bytes/tile = 4096 bytes )
|
||||
( second tile only uses top 50% )
|
||||
@cp437
|
||||
~cp437.tal
|
||||
|
||||
( input and args )
|
||||
@addr $100
|
||||
@port $10
|
||||
@nick $20
|
||||
@input $1000
|
||||
|
||||
( compose buffer )
|
||||
@compose $51 &limit
|
||||
|
||||
( 640x480 resolution means 80 x 40 = 3200 characters )
|
||||
@history $c80 &start =history &limit =history
|
||||
|
||||
214
zenosrv.tal
214
zenosrv.tal
|
|
@ -1,214 +0,0 @@
|
|||
( zenochat.tal )
|
||||
( )
|
||||
( uses uxnet protocol, see uxnet.txt for details )
|
||||
( )
|
||||
( the server assumes its assigned idxs are exactly 3 bytes long. )
|
||||
( this is an implementation detail of uxnet.py not currently )
|
||||
( required by the spec. )
|
||||
( )
|
||||
( clients send messages to the server using the > command. )
|
||||
( each type of messages is identified by its first ASCII )
|
||||
( character, which is otherwise ignored: )
|
||||
( )
|
||||
( CHAR MEANING )
|
||||
( N sets username to $text )
|
||||
( B broadcasts a chat message of $text )
|
||||
( C notifies that user $text has connected )
|
||||
( D notifies that user $text has disconnected )
|
||||
( R expects $prev/$curr, user $prev is renamed to $curr )
|
||||
( )
|
||||
( nicknames are not allowed to have slashes, i.e. /, and must )
|
||||
( be 16 bytes or fewer long. messages are not allowed to contain )
|
||||
( the NULL byte, and are not expected to contain newlines. )
|
||||
|
||||
|10 @Console [ &vect $2 &r $1 &pad $4 &type $1 &w $1 &e $1 ]
|
||||
|
||||
|0000
|
||||
@interpret $2
|
||||
@pos $2
|
||||
@next-client $2
|
||||
|
||||
|0100
|
||||
;before-start .interpret STZ2
|
||||
;addr .pos STZ2
|
||||
;clients .next-client STZ2
|
||||
;read-args .Console/vect DEO2
|
||||
BRK
|
||||
|
||||
( we don't expect anything )
|
||||
@before-start ( -> )
|
||||
#0000 DIV JMP2r
|
||||
|
||||
( we expect to read $/ )
|
||||
@when-starting ( -> )
|
||||
;input LDAk LIT "$ NEQ ?&error
|
||||
INC2 LDAk LIT "/ NEQ ?&error
|
||||
POP2
|
||||
( TODO: validate input )
|
||||
;when-listening .interpret STZ2 JMP2r
|
||||
&error #010f DEO BRK
|
||||
|
||||
( we expect to read $ # < )
|
||||
@when-listening ( -> )
|
||||
;input LDAk LIT "$ EQU ?connect
|
||||
LDAk LIT "# EQU ?disconnect
|
||||
LDAk LIT "< EQU ?receive
|
||||
POP2 #0000 DIV
|
||||
|
||||
@connect ( input* -> )
|
||||
( TODO: validate input )
|
||||
INC2 !add-client
|
||||
|
||||
@disconnect ( input* -> )
|
||||
( TODO: validate input )
|
||||
INC2 !rm-client
|
||||
|
||||
( expect: <999/N...\0 )
|
||||
( or: <999/B...\0 )
|
||||
@receive ( input* -> )
|
||||
( TODO: validate input )
|
||||
INC2 DUP2 find-client ( msg=input+1* maybe* )
|
||||
ORAk ?&found POP2 emit JMP2r ( )
|
||||
&found ( msg* client* )
|
||||
SWP2 #0004 ADD2 ( client* body=msg+4 )
|
||||
LDAk LIT "N EQU ?rename ( client* body* )
|
||||
LDAk LIT "B EQU ?broadcast ( client* body* )
|
||||
POP2 POP2 JMP2r ( )
|
||||
|
||||
@broadcast ( client* body* -> )
|
||||
INC2 SWP2 #0003 ADD2 ( data=body+1* name=client+3* )
|
||||
start-output copy-dst0 ( data* dst+n* ; copy name into dst+5 )
|
||||
#3a20 OVR2 STA2 ( data* dst+n-1* ; dst+n-1<-": " )
|
||||
INC2 INC2 copy ( ; copy data into dst+n+1 )
|
||||
!send-to-all ( )
|
||||
|
||||
( sends ;output to all clients )
|
||||
( fn should have shape: client* -> )
|
||||
@send-to-all ( -> )
|
||||
.next-client LDZ2 ;clients ( limit* start* )
|
||||
&loop GTH2k ?&ok POP2 POP2 JMP2r ( )
|
||||
&ok DUP2 send-to #0014 ADD2 !&loop ( limit* pos+20* )
|
||||
POP2 POP2 JMP2r ( )
|
||||
|
||||
( sends ;output to a client )
|
||||
@send-to ( client* -> )
|
||||
;output STH2k INC2 ( client* output+1* [output*] )
|
||||
idx-copy ( [output*] ; copy idx into output+1 )
|
||||
STH2r emit ( ; emit output )
|
||||
( #0a18 DEO JMP2r ( need newline for interactive testing ) )
|
||||
#0018 DEO JMP2r
|
||||
|
||||
@rename-msg 20 "is 20 "now 20 "called 20 00
|
||||
|
||||
@start-output ( -> dst* )
|
||||
LIT2r :output
|
||||
LIT "> STH2kr STA INC2r
|
||||
LIT2 "00 STH2kr STA2 INC2r INC2r
|
||||
LIT2 "0/ STH2kr STA2 INC2r INC2r
|
||||
STH2r JMP2r
|
||||
|
||||
@rename ( client* body* -> )
|
||||
OVR2 #0003 ADD2 ( client* body* name=client+3* )
|
||||
start-output copy-dst0 ( client* body* dst* ; copy old name to output )
|
||||
;rename-msg SWP2 copy-dst0 ( client* body* dst2* )
|
||||
STH2 INC2 STH2k #00 STH2kr ( client* data=body+1* 0^ data* [dst2* data*] )
|
||||
#0010 ADD2 STA ( client* data* ; data+16<-0 [dst2* data*] )
|
||||
SWP2 #0003 ADD2 copy ( [dst2* data*] ; copy data into client+3 )
|
||||
STH2r STH2r ( data* dst2* )
|
||||
copy !send-to-all ( ; copy data into dst2 and send )
|
||||
|
||||
( we expect to read addr then port )
|
||||
@read-args ( -> BRK )
|
||||
.Console/type DEI #04 EQU ?start-server
|
||||
.Console/type DEI #03 EQU ?&end-addr
|
||||
.Console/r DEI .pos LDZ2 STA ( ; write c into buf )
|
||||
.pos LDZ2k INC2 ROT STZ2 BRK ( BRK ; increment buf pos )
|
||||
&end-addr ;port .pos STZ2 BRK ( BRK ; start raeding port port )
|
||||
|
||||
@read-stdin
|
||||
( .Console/r DEI #0a NEQ ?&continue ( ; did we read null? ) )
|
||||
.Console/r DEI ?&continue ( ; did we read null? )
|
||||
#00 .pos LDZ2 STA ( ; write null )
|
||||
.interpret LDZ2 JSR2 ( ; interpret message )
|
||||
;input .pos STZ2 BRK ( ; reset input buffer )
|
||||
&continue ( )
|
||||
.Console/r DEI .pos LDZ2 STA ( ; write c into input buffer )
|
||||
.pos LDZ2k INC2 ROT STZ2 BRK ( ; increment input buffer )
|
||||
|
||||
@start-server ( -> BRK )
|
||||
LIT "@ .Console/w DEO ;addr emit
|
||||
LIT "/ .Console/w DEO ;port emit
|
||||
( #0a .Console/w DEO )
|
||||
#00 .Console/w DEO
|
||||
;input .pos STZ2
|
||||
;when-starting .interpret STZ2
|
||||
;read-stdin .Console/vect DEO2
|
||||
BRK
|
||||
|
||||
( assumes idxs are 3 bytes long )
|
||||
@idx-eq ( idx1* idx2* -> bool^ )
|
||||
STH2 LDAk LDAkr STHr NEQ ?&nope
|
||||
INC2 INC2r LDAk LDAkr STHr NEQ ?&nope
|
||||
INC2 INC2r LDA LDAr STHr EQU JMP2r
|
||||
&nope #00 JMP2r
|
||||
|
||||
( assumes idxs are 3 bytes long )
|
||||
@idx-copy ( idx* dst* -> )
|
||||
STH2 LDAk STH2kr STA INC2 INC2r ( idx+1* [dst+1*] ; dst<-idx )
|
||||
LDAk STH2kr STA INC2 INC2r ( idx+2* [dst+2*] ; dst+1<-idx+1 )
|
||||
LDA STH2r STA JMP2r ( ; dst+2<-idx+2 )
|
||||
|
||||
@connect-msg 20 "has 20 "connected 00
|
||||
|
||||
@add-client ( idx* -> )
|
||||
LITr -next-client LDZ2r ( idx* [next*] )
|
||||
DUP2 STH2kr copy-slash ( idx* [next*] ; copy idx to client-idx )
|
||||
STH2kr #0003 ADD2 copy-slash ( [next*] ; copy idx to client-name )
|
||||
#00 STH2kr #0006 ADD2 STA ( [next*] ; null terminate )
|
||||
STH2kr #0003 ADD2 ( next+3* [next*] )
|
||||
start-output copy-dst0 ( dst* [next*] ; start message )
|
||||
;connect-msg SWP2 copy ( [next*] ; finish message )
|
||||
STH2r #0014 ADD2 .next-client STZ2 ( ; next-client<-next+20 )
|
||||
!send-to-all ( )
|
||||
|
||||
@disconnect-msg 20 "has 20 "disconnected 00
|
||||
|
||||
@rm-client ( idx* -> )
|
||||
find-client ORAk ?&found ( addr* )
|
||||
POP2 JMP2r ( )
|
||||
&found ( addr* )
|
||||
DUP2 #0003 ADD2 start-output ( addr* addr+3* dst* )
|
||||
copy-dst0 ( addr* dst2* )
|
||||
;disconnect-msg SWP2 copy ( addr* )
|
||||
.next-client LDZ2 #0014 SUB2 SWP2 ( limit* addr* )
|
||||
&loop GTH2k ?&ok !&done ( limit* pos* )
|
||||
&ok DUP2 #0014 ADD2 LDA2 ( limit* pos* cc* )
|
||||
OVR2 STA2 INC2 INC2 !&loop ( limit* pos+2* )
|
||||
&done .next-client STZ2 POP2 ( )
|
||||
!send-to-all ( )
|
||||
|
||||
( returns client addr or 0000 on failure )
|
||||
( finds client based on 3 byte idx )
|
||||
@find-client ( idx* -> addr* )
|
||||
STH2 .next-client LDZ2 ;clients ( limit* clients* [idx*] )
|
||||
&loop ( limit* c* [idx*] )
|
||||
DUP2 STH2kr idx-eq ?&found ( limit* c* [idx*] )
|
||||
#0014 ADD2 GTH2k ?&loop ( limit* c+20* [idx*] )
|
||||
POP2r POP2 DUP2 EOR2 JMP2r ( 0* )
|
||||
&found NIP2 POP2r JMP2r ( c* )
|
||||
|
||||
~zenoutil.tal
|
||||
|
||||
@addr $100
|
||||
@port $6
|
||||
@input $1000
|
||||
@output $1000
|
||||
|
||||
( client layout: )
|
||||
( - bytes 1-3: idx )
|
||||
( - bytes 4-20: nickname\0 )
|
||||
( every idx is 3 bytes )
|
||||
( max username is 16 chars )
|
||||
( username is null-terminated; idx is not )
|
||||
( max # of clients is 64 )
|
||||
@clients $500 &limit
|
||||
49
zenoutil.tal
49
zenoutil.tal
|
|
@ -1,49 +0,0 @@
|
|||
( copy null-terminated string from src into dst )
|
||||
( includes the null terminator. )
|
||||
( returns first unwritten address. )
|
||||
@copy-dst ( src* dst* -> dst2* )
|
||||
STH2 &loop ( in* [out*] )
|
||||
LDAk DUP STH2kr STA ( in* c^ [out*] )
|
||||
INC2r STH INC2 ( in+1* [out+1* c^] )
|
||||
STHr ?&loop ( in+1 [out+1*] )
|
||||
POP2 STH2r JMP2r ( dst2=out+1* )
|
||||
|
||||
( copy-dst but without null termination )
|
||||
@copy-dst0 ( src* dst* -> dst2* )
|
||||
copy-dst #0001 SUB2 JMP2r
|
||||
|
||||
( copy null-terminated string from src into dst )
|
||||
( includes the null terminator. )
|
||||
@copy ( src* dst* -> )
|
||||
copy-dst POP2 JMP2r
|
||||
|
||||
( copy slash-terminated string from src into dst. )
|
||||
( writes a null terminator. )
|
||||
@copy-slash ( src/* dst* -> )
|
||||
STH2 &loop LDAk LIT "/ EQU ?&done ( in* [out*] )
|
||||
LDAk STH2kr STA INC2 INC2r !&loop ( in+1* [out+1*] )
|
||||
&done #00 STH2r STA POP2 JMP2r ( )
|
||||
|
||||
( compare two null-terminated strings )
|
||||
@eq ( s* t* -> eq^ )
|
||||
STH2 ( s1* [s2*] )
|
||||
&l LDAk LDAkr STHr NEQk ?&d ( s1* c1^ c2^ [s2*] )
|
||||
DUP EOR EQUk ?&d ( s1* c1^ 0^ [s2*] )
|
||||
POP2 INC2 INC2r !&l ( s1+1* [s2+1*] )
|
||||
&d NIP2 POP2r EQU JMP2r ( eq^ )
|
||||
|
||||
( compare slash-terminated string against null-terminated )
|
||||
( slash terminated string cannot contain nulls )
|
||||
@eq-slash ( s/* str* -> )
|
||||
STH2 ( s/* [str*] )
|
||||
&loop LDAk LIT "/ EQU ?&end ( s/* [str*] )
|
||||
LDAk LDAkr STHr NEQk ?&done ( s/* c1^ c2^ [str*] )
|
||||
POP2 INC2 INC2r !&loop ( s/+1* [str+1*] )
|
||||
&end LDAkr STHr DUPk EOR ( s/* c2^ 0^ [str*] )
|
||||
&done NIP2 POP2r EQU JMP2r ( 0^ )
|
||||
|
||||
( write null-terminated string to stdout )
|
||||
@emit ( buf* -> )
|
||||
LITr -Console/w ( buf* [dev^] )
|
||||
&loop LDAk ?&ok POP2 POPr JMP2r ( )
|
||||
&ok LDAk STHkr DEO INC2 !&loop ( buf+1* [dev^] )
|
||||
Loading…
Reference in New Issue