How to reverse a graph in haskell? - haskell

for an exercise I need to reverse a graph (reverse all edges), but I don't get anywhere.
So I need some help.
I am aware you might not want to solve the exercise for me, so that's not what I am asking for. I just need to get some advice...
So to get to it:
data Graph a = G
{ nodes :: [a]
, successors :: a -> [a] }
reverseGraph :: Eq a => Graph a -> Graph a
A graph has to parameters: a list of nodes and a function that defines the successors. This function has the type:
a -> [a]
for example:
graph1 :: Graph Int
graph1 = G [1..6] $ \case 1 -> [2,3]
2 -> []
3 -> [1,4,6]
4 -> [1]
5 -> [3,5]
6 -> [2,4,5]
the reversed graph would be:
reverseGraph graph1 ~>
2 -> [1,6]
3 -> [1,5]
1 -> [3,4]
4 -> [3,6]
6 -> [3]
5 -> [5,6]
I get that I need to check for each node in the input graph the successors and add for each the input node to the new successor list of the output node.
But i just don't get how to do this in Haskell.
Any help is appreciated!
Here is my solution for anyone who may attempt something similar:
reverseGraph :: Eq a => Graph a -> Graph a
reverseGraph (G nodes sucs) = (G nodes sucs') where
sucs' a = getVert a nodes sucs
--Makes a list of all occurrences of v in the succeccor list.
getVert :: Eq a => a -> [a] -> (a-> [a]) -> [a]
getVert v [] succs = []
getVert v (n:ns) succs = if v `elem` succs n then [n]++getVert v ns succs else getVert v ns succs

Here's a hint. Let's consider the reverse of G vertices edges.
That will be of the form G vertices' edges'.
It's obvious that vertices' = vertices.
What about edges'? Well, for any value v, edges' v must return
"the list of all the w in vertices such that edge w contains v as an element"
You can translate the above English description into Haskell code using a list comprehension. You can use x `elem` list to check whether x is an element of list.

Related

How can I use filter to find neighboring words in a text?

As pretext: I have, prior to this, written a function that counts the amount of times a pair of words occur in a text, this function calculates every single pair of words throughout the text.
Like so:
pairCounter = map (\x -> (head x,length x)). groupTuples . sort
This function returns: [((String, String), Int)] The first/second string being word1/2 in the pair, and the Int is how many times this can be found, or the "tally" of the pair if you will.
What I now would like to do is create a function that only returns the "neighbors" to any given word. For instance:
neighbours [(("red","car"),2),(("house","red"),1)] "red"
should return [("car",2),("house",1)] or some reordering of this list.
So basically; we have established all pairs of any given word, but now I want to single out only the neighbors to this word and a tally of its frequency.
So far, I have thought about using filters in this way:
filter (\(x, y) -> x /= c || y /= c)
--^(I have no idea if this is syntax correct but it is just to give myself an idea where to start)
However I find it hard to come up with a way to use filters and also include the tally of my neighbors, my Int argument that is.
One very idiomatic way would be via a list comprehension:
neighbours :: Eq a => [((a, a), b)] -> a -> [(a, b)]
neighbours items query =
[ (neighbor, count)
| ((s1, s2), count) <- items
, (self, neighbor) <- [(s1, s2), (s2, s1)]
, self == query
]
Actually, I'd probably put the arguments in the other order to match conventions used in existing libraries and shorten the names so that it comfortably fits on one line:
neighbours :: Eq a => a -> [((a, a), b)] -> [(a, b)]
neighbours x xs = [(x4, n) | ((x1, x2), n) <- xs, (x3, x4) <- [(x1, x2), (x2, x1)], x3 == x]
I suspect that the part where you don't care about order will come up in other parts of your code, and so additionally I would consider splitting out a part that symmetrizes. This will also be helpful if, later, you decide that pairs that occur in both orders should be normalized and their counts summed or some such thing, because you will only have to change one location to propagate that update to all consumers.
-- (s)ource, (t)arget, (u)ndirected edge, (w)eight, (w)eighted edge(s)
undirected :: [((a, a), b)] -> [((a, a), b)]
undirected ws = [(u, w) | ((s, t), w) <- ws, u <- [(s, t), (t, s)]]
neighbours :: Eq a => a -> [((a, a), b)] -> [(a, b)]
neighbours x xs = [(t, w) | ((s, t), w) <- undirected xs, s == x]
Alternately, you might decide to make the graph undirected from the very beginning.
import qualified Data.Map as M
-- export UPair the type but not UPair the constructor
data UPair a = UPair a a
deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)
-- this is strict. can also make a lazy variant
upair :: Ord a => a -> a -> UPair a
upair a a' = if a < a' then UPair a a' else UPair a' a
pairCounter :: [a] -> M.Map (UPair a) Int
pairCounter as = M.fromListWith (+) $ zipWith (\a a' -> (upair a a', 1)) as (tail as)
For a given word c you thus should retain the items for which the first String, or the second String are equal to c. We should use ((s1, s2), v) as pattern since the outer 2-tuple has as elements a 2-tuple of Strings as first item, and an Int as second item.
We can work with concatMap :: Foldable t => (a -> [b]) -> t a -> [b] and work with a function that will return [(s2, v)] if s1 matches, [(s1, v)] if s2 matches, and the empty list if none of the two elements was a match:
We thus filter with:
neighbors :: (Foldable f, Eq a) -> f ((a, a), b) -> a -> [(a, b)]
neighbors items query = concatMap f items
where f ((s1, s2), v)
| query == s1 = [(s2, v)]
| query == s2 = [(s1, v)]
| otherwise = []

Greaters function define

I would like to define a greaters function, which selects from a list items that are larger than the one before it.
For instance:
greaters [1,3,2,4,3,4,5] == [3,4,4,5]
greaters [5,10,6,11,7,12] == [10,11,12]
The definition I came up with is this :
greaters :: Ord a => [a] -> [a]
Things I tried so far:
greaters (x:xs) = group [ d | d <- xs, x < xs ]
Any tips?
We can derive a foldr-based solution by a series of re-writes starting from the hand-rolled recursive solution in the accepted answer:
greaters :: Ord a => [a] -> [a]
greaters [] = []
greaters (x:xs) = go x xs -- let's re-write this clause
where
go _ [] = []
go last (act:xs)
| last < act = act : go act xs
| otherwise = go act xs
greaters (x:xs) = go xs x -- swap the arguments
where
go [] _ = []
go (act:xs) last
| last < act = act : go xs act
| otherwise = go xs act
greaters (x:xs) = foldr g z xs x -- go ==> foldr g z
where
foldr g z [] _ = []
foldr g z (act:xs) last
| last < act = act : foldr g z xs act
| otherwise = foldr g z xs act
greaters (x:xs) = foldr g z xs x
where -- simplify according to
z _ = [] -- foldr's definition
g act (foldr g z xs) last
| last < act = act : foldr g z xs act
| otherwise = foldr g z xs act
Thus, with one last re-write of foldr g z xs ==> r,
greaters (x:xs) = foldr g z xs x
where
z = const []
g act r last
| last < act = act : r act
| otherwise = r act
The extra parameter serves as a state being passed forward as we go along the input list, the state being the previous element; thus avoiding the construction by zip of the shifted-pairs list serving the same purpose.
I would start from here:
greaters :: Ord a => [a] -> [a]
greaters [] = []
greaters (x:xs) = greatersImpl x xs
where
greatersImpl last [] = <fill this out>
greatersImpl last (x:xs) = <fill this out>
The following functions are everything you’d need for one possible solution :)
zip :: [a] -> [b] -> [(a, b)]
drop 1 :: [a] -> [a]
filter :: (a -> Bool) -> [a] -> [a]
(<) :: Ord a => a -> a -> Bool
uncurry :: (a -> b -> c) -> (a, b) -> c
map :: (a -> b) -> [a] -> [b]
snd :: (a, b) -> b
Note: drop 1 can be used when you’d prefer a “safe” version of tail.
If you like over-generalization like me, you can use the witherable package.
{-# language ScopedTypeVariables #-}
import Control.Monad.State.Lazy
import Data.Witherable
{-
class (Traversable t, Filterable t) => Witherable t where
-- `wither` is an effectful version of mapMaybe.
wither :: Applicative f => (a -> f (Maybe b)) -> t a -> f (t b)
-}
greaters
:: forall t a. (Ord a, Witherable t)
=> t a -> t a
greaters xs = evalState (wither go xs) Nothing
where
go :: a -> State (Maybe a) (Maybe a)
go curr = do
st <- get
put (Just curr)
pure $ case st of
Nothing -> Nothing
Just prev ->
if curr > prev
then Just curr
else Nothing
The state is the previous element, if there is one. Everything is about as lazy as it can be. In particular:
If the container is a Haskell list, then it can be an infinite one and everything will still work. The beginning of the list can be produced without withering the rest.
If the container extends infinitely to the left (e.g., an infinite snoc list), then everything will still work. How can that be? We only need to know what was in the previous element to work out the state for the current element.
"Roll your own recursive function" is certainly an option here, but it can also be accomplished with a fold. filter can't do it because we need some sort of state being passed, but fold can nicely accumulate the result while keeping that state at the same time.
Of course the key idea is that we keep track of last element add the next one to the result set if it's greater than the last one.
greaters :: [Int] -> [Int]
greaters [] = []
greaters (h:t) = reverse . snd $ foldl (\(a, r) x -> (x, if x > a then x:r else r)) (h, []) t
I'd really love to eta-reduce it but since we're dropping the first element and seeding the accumulator with it it kinda becomes awkward with the empty list; still, this is effectively an one-liner.
So i have come up with a foldr solution. It should be similar to what #Will Ness has demonstrated but not quite i suppose as we don't need a separate empty list check in this one.
The thing is, while folding we need to encapsulate the previous element and also the state (the result) in a function type. So in the go helper function f is the state (the result) c is the current element of interest and p is the previous one (next since we are folding right). While folding from right to left we are nesting up these functions only to run it by applyying the head of the input list to it.
go :: Ord a => a -> (a -> [a]) -> (a -> [a])
go c f = \p -> let r = f c
in if c > p then c:r else r
greaters :: Ord a => [a] -> [a]
greaters = foldr go (const []) <*> head
*Main> greaters [1,3,2,4,3,4,5]
[3,4,4,5]
*Main> greaters [5,10,6,11,7,12]
[10,11,12]
*Main> greaters [651,151,1651,21,651,1231,4,1,16,135,87]
[1651,651,1231,16,135]
*Main> greaters [1]
[]
*Main> greaters []
[]
As per rightful comments of #Will Ness here is a modified slightly more general code which hopefully doesn't break suddenly when the comparison changes. Note that const [] :: b -> [a] is the initial function and [] is the terminator applied to the result of foldr. We don't need Maybe since [] can easily do the job of Nothing here.
gs :: Ord a => [a] -> [a]
gs xs = foldr go (const []) xs $ []
where
go :: Ord a => a -> ([a] -> [a]) -> ([a] -> [a])
go c f = \ps -> let r = f [c]
in case ps of
[] -> r
[p] -> if c > p then c:r else r

Haskell and comprehension lists

I'm writing a function that compares two vectors in haskell using comprehension lists. The thing is that I want to add booleans to my final list, but Haskell interprets this code as if x == y, add the element to the list (that's how comprehensive lists works I know). What I want is a list with booleans if the coordinates I'm comparing are true or false.
Is it possible to do this with comprehension lists?
igualdad :: Vector -> Vector -> [Bool]
igualdad v1 v2 = [ x == y | x <- xs, y <- ys]
where xs = vectorToFloatList v1
ys = vectorToFloatList v2
PD: I'm going to use foldr (&&) True with the list that returns igualdad, in order to get the final result that I want.
Thanks.
What I want is a list with booleans if the coordinates I'm comparing are True or False. Is it possible to do this with comprehension lists?
You get such a list. For two Vectors v and w with lengths m and n respectively, you will get a list with m×n elements, such that the item vi and wj will be compared in the result list in the element with index i×m + j.
If you hwever want a list of length min(m, n), such that the item at index i checks if vi and wi are the same, then we can make use of zip :: [a] -> [b] -> [(a, b)]:
igualdad :: Vector -> Vector -> [Bool]
igualdad v1 v2 = [ x == y | (x, y) <- zip (vectorToFloatList xs) (vectorToFloatList ys)]
or with zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] and on :: (b -> b -> c) -> (a -> b) -> a -> a -> c:
import Data.Function(on)
igualdad :: Vector -> Vector -> [Bool]
igualdad = on (zipWith (==)) vectorToFloatList
or we can make use of the ParallelListComp extension [ghc-doc] and run this with:
{-# LANGUAGE ParallelListComp #-}
igualdad :: Vector -> Vector -> [Bool]
igualdad v1 v2 = [ x == y | x <- vectorToFloatList xs | y <- vectorToFloatList ys]
PD: I'm going to use foldr (&&) True with the list that returns igualdad.
There exists a function for that already: that is and :: Foldable f => f Bool -> Bool. If you however want to check if all the items are the same, you can just use all :: Foldable f => (a -> Bool) -> f a -> Bool here:
import Data.Function(on)
sameVec :: Vector -> Vector -> Bool
sameVec = on (all (uncurry (==) .) . zip) vectorToFloatList

How to know in Haskell in what row and column of a table ([[a]]) you are

I want to make a sudoku solver in Haskell (as an exercise). My idea is:
I have t :: [[Int]] representing a 9x9 grid so that it contains 0 in an empty field and 1-9 in a solved field.
A function solve :: [[Int]] -> [[Int]] returns the solved sudoku.
Here is a rough sketch of it (i'd like to point out i'm a beginner, i know it is not the most optimal code):
solve :: [[Int]] -> [[Int]]
solve t
| null (filter (elem 0) t) = t
| t /= beSmart t = solve (beSmart t)
| otherwise = guess t
The function beSmart :: [[Int]] -> [[Int]] tries to solve it by applying some solving algorithms, but if methodical approach fails (beSmart returns the unchanged sudoku table in that case) it should try to guess some numbers (and i'll think of that function later). In order to fill in an empty field, i have to find it first. And here's the problem:
beSmart :: [[Int]] -> [[Int]]
beSmart t = map f t
where f row
| elem 0 row = map unsolvedRow row
| otherwise = row
where unsolvedRow a
| a == 0 = tryToDo t r c --?!?!?!?! skip
| otherwise = a
The function tryToDo :: [[Int]]] -> Int -> Int - > Int needs the row and column of the field i'm trying to change, but i have no idea how to get that information. How do i get from map what element of the list i am in at the moment? Or is there a better way to move around in the table? I come from iterative and procedural programing and i understand that perhaps my approach to the problem is wrong when it comes to functional programing.
I know this is not really an answer to your question, but I would argue, that usually you would want a different representation (one that keeps a more detailed view of what you know about the sudoku puzzle, in your attempted solution you can only distinguish a solved cell from a cell that is free to assume any value). Sudoku is a classical instance of CSP. Where modern approaches offer many fairly general smart propagation rules, such as unit propagation (blocking a digit in neighboring cells once used somewhere), but also many other, see AC-3 for further details. Other related topics include SAT/SMT and you might find the algorithm DPLL also interesting. In the heart of most solvers there usually is some kind of a search engine to deal with non-determinism (not every instance must have a single solution that is directly derivable from the initial configuration of the instance by application of inference rules). There are also techniques such as CDCL to direct the search.
To address the question in the title, to know where you are, its probably best if you abstract the traversal of your table so that each step has access to the coordinates, you can for example zip a list of rows with [0..] (zip [0..] rows) to number the rows, when you then map a function over the zipped lists, you will have access to pairs (index, row), the same applies to columns. Just a sketch of the idea:
mapTable :: (Int -> Int -> a -> b) -> [[a]] -> [[b]]
mapTable f rows = map (\(r, rs) -> mapRow (f r) rs) $ zip [0..] rows
mapRow :: (Int -> a -> b) -> [a] -> [b]
mapRow f cols = map (uncurry f) $ zip [0..] cols
or use fold to turn your table into something else (for example to search for a unit cell):
foldrTable :: (Int -> Int -> a -> b -> b) -> b -> [[a]] -> b
foldrTable f z rows = foldr (\(r, rs) b -> foldrRow (f r) b rs) z $ zip [0..] rows
foldrRow :: (Int -> a -> b -> b) -> b -> [a] -> b
foldrRow f z cols = foldr (uncurry f) z $ zip [0..] cols
to find which cell is unital:
foldrTable
(\x y v acc -> if length v == 1 then Just (x, y) else acc)
Nothing
[[[1..9],[1..9],[1..9]],[[1..9],[1..9],[1..9]],[[1..9],[1],[1..9]]]
by using Monoid you can refactor it:
import Data.Monoid
foldrTable' :: Monoid b => (Int -> Int -> a -> b) -> [[a]] -> b
foldrTable' f rows = foldrTable (\r c a b -> b <> f r c a) mempty rows
unit :: Int -> Int -> [a] -> Maybe (Int, Int)
unit x y c | length c == 1 = Just (x, y)
| otherwise = Nothing
firstUnit :: [[[a]]] -> Maybe (Int, Int)
firstUnit = getFirst . foldrTable' (\r c v -> First $ unit r c v)
so now you would do
firstUnit [[[1..9],[1..9],[1..9]],[[1,2],[3,4],[5]]]
to obtain
Just (1, 2)
correctly determining that the first unit cell is at position 1,2 in the table.
[[Int]] is a good type for a sodoku. But map does not give any info regarding the place it is in. This is one of the ideas behind map.
You could zip together the index with the value. But a better idea would be to pass the whole [[Int]] and the indexes to to the function. So its type would become:
f :: [[Int]] -> Int -> Int -> [[Int]]
inside the function you can now access the current element by
t !! x !! y
Already did this a while ago as a learning example. It is definitely not the nicest solution, but it worked for me.
import Data.List
import Data.Maybe
import Data.Char
sodoku="\
\-9-----1-\
\8-4-2-3-7\
\-6-9-7-2-\
\--5-3-1--\
\-7-5-1-3-\
\--3-9-8--\
\-2-8-5-6-\
\1-7-6-4-9\
\-3-----8-"
sodoku2="\
\----13---\
\7-5------\
\1----547-\
\--418----\
\951-67843\
\-2---4--1\
\-6235-9-7\
\--7-98--4\
\89----1-5"
data Position = Position (Int, Int) deriving (Show)
data Sodoku = Sodoku [Int]
insertAtN :: Int -> a -> [a] -> [a]
insertAtN n y xs = intercalate [y] . groups n $ xs
where
groups n xs = takeWhile (not.null) . unfoldr (Just . splitAt n) $ xs
instance Show Sodoku where
show (Sodoku s) = (insertAtN 9 '\n' $ map intToDigit s) ++ "\n"
convertDigit :: Char -> Int
convertDigit x = case x of
'-' -> 0
x -> if digit>=1 && digit<=9 then
digit
else
0
where digit=digitToInt x
convertSodoku :: String -> Sodoku
convertSodoku x = Sodoku $ map convertDigit x
adjacentFields :: Position -> [Position]
adjacentFields (Position (x,y)) =
[Position (i,y) | i<-[0..8]] ++
[Position (x,j) | j<-[0..8]] ++
[Position (u+i,v+j) | i<-[0..2], j<-[0..2]]
where
u=3*(x `div` 3)
v=3*(y `div` 3)
positionToField :: Position -> Int
positionToField (Position (x,y)) = x+y*9
fieldToPosition :: Int -> Position
fieldToPosition x = Position (x `mod` 9, x `div` 9)
getDigit :: Sodoku -> Position -> Int
getDigit (Sodoku x) pos = x !! (positionToField pos )
getAdjacentDigits :: Sodoku -> Position -> [Int]
getAdjacentDigits s p = nub digitList
where
digitList=filter (\x->x/=0) $ map (getDigit s) (adjacentFields p)
getFreePositions :: Sodoku -> [Position]
getFreePositions (Sodoku x) = map fieldToPosition $ elemIndices 0 x
isSolved :: Sodoku -> Bool
isSolved s = (length $ getFreePositions s)==0
isDeadEnd :: Sodoku -> Bool
isDeadEnd s = any (\x->x==0) $ map length $ map (getValidDigits s)$ getFreePositions s
setDigit :: Sodoku -> Position -> Int -> Sodoku
setDigit (Sodoku x) pos digit = Sodoku $ h ++ [digit] ++ t
where
field=positionToField pos
h=fst $ splitAt field x
t=tail$ snd $ splitAt field x
getValidDigits :: Sodoku -> Position -> [Int]
getValidDigits s p = [1..9] \\ (getAdjacentDigits s p)
-- Select numbers with few possible choices first to increase execution time
sortImpl :: (Position, [Int]) -> (Position, [Int]) -> Ordering
sortImpl (_, i1) (_, i2)
| length(i1)<length(i2) = LT
| length(i1)>length(i2) = GT
| length(i1)==length(i2) = EQ
selectMoves :: Sodoku -> Maybe (Position, [Int])
selectMoves s
| length(posDigitList)>0 = Just (head posDigitList)
| otherwise = Nothing
where
posDigitList=sortBy sortImpl $ zip freePos validDigits
validDigits=map (getValidDigits s) freePos
freePos=getFreePositions s
createMoves :: Sodoku -> [Sodoku]
createMoves s=
case selectMoves s of
Nothing -> []
(Just (pos, digits)) -> [setDigit s pos d|d<-digits]
solveStep :: Sodoku -> [Sodoku]
solveStep s
| (isSolved s) = [s]
| (isDeadEnd s )==True = []
| otherwise = createMoves s
solve :: Sodoku -> [Sodoku]
solve s
| (isSolved s) = [s]
| (isDeadEnd s)==True = []
| otherwise=concat $ map solve (solveStep s)
s=convertSodoku sodoku2
readSodoku :: String -> Sodoku
readSodoku x = Sodoku []

Haskell - Counting how many times each distinct element in a list occurs

I'm new to Haskell and am just trying to write a list comprehension to calculate the frequency of each distinct value in a list, but I'm having trouble with the last part..
So far i have this:
frequency :: Eq a => [a] -> [(Int,a)]
frequency list = [(count y list,y) | y <- rmdups ]
Something is wrong with the last part involving rmdups.
The count function takes a character and then a list of characters and tells you how often that character occurs, the code is as follows..
count :: Eq a => a -> [a] -> Int
count x [] = 0
count x (y:ys) | x==y = 1+(count x ys)
| otherwise = count x ys
Thank-you in advance.
You could also use a associative array / finite map to store the associations from list elements to their count while you compute the frequencies:
import Data.Map (fromListWith, toList)
frequency :: (Ord a) => [a] -> [(a, Int)]
frequency xs = toList (fromListWith (+) [(x, 1) | x <- xs])
Example usage:
> frequency "hello world"
[(' ',1),('d',1),('e',1),('h',1),('l',3),('o',2),('r',1),('w',1)]
See documentation of fromListWith and toList.
I had to use Ord in instead of Eq because of the use of sort
frequency :: Ord a => [a] -> [(Int,a)]
frequency list = map (\l -> (length l, head l)) (group (sort list))
As requested, here's a solution using Control.Arrow:
frequency :: Ord a => [a] -> [(Int,a)]
frequency = map (length &&& head) . group . sort
This is the same function as ThePestest's answer, except
λ f g l -> (f l, g l)
is replaced with
-- simplified type signature
(&&&) :: (a -> b) -> (a -> c) -> a -> (b, c)
from Control.Arrow. If you want to avoid the import,
liftA2 (,) :: Applicative f => f a -> f b -> f (a, b)
works as well (using the Applicative instance of (->) r)
Assuming rmdups has the type
rmdups :: Eq a => [a] -> [a]
Then you're missing a parameter for it.
frequency :: Eq a => [a] -> [(Int,a)]
frequency list = [(count y list,y) | y <- rmdups list]
But the error you're getting would be helpful with diagnosis.
Your rmdups function is just nub from Data.List.
Replacing rmdups with nub list worked for me like a charm.
Hahahaha there is an rmdups on pg. 86 of Programming in Haskell by Graham Hutton. It is perfect and recursive. It is also handy in a great many situations.
Here is my one line rmdups and it produces the same results as nubor Hutton's.
rmdups ls = [d|(z,d)<- zip [0..] ls,notElem d $ take z ls]
It can well be used to count distinct elements of a list.
dl = "minimum-maximum"
[ (d,sum [1|x<-dl,d == x]) | d<-rmdups dl]
[('m',6),('i',3),('n',1),('u',2),('-',1),('a',1),('x',1)]

Resources