\ set the maximum memory (0 .. 2222222222 trinary)
base @ 3 base ! 10000000000 swap base ! Constant memBoundary

\ **** CHARACTER HANDLING ****
: createStringLookup ( addr u "name" -- )
	create swap , , 
	DOES> 
	@ + chars c@ ;

\ s\" +b(29e*j1VMEKLyC})8&m#~W>qxdRp0wkrUo[D7,XTcA\"lI.v%{gJh4G\\-=O@5`_3i<?Z';FNQuY]szf$!BS/|t:Pn6^Ha" createStringLookup enc1
s\" 5z]&gqtyfr$(we4{WP)H-Zn,[%\\3dL+Q;>U!pJS72FhOA1CB6v^=I_0/8|jsb9m<.TVac`uY*MK'X~xDl}REokN:#?G\"i@" createStringLookup enc2

\ this words do the encryption / decryption of the commands
\ : mdecode ( c i -- ec ) + 33 - 94 mod enc1 ;
: mdecode ( c i -- ec ) + 33 - 94 mod ;
: mrecode ( c -- ec ) 33 - 94 mod enc2 ;

: validChar? ( c -- flag ) dup 32 > swap 127 < and ;
: isSpace? ( c -- flag ) dup 10 = swap dup 12 = swap dup 32 = swap 9 = or or or ;

\ **** ARITMETIC ****
\ use this functions to correctly overflow on ternary limit
: +t (  x y -- [x + y] % 59049 ) + memBoundary mod ;
: +1t ( x -- [x+1] % 59049 ) 1 +t ;

\ **** MEMORY HANDLING ****
\ create memory for virtual machine (3^10 cells)
: init-mem ( -- addr u ) 
	memBoundary dup cells allocate throw swap ;

\ this word puts char c into cell [startaddr+i]
: put-mem ( c startaddr i -- ) cells + ! ;

\ **** FILE HANDLING ****
0 Value fd
: openf ( addr u -- ) r/o open-file throw to fd ;
: closef ( -- ) fd close-file throw 0 to fd ;

: readc ( -- c readcount )
	pad dup 1 fd ( padaddr padaddr 1 fd )
	read-file throw ( padaddr count )
 	swap c@ swap ;

: checkBounds ( i -- )
	memBoundary >= if throw then ;

: fill-mem { addr -- i }
	0 ( i )
	begin
	dup checkBounds readc 1 =
	while ( i char )
	dup isSpace? 0 =
		if ( i char )
			dup validChar? invert throw
			2dup addr rot ( i char char addr i )
			put-mem ( i char )
			drop 1+ ( i+1 )
		else
			drop ( i )
		then
	repeat
	drop
	;

\ **** I/O HANDLING ****
\ reads a char from console and converts it appropriately (<Enter> = 10)
: read-a-char ( -- a ) pad dup 1 accept 0 = if drop 10 else c@ then ;

\ **** Op - Operation ****

\ table for di-trits lookup
create op-table
	4 , 3 , 3 , 1 , 0 , 0 , 1 , 0 , 0  , 4 , 3 , 5 , 1 , 0 , 2 , 1 , 0 , 2  , 5 , 5 , 4 , 2 , 2 , 1 , 2 , 2 , 1  , 4 , 3 , 3 , 1 , 0 , 0 , 7 , 6 , 6  , 4 , 3 , 5 , 1 , 0 , 2 , 7 , 6 , 8  , 5 , 5 , 4 , 2 , 2 , 1 , 8 , 8 , 7  , 7 , 6 , 6 , 7 , 6 , 6 , 4 , 3 , 3  , 7 , 6 , 8 , 7 , 6 , 8 , 4 , 3 , 5  , 8 , 8 , 7 , 8 , 8 , 7 , 5 , 5 , 4 ,
	DOES> 
	swap cells + @ ;
	
\ table for trit-index to decimal
create trit-step
	1 , 9 , 81 , 729 , 6561 ,
	DOES> 
	swap cells + @ ;
	
\ returns item from op table
: getItemFromOpTable ( a d -- n )
	9 * + op-table ;

\ op-Operation
: op ( a d -- a )
	0 ( a d ret )
	-rot ( ret a dcont)
	5 0 ?DO
		2dup ( ret a d a d ) 
		i trit-step / 9 mod swap ( ret a d d' a ) 
		i trit-step / 9 mod swap ( ret a d a' d' ) 
		getItemFromOpTable ( ret a d tritwise-op )
		i trit-step * ( ret a d y )
		-rot ( ret y a d ) 
		2swap ( a d ret y ) 
		+ ( a d ret' ) 
		-rot ( ret' a d )
	LOOP
	2drop ( ret' ) ;


\ ops the free memory
: op-mem { addr length -- }
	memBoundary length ?DO
		i 1 - cells addr + @ ( mem[i-1] )
		i 2 - cells addr + @ ( mem[i-1] mem[i-2] )
		op ( oped-mem )
		i cells addr + ! ( )
	LOOP ;


\ **** Star (*) - Operator ****

\ takes the d-pointer to a cell, makes a right-rot of the content 
\ and sets pointer to new content
: mstar { addr d -- a d }
	d cells addr + @ ( mem[d] )
	dup 3 / swap 3 mod 19683 * + ( mem[d]' )
	dup ( mem[d]' mem[d]' )
	d cells addr + ! d ( mem[d]' d )
	;


\ mp operator
: mp { addr a d -- a d }
	d cells addr + @ ( mem[d] )
	a swap op ( op|a, mem[d]| )
	dup ( op op )
	d cells addr + ! d ( op d )
	;

\ i,j operator
: mij ( addr d -- c )
	cells + @ ;

: execEnd ( a d c addr -- a d c flag )
	drop false ;

: execNop ( a d c addr -- a d c flag )
	drop true ;

: execPrint ( a d c addr  -- a d c flag )
	drop rot dup emit -rot true ;

: execRead ( a d c addr  -- a d c flag )
	drop rot drop read-a-char -rot true ;

: execJump { a d c addr -- a d c flag }
	a d addr d mij true ;

: execLoad { a d c addr -- a d c flag }
	a addr d mij c true ;

: execOp { a d c addr -- a d c flag }
	addr a d mp c true ;

: execStar { a d c addr -- a d c flag }
	addr d mstar c true ;

\ execution table
create execTable
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execStar , ' execLoad , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execOp , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execEnd , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execJump , ' execPrint , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execRead , 
	' execNop , ' execNop , ' execNop , ' execNop , ' execNop , 
	' execNop , ' execNop , ' execNop , ' execNop ,
	DOES> ( i -- )
	swap cells + @ ;

: exec-mem { addr -- }
0 0 0
begin ( a d c )
	dup cells addr + @ ( a d c mem[c] )
	dup validChar? invert throw ( a d c mem[c] )
	over mdecode ( a d c decoded[mem] )
	execTable addr swap execute ( a d c flag)
\	CASE ( a d c )
\		'v' OF false ENDOF ( exit )
\		'<' OF rot dup emit -rot true ENDOF ( print A )
\		'/' OF rot drop read-a-char -rot true ENDOF ( read A )
\		'i' OF drop addr over mij true ENDOF ( jump )
\		'j' OF swap addr swap mij swap true ENDOF ( load D )	
\		'p' OF -rot addr -rot mp rot true ENDOF ( op )
\		'*' OF -rot swap drop addr swap mstar rot true ENDOF ( * )
\		true
\	ENDCASE ( a d c flag)
	swap dup cells addr + @ mrecode ( a d flag c encoded|mem[c]| )
	over cells addr + ! swap ( a d c flag )
	-rot +1t swap +1t swap rot ( a d+1 c+1 flag )
while repeat
2drop drop ( )
;

: dup-mem ( fromMem -- newMem )
	init-mem drop dup -rot memBoundary cells ( newMem fromMem newMem count )
	move ( newMem )
	;

: newMalWord ( addr u "name" -- )
	create
	openf ( )
	init-mem ( execaddr count )
	drop dup dup ( 3*execaddr )
	fill-mem ( 2*execaddr count )
	closef ( 2*execaddr count )
	op-mem ( execaddr ) ,
	DOES>
	@ dup-mem ( toMem )
	dup exec-mem ( toMem )
	free ( -- )
	;