SubTreeSet.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

module LogicTasks.Syntax.SubTreeSet where


import Capabilities.Cache (MonadCache)
import Capabilities.LatexSvg (MonadLatexSvg)
import Control.OutputCapable.Blocks (
  GenericOutputCapable (..),
  LangM,
  OutputCapable,
  extra,
  ($=<<),
  english,
  german,
  translate,
  localise,
  translations,
  Rated,
  extendedMultipleChoice,
  MinimumThreshold (MinimumThreshold),
  Punishment (Punishment),
  TargetedCorrect (TargetedCorrect),
  reRefuse,
  )
import Data.List (intercalate, nub, sort)
import qualified Data.Set (map)
import qualified Data.Map as Map (fromSet, insert, filter)
import Data.Maybe (isNothing)
import LogicTasks.Helpers (focus, instruct, keyHeading, reject, basicOpKey, arrowsKey')
import Tasks.SubTree.Config (checkSubTreeConfig, SubTreeInst(..), SubTreeConfig(..))
import Trees.Types (FormulaAnswer(..))
import Trees.Print (display, transferToPicture)
import Trees.Helpers
import Control.Monad (when)
import LogicTasks.Syntax.TreeToFormula (cacheTree)
import Data.Foldable (for_)
import Formula.Parsing.Delayed (Delayed, parseDelayedWithAndThen, complainAboutMissingParenthesesIfNotFailingOn, withDelayedSucceeding)
import Formula.Parsing (Parse(..), formulaListSymbolParser)
import Control.Applicative (Alternative)
import GHC.Real ((%))
import Tasks.SynTree.Config (checkArrowOperatorsToShow)


description :: OutputCapable m => Bool -> SubTreeInst -> LangM m
description withListInput SubTreeInst{..} = do
    instruct $ do
      english "Consider the following propositional logic formula:"
      german "Betrachten Sie die folgende aussagenlogische Formel:"

    focus (display tree)

    instruct $ do
      english $ "Give " ++ show inputTreeAmount ++ " non-atomic subformulas that are contained in this formula."
      german $ "Geben Sie " ++ show inputTreeAmount ++ " nicht-atomare Teilformeln an, die in dieser Formel enthalten sind."

    instruct $ do
      english "Submit your solution as a list of subformulas."
      german "Reichen Sie Ihre Lösung als eine Liste von Teilformeln ein."

    instruct $ do
      english "Remove bracket pairs which only serve to enclose an entire subformula you provide, and do not add any additional brackets."
      german "Entfernen Sie dabei Klammerpaare, die eine angegebene Teilformel komplett umschließen, und fügen Sie keine zusätzlichen Klammern hinzu."

    paragraph $ indent $ do
      translate $ do
        english "For example, if ¬(A ∨ (B ∧ C)) is the given formula and two subformulas are required, then a correct solution is:"
        german "Ist z.B. ¬(A ∨ (B ∧ C)) die gegebene Formel und es werden zwei Teilformeln gesucht, dann ist die folgende Lösung korrekt:"
      translatedCode $ flip localise $ translations exampleCode
      pure ()

    paragraph $ translate $ do
      german "Sie können dafür die ursprüngliche Formel mehrfach in die Abgabe kopieren und Teile entfernen oder leer starten."
      english "You can copy the original formula into the submission several times and remove parts or start from scratch."

    keyHeading
    basicOpKey unicodeAllowed
    arrowsKey' arrowOperatorsToShow

    extra addText
    pure ()
      where
        exampleCode = do
          german $ exampleForm ger
          english $ exampleForm eng

        (ger,eng)
          | unicodeAllowed = (["A ∨ (B ∧ C)", "B und C"] ,["A ∨ (B ∧ C)", "B and C"])
          | otherwise = (["A oder (B und C)", "B und C"],["A or (B and C)", "B and C"])

        exampleForm s
          | withListInput = "[ " ++ intercalate ", " s ++ " ]"
          | otherwise = intercalate "\n" s


verifyInst :: OutputCapable m => SubTreeInst -> LangM m
verifyInst SubTreeInst {..}
  | not $ checkArrowOperatorsToShow arrowOperatorsToShow = reject $ do
      english "The field arrowOperatorsToShow contains a binary operator which is no arrow."
      german "Das Feld arrowOperatorsToShow enthält einen binären Operator, der kein Pfeil ist."
  | otherwise = pure ()



verifyConfig :: OutputCapable m => SubTreeConfig -> LangM m
verifyConfig = checkSubTreeConfig



start :: [FormulaAnswer]
start = [FormulaAnswer Nothing]


partialGrade :: OutputCapable m => SubTreeInst -> Delayed [FormulaAnswer] -> LangM m
partialGrade = parseDelayedWithAndThen parser complainAboutMissingParenthesesIfNotFailingOn formulaListSymbolParser . partialGrade'

partialGrade' :: OutputCapable m => SubTreeInst -> [FormulaAnswer] -> LangM m
partialGrade' SubTreeInst{..} fs
    | any (isNothing . maybeForm) fs =
      reject $ do
        english "At least one of your answers is not a well-formed formula."
        german "Mindestens eine Ihrer Antworten ist keine wohlaufgebaute Formel."

    | any (`notElem` correctAtoms) atoms =
      reject $ do
        english "At least one formula in your submitted solution contains unknown atomic formulas."
        german "Die eingereichte Lösung beinhaltet mindestens eine Formel mit unbekannten atomaren Formeln."

    | any (> origOpsNum) opsNum =
      reject $ do
        english "The submitted solution contains at least one formula with more logical operators than the original formula."
        german "Die eingereichte Lösung beinhaltet mindestens eine Formel mit mehr logische Operatoren als die ursprüngliche Formel."

    | amount < inputTreeAmount =
      reject $ do
        english "The submitted solution does not contain enough different subformulas. "
        english $ "Add " ++ show (inputTreeAmount - amount) ++ "."
        german "Die eingereichte Lösung beinhaltet nicht genügend verschiedene Teilformeln. "
        german $ "Fügen Sie " ++ show (inputTreeAmount - amount) ++ " hinzu."

    | amount > inputTreeAmount =
      reject $ do
        english "The submitted solution contains too many formulas."
        german "Die eingereichte Lösung enthält zu viele Formeln."

    | otherwise = pure ()
  where
    amount = fromIntegral $ length $ nub fs
    atoms = sort $ nub $ concatMap collectLeavesInAnswer fs
    opsNum = map numberOfOperatorsInAnswer fs
    correctAtoms = sort $ nub $ collectLeaves tree
    origOpsNum = numOfOps tree


completeGrade
  :: (OutputCapable m, MonadCache m, MonadLatexSvg m, Alternative m)
  => FilePath
  -> SubTreeInst
  -> Delayed [FormulaAnswer]
  -> Rated m
completeGrade path inst = completeGrade' path inst `withDelayedSucceeding` parser

completeGrade'
  :: (OutputCapable m, MonadCache m, MonadLatexSvg m, Alternative m)
  => FilePath
  -> SubTreeInst
  -> [FormulaAnswer]
  -> Rated m
completeGrade' path SubTreeInst{..} sol = reRefuse
  (extendedMultipleChoice
    (MinimumThreshold (1 % inputTreeAmount))
    (Punishment 0)
    (TargetedCorrect (fromIntegral inputTreeAmount))
    (Just what)
    Nothing
    solution
    submission)
  $ when showSolution $ do
    instruct $ do
      english ("A possible solution for this task contains " ++ show inputTreeAmount ++ " of the following subformulas:")
      german ("Eine mögliche Lösung für diese Aufgabe beinhaltet " ++ show inputTreeAmount ++ " der folgenden Teilformeln:")

    for_ correctTrees $ \x -> paragraph $ indent $ do
      code (display x)

      instruct $ do
        german "mit zugehörigem Teil-Syntaxbaum:"
        english "with associated partial syntax tree:"

      image $=<< cacheTree (transferToPicture x) path
      pure ()

    pure ()
    where
      what = translations $ do
        german "Teilformeln"
        english "subformulas"
      solution = Map.fromSet (const True) $ Data.Set.map display correctTrees
      submission = foldr ((`Map.insert` True) . show) (Map.filter not solution) sol