Related
I need to swap blank space with letter from "moves" and each time I swap it I need to continue with another one from moves. I get Couldn't match expected type, even though I just want to return value x when it doesn't meet condition.
Error message:
[1 of 1] Compiling Main ( puzzlesh.hs, interpreted )
puzzlesh.hs:19:43: error:
• Couldn't match expected type ‘Int -> a’ with actual type ‘Char’
• In the expression: x
In the expression: if x == ' ' then repl x else x
In an equation for ‘eval’: eval x = if x == ' ' then repl x else x
• Relevant bindings include
eval :: Char -> Int -> a (bound at puzzlesh.hs:19:5)
repl :: forall p. p -> Int -> a (bound at puzzlesh.hs:20:5)
moves :: [a] (bound at puzzlesh.hs:16:9)
p :: t [Char] -> [a] -> [Int -> a] (bound at puzzlesh.hs:16:1)
|
19 | eval x = if x == ' ' then repl x else x
| ^
Failed, no modules loaded.
Code:
import Data.Char ( intToDigit )
sample :: [String]
sample = ["AC DE",
"FBHIJ",
"KGLNO",
"PQMRS",
"UVWXT"]
moves = "CBGLMRST"
type Result = [String]
pp :: Result -> IO ()
pp x = putStr (concat (map (++"\n") x))
p input moves = [eval x | x <- (concat input)]
where
c = 1
eval x = if x == ' ' then repl x else x
repl x count = moves !! count
count c = c + 1
I need to take character from moves, replace it onto blank space and do this till moves is []
Desired output:
ABCDE
FGHIJ
KLMNO
PQRST
UVWX
As with most problems, the key is to break it down into smaller problems. Your string that encodes character swaps: can we break that into pairs?
Yes, we just need to create a tuple from the first two elements in the list, and then add that to the result of calling pairs on the tail of the list.
pairs :: [a] -> [(a, a)]
pairs (x:tl#(y:_)) = (x, y) : pairs tl
pairs _ = []
If we try this with a string.
Prelude> pairs "CBGLMRST"
[('C','B'),('B','G'),('G','L'),('L','M'),('M','R'),('R','S'),('S','T')]
But you want a blank space swapped with the first character:
Prelude> pairs $ " " ++ "CBGLMRST"
[(' ','C'),('C','B'),('B','G'),('G','L'),('L','M'),('M','R'),('R','S'),('S','T')]
Now you have a lookup table with original characters and their replacements and the rest is straightforward. Just map a lookup on this table over each character in each string in the list.
Because you never touch any letter in the original strings more than once, you won't have to worry about double replacements.
Prelude> s = ["AC DE","FBHIJ","KGLNO","PQMRS","UVWXT"]
Prelude> r = "CBGLMRST"
Prelude> r' = " " ++ r
Prelude> p = pairs r'
Prelude> [[case lookup c p of {Just r -> r; _ -> c} | c <- s'] | s' <- s]
["ABCDE","FGHIJ","KLMNO","PQRST","UVWXT"]
So im doing this function and i need her to display on the screen the result of (premio ap x) , the problem is that (premio ap x)::Maybe Int , so its not a string.
joga :: Aposta -> IO ()
joga x= do
ap <- leAposta;
let arroz = (premio ap x)
putStr ^^^^^^^^^^
return ()
How can i convert this to a string? Or there is another way to display on the screen things that are not strings.
update :full code
comuns :: Aposta -> Aposta -> (Int,Int)
comuns (Ap a (b,c)) (Ap k (l,ç)) = (cnum a k, cnum [b,c] [l,ç])
cnum::[Int]->[Int]->Int
cnum [] l2 = 0
cnum (x:xs) l2 | elem x l2 = 1 + cnum xs l2
|otherwise = cnum xs l2
premio :: Aposta -> Aposta -> Maybe Int
premio l1 l2 | x == (5,2)= Just 1
| x == (5,1)= Just 2
| x == (5,0)= Just 3
| x == (4,2)= Just 4
| x == (4,1)= Just 5
| x == (4,0)= Just 6
| x == (3,2)= Just 7
| x == (2,2)= Just 8
| x == (3,1)= Just 9
| x == (3,0)= Just 10
| x == (1,2)= Just 11
| x == (2,1)= Just 12
| x == (2,0)= Just 13
|otherwise = Nothing
where
x = comuns l1 l2
leAposta :: IO Aposta
leAposta = do
putStrLn "Insira como lista as 5 estrelas"
num <-getLine
putStrLn "Insira em par as 2 estrelas"
es<-getLine
let ap = (Ap (read num) (read es))
if (valida ap)
then return ap
else do
putStrLn "Aposta invalida"
leAposta
Since arroz is premio ap x which has type Maybe Int, you can simply print arroz.
print works on any type that can be printed, i.e. on those types in class Show.
(You probably don't want to use print on values that are already strings, though, since that will print the escaped string, with quotes around. Use putStr and putStrLn for strings.)
I wrote a simple tic-tac-toe program in Haskell. It runs on the command line, has a one and two player mode, and implements a minimax algorithm when you play against it.
I'm used to writing proper code in OO languages, but Haskell is new to me. This code works reasonably well, but seems hard to read (even to me!). Any suggestions on how to make this code more...Haskellian?
import Data.List
import Data.Char
import Data.Maybe
import Control.Monad
data Square = A | B | C | D | E | F | G | H | I | X | O deriving (Read, Eq, Ord)
instance Show Square where
show A = "a"
show B = "b"
show C = "c"
show D = "d"
show E = "e"
show F = "f"
show G = "g"
show H = "h"
show I = "i"
show X = "X"
show O = "O"
type Row = [Square]
type Board = [Row]
data Player = PX | PO deriving (Read, Eq)
instance Show Player where
show PX = "Player X"
show PO = "Player O"
data Result = XWin | Tie | OWin deriving (Read, Show, Eq, Ord)
main :: IO ()
main = do
putStrLn "Let's play some tic tac toe!!!"
putStrLn "Yeeeaaaaaahh!!!"
gameSelect
gameSelect :: IO ()
gameSelect = do
putStrLn "Who gonna play, one playa or two??? (Enter 1 or 2)"
gameMode <- getLine
case gameMode of "1" -> onePlayerMode
"2" -> twoPlayerMode
gameMode -> gameSelect
where onePlayerMode = do
putStrLn "One playa"
putStrLn "Cool! Get ready to play...AGAINST MY INVINCIBLE TIC TAC TOE AI!!!!! HAHAHAHA!!!"
gameLoop 1 emptyBoard PX
twoPlayerMode = do
putStrLn "Two players"
gameLoop 2 emptyBoard PX
emptyBoard = [[A,B,C],[D,E,F],[G,H,I]]
gameLoop :: Int -> Board -> Player -> IO ()
gameLoop noOfPlayers board player = do
case detectWin board of Just XWin -> endgame board XWin
Just OWin -> endgame board OWin
Just Tie -> endgame board Tie
Nothing -> if noOfPlayers == 1
then if player == PX
then enterMove 1 board player
else enterBestMove board PO
else enterMove 2 board player
enterMove :: Int -> Board -> Player -> IO ()
enterMove noOfPlayers board player = do
displayBoard board
if noOfPlayers == 1
then do putStrLn ("Make your move. (A-I)")
else do putStrLn (show player ++ ", it's your turn. (A-I)")
move <- getLine
print move
if not $ move `elem` ["a","b","c","d","e","f","g","h","i"]
then do
putStrLn $ move ++ " is not a move, doofus"
gameLoop noOfPlayers board player
else if (read (map toUpper move) :: Square) `elem` [ sq | sq <- concat board]
then do
gameLoop noOfPlayers (newBoard (read (map toUpper move) :: Square) player board) (if player == PX then PO else PX)
else do
putStrLn "That square is already occupied"
gameLoop noOfPlayers board player
enterBestMove :: Board -> Player -> IO ()
enterBestMove board player = gameLoop 1 (newBoard bestmove player board) PX
where bestmove = fst $ findBestMove PO board
findBestMove :: Player -> Board -> (Square, Result)
findBestMove player board
| player == PO = findMax results
| player == PX = findMin results
where findMin = foldl1 (\ acc x -> if snd x < snd acc then x else acc)
findMax = foldl1 (\ acc x -> if snd x > snd acc then x else acc)
results = [ (sq, getResult b) | (sq, b) <- boards player board ]
getResult b = if detectWin b == Nothing
then snd (findBestMove (if player == PX then PO else PX) b)
else fromJust $ detectWin b
boards :: Player -> Board -> [(Square, Board)]
boards player board = [(sq, newBoard sq player board) | sq <- concat board, sq /= X, sq /=O]
displayBoard :: Board -> IO ()
displayBoard board = do
mapM_ print board
newBoard :: Square -> Player -> Board -> Board
newBoard move player board = [ [if sq == move then mark else sq | sq <- row] | row <- board]
where mark = if player == PX then X else O
detectWin :: Board -> (Maybe Result)
detectWin board
| [X,X,X] `elem` board ++ transpose board = Just XWin
| [X,X,X] `elem` [diagonal1 board, diagonal2 board] = Just XWin
| [O,O,O] `elem` board ++ transpose board = Just OWin
| [O,O,O] `elem` [diagonal1 board, diagonal2 board] = Just OWin
| [X,X,X,X,X,O,O,O,O] == (sort $ concat board) = Just Tie
| otherwise = Nothing
where
diagonal1 :: Board -> [Square]
diagonal1 bs = bs!!0!!0 : bs!!1!!1 : bs!!2!!2 : []
diagonal2 :: Board -> [Square]
diagonal2 bs = bs!!0!!2 : bs!!1!!1 : bs!!2!!0 : []
endgame :: Board -> Result -> IO ()
endgame board result = do
displayBoard board
if result `elem` [XWin, OWin]
then
let player = if result == XWin then PX else PO
in do
putStrLn ("The game is over, and " ++ show player ++ " wins!")
putStrLn ((if player == PX then show PO else show PX) ++ " is a loser lol")
else do
putStrLn "The game is a tie"
putStrLn "You are both losers! Ugh!"
putStrLn "Want to play again? (y/n)"
again <- getLine
if again `elem` ["y", "Y", "yes", "Yes", "YES"]
then gameSelect
else do
putStrLn "Goodbye"
EDIT: with special thanks to #Chi and #Caridorc, I've made the following changes. Further suggestions will be considered and updated as well
import Data.List
import Data.Char
import Data.Maybe
import Control.Monad
data Square = A | B | C | D | E | F | G | H | I | X | O deriving (Read, Eq, Ord)
instance Show Square where
show A = "a"
show B = "b"
show C = "c"
show D = "d"
show E = "e"
show F = "f"
show G = "g"
show H = "h"
show I = "i"
show X = "X"
show O = "O"
type Row = [Square]
type Board = [Row]
data Player = PX | PO deriving (Read, Eq)
instance Show Player where
show PX = "Player X"
show PO = "Player O"
data Result = XWin | Tie | OWin deriving (Read, Show, Eq, Ord)
main :: IO ()
main = do
putStrLn "Let's play some tic tac toe!!!"
putStrLn "Yeeeaaaaaahh!!!"
gameSelect
gameSelect :: IO ()
gameSelect = do
putStrLn "Who gonna play, one playa or two??? (Enter 1 or 2)"
gameMode <- getLine
case gameMode of
"1" -> onePlayerMode
"2" -> twoPlayerMode
_ -> gameSelect
where onePlayerMode = do
putStrLn "One playa"
putStrLn "Cool! Get ready to play...AGAINST MY INVINCIBLE TIC TAC TOE AI!!!!! HAHAHAHA!!!"
gameLoop 1 emptyBoard PX
twoPlayerMode = do
putStrLn "Two players"
gameLoop 2 emptyBoard PX
emptyBoard = [[A,B,C],[D,E,F],[G,H,I]]
displayBoard :: Board -> IO ()
displayBoard board = do
mapM_ print board
otherPlayer :: Player -> Player
otherPlayer PX = PO
otherPlayer PO = PX
gameLoop :: Int -> Board -> Player -> IO ()
gameLoop noOfPlayers board player = do
case detectWin board of
Just res -> endgame board res
Nothing -> case noOfPlayers of
1 -> case player of
PX -> enterMove 1 board player
PO -> enterBestMove board PO
2 -> enterMove 2 board player
enterMove :: Int -> Board -> Player -> IO ()
enterMove noOfPlayers board player = do
displayBoard board
case noOfPlayers of
1 -> do putStrLn ("Make your move. (A-I)")
2 -> do putStrLn (show player ++ ", it's your turn. (A-I)")
move <- getLine
print move
if not $ move `elem` ["a","b","c","d","e","f","g","h","i"] then do
putStrLn $ move ++ " is not a move, doofus"
gameLoop noOfPlayers board player
else if (read (map toUpper move) :: Square) `elem` (concat board) then do
gameLoop noOfPlayers (newBoard (read (map toUpper move) :: Square) player board) (otherPlayer player)
else do
putStrLn "That square is already occupied"
gameLoop noOfPlayers board player
enterBestMove :: Board -> Player -> IO ()
enterBestMove board player = gameLoop 1 (newBoard bestmove player board) PX
where bestmove = fst $ findBestMove PO board
findBestMove :: Player -> Board -> (Square, Result) -- minimax algorithm
findBestMove player board
| player == PO = findMax results
| player == PX = findMin results
where findMin = foldl1 (\ acc x -> if snd x < snd acc then x else acc)
findMax = foldl1 (\ acc x -> if snd x > snd acc then x else acc)
results = [ (sq, getResult b) | (sq, b) <- boards player board ]
getResult b = case detectWin b of
Nothing -> snd (findBestMove (otherPlayer player) b)
Just x -> x
boards :: Player -> Board -> [(Square, Board)]
boards player board = [(sq, newBoard sq player board) | sq <- concat board, sq /= X, sq /=O]
newBoard :: Square -> Player -> Board -> Board
newBoard move player board = [ [if sq == move then mark else sq | sq <- row] | row <- board]
where mark = if player == PX then X else O
detectWin :: Board -> (Maybe Result)
detectWin board
| [X,X,X] `elem` (triplets board) = Just XWin
| [O,O,O] `elem` (triplets board) = Just OWin
| [X,X,X,X,X,O,O,O,O] == (sort $ concat board) = Just Tie
| otherwise = Nothing
triplets :: Board -> [[Square]]
triplets board = board ++ transpose board ++ [diagonal1] ++ [diagonal2]
where
flat = concat board
diagonal1 = [flat !! 0, flat !! 4, flat !! 8]
diagonal2 = [flat !! 2, flat !! 4, flat !! 6]
endgame :: Board -> Result -> IO ()
endgame board result = do
displayBoard board
putStrLn $ endGameMessage result
putStrLn "Want to play again? (y/n)"
again <- getLine
if again `elem` ["y", "Y", "yes", "Yes", "YES"]
then gameSelect
else do
putStrLn "Goodbye"
endGameMessage :: Result -> String
endGameMessage result
| result `elem` [XWin, OWin] = winnerNotice ++ loserNotice
| otherwise = "The game is a tie\n" ++ "You are both losers! Ugh!"
where
winner = case result of
XWin -> PX
OWin -> PO
winnerNotice = "The game is over, and " ++ show winner ++ " wins!\n"
loserNotice = (show $ otherPlayer winner) ++ " is a loser lol"
Code style is often a matter of personal preference, in Haskell arguably more than in other languages with a "standard" style guide. Still, here's a few random suggestions.
Don't over-indent cases: just use another line
case gameMode of "1" -> onePlayerMode
"2" -> twoPlayerMode
gameMode -> gameSelect
vs
case gameMode of
"1" -> onePlayerMode
"2" -> twoPlayerMode
gameMode -> gameSelect
or even
case gameMode of
"1" -> onePlayerMode
"2" -> twoPlayerMode
_ -> gameSelect
case is usually preferred to if .. == Constructor:
if player == PX
then enterMove 1 board player
else enterBestMove board PO
vs
case player of
PX -> enterMove 1 board player
PY -> enterBestMove board PO
I'd strongly recommend against using partial functions like fromJust, since they can crash your program if you forget to check for Nothing beforehand. Safer alternatives exist, which never cause such crashes -- less burden on the programmer.
if detectWin b == Nothing
then snd (findBestMove (if player == PX then PO else PX) b)
else fromJust $ detectWin b
vs
case detectWin b of
Nothing -> snd $ findBestMove (if player == PX then PO else PX) b
Just x -> x
or
fromMaybe (snd $ findBestMove (if player == PX then PO else PX) b)
$ detectWin b
Try to factorize commonly used functions. For instance
nextPlayer PX = PO
nextPlayer PO = PX
can replace uses of
if player == PX then PO else PX
No do is needed when there's only one statement:
if noOfPlayers == 1
then do putStrLn ("Make your move. (A-I)") -- no need for parentheses here
else do putStrLn (show player ++ ", it's your turn. (A-I)")
Since you mention where in the title, let me state that I have mixed feelings about where, in general. I know I often tend to avoid where in favor of let, but this feeling is not shared with many other Haskellers, so take this with some care.
Personally, I tend to limit my where uses to one-liners:
foo = f x y
where x = ...
y = ...
Especially in do blocks, which might span several lines, I prefer lets:
foo = do
line
line using x -- what is x ??!?
line
...
line
where x = ... -- ah, here it is
vs
foo = do
line
let x = ...
line using x
line
...
line
However, feel free to adopt the style you find more readable.
Also don't forget to add a few comments, as #mawalker points out. Some definitions are obvious and don't need any explanation. Others could benefit from a few lines explaining the purpose.
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"]
I'm trying to complete the last part of my Haskell homework and I'm stuck, my code so far:
data Entry = Entry (String, String)
class Lexico a where
(<!), (=!), (>!) :: a -> a -> Bool
instance Lexico Entry where
Entry (a,_) <! Entry (b,_) = a < b
Entry (a,_) =! Entry (b,_) = a == b
Entry (a,_) >! Entry (b,_) = a > b
entries :: [(String, String)]
entries = [("saves", "en vaut"), ("time", "temps"), ("in", "<`a>"),
("{", "{"), ("A", "Un"), ("}", "}"), ("stitch", "point"),
("nine.", "cent."), ("Zazie", "Zazie")]
build :: (String, String) -> Entry
build (a, b) = Entry (a, b)
diction :: [Entry]
diction = quiksrt (map build entries)
size :: [a] -> Integer
size [] = 0
size (x:xs) = 1+ size xs
quiksrt :: Lexico a => [a] -> [a]
quiksrt [] = []
quiksrt (x:xs)
|(size [y|y <- xs, y =! x]) > 0 = error "Duplicates not allowed."
|otherwise = quiksrt [y|y <- xs, y <! x]++ [x] ++ quiksrt [y|y <- xs, y >! x]
english :: String
english = "A stitch in time save nine."
show :: Entry -> String
show (Entry (a, b)) = "(" ++ Prelude.show a ++ ", " ++ Prelude.show b ++ ")"
showAll :: [Entry] -> String
showAll [] = []
showAll (x:xs) = Main.show x ++ "\n" ++ showAll xs
main :: IO ()
main = do putStr (showAll ( diction ))
The question asks:
Write a Haskell programs that takes
the English sentence 'english', looks
up each word in the English-French
dictionary using binary search,
performs word-for-word substitution,
assembles the French translation, and
prints it out.
The function 'quicksort' rejects
duplicate entries (with 'error'/abort)
so that there is precisely one French
definition for any English word. Test
'quicksort' with both the original
'raw_data' and after having added
'("saves", "sauve")' to 'raw_data'.
Here is a von Neumann late-stopping
version of binary search. Make a
literal transliteration into Haskell.
Immediately upon entry, the Haskell
version must verify the recursive
"loop invariant", terminating with
'error'/abort if it fails to hold. It
also terminates in the same fashion if
the English word is not found.
function binsearch (x : integer) : integer
local j, k, h : integer
j,k := 1,n
do j+1 <> k --->
h := (j+k) div 2
{a[j] <= x < a[k]} // loop invariant
if x < a[h] ---> k := h
| x >= a[h] ---> j := h
fi
od
{a[j] <= x < a[j+1]} // termination assertion
found := x = a[j]
if found ---> return j
| not found ---> return 0
fi
In the Haskell version
binsearch :: String -> Integer -> Integer -> Entry
as the constant dictionary 'a' of type
'[Entry]' is globally visible. Hint:
Make your string (English word) into
an 'Entry' immediately upon entering
'binsearch'.
The programming value of the
high-level data type 'Entry' is that,
if you can design these two functions
over the integers, it is trivial to
lift them to to operate over Entry's.
Anybody know how I'm supposed to go about my binarysearch function?
The instructor asks for a "literal transliteration", so use the same variable names, in the same order. But note some differences:
the given version takes only 1
parameter, the signature he gives
requires 3. Hmmm,
the given version is not recursive, but he asks for a
recursive version.
Another answer says to convert to an Array, but for such a small exercise (this is homework after all), I felt we could pretend that lists are direct access. I just took your diction::[Entry] and indexed into that. I did have to convert between Int and Integer in a few places.
Minor nit: You've got a typo in your english value (bs is a shortcut to binSearch I made):
*Main> map bs (words english)
[Entry ("A","Un"),Entry ("stitch","point"),Entry ("in","<`a>"),Entry ("time","te
mps"),*** Exception: Not found
*Main> map bs (words englishFixed)
[Entry ("A","Un"),Entry ("stitch","point"),Entry ("in","<`a>"),Entry ("time","te
mps"),Entry ("saves","en vaut"),Entry ("nine.","cent.")]
*Main>
A binary search needs random access, which is not possible on a list. So, the first thing to do would probably be to convert the list to an Array (with listArray), and do the search on it.
here's my code for just the English part of the question (I tested it and it works perfectly) :
module Main where
class Lex a where
(<!), (=!), (>!) :: a -> a -> Bool
data Entry = Entry String String
instance Lex Entry where
(Entry a _) <! (Entry b _) = a < b
(Entry a _) =! (Entry b _) = a == b
(Entry a _) >! (Entry b _) = a > b
-- at this point, three binary (infix) operators on values of type 'Entry'
-- have been defined
type Raw = (String, String)
raw_data :: [Raw]
raw_data = [("than a", "qu'un"), ("saves", "en vaut"), ("time", "temps"),
("in", "<`a>"), ("worse", "pire"), ("{", "{"), ("A", "Un"),
("}", "}"), ("stitch", "point"), ("crime;", "crime,"),
("a", "une"), ("nine.", "cent."), ("It's", "C'est"),
("Zazie", "Zazie"), ("cat", "chat"), ("it's", "c'est"),
("raisin", "raisin sec"), ("mistake.", "faute."),
("blueberry", "myrtille"), ("luck", "chance"),
("bad", "mauvais")]
cook :: Raw -> Entry
cook (x, y) = Entry x y
a :: [Entry]
a = map cook raw_data
quicksort :: Lex a => [a] -> [a]
quicksort [] = []
quicksort (x:xs) = quicksort (filter (<! x) xs) ++ [x] ++ quicksort (filter (=! x) xs) ++ quicksort (filter (>! x) xs)
getfirst :: Entry -> String
getfirst (Entry x y) = x
getsecond :: Entry -> String
getsecond (Entry x y) = y
binarysearch :: String -> [Entry] -> Int -> Int -> String
binarysearch s e low high
| low > high = " NOT fOUND "
| getfirst ((e)!!(mid)) > s = binarysearch s (e) low (mid-1)
| getfirst ((e)!!(mid)) < s = binarysearch s (e) (mid+1) high
| otherwise = getsecond ((e)!!(mid))
where mid = (div (low+high) 2)
translator :: [String] -> [Entry] -> [String]
translator [] y = []
translator (x:xs) y = (binarysearch x y 0 ((length y)-1):translator xs y)
english :: String
english = "A stitch in time saves nine."
compute :: String -> [Entry] -> String
compute x y = unwords(translator (words (x)) y)
main = do
putStr (compute english (quicksort a))
An important Prelude operator is:
(!!) :: [a] -> Integer -> a
-- xs!!n returns the nth element of xs, starting at the left and
-- counting from 0.
Thus, [14,7,3]!!1 ~~> 7.