Tracery parser and generator in Uxntal

example-tracery-app.tal

|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

tracery.tal

(
	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