Last active
January 23, 2022 03:43
-
-
Save DeltaF1/e0510c02594c843ec53f33f86efeff48 to your computer and use it in GitHub Desktop.
Tracery parser and generator in Uxntal
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
|00 @System &vector $2 &wst $1 &rst $1 &pad $4 &r $2 &g $2 &b $2 &debug $1 &halt $1 | |
|10 @Console &vector $2 &read $1 &pad $5 &write $1 &error $1 | |
|80 @Controller &vector $2 &button $1 &key $1 | |
|a0 @File &vector $2 &success $2 &stat $2 &delete $1 &append $1 &name $2 &length $2 &read $2 &write $2 | |
|b0 @DateTime &year $2 &month $1 &day $1 &hour $1 &minute $1 &second $1 &dotw $1 &doty $2 &isdst $1 | |
%RET { JMP2r } | |
|0100 @Init | |
#0ff0 .System/r DEO2 | |
#0f0f .System/g DEO2 | |
#0f00 .System/b DEO2 | |
;seed-from-datetime JSR2 | |
#6000 .File/length DEO2 | |
;grammar-filename .File/name DEO2 | |
;json-file .File/read DEO2 | |
( Parse JSON into grammar ) | |
;grammar ;json-file ;json-grammar JSR2 | |
#0100 | |
&loop | |
EQUk ,&done JCN | |
INC | |
;generated-string ;grammar ;tracery-generate JSR2 | |
;generated-string ;print JSR2 | |
,&loop JMP | |
&done POP2 | |
( Print the grammar structure afterwards ) | |
;grammar ;print-grammar JSR2 | |
BRK | |
@print-grammar ( grammar* -- ) | |
&entry-loop | |
ORAk #00 EQU ,&done-printing JCN | |
STH2k | |
LDAk #01 EQU LIT "V LIT "I ROT #01 JCN [ SWP ] [ NIP ] .Console/write DEO ( Write valid bit ) | |
INC2 | |
&print-loop | |
LDAk .Console/write DEO INC2 LDAk ,&print-loop JCN | |
INC2 | |
LDA LIT "0 ADD .Console/write DEO ( Write value length ) | |
STH2r ;next-entry JSR2 | |
,&entry-loop JMP | |
&done-printing | |
RET | |
@print ( str* -- ) | |
&start | |
LDAk DUP #00 EQU ,&done JCN | |
.Console/write DEO | |
INC2 | |
,&start JMP | |
&done | |
POP POP2 | |
#0a .Console/write DEO | |
RET | |
@grammar-filename "grammar.json 00 | |
~projects/library/tracery.tal | |
( Big buffer ) | |
|1400 @generated-string | |
|2000 @json-file | |
|8000 @grammar |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
( | |
grammar := | |
entry . grammar | |
0x00 | |
entry := | |
valid-flag . name . len . pointer<value> | |
valid-flag := | |
VALID 0x02 | |
INVALID 0x01 | |
name := string | |
string := | |
char . entry | |
0x00 | |
len := byte | |
pointer := short | |
value := | |
string | |
list | |
list := | |
string . list | |
string | |
) | |
%DBG { BRK } | |
~projects/library/prng.tal | |
@dbg-print ( string* -- ) | |
&loop LDAk .Console/write DEO | |
INC2 LDAk | |
,&loop JCN | |
RET | |
( Public API ) | |
( @tracery-generate ) ( dest* grammar* -- ) | |
( @json-grammar ) ( dest* json* -- ) | |
( Generation ) | |
@tracery-generate ( dest* grammar* -- ) | |
;grammar-addr STA2 | |
;origin-name | |
;resolve-name JSR2 | |
POP2 ( Drop source ) | |
#00 ROT ROT STA ( Zero-terminate ) | |
RET | |
@grammar-addr $2 | |
( reify copies text from src to dest, applying tracery substitutions along the way ) | |
@reify ( dest* src* -- new-dest* new-src* ) | |
&start LDAk | |
DUP LIT "# NEQ ,&normal JCN | |
POP | |
;&start STH2 | |
;resolve-name JMP2 ( call into resolve-name and return back to the start ) | |
&normal ( dest* src* char ) | |
DUP #00 EQU ,&terminate JCN | |
( dest* src* ) | |
STH INC2 SWP2 | |
STHr ROT ROT STAk ( store ) ROT | |
POP INC2 SWP2 ( -- dest++* src++* ) | |
,&start JMP | |
&terminate | |
POP | |
RET | |
( resolve-name performs a substitution by looking up a name in the grammar ) | |
( the resulting string is copied to the destination with reify ) | |
@resolve-name ( dest* name* -- new-dest* new-src* ) | |
;search-grammar JSR2 | |
( dest* src* str*? flag ) | |
,&no-error JCN | |
;error-str ( Push the error string if not found ) | |
&no-error | |
( dest* src* new-src* -- src* dest* new-src* ) | |
ROT2 SWP2 | |
;reify JSR2 | |
( old-src* new-dest* new-src* -- new-dest* old-src* ) | |
POP2 SWP2 | |
INC2 ( Increment source pointer to skip past terminating # ) | |
RET | |
( If found == 00 then no string address follows ) | |
( This method modifies the grammar datastructure as a hidden side-effect by setting validity flags ) | |
@search-grammar ( name* -- name-end* string* found^ ) | |
;reset-grammar JSR2 | |
LIT2r 0000 ( Offset for grammar entry names ) | |
&char-loop | |
INC2 INC2r | |
( Convert the terminating "#" to nul terminator to compare to the entry names ) | |
LDAk #00 OVR LIT "# EQU JMP [ SWP ] NIP | |
( Compare char to each entry of the grammar ) | |
( name* char rs: offset* ) | |
;grammar-addr LDA2 | |
&entry-loop | |
ORAk ,&more-entries JCN | |
POP2 | |
( If this is the last char of the name then we're done ) | |
,&char-loop JCN [ ,&done JMP ] | |
&more-entries | |
( name* char entry* rs: offset* ) | |
LDAk #02 NEQ ,&skip-invalid JCN | |
( The entry is still valid, check the char ) | |
STH2rk | |
OVR2 STH2 ( Copy entry pointer ) | |
( name* char entry* offset* rs: offset* entry* ) | |
ADD2 LDA ( Fetch char in name ) | |
EQUk NIP INC ( Compare chars ) | |
STH2rk STA ( Store new validity flag ) | |
STH2r | |
&skip-invalid | |
;&entry-loop STH2 | |
;next-entry JMP2 | |
&done | |
POP2r ( Lose offset ) | |
,find-valid-entry JSR ( -- entry* flag^ ) | |
DUP JMP | |
[ RET ] ( If the flag is 0 then just return ) | |
STH ;entry-to-string JSR2 STHr | |
RET | |
( Iterate over each entry in the grammar object and check its valid bit ) | |
( If 0, then error ) | |
( If >1, then error ) | |
( If =1, then return that string ) | |
@find-valid-entry ( -- string* flag^ ) | |
LITr 00 ( # of valid entries ) | |
;grammar-addr LDA2 | |
&start ORAk #00 EQU ,&done JCN | |
LDAk #01 EQU ,&next JCN | |
INCr | |
DUP2 ,&entry STR2 ( Store current ) | |
&next | |
;&start STH2 | |
;next-entry JMP2 | |
&done | |
POP2 | |
( Check that count == 1 ) | |
STHr #01 EQU ,&valid JCN | |
#00 RET | |
&valid | |
,&entry LDR2 #01 RET | |
&entry $2 | |
( Converts a grammar entry to its given string pointer ) | |
( If the entry is a list, pick one randomly ) | |
@entry-to-string ( entry* -- string* ) | |
&start INC2 LDAk ,&start JCN | |
INC2 LDAk ( Fetch length byte ) | |
;rand-max JSR2 | |
STH | |
INC2 LDA2 ( Fetch pointer to string list ) | |
&list-loop | |
STHrk ,&next-string JCN ( If the count isn't 0 yet ) | |
POPr RET | |
&next-string | |
&skip-string INC2 LDAk ,&skip-string JCN | |
LITr 01 SUBr ( Decrement count ) | |
INC2 ,&list-loop JMP | |
( Reset the validity flags for each grammar entry ) | |
@reset-grammar ( -- ) | |
#02 ( Valid ) | |
;grammar-addr LDA2 | |
&loop | |
STAk ( Store flag ) | |
;next-entry JSR2 | |
DUP2 ORA ,&loop JCN | |
POP2 POP | |
RET | |
( Takes a pointer to an entry's validity flag and returns the next entry ) | |
( sets to 0000 upon the end of the grammar ) | |
@next-entry ( entry* -- next* ) | |
LDAk ,&non-zero JCN | |
POP2 #0000 | |
RET | |
&non-zero | |
( Skip past name ) | |
&name-loop INC2 LDAk ,&name-loop JCN | |
#0004 ADD2 ( Skip over the string pointer ) | |
LDAk ,&done JCN ( If it's not 0 then we're done ) | |
( Else set pointer to 0000 ) | |
POP2 #0000 | |
&done | |
RET | |
( Convert a json string into a grammar object stored at dest* ) | |
@json-grammar ( dest* json-string* -- ) | |
( Marker to stop popping the return stack ) | |
LIT2r 0000 | |
LDAk LIT "{ EQU ,&json-parse JCN | |
( use reify as a string copy to print error message ) | |
POP2 ;invalid-err-str ;reify JSR2 | |
POP2 POP2 RET | |
&json-parse | |
( Find the start of the json string ) | |
;start-of-name JSR2 INC2 ( ptr* -- ptr* ) | |
;new-entry JSR2 OVR2 STH2 ( dest* name* -- value-ptr* name* ) | |
SWP2 [ #0003 ADD2 ] SWP2 ( Increment dest to skip past the pointer space ) | |
( Advance the JSON pointer to get to the value for later ) | |
;start-of-value JSR2 STH2k ( Stash pointer to json value ) | |
;next-json-pair JSR2 INC2 | |
,&json-parse JMP | |
( wst: dest* ) | |
( The return stack now contains pairs of values: ) | |
( key-entry* json-value* ) | |
( The task is to unzip these values, writing the values out to dest and storing the current dest pointer location into the dictionary entries ) | |
DBG "store-values | |
&store-values | |
INC2 | |
&store-loop | |
STH2rk #0000 EQU2 ,&done JCN | |
( ws: dest* rs: entry-slot* json-value* ) | |
STH2r OVR2 STH2 ( Copy dest onto the return stack to keep track of value's address ) | |
( ws: dest* json-value* rs: key-entry* string-addr* ) | |
;write-json-value JSR2 ( dest* json-value* -- dest* count^ ) | |
SWP2r STH2rk STA ( Store count ) ( dest* rs: string-addr* key-entry* ) | |
INC2r STA2r ( Store string pointer into key struct ) | |
,&store-loop JMP | |
&done | |
POP2r POP2 RET | |
DBG "start-of-name | |
@start-of-name ( str* -- str* ) | |
&loop | |
LDAk #22 EQU ( Compare to " ) ,&found-string JCN | |
LDAk LIT "} EQU ,&eof JCN | |
INC2 | |
,&loop JMP | |
&found-string RET | |
&eof | |
POP2 ( No more need for json pointer ) | |
POP2r ;json-grammar/store-values JMP2 ( Alternate return ) | |
DBG "start-of-value | |
@start-of-value ( str* -- str* ) | |
&loop | |
LDAk DUP #22 EQU SWP LIT "[ EQU ORA ,&done JCN | |
LDAk LIT "} EQU ,&done JCN | |
INC2 | |
,&loop JMP | |
&done RET | |
DBG "next-json-pair | |
@next-json-pair ( str* -- str* ) | |
&loop | |
LDAk LIT "[ EQU ,flee-list JCN | |
LDAk #22 EQU ,flee-string JCN | |
LDAk LIT "} EQU ,&eof JCN | |
INC2 | |
,&loop JMP | |
&eof | |
POP2 POP2r POP2r POP2r | |
;json-grammar/store-values JMP2 ( Alternate return ) | |
DBG "flee-list | |
@flee-list ( str* -- str* ) | |
&loop | |
LDAk #22 NEQ ,&no-string JCN | |
,flee-string JSR | |
&no-string INC2 LDAk LIT "] NEQ ,&loop JCN | |
&done | |
RET | |
DBG "flee-string | |
@flee-string ( str* -- str* ) | |
INC2 | |
&loop | |
LDAk #22 EQU ,&done JCN | |
INC2 ,&loop JMP | |
&done RET | |
DBG "write-json-value | |
@write-json-value ( dest* json-value* -- dest* count^ ) | |
LDAk LIT "[ EQU ,write-list JCN | |
LDAk #22 EQU ,write-string JCN | |
RET | |
DBG "write-string | |
@write-string ,write-string-helper JSR POP2 #01 RET | |
DBG "write-string-helper | |
( Writes the contents of a json string to the buffer, terminating on " ) | |
@write-string-helper ( dest* string* -- dest* string* ) | |
SWP2 STH2 ( -- string* rs: dest* ) | |
&loop INC2 LDAk #22 EQU ,&done JCN | |
LDAk STH2rk STA ( Store char ) | |
INC2r | |
,&loop JMP | |
&done | |
INC2 ( Increment string ) | |
#00 STH2rk STA ( Zero-terminate ) | |
INC2r STH2r SWP2 RET ( Restore stack ) | |
DBG "write-list | |
@write-list ( dest* string* -- dest* count ) | |
LITr 00 | |
&loop | |
&skip-to-string | |
LDAk #22 EQU ,&found-string JCN | |
LDAk LIT "] EQU ,&done JCN | |
INC2 ,&skip-to-string JMP | |
&found-string | |
,write-string-helper JSR INCr ( Increment count ) | |
,&loop JMP | |
&done | |
POP2 STHr RET | |
DBG "new-entry | |
( Creates a key entry in the grammar table from the given json string ) | |
( Return a pointer to the value pointer slot ) | |
@new-entry ( dest* name* -- dest* name* ) | |
SWP2 | |
STH2 #02 STH2kr STA ( Write valid flag ) INC2r ( name* rs: dest* ) | |
&name-loop LDAk DUP #22 EQU ( Compare to " ) ,&done-name JCN | |
STH2kr STA ( Write char ) INC2 INC2r | |
,&name-loop JMP | |
&done-name | |
( name* char rs: dest* ) | |
POP INC2 ( increment past the name string ) | |
#00 STH2rk STA ( Zero-terminate ) | |
STH2r | |
INC2 ( Point to the length byte ) | |
SWP2 | |
RET | |
@invalid-err-str "NotJSON 00 | |
@parse-err-str "CANTPARSEJSON 00 | |
@origin-name "#origin# 00 | |
@error-str "NOTFOUND 00 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment