logic-tasks/src/Tasks/SubTree/Quiz.hs at master · fmidue/logic-tasks · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}

module Tasks.SubTree.Quiz(
    generateSubTreeInst,
    ) where


import Data.Set (size)
import Trees.Generate (genSynTree)
import Test.QuickCheck (Gen, suchThat)

import Tasks.SubTree.Config (SubTreeConfig(..), SubTreeInst(..))
import Tasks.SynTree.Config (getArrows)
import Trees.Helpers (allNotLeafSubTrees, noSameSubTree)


generateSubTreeInst :: SubTreeConfig -> Gen SubTreeInst
generateSubTreeInst SubTreeConfig {..} = do
    tree <- genSynTree syntaxTreeConfig
      `suchThat` \synTree ->
        (allowSameSubTree || noSameSubTree synTree) && fromIntegral (size (allNotLeafSubTrees synTree)) >= subTreeAmount
    let correctTrees = allNotLeafSubTrees tree
    return $ SubTreeInst
      { tree
      , inputTreeAmount = subTreeAmount
      , correctTrees = correctTrees
      , arrowOperatorsToShow = getArrows syntaxTreeConfig
      , showSolution = printSolution
      , addText = extraText
      , unicodeAllowed = offerUnicodeInput
      }