module Lab10 where

{- EXERCISES -}

interleave :: a -> [a] -> [[a]]
interleave e [] = [[e]]
interleave e l@(x : xs) =
  let smallerInterleave = interleave e xs
  in  (e : l) : map (x :) smallerInterleave

permutations :: [a] -> [[a]]
permutations [] = [[]]
permutations (x : xs) =
  let smallerPerms = permutations xs
  in  concat $ map (interleave x) smallerPerms

type Edge a = (a, a)
data Graph a = Graph
  { vertices :: [a]
  , edges    :: [Edge a]
  }
  deriving Show

gr :: Graph Int
gr = Graph { vertices = [1 .. 6]
           , edges    = [(1, 2), (1, 5), (2, 3), (2, 5), (3, 4), (4, 5), (4, 6)]
           }

isPath :: Eq a => [Edge a] -> [a] -> Bool
isPath edges (x : y : xs) =
  ((x, y) `elem` edges || (y, x) `elem` edges) && isPath edges (y : xs)
isPath _ _ = True

findHamiltonian :: Eq a => Graph a -> [[a]]
findHamiltonian g =
  let vertexPerms = permutations (vertices g)
  in  filter (isPath (edges g)) vertexPerms

data DualNum a = Dn a a
  deriving (Eq, Ord)

instance Show a => Show (DualNum a) where
  show (Dn x x') = show x ++ " + " ++ show x' ++ "eps"

instance Num a => Num (DualNum a) where
  (Dn x x') + (Dn y y') = Dn (x + y) (x' + y')
  (Dn x x') * (Dn y y') = Dn (x * y) (x * y' + x' * y)
  abs (Dn x x') = Dn (abs x) (signum x * x')
  signum (Dn x x') = Dn (signum x) 0
  fromInteger i = Dn (fromInteger i) 0
  negate (Dn x x') = Dn (negate x) (negate x')

f :: Num a => a -> a
f x = x ^ 2 + 1

instance Fractional a => Fractional (DualNum a) where
  (Dn x x') / (Dn y y') = Dn (x / y) ((x' * y - x * y') / (y * y))
  fromRational r = Dn (fromRational r) 0

g :: Fractional a => a -> a
g x = (x ^ 2 - 2) / (x - 1)

sqr :: (Fractional a, Ord a) => a -> a
sqr x = convAbs $ iterate improve 1
 where
  improve r = (r + x / r) / 2
  convAbs (x1 : x2 : xs) | abs (x1 - x2) < 1e-10 = x2
                         | otherwise             = convAbs xs
  convAbs _ = error "end of infinite list"

{- TASKS -}

merge :: Ord b => (a -> b) -> [a] -> [a] -> [a]
merge _ xs [] = xs
merge _ [] ys = ys
merge f lx@(x : xs) ly@(y : ys) =
  let fx = f x
      fy = f y
  in  case compare fx fy of
        LT -> x : merge f xs ly
        EQ -> x : y : merge f xs ys
        GT -> y : merge f lx ys

subseqs :: [a] -> [[a]]
subseqs []       = [[]]
subseqs (x : xs) = merge length (subseqs xs) (map (x :) (subseqs xs))