Ciao a tutti.

Un po' di tempo fa sul forum chiedevo una mano per scrivere l'algoritmo BFS in Haskell. Alla fine, ci sono riuscito, e infatti funzionava.

Per la precisione, l'avevo testato su un problema dei secchi d'acqua, in cui bisognava travasare acqua da due secchi secondo certe regole. E funzionava: trovava sempre la soluzione, se esisteva. Gli ho persino chiesto di calcolare tutti i possibili stati finali del problema secondo le regole, e le trovava tutte.

Al che ho deciso di passare ad un problema più complesso, ovvero questo.

Dopo parecchio pensare (e smadonnare dietro alle parentesi e a quanto è pedante Haskell sui tipi), sono riuscito a definire tutte le regole per la soluzione del problema, e ho lanciato la BFS.

E non funziona. Ritorna sempre Nothing, ovvero mi dice che non c'è soluzione al problema con le regole specificate.

Ma ho dimostrato che non è vero: ho applicato le regole che portano alla soluzione, una per volta, a mano. E si riesce ad arrivare alla soluzione voluta: quindi le regole sono giuste (o almeno, ammettono almeno una sequenza che porta alla soluzione. Quindi con la BFS dovrei trovarla, giusto? Eppure non funziona, non riesco a capire dove sia l'errore.

Non è che a qualcuno viene qualche idea?

Posto il codice:

codice:
import Data.Maybe

-- State definition:
-- StateInternal left right side where
-- left and right are (missionary, cannibals)

data Side = L | R	-- Side where the boat is
	deriving (Eq, Show)

-- Abstract internal representation of the state data
data StateInternal = StateInternal (Int, Int) (Int, Int) Side
	deriving (Eq, Show)

-- Abstract internal representation of the route data	
type RouteInternal = String

-- Abstract Stat type
data State = State StateInternal [RouteInternal]
	deriving Show

{- 	Two States are equivalent where they have the same
	StateInternal data, regardless of the route that led there.
-}
instance Eq State where
	State s1 r1 == State s2 r2 = s1 == s2

-- Initial state and final state
s0 :: StateInternal
sln :: StateInternal
s0 = StateInternal (3,3) (0,0) L
sln = StateInternal (0,0) (3,3) R

-- Applies a rule to a state
applyTo :: State -> ( State -> Maybe State ) -> Maybe State
applyTo state rule = rule state

-- BFS Search
search :: StateInternal -> [(State -> Maybe State)] -> StateInternal -> Maybe State
search s0 rules sln = bfs [(State s0 [])] [] rules (State sln [])

bfs :: [State] -> [State] -> [(State -> Maybe State)] -> State -> Maybe State
bfs [] _ _ _ = Nothing
bfs (sc:ss) visited rules sln
	| sc == sln = Just sc
	| otherwise = bfs searchSpace visitedSpace rules sln where
		visitedSpace = sc : (listrm1 visited sc)
		searchSpace = listrm (ss ++ newStates) visitedSpace where
			newStates = catMaybes (map (applyTo sc) rules)

-- listrm
listrm :: (Eq a) => [a] -> [a] -> [a]
listrm [] _ = []
listrm ls [] = ls
listrm ls (y:ys) = listrm1 (listrm ls ys) y

listrm1 :: (Eq a) => [a] -> a -> [a]
listrm1 [] _ = []
listrm1 (x:xs) y
	| x == y = g
	| otherwise = x : g where
		g = listrm1 xs y


----- Rules -----

rules :: [(State -> Maybe State)]
rules = [rule1, rule2, rule3]

-- Checks if a state is acceptable
accept :: StateInternal -> Bool
accept (StateInternal (lm, lc) (rm, rc) side) = 
	(acceptShore (lm, lc)) && (acceptShore (rm, rc))

-- Checks if a shore is acceptable
acceptShore :: (Int, Int) -> Bool
acceptShore (m, c)
	| (m < 0 || c < 0) = False
	| m == 0 = True
	| otherwise = (m >= c)

-- Move 1 missionary
rule0 :: State -> Maybe State
rule0 (State s@(StateInternal (lm, lc) (rm, rc) side) route) =
	if side == L then
		let proposedState = StateInternal (lm - 1, lc) (rm + 1, rc) R in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["1M L->R"]))
			else
				Nothing
	else --side == R
		let proposedState = (StateInternal (lm + 1, lc) (rm - 1, rc ) L) in
			if (accept proposedState) then
				Just (State proposedState(route ++ ["1M R->L"]))
			else
				Nothing

-- Move 1 cannibal
rule1 :: State -> Maybe State
rule1 (State s@(StateInternal (lm, lc) (rm, rc) side) route) =
	if side == L then
		let proposedState = StateInternal (lm, lc - 1) (rm, rc + 1) R in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["1C L->R"]))
			else
				Nothing
	else --side == R
		let proposedState = StateInternal (lm, lc + 1) (rm, rc - 1) L in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["1C R->L"]))
			else
				Nothing

-- Move 1 missionary and 1 cannibal
rule2 :: State -> Maybe State
rule2 (State s@(StateInternal (lm, lc) (rm, rc) side) route) =
	if side == L then
		let proposedState = StateInternal (lm - 1, lc - 1) (rm + 1, rc + 1) R in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["1M 1C L->R"]))
			else
				Nothing
	else --side == R
		let proposedState = StateInternal (lm + 1, lc + 1) (rm - 1, rc - 1) L in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["1M 1C R->L"]))
			else
				Nothing

-- Move 2 missionaries
rule3 :: State -> Maybe State
rule3 (State s@(StateInternal (lm, lc) (rm, rc) side) route) =
	if side == L then
		let proposedState = StateInternal (lm - 2, lc) (rm + 2, rc) R in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["2M L->R"]))
			else
				Nothing
	else --side == R
		let proposedState = StateInternal (lm + 2, lc) (rm - 2, rc) L in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["2M R->L"]))
			else
				Nothing

-- Move 2 cannibals			
rule4 :: State -> Maybe State
rule4 (State s@(StateInternal (lm, lc) (rm, rc) side) route) =
	if side == L then
		let proposedState = StateInternal (lm, lc - 2) (rm, rc + 2) R in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["2C L->R"]))
			else
				Nothing
	else --side == R
		let proposedState = StateInternal (lm, lc + 2) (rm, rc - 2) L in
			if (accept proposedState) then
				Just (State proposedState (route ++ ["2C R->L"]))
			else
				Nothing