Menu Close

Problema del dominó

José A. Alonso,

Las fichas del dominó se pueden representar por pares de números enteros. El problema del dominó consiste en colocar todas las fichas de una lista dada de forma que el segundo número de cada ficha coincida con el primero de la siguiente.

Definir la función

   domino :: [(Int,Int)] -> [[(Int,Int)]]

tal que (domino fs) es la lista de las soluciones del problema del dominó correspondiente a las fichas fs. Por ejemplo,

   λ> domino [(1,2),(2,3),(1,4)]
   [[(4,1),(1,2),(2,3)],[(3,2),(2,1),(1,4)]]
   λ> domino [(1,2),(1,1),(1,4)]
   [[(4,1),(1,1),(1,2)],[(2,1),(1,1),(1,4)]]
   λ> domino [(1,2),(3,4),(2,3)]
   [[(1,2),(2,3),(3,4)]]
   λ> domino [(1,2),(2,3),(5,4)]
   []
   λ> domino [(x,y) | x <- [1..2], y <- [x..2]]
   [[(2,2),(2,1),(1,1)],[(1,1),(1,2),(2,2)]]
   λ> [(x,y) | x <- [1..3], y <- [x..3]]
   [(1,1),(1,2),(1,3),(2,2),(2,3),(3,3)]
   λ> mapM_ print (domino [(x,y) | x <- [1..3], y <- [x..3]])
   [(1,3),(3,3),(3,2),(2,2),(2,1),(1,1)]
   [(1,2),(2,2),(2,3),(3,3),(3,1),(1,1)]
   [(2,2),(2,3),(3,3),(3,1),(1,1),(1,2)]
   [(3,3),(3,2),(2,2),(2,1),(1,1),(1,3)]
   [(2,3),(3,3),(3,1),(1,1),(1,2),(2,2)]
   [(2,1),(1,1),(1,3),(3,3),(3,2),(2,2)]
   [(3,3),(3,1),(1,1),(1,2),(2,2),(2,3)]
   [(3,2),(2,2),(2,1),(1,1),(1,3),(3,3)]
   [(3,1),(1,1),(1,2),(2,2),(2,3),(3,3)]
   λ> length (domino [(x,y) | x <- [1..3], y <- [x..3]])
   9
   λ> length (domino [(x,y) | x <- [1..4], y <- [x..4]])
   0
   λ> length (domino [(x,y) | x <- [1..5], y <- [x..5]])
   84480

Soluciones

import I1M.BusquedaEnEspaciosDeEstados (buscaEE)
import Data.List (delete)
 
-- 1ª solución (por búsqueda en anchura)
-- =====================================
 
-- Las fichas son pares de números enteros.
type Ficha  = (Int,Int)
 
-- Un problema está definido por la lista de fichas que hay que colocar
type Problema = [Ficha]
 
-- Los estados son los pares formados por la listas sin colocar y las
-- colocadas. 
type Estado = ([Ficha],[Ficha])
 
-- (inicial p) es el estado inicial del problema p.
inicial :: Problema -> Estado
inicial p = (p,[])
 
-- (es final e) se verifica si e es un estado final.
esFinal :: Estado -> Bool
esFinal (fs,_) = null fs 
 
sucesores :: Estado -> [Estado]
sucesores (fs,[]) =
  [(delete f fs, [f]) | f <- fs]
sucesores (fs,n@((x,y):qs)) =
  [(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u /= v, v == x] ++
  [(delete (u,v) fs,(v,u):n) | (u,v) <- fs, u /= v, u == x] ++
  [(delete (u,v) fs,(u,v):n) | (u,v) <- fs, u == v, u == x] 
 
soluciones :: Problema -> [Estado]
soluciones p = busca [(inicial p)]
  where
    busca []        = []
    busca (e:es)  
      | esFinal e = e : busca es
      | otherwise = busca (es ++ sucesores e)
 
domino :: Problema -> [[Ficha]]
domino ps = map snd (soluciones ps)
 
-- 2ª solución (por búsqueda en profundidad)
-- =========================================
 
soluciones2 :: Problema -> [Estado]
soluciones2 p = busca [(inicial p)]
  where
    busca []        = []
    busca (e:es)  
      | esFinal e = e : busca es
      | otherwise = busca (sucesores e ++ es)
 
domino2 :: Problema -> [[Ficha]]
domino2 ps = map snd (soluciones2 ps)
 
-- 3ª solución (con I1M.BusquedaEnEspaciosDeEstados)
-- =================================================
 
domino3 :: Problema -> [[Ficha]]
domino3 ps = map snd (soluciones3 ps)
 
soluciones3 :: Problema -> [Estado]
soluciones3 ps = buscaEE sucesores
                         esFinal         
                         (inicial ps)
Posted in Medio
Tagged , , , , , ,

1 Comment

  1. agumaragu1
    Responder 
     
import I1M.BusquedaEnEspaciosDeEstados
import Data.List ((\), nub)
 
domino :: [(Int,Int)] -> [[(Int,Int)]]
domino fs = map reverse $ map fst $ buscaEE sucesoresR terminado (inicial fs)
 
type Ficha = (Int,Int)
type Recorrido = ([Ficha],[Ficha])
 
sucesoresR :: Recorrido -> [Recorrido]
sucesoresR ((e:es),fs) = [((e':e:es),fs') | (e',fs') <- sucesoresF e fs]
sucesoresR ([],fs) = nub [([f],fs') | f <- fss, let fs' = fs \ [f, o f]]
  where fss = fs ++ map o fs
        o (x,y) = (y,x)
 
sucesoresF :: Ficha -> [Ficha] -> [(Ficha, [Ficha])]
sucesoresF f fs = nub [(f',fs') | f' <- fss, sigue f f', let fs' = fs \ [f', o f']]
  where sigue (a,b) (c,d) = b == c
        fss = fs ++ map o fs
        o (x,y) = (y,x)
 
terminado :: Recorrido -> Bool
terminado (_,fs) = null fs
 
inicial :: [Ficha] -> Recorrido
inicial fs = ([],fs)

Escribe tu solución

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.