Related
I want to create game Magic 15 Puzzle in Haskell I have function set :: [[Char]] -> Char -> [[Char]] .
It switches Char with empty space in [[Char]].
*Main> pp puzzle2
AC DE
FBHIJ
KGLNO
PQMRS
UVWXT
*Main> pp (set puzzle2 'C')
A CDE
FBHIJ
KGLNO
PQMRS
UVWXT
*Main>
Now I want to do recursion for [Char] (or String) like this (To do set xs for previous set x)
puzzle :: Result -> [Char] -> Result
puzzle gameboard (x:xs) = set (set (x:xs) x) xs
But compilation says it is error:
Couldn't match expected type ‘Char’ with actual type ‘[Char]’
I expect this output:
*Main> pp(puzzle puzzle2 "CB")
ABCDE
F HIJ
KGLNO
PQMRS
UVWXT
What can I do to solve this? Thanks a lot in advance for answer!
Whole Code:
import Data.Char
type Result = [String]
pp :: Result -> IO ()
pp x = putStr (concat (map (++"\n") x))
puzzle2 :: [[Char]]
puzzle2 = ["AC DE",
"FBHIJ",
"KGLNO",
"PQMRS",
"UVWXT"]
getCords board x = head ( head [[(row_index, column_index) |(column_index, char) <- zip[1..] row, x == char] |(row_index,row)<- zip [1..]board,x `elem` row])
getRow board c = fst ( getCords board c)
getCol board c = snd ( getCords board c)
check ch1 ch2 board = (getRow board ch2 == getRow board ch1 + 1 || getRow board ch2 == getRow board ch1 - 1) && (getCol board ch1 == getCol board ch2) || ((getRow board ch1 == getRow board ch2) && (getCol board ch2 == getCol board ch1 + 1 || getCol board ch2 == getCol board ch1 - 1) )
set gameboard x | check x ' ' gameboard = [[if ch == ' ' then x else if ch == x then ' ' else ch | ch<- line] | line<-gameboard]
| not (check x ' ' gameboard ) = [[ch | ch<- line] | line<-gameboard]
puzzle :: Result -> [Char] -> Result
puzzle gameboard (x:xs) = set (set (x:xs) x) xs
Just change the last function to
puzzle :: Result -> [Char] -> Result
puzzle g [] = g
puzzle g (x:xs) = puzzle (set g x) xs
I'm trying to solve Knight's Open Tour in Haskell，and come up with a solution to generate all possible solutions:
knightsTour :: Int -> [[(Int, Int)]]
knightsTour size = go 1 [(1, 1)]
where
maxSteps = size^2
isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size
go :: Int -> [(Int, Int)] -> [[(Int, Int)]]
go count acc | count == maxSteps = return $ reverse acc
go count acc = do
next <- nextSteps (head acc)
guard $ isValid next && next `notElem` acc
go (count + 1) (next : acc)
fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
(x', y') <- [(1, 2), (2, 1)]
[f, f'] <- fs
return (x + f x', y + f' y')
However, when tested with 8-by-8 chess board, the above function never stops, which is because the solution space is insanely large(19,591,828,170,979,904 different open tours according to 1). So I want to find only one solution. Fisrt, I tried:
-- First try
head (knightsTour 8)
with the hope that Haskell's lazy evaluation may come to save the day. But that didn't happen, the solution still runs forever.
Then, I tried：
-- second try
import Data.List (find)
import Data.Maybe (fromMaybe)
knightsTour' :: Int -> [(Int, Int)]
knightsTour' size = go 1 [(1, 1)]
where
maxSteps = size^2
isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size
go :: Int -> [(Int, Int)] -> [(Int, Int)]
go count acc | count == maxSteps = reverse acc
go count acc =
let
nextSteps' = [step | step <- nextSteps (head acc), isValid step && step `notElem` acc]
in
fromMaybe [] (find (not . null) $ fmap (\step -> go (count+1) (step:acc)) nextSteps')
fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
(x', y') <- [(1, 2), (2, 1)]
[f, f'] <- fs
return (x + f x', y + f' y')
But the solution above still cannot deliver, because it still runs forever.
My questions are:
Why can't lazy evaluation work as I expected to produce only the first solution found? In my opinion, in both tries, only the first solution is required.
How to change the code above to produce only the first solution?
So first the good news: your code is doing what you expect, and only producing the first solution!
That's also the bad news: it really is taking this long to even find the first solution. I think something you underestimate greatly is how many "dead ends" need to be encountered in order to produce a solution.
For example, here's a tweak of your initial version using the Debug.Trace module to let us know how many dead ends you encounter while trying to find the first path:
import Control.Monad
import Debug.Trace (trace)
import System.Environment (getArgs)
knightsTour :: Int -> [[(Int, Int)]]
knightsTour size = go 1 [(1, 1)]
where
maxSteps = size * size
isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size
go :: Int -> [(Int, Int)] -> [[(Int, Int)]]
go count acc | count == maxSteps = return $ reverse acc
go count acc = do
let nextPossible' = [ next |
next <- nextSteps (head acc)
, isValid next && next `notElem` acc]
nextPossible = if null nextPossible'
then trace ("dead end; count: " ++ show count) []
else nextPossible'
next <- nextPossible
-- guard $ isValid next && next `notElem` acc
go (count + 1) (next : acc)
fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
(x', y') <- [(1, 2), (2, 1)]
[f, f'] <- fs
return (x + f x', y + f' y')
main :: IO ()
main = do
[n] <- getArgs
print (head $ knightsTour (read n))
Now, let's see how much output that gives us for different board sizes:
/tmp$ ghc -o kntest -O2 kntest.hs
[1 of 1] Compiling Main ( kntest.hs, kntest.o )
Linking kntest ...
/tmp$ ./kntest 5 2>&1 | wc
27366 109461 547424
/tmp$ ./kntest 6 2>&1 | wc
783759 3135033 15675378
/tmp$ ./kntest 7 2>&1 | wc
818066 3272261 16361596
Okay, so we encountered 27,365 dead ends on a board size of 5 and over 800 thousand dead ends on a board size of 7. For a board size of eight, I redirected it to a file:
/tmp$ ./kntest 8 2> kn8.deadends.txt
It's still running. At this point, it's encountered over 38 million dead ends:
/tmp$ wc -l kn8.deadends.txt
38178728 kn8.deadends.txt
How many of those dead ends were really close to the end?
/tmp$ wc -l kn8.deadends.txt ; fgrep 'count: 61' kn8.deadends.txt | wc -l ; fgrep 'count: 62' kn8.deadends.txt | wc -l; fgrep 'count: 63' kn8.deadends.txt | wc -l ; wc -l kn8.deadends.txt
52759655 kn8.deadends.txt
1448
0
0
64656651 kn8.deadends.txt
So it's up to well over 64 million dead ends now and it still hasn't found a dead end longer than 61 steps.
And now it's at 85 million, and if I take too long to write the rest of this it could be at over 100 million by the time I finish this answer.
There are some things you might do to speed up your program (such as using a vector to track already visited spots rather than the O(n) notElem lookup), but fundamentally it's taking so long to get just the first answer because it's really much, much longer to the first answer than you initially thought.
EDIT: If you add a very simple, naive implementation of Warnsdorf's rule then you get the first knight's tour almost instantly even for very large (40x40) boards:
import Control.Monad
import System.Environment (getArgs)
import Data.List (sort)
knightsTour :: Int -> [[(Int, Int)]]
knightsTour size = go 1 [(1, 1)]
where
maxSteps = size * size
isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size
getValidFor from acc = do
next <- nextSteps from
guard $ isValid next && next `notElem` acc
return next
go :: Int -> [(Int, Int)] -> [[(Int, Int)]]
go count acc | count == maxSteps = return $ reverse acc
go count acc = do
let allPoss = getValidFor (head acc) acc
sortedPossible = map snd $ sort $
map (\x -> (length $ getValidFor x acc, x))
allPoss
next <- sortedPossible
go (count + 1) (next : acc)
fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
(x', y') <- [(1, 2), (2, 1)]
[f, f'] <- fs
return (x + f x', y + f' y')
main :: IO ()
main = do
[n] <- getArgs
print (head $ knightsTour (read n))
As part of some "self imposed homework" on Haskell study, I did the classic solution of the Towers of Hanoi:
doHanoi :: Int -> Int -> Int -> [(Int, Int)]
doHanoi 0 _ _ = []
doHanoi n from to = first ++ [(from, to)] ++ last
where
using = 3 - from - to;
first = doHanoi (n - 1) from using;
last = doHanoi (n - 1) using to
(where the meaning of doHanoi n from to using get the asequence of movements assuming the disks 0.. n - 1 are at peg from, and we need to move them to peg to.)
This gives the sequence of movements, e.g.,
>>> doHanoi 3 0 2
[(0,2),(0,1),(2,1),(0,2),(1,0),(1,2),(0,2)]
I then wanted to see if I could transform the output into the set of configurations (i.e., initially, all rings are on the left peg, then there are intermediate configurations, finally all rings are on the right peg). I could do this by writing a changeConfig function
changeConfig :: [[Int]] -> (Int, Int) -> [[Int]]
changeConfig [e0:e0s, e1s, e2s] (0, 1) = [e0s, e0:e1s, e2s]
changeConfig [e0:e0s, e1s, e2s] (0, 2) = [e0s, e1s, e0:e2s]
changeConfig [e0s, e1:e1s, e2s] (1, 0) = [e1:e0s, e1s, e2s]
changeConfig [e0s, e1:e1s, e2s] (1, 2) = [e0s, e1s, e1:e2s]
changeConfig [e0s, e1s, e2:e2s] (2, 0) = [e2:e0s, e1s, e2s]
changeConfig [e0s, e1s, e2:e2s] (2, 1) = [e0s, e2:e1s, e2s]
then using scanl:
>>> scanl changeConfig [[0.. 2], [], []] (doHanoi 3 0 2 1)
[[[0,1,2],[],[]],[[1,2],[],[0]],[[2],[1],[0]],[[2],[0,1],[]],[[],[0,1],[2]],[[0],[1],[2]],[[0],[],[1,2]],[[],[],[0,1,2]]]
While this works, I think I'm missing something in changeConfig: this is just an exhaustive enumeration of all configurations, in a setting that has some form of cyclic symmetry, that happened to work because there are three pegs, and would not scale well (in terms of LOC). What is the "Haskellic" way to write it?
Thanks to kind help by chepner and jberryman, here's what I came up with.
The function finding the movements is unchanged:
doHanoi :: Int -> Int -> Int -> [(Int, Int)]
doHanoi 0 _ _ = []
doHanoi n from to = first ++ [(from, to)] ++ last
where
using = 3 - from - to;
first = doHanoi (n - 1) from using;
last = doHanoi (n - 1) using to
Now an auxiliary function, changePeg es i from to new_e returns the output to peg i assuming it contained elements es, its index was i, the movement was from from to to, and of element new_e.
changePeg :: [Int] -> Int -> Int -> Int -> Int -> [Int]
changePeg es i from to new_e
| i == from = tail es
| i == to = new_e: es
| otherwise = es
Using this, changeConfig becomes
changeConfig :: [[Int]] -> (Int, Int) -> [[Int]]
changeConfig es (from, to) = new_es where
new_e = head $ es !! from;
new_es = [changePeg (es !! i) i from to new_e | i <- [0.. 2]]
As before, the solution can be found with
>>> scanl changeConfig [[0.. 2], [], []] (doHanoi 3 0 2)
[[[0,1,2],[],[]],[[1,2],[],[0]],[[2],[1],[0]],[[2],[0,1],[]],[[],[0,1],[2]],[[0],[1],[2]],[[0],[],[1,2]],[[],[],[0,1,2]]]
I am doing another Project Euler problem and I need to find when the result of these 3 lists is equal (we are given 40755 as the first time they are equal, I need to find the next:
hexag n = [ n*(2*n-1) | n <- [40755..]]
penta n = [ n*(3*n-1)/2 | n <- [40755..]]
trian n = [ n*(n+1)/2 | n <- [40755..]]
I tried adding in the other lists as predicates of the first list, but that didn't work:
hexag n = [ n*(2*n-1) | n <- [40755..], penta n == n, trian n == n]
I am stuck as to where to to go from here.
I tried graphing the function and even calculus but to no avail, so I must resort to a Haskell solution.
Your functions are weird. They get n and then ignore it?
You also have a confusion between function's inputs and outputs. The 40755th hexagonal number is 3321899295, not 40755.
If you really want a spoiler to the problem (but doesn't that miss the point?):
binarySearch :: Integral a => (a -> Bool) -> a -> a -> a
binarySearch func low high
| low == high = low
| func mid = search low mid
| otherwise = search (mid + 1) high
where
search = binarySearch func
mid = (low+high) `div` 2
infiniteBinarySearch :: Integral a => (a -> Bool) -> a
infiniteBinarySearch func =
binarySearch func ((lim+1) `div` 2) lim
where
lim = head . filter func . lims $ 0
lims x = x:lims (2*x+1)
inIncreasingSerie :: (Ord a, Integral i) => (i -> a) -> a -> Bool
inIncreasingSerie func val =
val == func (infiniteBinarySearch ((>= val) . func))
figureNum :: Integer -> Integer -> Integer
figureNum shape index = (index*((shape-2)*index+4-shape)) `div` 2
main :: IO ()
main =
print . head . filter r $ map (figureNum 6) [144..]
where
r x = inIncreasingSerie (figureNum 5) x && inIncreasingSerie (figureNum 3) x
Here's a simple, direct answer to exactly the question you gave:
*Main> take 1 $ filter (\(x,y,z) -> (x == y) && (y == z)) $ zip3 [1,2,3] [4,2,6] [8,2,9]
[(2,2,2)]
Of course, yairchu's answer might be more useful in actually solving the Euler question :)
There's at least a couple ways you can do this.
You could look at the first item, and compare the rest of the items to it:
Prelude> (\x -> all (== (head x)) $ tail x) [ [1,2,3], [1,2,3], [4,5,6] ]
False
Prelude> (\x -> all (== (head x)) $ tail x) [ [1,2,3], [1,2,3], [1,2,3] ]
True
Or you could make an explicitly recursive function similar to the previous:
-- test.hs
f [] = True
f (x:xs) = f' x xs where
f' orig (y:ys) = if orig == y then f' orig ys else False
f' _ [] = True
Prelude> :l test.hs
[1 of 1] Compiling Main ( test.hs, interpreted )
Ok, modules loaded: Main.
*Main> f [ [1,2,3], [1,2,3], [1,2,3] ]
True
*Main> f [ [1,2,3], [1,2,3], [4,5,6] ]
False
You could also do a takeWhile and compare the length of the returned list, but that would be neither efficient nor typically Haskell.
Oops, just saw that didn't answer your question at all. Marking this as CW in case anyone stumbles upon your question via Google.
The easiest way is to respecify your problem slightly
Rather than deal with three lists (note the removal of the superfluous n argument):
hexag = [ n*(2*n-1) | n <- [40755..]]
penta = [ n*(3*n-1)/2 | n <- [40755..]]
trian = [ n*(n+1)/2 | n <- [40755..]]
You could, for instance generate one list:
matches :: [Int]
matches = matches' 40755
matches' :: Int -> [Int]
matches' n
| hex == pen && pen == tri = n : matches (n + 1)
| otherwise = matches (n + 1) where
hex = n*(2*n-1)
pen = n*(3*n-1)/2
tri = n*(n+1)/2
Now, you could then try to optimize this for performance by noticing recurrences. For instance when computing the next match at (n + 1):
(n+1)*(n+2)/2 - n*(n+1)/2 = n + 1
so you could just add (n + 1) to the previous tri to obtain the new tri value.
Similar algebraic simplifications can be applied to the other two functions, and you can carry all of them in accumulating parameters to the function matches'.
That said, there are more efficient ways to tackle this problem.
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.