Can't find the error in my Haskell code - haskell

I tried to translate a (working !) solution of the cabbage-goat-wolf puzzle from Scala to Haskell, but the code throws and error when calling head in findSolutions because the solution list is empty, so the problem seems to be somewhere in loop. findMoves seems to work fine.
import Data.Maybe(fromMaybe)
data Item = Farmer | Cabbage | Goat | Wolf deriving (Eq, Show)
type Position = ([Item], [Item])
validPos :: Position -> Bool
validPos p = valid (fst p) && valid (snd p) where
valid list = elem Farmer list || notElem Goat list ||
(notElem Cabbage list && notElem Wolf list)
findMoves :: Position -> [Position]
findMoves (left,right) = filter validPos moves where
moves | elem Farmer left = map (\item -> (delItem item left, addItem item right)) left
| otherwise = map (\item -> (addItem item left, delItem item right)) right
delItem item = filter (\i -> notElem i [item, Farmer])
addItem Farmer list = Farmer:list
addItem item list = Farmer:item:list
findSolution :: Position -> Position -> [Position]
findSolution from to = head $ loop [[from]] where
loop pps = do
(p:ps) <- pps
let moves = filter (\x -> notElem x (p:ps)) $ findMoves p
if elem to moves then return $ reverse (to:p:ps)
else loop $ map (:p:ps) moves
solve :: [Position]
solve = let all = [Farmer, Cabbage, Goat, Wolf]
in findSolution (all,[]) ([],all)
Of course I would also appreciate hints concerning improvements not related to the actual error.
[Update]
Just for the record, I followed the suggestion to use a Set. Here is the working code:
import Data.Set
data Item = Farmer | Cabbage | Goat | Wolf deriving (Eq, Ord, Show)
type Position = (Set Item, Set Item)
validPos :: Position -> Bool
validPos p = valid (fst p) && valid (snd p) where
valid set = or [Farmer `member` set, Goat `notMember` set,
Cabbage `notMember` set && Wolf `notMember` set]
findMoves :: Position -> [Position]
findMoves (left,right) = elems $ Data.Set.filter validPos moves where
moves | Farmer `member` left = Data.Set.map (move delItem addItem) left
| otherwise = Data.Set.map (move addItem delItem) right
move f1 f2 item = (f1 item left, f2 item right)
delItem item = delete Farmer . delete item
addItem item = insert Farmer . insert item
findSolution :: Position -> Position -> [Position]
findSolution from to = head $ loop [[from]] where
loop pps = do
ps <- pps
let moves = Prelude.filter (\x -> notElem x ps) $ findMoves $ head ps
if to `elem` moves then return $ reverse $ to:ps
else loop $ fmap (:ps) moves
solve :: [Position]
solve = let all = fromList [Farmer, Cabbage, Goat, Wolf]
in findSolution (all, empty) (empty, all)
The call to head in findSolution could be made safer, and a better way to print out the solution should be used, but apart from that I'm quite happy with it.
[Update 2]
I think the former representations of the positions were suboptimal for this kind of problem. I switched to the following data model, which made moving etc slightly more verbose, but much more readable:
data Place = Here | There deriving (Eq, Show)
data Pos = Pos { cabbage :: Place
, goat :: Place
, wolf :: Place
, farmer :: Place
} deriving (Eq, Show)

The problem is that [Farmer,Goat,Cabbage,Wolf] is not the same that [Farmer,Cabbage,Goat,Wolf] and you don't check it when use elem and notElem. One solution is always sort the list of elements, e.g in the function findMoves you can use:
import Data.List(ord)
import Control.Arrow((***))
data Item = Farmer | Cabbage | Goat | Wolf deriving (Eq, Show, Ord)
findMoves (left,right) = map (sort***sort) $ filter validPos moves where
-- ....
solve = let all = sort [Farmer, Cabbage, Goat, Wolf]
-- ....
Or you can use a set of Item instead a list of Item.

Related

Haskell checkers - how to write a function that returns a list of possible jumps

I would like to ask for help because I do not know how to write a function that analyzes possible jumps for a checkers' pawn.
I am stuck and I will be very thankful for help.
I created a chessboard and a list of tuples that represent chessboard as a list.
This is the form to be able to show the chessboard on the screen:
"\"p.p.p.p.\n.p.p.p.p\np.p.p.p.\n........\n........\n........\nP.P.P.P.\n.P.P.P.P\nP.P.P.P.\n\""
And this is the form which I use to analyze possible moves of pieces:
[((1,1),'p'),((1,2),'.'),((1,3),'p'),((1,4),'.'),((1,5),'p'),((1,6),'.'),((1,7),'p'),((1,8),'.'),((2,1),'.'),((2,2),'p'),((2,3),'.'),((2,4),'p'),((2,5),'.'),((2,6),'p'),((2,7),'.'),((2,8),'p'),((3,1),'p'),((3,2),'.'),((3,3),'p'),((3,4),'.'),((3,5),'p'),((3,6),'.'),((3,7),'p'),((3,8),'.'),((4,1),'.'),((4,2),'.'),((4,3),'.'),((4,4),'.'),((4,5),'.'),((4,6),'.'),((4,7),'.'),((4,8),'.'),((5,1),'.'),((5,2),'.'),((5,3),'.'),((5,4),'.'),((5,5),'.'),((5,6),'.'),((5,7),'.'),((5,8),'.'),((6,1),'.'),((6,2),'.'),((6,3),'.'),((6,4),'.'),((6,5),'.'),((6,6),'.'),((6,7),'.'),((6,8),'.'),((7,1),'P'),((7,2),'.'),((7,3),'P'),((7,4),'.'),((7,5),'P'),((7,6),'.'),((7,7),'P'),((7,8),'.'),((8,1),'.'),((8,2),'P'),((8,3),'.'),((8,4),'P'),((8,5),'.'),((8,6),'P'),((8,7),'.'),((8,8),'P')]
This is the code I wrote so far:
module Checkers where
import Test.HUnit
import Test.QuickCheck
import Data.Char
import Data.Maybe (fromJust)
import Control.Error.Util (note)
import Data.Maybe (listToMaybe)
import Data.Char(isDigit)
import Data.String
import Data.List
import Prelude
type Board = [[Square]]
type Square = Maybe Piece
data Piece = Piece PColor PType deriving (Show)
data PColor = White | Black deriving (Show)
data PType = Pawn | Queen deriving (Show)
typeList:: [(Char, PType)]
typeList = [('p', Pawn), ('q', Queen)]
initialBoard = unlines ["p.p.p.p."
,".p.p.p.p"
,"p.p.p.p."
,"........"
,"........"
,"........"
,"P.P.P.P."
,".P.P.P.P"
,"P.P.P.P." ]
board2 = unlines ["p.p.p.p."
,".p.p.p.p"
,"p.p.p.p."
,".P.P.P.."
,"........"
,"........"
,"P...P.P."
,".P.P.P.P"
,"P.P.P.P."]
showBoard :: Board -> String
showBoard = unlines. map showRow
where showRow = map showSquare
readBoard :: String -> Either String Board
readBoard = (mapM . mapM) readSquare . lines
showSquare:: Square -> Char
-- showSquare Nothing = ' '
-- showSquare (Just p) = showPiece p
showSquare = maybe ' ' showPiece
readSquare:: Char -> Either String Square
readSquare '.' = return Nothing
readSquare c = note errorMsg $ fmap return (readPiece c)
where errorMsg = "Error reading square '" ++ show c ++ "' is not a valid square"
--readSquare:: Char -> Square
--readSquare c = readPiece c
showPiece:: Piece -> Char
showPiece (Piece White Pawn) = 'P'
showPiece (Piece Black Pawn) = 'p'
showPiece (Piece White Queen) = 'Q'
showPiece (Piece Black Queen) = 'q'
readPiece:: Char -> Maybe Piece
readPiece c = fmap makePiece lookupType
where color = if isUpper c then White else Black
lookupType = lookup (toLower c) typeList
makePiece = Piece color
--readPiece 'P' = Just (Piece White Pawn)
--readPiece 'p' = Just (Piece Black Pawn)
--readPiece 'Q' = Just (Piece White Queen)
--readPiece 'q' = Just (Piece Black Queen)
--readPiece _ = Nothing
--transform chessboard into a list of tuples to analyze possible kills
--String or Int?
testString = "hello world 13 i am a new 37 developer 82"
data StringOrInt = S String | I Int
deriving (Eq,Ord,Show)
readInt :: String -> Int
readInt = read
--convert String into tuples
--1. convert chessBoard into a list
myShow :: String -> String
myShow s = concat ["[", intersperse ',' s, "]"]
isSlash x = x=='\\'
deleteAllInstances :: Eq a => a -> [a] -> [a]
deleteAllInstances a xs = filter (/= a) xs
clearBoardList_ s = deleteAllInstances '\n' $ myShow $ s
clearBoardList__ s = deleteAllInstances '[' $ clearBoardList_ s
clearBoardList s = deleteAllInstances ',' $ clearBoardList__ s
--2 zip with coordinates (1,1), (1,2).... (8,8)
makeL = [(x,y)| x<-[1..8], y<-[1..8]]
makeTuplesBoard s = zip makeL s
testList = makeList initialBoard
testList2 = makeList board2
--3 all together
makeList s = makeTuplesBoard $ clearBoardList s --xy coordinates of pawns
--is there my Pawn?
isMyPawn ((x,y),z) = (z=='p' || z=='q')
matchFirst (a,b) ((c,d),_) = (a,b) == (c,d)
whatIsThere (a,b) list = eliminate $ find (matchFirst (a,b)) list --test: whatIsThere (1,1) $ makeList initialBoard
eliminate (Just a) = a
whichPiece (a,b) list = snd $ snd ( whatIsThere (a,b) $ makeTuplesBoard list ) --shows what is on a specific field
isThereSth (a,b) list = whichPiece (a,b) list == 'p' || whichPiece (a,b) list == 'P' || whichPiece (a,b) list == 'q' ||whichPiece (a,b) list == 'Q' --isThereSth (1,1) $ makeList initialBoard
isThereMyPawn (a,b) list = ((whichPiece (a,b) list == 'p'), list) --whichPiece (a,b) list == ((a,b),'p')
isThereMyQueen (a,b) list = ((whichPiece (a,b) list == 'q'), list)
isThereOtherPawn (a,b) list = ((whichPiece (a,b) list == 'P'), list)
isThereOtherQueen (a,b) list = ((whichPiece (a,b) list == 'Q'), list)
--remove a figure from its place and put somewhere else
removePiece (a,b) list = map (\ x -> if matchFirst (a,b) x then ((a,b),'.') else x) list
removeMyPawn (a,b) list = removePiece (a,b) list
removeMyQueen (a,b) list = removePiece (a,b) list
removeOtherPawn (a,b) list = removePiece (a,b) list
removeOtherQueen (a,b) list = removePiece (a,b) list
isWithinLimit (a,b)
| not ((a>0) && (a<9) && (b>0) && (b<9)) = False
| otherwise = True
isWithinLimit1 (a,b) list
| not ((a>0) && (a<9) && (b>0) && (b<9)) = (False, list)
| otherwise = (True, list)
putPiece (a,b) piece list = map (\ x -> if matchFirst (a,b) x then ((a,b),piece) else x) list --map (\ x -> if matchFirst (a,b) x then ((a,b),'.') else x) list
--test: movePiece (1,1) (1,2) $ makeTuplesBoard initialBoard
movePiece (a,b) (c,d) list = removePiece (a,b) $ putPiece (c,d) (whichPiece (a,b) $ makeTuplesBoard initialBoard ) (makeTuplesBoard initialBoard)
--putADot (a,b) list = replace ( matchFirst (a,b)) list
--swapTuples (a,b) (c,d) list =
--move (a,b) (c,d) list =
-- | (isThereSth (a,b) == False) = list
-- | otherwise =
isThereOtherPawn2 (a,b) list x
| (x==True) = fst $ isThereOtherPawn (a,b) list
| otherwise = False
isWithinLimit2 (a,b) list x
| (x==True) = fst $ isWithinLimit1 (a,b) list
| otherwise = False
isFree2 (a,b) list x
| (x==True) = isFree (a,b) list
| otherwise = False
isThereMyPawn2 (a,b) list x
| (x==True) = fst $ isThereMyPawn (a,b) list
| otherwise = False
isFree (a,b) list = not (isThereSth (a,b) list)
isJumpLFPossible (a,b) list = isThereMyPawn2 (a,b) list $ (isFree2 (a+2,b-2) list $ isWithinLimit2 (a+2,b-2) testList $ isThereOtherPawn2 (a+1,b-1) list $ fst $ isWithinLimit1 (a+1,b-1) list) --test: isFree2 (3,4) testList $ isWithinLimit2 (3,4) testList $ isThereOtherPawn2 (3,4) testList $ fst $ isWithinLimit1 (2,3) testList
isJumpRFPossible (a,b) list = isThereMyPawn2 (a,b) list $ (isFree2 (a+2,b+2) list $ isWithinLimit2 (a+2,b+2) testList $ isThereOtherPawn2 (a+1,b+1) list $ fst $ isWithinLimit1 (a+1,b+1) list) --test: isFree2 (3,4) testList $ isWithinLimit2 (3,4) testList $ isThereOtherPawn2 (3,4) testList $ fst $ isWithinLimit1 (2,3) testList
-- checking whether my Pawn has any jump possiblitiy - one move
canJumpLF (a,b) list
| (isJumpLFPossible (a,b) list) = [(a,b),(a+2, b-2)]
| otherwise = [] --test: canJump (1,1) testBoard
canJumpRF (a,b) list
| (isJumpRFPossible (a,b) list) = [(a,b),(a+2, b+2)]
| otherwise = [] --test: canJump (1,1) testBoard
isFree (a,b) list = not (isThereSth (a,b) list)
-- recursive check whether and which kills are possible for my Pawn
--canJump (a,b) list
-- | (fst (canJumpLF (a,b) list)) = snd (canJump (a+2, b-2) list)
-- | (fst (canJumpRF (a,b) list)) = snd (canJump (a+2, b+2) list)
-- | otherwise = []
replaceTuple tups old new = map check tups where
check tup | tup == old = new
| otherwise = tup
--movePawn (x,y) (a,b) = if (isMyPawn(x,y)
--replacePawn list = replaceTuple $ ((x,y),_) ((x,y),'.') list
--analyze possible moves of pawn
--Tests
tests:: Test
tests = TestList $ map TestCase
[assertEqual "odd tests here" 1(1 :: Int)]
prop_empty :: Int -> Bool
prop_empty c1 = (c1::Int) == c1
runTest = do
return()
main:: IO()
main = runTest
My problem is as follows. I need a function that returns a list of all possible jump sequences. I think it needs to be a recursive function. It should:
(1) check whether a jump to the right, left is possible
(2) if it is possible, then recursively run itself from the position a pawn would take after (1)
(3) it should return a list of tuples' lists representing possible sequences of jumps: [(a,b), (c,d), (e,f), (g,h)], [(a,b), (p,r)], [(a,b), (q,s), (t,u)]]
(4) if the pawn reached the opposite end of the chessboard it can jump backwards if there are any possible jumps
(5) if the pawn reached the end of the board and there are no jumps possible it turns into a queen (it gets crowned - I cannot tell whether this possibility should be included in this function or not - perhaps not)
In other words, from the position (a,b) I want to analyze all possible jumps and write a function that returns a list of all possible jump sequences.
...
After modifications my problem remains but I can explain it simpler:
The function canOneJump (a,b) board returns a list of possible places where pawns can be after they made 1 jump. In other words, the function returns [(1,2), (2,3), (4,5)] each tuple representing a row and a column where a pawn can be after a jump.
I have a function that is supposed to create now lists of jumps from the initial location of a pawn (a,b) (based on the chessboard situation which is given as a list) but it does not work. Perhaps someone could help me to fix this function so it works.
I want to get a list of jump sequences [[(3,3), (5,5), (7,3)], [(3,3), (5,1)]] that represent different jump sequences that are available.
canJump v board =
map (v:) w
where
list = listPlacesAfterMyPawnJump v board
w = concat $ map (flip canJump board) list
First I'd suggest posting your code to the Code Review Stackexchange to get some pointers on code style, organization, and other tips. They have a rule about only reviewing working code, so just ask them to review the code that you have.
Here's an outline of how I would proceed.
The solution will be a lot easier to understand with these type definitions:
type Coord = (Int,Int)
type CoordBoard = [ (Coord, Char) ]
Step 1. Using the functions you already have, write a function to return all possible single jumps from a specific square:
singleJumps :: (Coord, CoordBoard) -> [ (Coord, CoordBoard) ]
Note that you return the updated CoordBoard - i.e. the board with the jumped piece removed and the jumper moved. Return the empty list if there are no possible jumps.
Step 2. Then write a function to find all possible jump paths from a starting square:
multiJumps :: (Coord, CoordBoard) -> [ ([Coord], CoordBoard) ]
This also returns the CoordBoard with the jump moves executed. The idea behind multiJumps is:
for each possible single jump (rc, b):
for each possible multi jump (path, b') starting from (rc,b):
return the path (rc:path) and ending board configuration b'
This is where the recursion happens. (Hint: multijumps can be written as a list comprehension.)
Finally, I solved my problem, but I had to change several functions / write new ones.
canJumpLB (a,b) list
| (isJumpLBPossible (a,b) list) = [(a,b),(a-2, b-2)]
| otherwise = []
canJumpRB (a,b) list
| (isJumpRBPossible (a,b) list) = [(a,b),(a-2, b+2)]
| otherwise = []
canOneJump (a,b) list =filter (/=[]) $filter (/=[]) $filter (/=[]) [canJumpLF (a,b) list] ++ [canJumpRF (a,b) list]
canImakeAnotherJump list listOfLists = concat $ [canOneJump (x!!((length x)-1)) list | x <- listOfLists]
anotherJump list listOfLists = combine (canImakeAnotherJump list listOfLists) listOfLists []
jumpSequences v list []
| (canOneJump v list == []) = []
| otherwise = jumpSequences v list (canOneJump v list)
jumpSequences v list results
| ((canImakeAnotherJump list results) == []) = results
| otherwise = jumpSequences v list (anotherJump list results)
The function jumpSequences shows all sequences of jumps from a certain position. My pawns do not jump backwards, so I do not update the chessboard.

Haskell - Chess - which next moves are possible?

I want to write a function that takes a chess figure with a position and tell me which moves this figure can make with his next move.
For the king I was able to do this.
type Position = (Int,Int)
data Piece = Piece {
_position :: Position,
_color :: String}
nextMoves :: Piece -> [Position]
nextMoves king = filter (onTheBoard) (filter (/= (xOld,yOld))
[(x,y) | x <- [(xOld-1)..(xOld+1)], y <- [(yOld-1)..(yOld+1)]])
where
xOld = fst(_position king)
yOld = snd(_position king)
He stands on (1,3) and my function gives me [(1,2),(1,4),(2,2),(2,3),(2,4)].
Now I want to do the same for a bishop or a knight. But how can I use filter for this issue?
Thanks for a tipp.
//edit: I've changed my check to a help function:
onTheBoard :: Position -> Bool
onTheBoard (x,y) = elem x [1..8] && elem y [1..8]
You have no way to tell which piece (king, bishop, knight, etc.) a Piece is. nextMoves king matches all pieces, regardless of which type it is. To figure out the moves for other pieces, you'll need to be able to discriminate between them. You'll need something like
data PieceType = Pawn | Knight | Bishop | Rook | Queen | King
data Piece = Piece {
_position :: Position,
_color :: String,
_pieceType :: PieceType}
Then you can write more cases for nextMoves
nextMoves :: Piece -> [Position]
nextMoves piece =
case _pieceType piece of
King -> filter (<= (1,1)) (filter (>= (8,8)) (filter (/= (xOld,yOld))
[(x,y) | x <- [(xOld-1)..(xOld+1)], y <- [(yOld-1)..yOld+1)]]))(yOld+1)]]))
Queen -> ...
Rook -> ...
Bishop -> ...
Knight -> ...
Pawn -> ...
where
xOld = fst(_position piece)
yOld = snd(_position piece)
You could extract the filtering that the move must be on the board from the rest of the rules.
If you are aiming for the actual game of chess, there are other rules for whether a move is valid that depend on the rest of the state of the board.
Filtering
You also have a problem with the filtering, as pointed out by Priyatham. The Ord instance for typles (,) first compares the first element of the tuple, then compares the second one. That means, for instance, that (1, 9) < (2, 0). This is called a lexographic ordering, like how entries are alphabetized: first by their first letter, then by their second, etc...
You need to check that each component is individually in the range, which is easily done with Data.Ix's inRange and the fst and snd functions, for example:
filter (inRange (1,8) . fst) . filter (inRange (1,8) . snd) . filter (/= (8,8)) $ [(7,9), 9,7), (7,7), (8, 8)]
The Ix instance for tuples (,) checks that both components are inRange, so this is equivalent to
filter (inRange ((1,1), (8,8))) . filter (/= (8,8)) $ [(7,9), (9,7), (7,7), (8, 8)]

manual Instance Show definition causes Stack Space Overflow

When I write manually a simple show instance for the PhisicalCell datatype, the program consumes all the space. When deriving his own version of Show, this doesn't happen. Why?
here is a stripped-down version of the code I'm writing:
import Data.Array
type Dimensions = (Int, Int)
type Position = (Int, Int)
data PipeType = Vertical | Horizontal | UpLeft | UpRight | DownLeft | DownRight deriving (Show)
data PhisicalCell = AirCell
| PipeCell PipeType
| DeathCell
| RecipientCell Object
-- deriving (Show) SEE THE PROBLEM BELOW
data Object = Pipe { pipeType :: PipeType -- tipo di tubo
, position :: Position -- posizione del tubo
, movable :: Bool -- se posso muoverlo
}
| Bowl { position :: Position -- posizione dell'angolo in alto a sinistra
, dimensions :: Dimensions -- dimensioni (orizzontale, verticale)
, waterMax :: Int -- quanta acqua puo' contenere al massimo
, waterStart :: Int -- con quanta acqua parte
, hatch :: Maybe Position -- un eventuale casella di sbocco
, sourceIn :: [Position] -- posti da cui l'acqua entra
, movable :: Bool -- se posso muoverlo
}
| Death
deriving (Show)
data Level = Level Dimensions [Object]
type LevelTable = Array Dimensions PhisicalCell
-- HERE IS THE PROBLEM --
instance Show PhisicalCell where
show AirCell = " "
show (PipeCell _) = "P"
show DeathCell = "X"
show (RecipientCell _) = "U"
both :: (a -> b) -> (a,a) -> (b,b)
both f (a,b) = (f a, f b)
levelTable :: Level -> LevelTable
levelTable (Level dim _) = initial
where initial = array ((0,0), both (+1) dim) $
[((x,y), AirCell) | x <- [1..fst dim], y <- [1..snd dim] ]
++ [((x,y), DeathCell) | x <- [0..fst dim + 1], y <- [0, snd dim + 1]]
++ [((x,y), DeathCell) | x <- [0, fst dim + 1], y <- [0..snd dim + 1]]
main = print $ levelTable (Level (8,12) [])
The Show type class has mutually referencing default implementations:
class Show a where
-- | Convert a value to a readable 'String'.
--
-- 'showsPrec' should satisfy the law
-- ...
...
showsPrec _ x s = show x ++ s
show x = shows x ""
showList ls s = showList__ shows ls s
...
shows :: (Show a) => a -> ShowS
shows = showsPrec 0
So if you declare a Show instance without defining any of the methods
instance Show where
nextNewFunction :: Bla
...
GHC will happily compile all the default ones, so there won't be any errors. However, as soon as you try to use any of them, your trapped in a loop as deadly as your Objects... and the mutual recursion will eventually blow the stack.
Now, your code doesn't quite look as if you have such an empty instance Show declarion, but in fact you do: because of the wrong indentation, the show you define there is recognised as a new free top-level function that merely happens to have the same name as GHC.Show.show. You could add
show :: PhisicalCell -> String
to your file and get the same result as now.
The problem does actually lie in the spacing that Sassa NF points out. When I indent the show, it works (and when I don't, I get the stack overflow). Without the indent, you're defining a top-level show function that is never used, and the show function for the Show instance of PhisicalCell has an undefined show function, which causes the problem.

Haskell, creating a binary search tree from a list

Can someone tell me why this code isn't producing what I want.
data BST = MakeNode BST String BST
| Empty
add :: String -> BST -> BST
add new Empty = (MakeNode Empty new Empty)
add string tree#(MakeNode left value right)
| string > value = MakeNode left value (add string right)
| string < value = MakeNode (add string left) value right
| otherwise = tree
output
"John"
"Doug"
"Charlie"
"Alice"
listToBST :: [String] -> BST
listToBST = foldr add Empty
If we create and function which takes a BST and returns a list in sorted order, modelled after sort . nub, then your Tree is fine as quickcheck tells us. QuickCheck is very easy to use.
import Data.List
import Test.QuickCheck
data BST = MakeNode BST String BST
| Empty
deriving (Show)
add :: String -> BST -> BST
add new Empty = (MakeNode Empty new Empty)
add string tree#(MakeNode left value right)
| string > value = MakeNode left value (add string right)
| string < value = MakeNode (add string left) value right
| otherwise = tree
test = ["alice", "blup", "test", "aa"]
manual_test = inorder (foldr add Empty test) == sort (nub test)
prop_inorder = property inorder_test
where inorder_test :: [String] -> Bool
inorder_test xs = inorder (foldr add Empty xs) == sort (nub xs)
-- return sorted nodes
inorder :: BST -> [String]
inorder (Empty) = []
inorder (MakeNode l x r) = inorder l ++ (x : inorder r)
Just load ghci and then run quickCheck prop_inorder.
Other useful functions are:
reverseOrder :: BST -> [String]
reverseOrder Empty = []
reverseOrder (MakeNode l x r) = reverseOrder r ++ (x : reverseOrder r)
asList :: BST -> [String]
asList Empty = []
asList (MakeNode l x r) = x : (asList l ++ asList r)
And also think about making your tree more general by parameterizing over a:
data BST a = Empty | MakeNode (BST a) a (BST a)
You can make it than an instance of Functor, Monad, Foldable and all kind of handy typeclasses.
I tried it and it seems ok to me. It could help if you gave an example of an input that it doesn't work for.
I think the problem may be that string comparison does not work the way you expect ("123" < "7" because "1" < "7"). If I'm right, you might want to use Ints instead of Strings or even better, the class Ord of all the types that can be ordered using (<).

Creating functions over Enumerations

I just started learning Haskell. I think I've got the basics down, but I want to make sure I'm actually forcing myself to think functionally too.
data Dir = Right | Left | Front | Back | Up | Down deriving (Show, Eq, Enum)
inv Right = Left
inv Front = Back
inv Up = Down
Anyway, the jist of what I'm trying to do is to create a function to map between each "Dir" and its opposite/inv. I know I could easily continue this for another 3 lines, but I can't help but wonder if there's a better way. I tried adding:
inv a = b where inv b = a
but apparently you can't do that. So my question is: Is there either a way to generate the rest of the inverses or an altogether better way to create this function?
Thanks much.
If the pairing between Up and Down and so on is an important feature then maybe this knowledge should be reflected in the type.
data Axis = UpDown | LeftRight | FrontBack
data Sign = Positive | Negative
data Dir = Dir Axis Sign
inv is now easy.
Do you have a closed-form solution over the indices that corresponds to this function? If so, yes, you can use the Enum deriving to simplify things. For example,
import Prelude hiding (Either(..))
data Dir = Right
| Front
| Up
| Left
| Back
| Down
deriving (Show, Eq, Ord, Enum)
inv :: Dir -> Dir
inv x = toEnum ((3 + fromEnum x) `mod` 6)
Note, this relies on the ordering of the constructors!
*Main> inv Left
Right
*Main> inv Right
Left
*Main> inv Back
Front
*Main> inv Up
Down
This is very C-like, exploits the ordering of constructors, and is un-Haskelly. A compromise is to use more types, to define a mapping between the constructors and their mirrors, avoiding the use of arithmetic.
import Prelude hiding (Either(..))
data Dir = A NormalDir
| B MirrorDir
deriving Show
data NormalDir = Right | Front | Up
deriving (Show, Eq, Ord, Enum)
data MirrorDir = Left | Back | Down
deriving (Show, Eq, Ord, Enum)
inv :: Dir -> Dir
inv (A n) = B (toEnum (fromEnum n))
inv (B n) = A (toEnum (fromEnum n))
E.g.
*Main> inv (A Right)
B Left
*Main> inv (B Down)
A Up
So at least we didn't have to do arithmetic. And the types distinguish the mirror cases. However, this is very un-Haskelly. It is absolute fine to enumerate the cases! Others will have to read your code at some point...
pairs = ps ++ map swap ps where
ps = [(Right, Left), (Front, Back), (Up, Down)]
swap (a, b) = (b, a)
inv a = fromJust $ lookup a pairs
[Edit]
Or how about this?
inv a = head $ delete a $ head $ dropWhile (a `notElem`)
[[Right,Left],[Front,Back],[Up,Down]]
It is good to know, that Enumeration starts with zero.
Mnemonic: fmap fromEnum [False,True] == [0,1]
import Data.Bits(xor)
-- Enum: 0 1 2 3 4 5
data Dir = Right | Left | Front | Back | Up | Down
deriving (Read,Show,Eq,Ord,Enum,Bounded)
inv :: Dir -> Dir
inv = toEnum . xor 1 . fromEnum
I don't think I'd recommend this, but the simple answer in my mind would be to add this:
inv x = fromJust $ find ((==x) . inv) [Right, Front, Up]
I couldn't resist tweaking Landei's answer to fit my style; here's a similar and slightly-more-recommended solution that doesn't need the other definitions:
inv a = fromJust $ do pair <- find (a `elem`) invList
find (/= a) pair
where invList = [[Right, Left], [Up, Down], [Front, Back]]
It uses the Maybe monad.

Resources