diff --git a/lib/Text/Takkyuu/French.hs b/lib/Text/Takkyuu/French.hs index f843255ca0ebb49bbc7cb24383e5117b1e15f4aa..1fdfe6a605f3343f5c2fe962e5cbfda7640467f6 100644 --- a/lib/Text/Takkyuu/French.hs +++ b/lib/Text/Takkyuu/French.hs @@ -3,16 +3,16 @@ module Text.Takkyuu.French ( POS(..) , Gender(..) , MorphoLabel(..) + , typo , french , tag , syntax ) where -import Control.Monad.IO.Class (MonadIO(..)) import Data.Char (isSpace, toLower) import qualified Data.Map as Map (fromList) import qualified Data.Set as Set (fromList) -import Text.Takkyuu (Game, Label(..), Labeled(..), dico, labelizer, rules) +import Text.Takkyuu (Game, Label(..), Labeled(..), dico, fuzz, labelizer, rules) data POS = Determiner @@ -39,10 +39,13 @@ data MorphoLabel = MorphoLabel { type LabeledWord = Labeled String MorphoLabel -french:: MonadIO m => Game Char String m +typo :: Functor m => Game Char Char m +typo = fuzz $ Set.fromList ["bh"] + +french:: Functor m => Game Char String m french = dico toLower isSpace $ Set.fromList ["le", "la", "chat", "lait", "marché"] -tag :: Game String [LabeledWord] m +tag :: Functor m => Game String LabeledWord m tag = labelizer (fmap toLower) $ Map.fromList [ ("le", [MorphoLabel {pos = Determiner, gender = Masculine, number = Singular}]) @@ -60,7 +63,7 @@ tag = labelizer (fmap toLower) $ Map.fromList [ ]) ] -syntax :: Game LabeledWord [LabeledWord] m +syntax :: Functor m => Game LabeledWord [LabeledWord] m syntax = rules label . Set.fromList $ agreeSn <$> combinations where combinations = [(g, n) | g <- [Masculine, Feminine], n <- [Singular, Plural]] diff --git a/lib/Text/Takkyuu/IO.hs b/lib/Text/Takkyuu/IO.hs index f9a91e46d0f08290d29b18c1c47cdfcac560092a..40badc1ad47c620fb86fac20654d9f0e82fa54fe 100644 --- a/lib/Text/Takkyuu/IO.hs +++ b/lib/Text/Takkyuu/IO.hs @@ -9,11 +9,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import System.IO (Handle) import Text.Takkyuu.Internal (Game(..), Destination, Source) import Text.Takkyuu.Protocol (Move(..), Reply(..)) ---import Text.Takkyuu.Toolbox (effect) - - -effect :: Monad m => m () -> Game a b m -effect m = M (m *> pure mempty) +import Text.Takkyuu.Toolbox (effect) display :: MonadIO m => String -> Game a b m display = effect . liftIO . putStrLn diff --git a/lib/Text/Takkyuu/NLP.hs b/lib/Text/Takkyuu/NLP.hs index 610ec6bbfdd2ccec19446983c8a3acb7f13a20a5..af572feb1a4814f1c82e4e266d8182417c61e9bb 100644 --- a/lib/Text/Takkyuu/NLP.hs +++ b/lib/Text/Takkyuu/NLP.hs @@ -7,18 +7,16 @@ module Text.Takkyuu.NLP ( , rules ) where -import Control.Monad.IO.Class (MonadIO(..)) import Data.Map (Map, findWithDefault, insertWith) -import qualified Data.Map as Map (empty) +import qualified Data.Map as Map (empty, lookup) import Data.Set (Set) import qualified Data.Set as Set (empty, fromList, member) import Text.Takkyuu.Internal (Game(..), (//)) import Text.Takkyuu.Protocol (ExitStatus(..), Move(..), Reply(..)) -import Text.Takkyuu.Toolbox (accept, here, oneOf) +import Text.Takkyuu.Toolbox (accept, back, here, oneOf) -fuzz :: (Eq a, Ord a, MonadIO m) => Set [a] -> Game a a m ---fuzz :: (Eq a, Ord a, Functor m) => Set [a] -> Game a a m -fuzz classes = accept expand +fuzz :: (Eq a, Ord a, Functor m) => Set [a] -> Game a a m +fuzz classes = accept expand back where expand a = oneOf (a:findWithDefault [] a equiv) equiv = foldl (\tmp0 l -> @@ -27,9 +25,7 @@ fuzz classes = accept expand ) tmp0 l ) Map.empty classes -dico :: (MonadIO m, Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] m ---dico :: (Functor m, Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] m ---dico :: (Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] (StateT [String] IO) +dico :: (Functor m, Eq k, Ord k) => (a -> k) -> (k -> Bool) -> Set [k] -> Game a [a] m dico projector _ vocabulary = start where start = Opponent $ continueFrom ([], [vocabulary]) @@ -58,15 +54,18 @@ data Label l = | Label l deriving (Eq, Ord, Show) - data Labeled a l = Labeled { item :: a , label :: Label l } deriving (Eq, Ord, Show) -labelizer :: (a -> k) -> Map a [b] -> Game a [Labeled a b] m -labelizer = undefined +labelizer :: (Functor m, Ord k) => (a -> k) -> Map k [b] -> Game a (Labeled a b) m +labelizer projector labels = accept outputLabels back + where + outputLabels a = + let possibleLabels = Map.lookup (projector a) labels in + oneOf $ maybe [Labeled a Unknown] (Labeled a . Label <$>) possibleLabels -rules :: (a -> k) -> Set [k] -> Game a [a] m -rules = undefined +rules :: (Functor m, Ord k) => (a -> k) -> Set [k] -> Game a [a] m +rules projector = dico projector undefined diff --git a/lib/Text/Takkyuu/Toolbox.hs b/lib/Text/Takkyuu/Toolbox.hs index 23ee21f92492d0a5e90af7381058dd2c8dcb3388..cfa79a3f9eb90146b988b5c997b03862d2a155a4 100644 --- a/lib/Text/Takkyuu/Toolbox.hs +++ b/lib/Text/Takkyuu/Toolbox.hs @@ -5,30 +5,30 @@ module Text.Takkyuu.Toolbox ( , effect , fromEffect , accept + , handle , game , oneOf - , wire + , diode + , keep + , require , sink , runMonoid , runMonoidT , integrator ) where -import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.State (MonadState(..), modify, State, StateT(..), runState, runStateT) import Text.Takkyuu.Internal (Game(..), Destination, Match, (//), play) -import Text.Takkyuu.IO (display) import Text.Takkyuu.Protocol (ExitStatus(..), Move(..), Reply(..)) ---checkOk :: Reply b -> Game a b m -checkOk :: MonadIO m => Reply b -> Game a b m -checkOk Ok = display "ok" <> Finished Success -checkOk _ = display "no" <> Finished Failure +checkOk :: Reply b -> Game a b m +checkOk Ok = Finished Success +checkOk _ = Finished Failure -here :: MonadIO m => b -> Game a b m +here :: b -> Game a b m here a = Player (Here a, checkOk) -back :: MonadIO m => Game a b m +back :: Game a b m back = Player (Back, checkOk) fromEffect :: Monad m => m c -> (c -> Game a b m) -> Game a b m @@ -37,32 +37,37 @@ fromEffect m f = M (m >>= pure . f) effect :: Monad m => m () -> Game a b m effect m = M (m *> pure mempty) -accept :: MonadIO m => (a -> Game a b m) -> Game a b m ---accept :: Functor m => (a -> Game a b m) -> Game a b m -accept f = Opponent use +handle :: Functor m => (a -> (Reply a, Game a b m)) -> Game a b m -> Game a b m +handle whenHere whenBack = Opponent use where - use (Here a) = (Ok, f a <> accept f) - use Back = (Ok, back <> accept f) + use (Here a) = (<> handle whenHere whenBack) <$> whenHere a + use Back = (Ok, whenBack <> handle whenHere whenBack) use (Finish exitStatus) = (Ok, Finished exitStatus) -wire :: MonadIO m => Game a a m ---wire :: Functor m => Game a a m -wire = accept here -{- -wire = Opponent pass - where - pass (Finish exitStatus) = (Ok, Finished exitStatus) - pass m = --} +accept :: Functor m => (a -> Game a b m) -> Game a b m -> Game a b m +accept f = handle ((,) Ok . f) + +diode :: Functor m => Game a a m +diode = accept here back -game :: (MonadIO m, Foldable f) => f b -> Game a b m ---game :: (Functor m, Foldable f) => f b -> Game a b m +game :: (Functor m, Foldable f) => f b -> Game a b m game = foldr (\a s -> here a <> s) (Finished Success) -oneOf :: (MonadIO m, Foldable f) => f b -> Game a b m ---oneOf :: (Functor m, Foldable f) => f b -> Game a b m +oneOf :: (Functor m, Foldable f) => f b -> Game a b m oneOf = foldr (\a s -> here a // s) (Finished Failure) +keep :: Functor m => (a -> Bool) -> Game a a m +keep predicate = handle skipOthers back + where + skipOthers a = (Ok, if predicate a then here a else mempty) + +require :: Functor m => (a -> Bool) -> Game a a m +require predicate = handle replaceOthers back + where + replaceOthers a + | predicate a = (Ok, here a) + | otherwise = (No, mempty) + integrator :: MonadState [a] m => Destination a m integrator = Opponent record where