diff --git a/src/Algorithm/BaseQuery.hs b/src/Algorithm/BaseQuery.hs index e71af69..5ee75d9 100644 --- a/src/Algorithm/BaseQuery.hs +++ b/src/Algorithm/BaseQuery.hs @@ -18,6 +18,9 @@ data Card = Card T.Text deriving (Show) +instance Eq Card where + (==) (Card id_ _ _ _ _ _ _) (Card id2_ _ _ _ _ _ _) = id_ == id2_ + instance FromRow Card where fromRow = Card <$> field <*> field <*> field <*> field <*> field <*> field <*> field diff --git a/src/Algorithm/Lex.hs b/src/Algorithm/Lex.hs index 8f91b2b..444c17b 100644 --- a/src/Algorithm/Lex.hs +++ b/src/Algorithm/Lex.hs @@ -60,7 +60,7 @@ findClosing [] _ _ = error "Unequal number of parenthesis" data Token = Func Operator Token Token | Queri QueryDef deriving Show data QueryDef = SuperType String| Color String deriving Show -data Operator = Union deriving Show +data Operator = Union | Intersect deriving Show seperator :: [String] -> [(Int, Int)] -> Token seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of @@ -75,6 +75,7 @@ extractQueryDef ("SuperType", value) = SuperType value extractQueryDef _ = error $ "This command was not valid" extractOperator "union" = Union +extractOperator "intersect" = Intersect extractOperator _ = error $ "This operator is not defined" -- ((Is instant) union (Color R)) union ((Is instant) union (Color R)) -- (((Color Red) union (Color Blue)) union ((Is instant) union (Is Enchantment))) \ No newline at end of file diff --git a/src/Algorithm/Operator.hs b/src/Algorithm/Operator.hs index 176b782..21853aa 100644 --- a/src/Algorithm/Operator.hs +++ b/src/Algorithm/Operator.hs @@ -1,8 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module Algorithm.Operator - ( union + ( union, + intersect ) where -union :: IO [a] -> IO [a] -> [a] -union res1 res2 = res1 ++ res2 \ No newline at end of file +union :: [a] -> [a] -> [a] +union res1 res2 = res1 ++ res2 + +intersect :: Eq a => [a] -> [a] -> [a] +intersect (a:as) b = if a `elem` b then a: intersect as b else intersect as b + +intersect [] _ = [] \ No newline at end of file diff --git a/src/Algorithm/Search.hs b/src/Algorithm/Search.hs index d444b0a..d2f7898 100644 --- a/src/Algorithm/Search.hs +++ b/src/Algorithm/Search.hs @@ -9,23 +9,26 @@ import qualified Data.Text as T import Algorithm.Lex import Control.Monad import Data.Text (unpack) -import Algorithm.Operator (union) +import Algorithm.Operator (union, intersect) import Control.Monad.IO.Class - +data Tree = Funct Operator Tree Tree | Holder [Card] search :: String -> IO String search q = do let tokens = lexx q - queryRes <- executeQuery tokens + tree <- liftIO (executeBottomQuery tokens) + + let queryRes = executeQuery tree let hyperText = buildHtml queryRes return hyperText -executeQuery :: Token -> IO [Card] -executeQuery (Queri bottom) = executeBottomQuery bottom -executeQuery (Func Union leftToken rightToken) = executeQuery leftToken `union` executeQuery rightToken +executeQuery :: Tree -> [Card] +executeQuery (Holder cards) = cards +executeQuery (Funct Union leftToken rightToken) = executeQuery leftToken `union` executeQuery rightToken +executeQuery (Funct Intersect leftToken rightToken) = executeQuery leftToken `intersect` executeQuery rightToken executeQuery _ = error $ "Not implemented!" @@ -33,10 +36,17 @@ buildHtml :: [Card] -> String buildHtml = concatMap cardToHtml +--Fancy trickery to move the IO to outer, in order to allow all the combinatorics to not have to live in IO land :) +executeBottomQuery :: Token -> IO Tree +executeBottomQuery (Queri (SuperType value)) = do + temp <- superType value + return $ Holder temp +executeBottomQuery (Queri _) = error $ "Not implemented yet" +executeBottomQuery (Func operator left right) = do + left <- executeBottomQuery left + right <- executeBottomQuery right + return $ Funct operator left right -executeBottomQuery :: QueryDef -> IO [Card] -executeBottomQuery (SuperType value) = superType value -executeBottomQuery _ = error $ "Not implemented yet"