From c08ef8b7144029eae69051e256686abb951a3bc3 Mon Sep 17 00:00:00 2001 From: polsevev Date: Sat, 6 May 2023 17:25:08 +0200 Subject: [PATCH] Probably finished this time --- src/Algorithm/BaseQuery.hs | 32 +++++++++++++++++++------------- src/Algorithm/Lex.hs | 2 ++ src/Algorithm/Search.hs | 1 + src/Seed.hs | 27 ++++++++++++++++----------- 4 files changed, 38 insertions(+), 24 deletions(-) diff --git a/src/Algorithm/BaseQuery.hs b/src/Algorithm/BaseQuery.hs index c204ef3..9005940 100644 --- a/src/Algorithm/BaseQuery.hs +++ b/src/Algorithm/BaseQuery.hs @@ -8,16 +8,14 @@ module Algorithm.BaseQuery Tree(..), CardFace(..), ImageUris(..), - isLegal + isLegal, + notSuperType ) where import qualified Data.Text as T import Database.SQLite.Simple import Config (getDbPath) import Data.Text (Text, isInfixOf) -import Control.Monad.IO.Class (MonadIO(liftIO)) import Algorithm.Lex (Operator) -import GHC.Generics (Generic) -import Web.Scotty (rescue) {- @@ -98,10 +96,10 @@ instance Eq Card where --Re design fetching of cards by id to only gather the dbPath from config once! fetchCardsWithIds :: [ID] -> IO [Card] -fetchCardsWithIds ids = do +fetchCardsWithIds ids = do dbPath <- getDbPath conn <- open dbPath - mapM (fetchCardWithId conn) ids + mapM (fetchCardWithId conn) ids fetchCardWithId :: Connection -> ID -> IO Card fetchCardWithId conn (ID id) = do @@ -121,7 +119,6 @@ fetchImageUris conn (TempCardFace id card_id name cmc oracle_text type_line mana runQuerySimple :: (FromRow a) => Connection -> Query -> IO [a] runQuerySimple conn str = do - query_ conn str ::(FromRow a) => IO [a]; runQueryNamed ::(FromRow a) => Connection -> Query -> [NamedParam] -> IO [a] @@ -142,13 +139,22 @@ superType qry = do dbPath <- getDbPath conn <- open dbPath res <- runQuerySimple conn "select card.id, card_face.type_line from card inner join card_face where card.id = card_face.card_id and card_face.oracle_text is not null" :: IO [CardTypeLine] - cards <- fetchCardsWithIds (typeLineFilter res (T.pack qry)) + cards <- fetchCardsWithIds (typeLineFilter res (T.pack qry) True) return $ Holder cards -typeLineFilter :: [CardTypeLine] -> Text -> [ID] -typeLineFilter ((CardTypeLine id_ type_line):cards) qry = if qry `isInfixOf` type_line then ID id_:typeLineFilter cards qry else typeLineFilter cards qry -typeLineFilter [] _ = [] +typeLineFilter :: [CardTypeLine] -> Text -> Bool -> [ID] +typeLineFilter ((CardTypeLine id_ type_line):cards) qry True = if qry `isInfixOf` type_line then ID id_:typeLineFilter cards qry True else typeLineFilter cards qry True +typeLineFilter ((CardTypeLine id_ type_line):cards) qry False = if not (qry `isInfixOf` type_line) then ID id_:typeLineFilter cards qry False else typeLineFilter cards qry False +typeLineFilter [] _ _ = [] -------------------------------------------------------------- +notSuperType :: String -> IO Tree +notSuperType qry = do + dbPath <- getDbPath + conn <- open dbPath + res <- runQuerySimple conn "select card.id, card_face.type_line from card inner join card_face where card.id = card_face.card_id and card_face.oracle_text is not null" :: IO [CardTypeLine] + cards <- fetchCardsWithIds (typeLineFilter res (T.pack qry) False) + return $ Holder cards + newtype ID = ID Int instance FromRow ID where @@ -182,8 +188,8 @@ isLegal :: String -> IO Tree isLegal qry = do dbPath <- getDbPath conn <- open dbPath - res <- runQueryNamed conn "select card.id from card inner join legalities where card.id = legalities.card_id and legalities.:val = legal" [":val" := qry] :: IO [ID] + res <- runQueryNamed conn "select card.id from card inner join legalities where card.id = legalities.card_id and format = :val and is_legal=1" [":val" := qry] :: IO [ID] cards <- fetchCardsWithIds res return $ Holder cards - + diff --git a/src/Algorithm/Lex.hs b/src/Algorithm/Lex.hs index 759650d..ce55817 100644 --- a/src/Algorithm/Lex.hs +++ b/src/Algorithm/Lex.hs @@ -82,6 +82,7 @@ data Token = deriving Show data QueryDef = SuperType String| + NotSuperType String | Color String | CMCLT Int | CMCMT Int | @@ -117,6 +118,7 @@ spawnBranch operator (Right res1) (Right res2) = Right (Func operator res1 res2) extractQueryDef :: (String, String) -> Either ParseError QueryDef extractQueryDef ("SuperType", value) = Right $ SuperType value +extractQueryDef ("NotSuperType", value) = Right $ NotSuperType value extractQueryDef ("CmcLT", value) = case readMaybe value :: Maybe Int of Just a -> Right $ CMCLT a Nothing -> Left $ ParseError "Could not parse number from call to CmcLT" diff --git a/src/Algorithm/Search.hs b/src/Algorithm/Search.hs index 386b4e6..267930d 100644 --- a/src/Algorithm/Search.hs +++ b/src/Algorithm/Search.hs @@ -48,6 +48,7 @@ buildHtml = concatMap cardToHtml executeBottomQuery :: Token -> IO Tree executeBottomQuery (Queri (SuperType value)) = superType value +executeBottomQuery (Queri (NotSuperType value)) = notSuperType value executeBottomQuery (Queri (CMCLT value)) = cmcLT value executeBottomQuery (Queri (CMCMT value)) = cmcMT value executeBottomQuery (Queri (CMCEQ value)) = cmcEQ value diff --git a/src/Seed.hs b/src/Seed.hs index c13efac..bfc58f0 100644 --- a/src/Seed.hs +++ b/src/Seed.hs @@ -71,6 +71,8 @@ data Legalities = Legalities{ }deriving (Show,Generic) instance FromJSON Legalities +data DbLegality = DbLegality Int Text Bool + data Card = Card{ c_id :: Text, lang :: Text, @@ -115,7 +117,9 @@ instance FromJSON Card where data DbCard = DbCard Int Text Text Text Text (Maybe Float) (Maybe Text) (Maybe Text) (Maybe Text) -instance ToRow Legalities +instance ToRow DbLegality where + toRow(DbLegality id format legalStatus) = + toRow(id, format, legalStatus) instance ToRow DbCard where toRow (DbCard id scryfall_id lang name layout cmc oracle_text type_line mana_cost) = @@ -161,7 +165,7 @@ seedData d = do execute_ conn "CREATE TABLE IF NOT EXISTS card (id INTEGER PRIMARY KEY, scryfall_id TEXT, lang TEXT, name TEXT, cmc INT, oracle_text TEXT, type_line TEXT, mana_cost TEXT)" execute_ conn "CREATE TABLE IF NOT EXISTS card_face (id INTEGER PRIMARY KEY,card_id INT, name TEXT, cmc INT, oracle_text TEXT, type_line TEXT, mana_cost TEXT)" execute_ conn "CREATE TABLE IF NOT EXISTS image_uris (id INTEGER PRIMARY KEY, card_face_id INT, small TEXT, normal TEXT, large TEXT, png TEXT, art_crop TEXT, border_crop TEXT)" - execute_ conn "CREATE TABLE IF NOT EXISTS legalities (id INTEGER PRIMARY KEY, card_id INT, standard TEXT, future TEXT, historic TEXT, gladiator TEXT, pioneer TEXT, explorer TEXT, modern TEXT, legacy TEXT, pauper TEXT, vintage TEXT, penny TEXT, commander TEXT, brawl TEXT, historicbrawl TEXT, alchemy TEXT, paupercommander TEXT, duel TEXT, oldschool TEXT, premodern TEXT, predh TEXT)" + execute_ conn "CREATE TABLE IF NOT EXISTS legalities (id INTEGER PRIMARY KEY,card_id INT, format TEXT, is_legal BOOL)" case d of @@ -184,7 +188,7 @@ getJSONWeb = fetchData --------------------------------------------------------------------------------------------------------- -collectCards :: Connection -> Int -> Int -> [Card] -> IO ([DbCard], [Legalities], [(CardFace, ImageUris)]) +collectCards :: Connection -> Int -> Int -> [Card] -> IO ([DbCard], [DbLegality], [(CardFace, ImageUris)]) --Skip illegal card types that are not relevant (These are difficult to parse as they contain non standard card formats) collectCards conn card_id card_face_id ((Card _ _ _ layout _ _ _ _ _ _ _):cards) | unpack layout `Prelude.elem` ["scheme", "token", "double_faced_token", "emblem", "art_series", "vanguard", "host"] = @@ -202,7 +206,7 @@ collectCards conn card_id card_face_id (card@(Card _ _ c_name _ c_cmc c_oracle_t let dbCard = cardToDbCard card_id card --insertRows conn dbCard legalities [(cardFace, imageUris)] (dbCards, legalitiesRest, cfius) <- collectCards conn (card_id + 1) (card_face_id + 1) cards - return (dbCard:dbCards, legalities:legalitiesRest, (cardFace, imageUris):cfius) + return (dbCard:dbCards, legalities++legalitiesRest, (cardFace, imageUris):cfius) --This will be ran when a card is multi face collectCards conn card_id card_face_id (card@(Card _ _ _ _ _ _ _ _ (Just card_faces) Nothing legal):cards) = do @@ -211,7 +215,7 @@ collectCards conn card_id card_face_id (card@(Card _ _ _ _ _ _ _ _ (Just card_fa let cardFacesAndImageUris = addCardIdToCardFaces card_id card_face_id card_faces --insertRows conn dbCard legalities cardFacesAndImageUris (dbCards, legalitiesRest, cfius) <- collectCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards - return (dbCard:dbCards, legalities:legalitiesRest, cardFacesAndImageUris ++ cfius) + return (dbCard:dbCards, legalities++legalitiesRest, cardFacesAndImageUris ++ cfius) --This will be ran when a card contains multiple cards on the front collectCards conn card_id card_face_id (card@(Card _ _ _ _ _ _ _ _ (Just card_faces) (Just image_uris) legal):cards) = do @@ -220,16 +224,17 @@ collectCards conn card_id card_face_id (card@(Card _ _ _ _ _ _ _ _ (Just card_fa let cardFacesAndImageUris = addCardIdAndImageUrisToCardFaces card_id card_face_id image_uris card_faces --insertRows conn dbCard legalities cardFacesAndImageUris (dbCards, legalitiesRest, cfius) <- collectCards conn (card_id + 1) (card_face_id + Prelude.length cardFacesAndImageUris+1) cards - return (dbCard:dbCards, legalities:legalitiesRest, cardFacesAndImageUris ++ cfius) + return (dbCard:dbCards, legalities++legalitiesRest, cardFacesAndImageUris ++ cfius) collectCards _ _ _ [] = return ([],[],[]) -- Helper functions for collectCards - -insertIdLegalities :: Legalities -> Int -> Legalities -insertIdLegalities (Legalities Nothing a b c d e f g h i j k l m n o p q r s t) id = Legalities (Just id) a b c d e f g h i j k l m n o p q r s t +--God help me i know this is garbage +insertIdLegalities :: Legalities -> Int -> [DbLegality] +insertIdLegalities (Legalities Nothing a b c d e f g h i j k l m n o p q r s t) id = + [DbLegality id "standard" (a=="legal"), DbLegality id "future" (b=="legal"), DbLegality id "historic" (c=="legal"), DbLegality id "gladiator" (d=="legal"), DbLegality id "pioneer" (e=="legal"), DbLegality id "explorer" (f=="legal"), DbLegality id "modern" (g=="legal"), DbLegality id "legacy" (h=="legal"), DbLegality id "pauper" (i=="legal"), DbLegality id "vintage" (j=="legal"), DbLegality id "penny" (k=="legal"), DbLegality id "commander" (l=="legal"), DbLegality id "brawl" (m=="legal"), DbLegality id "historicBrawl" (n=="legal"), DbLegality id "alchemy" (o=="legal"), DbLegality id "paupercommander" (p=="legal"), DbLegality id "duel" (q=="legal"), DbLegality id "oldschool" (r=="legal"), DbLegality id "premodern" (s=="legal"), DbLegality id "predh" (t=="legal")] insertIdLegalities _ _ = error $ "Illegal id insert into data legality" @@ -257,10 +262,10 @@ addCardIdToCardFaces _ _ [] = [] --------------------------------------------------------------------------------------------------------------------------------------------------------------------- -fillDb :: Connection -> ([DbCard], [Legalities], [(CardFace, ImageUris)]) -> IO () +fillDb :: Connection -> ([DbCard], [DbLegality], [(CardFace, ImageUris)]) -> IO () fillDb conn (dbCards, legalities, combo) = do let (cardFaces, imageUris) = unzip combo executeMany conn "INSERT INTO card (id, scryfall_id, lang, name, cmc, oracle_text, type_line, mana_cost ) VALUES (?,?,?,?,?,?,?,?)" dbCards executeMany conn "INSERT INTO card_face (id, card_id, name, cmc, oracle_text, type_line, mana_cost) VALUES (?,?,?,?,?,?,?)" cardFaces executeMany conn "INSERT INTO image_uris (card_face_id, small , normal , large , png , art_crop, border_crop) VALUES (?,?,?,?,?,?,?)" imageUris - executeMany conn "INSERT INTO legalities (card_id, standard , future , historic , gladiator , pioneer , explorer , modern , legacy , pauper , vintage , penny , commander , brawl , historicbrawl , alchemy , paupercommander , duel , oldschool , premodern, predh ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" legalities + executeMany conn "INSERT INTO legalities (card_id, format, is_legal) VALUES (?,?,?)" legalities