*      Josephus problem               10/02/2017
JOSEPH CSECT
       USING  JOSEPH,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
       LA     R7,1                    m=1
       DO WHILE=(C,R7,LE,=A(NPROB))   do m=1 to nprob
         LR     R1,R7                   m
         MH     R1,=H'6'                *6
         LH     R2,PROB-6(R1)
         ST     R2,N                    n=prob(m,1)
         LH     R2,PROB-4(R1)
         ST     R2,W                    w=prob(m,2)
         LH     R2,PROB-2(R1)
         ST     R2,S                    s=prob(m,3)
         MVC    PG,=CL80'josephus'      init buffer
         L      R1,N                    n
         XDECO  R1,DEC                  edit
         MVC    PG+8(4),DEC+8           output
         L      R1,W                    w
         XDECO  R1,DEC                  edit
         MVC    PG+12(4),DEC+8          output
         L      R1,S                    s
         XDECO  R1,DEC                  edit
         MVC    PG+16(4),DEC+8          output
         XPRNT  PG,L'PG                 print buffer
         MVI    DEAD,X'00'              dead(1)='0'B;
         MVC    DEAD+1(255),DEAD        dead(*)='0'B;
         L      R11,N                   nx=n
         L      R8,=F'-1'               p=-1
         DO UNTIL=(C,R11,EQ,S)          do until n=s
           SR     R9,R9                   found=0
           DO UNTIL=(C,R9,EQ,W)           do until found=w
             LA     R8,1(R8)                p=p+1
             IF C,R8,EQ,N THEN              if p=nn then
               SR     R8,R8                   p=0
             ENDIF  ,                       end if
             LA     R2,DEAD(R8)             @dead(p+1)
             IF CLI,0(R2),EQ,X'00' THEN     if not dead(p+1) then
               LA     R9,1(R9)                found=found+1
             ENDIF  ,                       end if
           ENDDO  ,                       end do
           LA     R2,DEAD(R8)             @dead(p+1)
           MVI    0(R2),X'01'             dead(p+1)='1'B
           BCTR   R11,0                   nx=nx-1
         ENDDO  ,                       end do
         MVC    PG,=CL80' '             clear buffer
         LA     R10,PG                  ipg=0
         L      R9,N                    nn
         BCTR   R9,0                    nn-1
         SR     R6,R6                   i=0
         DO WHILE=(CR,R6,LE,R9)         do i=0 to nn-1
           LA     R2,DEAD(R6)             @dead(i+1)
           IF CLI,0(R2),EQ,X'00' THEN     if not dead(i+1) then
             XDECO  R6,DEC                  edit i
             MVC    0(4,R10),DEC+8          output
             LA     R10,4(R10)              ipg=ipg+4
           ENDIF  ,                       end if
           LA     R6,1(R6)                i=i+1
         ENDDO  ,                       end do
         XPRNT  PG,L'PG                 print buffer
         LA     R7,1(R7)                m=m+1
       ENDDO  ,                       end do
       L      R13,4(0,R13)            epilog
       LM     R14,R12,12(R13)         " restore
       XR     R15,R15                 " rc=0
       BR     R14                     exit
PROB   DC     H'41',H'3',H'1'         round 1
       DC     H'41',H'3',H'3'         round 2
NPROB  EQU    (*-PROB)/6              number of rounds
N      DS     F                       n number of prisoners
W      DS     F                       w killing count
S      DS     F                       s number of prisoners to survive
PG     DS     CL80                    buffer
DEC    DS     CL12                    temp for xdeco
DEAD   DS     256X                    n max
       YREGS
       END    JOSEPH