{-|
Module      : TSL
Description : Tier-based Strictly Local Grammars and Applications
Copyright   : (c) Greg Kobele, 2019
Maintainer  : gkobele@uni-leipzig.de

This module implements Tier-based Strictly local string grammars, and
parsing, generation, and learning algorithms for them:

[Parsing]: How could we use a grammar to understand (recognize) language data?

[Generation]: How could we use a grammar to construct a sentence?

[Learning]: How could we learn a grammar from language data?
-}

module TSL (Sentence
           , Text
           , TSL
           , acceptTSL
           , generateTSL
           , learnTSL)
where


import Data.List (tails,nub,partition,isPrefixOf)
import Data.Function ((&))

{- We will make use of set operations on lists, in particular, 'subset' -}
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


-- * Delimited Strings

{- A string is delimited iff it begins with 'Start', ends with 'End',
 and the symbols in between are of the form 'Mid' a. -}
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

{- We compute a value given a 'Delimited' b as input. -}
delTest :: a        -- ^ The value to return if given 'Start'
        -> (b -> a) -- ^ How to compute the value if given a 'Mid' b
        -> a        -- ^ The value to return if given 'End'
        -> 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

-- The following type abbreviations make the types of our functions
-- easier to read

-- | a sentence is a list of symbols
type Sentence a = [a]
-- | a text is a list of sentences
type Text a = [Sentence a]

{- Sentences can be delimited by adding a 'Start' to their front, and
 'End' to their end, and prefixing each symbol with a 'Mid' -}
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

{- A delimited sentence can be undelimited by erasing the 'Start' and
 'End' symbols, and removing the prefix 'Mid' from the symbols in
 between -}
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) []

-- * Grammars and Factors
--
-- We introduce some more type abbreviations, this time for the
-- objects we use for describing 'Sentences'.

type Factor a = [Delimited a] -- ^ a factor is just a sequence of segments
type Grammar a = [Factor a] -- ^ a grammar is just a list of factors

{- The function 'fac' breaks a sentence up into its factors (of length
 given by its 'Int' argument).  If its input sentence is too short, it
 just returns the input as a single (but possibly shorter than
 desired) factor. -}
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


-- * TSL Grammars

type Tier a = [a] -- ^ a tier is defined by specifying which items appear on it

type TSL a = (Tier a, Grammar a)
-- ^ a TSL grammar consists of
--
--    1. a tier, and
--
--    2. an SL grammar

{-
  Projecting a string onto a Tier can be implemented by erasing all
  non-tier relevant segments.
-}
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)

-- ** Parsing

-- | determining whether a sentence is generated by the grammar is a
--  matter of checking that its factors are permitted by the grammar
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


-- ** Generation
--
-- We can generate all grammatical sentences from a grammar, by
-- enumerating them one by one (i.e. by outputting a list of the
-- grammatical sentences).  We could do this in a number of ways, but
-- an important desideratum is that every sentence of the grammar be
-- at some finite point in the enumeration.  This could be ensured by,
-- for example, enumerating the shorter sentences before the longer
-- ones. Using natural numbers as an easy example, if we enumerate the
-- even numbers before any odd numbers, the first odd number will not
-- appear at any finite position in the enumerated list!

-- | The generation algorithm first makes a tree of all the
-- grammatical ways of adding a next letter to what we had before,
-- then enumerates the nodes of this tree in a breadth-first fashion.
-- The unfinished sentences are filtered out of this list of nodes,
-- and then the remaining sentences are made pretty.
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] -- make a tree of
                                             -- all the grammatical
                                             -- ways of adding a next
                                             -- letter to what we had
                                             -- before
                                             --
  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                             -- enumerate the nodes of
                                             -- this tree
                                             --
  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                        -- keep only those
                                             -- sentences which are
                                             -- finished
                                             --  
  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                          -- make them pretty
                                             -- (reverse them, and
                                             -- remove the delimiter
                                             -- signs)
  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


{- The generation algorithm is based on a Tree data structure, which we
  define here.  A tree consists of a node, and its daughters, which
  are themselves trees. -}
data Tree a = Tree a [Tree a]

{- We can create a tree by specifying two things:
  1. how to create the daughter root nodes, given the current node
   value, and
  2. what the value of the root is -}
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

{- We can enumerate the nodes of a tree one level at a time (a so called
 'breadth-first' enumeration). -}
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)

-- ** Learning

-- | The TSL learner works by first identifying the elements on a
-- tier, and then by running the usual SL learner on the
-- tier-projection of the input text.  This implements the algorithm
-- described by [Jardine and
-- McMullin](https://adamjardine.net/files/jardinemcmullin2016tslk.pdf).
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)

{-
  To test whether a segment should be projected we see whether it can
  be added to all k-1 factors, and removed from all k+1 factors, each
  time giving us some already seen k factor.  If so, then the segment
  is *NOT* tier relevant.
-}
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]

{-
We can add a letter to a factor in a number of ways.
-}
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)

{-
Similarly, a letter can be removed from a factor whenever it occurs
-}
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 = -- The list of ways of removing something from bs,
                    -- and then putting b in front
        (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 -- the beginning of a string cannot be removed
removeLetter c :: a
c (End:_) =
  [] -- once you come to the end of a string, there are no more letters to remove