IIS coursework

import Control.Monad
import Data.List

-- data structures declaration

data Feature = MkFeat String deriving (Show, Eq)
data Type = MkType String | RootType | Unkn deriving (Show, Eq)
data Object = MkObj String [Feature] Type | LeafObj String [Feature] Type deriving (Show)

-- data Hypothesis = Match | HType Type | Check deriving (Show, Eq)


data Unification = UniRes [Feature] [Feature] Bool deriving (Show)

-- (1) [Feature] - list of unified features
-- (2) [Feature] - list of features failed to unify
-- Bool - was object matched?


-- objects declaration

objList :: [Object]
objList =
  [
    MkObj "Anilyn"      [MkFeat "Heavier-water",  MkFeat "Unsolv"]        (MkType "Amins"),
    MkObj "Trietilamin" [MkFeat "Lighter-water",  MkFeat "Danger"]       (MkType "Amins"),
    MkObj "Piperidin"   [MkFeat "Solvable"]                              (MkType "Amins"),
    MkObj "Etanol"      [MkFeat "Lighter-water", MkFeat "Fuel"]          (MkType "Spirits"),
    MkObj "Metanol"     [MkFeat "Danger",        MkFeat "Heavier-water"] (MkType "Spirits"),
    MkObj "CU(OH)2"     [MkFeat "Racids",        MkFeat "Industry"]      (MkType "Bases"),
    MkObj "LIOH"        [MkFeat "Solvable",      MkFeat "Danger"]        (MkType "Bases"),
    MkObj "H2S04"       [MkFeat "Danger",        MkFeat "Industry"]      (MkType "Acids"),
    MkObj "Si203"       [MkFeat "Racids",        MkFeat "Unsolvable"]    (MkType "Acids"),
    MkObj "K2S04"       [MkFeat "Industry",      MkFeat "Solvable"]      (MkType "Salts"),
    MkObj "Na2C03"      [MkFeat "Industry",      MkFeat "Fuel"]          (MkType "Salts"),

    MkObj "Amins"       [MkFeat "Ammonia-deriv"]                         (MkType "Organic"),
    MkObj "Spirits"     [MkFeat "Water-deriv"]                           (MkType "Organic") ,
    MkObj "Bases"       [MkFeat "Metal-ions-deriv"]                      (MkType "Non-organic"),
    MkObj "Acids"       [MkFeat "Soury"]                                 (MkType "Non-organic"),
    MkObj "Salts"       [MkFeat "Cons-Anions-KO"]                        (MkType "Non-organic"),

    MkObj "Organic"     [MkFeat "Substance", MkFeat "Carbon-deriv"]      RootType,
    MkObj "Non-organic" [MkFeat "Substance", MkFeat "Minerals-contain"]  RootType
  ]

-- number of last leaf object
leafObjNum = 11


getName (MkObj name _ _ ) = name

getReply :: String -> IO Bool
getReply s = do
  putStrLn ("Is " ++ s ++ " ?")
  a <- getLine
  return (a == "y" || a == "Y" || a == "yes")

type_choice :: Feature -> IO Bool
type_choice (MkFeat f) = do
  a <- getReply f
  return (a)

checkFeat :: [Feature] -> IO Bool
checkFeat [] = return (True)
checkFeat (x : xs) = do
  a <- type_choice x
  b <- checkFeat(xs)
  return (a && b)

iand :: IO Bool -> IO Bool -> IO Bool
iand a b = do
  ca <- a
  cb <- b
  return (ca && cb)

-- Get the name of the object

nameOf :: Object -> String
nameOf (MkObj nm _ _) = nm

typeOf :: Object -> Type
typeOf (MkObj _ _ t) = t

featsOf :: Object -> [Feature]
featsOf (MkObj _ fts (MkType _)) = fts
featsOf (MkObj _ fts RootType) = [] ++ fts
-- nameOf (LeafObj nm _ _) = nm

--------------------------------------------------------------
findObj :: String -> [Object] -> Object

findObj nm (obj : xs) =
  if (nameOf obj == nm)
  then (obj)
  else (findObj nm xs)

--------------------------------------------------------------

contAll :: (Eq a) => [a] -> [a] -> Bool
contAll _ [] = True
contAll arr (x:xs) = any (x == ) arr && (contAll arr xs)

--------------------------------------------------------------

findFeat :: [Feature] -> Feature -> Bool
findFeat (x:xs) feat =
  if x == feat
  then True
  else
    findFeat xs feat
findFeat [] _ = False

--------------------------------------------------------------

getUniRes :: Unification -> Bool
getUniRes (UniRes _ _ res) = res

getUniFeatPos :: Unification -> [Feature]
getUniFeatPos  (UniRes fp _ _) = fp

getUniFeatNeg :: Unification -> [Feature]
getUniFeatNeg  (UniRes _ fn _) = fn

--------------------------------------------------------------

-- Walk through Unification Features and ask user for missing ones

upUni :: [Feature] -> Unification -> IO Unification
upUni [] uf = return uf
upUni (f:fx) (UniRes fp fn _) =
  if ((findFeat fp f) == False) && ((findFeat fn f) == False)
     then
    do
      res <- (type_choice f)

      if (res == True)
        then upUni fx (UniRes (fp ++ (f:[])) fn True)
        else
        return (UniRes fp (fn ++ (f:[])) False)

  else
    upUni fx (UniRes fp fn True)

--------------------------------------------------------------
-- Make false unification of all objects with specified types

falseUnify :: Object -> [Feature]

falseUnify (MkObj name feats t) =
  foldl
  (\y x -> if ((typeOf x) == t && (nameOf x) /= name) == True
                then y ++ ((featsOf x) \\ feats)
                else y)
  []
  objList

--------------------------------------------------------------

-- 1 Object - hypothesis object
-- 2 [Feature] - unified features
-- 3 [Feature] - features failed to unify

hypsolve :: Object -> [Feature] -> [Feature] -> IO Unification

hypsolve (MkObj name (feat:xs) RootType) fp fn =
  if (contAll fp (feat:xs)) == True --
  then do
    -- putStrLn "hypsolve - True"
    return (UniRes fp fn True)
  else
    -- if (contAll fn (feat:xs)) == True --
    if (length (intersect fn (feat:xs)) /= 0)
    then
      return (UniRes fp fn False)
    else

      do
        uf <- upUni (feat:xs)
              (UniRes
               fp
               fn
               True)

        if (getUniRes uf == True)
          then
          return (
            (UniRes (getUniFeatPos uf)
             ((getUniFeatNeg uf) ++ falseUnify (findObj name objList))
             (getUniRes uf)))
          else
          return (
            (UniRes (getUniFeatPos uf)
             (getUniFeatNeg uf)
             (getUniRes uf)))

hypsolve (MkObj name (feat:xs) (MkType tp)) fp fn =
  if (contAll fp (feat:xs)) == True --
  then do
    -- putStrLn "hypsolve - True"
    return (UniRes fp fn True)
  else
    if (length (intersect fn (feat:xs)) /= 0)
    -- if (contAll fn (feat:xs)) == True --
    -- if (any (fn

    then
      return (UniRes fp fn False)
    else

    do
      hr <- hypsolve (findObj tp objList) fp fn
      let ur = getUniRes hr

      if (ur == False)
        then do
        -- putStrLn "hypsolve - False"
        return (UniRes (getUniFeatPos hr)
                     (getUniFeatNeg hr) False)
        else

        do
          -- putStr "falseUnify for "
          -- putStrLn name
          -- print (falseUnify (findObj name objList))
          uf <- upUni (feat:xs) (UniRes
                           ((getUniFeatPos hr))
                           ((getUniFeatNeg hr)
                            -- ++ falseUnify (findObj name objList)
                           )
                           True)

          if (getUniRes uf == True)
            then
            return (
              (UniRes (getUniFeatPos uf)
               ((getUniFeatNeg uf) ++ falseUnify (findObj name objList))
               (getUniRes uf)))
            else
            return (
              (UniRes (getUniFeatPos uf)
               (getUniFeatNeg uf)
               (getUniRes uf)))

solve :: [Feature] -> [Feature] -> Int -> IO Object

solve fp fn num =

  if (num == leafObjNum)
  then return (MkObj "No solution" [] RootType)
  else

  do
  putStrLn ("trying: " ++ nameOf (objList !! num))
  -- print (objList !! num)
  -- print fp
  -- print fn
  -- putStrLn " "
  hr <- (hypsolve (objList !! num) fp fn)

  if (getUniRes hr == True)
    then
    do
    -- putStr ("result is : ")
    -- print (nameOf (objList !! num))

    return (objList !! num)
    else
      solve (getUniFeatPos hr) (getUniFeatNeg hr) (num + 1)

getSolve =
  do
    x <- solve [] [] 0
    putStrLn ("Result: " ++ (nameOf x))
    return ()

  -- return ()

main =
  getSolve