module Fp10 where
--import Control.Monad.Instances
import Control.Applicative
--import Control.Monad.Identity
--import Data.Monoid
--import Data.Maybe
--import Control.Monad.Writer
--import Control.Monad.Reader
--import Control.Monad.State
import Data.Char
import Control.Monad.Error
import Control.Monad.Cont
import Control.Monad.State
import Control.Monad.Identity



-- github.com/feuerbach/regex-applicative/
-- cabal install regex-applicative
--import Text.Regex.Applicative


-- *Fp10> Nothing <|> (Just 3) <|> (Just 5) <|> Nothing
-- Just 3

-- *Fp10> match (sym 'a' <|> sym 'b') "a"
-- Just 'a'
-- *Fp10> match (many $ psym isAlpha) "abc"
-- Just "abc"
-- *Fp10> match (many $ psym isAlpha) "123"
-- Nothing
-- *Fp10> match (many $ psym isAlpha) ""
-- Just ""
-- *Fp10> match (some $ psym isAlpha) ""
-- Nothing

-- 
-- *Fp10> Nothing `mplus` (Just 3) `mplus` (Just 5) `mplus` Nothing
-- Just 3

pythags = do
  z <- [1..]
  x <- [1..z]
  y <- [x..z]
  guard (x^2 + y^2 == z^2)
  return (x, y, z)

-- *Fp10> take 5 pythags
-- [(3,4,5),(6,8,10),(5,12,13),(9,12,15),(8,15,17)]

--------------------------------------------------
-- Continuation passing style (CPS)

square :: Int -> (Int -> r) -> r
square x k = k $ x^2

add :: Int -> Int -> (Int -> r) -> r
add x y k = k $ x + y

sum_squares :: Int -> Int -> (Int -> r) -> r
sum_squares x y k =
  square x  $ \x2 ->
  square y  $ \y2 ->
  add x2 y2 $ \ss ->
  k ss

-- *Fp10> sum_squares 3 4 print
-- 25

-- То же, но через монаду Cont

add' :: Int -> Int -> Cont r Int
add' x y = return $ x + y

square' :: Int -> Cont r Int
square' x = return $ x^2

sum_squares' :: Int -> Int -> Cont r Int
sum_squares' x y = do
  x2 <- square' x
  y2 <- square' y
  ss <- add' x2 y2
  return ss

-- *Fp10> runCont (sum_squares' 3 4) print
-- 25

square'' :: Int -> Cont r Int
square'' x = callCC $ \k -> k $ x^2

-- *Fp10> runCont (square'' 6) print
-- 36

foo :: Cont r Int
foo = callCC $ \k -> do
    let x = 2
    k x
    return 5 -- никогда не выполнится!


roots :: (Double,Double,Double) -> Cont r String
roots (a,b,c) =  callCC $ \k -> do
    let delta = b^2 - 4 * a * c
    when (delta < 0) $ k "No roots!"
    let sqrt_delta = sqrt delta
    let x1 = (-b - sqrt_delta) / (2 * a)
    let x2 = (-b + sqrt_delta) / (2 * a)
    return $ "Roots are " ++ show x1 ++ ", " ++ show x2

-- *Fp10> runCont (roots (1,5,6)) print
-- "Roots are -3.0, -2.0"
-- *Fp10> runCont (roots (1,4,6)) print
-- "No roots!"


stInteger :: State Integer Integer       
stInteger = do modify (+1)
               a <- get
               return a
         
stString :: State String String       
stString = do modify (++"1")
              b <- get
              return b

-- *Fp10> evalState stInteger 0
-- 1
-- *Fp10> evalState stString "0"
-- "01"

stComb :: StateT Integer (StateT String Identity) (Integer, String)      
stComb = do modify (+1)
            lift $ modify (++"1")
            a <- get
            b <- lift $ get
            return (a,b)

-- *Fp10> runIdentity $ evalStateT (evalStateT stComb 0) "0"
-- (1,"01")



