Visualizzazione dei risultati da 1 a 2 su 2
  1. #1
    Utente di HTML.it
    Registrato dal
    May 2008
    Messaggi
    475

    [Haskell] Breadth First Search non trova la soluzione

    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
    "Let him who has understanding reckon the number of the beast, for it is a human number.
    Its number is rw-rw-rw-."

  2. #2
    Utente di HTML.it
    Registrato dal
    May 2008
    Messaggi
    475
    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 ._.

    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)
    
    -- 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"
    "Let him who has understanding reckon the number of the beast, for it is a human number.
    Its number is rw-rw-rw-."

Permessi di invio

  • Non puoi inserire discussioni
  • Non puoi inserire repliche
  • Non puoi inserire allegati
  • Non puoi modificare i tuoi messaggi
  •  
Powered by vBulletin® Version 4.2.1
Copyright © 2020 vBulletin Solutions, Inc. All rights reserved.