> {-# OPTIONS_HADDOCK show-extensions #-}
> {-|
> Module    : LTK.Learn.TSL.ViaSL
> Copyright : (c) 2020,2023 Dakotah Lambert
> License   : MIT

> This module implements a string extension learner for the TSL class.
> A variant of the tier-finding algorithm of Jardine and McMullin (2017)
> is used.
> Under a Gold-style framework of learning in the limit from positive data,
> a strictly local grammar can be reinterpreted as a tier-based grammar.
> 
> For the original work, see https://doi.org/10.1007/978-3-319-53733-7_4
>
> @since 0.3
> -}

> module LTK.Learn.TSL.ViaSL(TSLG, fTSL) where

> import Data.Set (Set)
> import qualified Data.Set as Set

> import LTK.FSA
> import LTK.Learn.StringExt
> import LTK.Learn.SL

> -- |Extract information from a word.
> fTSL :: Ord a => Int -> [a] -> TSLG a
> fTSL :: forall a. Ord a => Int -> [a] -> TSLG a
fTSL Int
k [a]
w = TSLG { tslGK :: SLG a
tslGK = Int -> [a] -> SLG a
forall a. Ord a => Int -> [a] -> SLG a
fSL Int
k [a]
w, tslGK1 :: SLG a
tslGK1 = Int -> [a] -> SLG a
forall a. Ord a => Int -> [a] -> SLG a
fSL (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
w }

> tslgTier :: Ord a => TSLG a -> Set a
> tslgTier :: forall a. Ord a => TSLG a -> Set a
tslgTier TSLG a
g = (a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
n) (TSLG a -> Set a
forall e. TSLG e -> Set e
forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet TSLG a
g)
>     where n :: a -> Bool
n   = (a -> Bool) -> (a -> Bool) -> a -> Bool
forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
both a -> Bool
r a -> Bool
p
>           r :: a -> Bool
r a
x = Set (Bool, [a], Bool) -> Set (Bool, [a], Bool) -> Bool
forall c a. (Container c a, Eq a) => c -> c -> Bool
isSubsetOf (SLG a -> Set (Bool, [a], Bool)
forall a. SLG a -> Set (Bool, [a], Bool)
slg (SLG a -> Set (Bool, [a], Bool)) -> SLG a -> Set (Bool, [a], Bool)
forall a b. (a -> b) -> a -> b
$ TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK TSLG a
g) (Set (Bool, [a], Bool) -> Bool) -> Set (Bool, [a], Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
forall a.
Ord a =>
a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
gDrop a
x (SLG a -> Set (Bool, [a], Bool)
forall a. SLG a -> Set (Bool, [a], Bool)
slg (SLG a -> Set (Bool, [a], Bool)) -> SLG a -> Set (Bool, [a], Bool)
forall a b. (a -> b) -> a -> b
$ TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK1 TSLG a
g)
>           p :: a -> Bool
p a
x = Set (Bool, [a], Bool) -> Set (Bool, [a], Bool) -> Bool
forall c a. (Container c a, Eq a) => c -> c -> Bool
isSubsetOf (SLG a -> Set (Bool, [a], Bool)
forall a. SLG a -> Set (Bool, [a], Bool)
slg (SLG a -> Set (Bool, [a], Bool)) -> SLG a -> Set (Bool, [a], Bool)
forall a b. (a -> b) -> a -> b
$ TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK1 TSLG a
g) (Set (Bool, [a], Bool) -> Bool) -> Set (Bool, [a], Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
forall a.
Ord a =>
a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
gIn a
x (SLG a -> Set (Bool, [a], Bool)
forall a. SLG a -> Set (Bool, [a], Bool)
slg (SLG a -> Set (Bool, [a], Bool)) -> SLG a -> Set (Bool, [a], Bool)
forall a b. (a -> b) -> a -> b
$ TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK TSLG a
g)

> slgFromTslg :: Ord a => TSLG a -> SLG a
> slgFromTslg :: forall a. Ord a => TSLG a -> SLG a
slgFromTslg TSLG a
g = SLG { slgAlpha :: Set a
slgAlpha = Set a
t
>                     , slgK :: Int
slgK = SLG a -> Int
forall a. SLG a -> Int
slgK SLG a
gk
>                     , slg :: Set (Bool, [a], Bool)
slg = ((Bool, [a], Bool) -> Bool)
-> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep (Bool, [a], Bool) -> Bool
forall {t :: * -> *} {a} {c}. Foldable t => (a, t a, c) -> Bool
f (SLG a -> Set (Bool, [a], Bool)
forall a. SLG a -> Set (Bool, [a], Bool)
slg SLG a
gk)
>                     }
>     where gk :: SLG a
gk = TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK TSLG a
g
>           t :: Set a
t = TSLG a -> Set a
forall a. Ord a => TSLG a -> Set a
tslgTier TSLG a
g
>           f :: (a, t a, c) -> Bool
f (a
_, t a
a, c
_) = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Set a -> a -> Bool
forall c a. (Container c a, Eq a) => c -> a -> Bool
isIn Set a
t) t a
a



> -- |A representation of a TSL grammar.
> data TSLG a = TSLG { forall a. TSLG a -> SLG a
tslGK :: SLG a, forall a. TSLG a -> SLG a
tslGK1 :: SLG a }
>               deriving (TSLG a -> TSLG a -> Bool
(TSLG a -> TSLG a -> Bool)
-> (TSLG a -> TSLG a -> Bool) -> Eq (TSLG a)
forall a. Eq a => TSLG a -> TSLG a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => TSLG a -> TSLG a -> Bool
== :: TSLG a -> TSLG a -> Bool
$c/= :: forall a. Eq a => TSLG a -> TSLG a -> Bool
/= :: TSLG a -> TSLG a -> Bool
Eq, Eq (TSLG a)
Eq (TSLG a) =>
(TSLG a -> TSLG a -> Ordering)
-> (TSLG a -> TSLG a -> Bool)
-> (TSLG a -> TSLG a -> Bool)
-> (TSLG a -> TSLG a -> Bool)
-> (TSLG a -> TSLG a -> Bool)
-> (TSLG a -> TSLG a -> TSLG a)
-> (TSLG a -> TSLG a -> TSLG a)
-> Ord (TSLG a)
TSLG a -> TSLG a -> Bool
TSLG a -> TSLG a -> Ordering
TSLG a -> TSLG a -> TSLG 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 (TSLG a)
forall a. Ord a => TSLG a -> TSLG a -> Bool
forall a. Ord a => TSLG a -> TSLG a -> Ordering
forall a. Ord a => TSLG a -> TSLG a -> TSLG a
$ccompare :: forall a. Ord a => TSLG a -> TSLG a -> Ordering
compare :: TSLG a -> TSLG a -> Ordering
$c< :: forall a. Ord a => TSLG a -> TSLG a -> Bool
< :: TSLG a -> TSLG a -> Bool
$c<= :: forall a. Ord a => TSLG a -> TSLG a -> Bool
<= :: TSLG a -> TSLG a -> Bool
$c> :: forall a. Ord a => TSLG a -> TSLG a -> Bool
> :: TSLG a -> TSLG a -> Bool
$c>= :: forall a. Ord a => TSLG a -> TSLG a -> Bool
>= :: TSLG a -> TSLG a -> Bool
$cmax :: forall a. Ord a => TSLG a -> TSLG a -> TSLG a
max :: TSLG a -> TSLG a -> TSLG a
$cmin :: forall a. Ord a => TSLG a -> TSLG a -> TSLG a
min :: TSLG a -> TSLG a -> TSLG a
Ord, ReadPrec [TSLG a]
ReadPrec (TSLG a)
Int -> ReadS (TSLG a)
ReadS [TSLG a]
(Int -> ReadS (TSLG a))
-> ReadS [TSLG a]
-> ReadPrec (TSLG a)
-> ReadPrec [TSLG a]
-> Read (TSLG a)
forall a. (Read a, Ord a) => ReadPrec [TSLG a]
forall a. (Read a, Ord a) => ReadPrec (TSLG a)
forall a. (Read a, Ord a) => Int -> ReadS (TSLG a)
forall a. (Read a, Ord a) => ReadS [TSLG a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. (Read a, Ord a) => Int -> ReadS (TSLG a)
readsPrec :: Int -> ReadS (TSLG a)
$creadList :: forall a. (Read a, Ord a) => ReadS [TSLG a]
readList :: ReadS [TSLG a]
$creadPrec :: forall a. (Read a, Ord a) => ReadPrec (TSLG a)
readPrec :: ReadPrec (TSLG a)
$creadListPrec :: forall a. (Read a, Ord a) => ReadPrec [TSLG a]
readListPrec :: ReadPrec [TSLG a]
Read, Int -> TSLG a -> ShowS
[TSLG a] -> ShowS
TSLG a -> String
(Int -> TSLG a -> ShowS)
-> (TSLG a -> String) -> ([TSLG a] -> ShowS) -> Show (TSLG a)
forall a. Show a => Int -> TSLG a -> ShowS
forall a. Show a => [TSLG a] -> ShowS
forall a. Show a => TSLG a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TSLG a -> ShowS
showsPrec :: Int -> TSLG a -> ShowS
$cshow :: forall a. Show a => TSLG a -> String
show :: TSLG a -> String
$cshowList :: forall a. Show a => [TSLG a] -> ShowS
showList :: [TSLG a] -> ShowS
Show)

> instance HasAlphabet TSLG
>     where alphabet :: forall e. TSLG e -> Set e
alphabet = SLG e -> Set e
forall e. SLG e -> Set e
forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet (SLG e -> Set e) -> (TSLG e -> SLG e) -> TSLG e -> Set e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSLG e -> SLG e
forall a. TSLG a -> SLG a
tslGK1

> instance Grammar TSLG
>     where emptyG :: forall a. Ord a => TSLG a
emptyG = SLG a -> SLG a -> TSLG a
forall a. SLG a -> SLG a -> TSLG a
TSLG SLG a
forall a. Ord a => SLG a
forall (g :: * -> *) a. (Grammar g, Ord a) => g a
emptyG SLG a
forall a. Ord a => SLG a
forall (g :: * -> *) a. (Grammar g, Ord a) => g a
emptyG
>           augmentG :: forall a. Ord a => TSLG a -> TSLG a -> TSLG a
augmentG TSLG a
g1 TSLG a
g2
>               = TSLG { tslGK :: SLG a
tslGK   =  SLG a -> SLG a -> SLG a
forall a. Ord a => SLG a -> SLG a -> SLG a
forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> g a
augmentG (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK TSLG a
g1)  (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK TSLG a
g2)
>                      , tslGK1 :: SLG a
tslGK1  =  SLG a -> SLG a -> SLG a
forall a. Ord a => SLG a -> SLG a -> SLG a
forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> g a
augmentG (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK1 TSLG a
g1) (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK1 TSLG a
g2)}
>           isSubGOf :: forall a. Ord a => TSLG a -> TSLG a -> Bool
isSubGOf TSLG a
g1 TSLG a
g2 = SLG a -> SLG a -> Bool
forall a. Ord a => SLG a -> SLG a -> Bool
forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> Bool
isSubGOf (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK TSLG a
g1) (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK TSLG a
g2)
>                            Bool -> Bool -> Bool
&& SLG a -> SLG a -> Bool
forall a. Ord a => SLG a -> SLG a -> Bool
forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> Bool
isSubGOf (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK1 TSLG a
g1) (TSLG a -> SLG a
forall a. TSLG a -> SLG a
tslGK1 TSLG a
g2)
>           genFSA :: forall a. (NFData a, Ord a) => TSLG a -> FSA Integer a
genFSA TSLG a
g = FSA (Maybe Integer, Maybe Integer) a -> FSA Integer a
forall e n. (Ord e, Ord n) => FSA n e -> FSA Integer e
normalize (FSA (Maybe Integer, Maybe Integer) a -> FSA Integer a)
-> (SLG a -> FSA (Maybe Integer, Maybe Integer) a)
-> SLG a
-> FSA Integer a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSA (Maybe Integer, Maybe Integer) (Maybe a)
-> FSA (Maybe Integer, Maybe Integer) a
forall a b. (Ord a, Ord b) => FSA a (Maybe b) -> FSA a b
desemantify (FSA (Maybe Integer, Maybe Integer) (Maybe a)
 -> FSA (Maybe Integer, Maybe Integer) a)
-> (SLG a -> FSA (Maybe Integer, Maybe Integer) (Maybe a))
-> SLG a
-> FSA (Maybe Integer, Maybe Integer) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      Set a
-> FSA (Maybe Integer, Maybe Integer) (Maybe a)
-> FSA (Maybe Integer, Maybe Integer) (Maybe a)
forall a b.
(Ord a, Ord b) =>
Set b -> FSA a (Maybe b) -> FSA a (Maybe b)
tierify (TSLG a -> Set a
forall a. Ord a => TSLG a -> Set a
tslgTier TSLG a
g) (FSA (Maybe Integer, Maybe Integer) (Maybe a)
 -> FSA (Maybe Integer, Maybe Integer) (Maybe a))
-> (SLG a -> FSA (Maybe Integer, Maybe Integer) (Maybe a))
-> SLG a
-> FSA (Maybe Integer, Maybe Integer) (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      (a -> Maybe a)
-> FSA (Maybe Integer, Maybe Integer) a
-> FSA (Maybe Integer, Maybe Integer) (Maybe a)
forall e e1 n.
(Ord e, Ord e1, Ord n) =>
(e -> e1) -> FSA n e -> FSA n e1
renameSymbolsBy a -> Maybe a
forall a. a -> Maybe a
Just (FSA (Maybe Integer, Maybe Integer) a
 -> FSA (Maybe Integer, Maybe Integer) (Maybe a))
-> (SLG a -> FSA (Maybe Integer, Maybe Integer) a)
-> SLG a
-> FSA (Maybe Integer, Maybe Integer) (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      Set a -> FSA Integer a -> FSA (Maybe Integer, Maybe Integer) a
forall a b.
(Ord a, Ord b) =>
Set b -> FSA a b -> FSA (Maybe Integer, Maybe a) b
extendAlphabetTo (TSLG a -> Set a
forall e. TSLG e -> Set e
forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet TSLG a
g) (FSA Integer a -> FSA (Maybe Integer, Maybe Integer) a)
-> (SLG a -> FSA Integer a)
-> SLG a
-> FSA (Maybe Integer, Maybe Integer) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      SLG a -> FSA Integer a
forall a. (NFData a, Ord a) => SLG a -> FSA Integer a
forall (g :: * -> *) a.
(Grammar g, NFData a, Ord a) =>
g a -> FSA Integer a
genFSA (SLG a -> FSA Integer a) -> SLG a -> FSA Integer a
forall a b. (a -> b) -> a -> b
$ TSLG a -> SLG a
forall a. Ord a => TSLG a -> SLG a
slgFromTslg TSLG a
g



> gIn :: Ord a => a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
> gIn :: forall a.
Ord a =>
a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
gIn a
x = ([a] -> Set [a]) -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
forall a b x y.
(Ord a, Ord b, Ord x, Ord y) =>
(a -> Set b) -> Set (x, a, y) -> Set (x, b, y)
gSet (a -> [a] -> Set [a]
forall a. Ord a => a -> [a] -> Set [a]
putIn a
x)

> putIn :: Ord a => a -> [a] -> Set [a]
> putIn :: forall a. Ord a => a -> [a] -> Set [a]
putIn a
a = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
Set.fromList ([[a]] -> Set [a]) -> ([a] -> [[a]]) -> [a] -> Set [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a] -> [[a]]
forall a. a -> [a] -> [[a]]
putIn' a
a

> putIn' :: a -> [a] -> [[a]]
> putIn' :: forall a. a -> [a] -> [[a]]
putIn' a
a [a]
xs = (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:
>               case [a]
xs
>               of []      ->  []
>                  (a
y:[a]
ys)  ->  ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [[a]]
forall a. a -> [a] -> [[a]]
putIn' a
a [a]
ys

> gDrop :: Ord a => a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
> gDrop :: forall a.
Ord a =>
a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
gDrop a
x = ([a] -> Set [a]) -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
forall a b x y.
(Ord a, Ord b, Ord x, Ord y) =>
(a -> Set b) -> Set (x, a, y) -> Set (x, b, y)
gSet (a -> [a] -> Set [a]
forall a. Ord a => a -> [a] -> Set [a]
dropOneOf a
x)

> dropOneOf :: Ord a => a -> [a] -> Set [a]
> dropOneOf :: forall a. Ord a => a -> [a] -> Set [a]
dropOneOf a
x = [[a]] -> Set [a]
forall a. Ord a => [a] -> Set a
Set.fromList ([[a]] -> Set [a]) -> ([a] -> [[a]]) -> [a] -> Set [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a] -> [[a]]
forall a. Eq a => a -> [a] -> [[a]]
dropOneOf' a
x

> dropOneOf' :: Eq a => a -> [a] -> [[a]]
> dropOneOf' :: forall a. Eq a => a -> [a] -> [[a]]
dropOneOf' a
_ [] = []
> dropOneOf' a
a (a
x:[a]
xs)
>     | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
a = [[a]]
ns
>     | Bool
otherwise = [a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
ns
>     where ns :: [[a]]
ns = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [[a]]
forall a. Eq a => a -> [a] -> [[a]]
dropOneOf' a
a [a]
xs

> gSet :: (Ord a, Ord b, Ord x, Ord y) =>
>         (a -> Set b) -> Set (x, a, y) -> Set (x, b, y)
> gSet :: forall a b x y.
(Ord a, Ord b, Ord x, Ord y) =>
(a -> Set b) -> Set (x, a, y) -> Set (x, b, y)
gSet a -> Set b
f = ((x, a, y) -> Set (x, b, y) -> Set (x, b, y))
-> Set (x, b, y) -> Set (x, a, y) -> Set (x, b, y)
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (Set (x, b, y) -> Set (x, b, y) -> Set (x, b, y)
forall c a. Container c a => c -> c -> c
union (Set (x, b, y) -> Set (x, b, y) -> Set (x, b, y))
-> ((x, a, y) -> Set (x, b, y))
-> (x, a, y)
-> Set (x, b, y)
-> Set (x, b, y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set b) -> (x, a, y) -> Set (x, b, y)
forall a b x y.
(Ord a, Ord b, Ord x, Ord y) =>
(a -> Set b) -> (x, a, y) -> Set (x, b, y)
gDo a -> Set b
f) Set (x, b, y)
forall c a. Container c a => c
empty

> gDo :: (Ord a, Ord b, Ord x, Ord y) =>
>        (a -> Set b) -> (x, a, y) -> Set (x, b, y)
> gDo :: forall a b x y.
(Ord a, Ord b, Ord x, Ord y) =>
(a -> Set b) -> (x, a, y) -> Set (x, b, y)
gDo a -> Set b
f (x
h, a
s, y
t) = (b -> (x, b, y)) -> Set b -> Set (x, b, y)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\b
a -> (x
h, b
a, y
t)) (Set b -> Set (x, b, y)) -> Set b -> Set (x, b, y)
forall a b. (a -> b) -> a -> b
$ a -> Set b
f a
s