{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

module Forks (Refusal (..), Side (..), forked, joined) where

import AST (Argument (..), Attribute (AtDelta, AtLabel, AtLambda, AtRho), Binding (..), Bytes, Expression (ExApplication, ExDispatch, ExFormation, ExPhiAgain, ExPhiMeet, ExTermination, ExXi), Function (FnSymbol), attributeFromBinding, symbols)
import Control.Monad.Trans.State.Strict (State, runState, state)
import Data.Bifunctor (bimap, first)
import Data.List (nub)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T

type Joining = (Int, Maybe Int, Map (Int, Int) Int, [(Int, (Int, Int))])

data Side = Lefthand | Righthand
  deriving (Side -> Side -> Bool
(Side -> Side -> Bool) -> (Side -> Side -> Bool) -> Eq Side
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Side -> Side -> Bool
== :: Side -> Side -> Bool
$c/= :: Side -> Side -> Bool
/= :: Side -> Side -> Bool
Eq, Int -> Side -> ShowS
[Side] -> ShowS
Side -> String
(Int -> Side -> ShowS)
-> (Side -> String) -> ([Side] -> ShowS) -> Show Side
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Side -> ShowS
showsPrec :: Int -> Side -> ShowS
$cshow :: Side -> String
show :: Side -> String
$cshowList :: [Side] -> ShowS
showList :: [Side] -> ShowS
Show)

data Refusal
  = Unnamed
  | Unformed Side
  | Holding Side Attribute
  | Unripe Side Attribute
  deriving (Refusal -> Refusal -> Bool
(Refusal -> Refusal -> Bool)
-> (Refusal -> Refusal -> Bool) -> Eq Refusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Refusal -> Refusal -> Bool
== :: Refusal -> Refusal -> Bool
$c/= :: Refusal -> Refusal -> Bool
/= :: Refusal -> Refusal -> Bool
Eq, Int -> Refusal -> ShowS
[Refusal] -> ShowS
Refusal -> String
(Int -> Refusal -> ShowS)
-> (Refusal -> String) -> ([Refusal] -> ShowS) -> Show Refusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Refusal -> ShowS
showsPrec :: Int -> Refusal -> ShowS
$cshow :: Refusal -> String
show :: Refusal -> String
$cshowList :: [Refusal] -> ShowS
showList :: [Refusal] -> ShowS
Show)

joined :: Expression -> Expression -> Int -> Either [Attribute] (Expression, [(Int, (Int, Int))], Maybe Int, Int)
joined :: Expression
-> Expression
-> Int
-> Either
     [Attribute] (Expression, [(Int, (Int, Int))], Maybe Int, Int)
joined Expression
left Expression
right Int
spent = (\(Expression
term, (Int
spent', Maybe Int
bottom, Map (Int, Int) Int
_, [(Int, (Int, Int))]
made)) -> (Expression
term, [(Int, (Int, Int))] -> [(Int, (Int, Int))]
forall a. [a] -> [a]
reverse [(Int, (Int, Int))]
made, Maybe Int
bottom, Int
spent')) ((Expression, Joining)
 -> (Expression, [(Int, (Int, Int))], Maybe Int, Int))
-> Either [Attribute] (Expression, Joining)
-> Either
     [Attribute] (Expression, [(Int, (Int, Int))], Maybe Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
left Expression
right (Int
spent, Maybe Int
forall a. Maybe a
Nothing, Map (Int, Int) Int
forall k a. Map k a
Map.empty, [])
  where
    goExpr :: Expression -> Expression -> Joining -> Either [Attribute] (Expression, Joining)
    goExpr :: Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr (ExFormation [Binding]
one) (ExFormation [Binding]
two) Joining
joining = ([Binding] -> Expression)
-> ([Binding], Joining) -> (Expression, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Binding] -> Expression
ExFormation (([Binding], Joining) -> (Expression, Joining))
-> Either [Attribute] ([Binding], Joining)
-> Either [Attribute] (Expression, Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
-> [Binding] -> Joining -> Either [Attribute] ([Binding], Joining)
goBindings [Binding]
one [Binding]
two Joining
joining
    goExpr (ExApplication Expression
one Argument
arg) (ExApplication Expression
two Argument
arg') Joining
joining = Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
within (Either [Attribute] (Expression, Joining)
 -> Either [Attribute] (Expression, Joining))
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
forall a b. (a -> b) -> a -> b
$ do
      (Expression
target, Joining
joining') <- Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
one Expression
two Joining
joining
      (Argument -> Expression)
-> (Argument, Joining) -> (Expression, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Expression -> Argument -> Expression
ExApplication Expression
target) ((Argument, Joining) -> (Expression, Joining))
-> Either [Attribute] (Argument, Joining)
-> Either [Attribute] (Expression, Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Argument
-> Argument -> Joining -> Either [Attribute] (Argument, Joining)
goArgument Argument
arg Argument
arg' Joining
joining'
    goExpr (ExDispatch Expression
one Attribute
attr) (ExDispatch Expression
two Attribute
attr') Joining
joining
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' = Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
within ((Expression -> Expression)
-> (Expression, Joining) -> (Expression, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Expression -> Attribute -> Expression
`ExDispatch` Attribute
attr) ((Expression, Joining) -> (Expression, Joining))
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
one Expression
two Joining
joining)
    goExpr (ExPhiMeet Maybe String
prefix Int
idx Expression
one) (ExPhiMeet Maybe String
prefix' Int
idx' Expression
two) Joining
joining
      | Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx' = Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
within ((Expression -> Expression)
-> (Expression, Joining) -> (Expression, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx) ((Expression, Joining) -> (Expression, Joining))
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
one Expression
two Joining
joining)
    goExpr (ExPhiAgain Maybe String
prefix Int
idx Expression
one) (ExPhiAgain Maybe String
prefix' Int
idx' Expression
two) Joining
joining
      | Maybe String
prefix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
prefix' Bool -> Bool -> Bool
&& Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
idx' = Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
within ((Expression -> Expression)
-> (Expression, Joining) -> (Expression, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx) ((Expression, Joining) -> (Expression, Joining))
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
one Expression
two Joining
joining)
    goExpr Expression
ExTermination Expression
ExTermination Joining
joining = (Expression, Joining) -> Either [Attribute] (Expression, Joining)
forall a b. b -> Either a b
Right (Expression
ExTermination, Joining
joining)
    goExpr Expression
ExTermination Expression
two Joining
joining = (Int -> Int -> (Int, Int))
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
faced (,) Expression
two Joining
joining
    goExpr Expression
one Expression
ExTermination Joining
joining = (Int -> Int -> (Int, Int))
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
faced ((Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) Expression
one Joining
joining
    goExpr Expression
one Expression
two Joining
joining = Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
forall item.
Eq item =>
item -> item -> Joining -> Either [Attribute] (item, Joining)
same Expression
one Expression
two Joining
joining
    goBinding :: Binding -> Binding -> Joining -> Either [Attribute] (Binding, Joining)
    goBinding :: Binding
-> Binding -> Joining -> Either [Attribute] (Binding, Joining)
goBinding (BiTau Attribute
attr Expression
one) (BiTau Attribute
attr' Expression
two) Joining
joining
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' = ([Attribute] -> [Attribute])
-> ((Expression, Joining) -> (Binding, Joining))
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Binding, Joining)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Attribute
attr Attribute -> [Attribute] -> [Attribute]
forall a. a -> [a] -> [a]
:) ((Expression -> Binding)
-> (Expression, Joining) -> (Binding, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Attribute -> Expression -> Binding
BiTau Attribute
attr)) (Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
one Expression
two Joining
joining)
    goBinding (BiLambda (FnSymbol Int
one)) (BiLambda (FnSymbol Int
two)) Joining
joining
      | Int
one Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
two = (Binding, Joining) -> Either [Attribute] (Binding, Joining)
forall a b. b -> Either a b
Right ((Int -> Binding) -> (Int, Joining) -> (Binding, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Function -> Binding
BiLambda (Function -> Binding) -> (Int -> Function) -> Int -> Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Function
FnSymbol) ((Int, Int) -> Joining -> (Int, Joining)
picked (Int
one, Int
two) Joining
joining))
    goBinding Binding
one Binding
two Joining
joining = ([Attribute] -> [Attribute])
-> Either [Attribute] (Binding, Joining)
-> Either [Attribute] (Binding, Joining)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Attribute] -> [Attribute] -> [Attribute]
forall a b. a -> b -> a
const ([Attribute]
-> (Attribute -> [Attribute]) -> Maybe Attribute -> [Attribute]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Attribute -> [Attribute]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding -> Maybe Attribute
attributeFromBinding Binding
one))) (Binding
-> Binding -> Joining -> Either [Attribute] (Binding, Joining)
forall item.
Eq item =>
item -> item -> Joining -> Either [Attribute] (item, Joining)
same Binding
one Binding
two Joining
joining)
    goArgument :: Argument -> Argument -> Joining -> Either [Attribute] (Argument, Joining)
    goArgument :: Argument
-> Argument -> Joining -> Either [Attribute] (Argument, Joining)
goArgument (ArTau Attribute
attr Expression
one) (ArTau Attribute
attr' Expression
two) Joining
joining
      | Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr' = (Expression -> Argument)
-> (Expression, Joining) -> (Argument, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Attribute -> Expression -> Argument
ArTau Attribute
attr) ((Expression, Joining) -> (Argument, Joining))
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Argument, Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
one Expression
two Joining
joining
    goArgument (ArAlpha Alpha
alpha Expression
one) (ArAlpha Alpha
alpha' Expression
two) Joining
joining
      | Alpha
alpha Alpha -> Alpha -> Bool
forall a. Eq a => a -> a -> Bool
== Alpha
alpha' = (Expression -> Argument)
-> (Expression, Joining) -> (Argument, Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Alpha -> Expression -> Argument
ArAlpha Alpha
alpha) ((Expression, Joining) -> (Argument, Joining))
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Argument, Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
goExpr Expression
one Expression
two Joining
joining
    goArgument Argument
one Argument
two Joining
joining = Argument
-> Argument -> Joining -> Either [Attribute] (Argument, Joining)
forall item.
Eq item =>
item -> item -> Joining -> Either [Attribute] (item, Joining)
same Argument
one Argument
two Joining
joining
    goBindings :: [Binding] -> [Binding] -> Joining -> Either [Attribute] ([Binding], Joining)
    goBindings :: [Binding]
-> [Binding] -> Joining -> Either [Attribute] ([Binding], Joining)
goBindings [] [] Joining
joining = ([Binding], Joining) -> Either [Attribute] ([Binding], Joining)
forall a b. b -> Either a b
Right ([], Joining
joining)
    goBindings (Binding
one : [Binding]
ones) (Binding
two : [Binding]
twos) Joining
joining
      | Binding -> Maybe Attribute
attributeFromBinding Binding
one Maybe Attribute -> Maybe Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Binding -> Maybe Attribute
attributeFromBinding Binding
two = do
          (Binding
item, Joining
joining') <- Binding
-> Binding -> Joining -> Either [Attribute] (Binding, Joining)
goBinding Binding
one Binding
two Joining
joining
          ([Binding] -> [Binding])
-> ([Binding], Joining) -> ([Binding], Joining)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Binding
item Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
:) (([Binding], Joining) -> ([Binding], Joining))
-> Either [Attribute] ([Binding], Joining)
-> Either [Attribute] ([Binding], Joining)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
-> [Binding] -> Joining -> Either [Attribute] ([Binding], Joining)
goBindings [Binding]
ones [Binding]
twos Joining
joining'
    goBindings [Binding]
ones [Binding]
twos Joining
_ = [Attribute] -> Either [Attribute] ([Binding], Joining)
forall a b. a -> Either a b
Left (Int -> [Attribute] -> [Attribute]
forall a. Int -> [a] -> [a]
take Int
1 ([Binding] -> [Binding] -> [Attribute]
absent [Binding]
ones [Binding]
twos [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Binding] -> [Attribute]
absent [Binding]
twos [Binding]
ones [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ (Binding -> Maybe Attribute) -> [Binding] -> [Attribute]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Binding -> Maybe Attribute
attributeFromBinding [Binding]
ones))
    absent :: [Binding] -> [Binding] -> [Attribute]
    absent :: [Binding] -> [Binding] -> [Attribute]
absent [Binding]
bds [Binding]
others = [Attribute
attr | Just Attribute
attr <- (Binding -> Maybe Attribute) -> [Binding] -> [Maybe Attribute]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Maybe Attribute
attributeFromBinding (Int -> [Binding] -> [Binding]
forall a. Int -> [a] -> [a]
take Int
1 [Binding]
bds), Attribute
attr Attribute -> [Attribute] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Binding -> Maybe Attribute) -> [Binding] -> [Attribute]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Binding -> Maybe Attribute
attributeFromBinding [Binding]
others]
    within :: Either [Attribute] (Expression, Joining) -> Either [Attribute] (Expression, Joining)
    within :: Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
within = ([Attribute] -> [Attribute])
-> Either [Attribute] (Expression, Joining)
-> Either [Attribute] (Expression, Joining)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Attribute] -> [Attribute] -> [Attribute]
forall a b. a -> b -> a
const [])
    same :: (Eq item) => item -> item -> Joining -> Either [Attribute] (item, Joining)
    same :: forall item.
Eq item =>
item -> item -> Joining -> Either [Attribute] (item, Joining)
same item
one item
two Joining
joining
      | item
one item -> item -> Bool
forall a. Eq a => a -> a -> Bool
== item
two = (item, Joining) -> Either [Attribute] (item, Joining)
forall a b. b -> Either a b
Right (item
one, Joining
joining)
      | Bool
otherwise = [Attribute] -> Either [Attribute] (item, Joining)
forall a b. a -> Either a b
Left []
    faced :: (Int -> Int -> (Int, Int)) -> Expression -> Joining -> Either [Attribute] (Expression, Joining)
    faced :: (Int -> Int -> (Int, Int))
-> Expression
-> Joining
-> Either [Attribute] (Expression, Joining)
faced Int -> Int -> (Int, Int)
pair Expression
side joining :: Joining
joining@(Int
spent', Maybe Int
bottom, Map (Int, Int) Int
names, [(Int, (Int, Int))]
made)
      | [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Expression -> [Int]
symbols Expression
side) = [Attribute] -> Either [Attribute] (Expression, Joining)
forall a b. a -> Either a b
Left []
      | Bool
otherwise = (Expression, Joining) -> Either [Attribute] (Expression, Joining)
forall a b. b -> Either a b
Right (State Joining Expression -> Joining -> (Expression, Joining)
forall s a. State s a -> s -> (a, s)
runState (Expression -> State Joining Expression
goFaced Expression
side) Joining
joining')
      where
        (Int
termination, Joining
joining') = (Int, Joining)
-> (Int -> (Int, Joining)) -> Maybe Int -> (Int, Joining)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int -> Int
forall a. Enum a => a -> a
succ Int
spent', (Int -> Int
forall a. Enum a => a -> a
succ Int
spent', Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int
forall a. Enum a => a -> a
succ Int
spent'), Map (Int, Int) Int
names, [(Int, (Int, Int))]
made)) (,Joining
joining) Maybe Int
bottom
        goFaced :: Expression -> State Joining Expression
        goFaced :: Expression -> State Joining Expression
goFaced (ExFormation [Binding]
bds) = [Binding] -> Expression
ExFormation ([Binding] -> Expression)
-> StateT Joining Identity [Binding] -> State Joining Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding -> StateT Joining Identity Binding)
-> [Binding] -> StateT Joining Identity [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> StateT Joining Identity Binding
goFacedBinding [Binding]
bds
        goFaced (ExApplication Expression
expr Argument
arg) = Expression -> Argument -> Expression
ExApplication (Expression -> Argument -> Expression)
-> State Joining Expression
-> StateT Joining Identity (Argument -> Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Joining Expression
goFaced Expression
expr StateT Joining Identity (Argument -> Expression)
-> StateT Joining Identity Argument -> State Joining Expression
forall a b.
StateT Joining Identity (a -> b)
-> StateT Joining Identity a -> StateT Joining Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Argument -> StateT Joining Identity Argument
goFacedArgument Argument
arg
        goFaced (ExDispatch Expression
expr Attribute
attr) = (Expression -> Attribute -> Expression
`ExDispatch` Attribute
attr) (Expression -> Expression)
-> State Joining Expression -> State Joining Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Joining Expression
goFaced Expression
expr
        goFaced (ExPhiMeet Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiMeet Maybe String
prefix Int
idx (Expression -> Expression)
-> State Joining Expression -> State Joining Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Joining Expression
goFaced Expression
expr
        goFaced (ExPhiAgain Maybe String
prefix Int
idx Expression
expr) = Maybe String -> Int -> Expression -> Expression
ExPhiAgain Maybe String
prefix Int
idx (Expression -> Expression)
-> State Joining Expression -> State Joining Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Joining Expression
goFaced Expression
expr
        goFaced Expression
expr = Expression -> State Joining Expression
forall a. a -> StateT Joining Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
expr
        goFacedBinding :: Binding -> State Joining Binding
        goFacedBinding :: Binding -> StateT Joining Identity Binding
goFacedBinding (BiTau Attribute
attr Expression
expr) = Attribute -> Expression -> Binding
BiTau Attribute
attr (Expression -> Binding)
-> State Joining Expression -> StateT Joining Identity Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Joining Expression
goFaced Expression
expr
        goFacedBinding (BiLambda (FnSymbol Int
idx)) = Function -> Binding
BiLambda (Function -> Binding) -> (Int -> Function) -> Int -> Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Function
FnSymbol (Int -> Binding)
-> StateT Joining Identity Int -> StateT Joining Identity Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Joining -> (Int, Joining)) -> StateT Joining Identity Int
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state ((Int, Int) -> Joining -> (Int, Joining)
picked (Int -> Int -> (Int, Int)
pair Int
termination Int
idx))
        goFacedBinding Binding
bd = Binding -> StateT Joining Identity Binding
forall a. a -> StateT Joining Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding
bd
        goFacedArgument :: Argument -> State Joining Argument
        goFacedArgument :: Argument -> StateT Joining Identity Argument
goFacedArgument (ArTau Attribute
attr Expression
expr) = Attribute -> Expression -> Argument
ArTau Attribute
attr (Expression -> Argument)
-> State Joining Expression -> StateT Joining Identity Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Joining Expression
goFaced Expression
expr
        goFacedArgument (ArAlpha Alpha
alpha Expression
expr) = Alpha -> Expression -> Argument
ArAlpha Alpha
alpha (Expression -> Argument)
-> State Joining Expression -> StateT Joining Identity Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> State Joining Expression
goFaced Expression
expr
    picked :: (Int, Int) -> Joining -> (Int, Joining)
    picked :: (Int, Int) -> Joining -> (Int, Joining)
picked (Int, Int)
pair joining :: Joining
joining@(Int
spent', Maybe Int
bottom, Map (Int, Int) Int
names, [(Int, (Int, Int))]
made) = case (Int, Int) -> Map (Int, Int) Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int, Int)
pair Map (Int, Int) Int
names of
      Just Int
name -> (Int
name, Joining
joining)
      Maybe Int
Nothing -> (Int -> Int
forall a. Enum a => a -> a
succ Int
spent', (Int -> Int
forall a. Enum a => a -> a
succ Int
spent', Maybe Int
bottom, (Int, Int) -> Int -> Map (Int, Int) Int -> Map (Int, Int) Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Int, Int)
pair (Int -> Int
forall a. Enum a => a -> a
succ Int
spent') Map (Int, Int) Int
names, (Int -> Int
forall a. Enum a => a -> a
succ Int
spent', (Int, Int)
pair) (Int, (Int, Int)) -> [(Int, (Int, Int))] -> [(Int, (Int, Int))]
forall a. a -> [a] -> [a]
: [(Int, (Int, Int))]
made))

forked :: Function -> Either Int Bytes -> Expression -> Expression -> Either Refusal Expression
forked :: Function
-> Either Int Bytes
-> Expression
-> Expression
-> Either Refusal Expression
forked Function
func Either Int Bytes
condition Expression
left Expression
right = do
  [Binding]
one <- Side -> Expression -> Either Refusal [Binding]
formed Side
Lefthand Expression
left
  [Binding]
two <- Side -> Expression -> Either Refusal [Binding]
formed Side
Righthand Expression
right
  Either Refusal Expression
-> (Refusal -> Either Refusal Expression)
-> Maybe Refusal
-> Either Refusal Expression
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Expression -> Either Refusal Expression
forall a b. b -> Either a b
Right ([Binding] -> [Binding] -> Expression
fabricated [Binding]
one [Binding]
two)) Refusal -> Either Refusal Expression
forall a b. a -> Either a b
Left ([Refusal] -> Maybe Refusal
forall a. [a] -> Maybe a
listToMaybe (Side -> [Binding] -> [Binding] -> [Refusal]
unripe Side
Lefthand [Binding]
one [Binding]
two [Refusal] -> [Refusal] -> [Refusal]
forall a. [a] -> [a] -> [a]
++ Side -> [Binding] -> [Binding] -> [Refusal]
unripe Side
Righthand [Binding]
two [Binding]
one))
  where
    formed :: Side -> Expression -> Either Refusal [Binding]
    formed :: Side -> Expression -> Either Refusal [Binding]
formed Side
side (ExFormation [Binding]
bds) = Either Refusal [Binding]
-> (Attribute -> Either Refusal [Binding])
-> Maybe Attribute
-> Either Refusal [Binding]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Binding] -> Either Refusal [Binding]
forall a b. b -> Either a b
Right [Binding]
bds) (Refusal -> Either Refusal [Binding]
forall a b. a -> Either a b
Left (Refusal -> Either Refusal [Binding])
-> (Attribute -> Refusal) -> Attribute -> Either Refusal [Binding]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Side -> Attribute -> Refusal
Holding Side
side) ([Attribute] -> Maybe Attribute
forall a. [a] -> Maybe a
listToMaybe [Attribute
attr | Just Attribute
attr <- (Binding -> Maybe Attribute) -> [Binding] -> [Maybe Attribute]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Maybe Attribute
attributeFromBinding [Binding]
bds, Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
AtDelta Bool -> Bool -> Bool
|| Attribute
attr Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
AtLambda])
    formed Side
side Expression
_ = Refusal -> Either Refusal [Binding]
forall a b. a -> Either a b
Left (Side -> Refusal
Unformed Side
side)
    fabricated :: [Binding] -> [Binding] -> Expression
    fabricated :: [Binding] -> [Binding] -> Expression
fabricated [Binding]
one [Binding]
two = [Binding] -> Expression
ExFormation ((Attribute -> Binding) -> [Attribute] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Binding
BiVoid [Attribute]
voids [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Text -> Expression -> [Binding] -> Binding
copy Text
"left🌵" Expression
left [Binding]
one, Text -> Expression -> [Binding] -> Binding
copy Text
"right🌵" Expression
right [Binding]
two] [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ (Attribute -> Binding) -> [Attribute] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Binding
branch ((Attribute -> Bool) -> [Attribute] -> [Attribute]
forall a. (a -> Bool) -> [a] -> [a]
filter (Attribute -> [Attribute] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Attribute]
voids) ([Attribute] -> [Attribute]
forall a. Eq a => [a] -> [a]
nub ([Binding] -> [Attribute]
attributes [Binding]
one [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Attribute]
attributes [Binding]
two))))
      where
        voids :: [Attribute]
        voids :: [Attribute]
voids = [Attribute] -> [Attribute]
forall a. Eq a => [a] -> [a]
nub ([Binding] -> [Attribute]
vacant [Binding]
one [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Attribute]
vacant [Binding]
two)
        branch :: Attribute -> Binding
        branch :: Attribute -> Binding
branch Attribute
attr = Binding -> (Expression -> Binding) -> Maybe Expression -> Binding
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Attribute -> Binding
forking Attribute
attr) (Attribute -> Expression -> Binding
BiTau Attribute
attr) (Attribute -> Maybe Expression
aliased Attribute
attr)
        aliased :: Attribute -> Maybe Expression
        aliased :: Attribute -> Maybe Expression
aliased Attribute
attr = case ([Binding] -> Attribute -> Maybe Expression
bound [Binding]
one Attribute
attr, [Binding] -> Attribute -> Maybe Expression
bound [Binding]
two Attribute
attr) of
          (Just term :: Expression
term@(ExDispatch Expression
ExXi Attribute
name), Just Expression
other) | Expression
term Expression -> Expression -> Bool
forall a. Eq a => a -> a -> Bool
== Expression
other Bool -> Bool -> Bool
&& Attribute
name Attribute -> [Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Binding] -> [Attribute]
attributes [Binding]
one [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++ [Binding] -> [Attribute]
attributes [Binding]
two -> Expression -> Maybe Expression
forall a. a -> Maybe a
Just Expression
term
          (Maybe Expression, Maybe Expression)
_ -> Maybe Expression
forall a. Maybe a
Nothing
        bound :: [Binding] -> Attribute -> Maybe Expression
        bound :: [Binding] -> Attribute -> Maybe Expression
bound [Binding]
bds Attribute
attr = [Expression] -> Maybe Expression
forall a. [a] -> Maybe a
listToMaybe [Expression
term | BiTau Attribute
label Expression
term <- [Binding]
bds, Attribute
label Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr]
        forking :: Attribute -> Binding
        forking :: Attribute -> Binding
forking Attribute
attr = Attribute -> Expression -> Binding
BiTau Attribute
attr ([Binding] -> Expression
ExFormation ([Attribute -> Binding
BiVoid Attribute
AtRho, Function -> Binding
BiLambda Function
func] [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ (Attribute -> Binding) -> [Attribute] -> [Binding]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Binding
BiVoid (Attribute -> [Attribute]
inner Attribute
attr) [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Attribute -> Expression -> Binding
BiTau (Text -> Attribute
AtLabel Text
"on🌵") ([Binding] -> Expression
ExFormation [(Int -> Binding)
-> (Bytes -> Binding) -> Either Int Bytes -> Binding
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Function -> Binding
BiLambda (Function -> Binding) -> (Int -> Function) -> Int -> Binding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Function
FnSymbol) Bytes -> Binding
BiDelta Either Int Bytes
condition]), Text -> [Binding] -> Attribute -> Binding
ask Text
"left🌵" [Binding]
one Attribute
attr, Text -> [Binding] -> Attribute -> Binding
ask Text
"right🌵" [Binding]
two Attribute
attr]))
        inner :: Attribute -> [Attribute]
        inner :: Attribute -> [Attribute]
inner Attribute
attr = [Attribute] -> [Attribute]
forall a. Eq a => [a] -> [a]
nub ([[Attribute]] -> [Attribute]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Binding] -> Maybe [Attribute]) -> [[Binding]] -> [[Attribute]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Binding] -> Attribute -> Maybe [Attribute]
`held` Attribute
attr) [[Binding]
one, [Binding]
two]))
        ask :: Text -> [Binding] -> Attribute -> Binding
        ask :: Text -> [Binding] -> Attribute -> Binding
ask Text
name [Binding]
bds Attribute
attr = Attribute -> Expression -> Binding
BiTau (Text -> Attribute
AtLabel Text
name) (Expression -> [Attribute] -> Expression
applied (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch (Expression -> Attribute -> Expression
ExDispatch Expression
ExXi Attribute
AtRho) (Text -> Attribute
AtLabel Text
name)) Attribute
attr) ([Attribute] -> Maybe [Attribute] -> [Attribute]
forall a. a -> Maybe a -> a
fromMaybe (Attribute -> [Attribute]
inner Attribute
attr) ([Binding] -> Attribute -> Maybe [Attribute]
held [Binding]
bds Attribute
attr)))
    unripe :: Side -> [Binding] -> [Binding] -> [Refusal]
    unripe :: Side -> [Binding] -> [Binding] -> [Refusal]
unripe Side
side [Binding]
bds [Binding]
others = [Side -> Attribute -> Refusal
Unripe Side
side Attribute
attr | Attribute
attr <- [Binding] -> [Attribute]
vacant [Binding]
bds, Attribute
attr Attribute -> [Attribute] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Attribute
label | BiTau Attribute
label Expression
_ <- [Binding]
others]]
    vacant :: [Binding] -> [Attribute]
    vacant :: [Binding] -> [Attribute]
vacant [Binding]
bds = [Attribute
attr | BiVoid Attribute
attr <- [Binding]
bds, Attribute -> Bool
own Attribute
attr]
    attributes :: [Binding] -> [Attribute]
    attributes :: [Binding] -> [Attribute]
attributes [Binding]
bds = [Attribute
attr | Just Attribute
attr <- (Binding -> Maybe Attribute) -> [Binding] -> [Maybe Attribute]
forall a b. (a -> b) -> [a] -> [b]
map Binding -> Maybe Attribute
attributeFromBinding [Binding]
bds, Attribute -> Bool
own Attribute
attr]
    own :: Attribute -> Bool
    own :: Attribute -> Bool
own (AtLabel Text
label) = Bool -> Bool
not (Text
"🌵" Text -> Text -> Bool
`T.isSuffixOf` Text
label)
    own Attribute
attr = Attribute
attr Attribute -> [Attribute] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Attribute
AtRho, Attribute
AtLambda, Attribute
AtDelta]
    copy :: Text -> Expression -> [Binding] -> Binding
    copy :: Text -> Expression -> [Binding] -> Binding
copy Text
name Expression
side [Binding]
bds = Attribute -> Expression -> Binding
BiTau (Text -> Attribute
AtLabel Text
name) (Expression -> [Attribute] -> Expression
applied Expression
side ([Binding] -> [Attribute]
vacant [Binding]
bds))
    applied :: Expression -> [Attribute] -> Expression
    applied :: Expression -> [Attribute] -> Expression
applied = (Expression -> Attribute -> Expression)
-> Expression -> [Attribute] -> Expression
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Expression
term Attribute
attr -> Expression -> Argument -> Expression
ExApplication Expression
term (Attribute -> Expression -> Argument
ArTau Attribute
attr (Expression -> Attribute -> Expression
ExDispatch Expression
ExXi Attribute
attr)))
    held :: [Binding] -> Attribute -> Maybe [Attribute]
    held :: [Binding] -> Attribute -> Maybe [Attribute]
held [Binding]
bds Attribute
attr = [[Attribute]] -> Maybe [Attribute]
forall a. [a] -> Maybe a
listToMaybe [[Binding] -> [Attribute]
vacant [Binding]
inside | BiTau Attribute
label (ExFormation [Binding]
inside) <- [Binding]
bds, Attribute
label Attribute -> Attribute -> Bool
forall a. Eq a => a -> a -> Bool
== Attribute
attr]