ideas-0.7: src/Service/ProblemDecomposition.hs
-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-----------------------------------------------------------------------------
module Service.ProblemDecomposition
( problemDecomposition
, replyType, replyTypeSynonym, encodeReply
) where
import Common.Library
import Common.Utils
import Control.Monad
import Data.Maybe
import Service.ExercisePackage
import Service.State
import Service.Types
import Text.XML hiding (name)
problemDecomposition :: Monad m => Maybe Id -> State a -> Maybe a -> m (Reply a)
problemDecomposition msloc state answer
| isNothing $ subStrategy sloc (strategy ex) =
fail "request error: invalid location for strategy"
| otherwise =
let pr = fromMaybe (emptyPrefix $ strategy ex) (statePrefix state) in
case (runPrefixLocation sloc pr requestedTerm, maybe Nothing (Just . inContext ex) answer) of
([], _) -> fail "strategy error: not able to compute an expected answer"
(answers, Just answeredTerm)
| not (null witnesses) -> return $
Ok newLocation newState
where
witnesses = filter (similarityCtx ex answeredTerm . fst) $ take 1 answers
(newCtx, newPrefix) = head witnesses
newLocation = nextTaskLocation (strategy ex) sloc $
fromMaybe topId $ nextMajorForPrefix newPrefix newCtx
newState = makeState pkg (Just newPrefix) newCtx
((expected, pref):_, maybeAnswer) -> return $
Incorrect isEquiv newLocation expState arguments
where
newLocation = subTaskLocation (strategy ex) sloc loc
expState = makeState pkg (Just pref) expected
isEquiv = maybe False (equivalenceContext ex expected) maybeAnswer
(loc, arguments) = fromMaybe (topId, []) $
firstMajorInPrefix pr pref requestedTerm
where
pkg = exercisePkg state
ex = exercise pkg
topId = getId (strategy ex)
sloc = fromMaybe topId msloc
requestedTerm = stateContext state
similarityCtx :: Exercise a -> Context a -> Context a -> Bool
similarityCtx ex a b = fromMaybe False $
liftM2 (similarity ex) (fromContext a) (fromContext b)
-- | Continue with a prefix until a certain strategy location is reached. At least one
-- major rule should have been executed
runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)]
runPrefixLocation loc p0 =
concatMap (checkPair . f) . derivations .
cutOnStep (stop . lastStepInPrefix) . prefixTree p0
where
f d = (last (terms d), if isEmpty d then p0 else last (steps d))
stop (Just (Exit info)) = getId info == loc
stop _ = False
checkPair result@(a, p)
| null rules = [result]
| all isMinorRule rules = runPrefixLocation loc p a
| otherwise = [result]
where
rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p
firstMajorInPrefix :: Prefix a -> Prefix a -> a -> Maybe (Id, Args)
firstMajorInPrefix p0 p a = do
let newSteps = drop (length $ prefixToSteps p0) (prefixToSteps p)
is <- firstLocation newSteps
return (is, argumentsForSteps a newSteps)
where
firstLocation :: HasId l => [Step l a] -> Maybe Id
firstLocation [] = Nothing
firstLocation (Enter info:RuleStep r:_) | isMajorRule r = Just (getId info)
firstLocation (_:rest) = firstLocation rest
argumentsForSteps :: a -> [Step l a] -> Args
argumentsForSteps a0 = flip rec a0 . stepsToRules
where
rec [] _ = []
rec (r:rs) a
| isMinorRule r = concatMap (rec rs) (applyAll r a)
| applicable r a = let ds = map (\(Some d) -> labelArgument d) (getDescriptors r)
in maybe [] (zip ds) (expectedArguments r a)
| otherwise = []
nextMajorForPrefix :: Prefix a -> a -> Maybe Id
nextMajorForPrefix p0 a = do
(_, p1) <- safeHead $ 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
-- Copied from TypedAbstractService: clean me up
runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)]
runPrefixMajor p0 =
map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree p0
where
f d = (last (terms d), if isEmpty d then p0 else last (steps d))
stop (Just (RuleStep r)) = isMajorRule r
stop _ = False
------------------------------------------------------------------------
-- Data types for replies
data Reply a = Ok Id (State a)
| Incorrect Bool Id (State a) Args
type Args = [(String, String)]
------------------------------------------------------------------------
-- Conversion functions to XML
encodeReply :: Monad m => (State a -> m XMLBuilder) -> Reply a -> m XMLBuilder
encodeReply showState reply =
case reply of
Ok loc state -> do
stateXML <- showState state
return $
element "correct" $ do
element "location" (text $ show loc)
stateXML
Incorrect b loc state args -> do
stateXML <- showState state
return $
element "incorrect" $ do
"equivalent" .=. show b
element "location" (text $ show loc)
stateXML
let f (x, y) = element "elem" $ do
"descr" .=. x
text y
unless (null args) $
element "arguments" $ mapM_ f args
replyType :: Type a (Reply a)
replyType = useSynonym replyTypeSynonym
replyTypeSynonym :: TypeSynonym a (Reply a)
replyTypeSynonym = typeSynonym "DecompositionReply" to from tp
where
to (Left (a, b)) = Ok a b
to (Right (a, b, c, d)) = Incorrect a b c d
from (Ok a b) = Left (a, b)
from (Incorrect a b c d) = Right (a, b, c, d)
tp = tuple2 Id stateTp
:|: tuple4 Bool Id stateTp argsTp
argsTp = List (Pair String String)