68 lines
3 KiB
Text
68 lines
3 KiB
Text
* Roman numerals Decode - 17/04/2019
|
|
ROMADEC CSECT
|
|
USING ROMADEC,R13 base register
|
|
B 72(R15) skip savearea
|
|
DC 17F'0' savearea
|
|
SAVE (14,12) save previous context
|
|
ST R13,4(R15) link backward
|
|
ST R15,8(R13) link forward
|
|
LR R13,R15 set addressability
|
|
LA R6,1 i=1
|
|
DO WHILE=(C,R6,LE,=A(NV)) do i=1 to hbound(vals)
|
|
LR R1,R6 i
|
|
SLA R1,3 ~
|
|
LA R4,VALS-L'VALS(R1) @vals(i)
|
|
MVC X,0(R4) x=vals(i)
|
|
SR R9,R9 prev=0
|
|
ST R9,Y y=0
|
|
LA R7,L'X j=1
|
|
DO WHILE=(C,R7,GE,=A(1)) do j=length(x) to 1 by -1
|
|
LA R4,X-1 @x
|
|
AR R4,R7 +j
|
|
MVC C,0(R4) c=substr(x,j,1)
|
|
IF CLI,C,NE,C' ' THEN if c^=' ' then
|
|
SR R1,R1 r1=0
|
|
LA R2,1 k=1
|
|
DO WHILE=(C,R2,LE,=A(L'ROMAN)) do k=1 to length(roman)
|
|
LA R3,ROMAN-1 @roman
|
|
AR R3,R2 +k
|
|
IF CLC,0(L'C,R3),EQ,C THEN if substr(roman,k,1)=c
|
|
LR R1,R2 index=k
|
|
B REINDEX leave k
|
|
ENDIF , endif
|
|
LA R2,1(R2) k=k+1
|
|
ENDDO , enddo k
|
|
REINDEX EQU * r1=index(roman,c)
|
|
SLA R1,2 ~
|
|
L R8,DECIM-4(R1) n=decim(index(roman,c))
|
|
IF CR,R8,LT,R9 THEN if n<prev then
|
|
LCR R8,R8 n=-n
|
|
ENDIF , endif
|
|
L R2,Y y
|
|
AR R2,R8 +n
|
|
ST R2,Y y=y+n
|
|
LR R9,R8 prev=n
|
|
ENDIF , endif
|
|
BCTR R7,0 j--
|
|
ENDDO , enddo j
|
|
MVC PG(8),X x
|
|
L R1,Y y
|
|
XDECO R1,XDEC edit y
|
|
MVC PG+12(4),XDEC+8 output y
|
|
XPRNT PG,L'PG print buffer
|
|
LA R6,1(R6) i++
|
|
ENDDO , enddo i
|
|
L R13,4(0,R13) restore previous savearea pointer
|
|
RETURN (14,12),RC=0 restore registers from calling sav
|
|
NV EQU (X-VALS)/L'VALS
|
|
ROMAN DC CL7'MDCLXVI'
|
|
DECIM DC F'1000',F'500',F'100',F'50',F'10',F'5',F'1'
|
|
VALS DC CL8'XIV',CL8'CMI',CL8'MIC',CL8'MCMXC',CL8'MDCLXVI'
|
|
DC CL8'MMVIII',CL8'MMXIX',CL8'MMMCMXCV'
|
|
X DS CL(L'VALS)
|
|
Y DS F
|
|
C DS CL1
|
|
PG DC CL80'........ -> ....'
|
|
XDEC DS CL12
|
|
REGEQU
|
|
END ROMADEC
|