/****************************************************************************/
/*                                                                          */
/* BCS Algorithm 68:  White to move and mate in n moves.                    */
/*                                                                          */
/* J. R. Manning, Shoe & Allied Trades R. A., Kettering, UK.                */
/*                                                                          */
/* The Computer Journal, Vol. 14 No. 2, May 1971,209-213.                   */
/*                                                                          */
/****************************************************************************/

/* Translated from Algol 60 to PL/I by R. A. Vowels, 2 June 2008.           */

/* I have enhanced the input and output so as to show the                   */
/* pieces as letters instead of as integers.                                */
/* Black's pieces are represented by lower-case letters, while              */
/* white's pieces are represented as upper-case letters.                    */
/* Thus, Q = white's queen, q = black's queen, etc.                         */
/* An empty board square is shown as a period (.).                          */

/* Errors corrected:
/* 1.  In procedure SCANMO, orthagonal move by Rook or Queen,
/*     "if w = 7 | w = 9 then" should be "if w = 7 | w = 8 then",
/*     in order to involve Queen.
/* 2.  In OWNCH, searching for friendly king:  Loop should search positions */
/*     from 1 to 78, not 1 to 79.
/* 3.  stal may need initializing. */

/* This program solves chess problems of the type "White to                 */
/* move and mate in n moves".                                               */

/* x      is the depth of search;
/* a(x,m) takes the value 0 if square m is empty,
/*        and the values -1, -3, -4, -7, -8, -9
/*        if it is occupied by an enemy pawn, knight, bishop,
/*        rook, queen or king repectively,
/*        and +1, +3, +4, +7, +8, +9 if it is occupied by a
/*        friendly pawn, knight, bishop, rook, queen or king.
/*        Note that the board is treated as a linear vector
/*        of 64 elements, not as an 8 x 8 matrix.
/*        One cross-section a(k,*) represents the positions
/*        of the pieces after one move.  A(1,*) is the
/*        initial position, A(2,*) is black's reply; a(3,*)
/*        is white's reply to black, and so on.
/* stal   is used to guard against the possibility of a
/*        stalemate.
/* ep(*)  holds information about en passant moves.
/* exh    appears to be true if all white's moves are exhausted for
/*        this square, false otherwise.
/* val    An array whose values are true when a board square is a
/*        valid square, i.e., for the positions 1 to 8, 11 to 18, etc,
/*        as enumerated for array A below.

/* After each trial move, the Boolean procedure OWNCH is
/* entered to test whether one's own king is left in check.
/* If not, then the board is reversed
/* ( a(x+1, m) = -a(x,79-m) ) and the computer is ready to
/* 'play from the opposite side'.                             */

/* The board - array a - is represented as follows.  Actual
/* board positions are numbered from 1 to 8, 11 to 18,
/* 21 to 28, 31 to 38, 41 to 48, 51 to 58, 61 to 68,
/* 71 to 78, as indicated within the square marked by four
/* crosses (x).
/* Note that board positions (e.g., 38) can be read as
/* co-ordinates (e,g,, 3,8) measured from top left-hand corner
/* of the board, rows numbering from 0, and columns numbering
/* from 1.

+----+----+----+----+----+----+----+----+----+----+----+----+
|    |-20 |-19 |-18 |-17 |-16 |-15 |-14 |-13 |-12 |-11 |-10 |
+----+----+----+----+----+----+----+----+----+----+----+----+
|-11 |-10 | -9 | -8 | -7 | -6 | -5 | -4 | -3 | -2 | -1 |  0 |
+----+----x----+----+----+----+----+----+----+----x----+----+
| -1 |  0 |  1 |  2 |  3 |  4 |  5 |  6 |  7 |  8 |  9 | 10 |
+----+----+----+----+----+----+----+----+----+----+----+----+
|  9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 |
+----+----+----+----+----+----+----+----+----+----+----+----+
| 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 |
+----+----+----+----+----+----+----+----+----+----+----+----+
| 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 |
+----+----+----+----+----+----+----+----+----+----+----+----+
| 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 |
+----+----+----+----+----+----+----+----+----+----+----+----+
| 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 |
+----+----+----+----+----+----+----+----+----+----+----+----+
| 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 |
+----+----+----+----+----+----+----+----+----+----+----+----+
| 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 |
+----+----x----+----+----+----+----+----+----+----x----+----+
| 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 |
+----+----+----+----+----+----+----+----+----+----+----+----+
| 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 |    |
+----+----+----+----+----+----+----+----+----+----+----+----+

*/

(SUBRG, FOFL, SIZE):
CHESS: PROCEDURE OPTIONS (MAIN);
	declare (y, n, j) fixed binary;
	declare board file;
	declare debug bit (1) static aligned initial ('0'b);

	put ('How many moves to mate?:');
	get list (n);
	y = n + n;
	begin;
		declare (a(y+1, -20:99), ep(0:y+1) ) fixed binary (7);
		declare (x, s, z) fixed binary;
		declare (val(-20:99), stal(0:y+1), exh(0:y+1), white) bit (1) aligned;

/* This procedure returns TRUE ('1'b) if own king is in check. */

OWNCH: PROCEDURE (xp) returns (bit(1) aligned) OPTIONS (REORDER);
	declare xp fixed binary;
	declare (x, k, mk, m) fixed binary;
	declare result bit (1) aligned;

	on error snap system;

	x = xp;
	result = '1'b;

	if debug then put skip list ('Looking for friendly King.');
	/* Search for friendly King. */
	do m = 1 to 78; /* corrected; was 79. */
		if a(x,m) = 9 then
			do;
				mk = m; /* mk is square where the king is. */
				go to L4;
			end;
	end;

	/* Look for threats of check from opponent's pawns or pieces. */

	/* Look out for opponent's Knight. */
L4:	if debug then put skip edit ('Found friendly king at position ', trim(mk)) (A);
	if debug then put skip list ('Looking for threat of check from opponent''s Knight');
	do m = 8, 12, 19, 21;
		if a(x, mk+m) = -3 | a(x, mk-m) = -3 then go to L1;
	end;

	/* Look out for opponent's pawn. */
	if debug then put skip list ('Looking for threat of check from opponent''s pawn');
	if a(x, mk-9) = -1 | a(x, mk-11) = -1 then go to L1;

	/* Look out for opponent's King. */
	if debug then put skip list ('Looking for threat of check from opponent''s King');
	do m = 11, 10, 9, 1;
		if a(x, mk+m) = -9 | a(x, mk-m) = -9 then go to L1;
	end;

	/* Look out for opponent's Rook and Queen (orthogonal move). */
	if debug then
		put skip list ('Looking for threat of check from opponent''s Rook or Queen');
	do m = -1, -10, 1, 10;
		k = mk;
		do k = k+m by m while (val(k));
			if a(x, k) = -7 | a(x, k) = -8 then
				go to L1;
			else
				if a(x, k) ^= 0 then go to L2;
		end;
L2:	end;

	/* Look out for opponent's Bishop and Queen (diagonal move). */
	if debug then
		put skip list ('Looking for threat of check from opponent''s Bishop or Queen');
	do m = -9, -11, 9, 11;
		k = mk;
		do k = k+m by m while (val(k));
			if a(x, k) = -4 | a(x,k) = -8 then
				go to L1;
			else
				if a(x, k) ^= 0 then go to L3;
		end;
L3:	end;
	if debug then put skip list ('OWNCH is FALSE.');
	return ( '0'b );

L1:
	if debug then put skip list ('OWNCH is TRUE.');
	return ( result );

END OWNCH;

/* Procedure TRYM makes a trial move by moving a piece from square    */
/* p to square q.  The argument corresponding to R is always SCANMO.  */

TRYM: PROCEDURE (PP, QP, R) RECURSIVE OPTIONS (REORDER);
	declare (pp, qp) fixed binary;
	declare (p, q) fixed binary;
	declare r entry ();
	declare (d, m) fixed binary;

	on error snap system;

	if debug then put skip edit ('ENTERED TRYM to move piece at ',
		trim(pp), ' to position ', trim(qp)) (a);

	p = pp; q = qp;

	exh(x) = '0'b;
	d = a(x, q);        /* Save the piece at position q ... */
	a(x, q) = a(x, p);  /* ... and move the piece at position p there, */
	a(x, p) = 0;        /* ... and delete the piece originally at position p. */

	if ownch(x) then
		do;         /* The piece moved into check. */
			a(x, p) = a(x, q);  a(x, q) = d; /* Restore the board. */
			if debug then put skip list ('TRYM: MOVED INTO CHECK, SO BACK UP.');
			go to M6;
		end;

	stal(x) = '0'b;
	if x = y then
		do;
			exh(x) = '1'b; go to M6;
		end;

	if debug then call display_board(x);

	/* Reverse the Board storing the new board one level higher, */
	/* so that computer plays from the opposite side.            */
	do m = 1 to 78;
		a(x+1, m) = -a(x, 79-m);
	end;

	/* Board is reversed so that computer plays from the opposite side. */

	if debug then call display_board(x+1);

	a(x, p) = a(x, q); a(x, q) = d;

	if white then
		do;
			stal(x+1) = ^ownch(x+1);
			if x = y-1 & stal(y) then go to M6;
		end;

	white = ^white; x = x + 1;
	if x > j then j = x;

	call r;
	x = x-1; white = ^white;

	if exh(1) & ^stal(j) then
		do;
			m = a(1, p);
			put skip edit ('Mate in ', trim(isrl(j, 1)), ': key move from position ',
				display_position (p), ' to position ',
				display_position (q), ' ' ) (A);

			if m = 1 then
				do;
					put skip list ('pawn');
					if q > 70 then
						do;
							put edit ('=') (a);
							m = -a(2, 79-q);
						end;
				end;
			select (m);
				when (3) put edit ('knight') (a);
				when (4) put edit ('bishop') (a);
				when (7) put edit ('rook')   (a);
				when (8) put edit ('queen')  (a);
				otherwise put edit ('king')  (a);
			end;
			exh(1) = '0'b;
		end;
	if x = 1 then j = x;
M6:
END TRYM;

/* This procedure scans all possible moves, one by one.  When a possible  */
/* move is found, TRYM is invoked.                                        */

SCANMO: PROCEDURE () RECURSIVE OPTIONS (REORDER);
	declare (w, i, m, k) fixed binary;

RETRACE: PROCEDURE();
	on error snap system;
	if ^stal(x+1) | ^white then go to L5;
END RETRACE;

	on error snap system;

	w = ep(x-1);

	/* en passant capture. */
	if w > 0 then
		do m = 80-w, 78-w;
			if a(x,m) = 1 then
				do;
					a(x, 79-w) = 0;
					call trym(m, 69-w, scanmo);
					a(x, 79-w) = -1;
					if exh(x) then call retrace;
				end;
		end; /* of e.p. capture. */

	do m = 1 to 78;
		w = a(x, m);
		if w < 1 then go to L4; /* Skip opponent's pawn or piece, and empty square. */
		/* Pawn move. */
		if w = 1 then
			do;
				if a(x, m-10) = 0 then
					do;
						if m < 19 then
							/* pawn promotion to knight, bishop, */
							/* rook, or queen. */
							do k = 3, 4, 7, 8;
								a(x, m) = k;
								call trym(m, m-10, scanmo);
								a(x, m) = 1;
								if exh(x) then call retrace;
							end;
						else
							do;
								call trym(m, m-10, scanmo);
								if exh(x) then call retrace;
							end;
						if m > 60 & m < 69 & a(x, m-20) = 0 then
						do; /* double move by pawn. */
							ep(x) = m-20;
							call trym(m, m-20, scanmo);
							ep(x) = 0;
							if exh(x) then call retrace;
						end;
					end;

				do i = 9, 11;
					if a(x, m-i) < 0 then
						do;
							if m < 19 then
								/* Pawn promotion by capture. */
								do k = 3, 4, 7, 8;
									a(x,m) = k;
									call trym(m, m-i, scanmo);
									a(x,m) = 1;
									if exh(x) then call retrace;
								end;
							else /* pawn capture. */
								do;
									call trym(m, m-i, scanmo);
									if exh(x) then call retrace;
								end;
						end;
				end;
			end; /* pawn move. */

		/* Knight move. */
		if w = 3 then
			do i = 8, 12, 19, 21, -8, -12, -19, -21;
				if a(x, i+m) < 1 & val(i+m) then
					do;
						call trym(m, i+m, scanmo);
						if exh(x) then call retrace;
					end;
			end; /* knight move. */

		/* Diagonal move by bishop or queen. */
		if w = 4 | w = 8 then
			do i = -11, -9, 9, 11;
				k = m;
				do k = k+i by i while (val(k) & a(x, k) < 1);
					call trym(m, k, scanmo);
					if exh(x) then call retrace;
					if a(x, k) ^= 0 then go to Q7;
				end;
Q7:			end; /* diagonal move. */

		/* Orthogonal move by rook or queen. */
		if w = 7 | w = 8 then	/* This was w = 9, but 9 is King. */
					/* Changed to 8 for queen. */
			do i = -10, -1, 1, 10;
				if debug then
					do;
						if w = 7 then
							put skip edit (
						'Checking Rook moves at position ', trim(m)) (a);
						else
							put skip edit (
						'Checking orthogonal Queen moves at position ',
							trim(m))(a);
					end;
				k = m;
				do k = k+i by i while (val(k) & a(x, k) < 1);
					if debug then
						put skip edit ('Checking position ', trim(k)) (A);
					call trym (m, k, scanmo);
					if exh(x) then call retrace;
					if a(x, k) ^= 0 then go to Q8;
				end;
Q8:			end; /* of orthogonal move. */

		/* King move */
		if w = 9 then
			do i = -11, -10, -9, -1, 1, 9, 10, 11;
				if a(x, i+m) < 1 & val(i+m) then
					do;
						call trym(m, i+m, scanmo);
						if exh(x) then call retrace;
					end;
			end; /* of King move. */
L4:
	end;

	exh(x-1) = '1'b;
L5:
END SCANMO;

/* Displays a position in algebraic notation. */
DISPLAY_POSITION: PROCEDURE (m) RETURNS ( CHAR(2) );
	declare m fixed binary;
	declare (row, column) fixed binary (7);

	on error snap system;

	row = 8 - divide(m, binary(10), 7, 0);

	column = mod(m, 10);

	return ( substr('ABCDEFGH', column, 1) || substr('12345678', row, 1) );

END DISPLAY_POSITION;

DISPLAY_BOARD:
	PROCEDURE (level);
	declare level fixed binary;
	declare (s, z) fixed binary (7);

	put skip list ('Level ' || trim(level));

	do s =1 to 71 by 10;
		put skip edit (' ') (col(25), a);
		do z = 0 to 7;
			select ( a(level, s+z) );
				when (-1) put edit ('p') (x(1), a);
				when (-3) put edit ('n') (x(1), a);
				when (-4) put edit ('b') (x(1), a);
				when (-7) put edit ('r') (x(1), a);
				when (-8) put edit ('q') (x(1), a);
				when (-9) put edit ('k') (x(1), a);
				when ( 1) put edit ('P') (x(1), a);
				when ( 3) put edit ('N') (x(1), a);
				when ( 4) put edit ('B') (x(1), a);
				when ( 7) put edit ('R') (x(1), a);
				when ( 8) put edit ('Q') (x(1), a);
				when ( 9) put edit ('K') (x(1), a);
				otherwise put edit ('.') (x(1), a);
			end;
		end;
	end;
END DISPLAY_BOARD;

INPUT_BOARD: PROCEDURE;
	declare v character (1);
	declare k fixed binary (7);
	declare (s, z) fixed binary (7);

	do s =1 to 71 by 10;
		do z = 0 to 7;
			get file (board) edit (v) (a(1));
			select (v);
				when ('p') k = -1;
				when ('n') k = -3;
				when ('b') k = -4;
				when ('r') k = -7;
				when ('q') k = -8;
				when ('k') k = -9;
				when ('P') k =  1;
				when ('N') k =  3;
				when ('B') k =  4;
				when ('R') k =  7;
				when ('Q') k =  8;
				when ('K') k =  9;
				when ('.') k =  0;
				otherwise
					do;
						put skip list
					('Invalid piece, ' || v || '.  Empty square assumed');
						k = 0;
					end;
			end;
			a(1, s+z) = k;
			val(s+z) = '1'b;
		end;
	end;
END INPUT_BOARD;

	/* Initialize the board. */
	do s = -20 to 99;
		val(s) = '0'b;
		do z = 1 to y+1;
			a(z,s) = 0;
		end;
	end;

	stal = '0'b; /* may need initializing? */

	/* Obtain the values and the implied board positions from the player. */
	put skip list
		('Please type the 64 values representing the pieces and their implied positions:');

	open file (board) title ( '/BOARD.DAT,TYPE(CRLF),RECSIZE(80)' ) input;

	/* read in the initial position. */

	call input_board;

/*	do s =1 to 71 by 10;
		do z = 0 to 7;
			get file (board) list (a(1, s+z));
			val(s+z) = '1'b;
		end;
	end;
*/

	call display_board (1); /* Display the initial position. */

	ep = 0;

	/* En passant capture is forbidden on white's first move. */
	stal(1), white = '1'b;
	x, j = 1;
	call scanmo;

	put skip list ('No other solution');

	end; /* of the BEGIN block. */

END CHESS;