fpc-20-12-2017.hs

diff --git a/classwork.cabal b/classwork.cabal
index 514e71b..853789b 100644
--- a/classwork.cabal
++ b/classwork.cabal
@@ -19,4 +19,5 @@ executable classwork
   other-modules:       Parser
   default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5,
-                       containers
                       containers,
                       mtl
diff --git a/src/Main.hs b/src/Main.hs
index d88e8a4..2aec7b1 100644
--- a/src/Main.hs
++ b/src/Main.hs
@@ -3,8 +3,213 @@
 
 
 
{-# LANGUAGE RankNTypes #-}
 module Main where
 
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.State

data Tree a
  = Leaf
  | Node (Tree a) a (Tree a)
  deriving Show

fromList :: [a] -> Tree a
fromList [] = Leaf
fromList nodes =
  let (left_nodes, x : right_nodes) =
        splitAt (length nodes `div` 2) nodes
  in Node (fromList left_nodes) x (fromList right_nodes)

-- T(a) = 1 + a * T^2(a)
-- T'(a) = T^2(a) + 2 * a * T(a) * T'(a)
-- T'(a) * (1 - 2 * a * T(a)) = T^2(a)
-- T'(a) = T^2(a) / (1 - 2 * a * T(a))
-- T'(a) = T^2(a) * L(2 * a * T(a))

data Direction = L | R

data TreeZip a = TreeZip
  { val :: Maybe a
  , ltree :: Tree a
  , rtree :: Tree a
  , parents :: [(Direction, Tree a, a)]
  }

zipFromTree :: Tree a -> TreeZip a
zipFromTree Leaf = TreeZip
  { val = Nothing
  , ltree = Leaf
  , rtree = Leaf
  , parents = []
  }
zipFromTree (Node l x r) = TreeZip
  { val = Just x
  , ltree = l
  , rtree = r
  , parents = []
  }

treeAtTip :: TreeZip a -> Tree a
treeAtTip TreeZip { val = Nothing } = Leaf
treeAtTip tz@(TreeZip { val = Just v }) =
  Node (ltree tz) v (rtree tz)

goLeft :: TreeZip a -> TreeZip a
goLeft tz@(TreeZip { val = Nothing }) = tz
goLeft tz@(TreeZip { val = Just v }) =
  (zipFromTree (ltree tz))
    { parents = (L, rtree tz, v) : parents tz
    }

goRight :: TreeZip a -> TreeZip a
goRight tz@(TreeZip { val = Nothing }) = tz
goRight tz@(TreeZip { val = Just v }) =
  (zipFromTree (rtree tz))
    { parents = (R, ltree tz, v) : parents tz
    }

goUp :: TreeZip a -> TreeZip a
goUp tz@(TreeZip { parents = [] }) = tz
goUp tz@(TreeZip { parents = (L, rtree, v) : grandparents }) =
  TreeZip { val = Just v
          , ltree = treeAtTip tz
          , rtree = rtree
          , parents = grandparents
          }
goUp tz@(TreeZip { parents = (R, ltree, v) : grandparents }) =
  TreeZip { val = Just v
          , ltree = ltree
          , rtree = treeAtTip tz
          , parents = grandparents
          }

interactive :: Show a => Tree a -> IO ()
interactive t = evalStateT go (zipFromTree t)
 where
  go :: Show a => StateT (TreeZip a) IO ()
  go = do
    x <- liftIO $ getLine
    case x of
      "q" -> pure ()
      "l" -> perform goLeft >> go
      "r" -> perform goRight >> go
      "u" -> perform goUp >> go
      _ -> liftIO (putStrLn "Unknown command") >> go
  perform :: Show a
          => (TreeZip a -> TreeZip a)
          -> StateT (TreeZip a) IO ()
  perform f = do
    modify f
    v <- val <$> get
    liftIO (putStr "Current value: ")
    liftIO (print v)

data Person = Person { name :: String, address :: Address }
  deriving Show
data Address = Address { street :: String, building :: Building }
  deriving Show
data Building = Building { number :: Int, litera :: Char }
  deriving Show

person :: Person
person = Person
  { name = "Name"
  , address = Address
    { street = "Street"
    , building = Building
      { number = 2
      , litera = 'c'
      }
    }
  }

setNumber :: Person -> Int -> Person
setNumber p n = p
  { address = (address p)
    { building = (building (address p))
      { number = n
      }
    }
  }

-- data Lens s a
-- view :: Lens s a -> s -> a
-- set :: Lens s a -> a -> s -> s
-- compose :: Lens t a -> Lens s t -> Lens s a
--
-- lAddress :: Lens Person Address
-- lBuilding :: Lens Address Building
-- lNumber :: Lens Building Int

setNumber' :: Person -> Int -> Person
setNumber' p n =
  set (lNumber `compose` lBuilding `compose` lAddress) n p

{-
data Lens s a = Lens { view :: s -> a, set :: a -> s -> s }

compose :: Lens t a -> Lens s t -> Lens s a
compose lhs rhs = Lens
  { view = view lhs . view rhs
  , set = \v s -> set rhs ((set lhs v) (view rhs s)) s
  }

lAddress :: Lens Person Address
lAddress = Lens { view = address, set = \v s -> s { address = v } }

lBuilding :: Lens Address Building
lBuilding = Lens { view = building, set = \v s -> s { building = v } }

lNumber :: Lens Building Int
lNumber = Lens { view = number, set = \v s -> s { number = v } }

over :: Lens s a -> (a -> a) -> s -> s
over l f s = set l (f (view l s)) s
-}

{-
data Lens s a = Lens
  { view :: s -> a
  , set :: a -> s -> s
  , over :: (a -> a) -> s -> s
  , overMaybe :: (a -> Maybe a) -> s -> Maybe s
  , overIO :: (a -> IO a) -> s -> IO s
  , overF :: Functor f => (a -> f a) -> s -> f s
  }
-}

type Lens s a = forall f. Functor f => (a -> f a) -> (s -> f s)

over :: Lens s a -> (a -> a) -> s -> s
over l f s = runIdentity $ l (\x -> Identity (f x)) s

set :: Lens s a -> a -> s -> s
set l x s = over l (const x) s

compose :: Lens t a -> Lens s t -> Lens s a
compose lhs rhs = rhs . lhs

-- data Const v a = Const v
--
-- getConst :: Const v a -> v
--
-- instance Functor (Const v) where
--   fmap f (Const v) = Const v

view :: Lens s a -> s -> a
view l s = getConst (l Const s)

lAddress :: Lens Person Address
lAddress f s = (\v -> s { address = v }) <$> (f (address s))

lBuilding :: Lens Address Building
lBuilding f s = (\v -> s { building = v }) <$> (f (building s))

lNumber :: Lens Building Int
lNumber f s = (\v -> s { number = v }) <$> (f (number s))