module TSL (Sentence
, Text
, TSL
, acceptTSL
, generateTSL
, learnTSL)
where
import Data.List (tails,nub,partition,isPrefixOf)
import Data.Function ((&))
subset :: Eq a => [a] -> [a] -> Bool
s :: [a]
s subset :: [a] -> [a] -> Bool
`subset` t :: [a]
t = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
t) [a]
s
data Delimited a = Start | Mid a | End deriving (Delimited a -> Delimited a -> Bool
(Delimited a -> Delimited a -> Bool)
-> (Delimited a -> Delimited a -> Bool) -> Eq (Delimited a)
forall a. Eq a => Delimited a -> Delimited a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Delimited a -> Delimited a -> Bool
$c/= :: forall a. Eq a => Delimited a -> Delimited a -> Bool
== :: Delimited a -> Delimited a -> Bool
$c== :: forall a. Eq a => Delimited a -> Delimited a -> Bool
Eq,Eq (Delimited a)
Eq (Delimited a) =>
(Delimited a -> Delimited a -> Ordering)
-> (Delimited a -> Delimited a -> Bool)
-> (Delimited a -> Delimited a -> Bool)
-> (Delimited a -> Delimited a -> Bool)
-> (Delimited a -> Delimited a -> Bool)
-> (Delimited a -> Delimited a -> Delimited a)
-> (Delimited a -> Delimited a -> Delimited a)
-> Ord (Delimited a)
Delimited a -> Delimited a -> Bool
Delimited a -> Delimited a -> Ordering
Delimited a -> Delimited a -> Delimited a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Delimited a)
forall a. Ord a => Delimited a -> Delimited a -> Bool
forall a. Ord a => Delimited a -> Delimited a -> Ordering
forall a. Ord a => Delimited a -> Delimited a -> Delimited a
min :: Delimited a -> Delimited a -> Delimited a
$cmin :: forall a. Ord a => Delimited a -> Delimited a -> Delimited a
max :: Delimited a -> Delimited a -> Delimited a
$cmax :: forall a. Ord a => Delimited a -> Delimited a -> Delimited a
>= :: Delimited a -> Delimited a -> Bool
$c>= :: forall a. Ord a => Delimited a -> Delimited a -> Bool
> :: Delimited a -> Delimited a -> Bool
$c> :: forall a. Ord a => Delimited a -> Delimited a -> Bool
<= :: Delimited a -> Delimited a -> Bool
$c<= :: forall a. Ord a => Delimited a -> Delimited a -> Bool
< :: Delimited a -> Delimited a -> Bool
$c< :: forall a. Ord a => Delimited a -> Delimited a -> Bool
compare :: Delimited a -> Delimited a -> Ordering
$ccompare :: forall a. Ord a => Delimited a -> Delimited a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Delimited a)
Ord)
instance Show a => Show (Delimited a) where
show :: Delimited a -> String
show Start = ">"
show End = "<"
show (Mid b :: a
b) = a -> String
forall a. Show a => a -> String
show a
b
delTest :: a
-> (b -> a)
-> a
-> Delimited b -> a
delTest :: a -> (b -> a) -> a -> Delimited b -> a
delTest s :: a
s m :: b -> a
m e :: a
e Start = a
s
delTest s :: a
s m :: b -> a
m e :: a
e (Mid a :: b
a) = b -> a
m b
a
delTest s :: a
s m :: b -> a
m e :: a
e End = a
e
type Sentence a = [a]
type Text a = [Sentence a]
delim :: Sentence a -> Sentence (Delimited a)
delim :: Sentence a -> Sentence (Delimited a)
delim word :: Sentence a
word = Delimited a
forall a. Delimited a
Start Delimited a -> Sentence (Delimited a) -> Sentence (Delimited a)
forall a. a -> [a] -> [a]
: (a -> Sentence (Delimited a) -> Sentence (Delimited a))
-> Sentence (Delimited a) -> Sentence a -> Sentence (Delimited a)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Delimited a -> Sentence (Delimited a) -> Sentence (Delimited a))
-> (a -> Delimited a)
-> a
-> Sentence (Delimited a)
-> Sentence (Delimited a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Delimited a
forall a. a -> Delimited a
Mid) [Delimited a
forall a. Delimited a
End] Sentence a
word
undelim :: Sentence (Delimited a) -> Sentence a
undelim :: Sentence (Delimited a) -> Sentence a
undelim = (Delimited a -> Sentence a -> Sentence a)
-> Sentence a -> Sentence (Delimited a) -> Sentence a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Sentence a -> Sentence a)
-> (a -> Sentence a -> Sentence a)
-> (Sentence a -> Sentence a)
-> Delimited a
-> Sentence a
-> Sentence a
forall a b. a -> (b -> a) -> a -> Delimited b -> a
delTest Sentence a -> Sentence a
forall a. a -> a
id (:) Sentence a -> Sentence a
forall a. a -> a
id) []
type Factor a = [Delimited a]
type Grammar a = [Factor a]
fac :: Int -> Sentence a -> Grammar a
fac :: Int -> Sentence a -> Grammar a
fac k :: Int
k sentence :: Sentence a
sentence = if Sentence a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Sentence a
sentence Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
then [Sentence a -> Sentence (Delimited a)
forall a. Sentence a -> Sentence (Delimited a)
delim Sentence a
sentence]
else Sentence a -> Grammar a
forall a. Sentence a -> [[Delimited a]]
getFac Sentence a
sentence
where
getFac :: Sentence a -> [[Delimited a]]
getFac = ([Delimited a] -> [[Delimited a]] -> [[Delimited a]])
-> [[Delimited a]] -> [[Delimited a]] -> [[Delimited a]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Delimited a -> [Delimited a] -> [Delimited a])
-> [Delimited a] -> [[Delimited a]] -> [[Delimited a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (:)) ([Delimited a] -> [[Delimited a]]
forall a. a -> [a]
repeat []) ([[Delimited a]] -> [[Delimited a]])
-> (Sentence a -> [[Delimited a]]) -> Sentence a -> [[Delimited a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[Delimited a]] -> [[Delimited a]]
forall a. Int -> [a] -> [a]
take Int
k ([[Delimited a]] -> [[Delimited a]])
-> (Sentence a -> [[Delimited a]]) -> Sentence a -> [[Delimited a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Delimited a] -> [[Delimited a]]
forall a. [a] -> [[a]]
tails ([Delimited a] -> [[Delimited a]])
-> (Sentence a -> [Delimited a]) -> Sentence a -> [[Delimited a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sentence a -> [Delimited a]
forall a. Sentence a -> Sentence (Delimited a)
delim
type Tier a = [a]
type TSL a = (Tier a, Grammar a)
project :: Eq a => Tier a -> Sentence a -> Sentence a
project :: Tier a -> Tier a -> Tier a
project tier :: Tier a
tier = (a -> Bool) -> Tier a -> Tier a
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Tier a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Tier a
tier)
acceptTSL :: Eq a => TSL a -> Int -> Sentence a -> Bool
acceptTSL :: TSL a -> Int -> Sentence a -> Bool
acceptTSL (tier :: Sentence a
tier,grammar :: Grammar a
grammar) k :: Int
k word :: Sentence a
word =
Int -> Sentence a -> Grammar a
forall a. Int -> Sentence a -> Grammar a
fac Int
k (Sentence a -> Sentence a -> Sentence a
forall a. Eq a => Tier a -> Tier a -> Tier a
project Sentence a
tier Sentence a
word) Grammar a -> Grammar a -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`subset` Grammar a
grammar
generateTSL :: Eq a => [a] -> Int -> TSL a -> [Sentence a]
generateTSL :: [a] -> Int -> TSL a -> [[a]]
generateTSL alphabet :: [a]
alphabet k :: Int
k (tier :: [a]
tier,grammar :: Grammar a
grammar) =
([Delimited a] -> Grammar a) -> [Delimited a] -> Tree [Delimited a]
forall a. (a -> [a]) -> a -> Tree a
mkTree (([Delimited a] -> Bool) -> Grammar a -> Grammar a
forall a. (a -> Bool) -> [a] -> [a]
filter [Delimited a] -> Bool
filterFunc (Grammar a -> Grammar a)
-> ([Delimited a] -> Grammar a) -> [Delimited a] -> Grammar a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Delimited a] -> Grammar a
nexts) [Delimited a
forall a. Delimited a
Start]
Tree [Delimited a]
-> (Tree [Delimited a] -> Grammar a) -> Grammar a
forall a b. a -> (a -> b) -> b
& Tree [Delimited a] -> Grammar a
forall a. Tree a -> [a]
breadthFirst
Grammar a -> (Grammar a -> Grammar a) -> Grammar a
forall a b. a -> (a -> b) -> b
& ([Delimited a] -> Bool) -> Grammar a -> Grammar a
forall a. (a -> Bool) -> [a] -> [a]
filter [Delimited a] -> Bool
forall a. [Delimited a] -> Bool
isFinished
Grammar a -> (Grammar a -> [[a]]) -> [[a]]
forall a b. a -> (a -> b) -> b
& ([Delimited a] -> [a]) -> Grammar a -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Delimited a] -> [a]
forall a. Sentence (Delimited a) -> [a]
makePretty
where
makePretty :: Sentence (Delimited a) -> [a]
makePretty = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a])
-> (Sentence (Delimited a) -> [a]) -> Sentence (Delimited a) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sentence (Delimited a) -> [a]
forall a. Sentence (Delimited a) -> [a]
undelim
isFinished :: [Delimited a] -> Bool
isFinished (End:_) = Bool
True
isFinished _ = Bool
False
nexts :: [Delimited a] -> Grammar a
nexts (End:_) = []
nexts l :: [Delimited a]
l = (Delimited a -> [Delimited a]) -> [Delimited a] -> Grammar a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Delimited a -> [Delimited a] -> [Delimited a]
forall a. a -> [a] -> [a]
: [Delimited a]
l) ([Delimited a] -> Grammar a) -> [Delimited a] -> Grammar a
forall a b. (a -> b) -> a -> b
$ [Delimited a] -> [Delimited a]
forall a. [a] -> [a]
tail ([a] -> [Delimited a]
forall a. Sentence a -> Sentence (Delimited a)
delim [a]
alphabet)
filterFunc :: [Delimited a] -> Bool
filterFunc xs :: [Delimited a]
xs = ([Delimited a] -> Bool) -> Grammar a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([Delimited a] -> [Delimited a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Delimited a]
initialSegment) Grammar a
grammar
where
initialSegment :: [Delimited a]
initialSegment = [Delimited a] -> [Delimited a]
forall a. [a] -> [a]
reverse ([Delimited a] -> [Delimited a]) -> [Delimited a] -> [Delimited a]
forall a b. (a -> b) -> a -> b
$ Int -> [Delimited a] -> [Delimited a]
forall a. Int -> [a] -> [a]
take Int
k ([Delimited a] -> [Delimited a]) -> [Delimited a] -> [Delimited a]
forall a b. (a -> b) -> a -> b
$ (Delimited a -> Bool) -> [Delimited a] -> [Delimited a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> (a -> Bool) -> Bool -> Delimited a -> Bool
forall a b. a -> (b -> a) -> a -> Delimited b -> a
delTest Bool
True ((a -> [a] -> Bool) -> [a] -> a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [a]
tier) Bool
True) [Delimited a]
xs
data Tree a = Tree a [Tree a]
mkTree :: (a -> [a]) -> a -> Tree a
mkTree :: (a -> [a]) -> a -> Tree a
mkTree next :: a -> [a]
next seed :: a
seed = a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Tree a
seed ([Tree a] -> Tree a) -> [Tree a] -> Tree a
forall a b. (a -> b) -> a -> b
$ (a -> Tree a) -> [a] -> [Tree a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> [a]) -> a -> Tree a
forall a. (a -> [a]) -> a -> Tree a
mkTree a -> [a]
next) ([a] -> [Tree a]) -> [a] -> [Tree a]
forall a b. (a -> b) -> a -> b
$ a -> [a]
next a
seed
breadthFirst :: Tree a -> [a]
breadthFirst :: Tree a -> [a]
breadthFirst tree :: Tree a
tree = [Tree a] -> [a]
forall a. [Tree a] -> [a]
bf [Tree a
tree]
where
bf :: [Tree a] -> [a]
bf [] = []
bf (Tree b :: a
b bs :: [Tree a]
bs : ts :: [Tree a]
ts) = a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Tree a] -> [a]
bf ([Tree a]
ts [Tree a] -> [Tree a] -> [Tree a]
forall a. [a] -> [a] -> [a]
++ [Tree a]
bs)
learnTSL :: Eq a => Int -> Text a -> TSL a
learnTSL :: Int -> Text a -> TSL a
learnTSL k :: Int
k text :: Text a
text = ([a]
tier, [Factor a]
grammar)
where
grammar :: [Factor a]
grammar = [Factor a] -> [Factor a]
forall a. Eq a => [a] -> [a]
nub ([Factor a] -> [Factor a]) -> [Factor a] -> [Factor a]
forall a b. (a -> b) -> a -> b
$ [[Factor a]] -> [Factor a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Factor a]] -> [Factor a]) -> [[Factor a]] -> [Factor a]
forall a b. (a -> b) -> a -> b
$ ([a] -> [Factor a]) -> Text a -> [[Factor a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [a] -> [Factor a]
forall a. Int -> Sentence a -> Grammar a
fac Int
k ([a] -> [Factor a]) -> ([a] -> [a]) -> [a] -> [Factor a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a] -> [a]
forall a. Eq a => Tier a -> Tier a -> Tier a
project [a]
tier) Text a
text
tier :: [a]
tier = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Factor a] -> [Factor a] -> [Factor a] -> a -> Bool
forall a. Eq a => Grammar a -> Grammar a -> Grammar a -> a -> Bool
testTier [Factor a]
kFacMinus [Factor a]
kFac [Factor a]
kFacPlus) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ Text a -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Text a
text
kFacMinus :: [Factor a]
kFacMinus = Text a
text Text a -> ([a] -> [Factor a]) -> [Factor a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Factor a] -> [Factor a]
forall a. Eq a => [a] -> [a]
nub ([Factor a] -> [Factor a])
-> ([a] -> [Factor a]) -> [a] -> [Factor a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [Factor a]
forall a. Int -> Sentence a -> Grammar a
fac (Int -> Int
forall a. Enum a => a -> a
pred Int
k)
kFac :: [Factor a]
kFac = Text a
text Text a -> ([a] -> [Factor a]) -> [Factor a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Factor a] -> [Factor a]
forall a. Eq a => [a] -> [a]
nub ([Factor a] -> [Factor a])
-> ([a] -> [Factor a]) -> [a] -> [Factor a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [Factor a]
forall a. Int -> Sentence a -> Grammar a
fac Int
k
kFacPlus :: [Factor a]
kFacPlus = Text a
text Text a -> ([a] -> [Factor a]) -> [Factor a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Factor a] -> [Factor a]
forall a. Eq a => [a] -> [a]
nub ([Factor a] -> [Factor a])
-> ([a] -> [Factor a]) -> [a] -> [Factor a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [Factor a]
forall a. Int -> Sentence a -> Grammar a
fac (Int -> Int
forall a. Enum a => a -> a
succ Int
k)
testTier :: Eq a => Grammar a -> Grammar a -> Grammar a -> a -> Bool
testTier :: Grammar a -> Grammar a -> Grammar a -> a -> Bool
testTier kFacMinus :: Grammar a
kFacMinus kFac :: Grammar a
kFac kFacPlus :: Grammar a
kFacPlus c :: a
c =
Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Grammar a
added Grammar a -> Grammar a -> Grammar a
forall a. [a] -> [a] -> [a]
++ Grammar a
removed) Grammar a -> Grammar a -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`subset` Grammar a
kFac
where
added :: Grammar a
added = [Factor a
added | Factor a
factor <- Grammar a
kFacMinus, Factor a
added <- a -> Factor a -> Grammar a
forall a. a -> Factor a -> [Factor a]
addLetter a
c Factor a
factor]
removed :: Grammar a
removed = [Factor a
removed | Factor a
factor <- Grammar a
kFacPlus, Factor a
removed <- a -> Factor a -> Grammar a
forall a. Eq a => a -> Factor a -> [Factor a]
removeLetter a
c Factor a
factor]
addLetter :: a -> Factor a -> [Factor a]
addLetter :: a -> Factor a -> [Factor a]
addLetter c :: a
c [] = []
addLetter c :: a
c (Start : ls :: Factor a
ls) = (Factor a -> Factor a) -> [Factor a] -> [Factor a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Delimited a
forall a. Delimited a
Start Delimited a -> Factor a -> Factor a
forall a. a -> [a] -> [a]
:) (a -> Factor a -> [Factor a]
forall a. a -> Factor a -> [Factor a]
addLetter a
c Factor a
ls)
addLetter c :: a
c (End : _) = [[a -> Delimited a
forall a. a -> Delimited a
Mid a
c,Delimited a
forall a. Delimited a
End]]
addLetter c :: a
c (Mid b :: a
b : ls :: Factor a
ls) = (a -> Delimited a
forall a. a -> Delimited a
Mid a
c Delimited a -> Factor a -> Factor a
forall a. a -> [a] -> [a]
: a -> Delimited a
forall a. a -> Delimited a
Mid a
b Delimited a -> Factor a -> Factor a
forall a. a -> [a] -> [a]
: Factor a
ls) Factor a -> [Factor a] -> [Factor a]
forall a. a -> [a] -> [a]
: (Factor a -> Factor a) -> [Factor a] -> [Factor a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Delimited a
forall a. a -> Delimited a
Mid a
b Delimited a -> Factor a -> Factor a
forall a. a -> [a] -> [a]
:) (a -> Factor a -> [Factor a]
forall a. a -> Factor a -> [Factor a]
addLetter a
c Factor a
ls)
removeLetter :: Eq a => a -> Factor a -> [Factor a]
removeLetter :: a -> Factor a -> [Factor a]
removeLetter c :: a
c [] = []
removeLetter c :: a
c (Mid b :: a
b:bs :: Factor a
bs) =
let removedList :: [Factor a]
removedList =
(Factor a -> Factor a) -> [Factor a] -> [Factor a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Delimited a
forall a. a -> Delimited a
Mid a
b Delimited a -> Factor a -> Factor a
forall a. a -> [a] -> [a]
:) ([Factor a] -> [Factor a]) -> [Factor a] -> [Factor a]
forall a b. (a -> b) -> a -> b
$ a -> Factor a -> [Factor a]
forall a. Eq a => a -> Factor a -> [Factor a]
removeLetter a
c Factor a
bs
in
if a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b then Factor a
bs Factor a -> [Factor a] -> [Factor a]
forall a. a -> [a] -> [a]
: [Factor a]
removedList else [Factor a]
removedList
removeLetter c :: a
c (Start:bs :: Factor a
bs) =
(Factor a -> Factor a) -> [Factor a] -> [Factor a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Delimited a
forall a. Delimited a
Start Delimited a -> Factor a -> Factor a
forall a. a -> [a] -> [a]
:) ([Factor a] -> [Factor a]) -> [Factor a] -> [Factor a]
forall a b. (a -> b) -> a -> b
$ a -> Factor a -> [Factor a]
forall a. Eq a => a -> Factor a -> [Factor a]
removeLetter a
c Factor a
bs
removeLetter c :: a
c (End:_) =
[]