fpc-11-10-2017.hs

{- Classtype implementation details -}

class C a where
  f1 :: a -> Bool
  f2 :: Int -> a

instance C Integer where
  f1 x = x == 0
  f2 x = fromIntegral x

g :: (C a) => a -> a
g x = if f1 x then f2 0 else f2 1

data C' a = MkC { f1' :: (a -> Bool), f2' :: (Int -> a) }

integer_C' :: C' Integer
integer_C' = MkC { f1' = \x -> x == 0, f2' = \x -> fromIntegral x }

g' :: C' a -> a -> a
g' dict x = if f1' dict x then f2' dict 0 else f2' dict 1

{- Tree: Eq, elemTree -}

data Tree a
  = Leaf a
  | Branch (Tree a) a (Tree a)

instance Eq a => Eq (Tree a) where
  Leaf x1 == Leaf x2 = x1 == x2
  Leaf _ == _ = False
  Branch l1 x1 r1 == Branch l2 x2 r2 = x1 == x2 && l1 == l2 && r1 == r2
  Branch _ _ _ == _ = False

treeFromList :: [a] -> Tree a
treeFromList [] = error "Cannot construct from empty list"
treeFromList [x] = Leaf x
treeFromList [x,_] = Leaf x
treeFromList (x:xs) = Branch (treeFromList lxs) x (treeFromList rxs)
 where (lxs, rxs) = splitAt (length xs `div` 2) xs

elemTree :: Eq a => a -> Tree a -> Bool
elemTree x (Leaf y) = x == y
elemTree x (Branch l y r) = x == y || elemTree x l || elemTree x r

infiniteLTree :: Tree Int
infiniteLTree = go 0
 where go x = Branch (go (x + 2)) x (Leaf (x + 1))

elemTree' :: Eq a => a -> Tree a -> Bool
elemTree' x t = go [t]
 where go [] = False
       go (Leaf y : acc) = x == y || go acc
       go (Branch l y r : acc) = x == y || go (acc ++ [l,r])

instance Functor Tree where
  fmap f (Leaf x) = Leaf (f x)
  fmap f (Branch l x r) = Branch (fmap f l) (f x) (fmap f r)

{- Show -}

data List a
  = Nil
  | Cons a (List a)

listFromList :: [a] -> List a
listFromList [] = Nil
listFromList (x : xs) = Cons x (listFromList xs)

{-
instance (Show a) => Show (List a) where
  show Nil = "Nil"
  show (Cons x xs) = show xs ++ ";" ++ show x
-- [] ++ ys = ys
-- (x:xs) ++ ys = x : (xs ++ ys)
-- show (Cons 1 (Cons 2 (Cons 3 Nil))) = (("Nil" ++ (';' : "3")) ++ (';' : "2")) ++ (';' : "1")
-- type ShowS = String -> String
-- shows :: a -> ShowS
-- shows 1 "abcd" = "1abcd"
-- show x = shows x ""
-}

{-
instance (Show a) => Show (List a) where
  showsPrec _ Nil = ("Nil" ++)
  showsPrec _ (Cons x xs) = shows xs . (";" ++) . shows x
-- show (Cons 1 (Cons 2 (Cons 3 Nil))) =
-- (((("Nil" ++) . ((";" ++) . ("3" ++))) . ((";" ++) . ("2" ++))) . ((";" ++) . ("1" ++))) ""
-}

instance (Show a) => Show (List a) where
  showsPrec _ Nil = ("|" ++)
  showsPrec _ (Cons x xs) = ("<" ++) . shows x . shows xs . (">" ++)

instance (Show a) => Show (Tree a) where
  showsPrec _ (Leaf x) = shows x
  showsPrec _ (Branch l x r) = ("<" ++) . shows l . ("{" ++) . shows x . ("}" ++) . shows r . (">" ++)

infixr 7 :*
infixr 6 :+

data Cartesian7 a b = a :* b
  deriving Show

data Cartesian6 a b = a :+ b
  deriving Show

{- Read -}

{-
instance (Read a) => Read (List a) where
  readsPrec _ ('|':rest) = [(Nil, rest)]
  readsPrec _ ('<':rest) =
    flip concatMap (reads rest) $ \(x, rest') ->
      flip concatMap (reads rest') $ \(xs, rest'') ->
        case rest'' of
          '>':rest''' -> [(Cons x xs, rest''')]
          _ -> []
-}

readChar :: Char -> ReadS Char
readChar c [] = []
readChar c (x:xs)
 | c == x = [(c, xs)]
 | otherwise = []

{-
instance (Read a) => Read (List a) where
  readsPrec _ str =
    (flip concatMap (readChar '|' str) $ \(_, rest) -> [(Nil, rest)])
    ++
    (flip concatMap (readChar '<' str) $ \(_, rest) ->
      flip concatMap (reads rest) $ \(x, rest') ->
        flip concatMap (reads rest') $ \(xs, rest'') ->
          flip concatMap (readChar '>' rest'') $ \(_, rest''') ->
            [(Cons x xs, rest''')])
-}

instance (Read a) => Read (List a) where
  readsPrec _ str =
    [ (Nil, rest)
    | (_, rest) <- readChar '|' str
    ]
    ++
    [ (Cons x xs, rest''')
    | (_, rest) <- readChar '<' str
    , (x, rest') <- reads rest
    , (xs, rest'') <- reads rest'
    , (_, rest''') <- readChar '>' rest''
    ]

instance Read a => Read (Tree a) where
  readsPrec _ str =
    [ (Leaf x, rest)
    | (x, rest) <- reads str
    ]
    ++
    [ (Branch l x r, rest'''''')
    | (_, rest) <- readChar '<' str
    , (l, rest') <- reads rest
    , (_, rest'') <- readChar '{' rest'
    , (x, rest''') <- reads rest''
    , (_, rest'''') <- readChar '}' rest'''
    , (r, rest''''') <- reads rest''''
    , (_, rest'''''') <- readChar '>' rest'''''
    ]