*        Topswops optimized        12/07/2016
TOPSWOPS CSECT
         USING  TOPSWOPS,R13       base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    prolog
         ST     R13,4(R15)         " <-
         ST     R15,8(R13)         " ->
         LR     R13,R15            " addressability
         MVC    N,=F'1'            n=1
LOOPN    L      R4,N               n; do n=1 to 10  ===-------------==*
         C      R4,=F'10'          "                                  *
         BH     ELOOPN             .                                  *
         MVC    P(40),PINIT        p=pinit
         MVC    COUNTM,=F'0'       countm=0
REPEAT   MVC    CARDS(40),P        cards=p  -------------------------+
         SR     R11,R11            count=0                           |
WHILE    CLC    CARDS,=F'1'        do while cards(1)^=1  ---------+
         BE     EWHILE             .                              |
         MVC    M,CARDS            m=cards(1)
         L      R2,M               m
         SRA    R2,1               m/2
         ST     R2,MD2             md2=m/2
         L      R3,M               @card(mm)=m
         SLA    R3,2               *4
         LA     R3,CARDS-4(R3)     @card(mm)
         LA     R2,CARDS           @card(i)=0
         LA     R6,1               i=1
LOOPI    C      R6,MD2             do i=1 to m/2  -------------+
         BH     ELOOPI             .                           |
         L      R0,0(R2)           swap r0=cards(i)
         MVC    0(4,R2),0(R3)      swap cards(i)=cards(mm)
         ST     R0,0(R3)           swap cards(mm)=r0
         AH     R2,=H'4'           @card(i)=@card(i)+4
         SH     R3,=H'4'           @card(mm)=@card(mm)-4
         LA     R6,1(R6)           i=i+1                       |
         B      LOOPI              ----------------------------+
ELOOPI   LA     R11,1(R11)         count=count+1                  |
         B      WHILE              -------------------------------+
EWHILE   C      R11,COUNTM         if count>countm
         BNH    NOTGT              then
         ST     R11,COUNTM           countm=count
NOTGT    BAL    R14,NEXTPERM       call nextperm
         LTR    R0,R0              until nextperm=0                 |
         BNZ    REPEAT             ---------------------------------+
         L      R1,N               n
         XDECO  R1,XDEC            edit n
         MVC    PG(2),XDEC+10      output n
         MVI    PG+2,C':'          output ':'
         L      R1,COUNTM          countm
         XDECO  R1,XDEC            edit countm
         MVC    PG+3(4),XDEC+8     output countm
         XPRNT  PG,L'PG            print buffer
         L      R1,N               n                                  *
         LA     R1,1(R1)           +1                                 *
         ST     R1,N               n=n+1                              *
         B      LOOPN              ===------------------------------==*
ELOOPN   L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)    " restore
         XR     R15,R15            " rc=0
         BR     R14                exit
PINIT    DC     F'1',F'2',F'3',F'4',F'5',F'6',F'7',F'8',F'9',F'10'
CARDS    DS     10F                cards
P        DS     10F                p
COUNTM   DS     F                  countm
M        DS     F                  m
N        DS     F                  n
MD2      DS     F                  m/2
PG       DC     CL20' '            buffer
XDEC     DS     CL12               temp
*------- ----   nextperm ----------{-----------------------------------
NEXTPERM L      R9,N               nn=n
         SR     R8,R8              jj=0
         LR     R7,R9              nn
         BCTR   R7,0               j=nn-1
         LTR    R7,R7              if j=0
         BZ     ELOOPJ1            then skip do loop
LOOPJ1   LR     R1,R7              do j=nn-1 to 1 by -1; j ----+
         SLA    R1,2               .                           |
         L      R2,P-4(R1)         p(j)
         C      R2,P(R1)           if p(j)<p(j+1)
         BNL    PJGEPJP            then
         LR     R8,R7                jj=j
         B      ELOOPJ1              leave j                   |
PJGEPJP  BCT    R7,LOOPJ1          j=j-1  ---------------------+
ELOOPJ1  LA     R7,1(R8)           j=jj+1
LOOPJ2   CR     R7,R9              do j=jj+1 while j<nn  ------+
         BNL    ELOOPJ2            .                           |
         LR     R2,R7              j
         SLA    R2,2               .
         LR     R3,R9              nn
         SLA    R3,2               .
         L      R0,P-4(R2)         swap p(j),p(nn)
         L      R1,P-4(R3)         "
         ST     R0,P-4(R3)         "
         ST     R1,P-4(R2)         "
         BCTR   R9,0               nn=nn-1
         LA     R7,1(R7)           j=j+1                       |
         B      LOOPJ2             ----------------------------+
ELOOPJ2  LTR    R8,R8              if jj=0
         BNZ    JJNE0              then
         LA     R0,0                 return(0)
         BR     R14                  "
JJNE0    LA     R7,1(R8)           j=jj+1
         LR     R2,R7              j
         SLA    R2,2               r@p(j)
         LR     R3,R8              jj
         SLA    R3,2               r@p(jj)
LOOPJ3   L      R0,P-4(R2)         p(j)  ----------------------+
         C      R0,P-4(R3)         do j=jj+1 while p(j)<p(jj)  |
         BNL    ELOOPJ3
         LA     R2,4(R2)           r@p(j)=r@p(j)+4
         LA     R7,1(R7)           j=j+1                       |
         B      LOOPJ3             ----------------------------+
ELOOPJ3  L      R1,P-4(R3)         swap p(j),p(jj)
         ST     R0,P-4(R3)         "
         ST     R1,P-4(R2)         "
         LA     R0,1               return(1)
         BR     R14 ---------------}-----------------------------------
         YREGS
         END    TOPSWOPS