module Ideas.Service.ProblemDecomposition
( problemDecomposition, Reply(..)
) where
import Data.Maybe
import Ideas.Common.Library
import Ideas.Service.State
import Ideas.Service.Types
problemDecomposition :: Maybe Id -> State a -> Maybe (Answer a) -> Either String (Reply a)
problemDecomposition msloc state maybeAnswer
| isNothing $ subStrategy sloc (strategy ex) =
Left "request error: invalid location for strategy"
| null answers =
Left "strategy error: not able to compute an expected answer"
| otherwise =
case maybeAnswer of
Just (Answer answeredTerm) | not (null witnesses) -> Right $
Ok newLocation newState
where
witnesses = filter (similarity ex answeredTerm . fst) $ take 1 answers
(newCtx, newPrefix) = head witnesses
newLocation = nextTaskLocation (strategy ex) sloc $
fromMaybe topId $ nextMajorForPrefix newPrefix newCtx
newState = makeState ex [newPrefix] newCtx
_ -> Right $
Incorrect isEquiv newLocation expState arguments
where
newLocation = subTaskLocation (strategy ex) sloc loc
expState = makeState ex [pref] expected
isEquiv = maybe False (equivalence ex expected . fromAnswer) maybeAnswer
(expected, pref) = head answers
(loc, arguments) = fromMaybe (topId, mempty) $
firstMajorInPrefix prefix pref
where
ex = exercise state
topId = getId (strategy ex)
sloc = fromMaybe topId msloc
answers = runPrefixLocation sloc prefix requestedTerm
requestedTerm = stateContext state
prefix = case statePrefixes state of
[] -> emptyPrefix (strategy ex)
hd:_ -> hd
runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)]
runPrefixLocation loc p0 =
concatMap (checkPair . f) . derivations .
cutOnStep (stop . lastStepInPrefix) . prefixTree False p0
where
f d = (lastTerm d, fromMaybe p0 (lastStep d))
stop (Just (Exit info)) = getId info == loc
stop _ = False
checkPair result@(a, p)
| null rules = [result]
| all isMinor rules = runPrefixLocation loc p a
| otherwise = [result]
where
rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p
firstMajorInPrefix :: Prefix a -> Prefix a -> Maybe (Id, Environment)
firstMajorInPrefix p0 = rec . drop len . prefixToSteps
where
len = length (prefixToSteps p0)
rec xs =
case xs of
Enter info:RuleStep env r:_ | isMajor r ->
Just (getId info, env)
_:rest -> rec rest
[] -> Nothing
nextMajorForPrefix :: Prefix a -> a -> Maybe Id
nextMajorForPrefix p0 a = do
(_, p1) <- listToMaybe $ runPrefixMajor p0 a
rec (reverse (prefixToSteps p1))
where
rec [] = Nothing
rec (Enter info:_) = Just (getId info)
rec (Exit info:_) = Just (getId info)
rec (_:rest) = rec rest
runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)]
runPrefixMajor p0 =
map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree False p0
where
f d = (lastTerm d, fromMaybe p0 (lastStep d))
stop = maybe False isMajor
newtype Answer a = Answer { fromAnswer :: Context a }
data Reply a = Ok Id (State a)
| Incorrect Bool Id (State a) Environment
instance Typed a (Answer a) where
typed = Tag "answer" $ Iso (Answer <-> fromAnswer) (Const Context)
instance Typed a (Reply a) where
typed = Tag "DecompositionReply" (Iso (f <-> g) typed)
where
f (Left (a, b)) = Ok a b
f (Right (a, b, c, d)) = Incorrect a b c d
g (Ok a b) = Left (a, b)
g (Incorrect a b c d) = Right (a, b, c, d)