I want to write a function which calculates all combinations of the numbers 1 to 7 in 7-tuples, but every number can occur only once in every tuple.
So far I found this approach, but it also returns combinations with multiple occurrences of the same number in every tuple. I am not quite sure how to remove tuples with multiple
occurrences of the same number.
a = [(a,b,c,d,e,f,g) | a <- [1..7], b <- [1..7], c <- [1..7],
d <- [1..7], e <- [1..7], f <- [1..7], g <- [1..7]]
Example for goal result (all valid combinations should be in here):
[(1,2,3,4,5,6,7),(2,1,3,4,5,6,7),(2,3,1,4,5,6,7),...]
You can use list difference (\\) from Data.List.
perms = [ (a,b,c,d,e,f,g) | a <- [1..7]
, b <- [1..7] \\ [a]
, c <- [1..7] \\ [a,b]
, d <- [1..7] \\ [a,b,c]
, e <- [1..7] \\ [a,b,c,d]
, f <- [1..7] \\ [a,b,c,d,e]
, g <- [1..7] \\ [a,b,c,d,e,f] ]
This way b will be chosen to be different from a, c will be different from a and b, and so on.
We can optimize the code from the answer by kuoytfouy, as
perms = [(a,b,c,d,e,f,g) | a <- [1..7], let dom6 = [1..7] \\ [a]
, b <- dom6, let dom5 = dom6 \\ [b]
, c <- dom5, let dom4 = dom5 \\ [c]
, d <- dom4, let dom3 = dom4 \\ [d]
, e <- dom3, let dom2 = dom3 \\ [e]
, f <- dom2, let dom1 = dom2 \\ [f]
, g <- dom1, let dom0 = dom1 \\ [g] ]
and further improve it by cutting away the redundant computations,
perms = [(a,b,c,d,e,f,g) | a <- [1..7], let dom6 = delete a [1..7]
, b <- dom6, let dom5 = delete b dom6
, c <- dom5, let dom4 = delete c dom5
, d <- dom4, let dom3 = delete d dom4
, e <- dom3, let dom2 = delete e dom3
, f <- dom2, let [g] = delete f dom2 ]
Composing the choosing of an element with its deletion from the current domain gives us one function that does the two jobs at the same time, usually called picks. It's been used in SO answers in the past and can be found there.
See also:
picks from one pigworker
choose in Unique Selection monad
a Common Lisp answer of mine with an efficient code which actually shrinks the domain list by surgical mutation of the list structure, plucking the elements out one by one as we go down the recursively built nested loops; and healing it on the way back.
That is to say, choose- (or equivalently, picks-) based Haskell code is under grave suspicion of being grossly inefficient (inits being quadratic when fully forced, for starters).
Re-calculating the shrunk domains each time, like in this answer, we only end up with seven (six, whatever) domain lists at each point in time, each fully garbage collectible when done with -- but, each delete invocation searches its argument from the start anew (the inefficiency picks was invented to fix...), again suggesting the overall calculation being quadratic, inefficient. Food for thought!
What about something like:
import Data.List
list = [(a,b,c,d,e,f,g) | a <- [1..7], b <- [1..7], c <- [1..7],
d <- [1..7], e <- [1..7], f <- [1..7], g <- [1..7], [1,2,3,4,5,6,7]\\[a,b,c,d,e,f,g]==[]]
We can make a "helper function" here that for a given list xs generates a list of tuples where the first element is an element we picked, and the second the list of remaining elements, like:
import Data.List(inits, tails)
pick :: [a] -> [(a, [a])]
pick ls = [(b, as ++ bs) | (as, (b:bs)) <- zip (inits ls) (tails ls)]
For example:
Prelude Data.List> pick [1..5]
[(1,[2,3,4,5]),(2,[1,3,4,5]),(3,[1,2,4,5]),(4,[1,2,3,5]),(5,[1,2,3,4])]
each item thus picks an element from the list and returns a list where that picked element is removed. We can use this to then pass that list to the next generator.
Then we can use this for example in a do block like:
perms :: (Num a, Enum a) => [(a, a, a, a, a, a, a)]
perms = do
(a, as) <- pick [1..7]
(b, bs) <- pick as
(c, cs) <- pick bs
(d, ds) <- pick cs
(e, es) <- pick ds
(f, [g]) <- pick es
return (a, b, c, d, e, f, g)
which yields:
Prelude Data.List> perms
[(1,2,3,4,5,6,7),(1,2,3,4,5,7,6),(1,2,3,4,6,5,7),(1,2,3,4,6,7,5),(1,2,3,4,7,5,6),(1,2,3,4,7,6,5),(1,2,3,5,4,6,7),(1,2,3,5,4,7,6), ...
Related
I'm trying to calculate the module of an index of a list.
list=[5,6,7,8]
a = elemIndex 7 list
b = mod a 2
Ideally, this would give me b = 0 since a = 2 (technically).
But I'm getting error messages since a is not 2 but Just 2.
You can do this with fmap :: Functor f => (a -> b) -> f a -> f b or its operator variant (<$>) :: Functor f => (a -> b) -> f a -> f b to apply a function to the item wrapped in the Just … data constructor:
b = (`mod` 2) <$> a
this will then return Just 0 when a is Just 2, and Nothing if the elemIndex returned a Nothing. This thus means that if elemIndex fails (because the index is out of range), b will be Nothing.
You can just use pattern matching with let to get to the inner part of the Maybe value when it is guaranteed to be Just _:
list = [5,6,7,8]
a = elemIndex 7 list
b = mod a 2
foo list = [b | n <- [5,6,7,8]
, let a = elemIndex n [5,6,7,8]
, let Just i = a
, let b = mod i 2]
= [b | n <- list
, let Just i = elemIndex n list
, let b = mod i 2]
= [b | (_, i) <- zip list [0..]
, let b = mod a 2]
= ls where ls = [0,1] ++ ls
bar list = [(n,b) | n <- list
, let Just i = elemIndex n list
, let b = mod i 2]
= [(n,b) | (n, i) <- zip list [0..]
, let b = mod i 2]
= zip list ls where ls = cycle [0,1]
Normally this kind of pattern matching is frowned upon since it is partial, i.e. can cause error if the value is actually Nothing, but here it is correct by construction.
But then really, why put it into a Just -- just use it as it is. And we did.
i'm trying to write a function that for n gives matrix n*n with unique rows and columns (latin square).
I got function that gives my list of strings "1" .. "2" .. "n"
numSymbol:: Int -> [String]
I tried to generate all permutations of this, and them all n-length tuples of permutations, and them check if it is unique in row / columns. But complexity (n!)^2 works perfect for 2 and 3, but with n > 3 it takes forever. It is possible to build latin square from permutations directly, for example from
permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"],["3","1","2"],["3","2","1"]]
get
[[["1","2","3",],["2","1","3"],["3","1","2"]] , ....]
without generating list like [["1",...],["1",...],...], when we know first element disqualify it ?
Note: since we can easily take a Latin square that's been filled with numbers from 1 to n and re-label it with anything we want, we can write code that uses integer symbols without giving anything away, so let's stick with that.
Anyway, the stateful backtracking/nondeterministic monad:
type StateList s = StateT s []
is helpful for this sort of problem.
Here's the idea. We know that every symbol s is going to appear exactly once in each row r, so we can represent this with an urn of all possible ordered pairs (r,s):
my_rs_urn = [(r,s) | r <- [1..n], s <- [1..n]]
Similarly, as every symbol s appears exactly once in each column c, we can use a second urn:
my_cs_urn = [(c,s) | c <- [1..n], s <- [1..n]]
Creating a Latin square is matter of filling in each position (r,c) with a symbol s by removing matching balls (r,s) and (c,s) (i.e., removing two balls, one from each urn) so that every ball is used exactly once. Our state will be the content of the urns.
We need backtracking because we might reach a point where for a particular position (r,c), there is no s such that (r,s) and (c,s) are both still available in their respective urns. Also, a pleasant side-effect of list-based backtracking/nondeterminism is that it'll generate all possible Latin squares, not just the first one it finds.
Given this, our state will look like:
type Urn = [(Int,Int)]
data S = S
{ size :: Int
, rs :: Urn
, cs :: Urn }
I've included the size in the state for convenience. It won't ever be modified, so it actually ought to be in a Reader instead, but this is simpler.
We'll represent a square by a list of cell contents in row-major order (i.e., the symbols in positions [(1,1),(1,2),...,(1,n),(2,1),...,(n,n)]):
data Square = Square
Int -- square size
[Int] -- symbols in row-major order
deriving (Show)
Now, the monadic action to generate latin squares will look like this:
type M = StateT S []
latin :: M Square
latin = do
n <- gets size
-- for each position (r,c), get a valid symbol `s`
cells <- forM (pairs n) (\(r,c) -> getS r c)
return $ Square n cells
pairs :: Int -> [(Int,Int)]
pairs n = -- same as [(x,y) | x <- [1..n], y <- [1..n]]
(,) <$> [1..n] <*> [1..n]
The worker function getS picks an s so that (r,s) and (c,s) are available in the respective urns, removing those pairs from the urns as a side effect. Note that getS is written non-deterministically, so it'll try every possible way of picking an s and associated balls from the urns:
getS :: Int -> Int -> M Int
getS r c = do
-- try each possible `s` in the row
s <- pickSFromRow r
-- can we put `s` in this column?
pickCS c s
-- if so, `s` is good
return s
Most of the work is done by the helpers pickSFromRow and pickCS. The first, pickSFromRow picks an s from the given row:
pickSFromRow :: Int -> M Int
pickSFromRow r = do
balls <- gets rs
-- "lift" here non-determinstically picks balls
((r',s), rest) <- lift $ choices balls
-- only consider balls in matching row
guard $ r == r'
-- remove the ball
modify (\st -> st { rs = rest })
-- return the candidate "s"
return s
It uses a choices helper which generates every possible way of pulling one element out of a list:
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
where f a (x:b) = (x, a++b)
f _ _ = error "choices: internal error"
The second, pickCS checks if (c,s) is available in the cs urn, and removes it if it is:
pickCS :: Int -> Int -> M ()
pickCS c s = do
balls <- gets cs
-- only continue if the required ball is available
guard $ (c,s) `elem` balls
-- remove the ball
modify (\st -> st { cs = delete (c,s) balls })
With an appropriate driver for our monad:
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n p p)
where p = pairs n
this can generate all 12 Latin square of size 3:
λ> runM 3 latin
[Square 3 [1,2,3,2,3,1,3,1,2],Square 3 [1,2,3,3,1,2,2,3,1],...]
or the 576 Latin squares of size 4:
λ> length $ runM 4 latin
576
Compiled with -O2, it's fast enough to enumerate all 161280 squares of size 5 in a couple seconds:
main :: IO ()
main = print $ length $ runM 5 latin
The list-based urn representation above isn't very efficient. On the other hand, because the lengths of the lists are pretty small, there's not that much to be gained by finding more efficient representations.
Nonetheless, here's complete code that uses efficient Map/Set representations tailored to the way the rs and cs urns are used. Compiled with -O2, it runs in constant space. For n=6, it can process about 100000 Latin squares per second, but that still means it'll need to run for a few hours to enumerate all 800 million of them.
{-# OPTIONS_GHC -Wall #-}
module LatinAll where
import Control.Monad.State
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!))
import qualified Data.Map as Map
data S = S
{ size :: Int
, rs :: Map Int [Int]
, cs :: Set (Int, Int) }
data Square = Square
Int -- square size
[Int] -- symbols in row-major order
deriving (Show)
type M = StateT S []
-- Get Latin squares
latin :: M Square
latin = do
n <- gets size
cells <- forM (pairs n) (\(r,c) -> getS r c)
return $ Square n cells
-- All locations in row-major order [(1,1),(1,2)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [1..n] <*> [1..n]
-- Get a valid `s` for position `(r,c)`.
getS :: Int -> Int -> M Int
getS r c = do
s <- pickSFromRow r
pickCS c s
return s
-- Get an available `s` in row `r` from the `rs` urn.
pickSFromRow :: Int -> M Int
pickSFromRow r = do
urn <- gets rs
(s, rest) <- lift $ choices (urn ! r)
modify (\st -> st { rs = Map.insert r rest urn })
return s
-- Remove `(c,s)` from the `cs` urn.
pickCS :: Int -> Int -> M ()
pickCS c s = do
balls <- gets cs
guard $ (c,s) `Set.member` balls
modify (\st -> st { cs = Set.delete (c,s) balls })
-- Return all ways of removing one element from list.
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
where f a (x:b) = (x, a++b)
f _ _ = error "choices: internal error"
-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
where rs0 = Map.fromAscList $ zip [1..n] (repeat [1..n])
cs0 = Set.fromAscList $ pairs n
main :: IO ()
main = do
print $ runM 3 latin
print $ length (runM 4 latin)
print $ length (runM 5 latin)
Somewhat remarkably, modifying the program to produce only reduced Latin squares (i.e., with symbols [1..n] in order in both the first row and the first column) requires changing only two functions:
-- All locations in row-major order, skipping first row and column
-- i.e., [(2,2),(2,3)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [2..n] <*> [2..n]
-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
where -- skip balls [(1,1)..(n,n)] for first row
rs0 = Map.fromAscList $ map (\r -> (r, skip r)) [2..n]
-- skip balls [(1,1)..(n,n)] for first column
cs0 = Set.fromAscList $ [(c,s) | c <- [2..n], s <- skip c]
skip i = [1..(i-1)]++[(i+1)..n]
With these modifications, the resulting Square will include symbols in row-major order but skipping the first row and column. For example:
λ> runM 3 latin
[Square 3 [3,1,1,2]]
means:
1 2 3 fill in question marks 1 2 3
2 ? ? =====================> 2 3 1
3 ? ? in row-major order 3 1 2
This is fast enough to enumerate all 16,942,080 reduced Latin squares of size 7 in a few minutes:
$ stack ghc -- -O2 -main-is LatinReduced LatinReduced.hs && time ./LatinReduced
[1 of 1] Compiling LatinReduced ( LatinReduced.hs, LatinReduced.o )
Linking LatinReduced ...
16942080
real 3m9.342s
user 3m8.494s
sys 0m0.848s
Making tree like data structures is relatively easy in Haskell. However, what if I want a structure like the following:
A (root)
/ \
B C
/ \ / \
D E F
So if I traverse down the structure through B to update E, the returned new updated structure also has E updated if I traverse through C.
Could someone give me some hints about how to achieve this? You can assume there are no loops.
I would flatten the data structure to an array, and operate on this instead:
import Data.Array
type Tree = Array Int -- Bounds should start at (1) and go to sum [1..n]
data TreeTraverse = TLeft TreeTraverse | TRight TreeTraverse | TStop
Given some traverse directions (left, right, stop), it's easy to see that if we go left, we simply add the current level to our position, and if we go right, we also add the current position plus one:
getPosition :: TreeTraverse -> Int
getPosition = getPosition' 1 1
where
getPosition' level pos (TLeft ts) = getPosition' (level+1) (pos+level) ts
getPosition' level pos (TRight ts) = getPosition' (level+1) (pos+level + 1) ts
getPosition' _ pos (TStop) = pos
In your case, you want to traverse either ABE or ACE:
traverseABE = TLeft $ TRight TStop
traverseACE = TRight $ TLeft TStop
Since we already now how to get the position of your element, and Data.Array provides some functions to set/get specific elements, we can use the following functions to get/set tree values:
getElem :: TreeTraverse -> Tree a -> a
getElem tt t = t ! getPosition tt
setElem :: TreeTraverse -> Tree a -> a -> Tree a
setElem tt t x = t // [(getPosition tt, x)]
To complete the code, lets use your example:
example = "ABCDEF"
exampleTree :: Tree Char
exampleTree = listArray (1, length example) example
And put everything to action:
main :: IO ()
main = do
putStrLn $ "Traversing from A -> B -> E: " ++ [getElem traverseABE exampleTree]
putStrLn $ "Traversing from A -> C -> E: " ++ [getElem traverseACE exampleTree]
putStrLn $ "exampleTree: " ++ show exampleTree ++ "\n"
putStrLn $ "Setting element from A -> B -> E to 'X', "
let newTree = setElem traverseABE exampleTree 'X'
putStrLn $ "but show via A -> C -> E: " ++ [getElem traverseACE newTree]
putStrLn $ "newTree: " ++ show newTree ++ "\n"
Note that this is most-likely not the best way to do this, but the first thing that I had in mind.
Once you've established identity, it can be done.
But first you must establish identity.
In many languages, values can be distinct from each other, but equal. In Python, for example:
>>> a = [1]
>>> b = [1]
>>> a == b
True
>>> a is b
False
You want to update E in one branch of the tree, and also update all other elements for which that element is E. But Haskell is referentially transparent: it has no notion of things being the same object; only equality, and even that is not applicable for every object.
One way you could do this is equality. Say this was your tree:
__A__
/ \
B C
/ \ / \
1 2 2 3
Then we could go through the tree and update all the 2s to, say, four. But this isn't exactly what you want in some cases.
In Haskell, if you want to update one thing in multiple places, you'll have to be explicit about what is and isn't the same thing. Another way you could deal with this is to tag each different value with a unique integer, and use that integer to determine identity:
____________A___________
/ \
B C
/ \ / \
(id=1)"foo" (id=2)"bar" (id=2)"bar" (id=3)"baz"
Then we could update all values with an identity of 2. Accidental collisions cannot be a problem, as there can be no collisions except those that are intentional.
This is essentially what STRef and IORef do, except they hoist the actual value into the monad's state and hide the identities from you. The only downside of using these is you'll need to make much of your code monadic, but you're probably not going to get away from that easily whatever you do. (Modifying values rather than replacing them is an inherently effectful thing to do.)
The structure you gave was not specified in much detail so it's impossible to tailor an example to your use case, but here's a simple example using the ST monad and a Tree:
import Control.Monad
import Control.Monad.ST
import Data.Tree
import Data.Traversable (traverse)
import Data.STRef
createInitialTree :: ST s (Tree (STRef s String))
createInitialTree = do
[a, b, c, d, e, f] <- mapM newSTRef ["A", "B", "C", "D", "E", "F"]
return $ Node a [ Node b [Node d [], Node e []]
, Node c [Node e [], Node f []]
]
dereferenceTree :: Tree (STRef s a) -> ST s (Tree a)
dereferenceTree = traverse readSTRef
test :: ST s (Tree String, Tree String)
test = do
tree <- createInitialTree
before <- dereferenceTree tree
let leftE = subForest (subForest tree !! 0) !! 1
writeSTRef (rootLabel leftE) "new" -- look ma, single update!
after <- dereferenceTree tree
return (before, after)
main = do
let (before, after) = runST test
putStrLn $ drawTree before
putStrLn $ drawTree after
Observe that although we only explicitly modified the value of the left E value, it changed on the right side, too, as desired.
I should note that these are not the only ways. There are probably many other solutions to this same problem, but they all require you to define identity sensibly. Only once that has been done can one begin the next step.
I'm trying to place a bunch of words into a hash table based on length. The words are stored in
data Entry = Entry {word :: String, length :: Int} deriving Show
Now, I've got all the words stored in "entries", which is a list of Entry. Then, my hash table is defined as follows:
type Hash = [Run]
type Run = [Entry]
Now I'm trying to figure out how to get the entries into the hash table. The following is my current attempt
maxL = maximum [length e | e <- entries]
runs = [r | r <- [e | e <- entries, length e == i]] where i = [1..maxL]
Compiler's obviously telling me that Int can't be compared to [Int], but I don't know how to say
e | e <- entries, e has length i
Any help is much appreciated!
Cheers
Your code is almost OK:
maxL = maximum [length e | e <- entries]
runs = [r | r <- [e | e <- entries, length e == i]] where i = [1..maxL]
except that where doesn't work that way. It's not a synonym for foreach; but for let:
runs = let i = [1..maxL]
in [r | r <- [e | e <- entries, length e == i]]
So, length e is an integer, but i is [1..maxL] which is a list of integers. You intended for i to take on the values in [1..maxL] one-by-one, and that's done by <- binding in list comprehension:
runs = [ [r | r <- [e | e <- entries, length e == i]] | i <- [1..maxL]]
Now, [r | r <- xs] is the same as just xs, so it becomes
runs = [ [e | e <- entries, length e == i] | i <- [1..maxL]]
With "standard" functions, this is written as
import Data.List (sortBy)
import Data.Ord (comparing)
runs = group $ sortBy (comparing length) entries
It is also better algorithmically. Although, it won't have empty runs for non-existent lengths, so the two aren't strictly equivalent. But that can be fixed with another O(n) pass over the results, with
-- mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
runs' = snd $ mapAccumL
(\a# ~((k,g):t) i-> if null a || i<k then (a,[]) else (t,g))
[ (length $ head g, g) | g<- runs]
[ 1..maxL]
You're looking for the groupBy function from Data.List. You have a list of strings, which you want to group by their lengths. The groupBy function has type (a -> a -> Bool) -> [a] -> [[a]]. The second parameter is your input list and the first is a function that you need to write, which should take two strings and compare their lengths. It will return a list of lists of strings, where each sub-list will be containing strings of equal length.
By the way, if you want to write this succinctly, look at the on combinator from Data.Function.
How can I create a function which lazily makes permutations for the chars '_' and '*' like this:
For example:
Main> function 3
["___","*__","_*_","__*","**_","_**","*_*","***"]
First element is made only from _, the next 3 are permutations that lists: *__, the second 3 are permutations that lists **_, and the last element contains only *.
How can I do that?
Here's another "correct order" version:
function :: Int -> [String]
function c = concatMap helper $ zip (reverse [0..c]) [0..c]
helper :: (Int, Int) -> [String]
helper (c, 0) = [replicate c '_']
helper (0, c) = [replicate c '*']
helper (cUnderscores, cAsterisks) = map ('_' :) (helper (cUnderscores - 1, cAsterisks))
++ map ('*' :) (helper (cUnderscores, cAsterisks - 1))
You might want to look at replicateM.
let k = ["_", "*"]
let p = [ a ++ b ++ c | a <- k, b <- k, c <- k ]
The “correct order” version:
import Data.List
function k = concatMap (nub . permutations . pat) [0..k]
where pat x = replicate x '*' ++ replicate (k-x) '_'
I don’t know how to step from one permutation to another in constant time, though.