module Alga.Language.Eval
( evalDef
, eval
, toPrin )
where
import Alga.Language.Element
import Alga.Language.Environment
import Alga.Language.SyntaxTree
import Control.Arrow ((***))
import Control.Monad.State.Lazy
import Data.List (tails)
import Data.Maybe (listToMaybe)
import Data.Monoid ((<>))
import System.Random (next)
import System.Random.TF (TFGen)
data CalcSt = CalcSt
{ clHistory :: [NRatio]
, clRandGen :: TFGen
} deriving Show
evalDef :: HasEnv m
=> String
-> m [NRatio]
evalDef name = getPrin name >>= eval
eval :: HasEnv m
=> SyntaxTree
-> m [NRatio]
eval tree = liftM2 runCalc (resolve . cycle' <$> toPrin tree) newRandGen
where cycle' p = if null $ foldMap (:[]) (Sec p) then [] else cycle p
resolve :: MonadState CalcSt m
=> Principle
-> m [NRatio]
resolve [] = return []
resolve xs = concat <$> mapM f xs
where f (Val x) = addHistory x >> return [x]
f (Sec x) = resolve x
f (Mul x) = choice x >>= maybe (return []) f
f (CMul x) = listToMaybe <$> filterM (matchHistory . fst) x >>=
maybe (f . toMul $ x) (f . Mul . snd)
runCalc
:: State CalcSt a
-> TFGen
-> a
runCalc m gen = evalState m CalcSt
{ clHistory = mempty
, clRandGen = gen }
choice :: MonadState CalcSt m
=> [a]
-> m (Maybe a)
choice [] = return Nothing
choice xs = do
(n, g) <- next <$> gets clRandGen
modify $ \c -> c { clRandGen = g }
return . Just $ xs !! (abs n `rem` length xs)
condMatch :: [NRatio] -> Element NRatio -> Bool
condMatch [] _ = False
condMatch (h:_) (Val x) = h == x
condMatch hs (Sec x) = and $ zipWith condMatch (tails hs) (reverse x)
condMatch hs (Mul x) = or $ condMatch hs <$> x
condMatch hs (CMul x) = condMatch hs (toMul x)
toMul
:: [([Element NRatio], [Element NRatio])]
-> Element NRatio
toMul xs = Mul (xs >>= snd)
matchHistory :: MonadState CalcSt m
=> [Element NRatio]
-> m Bool
matchHistory x = do
hs <- gets clHistory
return . or $ condMatch hs <$> x
addHistory :: MonadState CalcSt m => NRatio -> m ()
addHistory x = modify $ \c -> c { clHistory = return x <> clHistory c }
toPrin :: HasEnv m
=> SyntaxTree
-> m Principle
toPrin = fmap simplifySec . toPrin'
simplifySec :: Principle -> Principle
simplifySec = (>>= f)
where f (Sec xs) = simplifySec xs
f x = simplifyElt x
simplify :: Principle -> Principle
simplify = (>>= simplifyElt)
simplifyElt :: Element NRatio -> Principle
simplifyElt x@(Val _) = [x]
simplifyElt (Sec [x]) = simplify [x]
simplifyElt (Mul [x]) = simplify [x]
simplifyElt (CMul [(_, xs)]) = simplifyElt (Mul xs)
simplifyElt (Sec xs) = [Sec (simplifySec xs)]
simplifyElt (Mul xs) = [Mul (simplify xs)]
simplifyElt (CMul xs) = [CMul ((simplify *** simplify) <$> xs)]
toPrin' :: HasEnv m
=> SyntaxTree
-> m Principle
toPrin' = liftM concat . mapM f
where
fPair (c, x) = (,) <$> toPrin' c <*> toPrin' x
f (Value x) = return . Val <$> return x
f (Section xs) = return . Sec <$> toPrin' xs
f (Multi xs) = return . Mul <$> toPrin' xs
f (CMulti xs) = return . CMul <$> mapM fPair xs
f (Reference x) = getPrin x >>= toPrin'
f (Range x y) = return $ Val <$> if x > y then [x,x1..y] else [x..y]
f (Product x y) = adb (\a b -> [(*) <$> a <*> b]) <$> f x <*> f y
f (Division x y) = adb (\a b -> [sdiv <$> a <*> b]) <$> f x <*> f y
f (Sum x y) = adb (\a b -> [(+) <$> a <*> b]) <$> f x <*> f y
f (Diff x y) = adb (\a b -> [sdif <$> a <*> b]) <$> f x <*> f y
f (Loop x y) = adb loop <$> f x <*> f y
f (Rotation x y) = adb (\a b -> [rotate a b]) <$> f x <*> f y
f (Reverse x) = adu reverse' <$> f x
adb _ [] _ = []
adb _ xs [] = xs
adb g xs (y:ys) = init xs ++ g (last xs) y ++ ys
adu _ [] = []
adu g (x:xs) = g x : xs
sdiv :: NRatio -> NRatio -> NRatio
sdiv x 0 = x
sdiv x y = x / y
sdif :: NRatio -> NRatio -> NRatio
sdif x y
| x < y = 0
| otherwise = x y
loop :: Element NRatio -> Element NRatio -> Principle
loop x (Val y) = replicate (floor y) x
loop x (Mul y) = [Mul $ Sec . loop x <$> y]
loop (Sec x) (Sec y) = [Sec . concat $ zipWith loop x (cycle y)]
loop (Mul x) (Sec y) = [Mul . concat $ zipWith loop x (cycle y)]
loop x _ = [x]
rotate :: Element NRatio -> Element NRatio -> Element NRatio
rotate (Sec x) (Val y) = Sec $ zipWith const (drop (floor y) (cycle x)) x
rotate x@(Sec _) (Mul y) = Mul $ rotate x <$> y
rotate (Sec x) (Sec y) = Sec $ zipWith rotate x (cycle y)
rotate x _ = x
reverse' :: Element NRatio -> Element NRatio
reverse' x@(Val _) = x
reverse' (Mul x) = Mul $ reverse' <$> x
reverse' (Sec x) = Sec $ reverse $ reverse' <$> x
reverse' (CMul x) = CMul $ ((reverse' <$>) *** (reverse' <$>)) <$> x