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
      ]

---------------------------------------------------------------------------