-- Candidate Elimination (CE) in Haskell
--
-- Run from Emacs with C-c C-l, then C-x o, then type
--   run <set> <feed-limit> RET
-- to feed the CE a certain number of examples from a certain set:
-- E.g, "run 5 7" will run the entire fifth set (counting from one)
--
-- The example sets are from the exams found here:
--   http://www.it.uu.se/edu/course/homepage/ai/ht11/
-- also check out docu.txt in the same directory as this file

data Prop = DoNotCare | Pp Char
instance Eq Prop where
  DoNotCare == DoNotCare = True
  Pp a      == Pp b      = a == b
  _         == _         = False
  a         /= b         = not (a == b)

type Conf = [Char]
type Concept = [Prop]
data Spec = SpecNotInit | InitSpec Concept
data Gen = GenNotInit | Gens [Concept]
type Ex = (Bool, Conf)
type Set = [Ex]
data State = Incons | StateOK (Spec, Gen, Set, Set)

conceptToChars :: Concept -> [Char]
conceptToChars ps =
  map
  (\p ->
    case p of
      DoNotCare -> '*'
      Pp c -> c)
  ps
  
run :: Int -> Int -> [[Char]]
run setIx setSize =
  let set = getSet setIx
      runSet = take setSize set
      state = getNewState runSet
      fallout = feed state
  in  
   case fallout of
     Incons -> [['e', 'r', 'r', 'o','r']]
     StateOK (InitSpec spec, Gens gens, [], _) ->
       map (\c -> conceptToChars c) (spec:gens)

getSet :: Int -> Set
getSet set =
  [
    [ (True,  "swtJS"),
      (False, "shaJT"),
      (True,  "sctMS"),
      (False, "rctMS"),
      (False, "shtAG") ],
    [ (True,  ['E', 'S', 'S']),
      (True,  ['C', 'C', 'L']) ],
    [ (True,  ['E', 'C', 'S']),
      (False, ['E', 'S', 'S']),
      (False, ['C', 'C', 'L']) ],
    [ (True,  ['E', 's', 'C', 'S']),
      (False, ['E', 'S', 'c', 'S']),
      (False, ['C', 's', 'C', 'L']),
      (True,  ['C', 'S', 'C', 'S']) ],
    [ (True,  "CATCAT"), 
      (False, "TACCAT"),
      (True,  "GATCAG"),
      (False, "ACTAAC"),
      (False, "TTTCCC"),
      (True,  "GATCTA"),
      (False, "AATTGA") ]
  ] !! (set - 1)

checkSet :: Set -> Bool
checkSet (e:es) =
  case e of
    (False, _) -> False;
    (True, props) ->
      let numOfProps = length props
      in all (\e -> length e == numOfProps) [ ps | (_, ps) <- es ]

getNewState :: Set -> State
getNewState exs = StateOK (SpecNotInit, GenNotInit, exs, [])

getInitGen :: Int -> [Prop]
getInitGen ps = replicate ps DoNotCare

initState :: State -> State
initState (StateOK (SpecNotInit, GenNotInit, (e:es), [])) =
  if (checkSet (e:es)) then
    case e of
      (_, props) ->
        let spec = InitSpec (propsToConcept props)
            gen = Gens [getInitGen (length props)]
        in (StateOK (spec, gen, es, []))
  else Incons
       
propsToConcept :: Conf -> Concept
propsToConcept [] = []
propsToConcept (c:cs) = (Pp c):(propsToConcept cs)
       
feed :: State -> State
feed state =
  case state of
    (StateOK (SpecNotInit, _, _, [])) -> feed (initState state)
    (StateOK (_, _, [], _)) -> state
    (StateOK (spec, gen, (e:es), rs)) ->
      case e of
        (True, sps) ->
          let newSpec = genToIncl sps spec
              newGen = dropOnNotIncl sps gen
          in if (checkNotToInclNegs newSpec rs) then
               feed (StateOK (newSpec, newGen, es, e:rs))
             else Incons
        (False, sps) ->
          if (checkNotToIncl sps spec) then
            let specGen = specToExclAll sps spec gen
                dropOverlapGen = dropOnOverlap specGen
                newGen = dropExclPos dropOverlapGen rs
            in feed (StateOK (spec, newGen, es, e:rs))
          else Incons
               
checkNotToInclNegs :: Spec -> Set -> Bool
checkNotToInclNegs (InitSpec spec) rs =
  not
  (any
  (\conf -> isIncluding conf spec)
  [conf | (sign, conf) <- rs, not sign])
  
dropExclPos :: Gen -> Set -> Gen
dropExclPos (Gens cs) rs =
  Gens
  [c | c <- cs,
   all (\rconf -> isIncluding rconf c) [conf | (sign, conf) <- rs, sign]]

flattenConceptList :: [[Concept]] -> [Concept]
flattenConceptList [[]] = []
flattenConceptList ([]:css) = flattenConceptList css
flattenConceptList ((c:cs):css) = c : (flattenConceptList (cs:css))

specToExclAll :: Conf -> Spec -> Gen -> Gen
specToExclAll conf spec (Gens gens) =
  let nonFlatConceptList = 
        map (\old -> if (isIncluding conf old) then
                       let new = specToExcl conf spec old
                           diffIxs = differsOnIndexes old new 0
                       in getPerms old new diffIxs
                     else [old]) gens
  in Gens (flattenConceptList nonFlatConceptList)

specToExcl :: Conf -> Spec -> Concept -> Concept
specToExcl conf (InitSpec spec) gen =
  [ if (s /= DoNotCare) &&
       (s /= Pp c) &&
       (g == DoNotCare) then s
    else g | (c, s, g) <- zip3 conf spec gen ]
       
differsOnIndexes :: Concept -> Concept -> Int -> [Int]
differsOnIndexes [] [] _ = []
differsOnIndexes (g:gs) (n:ns) index =
  if (g /= n) then index:(differsOnIndexes gs ns (index + 1))
  else differsOnIndexes gs ns (index + 1)

getPerms :: Concept -> Concept -> [Int] -> [Concept]
getPerms old new diffIxs =
  [ (take d old) ++ [ new !! d ] ++ (drop (d + 1) old) | d <- diffIxs ]

isIncluding :: Conf -> Concept -> Bool
isIncluding [] [] = True
isIncluding (e:es) (p:ps) =
  case p of
    DoNotCare -> isIncluding es ps
    Pp pc -> if (pc == e) then isIncluding es ps
             else False

genToIncl :: Conf -> Spec -> Spec
genToIncl ex (InitSpec concept) =
  InitSpec [ if (cp == DoNotCare) || (cp == Pp ep) then cp
             else DoNotCare
           | (ep, cp) <- zip ex concept ]
  
dropOnNotIncl :: Conf -> Gen -> Gen
dropOnNotIncl ps (Gens gens) = 
  Gens [ gen | gen <- gens, isIncluding ps gen ]
  
isIncludingConcept :: Concept -> Concept -> Bool
isIncludingConcept [] [] = True
isIncludingConcept (a:as) (b:bs) =
  if (b == DoNotCare) || (a == b) then isIncludingConcept as bs
  else False
  
dropOnOverlap :: Gen -> Gen
dropOnOverlap (Gens gens) =
  Gens [ g | g <- gens,
         not (any (\gt -> (g /= gt) && isIncludingConcept g gt) gens) ]
       
checkNotToIncl :: Conf -> Spec -> Bool  
checkNotToIncl es (InitSpec ps) =
  any
  (\(ee, pp) ->
    case pp of
      DoNotCare -> False
      Pp ppc -> ppc /= ee)
  [ (e, p) | e <- es, p <- ps ]