> {-# 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 = forall a. Ord a => Int -> [a] -> SLG a
fSL Int
k [a]
w, tslGK1 :: SLG a
tslGK1 = forall a. Ord a => Int -> [a] -> SLG a
fSL (Int
k 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 = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
n) (forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet TSLG a
g)
>     where n :: a -> Bool
n   = forall a. (a -> Bool) -> (a -> Bool) -> a -> Bool
both a -> Bool
r a -> Bool
p
>           r :: a -> Bool
r a
x = forall c a. (Container c a, Eq a) => c -> c -> Bool
isSubsetOf (forall a. SLG a -> Set (Bool, [a], Bool)
slg forall a b. (a -> b) -> a -> b
$ forall a. TSLG a -> SLG a
tslGK TSLG a
g) forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
gDrop a
x (forall a. SLG a -> Set (Bool, [a], Bool)
slg forall a b. (a -> b) -> a -> b
$ forall a. TSLG a -> SLG a
tslGK1 TSLG a
g)
>           p :: a -> Bool
p a
x = forall c a. (Container c a, Eq a) => c -> c -> Bool
isSubsetOf (forall a. SLG a -> Set (Bool, [a], Bool)
slg forall a b. (a -> b) -> a -> b
$ forall a. TSLG a -> SLG a
tslGK1 TSLG a
g) forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
a -> Set (Bool, [a], Bool) -> Set (Bool, [a], Bool)
gIn a
x (forall a. SLG a -> Set (Bool, [a], Bool)
slg forall a b. (a -> b) -> a -> b
$ 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 = forall a. SLG a -> Int
slgK SLG a
gk
>                     , slg :: Set (Bool, [a], Bool)
slg = forall (s :: * -> *) a.
(Collapsible s, Container (s a) a) =>
(a -> Bool) -> s a -> s a
keep forall {t :: * -> *} {a} {c}. Foldable t => (a, t a, c) -> Bool
f (forall a. SLG a -> Set (Bool, [a], Bool)
slg SLG a
gk)
>                     }
>     where gk :: SLG a
gk = forall a. TSLG a -> SLG a
tslGK TSLG a
g
>           t :: Set a
t = forall a. Ord a => TSLG a -> Set a
tslgTier TSLG a
g
>           f :: (a, t a, c) -> Bool
f (a
_, t a
a, c
_) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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
forall a. Eq a => TSLG a -> TSLG a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TSLG a -> TSLG a -> Bool
$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
Eq, TSLG a -> TSLG a -> Bool
TSLG a -> TSLG a -> Ordering
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
min :: TSLG a -> TSLG a -> TSLG a
$cmin :: forall a. Ord a => TSLG a -> TSLG a -> TSLG a
max :: TSLG a -> TSLG a -> TSLG a
$cmax :: forall a. Ord a => TSLG a -> TSLG a -> TSLG a
>= :: 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
$c< :: forall a. Ord a => TSLG a -> TSLG a -> Bool
compare :: TSLG a -> TSLG a -> Ordering
$ccompare :: forall a. Ord a => TSLG a -> TSLG a -> Ordering
Ord, ReadPrec [TSLG a]
ReadPrec (TSLG a)
ReadS [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
readListPrec :: ReadPrec [TSLG a]
$creadListPrec :: forall a. (Read a, Ord a) => ReadPrec [TSLG a]
readPrec :: ReadPrec (TSLG a)
$creadPrec :: forall a. (Read a, Ord a) => ReadPrec (TSLG a)
readList :: ReadS [TSLG a]
$creadList :: forall a. (Read a, Ord a) => ReadS [TSLG a]
readsPrec :: Int -> ReadS (TSLG a)
$creadsPrec :: forall a. (Read a, Ord a) => Int -> ReadS (TSLG a)
Read, Int -> TSLG a -> ShowS
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
showList :: [TSLG a] -> ShowS
$cshowList :: forall a. Show a => [TSLG a] -> ShowS
show :: TSLG a -> String
$cshow :: forall a. Show a => TSLG a -> String
showsPrec :: Int -> TSLG a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> TSLG a -> ShowS
Show)

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

> instance Grammar TSLG
>     where emptyG :: forall a. Ord a => TSLG a
emptyG = forall a. SLG a -> SLG a -> TSLG a
TSLG forall (g :: * -> *) a. (Grammar g, Ord a) => g a
emptyG 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   =  forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> g a
augmentG (forall a. TSLG a -> SLG a
tslGK TSLG a
g1)  (forall a. TSLG a -> SLG a
tslGK TSLG a
g2)
>                      , tslGK1 :: SLG a
tslGK1  =  forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> g a
augmentG (forall a. TSLG a -> SLG a
tslGK1 TSLG a
g1) (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 = forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> Bool
isSubGOf (forall a. TSLG a -> SLG a
tslGK TSLG a
g1) (forall a. TSLG a -> SLG a
tslGK TSLG a
g2)
>                            Bool -> Bool -> Bool
&& forall (g :: * -> *) a. (Grammar g, Ord a) => g a -> g a -> Bool
isSubGOf (forall a. TSLG a -> SLG a
tslGK1 TSLG a
g1) (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 = forall e n. (Ord e, Ord n) => FSA n e -> FSA Integer e
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Ord a, Ord b) => FSA a (Maybe b) -> FSA a b
desemantify forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall a b.
(Ord a, Ord b) =>
Set b -> FSA a (Maybe b) -> FSA a (Maybe b)
tierify (forall a. Ord a => TSLG a -> Set a
tslgTier TSLG a
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall e e1 n.
(Ord e, Ord e1, Ord n) =>
(e -> e1) -> FSA n e -> FSA n e1
renameSymbolsBy forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall a b.
(Ord a, Ord b) =>
Set b -> FSA a b -> FSA (Maybe Integer, Maybe a) b
extendAlphabetTo (forall (g :: * -> *) e. HasAlphabet g => g e -> Set e
alphabet TSLG a
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>                      forall (g :: * -> *) a.
(Grammar g, NFData a, Ord a) =>
g a -> FSA Integer a
genFSA forall a b. (a -> b) -> a -> b
$ 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 = 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 (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 = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. a -> [a] -> [a]
: [a]
xs) forall a. a -> [a] -> [a]
:
>               case [a]
xs
>               of []      ->  []
>                  (a
y:[a]
ys)  ->  forall a b. (a -> b) -> [a] -> [b]
map (a
y forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ 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 = 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 (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 = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Eq a => a -> a -> Bool
/= a
a = [[a]]
ns
>     | Bool
otherwise = [a]
xs forall a. a -> [a] -> [a]
: [[a]]
ns
>     where ns :: [[a]]
ns = forall a b. (a -> b) -> [a] -> [b]
map (a
x forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ 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 = forall (c :: * -> *) a b.
Collapsible c =>
(a -> b -> b) -> b -> c a -> b
collapse (forall c a. Container c a => c -> c -> c
union forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) 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) = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\b
a -> (x
h, b
a, y
t)) forall a b. (a -> b) -> a -> b
$ a -> Set b
f a
s