Related
I'm trying to write an evaluation function for a language that I am working on in which non-determinism can be permitted within an if-block, called a selection block. What I'm trying to achieve is the ability to pick an if/selection statement from the block whose guard is true and evaluate it but it doesn't matter which one I pick.
From searching, I found an example that performs in a similar way to what I would like to achieve through modelling coinflips. Below is my adapation of it but I'm having issue in applying this logic to my problem.
import Control.Monad
data BranchType = Valid | Invalid deriving (Show)
data Branch = If (Bool, Integer) deriving (Show, Eq)
f Valid = [If (True, 1)]
f Invalid = [If (False, 0)]
pick = [Invalid, Invalid, Valid, Invalid, Valid]
experiment = do
b <- pick
r <- f b
guard $ fstB r
return r
s = take 1 experiment
fstB :: Branch -> Bool
fstB (If (cond, int)) = cond
main :: IO ()
main = putStrLn $ show $ s -- shows first branch which could be taken.
Below is my ADT and what I have been trying to make work:
data HStatement
= Eval HVal
| Print HVal
| Skip String
| Do HVal [HStatement]
| If (HVal, [HStatement])
| IfBlock [HStatement] -- made up of many If
| Select [HStatement] -- made up of many If
deriving (Eq, Read)
fstIf :: HStatement -> Bool
fstIf (If (cond, body)) = if hval2bool cond == True
then True
else False
h :: Env -> HStatement -> IOThrowsError ()
h env sb = do
x <- g env sb
guard $ fstIf x -- Couldn't match expected type ‘HStatement’ with actual type ‘[HStatement]’
-- after guard, take 1 x then evaluate
g :: Env -> HStatement -> IOThrowsError [HStatement]
g env (Select sb) = mapM (\x -> f env x) sb
f :: Env -> HStatement -> IOThrowsError HStatement
f env (If (cond, body)) = evalHVal env cond >>= \x -> case x of
Bool True -> return $ If (Bool True, body)
Bool False -> return $ If (Bool False, body)
The error I receive is the following : Couldn't match expected type ‘HStatement’ with actual type ‘[HStatement]’ at the guard line. I believe the reason as to why the first section of code was successful was because the values were being drawn from List but in the second case although they're being drawn from a list, they're being drawn from a [HStatement], not something that just represents a list...if that makes any sort of sense, I feel like I'm missing the vocabulary.
In essence then what should occur is given a selection block of n statement, a subset of these are produced whose guards are true and only one statement is taken from it.
The error message is pretty clear now that you have some types written down. g returns IOThrowsError [HStatement], so when you bind its result to x in h, you have an [HStatement]. You then call fstIf, which expects a single HStatement, not a list. You need to decide how to handle the multiple results from g.
If I have a datatype representing a subset of propositional logic such as
data Prop = Lit String
| Neg Prop
| And Prop Prop
| Or Prop Prop
Are there then easy ways to do generic transformations on [[Prop]]? E.g.
replace [[And a b, c]] with [[a, b, c]]
replace [[Or a b, c]] with [[a], [b], [c]], or
removing occurrences of sublists containing both Neg a and a, e.g. turning [[Neg a, x, a], [b]] into [[b]]
This feels like something close to what e.g. uniplate does, but “two levels up”.
I assume that your second rule is wrong, and you really meant to say either:
replace [[Or a b],[c]] with [[a],[b],[c]]
or else:
replace [[Or a b, c]] with [[a,c],[b,c]]
In other words, I assume you're trying to convert a Prop into an alternate representation [[Prop]] where the first-level list is an "or" and the second-level lists are "and"s, with all terms being either literals or Neg-literals. So, you're trying to imagine how you could apply a bunch of generic structural rules to make transformations like:
[[And a (Or b c)]]
[[a, Or b c]] -- apply "And" rule
[[a,b],[a,c]] -- apply some kind of "Or" distribution rule
If so, having generic transformations isn't much use. With your current datatype, you can only apply these transformations to top-level expressions anyway. For example, there's no obvious way to apply an Or rule here:
[[And a (And b (Or c d))]]
without first applying And rules a couple of times. If you change your data type to add, say, an L2 [[Prop]] constructor, so you can transform the above expression to:
[[And a (And b (L2 [[c],[d]]))]] -- apply "Or" rule
it's not clear what that buys you.
Ultimately, I don't think this is the right approach...
You have a perfectly adequate representation of your prepositional logic in the Prop data type; and you have a desired final representation. Instead of trying to translate your Prop representation into the final representation using piecemeal generic transformations, transform your Prop representation using standard recursive Prop-to-Prop transformations into a canonical Prop form, and do the translation as the final step.
Here, a reasonable canonical form is:
Or e1 (Or e2 (... (Or e3 e4)))
where each ek is of form:
And t1 (And t2 (... (And t3 t4)))
and each tk is either a Lit _ or a Neg (Lit _). Obviously, this canonical form can be translated pretty easily into the desired final representation as a [[Prop]].
I've included a possible solution below. I don't see that much opportunity for simplifying things via generic transformations. Most of the pattern matching seems to be doing non-trivial work.
Possible Solution
After a bit of preamble:
import Data.List
data Prop = Lit String
| Neg Prop
| And Prop Prop
| Or Prop Prop
deriving (Eq)
then one way to translate an arbitrary Prop into this canonical form is to first push all the Negs down to the literal terms:
pushNeg :: Prop -> Prop
pushNeg = push False
where
-- de Morgan's laws
push neg (And x y) = (if neg then Or else And) (push neg x) (push neg y)
push neg (Or x y) = (if neg then And else Or) (push neg x) (push neg y)
-- handle Neg and Lit
push neg (Neg y) = push (not neg) y
push neg (Lit l) = if neg then Neg (Lit l) else Lit l
then push all the Ands down on top of them. This is tougher to get right, but I think the following is correct, even though it does a bit of unnecessary work in some cases:
pushAnd :: Prop -> Prop
pushAnd (Or x y) = Or (pushAnd x) (pushAnd y)
pushAnd (And x y)
= let x' = pushAnd x
in case x' of
Or u v -> Or (pushAnd (And u y)) (pushAnd (And v y))
_ -> let y' = pushAnd y
in case y' of
Or u v -> Or (pushAnd (And x' u)) (pushAnd (And x' v))
_ -> And x' y'
pushAnd x = x
and then recursively make all the And and Or clauses right-associative:
rassoc :: Prop -> Prop
rassoc (Or (Or x y) z) = rassoc (Or x (Or y z))
rassoc (Or x z) = Or (rassoc x) (rassoc z)
rassoc (And (And x y) z) = rassoc (And x (And y z))
rassoc (And x z) = And x (rassoc z)
rassoc x = x
and finally convert the canonical form to its final representation (dropping the inconsistent clauses and duplicate terms while we're at it):
translate :: Prop -> [[Prop]]
translate = nub . map nub . filter consistent . doOr
where
doOr x = case x of
Or x y -> doAnd x : doOr y
x -> doAnd x : []
doAnd x = case x of
And x y -> x : doAnd y
x -> x : []
consistent lits =
let (falses, trues) = partition isNeg lits
falses' = map (\(Neg (Lit l)) -> l) falses
trues' = map (\ (Lit l) -> l) trues
in null (intersect falses' trues')
isNeg (Neg x) = True
isNeg _ = False
The whole pipeline is:
final :: Prop -> [[Prop]]
final = translate . rassoc . pushAnd . pushNeg
and here's some test code:
a = Lit "a"
b = Lit "b"
c = Lit "c"
d = Lit "d"
e = Lit "e"
-- Show instance, but only for `final` forms
instance Show Prop where
show (Lit x) = x
show (Neg (Lit x)) = '~':x
main :: IO ()
main = do print $ final (Neg a)
print $ final (Or a b)
print $ final (Or a a)
print $ final (And a b)
print $ final (And (Or (And (Or a b) c) d) e)
print $ final (And (Or (Or a b) c) (Neg (And a (Or b d))))
which outputs:
[[~a]]
[[a],[b]]
[[a]]
[[a,b]]
[[a,c,e],[b,c,e],[d,e]]
[[a,~b,~d],[b,~a],[c,~a],[c,~b,~d]]
There's still some opportunity for further simplification, as:
final (And a (Or a b))
gives final form [[a],[a,b]] instead of just [[a]].
Apologies for my poor wording of the question. I've tried searching for an answer but not knowing what to search is making it very difficult to find one.
Here is a simple function which calculates the area of a triangle.
triangleArea :: Float -> Float -> Float -> Float
triangleArea a b c
| (a + b) <= c = error "Not a triangle!"
| (a + c) <= b = error "Not a triangle!"
| (b + c) <= a = error "Not a triangle!"
| otherwise = sqrt (s * (s - a) * (s - b) * (s - c))
where s = (a + b + c) / 2
Three lines of the function have been taken up for the purposes of error checking. I was wondering if these three lines could be condensed into one generic line.
I was wondering if something similar to the following would be possible
(arg1 + arg2) == arg3
where Haskell knows to check each possible combination of the three arguments.
I think #behzad.nouri's comment is the best. Sometimes doing a little math is the best way to program. Here's a somewhat overdone expansion on #melpomene's solution, which I thought would be fun to share. Let's write a function similar to permutations but that computes combinations:
import Control.Arrow (first, second)
-- choose n xs returns a list of tuples, the first component of each having
-- n elements and the second component having the rest, in all combinations
-- (ignoring order within the lists). N.B. this would be faster if implemented
-- using a DList.
choose :: Int -> [a] -> [([a],[a])]
choose 0 xs = [([], xs)]
choose _ [] = []
choose n (x:xs) =
map (first (x:)) (choose (n-1) xs) ++
map (second (x:)) (choose n xs)
So..
ghci> choose 2 [1,2,3]
[([1,2],[3]),([1,3],[2]),([2,3],[1])]
Now you can write
triangleArea a b c
| or [ x + y <= z | ([x,y], [z]) <- choose 2 [a,b,c] ] = error ...
This doesn't address the question of how to shorten your error checking code, but you may be able to limit how often you repeat it by defining some new types with invariants. This function needs error checking because you can't trust the user to supply Float triples that make a reasonable triangle, and if you continue to define functions this way then every triangle-related function you write would need similar error checks.
However, if you define a Triangle type, you can check your invariants only once, when a triangle is created, and then all other functions will be guaranteed to receive valid triangles:
module Triangle (Triangle(), mkTriangle, area) where
data Triangle a = Triangle a a a deriving Show
mkTriangle :: (Num a, Ord a) => a -> a -> a -> Either String (Triangle a)
mkTriangle a b c
| a + b <= c = wrong
| a + c <= b = wrong
| b + c <= a = wrong
| otherwise = Right $ Triangle a b c
where wrong = Left "Not a triangle!"
area :: Floating a => Triangle a -> a
area (Triangle a b c) = sqrt (s * (s - a) * (s - b) * (s - c))
where s = (a + b + c) / 2
Here we export the Triangle type, but not its constructor, so that the client must use mkTriangle instead, which can do the required error checking. Then area, and any other triangle functions you write, can omit the checks that they are receiving a valid triangle. This general pattern is called "smart constructors".
Here are two ideas.
Using existing tools, you can generate all the permutations of the arguments and check that they all satisfy a condition. Thus:
import Data.List
triangleArea a b c
| any (\[x, y, z] -> x + y <= z) (permutations [a,b,c])
= error "Not a triangle!"
| otherwise = {- ... -}
This doesn't require writing very much additional code; however, it will search some permutations you don't care about.
Use the usual trick for choosing an element from a list and the left-overs. The zippers function is one I use frequently:
zippers :: [a] -> [([a], a, [a])]
zippers = go [] where
go b [] = []
go b (v:e) = (b, v, e) : go (v:b) e
We can use it to build a function which chooses only appropriate triples of elements:
triples :: [a] -> [(a, a, a)]
triples xs = do
(b1, v1, e1) <- zippers xs
(b2, v2, e2) <- zippers e1
v3 <- b1 ++ b2 ++ e2
return (v1, v2, v3)
Now we can write our guard like in part (1), but it will only consider unique pairings for the addition.
triangleArea a b c
| any (\(x, y, z) -> x + y <= z) (triples [a,b,c])
= error "Not a triangle!"
| otherwise = {- ... -}
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.
So I have a Tic Tac Toe board, in the form of nested tuples, like so:
type Row = (Field, Field, Field)
type Board = (Row, Row, Row)
data Field = X | O | B
deriving (Eq, Ord)
Where B stands for empty. I need to take a player, a given board state, and then generate a list of all possible board states after the next move.
moves :: Player -> Board -> [Board]
However, I just can't figure it out. My initial thought is that I need to iterate through every field, to check whether or not it is empty, and then add a new Board to the list or do nothing. However, I see no way to iterate through all the fields. Even if I manually check every field with if statement or guards, how do I move onto the next field to check it, regardless of whether I end up with a possible move or not?
If I convert the board format into a list I could do it, but I feel like that defeats the purpose of this problem. There's got to be a better solution that doesn't require restructuring Board.
You're not going to be able to iterate through the fields of a tuple -- tuples aren't intended for that. A list of lists is probably a more natural representation for this problem.
That said, you can implement this function with the board representation you're using by following the types. A move on a Board is a move on either the first, second, or third row. A move on a row is the placement of the player on either the first, second, or third field. The difficulty with your representation is that there's no simple way to map over a tuple, since tuples are generally heterogeneous. So instead, one thing you can do is write yourself a generic way to apply a function to a location in a tuple. Here's one way to do that (if the Monad stuff confuses you, mentally substitute "list of foo" everywhere you see m foo and you'll be okay):
mReplace1 :: Monad m => (a -> m d) -> (a,b,c) -> m (d,b,c)
mReplace1 f (a,b,c) = f a >>= \d -> return (d,b,c)
mReplace2 :: Monad m => (b -> m d) -> (a,b,c) -> m (a,d,c)
mReplace2 f (a,b,c) = f b >>= \d -> return (a,d,c)
mReplace3 :: Monad m => (c -> m d) -> (a,b,c) -> m (a,b,d)
mReplace3 f (a,b,c) = f c >>= \d -> return (a,b,d)
These functions provide a way to apply a function to the first, second, and third slots in a tuple, respectively. They're wrapped in a monad so that we can have a function that returns a list of possibilities for the slot, and automatically convert that to a list of possibilities for the tuple as a whole.
With these, we can write the overall function just by stringing these calls together.
moves p board = mReplace1 rowMoves board ++
mReplace2 rowMoves board ++
mReplace3 rowMoves board
where rowMoves row = mReplace1 fieldMoves row ++
mReplace2 fieldMoves row ++
mReplace3 fieldMoves row
fieldMoves B = [p]
fieldMoves _ = []
That is: the moves for a board are all the possibilities for a move in row 1, plus all the possibilities for row 2, plust all the possibilities for row 3. For a given row, the possible moves are all the moves for slot 1, plus all the moves for slot 2, plus all the moves for slot 3. For a given slot, if there's already an X or an O there, then there are no possible moves; otherwise there's one possible move (placing the player in that slot).
Here's a simple solution that I've used before
import qualified Data.Map as Map
data Piece = O | X deriving (Eq,Ord)
type Position = (Int,Int)
type Board = Map.Map Position Piece
positions = [(i,j) | i <- [0,1,2], j <- [0,1,2]]
spaces board = map (\pos -> Map.notMember pos board) positions
moves player board = map (\pos -> Map.insert pos player board) (spaces board)
As other people have stated, tuples is not a very good idea for this approach, since there is no way to traverse them.
You said you needed tuples, so there you go, I'm almost sure it works, test it.
First your code how I would've done it
import Control.Monad (msum)
import Control.Applicative ((<*>), pure)
data Player = P1 | P2 deriving (Eq, Show)
data Field = X | O | B deriving (Eq, Show)
type Board = ((Field,Field,Field)
,(Field,Field,Field)
,(Field,Field,Field))
symbolToPlayer :: Field -> Player
symbolToPlayer X = P1
symbolToPlayer O = P2
checkThree :: (Field,Field,Field) -> Maybe Player
checkThree (a,b,c)
| a == b && a == c = Just $ symbolToPlayer a
| otherwise = Nothing
winHorizontal :: Board -> Maybe Player
winHorizontal (r1, r2, r3) = msum $ map checkThree [r1, r2, r3]
winVertical :: Board -> Maybe Player
winVertical ((a,b,c), (d,e,f), (g,h,i)) =
msum $ map checkThree [(a,d,g), (b,e,h), (c,f,i)]
winDiagonal :: Board -> Maybe Player
winDiagonal ((a,_,c), (_,e,_), (g,_,i)) =
msum $ map checkThree [(a,e,i), (c,e,g)]
hasWinner :: Board -> Maybe Player
hasWinner b = msum $ [winHorizontal, winVertical, winHorizontal] <*> pure b
This is the part of nextStates function
boardBlanks :: Board -> Int
boardBlanks (r1,r2,r3) = rowBlanks r1 + rowBlanks r2 + rowBlanks r3
rowBlanks :: (Field, Field, Field) -> Int
rowBlanks (a,b,c) = foldr hack 0 [a,b,c]
where hack B c = 1 + c
hack _ c = c
changeBoard :: Field -> Int -> Board -> Board
changeBoard f i (a,b,c)
| hack [a] > i = (changeRow f (i - hack []) a, b, c)
| hack [a,b] > i = (a, changeRow f (i - hack [a]) b, c)
| hack [a,b,c] > i= (a, b, changeRow f (i - hack [a,b]) c)
where
hack ls = sum $ map rowBlanks ls
changeRow f 0 row =
case row of
(B,a,b) -> (f,a,b)
(a,B,b) -> (a,f,b)
(a,b,B) -> (a,b,f)
otherwise -> row
changeRow f 1 row =
case row of
(B,B,a) -> (B,f,a)
(a,B,B) -> (a,B,f)
otherwise -> row
changeRow f 2 row =
case row of
(B,B,B) -> (B,B,f)
otherwise -> row
nextStates :: Board -> [Board]
nextStates b = os ++ xs
where
os = foldr (hack O) [] . zip [0..] $ replicate (boardBlanks b) b
xs = foldr (hack X) [] . zip [0..] $ replicate (boardBlanks b) b
hack f (i,a) ls = changeBoard f i a : ls