homeworks

Homework1.hs

module Homework1 where

    data Nat = Zero | Suc Nat
        deriving (Show, Eq)
    
    addNat :: Nat -> Nat -> Nat
    addNat Zero Zero = Zero
    addNat a Zero = a
    addNat Zero b = b
    addNat (Suc a) (Suc b) = addNat (Suc(Suc a)) b

    mulNat :: Nat -> Nat -> Nat
    mulNat Zero a = Zero
    mulNat (Suc(Zero)) a = a
    mulNat (Suc b) a = mulNat b (addNat a a)

    data List a = Nil | Cons a (List a)
        deriving (Show, Ord)
    
    product' :: List Nat -> Nat
    product' Nil = Suc Zero
    product' (Cons a Nil) = a
    product' (Cons a b) = mulNat a (product' b)

    mapList :: (a -> b) -> (List a) -> (List b)
    mapList f Nil = Nil
    mapList f (Cons a Nil) = Cons (f a) Nil
    mapList f (Cons a b) = Cons (f a) (mapList f b)

    (+++) :: List a -> List a -> List a
    (+++) Nil Nil = Nil
    (+++) a Nil = a
    (+++) Nil a = a
    (+++) (Cons a b) d = Cons a ((+++) b d)

    instance Eq a => Eq (List a) where
        (==) Nil Nil = True
        (==) Nil _   = False
        (==) _ Nil   = False
        (==) (Cons x xs) (Cons y ys) = x == y && xs == ys

    -- Leaf :: a -> Tree a b
    -- Bin  :: b -> Tree a b -> Tree a b -> Tree a b
    data Tree a b = Leaf a
                | Bin b (Tree a b) (Tree a b)
        deriving Show
    
    mapTree :: (a -> c) -> (b -> d) -> Tree a b -> Tree c d
    mapTree f _ (Leaf a) = Leaf (f a)
    mapTree f g (Bin b c d) = Bin (g b) (mapTree f g c) (mapTree f g d)
    

Homework10.hs

{-# LANGUAGE InstanceSigs #-}

module Bead where

  import Data.Char
  import Data.List
  import Data.Maybe
  import Control.Applicative
  import Data.List
  import Data.Function (on)
  import Control.Monad.State hiding (ap)
  import Data.Map (Map(..))
  import qualified Data.Map as Map

  ---------------- syntax file ---------------
  data Lit
    = LBool Bool
    | LInt Int
    | LStr String
    deriving (Eq, Ord, Show)

  type Name = String

  newtype Var = Var Name
    deriving (Eq, Ord, Show)

  data Expr
    -- atoms
    = ELit Lit
    | EVar Var
    -- arithmetic
    | Plus Expr Expr
    | Minus Expr Expr
    | Mul Expr Expr
    -- logical
    | And Expr Expr
    | Eq Expr Expr
    | LEq Expr Expr
    | Not Expr
    -- String
    | Concat Expr Expr
    deriving (Eq, Ord, Show)

  data Statement
    = Seq Statement Statement
    | If Expr Statement Statement
    | While Expr Statement
    | Assign Var Expr
    deriving (Eq, Ord, Show)

  ------------ Util file --------------------
  data Operator = OpMul | OpPlus | OpMinus | OpAnd | OpEq | OpLEq | OpConcat
    deriving (Eq, Ord, Show)

  precedence :: Operator -> Int
  precedence OpMul   = 7
  precedence OpPlus  = 6
  precedence OpMinus = 6
  precedence OpAnd   = 3
  precedence OpEq    = 4
  precedence OpLEq   = 4
  precedence OpConcat= 5

  ap :: Operator -> Expr -> Expr -> Expr
  ap OpMul   = Mul
  ap OpPlus  = Plus
  ap OpMinus = Minus
  ap OpAnd   = And
  ap OpEq    = Eq
  ap OpLEq   = LEq
  ap OpConcat = Concat

  data AltList a b = ACons a (AltList b a) | Nil
    deriving (Eq, Ord, Show)

  firsts :: AltList a b -> [a]
  firsts (ACons x xs) = x : seconds xs
  firsts Nil = []

  seconds :: AltList a b -> [b]
  seconds (ACons x xs) = firsts xs
  seconds Nil = []

  -- only works for AltLists with at least 2 elements
  maxPosBy :: (b -> b -> Ordering) -> AltList a b -> Int
  maxPosBy cmp xs
    | ys <- seconds xs
    , iys <- zip [0..] ys
    , (ix,_) <- maximumBy (cmp `on` snd) iys
    = 2*ix

  ----------- ParserBase file ---------------
  newtype Parser a = P { runParser :: String -> [(a, String)] }

  evalParser :: Parser a -> String -> Maybe a
  evalParser p = fmap fst
              . listToMaybe
              . filter (null . snd)
              . runParser p

  instance Functor Parser where
    fmap f (P p) = P (fmap (fmap (mapFst f)) p)
      where mapFst f (x,y) = (f x, y)

  instance Applicative Parser where
    pure :: a -> Parser a
    pure a = P (\s -> [(a,s)])

    (<*>) :: Parser (a -> b) -> Parser a -> Parser b
    (<*>) (P pF) (P pX) = P (\s -> [ (f x,s'') | (f,s') <- pF s, (x,s'') <- pX s'])

    (*>) :: Parser a -> Parser b -> Parser b
    (*>) q p = (\_ y -> y) <$> q <*> p

    (<*) :: Parser a -> Parser b -> Parser a
    (<*) q p = (\x _ -> x) <$> q <*> p

  -- monoid on applicative functors
  instance Alternative Parser where
    empty :: Parser a
    empty = P (const [])

    (<|>) :: Parser a -> Parser a -> Parser a
    (<|>) (P p) (P q) = P (\s -> p s ++ q s)

    some :: Parser a -> Parser [a]
    some p = (:) <$> p <*> many p

    many :: Parser a -> Parser [a]
    many p = some p <|> pure []

  infixl 3 <||>
  (<||>) :: Parser a -> Parser a -> Parser a
  (<||>) (P p) (P q) = P $ \s -> let r = p s in
      if null r then q s else r

  char :: Char -> Parser Char
  char c = matches (== c)

  anyChar :: Parser Char
  anyChar = matches (const True)

  matches :: (Char -> Bool) -> Parser Char
  matches p = P $ \s ->
    case s of
      (x:xs) | p x -> [(x,xs)]
      _ -> []

  digitC :: Parser Char
  digitC = matches isDigit

  letter :: Parser Char
  letter = matches isAlpha

  alphaNum :: Parser Char
  alphaNum = matches isAlphaNum

  -- motivation for Functor instance
  digit :: Parser Int
  digit = fmap digitToInt digitC

  -- motivation for Applicative instance
  tuple :: Parser a -> Parser b -> Parser (a,b)
  tuple p q = (,) <$> (char '(' *> p <* char ',') <*> (q <* char ')')

  -- motivation for Alternative instance
  list :: Parser a -> Parser [a]
  list p = char '[' *> (((:) <$> p <*> list') <|> pure []) <* char ']' where
    list' = many (char ',' *> p)
  
  -- string
  space :: Parser Char
  space = char ' '
  
  string :: Parser String
  string = char '"' *> ((:) <$> (alphaNum <||>  space) <*> (some (alphaNum <||> space)) <|> pure []) <* char '"'

  -- motivation 2 for Applicative
  token' :: String -> Parser String
  token' (c:cs) = (:) <$> char c <*> token' cs
  token' []     = pure ""

  token :: String -> Parser String
  token s = lexeme (token' s)

  nat :: Parser Int
  nat = foldl' (\acc cur -> acc*10 + cur) 0 <$> some digit

  -- parse one whitespace
  ws :: Parser ()
  ws = matches isSpace *> pure ()

  -- parse that p parses then all whitespaces
  lexeme :: Parser a -> Parser a
  lexeme p = p <* many ws

  between :: String -> String -> Parser a -> Parser a
  between before after p =
    token before *> lexeme p <* token after

  --between "asd" "qwe" digit -> "asd   5  qwe  "

  parens :: Parser a -> Parser a
  parens = between "(" ")"

  around :: Parser a -> Parser a
  around p = many ws *> p <* many ws

  digitNat :: Parser (Int, Int)
  digitNat = (,) <$> (digit) <*> nat

  ------------------ ParserWhile file -----------------
  bool :: Parser Bool
  bool = token "true"  *> pure True
    <|> token "false" *> pure False

  lit :: Parser Lit
  lit = LBool <$> lexeme bool
    <|> LInt <$> lexeme nat
    <|> LStr <$> lexeme string

  identifier :: Parser String
  identifier = (:) <$> letter <*> many alphaNum

  var :: Parser Var
  var = Var <$> lexeme identifier

  op :: String -> Parser String
  op s = token s


  expr :: Parser Expr
  expr = lexeme exprNoLRec
    <|> reorderExprChain <$> exprChainE

  exprNoLRec :: Parser Expr
  exprNoLRec = ELit <$> lit
          <||> EVar <$> var
          <||> parens expr
          <||> Not <$> (op "!" *> expr)

  statement :: Parser Statement
  statement = statementNoLRec
          <|> Seq <$> (statementNoLRec <* op ";")
                  <*> lexeme statement

  statementNoLRec :: Parser Statement
  statementNoLRec
    = If <$> (token "if"   *> lexeme expr)
          <*> statement
          <*> (token "else" *> lexeme statement)
          <*  (token "endif")
    <||> Assign <$> (var <* op ":=") <*> expr
    <||> While <$> (token "while" *> lexeme expr)
              <*> statement
              <*  (token "endwhile")

  operator :: Parser Operator
  operator = op "*" *> pure OpMul
        <||> op "++" *> pure OpConcat
        <||> op "+" *> pure OpPlus
        <||> op "-" *> pure OpMinus
        <||> op "&&" *> pure OpAnd
        <||> op "==" *> pure OpEq
        <||> op "<=" *> pure OpLEq

  -- won't allow zero-length expression chains
  exprChainE :: Parser (AltList Expr Operator)
  exprChainE = ACons <$> exprNoLRec <*> exprChainO

  exprChainO :: Parser (AltList Operator Expr)
  exprChainO = ACons <$> operator <*> exprChainE
          <||> pure Nil

  reorderExprChainE :: AltList Expr Operator -> Expr
  reorderExprChainE (ACons e Nil) = e
  reorderExprChainE (ACons e xs) = reorderExprChainO xs e

  reorderExprChainO :: AltList Operator Expr -> Expr -> Expr
  reorderExprChainO (ACons op xs) e = ap op e (reorderExprChainE xs)

  reorderExprChain :: AltList Expr Operator -> Expr
  reorderExprChain Nil = error "Should not have come here"
  reorderExprChain xs@(ACons e Nil) = e
  reorderExprChain xs
    | pos <- maxPosBy (compare `on` precedence) xs
    , ys <- applyAtPos pos xs
    = reorderExprChain ys

  applyAtPos :: Int -> AltList Expr Operator -> AltList Expr Operator
  applyAtPos 0 (ACons lhs (ACons op (ACons rhs xs))) = ACons (ap op lhs rhs) xs
  applyAtPos n (ACons lhs (ACons op xs)) = (ACons lhs (ACons op (applyAtPos (n-2) xs)))
  applyAtPos _ xs = xs


  ------- interpreter file --------------

  data RTVal = RTLit Lit
      deriving (Eq, Ord, Show)

  type Eval a = State (Map Var RTVal) a

  evalLit :: Lit -> Eval RTVal
  evalLit lit = return (RTLit lit)
  
  evalVar :: Var -> Eval RTVal
  evalVar var = do
    vars <- get
    let mVal = Map.lookup var vars
    case mVal of
      Just rtVal -> return rtVal
      Nothing -> error $ "Not defined"
      
  evalExpr :: Expr -> Eval RTVal
  evalExpr (ELit l) = evalLit l
  evalExpr (EVar v) = evalVar v
      
  -- string
  evalExpr (Concat lhs rhs) = do
    l <- evalExpr lhs
    r <- evalExpr rhs
    case (l, r) of
      (RTLit (LStr a), RTLit (LStr b)) -> return $ (RTLit $ LStr (a ++ b))
      _ -> error "invalid types"

Homework2.hs

{-# LANGUAGE FlexibleInstances #-}

module Homework2 where

    import Data.Monoid
    import Data.Foldable

    data RoseTree a = Node { value    :: a
                           , children :: [RoseTree a]
                           }
        deriving (Eq, Show)
    
    haskellTree :: RoseTree String
    haskellTree = Node "Haskell"
                    [ Node "is"
                        [ Node "a" []
                        , Node "purely" []
                        ]
                    , Node "functional"
                        [ Node "programming" []
                        , Node "language" []
                        ]
                    ]

    newtype PreOrder  t a = PreOrder  { getPreOrder  :: t a } deriving (Eq, Show)
    newtype PostOrder t a = PostOrder { getPostOrder :: t a } deriving (Eq, Show)

    instance Foldable (PreOrder RoseTree) where
        foldMap f (PreOrder tree) = f (value tree) `mappend` fold (map (foldMap f) wrapped)
            where
                wrapped = map (\x -> PreOrder x) (children tree)

    instance Foldable (PostOrder RoseTree) where
        foldMap f (PostOrder tree) = fold (map (foldMap f) wrapped) `mappend` f (value tree)
            where
                wrapped = map (\x -> PostOrder x) (children tree)
    
    preOrder  :: RoseTree a -> [a]
    preOrder tree = toList $ PreOrder tree

    postOrder :: RoseTree a -> [a]
    postOrder tree = toList $ PostOrder tree

    m1 :: RoseTree a -> [a]
    m1 tree = value tree :  foldMap m1 (children tree)

    m1' :: PreOrder RoseTree a -> [a]
    -- here the foldMap is not equal to the foldMap above, that foldMap is the m1' here
    -- to solve this, we can use fold ( map ...) above in the Foldable stuff
    m1' (PreOrder tree) = value tree : foldMap m1' (map (\x -> PreOrder x) (children tree))

    m2 :: RoseTree a -> [a]
    m2 tree = foldMap m2 (children tree) ++ [value tree]

    -- "Haskell is a purely functional programming language" == unwords (preOrder haskellTree)
    -- "a purely is programming language functional Haskell" == unwords (postOrder haskellTree)

Homework3.hs

{-# LANGUAGE FlexibleInstances #-}

-- source: http://hackage.haskell.org/package/dlist-0.8.0.5/docs/src/Data.DList.html#fromList

module Homework3 where
    import Prelude hiding (concat)

    newtype DList a = DL { unDL :: [a] -> [a] } deriving (Show)

    instance Show ([a] -> [a]) where
        show a = "something"

    fromList    :: [a] -> DList a
    fromList    = DL . (++)

    toList      :: DList a -> [a]
    toList      = ($[]) . unDL

    apply       :: DList a -> [a] -> [a]
    apply       = unDL

    empty :: DList a
    empty = DL id

    singleton :: a -> DList a
    singleton   = DL . (:)

    cons        :: a -> DList a -> DList a
    cons x xs   = DL ((x:) . unDL xs)

    snoc :: DList a -> a -> DList a
    snoc xs x = DL (unDL xs . (x:))

    append :: DList a -> DList a -> DList a
    append a b = DL (unDL a . unDL b)

    concat :: [DList a] -> DList a
    concat = foldr append empty

Homework4.hs

module Homework4 where

    newtype F1 x a   = F1 (x -> a)
    newtype F2 x a   = F2 ((a -> x) -> a)
    newtype F3 x y a = F3 ((a -> x) -> (a -> y) -> a)
    newtype F4 x y a = F4 (((y -> a) -> x) -> a)
    newtype F5 x a   = F5 (x -> (x -> a))
    newtype F6 x y a = F6 (x -> (a -> y) -> (x -> a))
    newtype F7 x y a = F7 (x -> ((a -> x) -> a))

    instance Functor (F1 x) where
        fmap f (F1 g) =  F1 (f . g)
    
    instance Functor (F2 x) where
        fmap f (F2 g) = F2 (\h -> f (g (h . f)))
    
    instance Functor (F3 x y) where
        fmap f (F3 g) = F3 (\p1 p2 -> f (g (p1 . f) (p2 . f)))
    
    instance Functor (F4 x y) where
        fmap f (F4 g) = F4 (\h -> (f (g (\i -> h (f . i)))))

    instance Functor (F5 x) where
        fmap f (F5 g) = F5 (\h -> f . (g h))
    
    instance Functor (F6 x y) where
        fmap f (F6 g) = F6 (\p1 p2 p3 -> (f (g p1 (p2 . f) p3)))
    
    instance Functor (F7 x y) where
        fmap f (F7 g) = F7 (\h -> (\i ->  (f (g h (i . f))) ))

Homework8.hs

{-# LANGUAGE InstanceSigs #-}

module State where
    newtype State s a = S { runState :: s -> (a,s)}
    
    instance Functor (State s) where
        fmap :: (a -> b) -> State s a -> State s b
        fmap f (S g) = S $ \s -> let (x, s') = g s in (f x, s')
    
    instance Applicative (State s) where
        pure x =  S (\s -> (x,s))
        
        (<*>) :: State s (a -> b) -> State s a -> State s b
        (<*>) (S sF) (S sG) = S (\s -> let 
            (ab, s1) = sF s 
            (a, s2) = sG s1
            in (ab a, s2) )
 
    instance Monad (State s) where
        return = pure
        
        (>>=) :: State s a -> (a -> State s b) -> State s b
        (>>=) (S f) g = S $ \s -> 
            let
                (a, s1) = f s
            in 
                runState (g a) s1

    evalState :: State s a -> s -> a
    evalState s = fst . runState s

    execState :: State s a -> s -> s
    execState s = snd . runState s

    get :: State s s
    get = S $ \s -> (s, s)

    put :: s -> State s ()
    put sa = S $ \s -> ((), sa)

    stateLength :: [a] -> State Int [a]
    stateLength xs = S $ \s -> (xs, length xs)

Homework9.hs

module Interpreter where

  import Control.Monad.State
  import Data.Map (Map(..))
  import qualified Data.Map as Map

  data Lit
    = LBool Bool
    | LInt Int
      deriving (Eq, Ord, Show)
  
  type Name = String
  
  newtype Var = Var Name
    deriving (Eq, Ord, Show)
  
  data Expr
    -- atoms
    = ELit Lit
    | EVar Var
    -- arithmetic
    | Plus Expr Expr
    | Minus Expr Expr
    | Mul Expr Expr
    -- logical
    | And Expr Expr
    | Eq Expr Expr
    | LEq Expr Expr
    | Not Expr
    deriving (Eq, Ord, Show)
  
  data Statement
    = Seq Statement Statement
    | If Expr Statement Statement
    | While Expr Statement
    | Assign Var Expr
    deriving (Eq, Ord, Show)
  

  data RTVal = RTLit Lit
      deriving (Eq, Ord, Show)

  type Eval a = State (Map Var RTVal) a

  evalLit :: Lit -> Eval RTVal
  evalLit lit = return (RTLit lit)
  
  evalVar :: Var -> Eval RTVal
  evalVar var = do
    vars <- get
    let mVal = Map.lookup var vars  -- ha tiszta a value, akkor let
    case mVal of
      Just rtVal -> return rtVal
      Nothing -> error $ "Not defined"
      
  evalExpr :: Expr -> Eval RTVal
  evalExpr (ELit l) = evalLit l
  evalExpr (EVar v) = evalVar v
  
  -- Arithmetic types
  evalExpr (Plus lhs rhs) = do
    l <- evalExpr lhs  -- ha monadikus a value, akkor bind
    r <- evalExpr rhs
    case (l, r) of
      (RTLit (LInt a), RTLit (LInt b)) -> return $ (RTLit $ LInt (a + b))
      _ -> error "invalid types"
  
  evalExpr (Minus lhs rhs) = do
    l <- evalExpr lhs
    r <- evalExpr rhs
    case (l, r) of
      (RTLit (LInt a), RTLit (LInt b)) -> return $ (RTLit $ LInt (a - b))
      _ -> error "invalid types"
  
  evalExpr (Mul lhs rhs) = do
    l <- evalExpr lhs
    r <- evalExpr rhs
    case (l, r) of
      (RTLit (LInt a), RTLit (LInt b)) -> return $ (RTLit $ LInt (a * b))
      _ -> error "invalid types"
  
  -- logical types

  evalExpr (And lhs rhs) = do
    l <- evalExpr lhs
    r <- evalExpr rhs
    case (l, r) of
      (RTLit (LBool a), RTLit (LBool b)) -> return $ (RTLit $ LBool (a && b))
      _ -> error "invalid types"

  evalExpr (Eq lhs rhs) = do
    l <- evalExpr lhs
    r <- evalExpr rhs
    case (l, r) of
      (RTLit (LBool a), RTLit (LBool b)) -> return $ (RTLit $ LBool (a == b))
      (RTLit (LInt a), RTLit (LInt b)) -> return $ (RTLit $ LBool (a == b))
      _ -> error "invalid types"

  evalExpr (LEq lhs rhs) = do
    l <- evalExpr lhs
    r <- evalExpr rhs
    case (l, r) of
      (RTLit (LBool a), RTLit (LBool b)) -> return $ (RTLit $ LBool (a <= b))
      (RTLit (LInt a), RTLit (LInt b)) -> return $ (RTLit $ LBool (a <= b))
      _ -> error "invalid types"

  evalExpr (Not expr) = do
    val <- evalExpr expr
    case (val) of
      (RTLit (LBool val)) -> return $ (RTLit $ LBool (not val))
      _ -> error "invalid types"


  evalWhile :: Statement -> Eval ()
  evalWhile (Seq p q) = evalWhile p >> evalWhile q -- futtasd le az elsot, nem erdekel az eredmeny, futtasd le a masodikat is
  evalWhile (Assign v expr) = do
    val <- evalExpr expr
    -- verzio egy
    vars <- get
    let vars' = Map.insert v val vars
    put vars'
    -- VAAAGY verzio ketto
    -- modify $ Map.insert v val vars
  
  evalWhile (If expr p q) = do
    isTrue <- evalExpr expr
    case isTrue of
      (RTLit (LBool True)) -> evalWhile p
      _ -> evalWhile q
    
  evalWhile (While expr p) = do

    isTrue <- evalExpr expr
    case isTrue of
      (RTLit (LBool True)) -> evalWhile p >> evalWhile (While expr p)
      _ -> return ()