PDA

Visualizza la versione completa : [Haskell] Breadth First Search non trova la soluzione


Ippo343
07-09-2010, 03:23
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 (http://www.nienteperniente.it/lm2_02_agosto/missionari_cannibali.html).

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:



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

Ippo343
07-09-2010, 12:03
Ok, le regole erano scritte malissimo, erano millemila righe di codice tutte uguali (dai, non fatemene una colpa, guardate l'ora a cui ho postato).

Ho pulito un po' il codice, ma il problema rimasto ._.



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)

-- Common rule structure
boilerplate :: State -> StateInternal -> String -> Maybe State
boilerplate (State oldstate route) proposedState rulename =
if (accept proposedState) then
Just (State proposedState (route ++ [rulename]))
else Nothing


-- Move 1 missionary
rule0 :: State -> Maybe State
rule0 state@(State s@(StateInternal (lm, lc) (rm, rc) side) route) =
boilerplate state proposedState rulename where
proposedState = if (side == L) then StateInternal (lm - 1, lc) (rm + 1, rc) R
else StateInternal (lm + 1, lc) (rm - 1, rc ) L
rulename = if (side == L) then "1M L->R"
else "1M R->L"

-- Move 1 cannibal
rule1 :: State -> Maybe State
rule1 state@(State s@(StateInternal (lm, lc) (rm, rc) side) route) =
boilerplate state proposedState rulename where
proposedState = if (side == L) then StateInternal (lm, lc - 1) (rm, rc + 1) R
else StateInternal (lm, lc + 1) (rm, rc - 1) L
rulename = if (side == L) then "1C L->R"
else "1C R->L"

-- Move 1 missionary and 1 cannibal
rule2 :: State -> Maybe State
rule2 state@(State s@(StateInternal (lm, lc) (rm, rc) side) route) =
boilerplate state proposedState rulename where
proposedState = if (side == L) then StateInternal (lm - 1, lc - 1) (rm + 1, rc + 1) R
else StateInternal (lm + 1, lc + 1) (rm - 1, rc - 1) L
rulename = if (side == L) then "1M 1C L->R"
else "1M 1C R->L"

-- Move 2 missionaries
rule3 :: State -> Maybe State
rule3 state@(State s@(StateInternal (lm, lc) (rm, rc) side) route) =
boilerplate state proposedState rulename where
proposedState = if (side == L) then StateInternal (lm - 2, lc) (rm + 2, rc) R
else StateInternal (lm + 2, lc) (rm - 2, rc) L
rulename = if (side == L) then "2M L->R"
else "2M R->L"

-- Move 2 cannibals
rule4 :: State -> Maybe State
rule4 state@(State s@(StateInternal (lm, lc) (rm, rc) side) route) =
boilerplate state proposedState rulename where
proposedState = if (side == L) then StateInternal (lm, lc - 2) (rm, rc + 2) R
else StateInternal (lm, lc + 2) (rm, rc - 2) L
rulename = if (side == L) then "2C L->R"
else "2C R->L"

Loading