import Test.QuickCheck
import Data.List
---------------------------------------------------------------------------
-- 1. Permutations
-- isPermutation xs ys checks whether xs is a permutation of ys
isPermutation :: Eq a => [a] -> [a] -> Bool
isPermutation [] [] = True
isPermutation [] (y:ys) = False
isPermutation (x:xs) ys = exists x ys && isPermutation xs (removeOnce x ys)
-- removeOnce x xs removes x from the list xs, but only once
removeOnce :: Eq a => a -> [a] -> [a]
removeOnce x [] = []
removeOnce x (y:ys) | x == y = ys
| otherwise = y : removeOnce x ys
-- backwards xs reverses the elements in the list xs
backwards :: [a] -> [a]
backwards [] = []
backwards (x:xs) = atBack x (backwards xs)
where
atBack x [] = [x]
atBack x (y:ys) = y : atBack x ys
---------------------------------------------------------------------------
-- 2. Sorting
-- sorted xs checks whether the list xs is sorted
sorted :: Ord a => [a] -> Bool
sorted [] = True
sorted [x] = True
sorted (x:y:xs) = x <= y && sorted (y:xs)
-- Note: Why don't we have to check that x <= all elements in (y:ys)?
-- insert' x xs inserts x in the sorted list xs, at the right place
insert' :: Ord a => a -> [a] -> [a]
insert' x [] = [x]
insert' x (y:ys)
| x <= y = x : y : ys
| otherwise = y : insert' x ys
-- isort xs produces the sorted version of the list xs
isort :: Ord a => [a] -> [a]
isort [] = []
isort (x:xs) = insert' x (isort xs)
prop_Sorted :: [Integer] -> Bool
prop_Sorted xs =
sorted (isort xs)
prop_Permutation :: [Integer] -> Bool
prop_Permutation xs =
isPermutation xs (isort xs)
---------------------------------------------------------------------------
-- 3. Avoiding Duplicates
-- duplicates xs checks if there are duplicates in the list xs
duplicates :: Eq a => [a] -> Bool
duplicates [] = False
duplicates (x:xs) = exists x xs || duplicates xs
-- exists x xs checks whether x exists as an element in the list xs
exists :: Eq a => a -> [a] -> Bool
exists x [] = False
exists x (y:ys) = x == y || exists x ys
-- Note: "exists" is the standard Haskell function "elem"
-- removeDuplicates xs returns the list xs with all duplicate elements removed
removeDuplicates :: Eq a => [a] -> [a]
removeDuplicates [] = []
removeDuplicates (x:xs) = x : removeDuplicates (remove x xs)
-- remove x xs removes x from the list xs
remove :: Eq a => a -> [a] -> [a]
remove x [] = []
remove x (y:ys) | x == y = remove x ys
| otherwise = y : remove x ys
{-
-- alternative solution:
-- (returns elements in different order!)
-- removeDuplicates xs returns the list xs with all duplicate elements removed
removeDuplicates :: Eq a => [a] -> [a]
removeDuplicates [] = []
removeDuplicates (x:xs) | exists x xs = removeDuplicates xs
| otherwise = x : removeDuplicates xs
-}
-- No, the property does not guarantee this. A function always returning the
-- empty list would also satisfy the property!
-- Missing is a property that checks that no elements disappear:
prop_RemoveDuplicatesKeepsElements xs =
allExist xs (removeDuplicates xs)
-- allExist xs ys checks whether all x in xs exist as an element in ys
allExist :: Eq a => [a] -> [a] -> Bool
allExist [] ys = True
allExist (x:xs) ys = exists x ys && allExist xs ys
-------------------------------------------------------------------------
-- 4. Pascal's Triangle
pascal :: Int -> [Int]
pascal 1 = [1]
pascal n = [1] ++ [ x+y | (x,y) <- pairs (pascal (n-1)) ] ++ [1]
where
pairs (x:y:xs) = (x,y) : pairs (y:xs)
pairs _ = []
prop_Pascal n =
n >= 1 ==>
length (pascal n) == n
-------------------------------------------------------------------------
-- 5. Eratosthenes' sieve
crossOut :: Int -> [Int] -> [Int]
crossOut n xs = [ x | x <- xs, x `mod` n /= 0 ]
sieve :: [Int] -> [Int]
sieve [] = []
sieve (n:ns) = n : sieve (crossOut n ns)
primes1to100 = sieve [2..100]
prop_Sieve n =
and [ isPrime n | n <- sieve [2..n] ]
where
isPrime n = factors n == [1,n]
factors n = [ k | k <- [1..n], n `mod` k == 0 ]
-------------------------------------------------------------------------
-- 6. Number Games
isPrime100 :: Int -> Bool
isPrime100 n = n `elem` primes1to100
isSumOf2Primes100 :: Int -> Bool
isSumOf2Primes100 n =
not (null [ (a,b)
| a <- primes1to100
, b <- primes1to100
, n == a+b
])
counterExamples :: [Int]
counterExamples = [ n | n <- [4..100], even n, not (isSumOf2Primes100 n) ]
prop_Goldbach =
null counterExamples
-------------------------------------------------------------------------
-- 7. Occurrences in Lists
occursIn :: Eq a => a -> [a] -> Bool
occursIn x xs = x `elem` xs
allOccurIn :: Eq a => [a] -> [a] -> Bool
allOccurIn xs ys = and [ x `elem` ys | x <- xs ]
sameElements :: Eq a => [a] -> [a] -> Bool
sameElements xs ys = allOccurIn xs ys && allOccurIn ys xs
numOccurIn :: Eq a => a -> [a] -> Int
numOccurIn x xs = length [ x' | x' <- xs, x == x' ]
type Table a b = [(a,b)]
type Bag a = Table a Int
bag :: Eq a => [a] -> Bag a
bag xs = [ (x, numOccurIn x xs) | x <- nub xs ]
prop_Bag :: [Int] -> Bool
prop_Bag xs =
[ x | (x,n) <- bag xs, i <- [1..n] ] `isPermutation` xs
{-
Note that
[ x | (x,n) <- xns, i <- [1..n] ]
is a list of all elements in the bag xns, where all elements are repeated
the number of times they occur in the bag xns.
-}
-------------------------------------------------------------------------
-- 8. Elements and Positions
positions :: [a] -> [(a,Int)]
positions xs = xs `zip` [1..length xs]
{-
-- alternatively:
positions :: [a] -> [(a,Int)]
positions xs = xs `zip` [1..]
-}
firstPosition :: Eq a => a -> [a] -> Int
firstPosition x xs = head [ i | (x',i) <- positions xs, x' == x ]
prop_FirstPositionIsX :: Int -> [Int] -> Property
prop_FirstPositionIsX x xs =
x `elem` xs ==>
xs !! (firstPosition x xs - 1) == x
prop_FirstPositionIsFirst :: Int -> [Int] -> Property
prop_FirstPositionIsFirst x xs =
x `elem` xs ==>
and [ x /= x' | x' <- take (firstPosition x xs - 1) xs ]
{-
Here, the function (!!) is a standard function: xs !! i produces the ith element
from the list xs. Counting starts at 0.
Furthermore, take n xs produces the first n elements of the list xs.
-}
remove1 :: Eq a => a -> [a] -> [a]
remove1 = removen 1
removen :: Eq a => Int -> a -> [a] -> [a]
removen 0 _ ys = ys
removen _ _ [] = []
removen n x (y:ys) | x == y = removen (n-1) x ys
| otherwise = y : removen n x ys
prop_RemoveN n x xs =
length (xs \\ removen n x xs) <= n
prop_RemoveNOnlyX n x xs =
and [ x == x' | x' <- xs \\ removen n x xs ]
{-
Here, the function (\\) is a standard function: xs \\ ys removes each element
in ys once from xs.
-}
-------------------------------------------------------------------------
-- 9. More List Comprehensions
pythagoreanTriads :: [(Int,Int,Int)]
pythagoreanTriads = [ (a,b,c)
| a <- [1..100]
, b <- [1..100]
, c <- [1..100]
, a^2 + b^2 == c^2
]
{-
A more efficient version, that also leaves out symmetric solutions
(such as (3,4,5) and (4,3,5)) is:
-}
pythagoreanTriads' :: [(Int,Int,Int)]
pythagoreanTriads' = [ (a,b,c)
| a <- [1..100]
, b <- [a..100]
, let c2 = a^2 + b^2
c = floor (sqrt (fromIntegral c2))
, c <= 100
, c^2 == c2
]
{-
Note: Browse the Haskell libraries, and use GHCi to see what type the
functions floor, sqrt and fromIntegral have and what they do.
-}
prop_Pythagoras =
and [ (a,b,c) `elem` pythagoreanTriads
| (a,b,c) <- pythagoreanTriads'
]
prop_Pythagoras' =
and [ (a,b,c) `elem` pythagoreanTriads'
|| (b,a,c) `elem` pythagoreanTriads'
| (a,b,c) <- pythagoreanTriads
]
---------------------------------------------------------------------------