# Matthew Russell
# Experimental Math
# Homework 5
# I give permission to post this

#####################################################################################

# By modifying procedure Sphere(G,i,k),
# write a procedure
# SphereWithPaths(G,i,k)
# that outputs a set of paths
# of minimal length k starting at i,
# where a path is given a list of vertices,
# but in case of multiple paths of length k
# ending at a given vertex, you only have one of them.
# For example
# SphereWithPaths([{2,3},{4},{4},{}],1,2) ;
# may output {[1,2,4]}
# or {[1,3,4]}
# (which one being a random choice of the machine)

Sphere:=proc(G,i,k) local S, s, kk:
option remember:

if k=0 then
	return {i}:
fi:

S:=Sphere(G,i,k-1):

return {seq(op(G[s]), s in S)} minus `union`(seq(Sphere(G,i,kk),kk=0..k-1)):

end:

SphereWithPaths:=proc(G,i,k) local S, T, j, T1, s, r:
option remember:

if k=0 then
	return {[i]}:
fi:

S:=SphereWithPaths(G,i,k-1):
T:={}:
for j in Sphere(G,i,k) do
	T1:={}:
	for s in S do
		if j in G[s[nops(s)]] then
			T1:=T1 union {[op(s),j]}:
		fi:
	od:
	r:=rand(1..nops(T1))():
	T:=T union {T1[r]}:
od:

return T:

end:

#####################################################################################

# A krook is a hybrid of a chess King and a chess rook,
# i.e. it is like a Queen that can only move diagonally one unit.
# Modify program Qnk(n,k) to write a program,
# Knk(n,k)
# to generate the set of ways of placing k non-attacking krooks
# on a k by n chess-board.
# Is the (start of the) sequence
# [seq(nops(Knk(n,n),n=1..infinity)]
# in Sloane?

KnkChildren:=proc(L,n) local i, S, s, k, flag:
S:={}:
k:=nops(L):
for s in {seq(i,i=1..n)} minus {op(L)} do
	flag:=true:
	if {false,seq(evalb(abs(L[i]-s)=k+1-i),i=max(k,1)..k)}={false} then
		S:=S union {[op(L),s]}:
	fi:
od:

return S:

end:

Knk:=proc(n,k) local NewS, S, L:
option remember:

if k=0 then
	return {[]}:
fi:

S:=Knk(n,k-1):
NewS:={}:
for L in S do
	NewS:=NewS union KnkChildren(L,n):
od:

return NewS:

end:

# This is A002464: 1, 0, 0, 2, 14, 90, 646, 5242

#####################################################################################

# A mook of order r is a hybrid of a chess King and a chess rook,
# i.e. it is like a Queen that can only move diagonally up to r units.
# In particular, a mook of order 1 is a krook.
# Modify program Knk(n,k)
# to write a program,
# Mnk(n,k,r)
# to generate the set of ways
# of placing k non-attacking mooks of order r
# on a k by n chess-board.
# (Of course Mnk(n,k,1) is the same as Knk(n,k)
# and Mnk(n,k,k) is the same as Qnk(n,k), please check!)
# For what values of r are the (starts of the) sequences
# [seq(nops(Mnk(n,n,r),n=1..infinity)]
# in Sloane?

MnkChildren:=proc(L,n,r) local i, S, s, k, flag:
S:={}:
k:=nops(L):
for s in {seq(i,i=1..n)} minus {op(L)} do
	flag:=true:
	if {false,seq(evalb(abs(L[i]-s)=k+1-i),i=max(1,k-r+1)..k)}={false} then
		S:=S union {[op(L),s]}:
	fi:
od:

return S:

end:

Mnk:=proc(n,k,r) local NewS, S, L:
option remember:

if k=0 then
	return {[]}:
fi:

S:=Mnk(n,k-1,r):
NewS:={}:
for L in S do
	NewS:=NewS union MnkChildren(L,n,r):
od:

return NewS:

end:

# Nothing past r=1 appears to be in the OEIS:
# r=2: 1, 0, 0, 2, 10, 32, 164, 1290, 10404
# r=3: 1, 0, 0, 2, 10, 24, 96, 612, 4268
# r=4: 1, 0, 0, 2, 10, 8, 56, 304, 1820

#####################################################################################

# Use directed graphs to solve the problem
# of n missionaries and n cannibals
# having to cross a river with a row boat
# that can only contain one or two persons,
# where no missionary gets eaten up
# (so at no time can either bank have more cannibals
# than missionaries, unless the number of missionaries
# on that bank is zero).

# MissCann(n,P):
# inputs n, number of missionaries and cannibals
# along with a state P, where
# P[1] = number of missionaries on the left bank
# P[2] = number of cannibals on the left bank
# P[3] = state of boat (0 on left, 1 on right)
# outputs all possible states that can legally be transitioned to
MissCann:=proc(n,P) local MissLeft, CannLeft, Boat, S, Pn:
option remember:
MissLeft:=P[1]:
CannLeft:=P[2]:
Boat:=P[3]:

S:={}:
if Boat=0 then
	Pn:=[MissLeft-1,CannLeft,1]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft,CannLeft-1,1]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft-2,CannLeft,1]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft-1,CannLeft-1,1]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft,CannLeft-2,1]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
fi:
if Boat=1 then
	Pn:=[MissLeft+1,CannLeft,0]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft,CannLeft+1,0]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft+2,CannLeft,0]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft+1,CannLeft+1,0]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
	Pn:=[MissLeft,CannLeft+2,0]:
	if IsLegalState(n,Pn) then
		S:=S union {Pn}:
	fi:
fi:

return S:

end:

IsLegalState:=proc(n,P) local MissLeft, CannLeft, Boat:
option remember:
MissLeft:=P[1]:
CannLeft:=P[2]:
Boat:=P[3]:

if MissLeft<0 or CannLeft<0 or MissLeft>n or CannLeft>n then
	return false:
fi:
if MissLeft>0 and MissLeft<CannLeft then
	return false:
fi:
if n-MissLeft>0 and n-MissLeft<n-CannLeft then
	return false:
fi:

return true:

end:

MissCannSphere:=proc(n,P,k) local S,s,kk:
option remember:

if k=0 then
	return {P}:
fi:

S:=MissCannSphere(n,P,k-1):

return {seq(op(MissCann(n,P1)), P1 in S)} minus `union`(seq(MissCannSphere(n,P,kk),kk=0..k-1)):

end:

MissCannSphereWithPaths:=proc(n,P,k) local S, T, j, T1, s:
option remember:

if k=0 then
	return {[P]}:
fi:

S:=MissCannSphereWithPaths(n,P,k-1):
T:={}:
for j in MissCannSphere(n,P,k) do
	T1:={}:
	for P1 in S do
		if j in MissCann(n,P1[nops(P1)]) then
			T1:=T1 union {[op(P1),j]}:
		fi:
	od:
	r:=rand(1..nops(T1))():
	T:=T union {T1[r]}:
od:

return T:

end:

# Then,
# MissCannSphereWithPaths(3,[3,3,0],11);
# gives
#    {[[3, 3, 0], [2, 2, 1], [3, 2, 0], [3, 0, 1], [3, 1, 0], 
#     [1, 1, 1], [2, 2, 0], [0, 2, 1], [0, 3, 0], [0, 1, 1], 
#     [0, 2, 0], [0, 0, 1]]}
# which shows how to get all of the missionaries and cannibals across.

#####################################################################################

# Consider peg-solitaire
# but played on a k by n board,
# where a position is represented as a 0-1 matrix,
# and we use the data structure
# of lists-of lists
# (a list of length k
# where each entry is a list of length n,
# so M[i][j]=1 if and only if
# the spot at the i-th row and j-th column has a peg).
# Write a program
# PegSoliChildren(M)
# that inputs such a position
# and outputs the set of all the positions
# (with the number of 1's reduced by 1)
# that are legally reachable from it.

PegSoliChildren1:=proc(M) local k, n, S, i, j, NewM:
option remember:
k:=nops(M):
n:=nops(M[1]):
S:={}:

for i from 1 to k do
	for j from 1 to n-2 do
		if M[i][j]=1 and M[i][j+1]=1 and M[i][j+2]=0 then
			NewM:=M:
			NewM[i][j]:=0:
			NewM[i][j+1]:=0:
			NewM[i][j+2]:=1:
			S:=S union {NewM}:
		fi:
		if M[i][j]=0 and M[i][j+1]=1 and M[i][j+2]=1 then
			NewM:=M:
			NewM[i][j]:=1:
			NewM[i][j+1]:=0:
			NewM[i][j+2]:=0:
			S:=S union {NewM}:
		fi:
	od:
od:
for j from 1 to n do
	for i from 1 to k-2 do
		if M[i][j]=1 and M[i+1][j]=1 and M[i+2][j]=0 then
			NewM:=M:
			NewM[i][j]:=0:
			NewM[i+1][j]:=0:
			NewM[i+2][j]:=1:
			S:=S union {NewM}:
		fi:
		if M[i][j]=0 and M[i+1][j]=1 and M[i+2][j]=1 then
			NewM:=M:
			NewM[i][j]:=1:
			NewM[i+1][j]:=0:
			NewM[i+2][j]:=0:
			S:=S union {NewM}:
		fi:
	od:
od:

return S:

end:

PegSoliChildren:=proc(M) local M1, P:
option remember:
P:=PegSoliChildren1(M):
if P={} then
	return {}:
fi:

return `union`(seq(PegSoliChildren(M1),M1 in P)) union P

end:

#####################################################################################

# Is the four-by-four Peg Solitaire with a one hole at a corner solvable?

PegCount:=proc(M)

return convert(convert(M,`+`),`+`):

end:

Check4x4:=proc() local M, A, a:
M:=[[1,1,1,1],[1,1,1,1],[1,1,1,1],[1,1,1,0]]:
A:=PegSoliChildren(M):

for a in A do
	if PegCount(a)=1 then
		return true:
	fi:
od:

return false:

end:

# The above program returns false.
# Hence, I conclude that this game is not solvable.

#####################################################################################

# Extend this methodology
# (hopefully not runing out of memory)
# to solve the usual (English) Peg-Solitaire, with the usual board. 

#    English           European
#     a b c             a b c
#     d e f           y d e f z
# g h i j k l m     g h i j k l m
# n o p x P O N     n o p x P O N
# M L K J I H G     M L K J I H G
#     F E D           Z F E D Y
#     C B A             C B A


EngM:=[
[2,2,1,1,1,2,2],
[2,2,1,1,1,2,2],
[1,1,1,1,1,1,1],
[1,1,1,1,1,1,1],
[1,1,1,1,1,1,1],
[2,2,1,1,1,2,2],
[2,2,1,1,1,2,2]
];

PegSoliChildren1:=proc(M) local k, n, S, i, j, NewM:
option remember:
k:=nops(M):
n:=nops(M[1]):
S:={}:

for i from 1 to k do
	for j from 1 to n-2 do
		if M[i][j]=1 and M[i][j+1]=1 and M[i][j+2]=0 then
			NewM:=M:
			NewM[i][j]:=0:
			NewM[i][j+1]:=0:
			NewM[i][j+2]:=1:
			S:=S union {NewM}:
		fi:
		if M[i][j]=0 and M[i][j+1]=1 and M[i][j+2]=1 then
			NewM:=M:
			NewM[i][j]:=1:
			NewM[i][j+1]:=0:
			NewM[i][j+2]:=0:
			S:=S union {NewM}:
		fi:
	od:
od:
for j from 1 to n do
	for i from 1 to k-2 do
		if M[i][j]=1 and M[i+1][j]=1 and M[i+2][j]=0 then
			NewM:=M:
			NewM[i][j]:=0:
			NewM[i+1][j]:=0:
			NewM[i+2][j]:=1:
			S:=S union {NewM}:
		fi:
		if M[i][j]=0 and M[i+1][j]=1 and M[i+2][j]=1 then
			NewM:=M:
			NewM[i][j]:=1:
			NewM[i+1][j]:=0:
			NewM[i+2][j]:=0:
			S:=S union {NewM}:
		fi:
	od:
od:

return S:

end:

PegSoliChildren:=proc(M) local M1, P:
option remember:
P:=PegSoliChildren1(M):
if P={} then
	return {}:
fi:

return `union`(seq(PegSoliChildren(M1),M1 in P)) union P

end: