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))