Assuming the following definitions:
type Index = Int
data BExp = Prim Bool | IdRef Index | Not BExp | And BExp BExp | Or BExp BExp
deriving (Eq, Ord, Show)
type NodeId = Int
type BDDNode = (NodeId, (Index, NodeId, NodeId))
type BDD = (NodeId, [BDDNode])
I want to build a ROBDD from a boolean expression. So far, I've been able to construct a BDD that doesn't satisfy the no-redundancy or sharing properties.
buildBDD :: BExp -> [Index] -> BDD
buildBDD e idxs
= buildBDD' e 2 idxs
buildBDD' :: BExp -> NodeId -> [Index] -> BDD
buildBDD' (Prim bool) _ []
| bool = (1, [])
| otherwise = (0, [])
buildBDD' e nodeId (idx : idxs)
= (nodeId, [newNode] ++ tl ++ tr)
where
newNode = (nodeId, (idx, il, ir))
(il, tl) = buildBDD' (restrict e idx False) (2 * nodeId) idxs
(ir, tr) = buildBDD' (restrict e idx True) (2 * nodeId + 1) idxs
The naming and style may not be the best, as this is still work in progress.
The nodes are internally represented by a unique id. It starts from 2. The root node of the left subtree will be labelled 2n and the root node of the right subtree will be labelled 2n + 1.
The function will take as input the boolean expression and a list of indices for the variables that appear in the expression.
For example, for the following expression:
And (IdRef 7) (Or (IdRef 2) (Not (IdRef 3)))
The call buildBDD bexp [2,3,7] will return
(2,[(2,(2,4,5)),(4,(3,8,9)),(8,(7,0,1)),(9,(7,0,0)),(5,(3,10,11)),(10,(7,0,1)),
(11,(7,0,1))])
I've made the following changes to account for the no-redundancy property (this has not been tested thoroughly, but appears to be working)
checkEqual (_, l, r)
| l == r = True
| otherwise = False
getElemFromTuple (_, _, e)
= e
getTuple = snd . head
buildROBDD' e nodeId (idx : idxs)
= (nodeId, [newNode] ++ left ++ right)
where
newNode = (nodeId, (idx, lId, rId))
(il, tl) = buildROBDD' (restrict e idx False) (2 * nodeId) idxs
(ir, tr) = buildROBDD' (restrict e idx True) (2 * nodeId + 1) idxs
lId = if (not . null) tl && (checkEqual . getTuple) tl then (getElemFromTuple . getTuple) tl else il
rId = if (not . null) tr && (checkEqual . getTuple) tr then (getElemFromTuple . getTuple) tr else ir
left = if (not . null) tl && (checkEqual . getTuple) tl then [] else tl
right = if (not . null) tr && (checkEqual . getTuple) tr then [] else tr
(excuse the clumsy expressions above)
However, I don't know how to approach the sharing property, especially because the shared node might be anywhere in the graph and I am not storing the current tree. The formula for the unique node ids can be changed if needed.
Note: this is meant as an exercise, so the types and style involved might not be optimal. I am also not supposed to change them (I am free to change the function though).
Related
I am getting an error where I am trying to use map in a depth first search algorithm to test paths to contain the goal cell in a maze that is undirected, and without cycles. where I am running into trouble is with the recursive call with map.
Here is my code:
type Maze = [[Cell]]
data Cell = Cell { top, left, right, bottom :: Bool }
type Pos = (Int, Int)
type Path = [Pos]
findPath :: Maze -> Path
findPath [] = []
findPath maze = dfs maze [] (-1,-1) (1,1)
dfs :: Maze ->Path -> Pos -> Pos -> Path
dfs maze trail prev curr
| (curr == goal) = reverse $ goal : trail -- ?
| (null adj) = []
| otherwise = dfs maze (curr : trail) curr `map` (adj c (fst curr) (snd curr) prev)
where c = maze!!(fst curr- 1)!!(snd curr - 1)
goal = (length maze, length (maze!!0))
adj:: Cell -> Int -> Int -> Pos ->Path
adj c x y prev = if (top c && prev /= (x-1, y)) then [(x-1, y)] else [] ++
if (left c && prev /= (x, y-1)) then [(x, y-1)] else [] ++
if (right c && prev /= (x, y+1)) then [(x, y+1)] else [] ++
if (bottom c && prev /= (x+1, y)) then [(x+1, y)] else []
what I expect with dfs maze (curr : trail) curr 'map' (adj c (fst curr) (snd curr) prev) is that I apply a function f::Pos->trail to each element in [Pos] but what the (curr : trail) gives is a [Path] rather than a Path
The error stack gives me is as follows:
stack: WARNING! Expecting stack options comment at line 1, column 1
stack: WARNING! Missing or unusable stack options specification
stack: WARNING! Using runghc without any additional stack options
SolveMaze.hs:77:24: error:
* Couldn't match type `[Pos]' with `(Int, Int)'
Expected type: Path
Actual type: [Path]
* In the expression:
dfs maze (curr : trail) curr
`map` (adj c (fst curr) (snd curr) prev)
In an equation for `dfs':
dfs maze trail prev curr
| (curr == goal) = reverse $ goal : trail
| (null adj) = []
| otherwise
= dfs maze (curr : trail) curr
`map` (adj c (fst curr) (snd curr) prev)
where
c = maze !! (fst curr - 1) !! (snd curr - 1)
goal = (length maze, length (maze !! 0))
|
77 | | otherwise = dfs maze (curr : trail) curr `map` (adj c (fst curr)
(snd curr) prev)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
^^^^^^^^^^^^^^^^^
I am sorry if this is a really basic problem for you Haskell wizards but I've been staring at this for so long that I can't take it and needed to reach out for help. Thank you.
Lets zoom in on two lines. First is the type of dfs:
dfs :: Maze ->Path -> Pos -> Pos -> Path
So dfs when fully applied returns a Path, great.
We also have the definition of dfs, which must return a Path, is:
dfs maze (curr : trail) curr `map` (adj c (fst curr) (snd curr) prev)
Or with some simplifications to make explicit what is going on:
map (dfs and some args) (some list)
So dfs must return a path, so says the type, but the definition shows it as returning a list of paths.
What you seem to want is try to descend into one of the adjacent positions and perform a depth first search then descend into the next possible path, taking advantage of lazy evaluation along the way - great!
Lets change dfs to returning a list of Paths ([Path]) - that will be a list of solutions or non-solutions ([]) if a dead end is found. Change reverse ... to [reverse ...]. and map to concatMap.
It doesn't make sense to ask if a function is null, I think you ment the application of adj such as null (adj c (fst curr) ....
Find path now has to select one of the list of solutions now returned by dfs - the first one should suffice. You can use listToMaybe to get a Maybe Path result.
.
import Data.Maybe (listToMaybe)
type Maze = [[Cell]]
data Cell = Cell { top, left, right, bottom :: Bool }
type Pos = (Int, Int)
type Path = [Pos]
findPath :: Maze -> Maybe Path
findPath [] = Just []
findPath maze = listToMaybe $ dfs maze [] (-1,-1) (1,1)
dfs :: Maze ->Path -> Pos -> Pos -> [Path]
dfs maze trail prev curr
| (curr == goal) = [reverse $ goal : trail] -- ?
| (null adjVal) = []
| otherwise = dfs maze (curr : trail) curr `concatMap` adjVal
where c = maze!!(fst curr- 1)!!(snd curr - 1)
goal = (length maze, length (maze!!0))
adjVal = adj c (fst curr) (snd curr) prev
adj:: Cell -> Int -> Int -> Pos ->Path
adj c x y prev = if (top c && prev /= (x-1, y)) then [(x-1, y)] else [] ++
if (left c && prev /= (x, y-1)) then [(x, y-1)] else [] ++
if (right c && prev /= (x, y+1)) then [(x, y+1)] else [] ++
if (bottom c && prev /= (x+1, y)) then [(x+1, y)] else []
There are lots of other things you can clean up if you so desire.
[] to signify a failed path instead of Maybe Path. If the first depth-first search fails then your returned "solution" will be [].
Use of !! and assumption the input is not jagged. You could use an array.
Verbose definition of adj that could use guards instead.
I'm solving the Brigde and torch problem
in Haskell.
I wrote a function that given a state of the puzzle, as in which people have yet to cross and those who have crossed, gives back a list of all possible moves from one side to the other (moving two people forwards and one person backwards).
module DarkBridgeDT where
data Crossing = Trip [Float] [Float] Float deriving (Show)
data RoundTrip = BigTrip Crossing Crossing deriving (Show)
trip :: [Float] -> [Float] -> Float -> Crossing
trip x y z = Trip x y z
roundtrip :: Crossing -> Crossing -> RoundTrip
roundtrip x y = BigTrip x y
next :: Crossing -> [RoundTrip]
next (Trip [] _ _) = []
next (Trip (a:b:[]) s _ )
|a>b = [BigTrip (Trip [] (a:b:s) a) (Trip [] [] 0)]
|otherwise = [BigTrip (Trip [] (b:a:s) b) (Trip [] [] 0)]
next (Trip d s _) = [BigTrip (Trip [x,z] (i:j:s) j) b | i <- d, j <- d, i < j, x <- d, z <- d, x < z, z /= i, z /= j, x /= z, x /= i, x /= j, b <- (back [x,z] (i:j:s))]
where
back [] s = []
back d s = [Trip (i:d) (filter (/= i) s) i | i <- s]
Now I need a function that given a state as the one above and a maximum amount of time gives back all possible solutions to the puzzle in less than that given time.
All I have for that is this:
cross :: Crossing -> Float -> [[RoundTrip]]
cross (Trip [] _ _) _ = []
cross (Trip _ _ acu) max
| acu > max = []
cross (Trip a b acu) max = map (cross (map (crec) (next (Trip a b acu)) acu)) max
where
crec (BigTrip (Trip _ _ t1) (Trip a b t2)) acu = (Trip a b (t1+t2+acu))
Of course that doesn't compile, the 5th line is the one that's driving me insane. Any input?
Edit:
The cross function is meant to apply the next function to every result of the last nextfunction called.
If the first result of next was something like: [A,B,C,D] then it would call next on A B C and D to see if any or all of those get to a solution in less than max (A B C and D would be Crossings inside which contain the floats that are the time that ads up and is compared to max).
My data structure is
Crossing: Contains the first side of the bridge (the people in it represented by the time they take to cross the bridge) the other side of the bridge (the same as the other) and a time that represents the greatest time that last crossed the bridge (either the greatest of the two in the first crossing or the only one in the second) or the amount of time acumulated crossing the bridge (in the cross function).
RoundTrip: Represents two crossings, the first and the second, the one getting to safety and the one coming back to danger.
cross (Trip [1,2,5,10] [] 0) 16 should give an empty list for there is no solution that takes less than 17 minutes (or whatever time unit).
cross (Trip [1,2,5,10] [] 0) 17 should give the normal solution to the puzzle as a list of roundtrips.
I hope that makes it clearer.
Edit2:
I finally got it. I read Carsten's solution before I completed mine and we laid it out practically the same. He used fancier syntax and more complex structures but it's really similar:
module DarkBridgeST where
data Torch = Danger | Safety deriving (Eq,Show)
data State = State
[Float] -- people in danger
[Float] -- people safe
Torch -- torch position
Float -- remaining time
deriving (Show)
type Crossing = [Float]
classic :: State
classic = State [1,2,5,10] [] Danger 17
next :: State -> [Crossing] -- List all possible moves
next (State [] _ _ _) = [] -- Finished
next (State _ [] Safety _) = [] -- No one can come back
next (State danger _ Danger rem) = [[a,b] | a <- danger, b <- danger, a /= b, a < b, max a b <= rem]
next (State _ safe Safety rem) = [[a] | a <- safe, a <= rem]
cross :: State -> Crossing -> State -- Crosses the bridge depending on where the torch is
cross (State danger safe Danger rem) cross = State (taking cross danger) (safe ++ cross) Safety (rem - (maximum cross))
cross (State danger safe Safety rem) cross = State (danger ++ cross) (taking cross safe) Danger (rem - (maximum cross))
taking :: [Float] -> [Float] -> [Float]
taking [] d = d
taking (x:xs) d = taking xs (filter (/=x) d)
solve :: State -> [[Crossing]]
solve (State [] _ _ _) = [[]]
solve sf = do
c <- next sf
let sn = cross sf c
r <- solve sn
return (c:r)
All in all thanks everyone. I'm new to Haskell programming and this helped me understand a lot of things. I hope this post can also help someone starting haskell like me one day :)
I'm not going to leave much of your code intact here.
The first problems are with the data structures. Crossing doesn't actually represent anything to do with crossing the bridge, but the state before or after a bridge crossing. And you can't use RoundTrip because the number of bridge crossings is always odd.
I'm renaming the data structure I'm actually keeping, but I'm not keeping it unmodified.
data Bank = Danger | Safety deriving (Eq,Show)
data PuzzleState = PuzzleState
[Float] -- people still in danger
[Float] -- people on the safe bank
Bank -- current location of the torch
Float -- remaining time
type Crossing = ([Float],Bank)
Modifying/writing these functions is left as an exercise for the reader
next :: PuzzleState -> [Crossing] -- Create a list of possible crossings
applyCrossing :: PuzzleState -> Crossing -> PuzzleState -- Create the next state
Then something like this function can put it all together (assuming next returns an empty list if the remaining time is too low):
cross (PuzzleState [] _ _ _) = [[]]
cross s1 = do
c <- next s1
let s2 = applyCrossing s1 c
r <- cross s2
return $ c : r
Just for the fun, an approach using a lazy tree:
import Data.List
import Data.Tree
type Pawn = (Char, Int)
data Direction = F | B
data Turn = Turn {
_start :: [Pawn],
_end :: [Pawn],
_dir :: Direction,
_total :: Int
}
type Solution = ([String], Int)
-- generate a tree
mkTree :: [Pawn] -> Tree Turn
mkTree p = Node{ rootLabel = s, subForest = branches s }
where s = Turn p [] F 0
-- generates a node for a Turn
mkNode :: Turn -> Tree Turn
mkNode t = Node{ rootLabel = t, subForest = branches t }
-- next possible moves
branches :: Turn -> [Tree Turn]
-- complete
branches (Turn [] e d t) = []
-- moving forward
branches (Turn s e F t) = map (mkNode.turn) (next s)
where
turn n = Turn (s\\n) (e++n) B (t+time n)
time = maximum . map snd
next xs = [x| x <- mapM (const xs) [1..2], head x < head (tail x)]
-- moving backward
branches (Turn s e B t) = map (mkNode.turn) e
where
turn n = Turn (n:s) (delete n e) F (t+time n)
time (_,b) = b
solve :: Int -> Tree Turn -> [Solution]
solve limit tree = solve' [] [] limit tree
where
solve' :: [Solution] -> [String] -> Int -> Tree Turn -> [Solution]
solve' sols cur limit (Node (Turn s e d t) f)
| and [t <= limit, s == []] = sols ++ [(cur++[step],t)]
| t <= limit = concat $ map (solve' sols (cur++[step]) limit) f
| otherwise = []
where step = "[" ++ (v s) ++ "|" ++ (v e) ++ "]"
v = map fst
Then you you can get a list of solutions:
solve 16 $ mkTree [('a',2), ('b',4), ('c',8)]
=> [(["[abc|]","[c|ab]","[ac|b]","[|bac]"],14),(["[abc|]","[c|ab]","[bc|a]","[|abc]"],16),(["[abc|]","[b|ac]","[ab|c]","[|cab]"],14),(["[abc|]","[a|bc]","[ba|c]","[|cab]"],16)]
Or also generate a tree of solutions:
draw :: Int -> Tree Turn -> Tree String
draw limit (Node (Turn s e d t) f)
| t > limit = Node "Time Out" []
| s == [] = Node ("Complete: " ++ step) []
| otherwise = Node step (map (draw limit) f)
where step = "[" ++ (v s) ++ "|" ++ (v e) ++ "]" ++ " - " ++ (show t)
v = map fst
Then:
putStrLn $ drawTree $ draw 16 $ mkTree [('a',2), ('b',4), ('c',8)]
Will result in:
[abc|] - 0
|
+- [c|ab] - 4
| |
| +- [ac|b] - 6
| | |
| | `- Complete: [|bac] - 14
| |
| `- [bc|a] - 8
| |
| `- Complete: [|abc] - 16
|
+- [b|ac] - 8
| |
| +- [ab|c] - 10
| | |
| | `- Complete: [|cab] - 14
| |
| `- [cb|a] - 16
| |
| `- Time Out
|
`- [a|bc] - 8
|
+- [ba|c] - 12
| |
| `- Complete: [|cab] - 16
|
`- [ca|b] - 16
|
`- Time Out
I have a problem making Backtracking on Haskell, I know how to do recursive functions but I get troubles when I try to get multiple solutions or the best one (backtracking).
There's a list with some strings, then I need to get the solutions to get from a string to another one changing one letter from the string, I will get the list, the first string and the last one. If there is solution return the count of steps that it did, if there is not solution it returns -1. here's an example:
wordF ["spice","stick","smice","stock","slice","slick","stock"] "spice" "stock"
Then I have my list and I need to start with "spice" and get to "stock"
and the best solution is ["spice","slice","slick","stick","stock"] with four steps to get from "spice" to "stock". then it return 4.
Another solution is ["spice","smice","slice","slick","stick","stock"] with five steps to get to "stock" then it return `5. But this is a wrong solution because there's another one that's better with lesser steps than this one.
I'm having troubles making a backtracking to get the best solution, because I don't know how to make that my code search another solutions and just not one..
Here's a code that i tried to make but i get some errors, btw i dont know if my way to "make" backtracking is good or if there are some mistakes that im not seeing..
wordF :: [String] -> String -> String -> (String, String, Int)
wordF [] a b = (a, b, -1)
wordF list a b | (notElem a list || notElem b list) = (a, b, -1)
| otherwise = (a, b, (wordF2 list a b [a] 0 (length list)))
wordF2 :: [String] -> String -> String -> [String] -> Int -> Int -> Int
wordF2 list a b list_aux cont maxi | (cont==maxi) = 1000
| (a==b) = length list_aux
| (a/=b) && (cont<maxi) && notElemFound && (checkin /= "ThisWRONG") && (wording1<=wording2) = wording1
| (a/=b) && (cont<maxi) && notElemFound && (checkin /= "ThisWRONG") && (wording1>wording2) = wording2
| (a/=b) && (checkin == "ThisWRONG") = wordF2 list a b list_aux (cont+1) maxi
where
checkin = (check_word2 a (list!!cont) (list!!cont) 0)
wording1 = (wordF2 list checkin b (list_aux++[checkin]) 0 maxi)
wording2 = (wordF2 list checkin b (list_aux++[checkin]) 1 maxi)
notElemFound = ((any (==(list!!cont)) list_aux) == False)
check_word2 :: String -> String -> String -> Int -> String
check_word2 word1 word2 word3 dif | (dif > 1) = "ThisWRONG"
| ((length word1 == 1) && (length word2 == 1) && (head word1 == head word2)) = word3
| ((length word1 == 1) && (length word2 == 1) && (head word1 /= head word2) && (dif<1)) = word3
| ((head word1) == (head word2)) = check_word2 (tail word1) (tail word2) word3 dif
| otherwise = check_word2 (tail word1) (tail word2) word3 (dif+1)
My first function wordF2 get the list, the start, the end, an auxiliary list to get the current solution with the first element that always will be there ([a]), a counter with 0, and the max size of the counter (length list)..
and the second function check_word2 it checks if a word can pass to another word, like "spice" to "slice" if it cant like "spice" to "spoca" it returns "ThisWRONG".
This solution gets an error of pattern match failure
Program error: pattern match failure: wordF2 ["slice","slick"] "slice" "slick" ["slice"] 0 1
I was trying with little cases and nothing, and I'm restricting that i get a wrong position of the list with the count and the max.
Or may be I dont know how to implement backtracking on haskell to get multiple solutions, the best solution, etc..
UPDATE: I did a solution but its not backtracking
wordF :: [String] -> String -> String -> (String, String, Int)
wordF [] a b = (a, b, -1)
wordF list a b | (notElem a list || notElem b list) = (a, b, -1)
| otherwise = (a, b, (wordF1 list a b))
wordF1 :: [String] -> String -> String -> Int
wordF1 list a b | ((map length (wordF2 (subconjuntos2 (subconjuntos list) a b))) == []) = -1
| (calculo > 0) = calculo
| otherwise = -1
where
calculo = (minimum (map length (wordF2 (subconjuntos2 (subconjuntos list) a b))))-1
wordF2 :: [[String]] -> [[String]]
wordF2 [[]] = []
wordF2 (x:xs) | ((length xs == 1) && ((check_word x) == True) && ((check_word (head xs)) == True)) = x:xs
| ((length xs == 1) && ((check_word x) == False) && ((check_word (head xs)) == True)) = xs
| ((length xs == 1) && ((check_word x) == True) && ((check_word (head xs)) == False)) = [x]
| ((length xs == 1) && ((check_word x) == False) && ((check_word (head xs)) == False)) = []
| ((check_word x) == True) = x:wordF2 xs
| ((check_word x) == False ) = wordF2 xs
check_word :: [String] -> Bool
check_word [] = False
check_word (x:xs) | ((length xs == 1) && ((check_word2 x (head xs) 0) == True)) = True
| ((length xs >1) && ((check_word2 x (head xs) 0) == True)) = True && (check_word xs)
| otherwise = False
check_word2 :: String -> String -> Int -> Bool
check_word2 word1 word2 dif | (dif > 1) = False
| ((length word1 == 1) && (length word2 == 1) && (head word1 == head word2)) = True
| ((length word1 == 1) && (length word2 == 1) && (head word1 /= head word2) && (dif<1)) = True
| ((head word1) == (head word2)) = check_word2 (tail word1) (tail word2) dif
| otherwise = check_word2 (tail word1) (tail word2) (dif+1)
subconjuntos2 :: [[String]] -> String -> String -> [[String]]
subconjuntos2 [] a b = []
subconjuntos2 (x:xs) a b | (length x <= 1) = subconjuntos2 xs a b
| ((head x == a) && (last x == b)) = (x:subconjuntos2 xs a b)
| ((head x /= a) || (last x /= b)) = (subconjuntos2 xs a b)
subconjuntos :: [a] -> [[a]]
subconjuntos [] = [[]]
subconjuntos (x:xs) = [x:ys | ys <- sub] ++ sub
where sub = subconjuntos xs
Mmm may be its inefficient but at least it does the solution..
i search all posible solutions, i compare head == "slice" and last == "stock", then i filter the ones that are solution and print the shorter one,
thanks and if you guys have any suggest say it :)
Not thoroughly tested, but this hopefully will help:
import Data.Function (on)
import Data.List (minimumBy, delete)
import Control.Monad (guard)
type Word = String
type Path = [String]
wordF :: [Word] -> Word -> Word -> Path
wordF words start end =
start : minimumBy (compare `on` length) (generatePaths words start end)
-- Use the list monad to do the nondeterminism and backtracking.
-- Returns a list of all paths that lead from `start` to `end`
-- in steps that `differByOne`.
generatePaths :: [Word] -> Word -> Word -> [Path]
generatePaths words start end = do
-- Choose one of the words, nondeterministically
word <- words
-- If the word doesn't `differByOne` from `start`, reject the choice
-- and backtrack.
guard $ differsByOne word start
if word == end
then return [word]
else do
next <- generatePaths (delete word words) word end
return $ word : next
differsByOne :: Word -> Word -> Bool
differsByOne "" "" = False
differsByOne (a:as) (b:bs)
| a == b = differsByOne as bs
| otherwise = as == bs
Example run:
>>> wordF ["spice","stick","smice","stock","slice","slick","stock"] "spice" "stock"
["spice","slice","slick","stick","stock"]
The list monad in Haskell is commonly described as a form of nondeterministic, backtracking computation. What the code above is doing is allowing the list monad to take on the responsibility of generating alternatives, testing whether they satisfy criteria, and backtracking on failure to the most recent choice point. The bind of the list monad, e.g. word <- words, means "nondeterministically pick one of the words. guard means "if the choices so far don't satisfy this condition, backtrack and make a different choice. The result of a list monad computation is the list of all the results that stem from choices that did not violate any guards.
If this looks like list comprehensions, well, list comprehensions are the same thing as the list monad—I chose to express it with the monad instead of comprehensions.
There have been several articles published recently on classic brute-force search problems.
Mark Dominus published a simple example of using lists for a simple exhaustive search.
Justin Le followed up with a small modification to the previous article that simplified tracking the current state of the search.
I followed up with a further modification that allowed measuring the gains from early rejection of part of the search tree.
Note that the code in my article is quite slow because it's measuring the amount of work done as well as doing it. My article has good examples for how to quickly reject parts of the search tree, but it should be considered only an illustration - not production code.
A brute force approach using recursion:
import Data.List (filter, (\\), reverse, delete, sortBy)
import Data.Ord (comparing)
neighbour :: String -> String -> Bool
neighbour word = (1 ==) . length . (\\ word)
process :: String -> String -> [String] -> [(Int, [String])]
process start end dict =
let
loop :: String -> String -> [String] -> [String] -> [(Int,[String])] -> [(Int,[String])]
loop start end dict path results =
case next of
[] -> results
xs ->
if elem end xs
then (length solution, solution) : results
else results ++ branches xs
where
next = filter (neighbour start) dict'
dict' = delete start dict
path' = start : path
branches xs = [a | x <- xs, a <- loop x end dict' path' results]
solution = reverse (end : path')
in
loop start end dict [] []
shortestSolution :: Maybe Int
shortestSolution = shortest solutions
where
solutions = process start end dict
shortest s =
case s of
[] -> Nothing
xs -> Just $ fst $ head $ sortBy (comparing fst) xs
start = "spice"
end = "stock"
dict = ["spice","stick","smice","slice","slick","stock"]
Notes:
This code computes all possibles solutions (process) and select the shortest one (shortestSolution), as Carl said, you might want to prune parts of the search tree for better performance.
Using a Maybe instead of returning -1 when a function can fail to return results is preferred.
Another way using a tree with breadth-first search:
import Data.Tree
import Data.List( filter, (\\), delete )
import Data.Maybe
node :: String -> [String] -> Tree String
node label dict = Node{ rootLabel = label, subForest = branches label (delete label dict) }
branches :: String -> [String] -> [Tree String]
branches start dict = map (flip node dict) (filter (neighbour start) dict)
neighbour :: String -> String -> Bool
neighbour word = (1 ==) . length . (\\ word)
-- breadth first traversal
shortestBF tree end = find [tree] end 0
where
find ts end depth
| null ts = Nothing
| elem end (map rootLabel ts) = Just depth
| otherwise = find (concat (map subForest ts)) end (depth+1)
result = shortestBF tree end
tree :: Tree String
tree = node start dict
start = "spice"
end = "stock"
dict = ["spice","stick","smice","slice","slick","stock"]
this is my code
font a = let x= ord a in
if x>=0 || x<=31 || x>=126 then ["*****","*****","*****","*****","*****","*****","*****"]
else
auxfont (fontBitmap!!(x-32))
where
auxfont b = let y = map trns (map rInt (map show b)) in
convertir y []
trns z = modA [] 1 z
modA o l k
| l < 8 = modA (o++[(k `mod` 2)]) (l+1) (k `div` 2)
| otherwise o
convertir (e1:e2:e3:e4:e5) f
| e1==[] = f
| otherwise convertir [tail(e1),tail(e2),tail(e3),tail(e4),tail(e5)] (f++[(psr(head(e1)))++(psr(head(e2)))++(psr(head(e3)))++(psr(head(e4)))++(psr(head(e5)))])
psr 0 = " "
psr 1 = "*"
and i had and this error in convertir:
[1 of 2] Compiling Pixels ( Pixels.hs, interpreted )
Pixels.hs:122:13: parse error (possibly incorrect indentation)
Failed, modules loaded: none.
Why the error
Every (normal) guard is of the form
| boolean expression = value
You missed this out for your otherwise cases. It works like this because otherwise is defined as
otherwise = True
so it's not a keyword like else, it's just a human-readable "always", and since the guards are tried top-to-bottom, this is a catch-all for anything that wasn't true above.
Some corrections
font a = let x= ord a in
if x>=0 || x<=31 || x>=126 then ["*****","*****","*****","*****","*****","*****","*****"]
else
auxfont (fontBitmap!!(x-32))
where
auxfont b = let y = map trns (map rInt (map show b)) in
convertir y []
trns z = modA [] 1 z
modA o l k
| l < 8 = modA (o++[(k `mod` 2)]) (l+1) (k `div` 2)
here:
| otherwise = o -- added =
convertir (e1:e2:e3:e4:e5) f
| e1==[] = f
and here:
| otherwise = convertir [tail(e1),tail(e2),tail(e3),tail(e4),tail(e5)] (f++[(psr(head(e1)))++(psr(head(e2)))++(psr(head(e3)))++(psr(head(e4)))++(psr(head(e5)))])
psr 0 = " "
psr 1 = "*"
Some abbreviations
By the way,
["*****","*****","*****","*****","*****","*****","*****"] is replicate 7 "*****" and
map trns (map rInt (map show b)) is map (trns.fInt.show) b.
Also [tail(e1),tail(e2),tail(e3),tail(e4)] is map tail [e1,e2,e3,e4,e5]
but I think you have a type error with :e5, because it has to be a list of lists in the pattern (e1:e2:e3:e4:e5) but you've used it like an element tail(e5).
Also [(psr(head(e1)))++(psr(head(e2)))++(psr(head(e3)))++(psr(head(e4)))++(psr(head(e5)))] is map (psr.head) [e1,e2,e3,e4,e5].
I have defined data type for Binary numbers as follows
data Bin = Nil | O Bin | I Bin
deriving (Show, Eq)
i want to define a function reverse :: Bin -> Bin so that when i give input like
reverse (I (O (I (I Nil)))) i should get the outut
I (I (O (I Nil))) that means reversed as input, any body please give me hint how i can do this ?
Why are you doing this this way? Why not something like this:
data Bit = I | O
newtype Bin = List Bit
Then you could just use the Prelude's reverse operation directly...
Edit
A simple substitution from the Prelude's function:
reverse x = rev x []
where
rev [] a = a
rev (x:xs) a = rev xs (x:a)
yields:
reverse x = rev x Nil
where
rev Nil a = a
rev (I xs) a = rev xs (I a)
rev (O xs) a = rev xs (O a)
The thing is, your type is very similar to the list type:
data List a = a : (List a) | []
so the logic for the List routines applies directly to your type.
data Bin = Nil | O Bin | I Bin deriving (Show, Eq)
reverse :: Bin -> Bin
reverse x = rev Nil x
where
rev a Nil = a
rev a ( O b ) = rev ( O a ) b
rev a ( I b ) = rev ( I a ) b
binToList Nil = []
binToList (O a) = False : binToList a
binToList (I a) = True : binToList a
listToBin [] = Nil
listToBin (False : xs) = O (listToBin xs)
listToBin (True : xs) = I (listToBin xs)
reverseBin = listToBin . reverse . binToList
GHC's List module defines the reverse function on lists like this:
reverse l = rev l []
where
rev [] a = a
rev (x:xs) a = rev xs (x:a)
The helper function rev uses its second element as an accumulator that stores the reversed part up to the current position. In each step the first element of the remaining input list is added to head of the accumulator that is passed to the recursive function call.
The same principle can be applied to your binary number type to reverse the order of the digits.
Seems odd that you're defining both a list type, and a type for bits. I think I'd reuse the base libraries list type [] and just set the elements to be your bit type, as Aidan shows above.
this is a possible solution:
reverseBin :: Bin -> Bin
reverseBin b = revBin b Nil
where revBin Nil acc = acc
revBin (I b) acc = revBin b (I acc)
revBin (O b) acc = revBin b (O acc)