Refal-expression mathcing implementation for one of CS courses. Comments in russian.

refal_matching.hs

-- | Задание практикума №2 
-- Вариант №2 "Отождествление Рефал-выражений"
module Main where

import Debug.Trace
import Data.Maybe
import Control.Monad
import Text.ParserCombinators.Parsec as Parsec

-- * Вспомогательные функции и типы

-- | Тип просмотра выражения
data MatchDirection = Normal | Reverse
-- | Тип перменной
data RefalVarType = S | T | E | V deriving (Show, Eq)
-- | Имя переменной
type RefalVarName = String 
-- | Внутреннее представление Рефал-выражений
data RefalData = RList [RefalData] 
               | RChar Char 
               | RInteger Integer 
               | RAtom String 
               | RVar RefalVarType RefalVarName 
               deriving (Eq)

-- | Свой экзлемляр стандартного |Show| дабы вывод выглядел чище
instance Show RefalData where
  show (RInteger x) = show x
  show (RVar t n)   = show t ++ show n
  show (RChar x)    = show x
  show (RList x)    = "<" ++ show x ++ ">"
  show (RAtom x)    = "<" ++ show x ++ ">"

-- | Пачка предикатов

isSymbol :: RefalData -> Bool
isSymbol (RList _) = False
isSymbol _         = True

isList = not . isSymbol

isVar :: RefalData -> Bool
isVar (RVar _ _) = True
isVar _ = False

isTerm = not . isVar

-- | Из Рефал-списка делает кортеж вида (Голова, Остальное)
readTok :: RefalData -> (RefalData, RefalData)
readTok (RList (e:es)) = (e,  RList es)
readTok (RList es)     = (RList [], RList es)

-- | Разбивает Рефал-список всеми возможными способами
splits (RList xs) = map (\y-> both RList $ splitAt y xs) [1..length xs] 
                    where both f (a, b) = (f a, f b)

-- | Обращает рефал-выражение
reverseRefal :: RefalData -> RefalData
reverseRefal (RList xs) = RList $ reverse $ map reverseRefal xs
reverseRefal x = x

justIf :: a -> Bool -> Maybe a
justIf x y = if y then Just x else Nothing

-- * Парсер Рефал-выражений во внутреннее представление
-- | Реализован при помощи стандартной библиотеки "Parsec"
-- Ничего примечательного с точки зрения задания

{-| Допускает примерно следующую грамматику: 
 @
 RefalData ::= RefalList !EOF
 RefalList ::= {!Space} {Term} {!Space}
 Term      ::= '\'' {(!Char кроме ')} '\'' | Atom | !Int | Var | Struct
 Atom      ::= Id
 Id        ::= {!Letter | !Digit}
 Variable  ::= VarT '.' Id
 VarT      ::= S | T | E
 Struct    ::= '(' RefalList ')'
 @
-}

parseRefal :: String -> RefalData
parseRefal s = 
  case (parse refalData "input" s) of
    Left err -> error $ show err
    Right x  -> x

varType :: Parser RefalVarType
varType = (char 's' >> return S) <|> (char 't' >> return T) <|> (char 'e' >> return E) <|> (char 'v' >> return V)

atom :: Parser RefalData
atom = do
  name <- many1 letter 
  return $ RAtom name

variable = do
  t <- varType
  char '.'
  n <- many1 (letter <|> digit)
  return $ RVar t n

struct = do
  char '('
  d <- refalList
  char ')'
  return d

rchars = do
  char '\''
  cs <- many rchar
  char '\''
  skipMany space
  return cs 

rchar = do 
  c <- noneOf "'"
  return $ RChar c

term :: Parser [RefalData]
term = rchars <|> (liftL term')
  where liftL x = do xc <-x
                     return [xc]

term' :: Parser RefalData
term' = do 
  t <- try (struct) <|> try (variable) <|> atom <|> number 
  skipMany space
  return t

number = do ds <- many1 digit
            return $ RInteger $ read ds
  <?> "number"

refalList = do skipMany space
               ts <- many1 term
               return $ RList $ concat ts

refalData :: Parser RefalData
refalData = do d <- refalList
               eof
               return d

-- * Недетерминированные вычисления

-- | Монада для работы с недетерменизмом
-- Очень простая, потому, что всю работу берет на себя ленивость Хаскеля, 
-- а эффективность в данном случае не критична
newtype Choice a = Choice [a] deriving Show

runChoice :: Choice a -> [a]
runChoice (Choice x) = x

choose :: [a] -> Choice a 
choose x = Choice x

instance Monad Choice where
  (>>=) (Choice c) f = Choice $ concat $ map (runChoice . f) c
  return x = choose [x]

instance MonadPlus Choice where
  mzero = Choice []
  mplus (Choice x) (Choice y) = Choice $ x ++ y

-- | Пример использования
solveConstraint = do
  x <- choose [1,2,3] -- ^ для очередного х из списка
  y <- choose [4,5,6] -- ^ и для очереднго y
  guard (x*y == 8)    -- ^ отсеять такие x и у, для которых условие не выполнено
  return (x,y)        -- ^ возвратить результат

-- * Реализация сопоставления

-- | Контейнер хранящий связи переменных со значениями
type Bindings = [(RefalData, RefalData)]

-- | Основная рабочая функция
match' :: (Bindings, RefalData) -- ^ (Текщее состояние связей, Выражение)
       -> RefalData -- ^ Образец
       -> Maybe (Bindings, RefalData) -- ^ Новое состояние и остаток выражения или ничего в случае неуспеха

-- | Успешное завершение. Возвращает установленные связи.
match' c@(_,(RList [])) (RList []) = return c
-- | Завершение с невычитаным до конца выражением. Возвращает неуспех.
match' c (RList []) = Nothing

-- | Сопоставление с переменной
match' (b, e) (RList (p:ps)) | isVar p, isList e =
  -- Из всех успешных вариантов нас интересует только первый (кратчайший)
  one $ runChoice $ do -- ^ Choice
     let (RVar t _) = p
     -- для кадого возможного способа прочитать значение переменной типа t
     v <- choose $ readVar t e
     -- попытаемся связать его с именем p из образца
     c <- return $ do -- ^ Maybe
       (val, e') <- v
       b' <- bindVar val p
       return (b', e')
     -- отсеем неуспехи
     guard (isJust c)
     --
     -- проведем сопоставление оставшейся части с новым состоянием связей
     let o = match' (fromJust c) (RList ps)
     -- отсеем неуспехи
     guard (isJust o)
     -- зафиксируем результат
     return o
  where 
    one [] = Nothing
    one x  = head x
    --
    isT T = isTerm
    isT S = isSymbol
    --
    -- | Функция выбора значения переменной типа t из выражения e
    -- возвращает спиоск возможных пар (Значение, Остаток выражения)
    -- | для V-перменной вернет все возможные разбиения e
    readVar V e = map Just $ splits e
    -- | для E-переменной к списку вариантов добавляем (Ничего, e)
    readVar E e = map Just $ ((RList [], e) : splits e)
    -- | для двух других типов функция успешно возвращает результат, 
    -- если тип переменной соответствует типу выбранного элемента выражения,
    -- в противном случае Nothing
    readVar t e = return $ tok `justIf` (isT t $ fst tok) 
                  where tok = readTok e
	-- | Связывание значения переменной
	-- На вход принимает предполагаемое значение и RefalData в качестве идентификатора
    bindVar v p = 
      case lookup p b of
      	-- | Если имя уже было однажды связано, 
      	-- то новое значение должно совпадать со старым
      	-- иначе возвращает Nothing
        Just val -> b `justIf` (val == v)
        -- | Если имя встречено впервые, просто свяжем его со значением
        Nothing  -> return $ (p, v):b

-- | Общий вид
match' c@(b, e) p | isList e, isList p = 
  -- | Выделяем головы у выражения и образца
  let 
    (ec, er) = readTok e
    (pc, pr) = readTok p 
  in
  if isVar pc -- ^ если голова образца оказалось переменной
    then match' c p -- ^ возвращаем сопоставление от изначальных c и p (пойдет по ветке с переменной)
    -- | иначе сопоставляем головы и, если удалось, хвосты
    else do 
      (b', _) <- match' (b, ec) pc
      match' (b', er) pr

-- | Сопоставление подвыражений без переменных
match' c@(_, e) p = c `justIf` (e == p)

-- | Функция обертка, которая вычленяет из результата |match'|
-- @(Maybe списокСвязей)@ и возвращает его
match :: RefalData -> RefalData -> MatchDirection -> Maybe Bindings 
match p e Normal = do 
  res <- match' ([], e) p
  return $ fst $ res

-- | Дополнительный случа для правого просмотра
match p e Reverse = 
  reverseResults $ match pr er Normal
  where 
    pr = reverseRefal p
    er = reverseRefal e
    reverseResults mx = do
      x <- mx
      return $ map (\(v, e)-> (v, reverseRefal e)) x

-- | Просто main
main :: IO ()
main = do
  putStrLn "Expression:"
  (_, e) <- readRefalExpr
  print e
  putStrLn "\nPattern:"
  (r, p) <- readRefalExpr
  print p
  putStrLn "\nResult:"
  printResults $ match p e r
    where 
      isReversed ('R':' ':xs) = (Reverse, xs)
      isReversed xs = (Normal, xs)
      --
      readRefalExpr = do
        s <- getLine
        (r, sc) <- return $ isReversed s
        return (r, parseRefal sc)
      printResults (Just b) = do
        putStrLn "Just"
        mapM_ (\(n, v)-> putStrLn $ show n ++ " -> " ++ show v) b
      printResults b = do 
        putStrLn "Nothing"