-- D. Sannella. M Fourman, H. Peng and P. Wadler
-- Introduction to Computation: Haskell, Logic and Automata
-- Undergraduate Topics in Computer Science, Springer (2021)
-- ISBN 978-3-030-76907

-- Chapter 26 : Combinatorial Algorithms

module Chap26_combinatorial_algorithms where

import Test.QuickCheck (quickCheck, quickCheckWith, stdArgs, maxSize, Property, (==>))

import Data.List (sort)

-- Repetitions in a list

-- ** nub is from Data.List
nub :: Eq a => [a] -> [a]
nub []     = []
nub (x:xs) = x : nub [ y | y <- xs, x /= y ]

distinct :: Eq a => [a] -> Bool
distinct xs = xs == nub xs

b0 = distinct "avocado"

b1 = distinct "peach"

-- Sublists

sub :: Eq a => [a] -> [a] -> Bool
xs `sub` ys = and [ x `elem` ys | x <- xs ]

b2 = "pea" `sub` "apple"

b3 = "peach" `sub` "apple"

subs :: [a] -> [[a]]
subs []     = [[]]
subs (x:xs) = subs xs ++ map (x:) (subs xs)

ls0 = subs [0,1]

ls1 = subs "abc"

subs_prop :: [Int] -> Property
subs_prop xs =
  distinct xs ==>
    and [ ys `sub` xs | ys <- subs xs ]
    && distinct (subs xs)
    && all distinct (subs xs)
    && length (subs xs) == 2 ^ length xs

sizeCheck n = quickCheckWith (stdArgs {maxSize = n})

qc0 = sizeCheck 10 subs_prop

-- Cartesian product

cpair :: [a] -> [b] -> [(a,b)]
cpair xs ys = [ (x,y) | x <- xs, y <- ys ]

cp :: [[a]] -> [[a]]
cp []       = [[]]
cp (xs:xss) = [ y:ys | y <- xs, ys <- cp xss ]

cp_prop :: [[Int]] -> Property
cp_prop xss =
  distinct (concat xss) ==>
    and [ and [ elem (ys !! i) (xss !! i)
                | i <- [0..length xss-1] ]
          | ys <- cp xss ]
    && distinct (cp xss)
    && all distinct (cp xss)
    && all (\ys -> length ys == length xss) (cp xss)
    && length (cp xss) == product (map length xss)

qc1 = quickCheck cp_prop

qc1' = sizeCheck 10 cp_prop

-- Permutations of a list


permscp :: Eq a => [a] -> [[a]]
permscp xs | distinct xs =
  [ ys | ys <- cp (replicate (length xs) xs), distinct ys ]

permscp_prop :: [Int] -> Property
permscp_prop xs =
  distinct xs ==> 
    and [ sort ys == sort xs | ys <- permscp xs ]
    && distinct (permscp xs)
    && all distinct (permscp xs)
    && length (permscp xs) == fac (length xs)

fac :: Int -> Int
fac n | n >= 0 = product [1..n]

qc2 = sizeCheck 10 permscp_prop

splits :: [a] -> [(a, [a])]
splits xs =
  [ (xs!!k, take k xs ++ drop (k+1) xs) | k <- [0..length xs-1] ]

ps0 = splits "abc"

splits_prop :: [Int] -> Property
splits_prop xs =
  distinct xs ==>
    and [ sort (y:ys) == sort xs | (y,ys) <- splits xs ]
    && and [ 1 + length ys == length xs | (y,ys) <- splits xs ]
    && distinct (map snd (splits xs))
    && distinct (map fst (splits xs))
    && all distinct (map snd (splits xs))
    && length (splits xs) == length xs

qc3 = quickCheck splits_prop

perms :: [a] -> [[a]]
perms []     = [[]]
perms (x:xs) = [ y:zs | (y,ys) <- splits (x:xs), zs <- perms ys ]

ls2 = perms "abc"

perms_prop :: [Int] -> Property
perms_prop xs =
  distinct xs ==> 
    and [ sort ys == sort xs | ys <- perms xs ]
    && distinct (perms xs)
    && all distinct (perms xs)
    && length (perms xs) == fac (length xs)

qc4 = sizeCheck 10 perms_prop

perms_permscp_prop :: [Int] -> Property
perms_permscp_prop xs =
  distinct xs ==> perms xs == permscp xs

qc5 = sizeCheck 10 perms_permscp_prop

-- Choosing k elements from a list

choose :: Int -> [a] -> [[a]]
choose 0 xs             = [[]]
choose k []     | k > 0 = []
choose k (x:xs) | k > 0 =
  choose k xs ++ map (x:) (choose (k-1) xs)

ls3 = choose 3 "abcde"

choose_prop :: Int -> [Int] -> Property
choose_prop k xs =
  0 <= k && k <= n && distinct xs ==>
    and [ ys `sub` xs && length ys == k | ys <- choose k xs ]
    && distinct (choose k xs)
    && all distinct (choose k xs)
    && length (choose k xs) == fac n `div` (fac k * fac (n-k))
      where n = length xs

choose_length_prop :: [Int] -> Bool
choose_length_prop xs =
  sum [ length (choose k xs) | k <- [0..n] ] == 2^n
    where n = length xs

choose_subs_prop :: [Int] -> Bool
choose_subs_prop xs =
  sort [ ys | k <- [0..n], ys <- choose k xs ] == sort (subs xs)
    where n = length xs

qc6 = sizeCheck 10 choose_prop

qc6' = sizeCheck 10 choose_length_prop

qc6'' = sizeCheck 10 choose_subs_prop

-- Partitions of a number

partitions :: Int -> [[Int]]
partitions 0 = [[]]
partitions n | n > 0
  = [ k : xs | k <- [1..n], xs <- partitions (n-k), all (k <=) xs ]

ls4 = partitions 5

partitions_prop :: Int -> Property
partitions_prop n  =
  n >= 0 ==> all ((== n) . sum) (partitions n)
  
partitions_prop' :: [Int] -> Property
partitions_prop' xs =
  all (> 0) xs ==> sort xs `elem` partitions (sum xs)

qc7 = sizeCheck 10 partitions_prop

qc7' = sizeCheck 8 partitions_prop'

-- Making change

type Coin = Int
type Total = Int

change :: Total -> [Coin] -> [[Coin]]
change n xs = change' n (sort xs)
  where change' 0 xs         = [[]]
        change' n xs | n > 0 =
          [ y : zs | (y, ys) <- nub (splits xs),
                     y <= n,
                     zs <- change' (n-y) (filter (y <=) ys) ]

ls5 = change 30 [5,5,10,10,20]

change_prop :: Total -> [Coin] -> Property
change_prop n xs =
  0 <= n && all (0 <) xs ==>
    all ((== n) . sum) (change n xs)

qc8 = sizeCheck 10 change_prop

-- Eight queens problem

type Row   = Int
type Col   = Int
type Coord = (Col, Row)
type Board = [Row]

queens :: Col -> [Board]
queens 0         = [[]]
queens n | n > 0 =
  [ q:qs | q <- [1..8],
           qs <- queens (n-1),
           and [ not (attack (1,q) (x,y))
               | (x,y) <- zip [2..n] qs ] ]

attack :: Coord -> Coord -> Bool
attack (x,y) (x',y') =
  x == x'         -- both in the same column
  || y == y'      -- both in the same row
  || x+y == x'+y' -- both on the line y = -x + b
  || x-y == x'-y' -- both on the line y = x + b

q8 = head (queens 8)

i0 = length (queens 8)

queens' :: [Board]
queens' = filter ok (perms [1..8])

ok :: Board -> Bool
ok qs = and [ not (attack' p p') | [p,p'] <- choose 2 (coords qs) ]

coords :: Board -> [Coord]
coords qs = zip [1..] qs
                 
attack' :: Coord -> Coord -> Bool
attack' (x,y) (x',y') = abs (x-x') == abs (y-y')

q8' = head queens'

i0' = length queens'

-- Exercise 7

fib :: Int -> Int
fib 0 = 0
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

fiblist :: [Int]
fiblist = map fib' [0..]

fib' :: Int -> Int
fib' 0 = 0
fib' 1 = 1
fib' n = fiblist!!(n-1) + fiblist!!(n-2)