%%HP: T(3)A(R)F(.);
"CODE
NB4BT	EQU	2		nibbles per 1 byte
MAXRO	EQU	15		nejdelsi je MMMDCCCLXXXVIII

*===============================*
*          VSTUPNI BOD          *
*===============================*
	C=DAT1	A		C(A): adresa objektu na RPL-stacku
	?C#0	A		je platna?
	GOYES	RO_ARG		- ano, pokracovat
	LA(5)	#201		- ne, chybove hlaseni *Too Few Arguments*
RO_ERROR
	GOVLNG	=Errjmp
RO_ERROR_VAL
	GOSBVL	=GETPTR
	LA(5)	=argvalerr	chybove hlaseni *Bad Argument Value*
	GOTO	RO_ERROR

*===============================*
*     NA STACKU JE ARGUMENT     *
*===============================*
RO_ARG
	CD1EX			D1:   adresa objektu
	A=DAT1	A		A(A): prolog
	D1=C			D1:   adresa objektu vracena
	LC(5)	=DOINT
	?A=C	A		je to ZINT?
	GOYES	RO_A2R		- ano
	LC(5)	=DOCSTR
	?A#C	A		je to STRING?
	GOYES	+		- ne
	GOTO	RO_R2A		- ano
+
	LA(5)	=argtypeerr	chybove hlaseni *Bad Argument Type*
	GOTO	RO_ERROR

*===============================*
*          JE TO CISLO          *
*===============================*
* R0(A): docasna pamet pro vysledek
* R1(A): pointer na cifry (vychozi D1)
* R2(A): index aktualni cifry (dekadicky rad)
* R3(A): pointer na tabulku rimskych cislic sromt[]
* B(A):  index do tabulky sromt[]
*
D1SROMT	MACRO
	C=R3.F	A		C(A): sromt[]
	C=C+B	A		B(A): index podle dekadickeho radu
	D1=C			D1:   sromt[] + index
D1SROMT	ENDM
*
RO_A2R
	GOSUB	RO_START
* D1:   pointer na cifry
* C(A): pocet cifer
	C=C-1	A		pouze nula ma jen jeden nibble
	?C=0	A		je to nula?
	GOYES	RO_ERROR_VAL	- ano
	AD1EX			A(A): adresa hodnoty
	A=A+C	A		A(A): adresa posledniho nibble...
	D1=A			D1:   ...tam kam patri
	A=DAT1	P		A(0): znamenko
	?A#0	P		je to minus?
	GOYES	RO_ERROR_VAL	- ano
	C=C-CON	A,5		moc velky pocet znaku?
	GONC	RO_ERROR_VAL	- ano
	D1=D1-	1		D1:   pointer na prvni cifru (MSD)
	C=C+1	A		ctyrmistne cislo? (C=C-5+1 -> C=C-1)
	GONC	+		- ne, bez kontroly
	A=DAT1	P		A(0): prvni cifra
	A=A-CON	P,4		hodnota > 3999?
	GONC	RO_ERROR_VAL	- ano
+
	C=C+CON	A,3		C(A):  pocet cifer - 1
	R2=C.F	A		R2(A): index prvni cifry (MSD)
	LC(5)	(MAXRO)*(NB4BT)
	GOSUB	RO_A2R_MEM
	AD0EX			A(A):  docasna pamet pro vysledek
	R0=A.F	A
	AD0EX
	C=R2.F	A		C(A):  index prvni cifry (MSD)
	C=C+C	A		viz. NB4BT
	C=C+C	A		2 rimske cislice na kazdy dekadicky rad
	B=C	A		B(A):  index do tabulky sromt[]
	GOSUB	RO_SROMT	R3(A): sromt[]
*-------------------------------*
*    ZPRACOVANI JEDNE CIFRY     *
*-------------------------------*
RO_A2R_LOOP
	A=DAT1	P		A(0):  cifra
	AD1EX
	R1=A.F	A		R1(A): pointer na cifry
	AD1EX			A(0):  cifra
	LC(1)	4
	?A=C	P		je to 4?
	GOYES	RO_A2R_4_9	- ano
	LC(1)	9
	?A#C	P		je to 9?
	GOYES	RO_A2R_REST0	- ne
RO_A2R_4_9
	D1SROMT
	C=DAT1	B		z sromt[]...
	DAT0=C	B		...do vysledku
	D0=D0+	NB4BT		dalsi znak ve vysledku
	D1=D1+	NB4BT		dalsi znak v sromt[]
	A=A+A	P		byla to 9?
	GONC	+		- ne
	D1=D1+	NB4BT		- ano, dalsi znak v sromt[]
+
	C=DAT1	B		z sromt[]...
	DAT0=C	B		...do vysledku
	D0=D0+	NB4BT		dalsi znaku ve vysledku
	GOTO	RO_A2R_CONT
RO_A2R_REST1
	D1SROMT
	LC(1)	5
	?A<C	P		cifra < 5?
	GOYES	+		- ano
	D1=D1+	NB4BT		- ne, dalsi znak v sromt[]
	A=A-CON	P,5-1		cifra -= 5 - 1;
+
	C=DAT1	B		z sromt[]...
	DAT0=C	B		...do vysledku
	D0=D0+	NB4BT		dalsi znak ve vysledku
	A=A-1	P		v cele iteraci odecteno 5
RO_A2R_REST0
	?A#0	P		nenulova cifra na dekadickem radu?
	GOYES	RO_A2R_REST1	- ano
RO_A2R_CONT
	A=R1.F	A		A(A): pointer na cifry...
	A=A-1	A		...aktualizovat...
	D1=A			...a dat tam, kam patri
	B=B-CON	A,2*NB4BT	index -= 2;
	C=R2.F	P		C(A): index aktualni cifry
	C=C-1	P		hotovo?
	R2=C.F	P
	GOC	+		- ano
	GOTO	RO_A2R_LOOP	- jeste ne
+
*-------------------------------*
* ULOZIT RETEZEC DO NOVEHO OBJ. *
*-------------------------------*
	A=R0.F	A		A(A): adresa vysledku
	CD0EX			C(A): konec ukladani vysledku
	C=C-A	A		delka retezce vysledku (nibble)
	D1=A			D1:   pointer na vysledek
	GOSUB	RO_A2R_MEM	D0:   pointer na data noveho objektu
	CD0EX			C(A): pointer na pridelenou pamet
	R0=C.F	A		uschovano v R0
	CD0EX
	C=C-1	A		bude se testovat CARRY, ne ZERO
RO_A2R_MOVE
	A=DAT1	B		byte z vysledku...
	DAT0=A	B		...do noveho objektu
	D0=D0+	NB4BT
	D1=D1+	NB4BT
	C=C-1	A		hotovo?
	GONC	RO_A2R_MOVE	- jeste ne
	C=R0.F	A		C(A): pointer na pridelenou pamet
	C=C-CON	A,5+5		zpet pred prolog a delku
	R0=C.F	A
*===============================*
*            HOTOVO             *
*===============================*
RO_DONE
	GOSBVL	=GETPTR
	C=R0.F	A
	DAT1=C	A		vysledny novy objekt
* LOOP
	A=DAT0	A
	D0=D0+	5
	PC=(A)

*===============================*
* NOVY RETEZEC - ALOKACE PAMETI *
*===============================*
* VSTUP:  C(A):  mnoztvi pameti [nibble]
* VYSTUP: D0:    pointer na pridelenou pamet
*         C(A):  delka retezce [byte]
* ZMENY:  A,R0,R1
RO_A2R_MEM
	AD1EX			uschovat D1...
	R1=A.F	A		...do R1
	R0=C.F	A		R0(A): delka retezce [nibble]
	C=C+CON	A,5+5		mnozstvi pameti vcetne prologu a delky
	GOSBVL	=GETTEMP
	LC(5)	=DOCSTR
	DAT0=C	A		prolog
	D0=D0+	5		preskocit prolog
	C=R0.F	A		C(A): delka retezce [nibble]
	C=C+CON	A,5		hodnota je vcetne pole delky
	DAT0=C	A		delka
	D0=D0+	5		preskocit delku na zacatek objektu
	C=R0.F	A
	CSRB.F	A		# nibble -> byte
	A=R1.F	A		z R1...
	D1=A			...obnovit D1
	RTN

*===============================*
*         JE TO RETEZEC         *
*===============================*
* R0(A): _IDX
* R1(0): _INC (1 nebo 5)
* R2(A): delka zadani (uschova C)
* R3(A): pointer na tabulku rimskych cislic sromt[]
* R4(A): pocet stejnych nebo mensich predchozich rimskych cislic
* D(0):  prechozi _IDX
* D0:    pointer na addt[] + subt[]
* D1:    pointer na znaky (zadani)
*
C2ORD	MICRO	CSRB.F P	C(A): _ORD
*
RO_R2A
	GOSUB	RO_START
	CSRB.F	A		# nibble -> byte
* D1:   pointer na znaky
* C(A): pocet znaku
	C=C-1	A
	LA(5)	MAXRO
	?C>=A	A		prilis dlouhe nebo kratke zadani?
	GOYES	RO_R2A_ERROR
	R2=C.F	A		R2(A): pocet znaku
	GOSUB	RO_SROMT	R3(A): sromt[]
	LC(5)	2*5		C(A):  delka addt[] + subt[]
	GOSUB	RO_A2R_MEM	D0:    pointer na addt[] + subt[]
*
	C=0	A		Vynulovat:
	R4=C	A		- pocet stejnych nebo mensich
	DAT0=C	A		- addt[]
	D0=D0+	5
	DAT0=C	A		- subt[]
	D0=D0-	5		D0:   pointer na addt[] + subt[]
*
	C=C-1	A		C(A): 0xFFFFF
	D=C	A		D(0): prechozi _IDX
*-------------------------------*
*   ZPRACOVANI JEDNOHO ZNAKU    *
*-------------------------------*
RO_R2A_LOOP
	AD0EX			A(A): pointer na addt[] + subt[]
	C=R3.F	A
	D0=C			D0:   sromt[]
	C=DAT1	B
	B=C	B		B(B): znak ze zadani
	D0=D0-	NB4BT
-
	D0=D0+	NB4BT		dalsi znak v sromt[]
	C=DAT0	B		C(B): znak z tabulky sromt[]
	?C#0	B		tabulka pokracuje?
	GOYES	+		- ano
RO_R2A_ERROR
	GOTO	RO_ERROR_VAL
+
	?C#B	B		znaky zadani:tabulka jsou ruzne?
	GOYES	-		- ano
	AD0EX			D0:   pointer na addt[] + subt[]
*				A(A): adresa nalezu v sromt[]
	C=R3.F	A		C(A): sromt[]
	A=A-C	A		A(A): rozdil pointeru
	ASRB.F	A		# nibble -> byte == _IDX
	R0=A.F	A		R0(A): _IDX
	LC(1)	#1		maska
	A=A&C	P		A(0):  _WHT
	A=A+A	P
	A=A+A	P		A(0):  _WHT << 2
	A=A+1	P
	R1=A.F	P		R1(0): _INC
*
	A=0	A		A(A):  smask
	C=R0.F	A		C(A):  _IDX
	?C<D	A		aktualni _IDX  >=  prechozi _IDX?
	GOYES	+		- ne,  smask: 0
	A=A-1	A		- ano, smask: -1
+
	C=R4	A		C(A):  less
	C=C-A	A		C(A):  less - smask
	C=C&A	A		C(A):  less - smask  &  smask
	R4=C	A		R4(A): nova hodnota less
	C=C-CON	A,3		less > 3?
	GONC	RO_R2A_ERROR	- ano
*
	C=R0.F	A		C(A): _IDX
	?C<=D	A		aktualni _IDX  <=  prechozi _IDX
	GOYES	RO_R2A_SUMM	- ano
*-------------------------------*
*     AKTUALNI > PREDCHOZI      *
*-------------------------------*
	C=R4	A		C(A):  less
	C=C-CON	A,2		less >= 2?
	GONC	RO_R2A_ERROR	- ano
*
	C=D	A		C(A): prechozi _IDX
	C2ORD			C(A): _ORD
	AD0EX
	D0=A			A(A): addt[]
	A=A+C	A		A(A): addt[] + _ORD
	AD0EX			A(A): addt[]
	C=DAT0	P		D0:   addt[] + _ORD
	B=C	P		B(0): addt[_ORD]
	C=0	P
	DAT0=C	P		addt[_ORD] = 0
	D0=D0+	5		D0:   subt[] + _ORD
	C=B	P		C(0): addt[_ORD]
	DAT0=C	P		subt[_ORD] = addt[_ORD]
	AD0EX			D0:   addt[]
	C=R0.F	A		C(A): _IDX
*-------------------------------*
*   PRICTENI AKTUALNI HODNOTY   *
*-------------------------------*
RO_R2A_SUMM
	D=C	A		D(A): nove prechozi _IDX
	C2ORD			C(A): _ORD
	AD0EX
	D0=A			A(A): addt[]
	A=A+C	A		A(A): addt[] + _ORD
	AD0EX			D0:   addt[] + _ORD
	C=DAT0	P
	B=C	P		C(0): addt[_ORD]
	C=R1.F	P
	C=C+B	P		C(0): addt[_ORD] + _INC
	DAT0=C	P
	AD0EX			D0:   pointer na addt[] + subt[]
	C=C+CON	P,6		prirustek stejneho radu v norme?
	GONC	+		- ano
	GOTO	RO_R2A_ERROR
+
	C=R2.F	A		C(A): zbyvajici pocet znaku
	C=C-1	A		jeste nejake znaky ze zadani?
	GOC	+		- ne, hotovo
	R2=C.F	A
	D1=D1+	NB4BT		dalsi znak ze zadani
	GOTO	RO_R2A_LOOP	- ano, pokracovat
+
*-------------------------------*
*     VYSLEDEK A JEHO DELKA     *
*-------------------------------*
	A=DAT0	A		cely obsah addt[]
	D0=D0+	5
	C=DAT0	A		cely obsah subt[]
	SETDEC
	A=A-C	A		A(A): vysledek!
	SETHEX
	LC(5)	#10000
	B=C	A
	LC(5)	5
-
	BSR	A
	C=C-1	P
	?A<B	A		je cislo mensi?
	GOYES	-		- ano
	R2=C.F	A		R2(A): delka - 1
	R3=A.F	A		R3(A): hodnota
*-------------------------------*
* ULOZIT RETEZEC DO NOVEHO OBJ. *
*-------------------------------*
	C=C+CON	A,5+5+1		mnozstvi pameti vcetne prologu a delky
	GOSBVL	=GETTEMP
	CD0EX
	D0=C
	R0=C.F	A		R0(A): pointer na novy objekt
	LC(5)	=DOINT
	DAT0=C	A		prolog
	D0=D0+	5		preskocit prolog
	C=R2.F	A		C(A): delka - 1
	C=C+CON	A,5+1		hodnota je vcetne pole delky
	DAT0=C	A		delka
	D0=D0+	5		preskocit delku na zacatek objektu
	C=R2.F	A		C(A): delka - 1
	A=R3.F	A		A(A): hodnota
-
	DAT0=A	P		cifra ulozena
	D0=D0+	1		pointer na dalsi cifru
	ASR	A		A(P): dalsi cifra
	C=C-1	P		hotovo?
	GONC	-		- ne, dalsi
	GOTO	RO_DONE

*===============================*
*  START: ADRESA+DELKA OBJEKTU  *
*===============================*
* VSTUP:  D1:   pointer na prvni uroven RPL-stacku
* VYSTUP: D1:   zacatek objektu (za prologem a delkou)
*         C(A): delka objektu [nibble]
* ZMENY:  N/A
RO_START
	GOSBVL	=SAVPTR
	C=DAT1	A
	D1=C			D1: adresa objektu na RPL-stacku
	D1=D1+	5		preskocit prolog
	C=DAT1	A		C:  delka...
	C=C-CON	A,5		...bez velikosti pole delky
	D1=D1+	5		preskocit delku na zacatek objektu
	RTN

*===============================*
*    TABULKA RIMSKYCH CISLIC    *
*===============================*
* VSTUP:  N/A
* VYSTUP: R3(A): pointer na tabulku
* ZMENY:  C(A)
RO_SROMT
	GOSUB	+
	CON(2)	'I'
	CON(2)	'V'
	CON(2)	'X'
	CON(2)	'L'
	CON(2)	'C'
	CON(2)	'D'
	CON(2)	'M'
	CON(2)	0		konec tabulky
+
	C=RSTK
	R3=C.F	A
	RTN
ENDCODE"