252 lines
11 KiB
Text
252 lines
11 KiB
Text
* Permutations/Derangements 01/04/2017
|
|
DERANGE CSECT
|
|
USING DERANGE,R13 base register
|
|
B 72(R15) skip savearea
|
|
DC 17F'0' savearea
|
|
STM R14,R12,12(R13) save previous context
|
|
ST R13,4(R15) link backward
|
|
ST R15,8(R13) link forward
|
|
LR R13,R15 set addressability
|
|
XPRNT PG1,L'PG1 print title
|
|
LA R1,4 4
|
|
LA R2,1 1 : combinations print
|
|
BAL R14,DERGEN call dergen
|
|
STH R0,COUNT count=dergen(4,1)
|
|
XPRNT PG2,L'PG2 print table headings
|
|
XPRNT PG3,L'PG3 print hyphens
|
|
SR R4,R4
|
|
STH R4,II ii=0
|
|
DO WHILE=(CH,R4,LE,=H'9') do ii=0 to 9
|
|
MVC PG,=CL80' ' clear buffer
|
|
XDECO R4,PG edit ii
|
|
LR R1,R4 ii
|
|
LA R2,0 0 : no combination print
|
|
BAL R14,DERGEN dergen(ii,0)
|
|
XDECO R0,PG+12 edit
|
|
LH R1,II ii
|
|
BAL R14,SUBFACT subfact(ii)
|
|
XDECO R0,PG+24 edit
|
|
XPRNT PG,L'PG print
|
|
LH R4,II ii
|
|
LA R4,1(R4) i+1
|
|
STH R4,II i=i+1
|
|
ENDDO , enddo i
|
|
LA R0,12 12
|
|
STH R0,II ii=12
|
|
MVC PG,=CL16'!xx=' init buffer
|
|
XDECO R0,XDEC edit ii
|
|
MVC PG+1(2),XDEC+10 output
|
|
LH R1,II ii
|
|
BAL R14,SUBFACT subfact(ii)
|
|
XDECO R0,PG+4 edit subfact(ii)
|
|
XPRNT PG,16 print
|
|
L R13,4(0,R13) restore previous savearea pointer
|
|
LM R14,R12,12(R13) restore previous context
|
|
XR R15,R15 rc=0
|
|
BR R14 exit
|
|
*------- ---- -------------------------------------------
|
|
DERGEN EQU * dergen(n,fprt)
|
|
ST R14,SAVEDG
|
|
ST R1,N n
|
|
ST R2,FPRT fprt
|
|
IF LTR,R1,Z,R1 THEN if n=0 then
|
|
LA R0,1 1
|
|
B RETDG return(1)
|
|
ENDIF , endif
|
|
MVC C,=F'0' c=0
|
|
LA R6,1 i=1
|
|
DO WHILE=(C,R6,LE,N) do i=1 to 2
|
|
LR R1,R6 i
|
|
SLA R1,1
|
|
STH R6,A-2(R1) a(i)=i
|
|
STH R6,AO-2(R1) ao(i)=i
|
|
LA R6,1(R6) i++
|
|
ENDDO , enddo i
|
|
L R1,N n
|
|
BAL R14,FACT
|
|
ST R0,FACTNM1 fact(n)-1
|
|
SR R6,R6 i=0
|
|
DO WHILE=(C,R6,LE,FACTNM1) do i=0 to fact(n)-1
|
|
L R1,N n
|
|
BAL R14,NEXTPER call nextper(n)
|
|
MVI D,X'01' d=true
|
|
LA R7,1
|
|
DO WHILE=(C,R7,LE,N) do j=1 to n
|
|
LR R1,R7 j
|
|
SLA R1,1
|
|
LH R2,A-2(R1) a(j)
|
|
LH R3,AO-2(R1) ao(j)
|
|
IF CR,R2,EQ,R3 THEN if a(j)=ao(j) then
|
|
MVI D,X'00' d=false
|
|
ENDIF , endif
|
|
LA R7,1(R7) j++
|
|
ENDDO , enddo j
|
|
IF CLI,D,EQ,X'01' THEN if d then
|
|
L R2,C c
|
|
LA R2,1(R2) c+1
|
|
ST R2,C c=c+1
|
|
IF CLI,FPRT+3,EQ,X'01' THEN if fprt=1 then
|
|
MVC PG,=CL80' ' clear buffer
|
|
LA R10,PG pgi=0
|
|
LA R7,1 j=1
|
|
DO WHILE=(C,R7,LE,N) do j=1 to n
|
|
LR R1,R7 j
|
|
SLA R1,1
|
|
LH R2,A-2(R1) a(j)
|
|
XDECO R2,XDEC edit
|
|
MVC 0(1,R10),XDEC+11 output
|
|
LA R10,2(R10) pgi=pgi+2
|
|
LA R7,1(R7) j++
|
|
ENDDO , enddo j
|
|
XPRNT PG,L'PG print
|
|
ENDIF , endif
|
|
ENDIF , endif
|
|
LA R6,1(R6) i++
|
|
ENDDO , enddo i
|
|
L R0,C c
|
|
B RETDG return(c)
|
|
RETDG L R14,SAVEDG
|
|
BR R14
|
|
SAVEDG DS A
|
|
*------- ---- -------------------------------------------
|
|
NEXTPER EQU * nextper(nk)
|
|
ST R14,SAVENP
|
|
ST R1,NK nk
|
|
BCTR R1,0 nk-1
|
|
ST R1,NELEM nelem=nk-1
|
|
IF C,R1,LT,=F'1' THEN if nelem<1 then
|
|
LA R0,0 return(0)
|
|
B RETNP
|
|
ENDIF , endif
|
|
L R8,NELEM nelem
|
|
BCTR R8,0 pos=nelem-1
|
|
LOOPW1 EQU * while a(pos+1)>=a(pos+2)
|
|
LR R1,R8 pos
|
|
SLA R1,1
|
|
LH R2,A(R1) a(pos+1)
|
|
CH R2,A+2(R1) if a(pos+1)<a(pos+2)
|
|
BL ELOOPW1 then exit while
|
|
BCTR R8,0 pos=pos-1
|
|
IF LTR,R8,M,R8 THEN if pos<0 then
|
|
LA R1,0 0
|
|
L R2,NELEM nelem
|
|
BAL R14,PERMREV call permrev(0,nelem)
|
|
LA R0,0 return(0)
|
|
B RETNP
|
|
ENDIF , endif
|
|
B LOOPW1 endwhile
|
|
ELOOPW1 L R9,NELEM last=nelem
|
|
LOOPW2 EQU * do while a(last+1)<=a(pos+1)
|
|
LR R1,R9 last
|
|
SLA R1,1
|
|
LH R2,A(R1) a(last+1)
|
|
LR R1,R8 pos
|
|
SLA R1,1
|
|
CH R2,A(R1) if a(last+1)>a(pos+1)
|
|
BH ELOOPW2 then exit while
|
|
BCTR R9,0 last=last-1
|
|
B LOOPW2 endwhile
|
|
ELOOPW2 LR R1,R8 pos
|
|
SLA R1,1 *2
|
|
LA R2,A(R1) @a(pos+1)
|
|
LR R1,R9 last
|
|
SLA R1,1
|
|
LA R3,A(R1) @a(last+1)
|
|
LH R0,0(R2) w=a(pos+1)
|
|
MVC 0(2,R2),0(R3) a(pos+1)=a(last+1)
|
|
STH R0,0(R3) a(last+1)=w
|
|
LA R1,1(R8) pos+1
|
|
L R2,NELEM nelem
|
|
BAL R14,PERMREV call permrev(pos+1,nelem)
|
|
RETNP L R14,SAVENP
|
|
BR R14
|
|
SAVENP DS A
|
|
*------- ---- -------------------------------------------
|
|
PERMREV EQU * permrev(firstix,lastix)
|
|
LR R4,R1 xfirst
|
|
LR R5,R2 xlast
|
|
DO WHILE=(CR,R4,LT,R5) do while(xfirst<xlast)
|
|
LR R1,R4 xfirst
|
|
SLA R1,1 *2
|
|
LA R2,A(R1) @a(xfirst+1)
|
|
LR R1,R5 xlast
|
|
SLA R1,1 *2
|
|
LA R3,A(R1) @a(xlast+1)
|
|
LH R0,0(R2) w=a(xfirst+1)
|
|
MVC 0(2,R2),0(R3) a(xfirst+1)=a(xlast+1)
|
|
STH R0,0(R3) a(xlast+1)=w
|
|
LA R4,1(R4) xfirst=xfirst+1
|
|
BCTR R5,0 xlast=xlast-1
|
|
ENDDO , enddo
|
|
BR R14
|
|
*------- ---- ----------------------------------------
|
|
FACT EQU * fact(n)
|
|
IF C,R1,LE,=F'1' THEN if n<=1 then
|
|
LA R0,1 return(1)
|
|
ELSE , else
|
|
LA R5,1 f=1
|
|
LA R2,1 i=1
|
|
DO WHILE=(CR,R2,LE,R1) do i=1 to n
|
|
MR R4,R2 f*i
|
|
LA R2,1(R2) i++
|
|
ENDDO , enddo
|
|
LR R0,R5 return(f)
|
|
ENDIF , endif
|
|
BR R14
|
|
*------- ---- -------------------------------------------
|
|
SUBFACT EQU * subfact(n)
|
|
ST R1,NY n
|
|
IF LTR,R1,Z,R1 THEN if n=0 then
|
|
LA R0,1 return(1)
|
|
ELSE , else
|
|
LA R4,1 1
|
|
ST R4,TT tt(0)=1
|
|
ST R4,IY i=1
|
|
DO WHILE=(C,R4,LE,NY) do i=1 to n
|
|
L R4,IY i
|
|
SRDA R4,32
|
|
D R4,=F'2' i/2
|
|
IF LTR,R4,Z,R4 THEN if i//2=0 then
|
|
LA R0,1 nn=1
|
|
ELSE , else
|
|
L R0,=F'-1' nn=-1
|
|
ENDIF , endif
|
|
L R1,IY i
|
|
SLA R1,2
|
|
L R3,TT-4(R1) tt(i-1)
|
|
M R2,IY *i
|
|
AR R3,R0 +nn
|
|
L R1,IY i
|
|
SLA R1,2
|
|
ST R3,TT(R1) tt(i)=i*tt(i-1)+nn
|
|
L R4,IY i
|
|
LA R4,1(R4) i++
|
|
ST R4,IY i
|
|
ENDDO , enddo
|
|
L R1,NY n
|
|
SLA R1,2
|
|
L R0,TT(R1) return(tt(n))
|
|
ENDIF , endif
|
|
BR R14
|
|
* ---- -------------------------------------------
|
|
A DS 12H A work
|
|
AO DS 12H A origin
|
|
II DS H
|
|
COUNT DS H
|
|
N DS F
|
|
FPRT DS F flag for printing
|
|
C DS F
|
|
D DS X boolean : a(i) different ao(i)
|
|
FACTNM1 DS F fact(n)-1
|
|
NK DS F n in nextper
|
|
NELEM DS F n elements in nextper
|
|
NY DS F n in subfact
|
|
IY DS F i in subfact
|
|
TT DS 13F tt(0:12)
|
|
PG1 DC CL44'derangements for the numbers : 1 2 3 4 are :'
|
|
PG2 DC CL38' table of n counted calculated :'
|
|
PG3 DC CL36' ----------- ----------- -----------'
|
|
XDEC DS CL12 temp for xdeco
|
|
PG DC CL80' ' buffer
|
|
YREGS
|
|
END DERANGE
|