{-|
Module     : Language.Change
Copyright  : (c) Owen Bechtel, 2023
License    : MIT
Maintainer : ombspring@gmail.com
Stability  : experimental
-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
module Language.Change
  ( -- * Phoneme sets
    PSet(..), member
    -- * Environments
  , Pattern(..), Env(..)
  , testPatterns, testEnv
    -- * Sound changes
  , Change(..)
  , applyChange, applyChanges, traceChanges, replace
  ) where

import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Set (Set)
import Data.Map (Map)
import Data.List (find, foldl', scanl')

-- | A finite set, or the complement of a finite set.
data PSet a = PSet (Set a) Bool
  deriving (Int -> PSet a -> ShowS
forall a. Show a => Int -> PSet a -> ShowS
forall a. Show a => [PSet a] -> ShowS
forall a. Show a => PSet a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PSet a] -> ShowS
$cshowList :: forall a. Show a => [PSet a] -> ShowS
show :: PSet a -> String
$cshow :: forall a. Show a => PSet a -> String
showsPrec :: Int -> PSet a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PSet a -> ShowS
Show)

-- | Test for membership in a 'PSet'.
--
-- @
-- member x (PSet set b) = 'Set.member' x set == b
-- @
member :: Ord a => a -> PSet a -> Bool
member :: forall a. Ord a => a -> PSet a -> Bool
member a
x (PSet Set a
set Bool
b) = forall a. Ord a => a -> Set a -> Bool
Set.member a
x Set a
set forall a. Eq a => a -> a -> Bool
== Bool
b

-- | A single component of an 'Env'.
data Pattern a
  = One (PSet a)      -- ^ Matches one occurrence of a 'PSet' member.
  | Optional (PSet a) -- ^ Matches zero or one occurences of a 'PSet' member.
  | Many (PSet a)     -- ^ Matches zero or more occurences of a 'PSet' member.
  deriving (Int -> Pattern a -> ShowS
forall a. Show a => Int -> Pattern a -> ShowS
forall a. Show a => [Pattern a] -> ShowS
forall a. Show a => Pattern a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pattern a] -> ShowS
$cshowList :: forall a. Show a => [Pattern a] -> ShowS
show :: Pattern a -> String
$cshow :: forall a. Show a => Pattern a -> String
showsPrec :: Int -> Pattern a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Pattern a -> ShowS
Show)

-- | An environment in which a phoneme (or in general, a value of type @a@), might occur.
-- An 'Env' is specified by two lists of patterns: the environment before the phoneme (ordered from nearest to farthest), and the environment after.
data Env a = Env [Pattern a] [Pattern a] 
  deriving (Int -> Env a -> ShowS
forall a. Show a => Int -> Env a -> ShowS
forall a. Show a => [Env a] -> ShowS
forall a. Show a => Env a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Env a] -> ShowS
$cshowList :: forall a. Show a => [Env a] -> ShowS
show :: Env a -> String
$cshow :: forall a. Show a => Env a -> String
showsPrec :: Int -> Env a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Env a -> ShowS
Show)

-- | A sound change.
newtype Change a = Change (Map a [([a], Env a)])
  deriving (Int -> Change a -> ShowS
forall a. Show a => Int -> Change a -> ShowS
forall a. Show a => [Change a] -> ShowS
forall a. Show a => Change a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Change a] -> ShowS
$cshowList :: forall a. Show a => [Change a] -> ShowS
show :: Change a -> String
$cshow :: forall a. Show a => Change a -> String
showsPrec :: Int -> Change a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Change a -> ShowS
Show)

-- | Match a list of phonemes against a list of patterns.
testPatterns :: Ord a => [a] -> [Pattern a] -> Bool
testPatterns :: forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list = \case
  [] -> Bool
True

  One PSet a
set : [Pattern a]
ps ->
    case [a]
list of
      a
x:[a]
xs | forall a. Ord a => a -> PSet a -> Bool
member a
x PSet a
set -> forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
xs [Pattern a]
ps
      [a]
_ -> Bool
False

  Optional PSet a
set : [Pattern a]
ps ->
       forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list [Pattern a]
ps
    Bool -> Bool -> Bool
|| forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list (forall a. PSet a -> Pattern a
One PSet a
set forall a. a -> [a] -> [a]
: [Pattern a]
ps)

  Many PSet a
set : [Pattern a]
ps ->
      forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list [Pattern a]
ps
    Bool -> Bool -> Bool
|| forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
list (forall a. PSet a -> Pattern a
One PSet a
set forall a. a -> [a] -> [a]
: forall a. PSet a -> Pattern a
Many PSet a
set forall a. a -> [a] -> [a]
: [Pattern a]
ps)

-- | Match two lists of phonemes against an 'Env'.
testEnv :: Ord a => [a] -> [a] -> Env a -> Bool
testEnv :: forall a. Ord a => [a] -> [a] -> Env a -> Bool
testEnv [a]
left [a]
right (Env [Pattern a]
psL [Pattern a]
psR) =
  forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
left [Pattern a]
psL Bool -> Bool -> Bool
&& forall a. Ord a => [a] -> [Pattern a] -> Bool
testPatterns [a]
right [Pattern a]
psR

-- | A helper function used by 'applyChange'.
-- Similar to 'map', except the first argument returns a list and has access to each element's environment.
replace :: ([a] -> a -> [a] -> [b]) -> [a] -> [b]
replace :: forall a b. ([a] -> a -> [a] -> [b]) -> [a] -> [b]
replace [a] -> a -> [a] -> [b]
f = [a] -> [a] -> [b]
replace' []
  where
    replace' :: [a] -> [a] -> [b]
replace' [a]
_ [] = []
    replace' [a]
left (a
x:[a]
right) = [a] -> a -> [a] -> [b]
f [a]
left a
x [a]
right forall a. [a] -> [a] -> [a]
++ [a] -> [a] -> [b]
replace' (a
xforall a. a -> [a] -> [a]
:[a]
left) [a]
right

-- | Apply a sound change to a word.
applyChange :: Ord a => Change a -> [a] -> [a]
applyChange :: forall a. Ord a => Change a -> [a] -> [a]
applyChange (Change Map a [([a], Env a)]
mapping) =
  forall a b. ([a] -> a -> [a] -> [b]) -> [a] -> [b]
replace \[a]
left a
x [a]
right ->
    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a [([a], Env a)]
mapping of
      Maybe [([a], Env a)]
Nothing -> [a
x]
      Just [([a], Env a)]
cs ->
        case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Ord a => [a] -> [a] -> Env a -> Bool
testEnv [a]
left [a]
right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([a], Env a)]
cs of
          Maybe ([a], Env a)
Nothing -> [a
x]
          Just ([a]
x', Env a
_) -> [a]
x'

-- | Apply a sequence of sound changes to a word, returning the final result.
applyChanges :: Ord a => [Change a] -> [a] -> [a]
applyChanges :: forall a. Ord a => [Change a] -> [a] -> [a]
applyChanges [Change a]
cs [a]
x = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => Change a -> [a] -> [a]
applyChange) [a]
x [Change a]
cs

-- | Apply a sequence of sound changes to a word, returning a list of intermediate results.
-- (The first element of the list is the original word, and the last element is the result after applying all changes.)
traceChanges :: Ord a => [Change a] -> [a] -> [[a]]
traceChanges :: forall a. Ord a => [Change a] -> [a] -> [[a]]
traceChanges [Change a]
cs [a]
x = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => Change a -> [a] -> [a]
applyChange) [a]
x [Change a]
cs