------------------------------------------------------------------------
-- A small library of derived parser combinators
------------------------------------------------------------------------

module TotalParserCombinators.Lib where

open import Category.Monad
open import Codata.Musical.Notation
open import Function.Base
open import Function.Equality using (_⟶_; _⟨$⟩_)
open import Function.Injection using (Injection; Injective)
open import Function.Inverse using (_↔_; module Inverse)
open import Data.Bool hiding (_≤?_)
open import Data.Char as Char using (Char; _==_)
open import Data.List as List
import Data.List.Categorical
open import Data.List.Membership.Propositional
import Data.List.Membership.Propositional.Properties as ∈
open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_)
open import Data.List.Relation.Unary.Any
open import Data.Maybe hiding (_>>=_)
open import Data.Nat hiding (_^_)
open import Data.Product as Prod
open import Data.Unit using (⊤)
open import Data.Vec as Vec using (Vec; []; _∷_)
import Level
open import Relation.Binary
open import Relation.Binary.HeterogeneousEquality as H using (_≅_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
import Relation.Binary.PropositionalEquality.WithK as P
open import Relation.Nullary
open import Relation.Nullary.Decidable

private
  open module ListMonad =
         RawMonad {f = Level.zero} Data.List.Categorical.monad
         using ()
         renaming (_<$>_ to _<$>′_; _⊛_ to _⊛′_; _>>=_ to _>>=′_)

import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics as S
  hiding (_≅_; return; token)

------------------------------------------------------------------------
-- Kleene star

-- The intended semantics of the Kleene star.

infixr 5 _∷_
infix  4 _∈[_]⋆·_

data _∈[_]⋆·_ {Tok R xs} :
              List R → Parser Tok R xs → List Tok → Set₁ where
  []  : ∀ {p} → [] ∈[ p ]⋆· []
  _∷_ : ∀ {x xs s₁ s₂ p} →
        (x∈p : x ∈ p · s₁) (xs∈p⋆ : xs ∈[ p ]⋆· s₂) →
        x ∷ xs ∈[ p ]⋆· s₁ ++ s₂

-- An implementation which requires that the argument parser is not
-- nullable.

infix 55 _⋆ _+

mutual

  _⋆ : ∀ {Tok R} →
       Parser Tok R        [] →
       Parser Tok (List R) [ [] ]
  p ⋆ = return [] ∣ p +

  _+ : ∀ {Tok R} →
       Parser Tok R        [] →
       Parser Tok (List R) []
  p + = _∷_ <$> p ⊛ ♯ (p ⋆)

module KleeneStar where

  -- The implementation is correct.

  sound : ∀ {Tok R xs s} {p : Parser Tok R []} →
          xs ∈ p ⋆ · s → xs ∈[ p ]⋆· s
  sound (∣-left S.return)              = []
  sound (∣-right ._ (<$> x∈p ⊛ xs∈p⋆)) = x∈p ∷ sound xs∈p⋆

  complete : ∀ {Tok R xs s} {p : Parser Tok R []} →
             xs ∈[ p ]⋆· s → xs ∈ p ⋆ · s
  complete []                           = ∣-left S.return
  complete (_∷_ {s₁ = []}    x∈p xs∈p⋆) with I.complete x∈p
  ... | ()
  complete (_∷_ {s₁ = _ ∷ _} x∈p xs∈p⋆) =
    ∣-right [ [] ] ([ ○ - ◌ ] <$> x∈p ⊛ complete xs∈p⋆)

  complete∘sound :
    ∀ {Tok R xs s} {p : Parser Tok R []} (xs∈ : xs ∈ p ⋆ · s) →
    complete (sound xs∈) ≡ xs∈
  complete∘sound (∣-left S.return) = P.refl
  complete∘sound (∣-right ._ (_⊛_ {s₁ = _ ∷ _} (<$> x∈p) xs∈p⋆))
    rewrite complete∘sound xs∈p⋆ = P.refl
  complete∘sound (∣-right ._ (_⊛_ {s₁ = []}    (<$> x∈p) xs∈p⋆))
    with I.complete x∈p
  ... | ()

  sound∘complete : ∀ {Tok R xs s} {p : Parser Tok R []}
                   (xs∈ : xs ∈[ p ]⋆· s) →
                   sound (complete xs∈) ≡ xs∈
  sound∘complete []                           = P.refl
  sound∘complete (_∷_ {s₁ = []}    x∈p xs∈p⋆) with I.complete x∈p
  ... | ()
  sound∘complete (_∷_ {s₁ = _ ∷ _} x∈p xs∈p⋆) =
    P.cong (_∷_ x∈p) $ sound∘complete xs∈p⋆

  correct : ∀ {Tok R xs s} {p : Parser Tok R []} →
            xs ∈ p ⋆ · s ↔ xs ∈[ p ]⋆· s
  correct = record
    { to         = P.→-to-⟶ sound
    ; from       = P.→-to-⟶ complete
    ; inverse-of = record
      { left-inverse-of  = complete∘sound
      ; right-inverse-of = sound∘complete
      }
    }

  -- The definition of _⋆ is restricted to non-nullable parsers. This
  -- restriction cannot be removed: an unrestricted Kleene star
  -- operator would be incomplete because, in the present framework, a
  -- parser can only return a finite number of results.

  unrestricted-incomplete :
    ∀ {R Tok} →
    R →
    (f : ∀ {xs} → Parser Tok R xs → List (List R)) →
    (_⋆′ : ∀ {xs} (p : Parser Tok R xs) → Parser Tok (List R) (f p)) →
    ¬ (∀ {xs ys s} {p : Parser Tok R ys} →
         xs ∈[ p ]⋆· s → xs ∈ p ⋆′ · s)
  unrestricted-incomplete {R} x f _⋆′ complete =
    ∈.finite (record { to = to; injective = injective })
             (f (return x)) (I.complete ∘ complete ∘ lemma)
    where
    to : P.setoid ℕ ⟶ P.setoid (List R)
    to = P.→-to-⟶ (flip replicate x)

    helper : ∀ {xs ys} → _≡_ {A = List R} (x ∷ xs) (x ∷ ys) → xs ≡ ys
    helper P.refl = P.refl

    injective : Injective to
    injective {zero}  {zero}  _  = P.refl
    injective {suc m} {suc n} eq = P.cong suc $
                                     injective $ helper eq
    injective {zero}  {suc n} ()
    injective {suc m} {zero}  ()

    lemma : ∀ i → replicate i x ∈[ return x ]⋆· []
    lemma zero    = []
    lemma (suc i) = S.return ∷ lemma i

------------------------------------------------------------------------
-- A combinator for recognising a string a fixed number of times

infixl 55 _^_ _↑_

^-initial : ∀ {R} → List R → (n : ℕ) → List (Vec R n)
^-initial xs zero    = [ [] ]
^-initial xs (suc n) = List.map _∷_ xs ⊛′ ^-initial xs n

_^_ : ∀ {Tok R xs} →
      Parser Tok R xs → (n : ℕ) → Parser Tok (Vec R n) (^-initial xs n)
p ^ 0     = return []
p ^ suc n = _∷_ <$> p ⊛ p ^ n

mutual

  -- A variant.

  -- The two functions below are not actually mutually recursive, but
  -- are placed in a mutual block to ensure that the constraints
  -- generated by the second function can be used to instantiate the
  -- underscores in the body of the first.

  ↑-initial : ∀ {R} → List R → ℕ → List (List R)
  ↑-initial _ _ = _

  _↑_ : ∀ {Tok R xs} →
        Parser Tok R xs → (n : ℕ) → Parser Tok (List R) (↑-initial xs n)
  p ↑ n = Vec.toList <$> p ^ n

-- Some lemmas relating _↑_ to _⋆.

module Exactly where

  ↑≲⋆ : ∀ {Tok R} {p : Parser Tok R []} n → p ↑ n ≲ p ⋆
  ↑≲⋆ {R = R} {p} n (<$> ∈pⁿ) = KleeneStar.complete $ helper n ∈pⁿ
    where
    helper : ∀ n {xs s} → xs ∈ p ^ n · s → Vec.toList xs ∈[ p ]⋆· s
    helper zero    S.return       = []
    helper (suc n) (<$> ∈p ⊛ ∈pⁿ) = ∈p ∷ helper n ∈pⁿ

  ⋆≲∃↑ : ∀ {Tok R} {p : Parser Tok R []} {xs s} →
         xs ∈ p ⋆ · s → ∃ λ i → xs ∈ p ↑ i · s
  ⋆≲∃↑ {R = R} {p} ∈p⋆ with helper $ KleeneStar.sound ∈p⋆
    where
    helper : ∀ {xs s} → xs ∈[ p ]⋆· s →
             ∃₂ λ i (ys : Vec R i) →
                  xs ≡ Vec.toList ys × ys ∈ p ^ i · s
    helper []         = (0 , [] , P.refl , S.return)
    helper (∈p ∷ ∈p⋆) =
      Prod.map suc (λ {i} →
        Prod.map (_∷_ _) (
          Prod.map (P.cong (_∷_ _))
                   (λ ∈pⁱ → [ ○ - ○ ] <$> ∈p ⊛ ∈pⁱ)))
       (helper ∈p⋆)
  ... | (i , ys , P.refl , ∈pⁱ) = (i , <$> ∈pⁱ)

------------------------------------------------------------------------
-- A parser which returns any element in a given list

return⋆ : ∀ {Tok R} (xs : List R) → Parser Tok R xs
return⋆ []       = fail
return⋆ (x ∷ xs) = return x ∣ return⋆ xs

module Return⋆ where

  sound : ∀ {Tok R x} {s : List Tok}
          (xs : List R) → x ∈ return⋆ xs · s → s ≡ [] × x ∈ xs
  sound []       ()
  sound (y ∷ ys) (∣-left S.return)       = (P.refl , here P.refl)
  sound (y ∷ ys) (∣-right .([ y ]) x∈ys) =
    Prod.map id there $ sound ys x∈ys

  complete : ∀ {Tok R x} {xs : List R} →
             x ∈ xs → x ∈ return⋆ {Tok} xs · []
  complete (here P.refl) = ∣-left S.return
  complete (there x∈xs)  =
    ∣-right [ _ ] (complete x∈xs)

  complete∘sound : ∀ {Tok R x} {s : List Tok}
                   (xs : List R) (x∈xs : x ∈ return⋆ xs · s) →
                   complete {Tok = Tok} (proj₂ $ sound xs x∈xs) ≅ x∈xs
  complete∘sound []       ()
  complete∘sound (y ∷ ys) (∣-left S.return)       = H.refl
  complete∘sound (y ∷ ys) (∣-right .([ y ]) x∈ys)
    with sound ys x∈ys | complete∘sound ys x∈ys
  complete∘sound (y ∷ ys) (∣-right .([ y ]) .(complete p))
    | (P.refl , p) | H.refl = H.refl

  sound∘complete : ∀ {Tok R x} {xs : List R} (x∈xs : x ∈ xs) →
                   sound {Tok = Tok} {s = []} xs (complete x∈xs) ≡
                   (P.refl , x∈xs)
  sound∘complete       (here P.refl)          = P.refl
  sound∘complete {Tok} (there {xs = xs} x∈xs)
    with sound {Tok = Tok} xs (complete x∈xs)
       | sound∘complete {Tok} {xs = xs} x∈xs
  sound∘complete (there x∈xs) | .(P.refl , x∈xs) | P.refl = P.refl

  correct : ∀ {Tok R} {xs : List R} {x s} →
            (s ≡ [] × x ∈ xs) ↔ x ∈ return⋆ {Tok} xs · s
  correct {xs = xs} {x} = record
    { to         = P.→-to-⟶ complete′
    ; from       = P.→-to-⟶ $ sound xs
    ; inverse-of = record
      { left-inverse-of  = sound∘complete′
      ; right-inverse-of = complete′∘sound xs
      }
    }
    where
    complete′ : ∀ {Tok R x} {xs : List R} {s : List Tok} →
                s ≡ [] × x ∈ xs → x ∈ return⋆ xs · s
    complete′ (P.refl , x∈xs) = complete x∈xs

    sound∘complete′ : ∀ {Tok R x} {xs : List R} {s : List Tok}
                      (p : s ≡ [] × x ∈ xs) → sound xs (complete′ p) ≡ p
    sound∘complete′ (P.refl , x∈xs) = sound∘complete x∈xs

    complete′∘sound : ∀ {Tok R x} {s : List Tok}
                      (xs : List R) (x∈xs : x ∈ return⋆ xs · s) →
                      complete′ (sound xs x∈xs) ≡ x∈xs
    complete′∘sound xs x∈ with sound xs x∈ | complete∘sound xs x∈
    complete′∘sound xs .(complete x∈xs) | (P.refl , x∈xs) | H.refl =
      P.refl

------------------------------------------------------------------------
-- The sat parser

module Sat where

  -- Helper functions for sat.

  mutual

    ok-bag : {R : Set} → Maybe R → List R
    ok-bag nothing  = _
    ok-bag (just _) = _

    ok : {Tok R : Set} → (x : Maybe R) → Parser Tok R (ok-bag x)
    ok nothing  = fail
    ok (just x) = return x

  ok-correct : ∀ {Tok R x s} (m : Maybe R) →
               (s ≡ [] × m ≡ just x) ↔ x ∈ ok {Tok} m · s
  ok-correct {Tok} {x = x} m = record
    { to         = P.→-to-⟶ (to m)
    ; from       = P.→-to-⟶ (from m)
    ; inverse-of = record
      { left-inverse-of  = from∘to m
      ; right-inverse-of = to∘from m
      }
    }
    where
    to : ∀ {s} m → (s ≡ [] × m ≡ just x) → x ∈ ok {Tok} m · s
    to (just .x) (P.refl , P.refl) = S.return
    to nothing   (P.refl , ())

    from : ∀ {s} m → x ∈ ok {Tok} m · s → s ≡ [] × m ≡ just x
    from (just .x) S.return = (P.refl , P.refl)
    from nothing   ()

    from∘to : ∀ {s} m (eqs : s ≡ [] × m ≡ just x) →
              from m (to m eqs) ≡ eqs
    from∘to (just .x) (P.refl , P.refl) = P.refl
    from∘to nothing   (P.refl , ())

    to∘from : ∀ {s} m (x∈ : x ∈ ok {Tok} m · s) →
              to m (from m x∈) ≡ x∈
    to∘from (just .x) S.return = P.refl
    to∘from nothing   ()

  -- sat p accepts a single token t iff p t ≡ just x for some x. The
  -- returned value is x.

  sat : ∀ {Tok R} → (Tok → Maybe R) → Parser Tok R _
  sat p = token >>= (ok ∘ p)

  correct : ∀ {Tok R x s} (p : Tok → Maybe R) →
            (∃ λ t → s ≡ [ t ] × p t ≡ just x) ↔ x ∈ sat p · s
  correct {x = x} p = record
    { to         = P.→-to-⟶ to
    ; from       = P.→-to-⟶ from
    ; inverse-of = record
      { left-inverse-of  = from∘to
      ; right-inverse-of = to∘from
      }
    }
    where
    to : ∀ {s} → (∃ λ t → s ≡ [ t ] × p t ≡ just x) → x ∈ sat p · s
    to (t , P.refl , p-t≡just-x) =
      [ ○ - ○ ] S.token >>=
                (Inverse.to (ok-correct (p t)) ⟨$⟩ (P.refl , p-t≡just-x))

    from : ∀ {s} → x ∈ sat p · s → ∃ λ t → s ≡ [ t ] × p t ≡ just x
    from (S.token {x = t} >>= x∈ok-p-t) =
      (t , Prod.map (P.cong (_∷_ t)) id
             (Inverse.from (ok-correct (p t)) ⟨$⟩ x∈ok-p-t))

    from∘to : ∀ {s} (eqs : ∃ λ t → s ≡ [ t ] × p t ≡ just x) →
              from (to eqs) ≡ eqs
    from∘to (t , P.refl , p-t≡just-x) =
      P.cong₂ (λ eq₁ eq₂ → (t , eq₁ , eq₂))
              (P.≡-irrelevant _ _)
              (P.≡-irrelevant _ _)

    to∘from : ∀ {s} (x∈ : x ∈ sat p · s) → to (from x∈) ≡ x∈
    to∘from (S.token {x = t} >>= x∈ok-p-t)
      with Inverse.from (ok-correct (p t)) ⟨$⟩ x∈ok-p-t
         | Inverse.right-inverse-of (ok-correct (p t)) x∈ok-p-t
    to∘from (S.token {x = t} >>= .(Inverse.to (ok-correct (p t)) ⟨$⟩
                                     (P.refl , p-t≡just-x)))
      | (P.refl , p-t≡just-x) | P.refl = P.refl

open Sat public using (sat)

-- A simplified variant of sat. Does not return anything interesting.

sat′ : ∀ {Tok} → (Tok → Bool) → Parser Tok ⊤ _
sat′ p = sat (boolToMaybe ∘ p)

-- Accepts a single whitespace character (from a limited set of such
-- characters).

whitespace : Parser Char ⊤ _
whitespace = sat′ isSpace
  where
  isSpace = λ c →
    (c == ' ') ∨ (c == '\t') ∨ (c == '\n') ∨ (c == '\r')

------------------------------------------------------------------------
-- A parser for a given token

module Token
         (Tok : Set)
         (_≟_ : Decidable (_≡_ {A = Tok}))
         where

  private
    p : Tok → Tok → Maybe Tok
    p t t′ = if ⌊ t ≟ t′ ⌋ then just t′ else nothing

  tok : Tok → Parser Tok Tok []
  tok t = sat (p t)

  sound : ∀ t {t′ s} →
          t′ ∈ tok t · s → t ≡ t′ × s ≡ [ t′ ]
  sound t t′∈ with Inverse.from (Sat.correct (p t)) ⟨$⟩ t′∈
  sound t t′∈ | (t″ , P.refl , p-t-t″≡just-t′) with t ≟ t″
  sound t t∈  | (.t , P.refl , P.refl) | yes P.refl = (P.refl , P.refl)
  sound t t′∈ | (t″ , P.refl , ())     | no  _

  private
    p-lemma : ∀ t → p t t ≡ just t
    p-lemma t with t ≟ t
    ... | yes P.refl = P.refl
    ... | no  t≢t    with t≢t P.refl
    ...   | ()

  complete : ∀ {t} → t ∈ tok t · [ t ]
  complete {t} =
    Inverse.to (Sat.correct (p t)) ⟨$⟩ (t , P.refl , p-lemma t)

  η : ∀ {t} (t∈ : t ∈ tok t · [ t ]) → t∈ ≡ complete {t = t}
  η {t = t} t∈ = H.≅-to-≡ $ helper t∈ P.refl
    where
    helper₂ : (t∈ : t ∈ Sat.ok {Tok = Tok} (p t t) · []) →
              t∈ ≡ Inverse.to (Sat.ok-correct (p t t)) ⟨$⟩
                     (P.refl , p-lemma t)
    helper₂ t∈       with t ≟ t
    helper₂ S.return | yes P.refl = P.refl
    helper₂ t∈       | no  t≢t  with t≢t P.refl
    helper₂ t∈       | no  t≢t  | ()

    helper : ∀ {s} (t∈ : t ∈ tok t · s) → s ≡ [ t ] →
             t∈ ≅ complete {t = t}
    helper (S.token >>= t∈) P.refl rewrite helper₂ t∈ = H.refl

------------------------------------------------------------------------
-- Map then choice

-- y ∈ ⋁ f xs · s  iff  ∃ x ∈ xs. y ∈ f x · s.

⋁ : ∀ {Tok R₁ R₂} {f : R₁ → List R₂} →
    ((x : R₁) → Parser Tok R₂ (f x)) → (xs : List R₁) →
    Parser Tok R₂ (xs >>=′ f)
⋁ f xs = return⋆ xs >>= f

module ⋁ where

  sound : ∀ {Tok R₁ R₂ y s} {i : R₁ → List R₂} →
          (f : (x : R₁) → Parser Tok R₂ (i x)) (xs : List R₁) →
          y ∈ ⋁ f xs · s → ∃ λ x → (x ∈ xs) × (y ∈ f x · s)
  sound f xs (∈ret⋆ >>= y∈fx) with Return⋆.sound xs ∈ret⋆
  ...   | (P.refl , x∈xs) = (_ , x∈xs , y∈fx)

  complete : ∀ {Tok R₁ R₂ x y s} {i : R₁ → List R₂} →
             (f : (x : R₁) → Parser Tok R₂ (i x)) {xs : List R₁} →
             x ∈ xs → y ∈ f x · s → y ∈ ⋁ f xs · s
  complete f x∈xs y∈fx =
    [ ○ - ○ ] Return⋆.complete x∈xs >>= y∈fx

  complete∘sound : ∀ {Tok R₁ R₂ y s} {i : R₁ → List R₂} →
                   (f : (x : R₁) → Parser Tok R₂ (i x)) (xs : List R₁)
                   (y∈⋁fxs : y ∈ ⋁ f xs · s) →
                   let p = proj₂ $ sound f xs y∈⋁fxs in
                   complete f (proj₁ p) (proj₂ p) ≡ y∈⋁fxs
  complete∘sound f xs (∈ret⋆ >>= y∈fx)
    with Return⋆.sound xs ∈ret⋆
       | Inverse.right-inverse-of Return⋆.correct ∈ret⋆
  complete∘sound f xs (.(Return⋆.complete x∈xs) >>= y∈fx)
    | (P.refl , x∈xs) | P.refl = P.refl

  sound∘complete :
    ∀ {Tok R₁ R₂ x y s} {i : R₁ → List R₂} →
    (f : (x : R₁) → Parser Tok R₂ (i x)) {xs : List R₁} →
    (x∈xs : x ∈ xs) (y∈fx : y ∈ f x · s) →
    sound f xs (complete f x∈xs y∈fx) ≡ (x , x∈xs , y∈fx)
  sound∘complete {Tok} f {xs} x∈xs y∈fx
    with Return⋆.sound {Tok = Tok} xs (Return⋆.complete x∈xs)
       | Inverse.left-inverse-of (Return⋆.correct {Tok = Tok})
                                 (P.refl , x∈xs)
  ... | (P.refl , .x∈xs) | P.refl = P.refl

------------------------------------------------------------------------
-- Digits and numbers

-- Digits.

digit = sat (λ t → if in-range t then just (to-number t) else nothing)
  where
  in-range : Char → Bool
  in-range t = ⌊ Char.toℕ '0' ≤? Char.toℕ  t  ⌋ ∧
               ⌊ Char.toℕ  t  ≤? Char.toℕ '9' ⌋

  to-number : Char → ℕ
  to-number t = Char.toℕ t ∸ Char.toℕ '0'

-- Numbers.

number : Parser Char ℕ _
number = digit + >>= (return ∘ foldl (λ n d → 10 * n + d) 0)


{-# OPTIONS --rewriting #-}

-- Normalization by Evaluation for Graded Call-By-Push-Value.

module GradedCBPV where

-- Imports from the Agda standard library.

open import Library hiding (_×̇_)
pattern here! = here refl

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

open import ProMonoid as _

-- We postulate an effect algebra, a pre-ordered monoid

postulate
  effAlg : ProMonoid lzero lzero lzero

open ProMonoid effAlg public
  renaming
    ( Carrier to Eff
    ; _∙_     to infixl 6 _+_
    ; ε       to ∅
    ; _≼_     to _≤_
    ; _≈_     to _=E_
    )

-- postulate
--   +-unitˡ : ∅ + e ≡ e
--   +-unitʳ : e + ∅ ≡ e
--   +-assoc : (e₁ + e₂) + e₃ ≡ e₁ + (e₂ + e₃)
--   +-supʳ  : sup es + e ≡ sup λ i → es i + e
--   sup-k   : sup {I = I} (λ _ → e) ≡ e

-- {-# REWRITE +-unitˡ +-unitʳ +-assoc +-supʳ sup-k #-}

-- We postulate a set of generic value types.
-- There are no operations defined on these types, thus,
-- they play the type of (universal) type variables.

postulate
  Base : Set

variable
  o : Base

-- Variants (Σ) (and records (Π), resp.) can in principle have any number of
-- constructors (fields, resp.), including infinitely one.
-- In general, the constructor (field, resp.) names are given by a set I.
-- However, I : Set would make syntax already a big type, living in Set₁.
-- To keep it in Set₀, we only consider variants (records) with finitely
-- many constructors (fields), thus, I : ℕ.
-- Branching over I is then realized as functions out of El I, where
-- El I = { i | i < I} = Fin I.

set = ℕ
El  = Fin

-- Let I range over arities (constructor/field sets) and i over
-- constructor/field names.

variable
  I : set
  i : El I

variable
  e e' e₁ e₂ e₃ : Eff
  es : El I → Eff

-- The types of CBPV are classified into value types P : Ty⁺ which we
-- refer to as positive types, and computation types N : Ty⁻ which we
-- refer to as negative types.

mutual

  -- Value types

  data Ty⁺ : Set where
    base  : (o : Base) → Ty⁺                   -- Base type.
    _×̇_   : (P₁ P₂ : Ty⁺) → Ty⁺                -- Finite product (tensor).
    Σ̇     : (I : set) (Ps : El I → Ty⁺) → Ty⁺  -- Variant (sum).
    [_]   : (e : Eff) (N : Ty⁻) → Ty⁺          -- Thunk (U).
                                               -- Remembers effects.

  -- Computation types

  data Ty⁻ : Set where
    ◇̇    : (P : Ty⁺) → Ty⁻                     -- Comp (F).
    Π̇    : (I : set) (Ns : El I → Ty⁻) → Ty⁻   -- Record (lazy product).
    _⇒̇_  : (P : Ty⁺) (N : Ty⁻) → Ty⁻           -- Function type.

-- In CBPV, a variable stands for a value.
-- Thus, environments only contain values,
-- and typing contexts only value types.

-- We use introduce syntax in an intrinsically well-typed way
-- with variables being de Bruijn indices into the typing context.
-- Thus, contexts are just lists of types.

Cxt = List Ty⁺

variable
  Γ Δ Φ            : Cxt
  J                : Cxt → Set
  P P₁ P₂ P' P′ Q  : Ty⁺
  N N₁ N₂ N' N′    : Ty⁻
  Ps               : El I → Ty⁺
  Ns               : El I → Ty⁻

-- Generic values

module _ (Var : Ty⁺ → Cxt → Set) (Comp : Eff → Ty⁻ → Cxt → Set) where

  -- Right non-invertible

  data Val' : (P : Ty⁺) (Γ : Cxt) → Set where
    var    : (x : Var P Γ)                      → Val' P Γ
    pair   : (v₁ : Val' P₁ Γ) (v₂ : Val' P₂ Γ)  → Val' (P₁ ×̇ P₂) Γ
    inj    : (i : _) (v : Val' (Ps i) Γ)        → Val' (Σ̇ I Ps) Γ
    thunk  : (t : Comp e N Γ)                   → Val' ([ e ] N) Γ

-- Terms

mutual

  Val = Val' _∈_ Comp

  data Comp (e : Eff) : (N : Ty⁻) (Γ : Cxt) → Set where
    -- introductions
    ret    : (∅≤ : ∅ ≤ e)
             (v : Val P Γ)                → Comp e (◇̇ P)    Γ
    rec    : (t : ∀ i → Comp e (Ns i) Γ)  → Comp e (Π̇ I Ns) Γ
    abs    : (t : Comp e N (P ∷ Γ))       → Comp e (P ⇒̇ N)  Γ
    -- positive eliminations
    split  : (v : Val (P₁ ×̇ P₂) Γ)  (t : Comp e N (P₂ ∷ P₁ ∷ Γ))      → Comp e N Γ
    case   : (v : Val (Σ̇ I Ps) Γ)   (t : ∀ i → Comp e N (Ps i ∷ Γ))   → Comp e N Γ
    bind   : (+≤ : e₁ + e₂ ≤ e)
             (u : Comp e₁ (◇̇ P) Γ)  (t : Comp e₂ N (P ∷ Γ))           → Comp e N Γ
    -- cut
    letv   : (v : Val P Γ)          (t : Comp e N (P ∷ Γ))            → Comp e N Γ
    -- negative eliminations
    force  : (v : Val  ([ e ] N)  Γ)                  → Comp e N      Γ
    prj    : (i : _) (t : Comp e (Π̇ I Ns) Γ)          → Comp e (Ns i) Γ
    app    : (t : Comp e (P ⇒̇ N)  Γ)   (v : Val P Γ)  → Comp e N      Γ

-- Normal forms
------------------------------------------------------------------------

-- Normal values only reference variables of base type

NVar : (P : Ty⁺) (Γ : Cxt) → Set
NVar (base o) Γ = base o ∈ Γ
NVar _ _ = ⊥

-- Negative neutrals

module _ (Val : Ty⁺ → Cxt → Set) where

  -- Right non-invertible
  -- Propagates the effect from the head variable, a thunk.

  data Ne' (e : Eff) : (N : Ty⁻) (Γ : Cxt) → Set where
    force  : (x : [ e ] N ∈ Γ)                    → Ne' e N Γ
    prj    : (i : El I) (t : Ne' e (Π̇ I Ns) Γ)    → Ne' e (Ns i) Γ
    app    : (t : Ne' e (P ⇒̇ N) Γ) (v : Val P Γ)  → Ne' e N Γ

mutual

  NVal = Val' NVar Nf
  Ne   = Ne' NVal

  -- Cover monad (generalized case tree).
  -- Collects effects from all bind nodes.

  data ⟨_⟩ (e : Eff) (J : Cxt → Set) (Γ : Cxt) : Set where
    return  : (∅≤ : ∅ ≤ e)         (j : J Γ)                          → ⟨ e ⟩ J Γ
    bind    : (+≤ : e₁ + e₂ ≤ e)
              (u : Ne e₁ (◇̇ P) Γ)  (t :      ⟨ e₂ ⟩ J       (P ∷ Γ))  → ⟨ e ⟩ J Γ
    case    : (x : Σ̇ I Ps ∈ Γ)     (t : ∀ i → ⟨ e ⟩ J    (Ps i ∷ Γ))  → ⟨ e ⟩ J Γ
    split   : (x : (P₁ ×̇ P₂) ∈ Γ)  (t :       ⟨ e ⟩ J (P₂ ∷ P₁ ∷ Γ))  → ⟨ e ⟩ J Γ

  ◇ : ∀ J e Γ → Set
  ◇ J e = ⟨ e ⟩ J

  -- syntax ◇ J e = ⟨ e ⟩ J

  -- Right invertible.

  data Nf (e : Eff) : (N : Ty⁻) (Γ : Cxt) → Set where
    -- ne only needed for negative base types
    -- ne    : let N = ◇̇ (base o) in (n : ⟨ e ⟩ (Ne e N) Γ)  → Nf e N       Γ
    -- ne    : let N = ◇̇ (base o) in
    --         (+≤ : e₁ + e₂ ≤ e) (n : ⟨ e₂ ⟩ (Ne e₁ N) Γ)  → Nf e N Γ
    ret   : (v : ⟨ e ⟩ (NVal P) Γ)                        → Nf e (◇̇ P)   Γ   -- Invoke RFoc
    rec   : (ts : ∀ i → Nf e (Ns i) Γ)                    → Nf e (Π̇ I Ns) Γ
    abs   : (t : Nf e N (P ∷ Γ))                          → Nf e (P ⇒̇ N)  Γ

-- Context-indexed sets
------------------------------------------------------------------------

PSet = (Γ : Cxt) → Set
NSet = (e : Eff) (Γ : Cxt) → Set

variable
  C A A' A₁ A₂ : PSet
  B B' B₁ B₂ : NSet
  F G As : (i : El I) → PSet
  Bs Bs' Bs₁ Bs₂ : (i : El I) → NSet

-- Constructions on PSet

1̂ : PSet
1̂ Γ = ⊤

_×̂_ : (A₁ A₂ : PSet) → PSet
(A₁ ×̂ A₂) Γ = A₁ Γ × A₂ Γ

Σ̂ : (I : set) (As : El I → PSet) → PSet
(Σ̂ I F) Γ = ∃ λ i → F i Γ

_⇒̂_ : (A₁ A₂ : PSet) → PSet
(A₁ ⇒̂ A₂) Γ = A₁ Γ → A₂ Γ

Π̂ : (I : set) (As : El I → PSet) → PSet
(Π̂ I As) Γ = ∀ i → As i Γ

⟪_⟫ : (P : Ty⁺) (A : PSet) → PSet
⟪ P ⟫ A Γ = A (P ∷ Γ)

-- Constructions on NSet

_⇒ⁿ_ : (A : PSet) (B : NSet) → NSet
(A ⇒ⁿ B) e Γ = A Γ → B e Γ

Πⁿ : (I : set) (Bs : El I → NSet) → NSet
(Πⁿ I Bs) e Γ = ∀ i → Bs i e Γ

-- Morphisms between ISets

_→̇_ : (A₁ A₂ : PSet) → Set
A₁ →̇ A₂ = ∀{Γ} → A₁ Γ → A₂ Γ

_→̈_ : (B₁ B₂ : NSet) → Set
B₁ →̈ B₂ = ∀{e Γ} → B₁ e Γ → B₂ e Γ

⟨_⊙_⟩→̇_ : (P Q R : PSet) → Set
⟨ P ⊙ Q ⟩→̇ R = ∀{Γ} → P Γ → Q Γ → R Γ

⟨_⊙_⊙_⟩→̇_ : (P Q R S : PSet) → Set
⟨ P ⊙ Q ⊙ R ⟩→̇ S = ∀{Γ} → P Γ → Q Γ → R Γ → S Γ

Map : (F : (PSet) → PSet) → Set₁
Map F = ∀{A B : PSet} (f : A →̇ B) → F A →̇ F B

Π-map : (∀ i {e} → Bs i e →̇ Bs' i e) → ∀{e} → Πⁿ I Bs e →̇ Πⁿ I Bs' e
Π-map f r i = f i (r i)

-- -- Introductions and eliminations for ×̂

-- p̂air : ⟨ A ⊙ B ⟩→̇ (A ×̂ B)
-- p̂air a b = λ

-- Monotonicity
------------------------------------------------------------------------

-- Monotonization □ is a monoidal comonad

□ : (A : PSet) → PSet
□ A Γ = ∀{Δ} (τ : Γ ⊆ Δ) → A Δ

extract : □ A →̇ A
extract a = a ⊆-refl

duplicate : □ A →̇ □ (□ A)
duplicate a τ τ′ = a (⊆-trans τ τ′)

□-map : Map □
□-map f a τ = f (a τ)

extend : (□ A →̇ C) → □ A →̇ □ C
extend f = □-map f ∘ duplicate

□-weak : □ A →̇ ⟪ P ⟫ (□ A)
□-weak a τ = a (⊆-trans (_ ∷ʳ ⊆-refl) τ)

□-weak' : □ A →̇ □ (⟪ P ⟫ A)
□-weak' a τ = a (_ ∷ʳ τ)

□-sum : Σ̂ I (□ ∘ F) →̇ □ (Σ̂ I F)
□-sum (i , a) τ = i , a τ

-- Monoidality:

□-unit : 1̂ →̇ □ 1̂
□-unit = _

□-pair : ⟨ □ A₁ ⊙ □ A₂ ⟩→̇ □ (A₁ ×̂ A₂)
□-pair a b τ = (a τ , b τ)

-- -- Strong functoriality

Map! : (F : PSet → PSet) → Set₁
Map! F = ∀{A C} → ⟨ □ (λ Γ → A Γ → C Γ) ⊙ F A ⟩→̇ F C

-- Monotonicity

Mon : (A : PSet) → Set
Mon A = A →̇ □ A

monVar : Mon (P ∈_)
monVar x τ = ⊆-lookup τ x

-- Positive ISets are monotone

□-mon : Mon (□ A)
□-mon = duplicate

1-mon : Mon 1̂
1-mon = □-unit

×-mon : Mon A₁ → Mon A₂ → Mon (A₁ ×̂ A₂)
×-mon mA mB (a , b) = □-pair (mA a) (mB b)

Σ-mon : ((i : El I) → Mon (F i)) → Mon (Σ̂ I F)
Σ-mon m (i , a) = □-sum (i , m i a)

□-intro : Mon A → (A →̇ C) → (A →̇ □ C)
□-intro mA f = □-map f ∘ mA

-- Cover monad: a strong graded monad
------------------------------------------------------------------------

join : ⟨ e₁ ⟩ (⟨ e₂ ⟩ A) →̇ ⟨ e₁ + e₂ ⟩ A
join (return ∅≤e c)  = {!c !}
join (bind ≤e u c)  = {!bind u (join c) !}
join (case x t)  = case x (join ∘ t)
join (split x c) = split x (join c)

{-
◇-map : Map ⟨ e ⟩
◇-map f (return  j) = return  (f j)
◇-map f (bind  u a) = bind  u (◇-map f a)
◇-map f (case  x t) = case  x (λ i → ◇-map f (t i))
◇-map f (split x a) = split x (◇-map f a)

◇-map! : Map! ⟨ e ⟩
◇-map! f (return  j) = return  (extract f j)
◇-map! f (bind  u a) = bind  u (◇-map! (□-weak f) a)
◇-map! f (case  x t) = case  x (λ i → ◇-map! (□-weak f) (t i))
◇-map! f (split x a) = split x (◇-map! (□-weak (□-weak f)) a)

◇-bind : A →̇ ⟨ e₂ ⟩ C → ⟨ e₁ ⟩ A →̇ ⟨ e₁ + e₂ ⟩ C
◇-bind f = join ∘ ◇-map f

◇-record : (⟨ e ⟩ ∘ Πⁿ I Bs) →̈ Πⁿ I (λ i → ⟨ e ⟩ ∘ Bs i)
◇-record c i = ◇-map (_$ i) c

◇-fun : Mon A → (⟨ e ⟩ ∘ A ⇒ⁿ B) →̈ (A ⇒ⁿ (⟨ e ⟩ ∘ B))
◇-fun mA c a = ◇-map! (λ τ f → f (mA a τ)) c

-- Monoidal functoriality

◇-pair : ⟨ □ (⟨ e₁ ⟩ A₁) ⊙ ⟨ e₂ ⟩ (□ A₂) ⟩→̇ ⟨ e₂ + e₁ ⟩ (A₁ ×̂ A₂)
◇-pair ca = join ∘ ◇-map! λ τ b → ◇-map! (λ τ′ a → a , b τ′) (ca τ)

_⋉_ = ◇-pair

□◇-pair' : ⟨ □ (⟨ e₁ ⟩ A₁) ⊙ □ (⟨ e₂ ⟩ (□ A₂)) ⟩→̇ □ (⟨ e₂ + e₁ ⟩ (A₁ ×̂ A₂))
□◇-pair' ca cb τ = ◇-pair (□-mon ca τ) (cb τ)

□◇-pair : Mon A₂ → ⟨ □ (⟨ e₁ ⟩ A₁) ⊙ □ (⟨ e₂ ⟩ A₂) ⟩→̇ □ (⟨ e₂ + e₁ ⟩ (A₁ ×̂ A₂))
□◇-pair mB ca cb τ = join $
  ◇-map! (λ τ₁ b → ◇-map! (λ τ₂ a → a , mB b τ₂) (ca (⊆-trans τ τ₁))) (cb τ)

◇□-pair' : ⟨ ⟨ e₁ ⟩ (□ A₁) ⊙ □ (⟨ e₂ ⟩ (□ A₂)) ⟩→̇ ⟨ e₁ + e₂ ⟩ (□ (A₁ ×̂ A₂))
◇□-pair' ca cb = join (◇-map! (λ τ a → ◇-map! (λ τ₁ b {_} τ₂ → a (⊆-trans τ₁ τ₂) , b τ₂) (cb τ)) ca)
  -- Without the abstraction over {_}, there is an incomprehensible error.

◇□-pair : ⟨ □ (⟨ e₁ ⟩ (□ A₁)) ⊙ ⟨ e₂ ⟩ (□ A₂) ⟩→̇ ⟨ e₂ + e₁ ⟩ (□ (A₁ ×̂ A₂))
◇□-pair ca cb = join (◇-map! (λ τ b → ◇-map! (λ τ₁ a {_} τ₂ → a τ₂ , b (⊆-trans τ₁ τ₂)) (ca τ)) cb)
  -- Without the abstraction over {_}, there is an incomprehensible error.

-- Runnability

Run : (B : NSet) → Set
Run B = ∀{e₁ e₂} → ⟨ e₁ ⟩ (B e₂) →̇ B (e₁ + e₂)

-- Negative ISets are runnable

◇-run : Run (◇ A)
◇-run = join

Π-run : (∀ i → Run (Bs i)) → Run (Πⁿ I Bs)
Π-run f c i = f i (◇-map (_$ i) c)
-- Π-run f x i = Π-map {!λ j → f j!} {!!} {!!}
-- Π-run f = {!Π-map f!} ∘ ◇-record

⇒-run : Mon A → Run B → Run (A ⇒ⁿ B)
⇒-run {B = B} mA rB f = rB ∘ ◇-fun {B = B} mA f

-- Bind for the ◇ monad

◇-elim : Run B → (A →̇ B e₂) → ⟨ e₁ ⟩ A →̇ B (e₁ + e₂)
◇-elim rB f = rB ∘ ◇-map f

◇-elim! : Run B → ⟨ □ (A ⇒̂ B e₂) ⊙ ⟨ e₁ ⟩ A ⟩→̇ B (e₁ + e₂)
◇-elim! rB f = rB ∘ ◇-map! f

◇-elim-□ : Run B → ⟨ □ (A ⇒̂ B e₂) ⊙ □ (⟨ e₁ ⟩ A) ⟩→̇ □ (B (e₁ + e₂))
◇-elim-□ {B = B} rB f c = □-map (uncurry (◇-elim! {B = B} rB)) (□-pair (□-mon f) c)

◇-elim-□-alt : Run B → ⟨ □ (A ⇒̂ B e₂) ⊙ □ (⟨ e₁ ⟩ A) ⟩→̇ □ (B (e₁ + e₂))
◇-elim-□-alt {B = B} rB f c τ = ◇-elim! {B = B} rB (□-mon f τ) (c τ)

bind! : Mon C → Run B → (C →̇ ⟨ e₁ ⟩ A) → (C →̇ (A ⇒̂ B e₂)) → C →̇ B (e₁ + e₂)
bind! {B = B} mC rB f k γ = ◇-elim! {B = B} rB (λ τ a → k (mC γ τ) a) (f γ)

-- Type interpretation
------------------------------------------------------------------------

mutual
  ⟦_⟧⁺ : Ty⁺ → PSet
  ⟦ base o  ⟧⁺ = base o ∈_
  ⟦ P₁ ×̇ P₂ ⟧⁺ = ⟦ P₁ ⟧⁺ ×̂ ⟦ P₂ ⟧⁺
  ⟦ Σ̇ I P   ⟧⁺ = Σ̂ I λ i → ⟦ P i ⟧⁺
  ⟦ [ e ] N ⟧⁺ = □ (⟦ N ⟧⁻ e)

  ⟦_⟧⁻ : Ty⁻ → NSet
  ⟦ ◇̇ P   ⟧⁻ = ◇ ⟦ P ⟧⁺
  ⟦ Π̇ I N ⟧⁻ = Πⁿ I λ i → ⟦ N i ⟧⁻
  ⟦ P ⇒̇ N ⟧⁻ = ⟦ P ⟧⁺ ⇒ⁿ ⟦ N ⟧⁻

⟦_⟧ᶜ : Cxt → PSet
⟦_⟧ᶜ Γ Δ = All (λ P → ⟦ P ⟧⁺ Δ) Γ

-- ⟦ []    ⟧ᶜ = 1̂
-- ⟦ P ∷ Γ ⟧ᶜ = ⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺

-- Positive types are monotone.

mon⁺ : (P : Ty⁺) → Mon ⟦ P ⟧⁺
mon⁺ (base o)  = monVar
mon⁺ (P₁ ×̇ P₂) = ×-mon (mon⁺ P₁) (mon⁺ P₂)
mon⁺ (Σ̇ I P)   = Σ-mon (mon⁺ ∘ P)
mon⁺ ([ e ] N) = □-mon

monᶜ : (Γ : Cxt) → Mon ⟦ Γ ⟧ᶜ
monᶜ Γ γ τ = All.map (λ {P} v → mon⁺ P v τ) γ

-- Negative types are runnable.

run⁻ : (N : Ty⁻) → Run ⟦ N ⟧⁻
run⁻ (◇̇ P)   = ◇-run
run⁻ (Π̇ I N) = Π-run (run⁻ ∘ N)
run⁻ (P ⇒̇ N) = ⇒-run {B = ⟦ N ⟧⁻} (mon⁺ P) (run⁻ N)

-- monᶜ []      = 1-mon
-- monᶜ (P ∷ Γ) = ×-mon (monᶜ Γ) (mon⁺ P)

-- Interpretation
------------------------------------------------------------------------

mutual

  ⦅_⦆⁺ : Val P Γ → ⟦ Γ ⟧ᶜ →̇ ⟦ P ⟧⁺
  ⦅ var x ⦆⁺      = λ γ → All.lookup γ x
  ⦅ pair v₁ v₂ ⦆⁺ = < ⦅ v₁ ⦆⁺ , ⦅ v₂ ⦆⁺ >
  ⦅ inj i v ⦆⁺    = (i ,_) ∘ ⦅ v ⦆⁺
  ⦅ thunk t ⦆⁺    = □-intro (monᶜ _) ⦅ t ⦆⁻

  λ⦅_⦆⁻ : Comp e N (P ∷ Γ) → ⟦ Γ ⟧ᶜ →̇ ⟦ P ⇒̇ N ⟧⁻ e
  λ⦅ t ⦆⁻ γ a = ⦅ t ⦆⁻ (a ∷ γ)

  ⦅_⦆⁻ : Comp e N Γ → ⟦ Γ ⟧ᶜ →̇ ⟦ N ⟧⁻ e
  ⦅ ret v ⦆⁻ = return ∘ ⦅ v ⦆⁺
  ⦅ rec t ⦆⁻ = flip λ i → {! ⦅ t i ⦆⁻ !}  -- need effect subsumption es i ≤ sup es
  ⦅ abs t ⦆⁻ = λ⦅ t ⦆⁻
  ⦅ split v t ⦆⁻ γ = let (a₁ , a₂) = ⦅ v ⦆⁺ γ in ⦅ t ⦆⁻ (a₂ ∷ (a₁ ∷ γ))
  ⦅ case v t ⦆⁻  γ = let (i , a) = ⦅ v ⦆⁺ γ in  {! ⦅ t i ⦆⁻ (a ∷ γ) !}  -- eff sub
  ⦅ bind {Γ = Γ} {N = N} t t₁ ⦆⁻ = bind! {B = ⟦ N ⟧⁻} (monᶜ Γ) (run⁻ N) ⦅ t ⦆⁻ λ⦅ t₁ ⦆⁻
  ⦅ force v ⦆⁻  = extract ∘ ⦅ v ⦆⁺
  ⦅ prj i t ⦆⁻  = (_$ i) ∘ ⦅ t ⦆⁻
  ⦅ app t v ⦆⁻  = ⦅ t ⦆⁻  ˢ ⦅ v ⦆⁺
  ⦅ letv v t ⦆⁻ = λ⦅ t ⦆⁻ ˢ ⦅ v ⦆⁺

-- Reflection and reification

mutual

  fresh□◇□ : ∀ P {Γ} → ⟪ P ⟫ (□ (⟨ ∅ ⟩ (□ ⟦ P ⟧⁺))) Γ
  fresh□◇□ P = reflect⁺□ P ∘ monVar here!

  fresh□ : ∀ P {Γ} → ⟪ P ⟫ (□ (⟨ ∅ ⟩ ⟦ P ⟧⁺)) Γ
  fresh□ P = ◇-map extract ∘ reflect⁺□ P ∘ monVar here!
  fresh□ P = reflect⁺ P ∘ monVar here!

  fresh : ∀ {P Γ} → ⟪ P ⟫ (⟨ ∅ ⟩ ⟦ P ⟧⁺) Γ
  fresh {P} = ◇-map extract (reflect⁺□ P here!)
  fresh {P} = reflect⁺ P here!

  fresh◇ : ∀ {P Γ} → ⟪ P ⟫ (⟨ ∅ ⟩ (□ ⟦ P ⟧⁺)) Γ
  fresh◇ {P} = reflect⁺□ P here!
  fresh◇ {P} = ◇-map (mon⁺ P) fresh

  -- saves us use of Mon P in freshᶜ
  reflect⁺□ : (P : Ty⁺) → (P ∈_) →̇ (⟨ ∅ ⟩ (□ ⟦ P ⟧⁺))
  reflect⁺□ (base o)  x = return (monVar x)
  reflect⁺□ (P₁ ×̇ P₂) x = split x (◇□-pair (reflect⁺□ P₁ ∘ monVar (there here!)) fresh◇)
  reflect⁺□ (Σ̇ I Ps)  x = case x λ i → ◇-map (□-map (i ,_)) fresh◇
  reflect⁺□ ([ e ] N) x = return (□-mon (reflect⁻ N ∘ force ∘ monVar x))

  reflect⁺ : (P : Ty⁺) → (P ∈_) →̇ (⟨ ∅ ⟩ ⟦ P ⟧⁺)
  reflect⁺ (base o)  x = return x
  reflect⁺ (P₁ ×̇ P₂) x = split x (□-weak (fresh□ P₁) ⋉ fresh◇)
  reflect⁺ (Σ̇ I Ps)  x = case x λ i → ◇-map (i ,_) fresh
  reflect⁺ ([ e ] N) x = return λ τ → reflect⁻ N (force (monVar x τ))

  reflect⁻ : (N : Ty⁻) → Ne e N →̇ ⟦ N ⟧⁻ e
  reflect⁻ (◇̇ P)    u = bind u fresh
  reflect⁻ (Π̇ I Ns) u = λ i → reflect⁻ (Ns i) (prj i u)
  reflect⁻ (P ⇒̇ N)  u = λ a → reflect⁻ N (app u (reify⁺ P a))

  reify⁺ : (P : Ty⁺) → ⟦ P ⟧⁺ →̇ NVal P
  reify⁺ (base o) = var
  reify⁺ (P₁ ×̇ P₂) (a₁ , a₂) = pair (reify⁺ P₁ a₁) (reify⁺ P₂ a₂)
  reify⁺ (Σ̇ I Ps)  (i  , a ) = inj i (reify⁺ (Ps i) a)
  reify⁺ ([ e ] N) a = thunk (reify⁻ N a)

  reify⁻ : (N : Ty⁻) → □ (⟦ N ⟧⁻ e) →̇ Nf e N
  reify⁻         (◇̇ P)    f = ret (◇-map (reify⁺ P) (extract f))
  reify⁻ {e = e} (Π̇ I Ns) f = rec {es = λ i → e} λ i → reify⁻ (Ns i) (□-map (_$ i) f)
  reify⁻         (P ⇒̇ N)  f = abs $ reify⁻ N $ ◇-elim-□ {B = ⟦ N ⟧⁻} (run⁻ N) (□-weak f) $ fresh□ P

ext : (⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺) →̇ ⟦ P ∷ Γ ⟧ᶜ
ext (γ , a) = a ∷ γ

◇-ext : ⟨ e ⟩ (⟦ Γ ⟧ᶜ ×̂ ⟦ P ⟧⁺) →̇ ⟨ e ⟩ ⟦ P ∷ Γ ⟧ᶜ
◇-ext = ◇-map ext

-- Without the use of ◇-mon!

freshᶜ : (Γ : Cxt) → □ (⟨ ∅ ⟩ ⟦ Γ ⟧ᶜ) Γ
freshᶜ []      = λ τ → return []
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair' (□-weak (freshᶜ Γ)) (fresh□◇□ P)
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair (mon⁺ P) (□-weak (freshᶜ Γ)) (fresh□ P)
freshᶜ (P ∷ Γ) = ◇-ext ∘ □◇-pair' (□-weak (freshᶜ Γ)) (◇-map (mon⁺ P) ∘ (fresh□ P))
freshᶜ (P ∷ Γ) = ◇-ext ∘ λ τ →
  (□-weak (□-mon (freshᶜ Γ)) τ)
  ⋉ ◇-map (mon⁺ P) (fresh□ P τ)

norm : Comp e N →̇ Nf e N
norm {N = N} {Γ = Γ} t = reify⁻ N $ □-map (run⁻ N ∘ ◇-map ⦅ t ⦆⁻) $ freshᶜ Γ
norm {N = N} {Γ = Γ} t = reify⁻ N $ run⁻ N ∘ ◇-map ⦅ t ⦆⁻ ∘ freshᶜ Γ

-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


module Duploid where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; cong)
open Eq.≡-Reasoning

open import Level

open import Preduploid

private
  variable p q r s : Polarity

record Duploid o ℓ : Set (suc (o ⊔ ℓ)) where
  field
    𝒟 : Preduploid o ℓ

  open Preduploid.Preduploid 𝒟 public

  field
    ⇓ : Ob ⊝ -> Ob +
    ⇑ : Ob + -> Ob ⊝

    delay : forall {P : Ob +} -> P ⇒ ⇑ P
    force : forall {P : Ob +} -> ⇑ P ⇒ P

    wrap : forall {N : Ob ⊝} -> N ⇒ ⇓ N
    unwrap : forall {N : Ob ⊝} -> ⇓ N ⇒ N

    force∘delay∙ : forall {A : Ob p} {P : Ob +} {f : A ⇒ P} -> force ∘ (delay ∙ f) ≡ f
    ∘unwrap∙wrap : forall {N : Ob ⊝} {A : Ob p} {f : N ⇒ A} -> (f ∘ unwrap) ∙ wrap ≡ f
    delay∙force : forall {P : Ob +} -> delay ∙ force ≡ id {A = ⇑ P}
    wrap∘unwrap : forall {N : Ob ⊝} -> wrap ∘ unwrap ≡ id {A = ⇓ N}

  ∙force∘delay : forall {P : Ob +} {A : Ob p} {g : P ⇒ A} -> (g ∙ force) ∘ delay ≡ g
  ∙force∘delay {g = g} =
    begin
      (g ∙ force) ∘ delay
    ≡⟨ assoc∙∘ ⟩
      g ∙ (force ∘ delay)
    ≡˘⟨ cong (g ∙_) (cong (force ∘_) identity∙ʳ) ⟩
      g ∙ (force ∘ (delay ∙ id))
    ≡⟨ cong (g ∙_) force∘delay∙ ⟩
      g ∙ id
    ≡⟨ identity∙ʳ ⟩
     g
    ∎

  unwrap∙wrap∘ : forall {A : Ob p} {N : Ob ⊝} {g : A ⇒ N} -> unwrap ∙ (wrap ∘ g) ≡ g
  unwrap∙wrap∘ {g = g} =
    begin
      unwrap ∙ (wrap ∘ g)
    ≡˘⟨ assoc∙∘ ⟩
      (unwrap ∙ wrap) ∘ g
    ≡˘⟨ cong (_∘ g) (cong (_∙ wrap) identity∘ˡ) ⟩
      ((id ∘ unwrap) ∙ wrap) ∘ g
    ≡⟨ cong (_∘ g) ∘unwrap∙wrap ⟩
      id ∘ g
    ≡⟨ identity∘ˡ ⟩
      g
    ∎

  wrap-Thunkable : forall {N : Ob ⊝} -> Thunkable (wrap {N = N})
  wrap-Thunkable {r = +} = sym assoc∙∙
  wrap-Thunkable {r = ⊝} {g = g} {h = h} =
    begin
      h ∘ (g ∙ wrap)
    ≡˘⟨ ∘unwrap∙wrap ⟩
      ((h ∘ (g ∙ wrap)) ∘ unwrap) ∙ wrap
    ≡⟨ cong (_∙ wrap) assoc∘∘ ⟩
      (h ∘ ((g ∙ wrap) ∘ unwrap)) ∙ wrap
    ≡⟨ cong (_∙ wrap) (cong (h ∘_) assoc∙∘) ⟩
      (h ∘ (g ∙ (wrap ∘ unwrap))) ∙ wrap
    ≡⟨ cong (_∙ wrap) (cong (h ∘_) (cong (g ∙_) wrap∘unwrap)) ⟩
      (h ∘ (g ∙ id)) ∙ wrap
    ≡⟨ cong (_∙ wrap) (cong (h ∘_) identity∙ʳ) ⟩
      (h ∘ g) ∙ wrap
    ∎

  force-Linear : forall {P : Ob +} -> Linear (force {P = P})
  force-Linear {q = +} {g = g} {h = h} = sym (
    begin
      (force ∘ g) ∙ h
    ≡˘⟨ force∘delay∙ ⟩
      force ∘ (delay ∙ ((force ∘ g) ∙ h))
    ≡˘⟨ cong (force ∘_) assoc∙∙ ⟩
      force ∘ ((delay ∙ (force ∘ g)) ∙ h)
    ≡˘⟨ cong (force ∘_) (cong (_∙ h) assoc∙∘) ⟩
      force ∘ (((delay ∙ force) ∘ g) ∙ h)
    ≡⟨ cong (force ∘_) (cong (_∙ h) (cong (_∘ g) delay∙force)) ⟩
      force ∘ ((id ∘ g) ∙ h)
    ≡⟨ cong (force ∘_) (cong (_∙ h) identity∘ˡ) ⟩
      force ∘ (g ∙ h)
    ∎)
  force-Linear {q = ⊝} = sym assoc∘∘

  helper1 : forall {A : Ob p} {P : Ob +} {f : A ⇒ P}
    -> (wrap ∘ delay) ∙ f ≡ wrap ∘ (delay ∙ f)
    -> forall {B : Ob q} {h : ⇑ P ⇒ B} -> (h ∘ delay) ∙ f ≡ h ∘ (delay ∙ f)
  helper1 {f = f} e {h = h} =
    begin
      (h ∘ delay) ∙ f
    ≡˘⟨ cong (_∙ f) (cong (_∘ delay) ∘unwrap∙wrap) ⟩
      (((h ∘ unwrap) ∙ wrap) ∘ delay) ∙ f
    ≡⟨ cong (_∙ f) assoc∙∘ ⟩
      ((h ∘ unwrap) ∙ (wrap ∘ delay)) ∙ f
    ≡⟨ assoc∙∙ ⟩
      (h ∘ unwrap) ∙ ((wrap ∘ delay) ∙ f)
    ≡⟨ cong ((h ∘ unwrap) ∙_) e ⟩
      (h ∘ unwrap) ∙ (wrap ∘ (delay ∙ f))
    ≡˘⟨ assoc∙∘ ⟩
      ((h ∘ unwrap) ∙ wrap) ∘ (delay ∙ f)
    ≡⟨ cong (_∘ _) ∘unwrap∙wrap ⟩
      h ∘ (delay ∙ f)
    ∎

  assoc-wrap∘delay∙→Thunkable : forall {A : Ob p} {P : Ob +} {f : A ⇒ P}
    -> (wrap ∘ delay) ∙ f ≡ wrap ∘ (delay ∙ f)
    -> Thunkable f
  assoc-wrap∘delay∙→Thunkable e {r = +} = sym assoc∙∙
  assoc-wrap∘delay∙→Thunkable {f = f} e {r = ⊝} {g = g} {h = h} =
    begin
      h ∘ (g ∙ f)
    ≡˘⟨ cong (h ∘_) (cong (_∙ f) ∙force∘delay) ⟩
      h ∘ (((g ∙ force) ∘ delay) ∙ f)
    ≡⟨ cong (h ∘_) (helper1 e) ⟩
      h ∘ ((g ∙ force) ∘ (delay ∙ f))
    ≡˘⟨ assoc∘∘ ⟩
      (h ∘ (g ∙ force)) ∘ (delay ∙ f)
    ≡˘⟨ helper1 e ⟩
      ((h ∘ (g ∙ force)) ∘ delay) ∙ f
    ≡⟨ cong (_∙ f) assoc∘∘ ⟩
      (h ∘ ((g ∙ force) ∘ delay)) ∙ f
    ≡⟨ cong (_∙ f) (cong (h ∘_) ∙force∘delay) ⟩
      (h ∘ g) ∙ f
    ∎

  helper2 : forall {N : Ob ⊝} {A : Ob p} {f : N ⇒ A}
    -> f ∘ (unwrap ∙ force) ≡ (f ∘ unwrap) ∙ force
    -> forall {B : Ob q} {h : B ⇒ ⇓ N} -> f ∘ (unwrap ∙ h) ≡ (f ∘ unwrap) ∙ h
  helper2 {f = f} e {h = h} =
    begin
      f ∘ (unwrap ∙ h)
    ≡˘⟨ cong (f ∘_) (cong (unwrap ∙_) force∘delay∙) ⟩
      f ∘ (unwrap ∙ (force ∘ (delay ∙ h)))
    ≡˘⟨ cong (f ∘_) assoc∙∘ ⟩
      f ∘ ((unwrap ∙ force) ∘ (delay ∙ h))
    ≡˘⟨ assoc∘∘ ⟩
      (f ∘ (unwrap ∙ force)) ∘ (delay ∙ h)
    ≡⟨ cong (_∘ (delay ∙ h)) e ⟩
      ((f ∘ unwrap) ∙ force) ∘ (delay ∙ h)
    ≡⟨ assoc∙∘ ⟩
      (f ∘ unwrap) ∙ (force ∘ (delay ∙ h))
    ≡⟨ cong ((f ∘ unwrap) ∙_) force∘delay∙ ⟩
      (f ∘ unwrap) ∙ h
    ∎

  assoc-∘unwrap∙force→Linear : forall {N : Ob ⊝} {A : Ob p} {f : N ⇒ A}
    -> f ∘ (unwrap ∙ force) ≡ (f ∘ unwrap) ∙ force
    -> Linear f
  assoc-∘unwrap∙force→Linear {f = f} e {q = +} {g = g} {h = h} =
    begin
      f ∘ (g ∙ h)
    ≡˘⟨ cong (f ∘_) (cong (_∙ h) unwrap∙wrap∘) ⟩
      f ∘ ((unwrap ∙ (wrap ∘ g)) ∙ h)
    ≡⟨ cong (f ∘_) assoc∙∙ ⟩
      f ∘ (unwrap ∙ ((wrap ∘ g) ∙ h))
    ≡⟨ helper2 e ⟩
      (f ∘ unwrap) ∙ ((wrap ∘ g) ∙ h)
    ≡˘⟨ assoc∙∙ ⟩
      ((f ∘ unwrap) ∙ (wrap ∘ g)) ∙ h
    ≡˘⟨ cong (_∙ h) assoc∙∘ ⟩
      (((f ∘ unwrap) ∙ wrap) ∘ g) ∙ h
    ≡⟨ cong (_∙ h) (cong (_∘ g) ∘unwrap∙wrap) ⟩
      (f ∘ g) ∙ h
    ∎
  assoc-∘unwrap∙force→Linear e {q = ⊝} = sym assoc∘∘


{-# OPTIONS --allow-unsolved-metas #-}
module Semantics.Bind where

open import Syntax.Types
open import Syntax.Context renaming (_,_ to _,,_)
open import Syntax.Terms
open import Syntax.Substitution.Kits
open import Syntax.Substitution.Instances
open import Syntax.Substitution.Lemmas

open import Semantics.Types
open import Semantics.Terms
open import Semantics.Context
open import Semantics.Substitution.Kits
open import Semantics.Substitution.Traversal
open import Semantics.Substitution.Instances

open import CategoryTheory.Categories using (Category ; ext)
open import CategoryTheory.Functor
open import CategoryTheory.NatTrans
open import CategoryTheory.Monad
open import CategoryTheory.Comonad
open import CategoryTheory.CartesianStrength
open import CategoryTheory.Instances.Reactive renaming (top to ⊤)
open import TemporalOps.Diamond
open import TemporalOps.Delay
open import TemporalOps.Box
open import TemporalOps.OtherOps
open import TemporalOps.StrongMonad

open import Data.Sum
open import Data.Product using (_,_)
open import Relation.Binary.PropositionalEquality as ≡
    using (_≡_ ; refl ; sym ; trans ; cong ; cong₂ ; subst)

open ≡.≡-Reasoning
open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

open Comonad W-□
open Monad M-◇
private module F-◇ = Functor F-◇
private module F-□ = Functor F-□
open Functor F-□ renaming (fmap to □-f)
open Functor F-◇ renaming (fmap to ◇-f)
private module ▹ᵏ-C k = CartesianFunctor (F-cart-delay k)
private module ▹ᵏ-F k = Functor (F-delay k)
private module □-▹ᵏ k = _⟹_ (□-to-▹ᵏ k)

bind-to->>= : ∀ Γ {⟦A⟧ ⟦B⟧} -> (⟦E⟧ : ⟦ Γ ⟧ₓ ⇴ ◇ ⟦A⟧) (⟦C⟧ : ⟦ Γ ˢ ⟧ₓ ⊗ ⟦A⟧ ⇴ ◇ ⟦B⟧)
        -> (n : ℕ) (⟦Γ⟧ : ⟦ Γ ⟧ₓ n)
        -> bindEvent Γ ⟦E⟧ ⟦C⟧ n ⟦Γ⟧
        ≡ (⟦E⟧ n ⟦Γ⟧ >>= λ l ⟦A⟧ → ⟦C⟧ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧))
bind-to->>= Γ {⟦A⟧} {⟦B⟧} ⟦E⟧ ⟦C⟧ n ⟦Γ⟧ =
    begin
        bindEvent Γ ⟦E⟧ ⟦C⟧ n ⟦Γ⟧
    ≡⟨⟩
        μ.at ⟦B⟧ n (F-◇.fmap (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n (st ⟦ Γ ˢ ⟧ₓ ⟦A⟧ n (⟦ Γ ˢ⟧□ n ⟦Γ⟧ , ⟦E⟧ n ⟦Γ⟧)))
    ≡⟨ cong (μ.at ⟦B⟧ n) (lemma (⟦E⟧ n ⟦Γ⟧)) ⟩
        μ.at ⟦B⟧ n (F-◇.fmap (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n (⟦E⟧ n ⟦Γ⟧))
    ≡⟨⟩
        (⟦E⟧ n ⟦Γ⟧ >>= (λ l ⟦A⟧ → ⟦C⟧ l (⟦ Γ ˢ⟧□ n ⟦Γ⟧ l , ⟦A⟧)))
    ∎
    where
    lemma : ∀ ◇⟦A⟧
         -> F-◇.fmap (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n (st ⟦ Γ ˢ ⟧ₓ ⟦A⟧ n (⟦ Γ ˢ⟧□ n ⟦Γ⟧ , ◇⟦A⟧))
          ≡ F-◇.fmap (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n ◇⟦A⟧
    lemma (k , a) =
        begin
            F-◇.fmap (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n (st ⟦ Γ ˢ ⟧ₓ ⟦A⟧ n (⟦ Γ ˢ⟧□ n ⟦Γ⟧ , (k , a)))
        ≡⟨⟩
            k , ▹ᵏ-F.fmap k (⟦C⟧ ∘ ε.at ⟦ Γ ˢ ⟧ₓ * id) n
                (▹ᵏ-C.m k (□ ⟦ Γ ˢ ⟧ₓ) ⟦A⟧ n (□-▹ᵏ.at k (□ ⟦ Γ ˢ ⟧ₓ) n (δ.at ⟦ Γ ˢ ⟧ₓ k (⟦ Γ ˢ⟧□ n ⟦Γ⟧)) , a))
        ≡⟨ {!   !} ⟩
            k , ▹ᵏ-F.fmap k (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n a
        ≡⟨⟩
            F-◇.fmap (⟦C⟧ ∘ ⟨ (λ l _ → ⟦ Γ ˢ⟧□ n ⟦Γ⟧ l) , id ⟩) n (k , a)
        ∎


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness #-}

open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.List using ([]; _++_; _∷_; _∷ʳ_)

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; subst)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε; _◅_; _◅◅_; return)

open import Common

module FairCompliance {ℙ : Set} (message : Message ℙ)
  where

open import Trace message
open import Session message
open import SessionType message
open import Transitions message
open import HasTrace message

fair-compliance-red* : ∀{S S'} -> FairComplianceS S -> Reductions S S' -> FairComplianceS S'
fair-compliance-red* comp reds reds' = comp (reds ◅◅ reds')

fair-compliance->may-succeed : ∀{S} -> FairComplianceS S -> MaySucceed S
fair-compliance->may-succeed fcomp = fcomp ε

fc-after-output :
  ∀{f g x} ->
  FairComplianceS (out f # inp g) ->
  x ∈ dom f ->
  FairComplianceS (f x .force # g x .force)
fc-after-output comp fx reds = comp (sync (out fx) inp ◅ reds)

fc-after-input :
  ∀{f g x} ->
  FairComplianceS (inp f # out g) ->
  x ∈ dom g ->
  FairComplianceS (f x .force # g x .force)
fc-after-input comp gx reds = comp (sync inp (out gx) ◅ reds)

fc-input : ∀{R f} -> FairComplianceS (R # inp f) ->
            Win R ⊎ ∃[ g ] (R ≡ out g × Witness g × (∀{x} (!x : x ∈ dom g) -> FairComplianceS (g x .force # f x .force)))
fc-input {nil} spec with spec ε
... | _ , ε , win#def () _
... | _ , sync () _ ◅ _ , _
fc-input {inp _} spec with spec ε
... | _ , ε , win#def () _
... | _ , sync () inp ◅ _ , _
fc-input {out g} spec with Empty? g
... | inj₁ U = inj₁ (out U)
... | inj₂ W = inj₂ (g , refl , W , λ !x -> fair-compliance-red* spec (return (sync (out !x) inp)))

fc-output : ∀{R f} -> FairComplianceS (R # out f) ->
            Win R ⊎ ∃[ g ] (R ≡ inp g × Witness f × (∀{x} (!x : x ∈ dom f) -> FairComplianceS (g x .force # f x .force)))
fc-output {nil} spec with spec ε
... | _ , ε , win#def () out
... | _ , sync () _ ◅ _ , _
fc-output {inp g} {f} spec with Empty? f
... | inj₂ W = inj₂ (g , refl , W , λ !x -> fair-compliance-red* spec (return (sync inp (out !x))))
... | inj₁ U with spec ε
... | _ , ε , win#def () _
... | _ , sync inp (out !x) ◅ _ , _ = ⊥-elim (U _ !x)
fc-output {out g} spec with Empty? g
... | inj₁ U = inj₁ (out U)
... | inj₂ (_ , !x) with spec ε
... | _ , ε , win#def (out U) out = ⊥-elim (U _ !x)
... | _ , sync () (out _) ◅ _ , _

fc-transitions :
  ∀{R R' T T' φ} ->
  Transitions R (co-trace φ) R' ->
  Transitions T φ T' ->
  FairComplianceS (R # T) ->
  FairComplianceS (R' # T')
fc-transitions rr tr comp = fair-compliance-red* comp (zip-red* rr tr)

fc-trace :
  ∀{R T φ} ->
  FairComplianceS (R # T) ->
  (rφ : R HasTrace (co-trace φ))
  (tφ : T HasTrace φ) ->
  FairComplianceS (after rφ # after tφ)
fc-trace comp (_ , _ , rr) (_ , _ , tr) = fc-transitions rr tr comp

fc-output-trace :
  ∀{R T x} ->
  FairComplianceS (R # T) ->
  T HasTrace (O x ∷ []) ->
  Win R ⊎ (R HasTrace (I x ∷ []))
fc-output-trace {nil} comp tφ with comp ε
... | _ , ε , win#def () _
... | _ , sync () _ ◅ _ , _
fc-output-trace {inp f} {_} {x} comp (_ , _ , step (out gx) refl) with x ∈? f
... | yes fx = inj₂ (_ , fx , step inp refl)
... | no nfx with comp (return (sync inp (out gx)))
... | _ , ε , win#def w _ = ⊥-elim (nfx (win->defined w))
... | _ , sync r _ ◅ _ , _ = ⊥-elim (contraposition transition->defined nfx r)
fc-output-trace {out f} comp (_ , _ , step (out _) refl) with comp ε
... | _ , ε , win#def w _ = inj₁ w
... | _ , sync () (out _) ◅ _ , _

has-trace-snoc :
  ∀{T φ α} -> T HasTrace (φ ∷ʳ α) ->
  ∃ λ (tφ : T HasTrace φ) -> after tφ HasTrace (α ∷ [])
has-trace-snoc {_} {[]} tα@(_ , _ , step inp refl) = (_ , inp , refl) , tα
has-trace-snoc {_} {[]} tα@(_ , _ , step (out _) refl) = (_ , out , refl) , tα
has-trace-snoc {_} {_ ∷ φ} (_ , def , step t tr) =
  let (_ , tdef , sr) , tφ/α = has-trace-snoc (_ , def , tr) in
  (_ , tdef , step t sr) , tφ/α

client-wins-or-accepts-prefix :
  ∀{R T φ x}
  (comp : FairComplianceS (R # T))
  (rφ : R HasTrace (co-trace φ))
  (tφ : T HasTrace (φ ∷ʳ O x)) ->
  Win (after rφ) ⊎ R HasTrace (co-trace (φ ∷ʳ O x))
client-wins-or-accepts-prefix {_} {_} {φ} comp rφ tφα with has-trace-snoc tφα
... | tφ , tφ/α with fc-trace comp rφ tφ
... | comp/φ with fc-output-trace comp/φ tφ/α
... | inj₁ w = inj₁ w
... | inj₂ rφ/α =
  let rφα = join-trace rφ rφ/α in
  inj₂ (subst (_ HasTrace_) (sym (co-trace-++ φ _)) rφα)


{-# OPTIONS --allow-unsolved-metas #-}
module MGU-revised where

--open import Agda.Builtin.Nat using () renaming (Nat to ℕ)
open import Agda.Primitive
open import Agda.Builtin.Equality

open import Prelude.Product using (Σ; _,_; fst; snd; _×_; curry; uncurry)
open import Prelude.Equality using (eqReasoningStep; _∎; sym; trans; cong)
open import Prelude.Function using (_∘_)
open import Prelude.Empty using (⊥)
open import Prelude.Sum using (left; right) renaming (Either to _⊎_)
open import Prelude.Maybe using (Maybe; just; nothing)

private
  ∃ : ∀ {a b} {A : Set a} (B : A → Set b) → Set (a ⊔ b)
  ∃ = Σ _

open import Prelude using (_$_)

open import Relation.Binary

open import Prolegomenon

import Relation.Binary.Indexed as I

open import Algebra

mcbrideMonoidTransformer : MonoidTransformer lzero lzero lzero lzero
Setoid.Carrier (MonoidTransformer.base mcbrideMonoidTransformer) = {!!}
Setoid._≈_ (MonoidTransformer.base mcbrideMonoidTransformer) = {!!}
Setoid.isEquivalence (MonoidTransformer.base mcbrideMonoidTransformer) = {!!}
Monoid.Carrier (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid._≈_ (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid._∙_ (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid.ε (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
Monoid.isMonoid (MonoidTransformer.exponent mcbrideMonoidTransformer) = {!!}
MonoidTransformer._◃_ mcbrideMonoidTransformer = {!!}
MonoidTransformer.isMonoidTransformer mcbrideMonoidTransformer = {!!}

record Unificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  field
    monoidTransformer : MonoidTransformer ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open module MT = MonoidTransformer monoidTransformer public
{-
  open MonoidTransformer monoidTransformer public renaming
    (_≈ˢ_ to _=ᵗ_
    ;Carrierˢ to T
    ;Carrierᵐ to S
    ;_≈ᵐ_ to _=ˢ_)
-}
  Property : ∀ {ℓ} → Set (ℓˢ ⊔ lsuc ℓ)
  Property {ℓ} = E.Carrier → Set ℓ

  Nothing : ∀ {ℓ} → (P : Property {ℓ}) → Set (ℓ ⊔ ℓˢ)
  Nothing P = ∀ s → P s → ⊥

  IsUnifier : (t₁ t₂ : B.Carrier) → Property
  IsUnifier t₁ t₂ s = s ◃ t₁ B.≈ s ◃ t₂

  field
    unify : (t₁ t₂ : B.Carrier) → Nothing (IsUnifier t₁ t₂) ⊎ ∃ (IsUnifier t₁ t₂)

record MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  --infix 4 _≠ᵗ_
  field
    unificationoid : Unificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open Unificationoid unificationoid public

  _≤_ : (s₋ : E.Carrier) (s₊ : E.Carrier) → Set (ℓˢ ⊔ ℓ⁼ˢ)
  _≤_ s₋ s₊ = ∃ λ s → s E.∙ s₊ E.≈ s₋

  _≠ᵗ_ : B.Carrier → B.Carrier → Set ℓ⁼ᵗ
  _≠ᵗ_ t₁ t₂ = t₁ B.≈ t₂ → ⊥
{-
  _<_ : (s₋ : E.Carrier) (s₊ : E.Carrier) → Set (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)
  _<_ s₋ s₊ = s₋ ≤ s₊ × (∀ t → (s₊ ◃ t) ≠ᵗ t → (s₋ ◃ t) ≠ᵗ t) × ∃ λ t → (s₋ ◃ t) ≠ᵗ t × (s₊ ◃ t) B.≈ t
  --the set of T that are changed by a applying substitution is strictly less with s₊ than with s₋. That is, s₋ makes more changes than s₊.
  --that is, if s₊ makes a change to t then so does s₋, but there is some t s.t. s₋ makes a change but s₊ does not
-}
  MostGenerally : ∀ {ℓ} (P : Property {ℓ}) → Property
  MostGenerally P s₊ = P s₊ × ∀ s₋ → P s₋ → s₋ ≤ s₊

  field
    isMguIfUnifier : (t₁ t₂ : B.Carrier) → (ru : ∃ λ s → unify t₁ t₂ ≡ right s) →
      Prelude.case ru of (λ {((u , _) , _) → MostGenerally (IsUnifier t₁ t₂) u})

  mgu : (t₁ t₂ : B.Carrier) → Nothing (IsUnifier t₁ t₂) ⊎ ∃ (MostGenerally $ IsUnifier t₁ t₂)
  mgu t₁ t₂ with unify t₁ t₂ | Prelude.graphAt (unify t₁) t₂
  mgu t₁ t₂ | left x | ef = left x
  mgu t₁ t₂ | right x | Prelude.ingraph eq with isMguIfUnifier t₁ t₂ (x , eq)
  mgu t₁ t₂ | right (fst₁ , snd₁) | (Prelude.ingraph eq) | dfsd = right (fst₁ , dfsd)

record PairMostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  field
    mostGeneralUnificationoid : MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open MostGeneralUnificationoid mostGeneralUnificationoid public

  field
    separateExponents : E.Carrier → E.Carrier × E.Carrier

  IsPairUnifier : (t₁ t₂ : B.Carrier) → Property
  IsPairUnifier t₁ t₂ u = let (s₁ , s₂) = separateExponents u in s₁ ◃ t₁ B.≈ s₂ ◃ t₂

  field
    pair-mgu : (t₁ t₂ : B.Carrier)
               → Nothing (IsPairUnifier t₁ t₂) ⊎ ∃ (MostGenerally (IsPairUnifier t₁ t₂))

record MakePairFromRegular ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
  field
    mostGeneralUnificationoid : MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

  open MostGeneralUnificationoid mostGeneralUnificationoid public

  field
    left-exponent : E.Carrier → E.Carrier
    right-exponent : E.Carrier → E.Carrier
    left-base : B.Carrier → B.Carrier
    right-base : B.Carrier → B.Carrier
    exponent-to-base : ∀ {s t₁ t₂} → left-exponent s ◃ t₁ B.≈ right-exponent s ◃ t₂ → s ◃ left-base t₁ B.≈ s ◃ right-base t₂
    base-to-exponent : ∀ {s t₁ t₂} → s ◃ left-base t₁ B.≈ s ◃ right-base t₂ → left-exponent s ◃ t₁ B.≈ right-exponent s ◃ t₂

  pairMostGeneralUnificationoid : PairMostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ
  PairMostGeneralUnificationoid.mostGeneralUnificationoid pairMostGeneralUnificationoid = mostGeneralUnificationoid
  PairMostGeneralUnificationoid.separateExponents pairMostGeneralUnificationoid x = left-exponent x , right-exponent x
  PairMostGeneralUnificationoid.pair-mgu pairMostGeneralUnificationoid t₁ t₂ with mgu (left-base t₁) (right-base t₂)
  PairMostGeneralUnificationoid.pair-mgu pairMostGeneralUnificationoid t₁ t₂ | left notunifier = left (λ s x → notunifier s (exponent-to-base x))
  PairMostGeneralUnificationoid.pair-mgu pairMostGeneralUnificationoid t₁ t₂ | right (s , x-base , unified-correct) = right (s , base-to-exponent x-base , (λ s₋ x-exponent → unified-correct s₋ (exponent-to-base x-exponent)))

  --(s , base-to-exponent x , (λ s₋ x₁ → s₋ , {!snd (snd₁ s x)!}))

-- -- open import Algebra

-- -- record PairUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
-- --   field
-- --     monoidTransformer : MonoidTransformer ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- --   open module MT = MonoidTransformer monoidTransformer public -- renaming (module E to Exponent)

-- -- {-
-- --   open MonoidTransformer monoidTransformer public renaming
-- --     (_≈ˢ_ to _=ᵗ_
-- --     ;Carrierˢ to T
-- --     ;Carrierᵐ to S
-- --     ;_≈ᵐ_ to _=ˢ_)
-- -- -}

-- --   Property : ∀ {ℓ} → Set (ℓˢ ⊔ lsuc ℓ)
-- --   Property {ℓ} = E.Carrier × E.Carrier → Set ℓ

-- --   Nothing : ∀ {ℓ} → (P : Property {ℓ}) → Set (ℓ ⊔ ℓˢ)
-- --   Nothing P = ∀ u → P u → ⊥

-- --   IsUnifier : ∀ t₁ t₂ → Property
-- --   IsUnifier t₁ t₂ u = let (s₁ , s₂) = u in s₁ ◃ t₁ B.≈ s₂ ◃ t₂

-- --   field
-- --     unify : ∀ t₁ t₂
-- --           → Nothing (IsUnifier t₁ t₂) ⊎ ∃ (IsUnifier t₁ t₂)

-- -- module MakePairUnificationoidFromUnificationoid where

-- --   postulate
-- --     ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Level
-- --     unificationoid : Unificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- --   open Unificationoid unificationoid

-- --   pairUnificationoid : PairUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ
-- --   PairUnificationoid.monoidTransformer pairUnificationoid = monoidTransformer
-- --   PairUnificationoid.unify pairUnificationoid t₁ t₂ with unify t₁ t₂
-- --   PairUnificationoid.unify pairUnificationoid t₁ t₂ | left x = left (λ {(s₁ , s₂) x₁ → x {!!} {!x₁!}})
-- --   PairUnificationoid.unify pairUnificationoid t₁ t₂ | right (s₁ , snd₁) = {!!}

-- --   {-
-- --     s ◃ swap ◃ t₁ = s ◃ t₂
-- --     swap ∙ swap = ε
-- --     want: x , y s.t. x ◃ t₁ = x ◃ t₂
-- --     easy: x = s ∙ swap, y = s

-- --     harder:
-- --     s₁ ◃ t₁ = s₂ ◃ t₂
-- --     want: x s.t. x ◃ t₁ = x ◃ t₂
-- --   -}

-- -- -- record Isomorphic {a} {A : Set a} {ℓᵃ} {_=ᵃ_ : A → A → Set ℓᵃ} (isEquivalenceᵃ : IsEquivalence _=ᵃ_)  {b} {B : Set b} {ℓᵇ} {_=ᵇ_ : B → B → Set ℓᵇ} (isEquivalenceᵇ : IsEquivalence _=ᵇ_) : Set (a ⊔ ℓᵃ ⊔ b ⊔ ℓᵇ) where
-- -- --   field
-- -- --     toA : B → A
-- -- --     toB : A → B
-- -- --     rtA : (x : A) → toA (toB x) =ᵃ x
-- -- --     rtB : (x : B) → toB (toA x) =ᵇ x
-- -- --     isoA : (x₁ x₂ : A) → x₁ =ᵃ x₂ → toB x₁ =ᵇ toB x₂
-- -- --     isoB : (x₁ x₂ : B) → x₁ =ᵇ x₂ → toA x₁ =ᵃ toA x₂

-- -- -- record Splittable ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
-- -- --   field
-- -- --     mostGeneralUnificationoid : MostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- -- --   open MostGeneralUnificationoid mostGeneralUnificationoid public

-- -- --   S-independent : (t₁ t₂ : T) → Set (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)
-- -- --   S-independent t₁ t₂ = ∀ t₁s s → s ◃ t₁ =ᵗ t₁s → MostGenerally (λ s → s ◃ t₁ =ᵗ t₁s) s → s ◃ t₂ =ᵗ t₂

-- -- --   S-Invertable : Property
-- -- --   S-Invertable s = s ∙ s =ˢ ε

-- -- --   Swapifies : (t₁ t₂ : T) → Property
-- -- --   Swapifies t₁ t₂ s = s ◃ t₁ =ᵗ t₂ × s ◃ t₂ =ᵗ t₁

-- -- --   UnifiesOnLeft : (t₁ t₂ : T) → Property
-- -- --   UnifiesOnLeft t₁ t₂ s = s ◃ t₁ =ᵗ t₂

-- -- --   RelativeIdentity : T → Property
-- -- --   RelativeIdentity t s = s ◃ t =ᵗ t

-- -- --   field
-- -- --     make-S-independent :
-- -- --       (t₁ t₂ : T) →
-- -- --         ∃ λ swap₁ → S-Invertable swap₁ ×
-- -- --                     ∃ λ t₁′ → MostGenerally (Swapifies t₁ t₁′) swap₁ ×
-- -- --                               ∃ λ s₁ → MostGenerally (UnifiesOnLeft t₁ t₁′) s₁ ×
-- -- --                                        RelativeIdentity t₂ s₁

-- -- --     Tᵢ : Prelude.List Prelude.Nat → Set
-- -- --     toTᵢ : T → ∃ Tᵢ

-- -- --   pairUnification : PairMostGeneralUnificationoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ
-- -- --   PairMostGeneralUnificationoid.monoidTransformer pairUnification = monoidTransformer
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ with make-S-independent t₁ t₂
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ | (swap₁ , swap₁∙swap₁=ε , t₁′ , ((swap₁◃t₁=t₁′ , swap₁◃t₁′=t₁) , mgswap) , slip₁ , (slip₁◃t₁=t₁′ , mgleft) , slip₁◃t₂=t₂) with mgu t₁′ t₂
-- -- -- --  … | (left NoT₁T₂) =
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ | (swap₁ , swap₁∙swap₁=ε , t₁′ , ((swap₁◃t₁=t₁′ , swap₁◃t₁′=t₁) , mgswap) , slip₁ , (slip₁◃t₁=t₁′ , mgleft) , slip₁◃t₂=t₂) | (left NoT₁T₂) =
-- -- --     left
-- -- --     λ {(s₁ , s₂) s₁◃t₁=s₂◃t₂ →
-- -- --     {!let (s₁′ , s₂′ , s₁′◃t₁=s₂′◃t₂ , s₁′∙swap₁◃t₂=swap₁◃t₂ , s₂′∙swap₁∙s₂′◃t₂=swap₁∙s₂′◃t₂) = helper!}}
-- -- --     {-
-- -- --     NoT₁T₂ (slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁)
-- -- --       (let t₁′▹s₂=t₁′ : {!!} -- s₂ ◃ t₁′ =ᵗ t₁′
-- -- --            t₁′▹s₂=t₁′ = {!!} in {!!})}
-- -- --     -}
-- -- --          -- ? s₂ (s₁ ◃ t₁) (symˢ t₁▹s₁=t₂▹s₂ , (λ s₁₋ t₂▹s₁₋=t₁▹s₁ → {!!} , {!!})) in {!!})}) -- mgur s₂ (t₁ ▹ s₁) (symˢ t₁▹s₁=t₂▹s₂ , ?)
-- -- --   PairMostGeneralUnificationoid.mgu pairUnification t₁ t₂ | (swap₁ , swap₁∙swap₁=ε , t₁′ , ((swap₁◃t₁=t₁′ , swap₁◃t₁′=t₁) , mgswap) , slip₁ , (slip₁◃t₁=t₁′ , mgleft) , slip₁◃t₂=t₂) | (right (s , s◃t₁′=s◃t₂ , mgur)) = right $ (s ∙ slip₁ , s) , {!!} , (λ {(s₁′ , s₂′) s₁′◃t₁=s₂′◃t₂ → {!!}})

-- -- --   {-
-- -- --   goal
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ◃ t₁′        =ᵗ slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ◃ t₂
-- -- --   by slip₁◃t₁=t₁′
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ∙ slip₁ ◃ t₁ =ᵗ slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁ ◃ t₂
-- -- --   conjecture: swap₁ ∙ slip₁ ◃ t₁ = t₁
-- -- --   conjecture: s₁ ∙ swap₁ ◃ t₂ = swap₁ ◃ t₂
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ◃ t₁ =ᵗ slip₁ ∙ s₂ ∙ swap₁ ∙ swap₁ ◃ t₂
-- -- --   by swap₁∙swap₁=ε
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ◃ t₁ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   by s₁◃t₁=s₂◃t₂
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   conjecture: s₂ ∙ swap₁ ∙ s₂ ◃ t₂ = swap₁ ∙ s₂ ◃ t₂
-- -- --   slip₁ ∙ swap₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   conjecture: swap₁ ∙ s₂ ◃ t₂ = slip₁ ∙ s₂ ◃ t₂
-- -- --   slip₁ ∙ slip₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂
-- -- --   conjecture: slip₁ ∙ slip₁ = slip₁
-- -- --   slip₁ ∙ s₂ ◃ t₂ =ᵗ slip₁ ∙ s₂ ◃ t₂

-- -- --   goal : ?0 ◃ t₁′ = ?0 ◃ t₂

-- -- --   e.g.
-- -- --   f(x,g(y),z) = f(g(y),x,h(z))
-- -- --   s₁ = x → g(y) , z → h(z) ; s₂ = x → g(y)
-- -- --   s = x → a ; y → b ; z → c
-- -- --   t₁′ = f(a,g(b),c)
-- -- --   S = a → g(y) , x → g(b) , c → h(z)
-- -- --   s⁻¹ = a → x , b → y , c → z
-- -- --   s₁ ∙ s⁻¹ = a → g(y) , b → y , c → h(z)
-- -- --   s₂ ∙ s₁ ∙ s⁻¹ = a → g(y) , b → y , c → h(z) , x → g(y)
-- -- --   S = s ∙ s₂ ∙ s₁ ∙ s⁻¹ = a → g(b) , b → b , c → h(c) , x → g(b) , y → b , z → c
-- -- --   t₁′ ▹ S = f(g(b),g(b),h(c))
-- -- --   t₂ ▹ S = f(g(b),g(b),h(c))

-- -- --   f(x,g(y),z) = f(g(y),x,h(z))
-- -- --   s₁ = x → g(x) , y → x , z → h(z) ; s₂ = y → x , x → g(x)
-- -- --   s = x → a ; y → b ; z → c
-- -- --   t₁′ = f(a,g(b),c)
-- -- --   s⁻¹ = a → x , b → y , c → z
-- -- --   s₁ ∙ s⁻¹ = a → g(x) , b → x , c → h(z) , x → g(x) , y → x , z → h(z)
-- -- --   s₂ ∙ s₁ ∙ s⁻¹ = a → g(g(x)) , b → g(x) , c → h(z) , x → g(g(x)) , y → g(x) , z → h(z)
-- -- --   s ∙ s₂ ∙ s₁ ∙ s⁻¹ = a → g(g(a)) , b → g(a) , c → h(c) , x → g(g(a)) , y → g(a) , z → h(c)

-- -- --   s⁻¹          = a → x    , b → y , c → z
-- -- --   s₁ ∙ s⁻¹     = a → g(x) , b → x , c → h(z) , x → g(x) , y → x , z → h(z)
-- -- --   s ∙ s₁ ∙ s⁻¹ = a → g(a) , b → a , c → h(c) , x → g(a) , y → a , z → h(c)

-- -- --   s₁′          = a → g(a) , b → a , c → h(c)
-- -- --   s₂′          = y → a , x → g(a) , z → c

-- -- --   let swap₁ = x → a , y → b , z → c , a → x , b → y , c → z -- take variables common to t₁ and t₂, and swap them for variables outside of either (and outside of s₁ or s₂?)
-- -- --         s₁ ∙ swap₁ = x → a , y → b , z → c , a → g(x) , b → x , c → h(z)
-- -- --   s₁′ = swap₁ ∙ s₁ ∙ swap₁ = a → g(a) , b → a , c → h(c)
-- -- --   s₁′ = swap₁ ∙ s₁ ∙ swap₁
-- -- --   let slip₁ = x → a , y → b , z → c
-- -- --   let s₂′ = slip₁ ∙ s₂ = y → a , x → g(a) , z → c
-- -- --   s₂′ ∙ s₁′ = a → g(a) , b → a , c → h(c) , y → a , x → g(a) , z → c
-- -- --   slip₁ ∙ s₂ ∙ swap₁ ∙ s₁ ∙ swap₁

-- -- --   f(g(g(a)),g(g(a)),h(c)) = f(g(g(a)),g(g(a)),h(h(c)))

-- -- --   f(x,g(y),z) = f(g(y),x,h(z))
-- -- --   -}
-- -- --   {-
-- -- --   … | (t₁' , s-independent , s , t₁'= , s⁻¹ , t₁=) with mgu t₁' t₂
-- -- --   … | (left NoT₁T₂) = left $ λ {(s₁ , s₂) t₁▹s₁=t₂▹s₂ → NoT₁T₂ {!≈ˢ-over-▹-⟶-≈ᵐ!} {!isMonoidTransformer!}}
-- -- --   … | (right x) = right {!!}
-- -- --   -}

-- -- -- {-
-- -- --   suppose t₁ ▹ s₁ = t₂ ▹ s₂
-- -- --   given:
-- -- --     t₁' ▹ * ≠ t₂ ▹ *

-- -- --   t₁ = t₁' ▹ s
-- -- --   try s = the most general such

-- -- --   t₁ = t₁' ▹ s⁻¹
-- -- --   t₁' = t₁ ▹ s
-- -- --   t₁ ▹ s₁ = t₂ ▹ s₂
-- -- --   s ∙ s⁻¹ = ε

-- -- --   t₁' ▹ s⁻¹ ▹ s₁ = t₂ ▹ s₂

-- -- --   finx x = s₁

-- -- --   t₁ ▹ x = t₂ ▹ s⁻¹ ▹ x
-- -- --   t₁' ▹ x = t₂ ▹ x
-- -- --   t₁ ▹ s ▹ x = t₂ ▹ x
-- -- --   t₁ ▹ s ▹ x = t₂ ▹ s⁻¹ ▹ s ▹ x
-- -- -- -}

-- -- -- data STerm (A : Set) : Set where
-- -- --   ι : A → STerm A
-- -- --   _fork_ : STerm A → STerm A → STerm A
-- -- --   leaf : STerm A

-- -- -- sub : {V : Set} → (V → Maybe (STerm V)) → STerm V → STerm V
-- -- -- sub σ (ι x) with σ x
-- -- -- sub σ (ι x) | nothing = ι x
-- -- -- sub σ (ι x) | just x₁ = x₁
-- -- -- sub σ (t fork t₁) = sub σ t fork sub σ t₁
-- -- -- sub σ leaf = leaf

-- -- -- {-
-- -- --   Sᵢ : List (V × T) → S
-- -- --   Tᵢ : List V → T
-- -- --   indexS : S → ∃ Sᵢ
-- -- --   indexT : T → ∃ Tᵢ
-- -- --   _▹ᵢ_ : {vs : List V} {vts : List (V × T)} → Tᵢ vs → Sᵢ vts → ∃ λ
-- -- --   (t : T) (s : S) → t ▹ s
-- -- --   (V → T) → T → T

-- -- --   getTermIndexedByAVariable : (v : V) (t : T) → T → T
-- -- --   getTermFromIndexedTerm :

-- -- --   v ∈ variables s → t ▹ s
-- -- -- -}

-- -- -- record IsSeparableInto {sx s x} (SX : Set sx) (S : Set s) (X : Set x) : Set (s ⊔ x ⊔ sx) where
-- -- --   field
-- -- --     separate : SX → S × X
-- -- --     combine : S × X → SX
-- -- --     iso : ∀ sx → combine (separate sx) ≡ sx

-- -- -- record IsSeparableInto₂ {sx s x} (SX : Set sx) (X : Set x) (S : X → Set s) : Set (s ⊔ x ⊔ sx) where
-- -- --   field
-- -- --     separate : SX → Σ X S
-- -- --     combine : Σ X S → SX
-- -- --     iso : ∀ sx → combine (separate sx) ≡ sx

-- -- -- record Separableoid sx s x : Set (lsuc (sx ⊔ s ⊔ x)) where
-- -- --   field
-- -- --     SX : Set sx
-- -- --     S : Set s
-- -- --     X : Set x
-- -- --     separable : IsSeparableInto SX S X

-- -- -- -- record FreeVariableoid ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ ℓᵛ ℓ : Set (lsuc (ℓᵗ ⊔ ℓ⁼ᵗ ⊔ ℓˢ ⊔ ℓ⁼ˢ)) where
-- -- -- --   field
-- -- -- --     monoidTransformer : MonoidTransformer ℓᵗ ℓ⁼ᵗ ℓˢ ℓ⁼ˢ

-- -- -- --   open MonoidTransformer monoidTransformer public renaming
-- -- -- --     (_≈ˢ_ to _=ᵗ_
-- -- -- --     ;Carrierˢ to T
-- -- -- --     ;Carrierᵐ to S
-- -- -- --     ;_≈ᵐ_ to _=ˢ_)

-- -- -- --   field
-- -- -- --     termVariableoid : Setoid ℓᵛ ℓ⁼ᵛ
-- -- -- --     termStructureoid :

-- -- -- --   open Setoid Variable public using () renaming
-- -- -- --     (Carrier to V
-- -- -- --     ;_≈_ to _=ᵛ_)

-- -- -- --   field
-- -- -- --     termVariables : Term → Pred Variable ℓᵛ


------------------------------------------------------------------------
-- A semantics which uses continuation-passing style
------------------------------------------------------------------------

module TotalParserCombinators.Semantics.Continuation where

open import Algebra
open import Codata.Musical.Notation
open import Data.List
import Data.List.Properties as ListProp
open import Data.List.Relation.Binary.BagAndSetEquality
  using (bag) renaming (_∼[_]_ to _List-∼[_]_)
open import Data.Maybe using (Maybe)
open import Data.Product as Prod
open import Function
open import Relation.Binary.PropositionalEquality as P using (_≡_)

private
  module LM {Tok : Set} = Monoid (ListProp.++-monoid Tok)

open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics as S
  hiding ([_-_]_⊛_; [_-_]_>>=_)

-- The statement x ⊕ s₂ ∈ p · s means that there is some s₁ such that
-- s ≡ s₁ ++ s₂ and x ∈ p · s₁. This variant of the semantics is
-- perhaps harder to understand, but sometimes easier to work with
-- (and it is proved to be language equivalent to the semantics in
-- TotalParserCombinators.Semantics).

infix  60 <$>_
infixl 50 [_-_]_⊛_
infixl 10 [_-_]_>>=_
infix   4 _⊕_∈_·_

data _⊕_∈_·_ {Tok} : ∀ {R xs} → R → List Tok →
                     Parser Tok R xs → List Tok → Set₁ where
  return     : ∀ {R} {x : R} {s} → x ⊕ s ∈ return x · s
  token      : ∀ {x s} → x ⊕ s ∈ token · x ∷ s
  ∣-left     : ∀ {R x xs₁ xs₂ s s₁}
                 {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂}
               (x∈p₁ : x ⊕ s₁ ∈ p₁ · s) → x ⊕ s₁ ∈ p₁ ∣ p₂ · s
  ∣-right    : ∀ {R x xs₂ s s₁} xs₁
                 {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂}
               (x∈p₂ : x ⊕ s₁ ∈ p₂ · s) → x ⊕ s₁ ∈ p₁ ∣ p₂ · s
  <$>_       : ∀ {R₁ R₂ x s s₁ xs} {p : Parser Tok R₁ xs} {f : R₁ → R₂}
               (x∈p : x ⊕ s₁ ∈ p · s) → f x ⊕ s₁ ∈ f <$> p · s
  [_-_]_⊛_   : ∀ {R₁ R₂ f x s s₁ s₂} xs fs
                 {p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs)}
                 {p₂ : ∞⟨ fs ⟩Parser Tok  R₁       (flatten xs)} →
               (f∈p₁ : f ⊕ s₁ ∈ ♭? p₁ · s)
               (x∈p₂ : x ⊕ s₂ ∈ ♭? p₂ · s₁) →
               f x ⊕ s₂ ∈ p₁ ⊛ p₂ · s
  [_-_]_>>=_ : ∀ {R₁ R₂ x y s s₁ s₂} (f : Maybe (R₁ → List R₂)) xs
                 {p₁ : ∞⟨ f ⟩Parser Tok R₁ (flatten xs)}
                 {p₂ : (x : R₁) → ∞⟨ xs ⟩Parser Tok R₂ (apply f x)} →
               (x∈p₁ : x ⊕ s₁ ∈ ♭? p₁ · s)
               (y∈p₂x : y ⊕ s₂ ∈ ♭? (p₂ x) · s₁) →
               y ⊕ s₂ ∈ p₁ >>= p₂ · s
  nonempty   : ∀ {R xs x y s₂} s₁ {p : Parser Tok R xs}
               (x∈p : y ⊕ s₂ ∈ p · x ∷ s₁ ++ s₂) →
               y ⊕ s₂ ∈ nonempty p · x ∷ s₁ ++ s₂
  cast       : ∀ {R xs₁ xs₂ x s₁ s₂} {xs₁≈xs₂ : xs₁ List-∼[ bag ] xs₂}
                 {p : Parser Tok R xs₁}
               (x∈p : x ⊕ s₂ ∈ p · s₁) → x ⊕ s₂ ∈ cast xs₁≈xs₂ p · s₁

-- A simple cast lemma.

private

  cast∈′ : ∀ {Tok R xs} {p : Parser Tok R xs} {x s s′ s₁} →
           s ≡ s′ → x ⊕ s₁ ∈ p · s → x ⊕ s₁ ∈ p · s′
  cast∈′ P.refl x∈ = x∈

-- The definition is sound and complete with respect to the one in
-- TotalParserCombinators.Semantics.

sound′ : ∀ {Tok R xs x s₂ s} {p : Parser Tok R xs} →
         x ⊕ s₂ ∈ p · s → ∃ λ s₁ → s ≡ s₁ ++ s₂ × x ∈ p · s₁
sound′ return                      = ([]    , P.refl , return)
sound′ {x = x} token               = ([ x ] , P.refl , token)
sound′ (∣-left x∈p₁)               = Prod.map id (Prod.map id ∣-left)       (sound′ x∈p₁)
sound′ (∣-right e₁ x∈p₁)           = Prod.map id (Prod.map id (∣-right e₁)) (sound′ x∈p₁)
sound′ (<$> x∈p)                   = Prod.map id (Prod.map id (<$>_))       (sound′ x∈p)
sound′ ([ xs - fs ] f∈p₁ ⊛ x∈p₂)   with sound′ f∈p₁ | sound′ x∈p₂
sound′ ([ xs - fs ] f∈p₁ ⊛ x∈p₂)   | (s₁ , P.refl , f∈p₁′) | (s₂ , P.refl , x∈p₂′) =
                                     (s₁ ++ s₂ , P.sym (LM.assoc s₁ s₂ _) ,
                                      S.[_-_]_⊛_ xs fs f∈p₁′ x∈p₂′)
sound′ (nonempty s₁ x∈p)           with sound′ x∈p
sound′ (nonempty s₁ x∈p)           | (y ∷ s , eq , x∈p′) = (y ∷ s , eq , nonempty x∈p′)
sound′ (nonempty s₁ x∈p)           | ([]    , eq , x∈p′)
                                     with ListProp.++-identityˡ-unique (_ ∷ s₁) (P.sym eq)
sound′ (nonempty s₁ x∈p)           | ([]    , eq , x∈p′) | ()
sound′ (cast x∈p)                  = Prod.map id (Prod.map id cast) (sound′ x∈p)
sound′ ([ f - xs ] x∈p₁ >>= y∈p₂x) with sound′ x∈p₁ | sound′ y∈p₂x
sound′ ([ f - xs ] x∈p₁ >>= y∈p₂x) | (s₁ , P.refl , x∈p₁′) | (s₂ , P.refl , y∈p₂x′) =
  (s₁ ++ s₂ , P.sym (LM.assoc s₁ s₂ _) , S.[_-_]_>>=_ f xs x∈p₁′ y∈p₂x′)

sound : ∀ {Tok R xs x s} {p : Parser Tok R xs} →
        x ⊕ [] ∈ p · s → x ∈ p · s
sound x∈p with sound′ x∈p
sound x∈p | (s , P.refl , x∈p′) with s ++ [] | Prod.proj₂ LM.identity s
sound x∈p | (s , P.refl , x∈p′) | .s | P.refl = x∈p′

extend : ∀ {Tok R xs x s s′ s″} {p : Parser Tok R xs} →
         x ⊕ s′ ∈ p · s → x ⊕ s′ ++ s″ ∈ p · s ++ s″
extend return                       = return
extend token                        = token
extend (∣-left x∈p₁)                = ∣-left     (extend x∈p₁)
extend (∣-right e₁ x∈p₂)            = ∣-right e₁ (extend x∈p₂)
extend (<$> x∈p)                    = <$> extend x∈p
extend ([ xs - fs ] f∈p₁ ⊛   x∈p₂)  = [ xs - fs ] extend f∈p₁ ⊛   extend x∈p₂
extend ([ f  - xs ] x∈p₁ >>= y∈p₂x) = [ f  - xs ] extend x∈p₁ >>= extend y∈p₂x
extend (cast x∈p)                   = cast (extend x∈p)
extend (nonempty s₁ x∈p)            = cast₂ (nonempty s₁ (cast₁ (extend x∈p)))
  where
  lem   = LM.assoc (_ ∷ s₁) _ _
  cast₁ = cast∈′        lem
  cast₂ = cast∈′ (P.sym lem)

complete : ∀ {Tok R xs x s} {p : Parser Tok R xs} →
           x ∈ p · s → x ⊕ [] ∈ p · s
complete return                                 = return
complete token                                  = token
complete (∣-left x∈p₁)                          = ∣-left     (complete x∈p₁)
complete (∣-right e₁ x∈p₂)                      = ∣-right e₁ (complete x∈p₂)
complete (<$> x∈p)                              = <$> complete x∈p
complete (_⊛_   {fs = fs} {xs = xs} f∈p₁ x∈p₂)  = [ xs - fs ] extend (complete f∈p₁) ⊛   complete x∈p₂
complete (_>>=_ {xs = xs} {f  = f}  x∈p₁ y∈p₂x) = [ f  - xs ] extend (complete x∈p₁) >>= complete y∈p₂x
complete (cast x∈p)                             = cast (complete x∈p)
complete (nonempty {s = s} x∈p)                 = cast₂ (nonempty s (cast₁ (complete x∈p)))
  where
  lem   = Prod.proj₂ LM.identity _
  cast₁ = cast∈′ (P.sym lem)
  cast₂ = cast∈′        lem

complete′ : ∀ {Tok R xs x s₂ s} {p : Parser Tok R xs} →
            (∃ λ s₁ → s ≡ s₁ ++ s₂ × x ∈ p · s₁) →
            x ⊕ s₂ ∈ p · s
complete′ (s₁ , P.refl , x∈p) = extend (complete x∈p)


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Reduction {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.Typed.Weakening
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Reflexivity
open import Definition.LogicalRelation.Properties.Transitivity
open import Definition.LogicalRelation.Properties.Symmetry
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Conversion

open import Tools.Product
open import Tools.Empty
import Tools.PropositionalEquality as PE

import Data.Fin as Fin
import Data.Nat as Nat

-- Weak head expansion of reducible types.
redSubst* : ∀ {A B r l Γ}
          → Γ ⊢ A ⇒* B ^ r
          → Γ ⊩⟨ l ⟩ B ^ r
          → ∃ λ ([A] : Γ ⊩⟨ l ⟩ A ^ r)
          → Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A]
redSubst* {A = A} D (Uᵣ′ B .(next l′) rU l′ l< PE.refl [[ ⊢A , ⊢B , D' ]]) =
  let ⊢A = redFirst* D
  in  Uᵣ′ A (next l′) rU l′ l< PE.refl [[ ⊢A , ⊢B , D ⇨* D' ]] , D'
redSubst* D (ℕᵣ [[ ⊢B , ⊢ℕ , D′ ]]) =
  let ⊢A = redFirst* D
  in  ℕᵣ ([[ ⊢A , ⊢ℕ , D ⇨* D′ ]]) , D′
redSubst* D (Emptyᵣ [[ ⊢B , ⊢Empty , D′ ]]) =
  let ⊢A = redFirst* D
  in  Emptyᵣ ([[ ⊢A , ⊢Empty , D ⇨* D′ ]]) , D′
redSubst* D (ne′ K [[ ⊢B , ⊢K , D′ ]] neK K≡K) =
  let ⊢A = redFirst* D
  in  (ne′ K [[ ⊢A , ⊢K , D ⇨* D′ ]] neK K≡K)
  ,   (ne₌ _ [[ ⊢B , ⊢K , D′ ]] neK K≡K)
redSubst* D (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢B , ⊢ΠFG , D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext) =
  let ⊢A = redFirst* D
  in  (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢ΠFG , D ⇨* D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext)
  ,   (Π₌ _ _ D′ A≡A (λ ρ ⊢Δ → reflEq ([F] ρ ⊢Δ))
        (λ ρ ⊢Δ [a] → reflEq ([G] ρ ⊢Δ [a])))
redSubst* D (∃ᵣ′ F G [[ ⊢B , ⊢ΠFG , D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext) =
  let ⊢A = redFirst* D
  in  (∃ᵣ′ F G [[ ⊢A , ⊢ΠFG , D ⇨* D′ ]] ⊢F ⊢G A≡A [F] [G] G-ext)
  ,   (∃₌ _ _ D′ A≡A (λ ρ ⊢Δ → reflEq ([F] ρ ⊢Δ))
        (λ ρ ⊢Δ [a] → reflEq ([G] ρ ⊢Δ [a])))
redSubst* {l = ι ¹} D (emb l< X) with redSubst* D X
redSubst* {l = ι ¹} D (emb l< X) | y , y₁ = emb l< y , y₁
redSubst* {l = ∞} D (emb l< X) with redSubst* D X
redSubst* {l = ∞} D (emb ∞< X) | y , y₁ = emb {l′ = ι ¹} ∞< y , y₁

redSubst*Term⁰ : ∀ {A t u ll Γ} → let l = ι ⁰ in
                Γ ⊢ t ⇒* u ∷ A ^ ll
              → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
              → Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ll ] / [A]
              → Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ll ] / [A]
              × Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubst*Term⁰ t⇒u (ℕᵣ D) (ℕₜ n [[ ⊢u , ⊢n , d ]] n≡n prop) =
  let A≡ℕ  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡ℕ
      t⇒u′ = conv* t⇒u A≡ℕ
  in  ℕₜ n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] n≡n prop
  ,   ℕₜ₌ n n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] [[ ⊢u , ⊢n , d ]]
          n≡n (reflNatural-prop prop)
redSubst*Term⁰ t⇒u (ne′ K D neK K≡K) (neₜ k [[ ⊢t , ⊢u , d ]] (neNfₜ neK₁ ⊢k k≡k)) =
  let A≡K  = subset* (red D)
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡K , ⊢u , conv* t⇒u A≡K ⇨∷* d ]]
  in  neₜ k [d′] (neNfₜ neK₁ ⊢k k≡k) , neₜ₌ k k [d′] [d] (neNfₜ₌ neK₁ neK₁ k≡k)
redSubst*Term⁰ {A} {t} {u} {l} {Γ} t⇒u (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                  (Πₜ f [[ ⊢t , ⊢u , d ]] funcF f≡f [f] [f]₁) =
  let A≡ΠFG = subset* (red D)
      t⇒u′  = conv* t⇒u A≡ΠFG
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡ΠFG , ⊢u , conv* t⇒u A≡ΠFG ⇨∷* d ]]
  in  Πₜ f [d′] funcF f≡f [f] [f]₁
  ,   Πₜ₌ f f [d′] [d] funcF funcF f≡f
          (Πₜ f [d′] funcF f≡f [f] [f]₁)
          (Πₜ f [d] funcF f≡f [f] [f]₁)
          (λ [ρ] ⊢Δ [a] → reflEqTerm ([G] [ρ] ⊢Δ [a]) ([f]₁ [ρ] ⊢Δ [a]))

-- Weak head expansion of reducible terms.
redSubst*Term : ∀ {A t u l ll Γ}
              → Γ ⊢ t ⇒* u ∷ A ^ ll
              → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
              → Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ll ] / [A]
              → Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ll ] / [A]
              × Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubst*Term {t = t} {l = ι ¹} {Γ = Γ} t⇒u (Uᵣ′ A .(next ⁰) rU ⁰ l< PE.refl D) (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) =
  let
    A≡U  = subset* (red D)
    ⊢t   = conv (redFirst*Term t⇒u) A≡U
    t⇒u′ = conv* t⇒u A≡U
    [t] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₁ (redSubst* {l = ι ⁰} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [t≡u] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₂ (redSubst* {l = ι ⁰} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [[t]] = Uₜ K [[ ⊢t , ⊢K , t⇒u′ ⇨∷* d ]] typeA A≡A [t]
  in
  ([[t]] , Uₜ₌ [[t]] (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) A≡A [t≡u])
redSubst*Term {t = t} {l = ∞} {Γ = Γ} t⇒u (Uᵣ′ A .(next ¹) rU ¹ l< PE.refl D) (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) =
  let
    A≡U  = subset* (red D)
    ⊢t   = conv (redFirst*Term t⇒u) A≡U
    t⇒u′ = conv* t⇒u A≡U
    [t] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₁ (redSubst* {l = ι ¹} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [t≡u] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ → proj₂ (redSubst* {l = ι ¹} (wkRed* [ρ] ⊢Δ (univ* t⇒u′)) ([u] [ρ] ⊢Δ))
    [[t]] = Uₜ K [[ ⊢t , ⊢K , t⇒u′ ⇨∷* d ]] typeA A≡A [t]
  in
  ([[t]] , Uₜ₌ [[t]] (Uₜ K [[ ⊢u , ⊢K , d ]] typeA A≡A [u]) A≡A [t≡u])
redSubst*Term t⇒u (ℕᵣ D) (ℕₜ n [[ ⊢u , ⊢n , d ]] n≡n prop) =
  let A≡ℕ  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡ℕ
      t⇒u′ = conv* t⇒u A≡ℕ
  in  ℕₜ n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] n≡n prop
  ,   ℕₜ₌ n n [[ ⊢t , ⊢n , t⇒u′ ⇨∷* d ]] [[ ⊢u , ⊢n , d ]]
          n≡n (reflNatural-prop prop)
redSubst*Term t⇒u (ne′ K D neK K≡K) (neₜ k [[ ⊢t , ⊢u , d ]] (neNfₜ neK₁ ⊢k k≡k)) =
  let A≡K  = subset* (red D)
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡K , ⊢u , conv* t⇒u A≡K ⇨∷* d ]]
  in  neₜ k [d′] (neNfₜ neK₁ ⊢k k≡k) , neₜ₌ k k [d′] [d] (neNfₜ₌ neK₁ neK₁ k≡k)
redSubst*Term {A} {t} {u} {l} {Γ} t⇒u (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                  (Πₜ f [[ ⊢t , ⊢u , d ]] funcF f≡f [f] [f]₁) =
  let A≡ΠFG = subset* (red D)
      t⇒u′  = conv* t⇒u A≡ΠFG
      [d]  = [[ ⊢t , ⊢u , d ]]
      [d′] = [[ conv (redFirst*Term t⇒u) A≡ΠFG , ⊢u , conv* t⇒u A≡ΠFG ⇨∷* d ]]
  in  Πₜ f [d′] funcF f≡f [f] [f]₁
  ,   Πₜ₌ f f [d′] [d] funcF funcF f≡f
          (Πₜ f [d′] funcF f≡f [f] [f]₁)
          (Πₜ f [d] funcF f≡f [f] [f]₁)
          (λ [ρ] ⊢Δ [a] → reflEqTerm ([G] [ρ] ⊢Δ [a]) ([f]₁ [ρ] ⊢Δ [a]))
redSubst*Term {l = ι ¹} D (emb l< X) [u] = redSubst*Term D X [u]
redSubst*Term {l = ∞} D (emb l< X) [u] = redSubst*Term D X [u]

-- Weak head expansion of reducible types with single reduction step.
redSubst : ∀ {A B r l Γ}
         → Γ ⊢ A ⇒ B ^ r
         → Γ ⊩⟨ l ⟩ B ^ r
         → ∃ λ ([A] : Γ ⊩⟨ l ⟩ A ^ r)
         → Γ ⊩⟨ l ⟩ A ≡ B ^ r / [A]
redSubst A⇒B [B] = redSubst* (A⇒B ⇨ id (escape [B])) [B]

-- Weak head expansion of reducible terms with single reduction step.
redSubstTerm : ∀ {A t u l ll Γ}
             → Γ ⊢ t ⇒ u ∷ A ^ ll
             → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
             → Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ll ] / [A]
             → Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ll ] / [A]
             × Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubstTerm t⇒u [A] [u] = redSubst*Term (t⇒u ⇨ id (escapeTerm [A] [u])) [A] [u]

-- Equalities
redSubst*EqTerm : ∀ {A B t t′ u u′ l ll Γ}
                → Γ ⊢ t ⇒* t′ ∷ A ^ ll
                → Γ ⊢ u ⇒* u′ ∷ B ^ ll
                → ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
                → ([B] : Γ ⊩⟨ l ⟩ B ^ [ ! , ll ])
                → Γ ⊩⟨ l ⟩ A ≡ B ^ [ ! , ll ] / [A]
                → Γ ⊩⟨ l ⟩ t′ ∷ A ^ [ ! , ll ] / [A]
                → Γ ⊩⟨ l ⟩ u′ ∷ B ^ [ ! , ll ] / [B]
                → Γ ⊩⟨ l ⟩ t′ ≡ u′ ∷ A ^ [ ! , ll ] / [A]
                → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
redSubst*EqTerm D D′ [A] [B] [A≡B] [t′] [u′] [t′≡u′] =
  let
    [t≡t′] = proj₂ (redSubst*Term D [A] [t′])
    [u≡u′:B] = proj₂ (redSubst*Term D′ [B] [u′])
    [u≡u′] = convEqTerm₂ [A] [B] [A≡B] [u≡u′:B]
  in transEqTerm [A] [t≡t′] (transEqTerm [A] [t′≡u′] (symEqTerm [A] [u≡u′]))


open import Prelude

module Implicits.Oliveira.Deterministic.Decidable where

open import Data.Fin.Substitution
open import Implicits.Oliveira.Types
open import Implicits.Oliveira.Terms
open import Implicits.Oliveira.Contexts
open import Implicits.Oliveira.Substitutions
open import Implicits.Oliveira.Substitutions.Lemmas
open import Implicits.Oliveira.Deterministic.Resolution
open import Implicits.Oliveira.Types.Unification
open import Data.Star hiding (map)

MICtx : ℕ → ℕ → Set
MICtx m ν = List (MetaType m ν)

private
  module M = MetaTypeMetaSubst
  module T = MetaTypeTypeSubst

{-
{-# NO_TERMINATION_CHECK #-}
_,_amatch_ : ∀ {m ν} → (MetaType m ν) → (ρs : MICtx m ν) → (τ : SimpleType ν) → Maybe (ICtx ν)
(a ⇒ b) , ρs amatch τ = b , a List.∷ ρs amatch τ
∀' x , ρs amatch τ = open-meta x , (List.map meta-weaken ρs) amatch τ
(simpl x) , ρs amatch τ with mgu (simpl x) τ
(simpl x) , ρs amatch τ | just (u , proj₂) =
  just $ List.map (λ r → from-meta $ substitute (asub u) r) ρs
(simpl x) , ρs amatch τ | nothing = nothing

_match_ : ∀ {ν} → (Type ν) → (SimpleType ν) → Maybe (ICtx ν)
r match a = (to-meta {zero} r) , List.[] amatch a

{-# NO_TERMINATION_CHECK #-}
lem-a6 : ∀ {m ν} {ρs ρs'} (a : MetaType m ν) (τ : SimpleType ν) → a , ρs amatch τ ≡ just ρs' →
  (∃ λ (u : AList ν m zero) → (from-meta $ substitute (asub u) a) ◁ τ)
lem-a6 {ρs = ρs} (a ⇒ b) τ m
  with _,_amatch_ b (a List.∷ ρs) τ | inspect (_,_amatch_ b (a List.∷ ρs)) τ
lem-a6 (a ⇒ b) τ refl | ._ | reveal[ eq ] with lem-a6 b τ eq
lem-a6 (a ⇒ b) τ refl | ._ | reveal[ eq ] | u , b/u◁τ = u , (m-iabs b/u◁τ)
lem-a6 {ρs = ρs} (∀' a) τ m
  with open-meta a , (List.map meta-weaken ρs) amatch τ | inspect (_,_amatch_ (open-meta a) (List.map meta-weaken ρs)) τ
lem-a6 (∀' a) τ refl | ._ | reveal[ eq ] with lem-a6 (open-meta a) τ eq
lem-a6 (∀' a) τ refl | ._ | reveal[ eq ] | (t' // x ◅ u , b/u◁τ) = {!!} -- {!u!} , (m-tabs {!!})
lem-a6 (simpl x) τ m with mgu (simpl x) τ | inspect (mgu (simpl x)) τ
lem-a6 (simpl x) τ refl | just (u , proj₂) | reveal[ eq ] =
  u , subst (λ u → u ◁ τ) (sym $ mgu-unifies (simpl x) τ {!!}) m-simp
lem-a6 (simpl x) τ () | nothing

_match1st_ : ∀ {ν} (Δ : ICtx ν) → (a : SimpleType ν) → Maybe (Type ν × ICtx ν)
List.[] match1st a = nothing
(x List.∷ Δ) match1st a with x match a
(x List.∷ Δ) match1st a | just z = just (x , z)
(x List.∷ Δ) match1st a | nothing = Δ match1st a

_⊢alg_ : ∀ {ν n} (K : Ktx ν n) → (a : Type ν) → Dec (K ⊢ᵣ a)
(Γ , Δ) ⊢alg simpl x with Δ match1st x
(Γ , Δ) ⊢alg simpl x | just (proj₁ , proj₂) = {!!}
(Γ , Δ) ⊢alg simpl x | nothing = {!!}
K ⊢alg (a ⇒ b) with (a ∷K K) ⊢alg b
K ⊢alg (a ⇒ b) | yes p = yes $ r-iabs a p
K ⊢alg (a ⇒ b) | no ¬p = no (λ{ (r-iabs .a x) → ¬p x })
K ⊢alg ∀' a with (ktx-weaken K) ⊢alg a
K ⊢alg ∀' a | yes p = yes (r-tabs p)
K ⊢alg ∀' a | no ¬p = no (λ{ (r-tabs p) → ¬p p })

-}
module relational where

  data _⊢_amatch_↠_ {m ν} : (ρs : MICtx m ν) → MetaType m ν → SimpleType ν → (ICtx ν) → Set where
    mtc-tabs : ∀ {r ρs ρs' a} → (List.map meta-weaken ρs) ⊢ (open-meta r) amatch a ↠ ρs' →
                ρs ⊢ ∀' r amatch a ↠ ρs'
    mtc-iabs : ∀ {ρs ρs' a b c} → (a List.∷ ρs) ⊢ b amatch c ↠ ρs' → ρs ⊢ a ⇒ b amatch c ↠ ρs'
    mtc-simp : ∀ {ρs a b} → (u : Unifiable (simpl a) b) →
               ρs ⊢ (simpl a) amatch b ↠ (List.map (λ r → from-meta $ r M./ (asub (proj₁ u))) ρs)

  _⊢match_↠_ : ∀ {ν} → (Type ν) → (SimpleType ν) → ICtx ν → Set
  r ⊢match a ↠ ρs = List.[] ⊢ (to-meta {zero} r) amatch a ↠ ρs

  data _⊢match1st_↠_ {ν} : List (Type ν) → (a : SimpleType ν) → ICtx ν → Set where
    m1-head : ∀ {rs ρs} {r : Type ν} {a} → r ⊢match a ↠ ρs → (r List.∷ rs) ⊢match1st a ↠ ρs
    m1-tail : ∀ {rs ρs} {r : Type ν} {a} → ¬ r ⊢match a ↠ ρs → rs ⊢match1st a ↠ ρs →
              (r List.∷ rs) ⊢match1st a ↠ ρs

  {-}
  gather : ∀ {ν} {ρs ρs' : ICtx ν} {a} → ρs ⊢match1st a ↠ ρs' → List (Type ν)
  gather (m1-head x) = gather' x
    where
        gather' : ∀ {m ν} {ρs : MICtx m ν} {r a} → ρs ⊢ r amatch a ↠→ List (Type ν)
        gather' (mtc-tabs x) = gather' x
        gather' (mtc-iabs x) = gather' x
        gather' {ρs = ρs} (mtc-simp {a = a} {b = b} u) =
                (List.map (λ r → from-meta $ substitute (asub (proj₁ u)) r) ρs)
  gather (m1-tail ¬x xs) = gather xs
  -}

  {-# NO_TERMINATION_CHECK #-}
  amatch : ∀ {m ν} → (ρs : MICtx m ν) → (r : MetaType m ν) (a : SimpleType ν) →
            Dec (∃ λ ρs' → ρs ⊢ r amatch a ↠ ρs')
  amatch ρs (simpl x) a with mgu (simpl x) a | inspect (mgu (simpl x)) a
  amatch ρs (simpl x) a | just mgu | _ = yes (, mtc-simp mgu)
  amatch ρs (simpl x) a | nothing | reveal[ eq ] =
    no (λ{ (._ , mtc-simp p) → (mgu-sound (simpl x) a eq) p})
  amatch ρs (b ⇒ c) a with amatch (b List.∷ ρs) c a
  amatch ρs (b ⇒ c) a | yes (_ , p) = yes $ , mtc-iabs p
  amatch ρs (b ⇒ c) a | no ¬p = no (λ{ (._ , mtc-iabs x) → ¬p (, x)})
  amatch ρs (∀' r) a with amatch (List.map meta-weaken ρs) (open-meta r) a
  amatch ρs (∀' r) a | yes (_ , p) = yes $ , mtc-tabs p
  amatch ρs (∀' r) a | no ¬p = no (λ{ (._ , mtc-tabs x) → ¬p (, x) })

  match : ∀ {ν} → (r : Type ν) → (a : SimpleType ν) → Dec (∃ λ ρs → r ⊢match a ↠ ρs)
  match r a = amatch List.[] (to-meta {zero} r) a

  _match1st_ : ∀ {ν} (Δ : ICtx ν) → (a : SimpleType ν) → Dec (∃ λ ρs → Δ ⊢match1st a ↠ ρs)
  List.[] match1st a = no (λ{ (_ , ()) })
  (x List.∷ xs) match1st a with match x a
  (x List.∷ xs) match1st a | yes (ρs , p) = yes (ρs , m1-head p)
  (x List.∷ xs) match1st a | no ¬p with xs match1st a
  (x List.∷ xs) match1st a | no ¬p | yes p = yes  ? -- (, m1-tail ¬p p)
  (x List.∷ xs) match1st a | no ¬p-head | no ¬p-tail =
    no (λ{ (_ , m1-head p-head) → ¬p-head (, p-head) ; (_ , m1-tail _ p-tail) → ¬p-tail (, p-tail) })

  module Lemmas where

    lem-A3 : ∀ {ν n} (K : Ktx ν n) {a r} → proj₂ K ⟨ a ⟩= r → r List.∈ (proj₂ K)
    lem-A3 f = proj₁ ∘ FirstLemmas.first⟶∈

    lem-A6-1 : ∀ {m ν} → AList ν (suc m) zero → ASub ν (suc m) m × AList ν m zero
    lem-A6-1 (t' // zero ◅ s) = t' // zero , s
    lem-A6-1 {zero} (t' // suc () ◅ xs)
    lem-A6-1 {suc m} (t' // x ◅ xs) with lem-A6-1 xs
    lem-A6-1 {suc m} (t' // zero ◅ xs) | e , u = t' // zero , xs -- same case as above
    lem-A6-1 {suc m} (t' // suc x ◅ xs) | e , u = asub-weaken e , t' // x ◅ u

    lem-A6 : ∀ {m ν} {ρs ρs'} {a : MetaType m ν} {τ : SimpleType ν} → ρs ⊢ a amatch τ ↠ ρs' →
             (∃ λ (u : AList ν m zero) → (from-meta $ a M./ (asub u)) ◁ τ)
    lem-A6 {a = ∀' a} {τ = τ} (mtc-tabs x) with lem-A6 x
    lem-A6 {a = ∀' a} {τ = τ} (mtc-tabs x) | u , p with lem-A6-1 u
    lem-A6 {a = ∀' a} {τ = τ} (mtc-tabs x) | u , p | b , bs = bs , m-tabs {!p!}
      where
        -- q : from-meta (substitute (asub u) a []) ◁ τ
        -- q = {!!}
    lem-A6 (mtc-iabs x) with lem-A6 x
    lem-A6 (mtc-iabs x) | u , p = u , (m-iabs p)
    lem-A6 {τ = τ} (mtc-simp {a = a} (u , eq)) =
      u , subst (flip _◁_ τ) (sym $ mgu-unifies (simpl a) τ (u , eq)) m-simp

    lem-A6' : ∀ {ν} {ρs ρs' } {r : Type ν} {a} → r ◁ a → ρs ⊢ (to-meta {zero} r) amatch a ↠ ρs'
    lem-A6' {a = a} m-simp = mtc-simp (mgu-id a)
    lem-A6' (m-tabs r◁a) = mtc-tabs {!!}
    lem-A6' (m-iabs r◁a) = mtc-iabs (lem-A6' r◁a)

    -- p'haps counterintuitively the following proposition is NOT a theorem:
    -- Δ⊢ᵣa⟶Δ≢Ø : ∀ {ν n} {K : Ktx ν n} {a} → K ⊢ᵣ a → ∃ λ b → b List.∈ (proj₂ K)
    -- since [] ⊢ᵣ Nat ⇒ Nat through the r-iabs rule, but also:
    -- [] ⊢ᵣ Nat ⇒ (Nat ⇒ Nat), etc; through recursion on r-iabs

    lem-A7a : ∀ {ν} (Δ : ICtx ν) {a ρs} → Δ ⊢match1st a ↠ ρs → ∃ λ r → Δ ⟨ a ⟩= r
    lem-A7a List.[] ()
    lem-A7a (x List.∷ Δ) {a = a} (m1-head x₁) = , (l-head u Δ)
        where
        p = lem-A6 x₁
        u = subst (λ u' → u' ◁ a) (alist-zero-vanishes (proj₁ p)) (proj₂ p)
    lem-A7a (r List.∷ Δ) (m1-tail ¬pr y) =
        , (l-tail (λ r◁a → ¬pr $ lem-A6' r◁a) (proj₂ $ lem-A7a Δ y))

  open Lemmas

  _⊢alg_ : ∀ {ν n} (K : Ktx ν n) → (a : Type ν) → Dec (K ⊢ᵣ a)
  K ⊢alg simpl x with proj₂ K match1st x
  K ⊢alg simpl x | yes p = yes (r-simp (proj₂ $ lem-A7a (proj₂ K) p) {!!})
  K ⊢alg simpl x | no ¬p = no (λ{ (r-simp x₁ x₂) → {!!} })
  K ⊢alg (a ⇒ b) with (a ∷K K) ⊢alg b
  K ⊢alg (a ⇒ b) | yes p = yes $ r-iabs a p
  K ⊢alg (a ⇒ b) | no ¬p = no (λ{ (r-iabs .a x) → ¬p x })
  K ⊢alg ∀' a with (ktx-weaken K) ⊢alg a
  K ⊢alg ∀' a | yes p = yes (r-tabs p)
  K ⊢alg ∀' a | no ¬p = no (λ{ (r-tabs x) → ¬p x })


{-# OPTIONS --without-K --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Escape {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.LogicalRelation

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Reducible types are well-formed.
escape : ∀ {l Γ A} → Γ ⊩⟨ l ⟩ A → Γ ⊢ A
escape (Uᵣ′ l′ l< ⊢Γ) = Uⱼ ⊢Γ
escape (ℕᵣ [ ⊢A , ⊢B , D ]) = ⊢A
escape (Emptyᵣ [ ⊢A , ⊢B , D ]) = ⊢A
escape (Unitᵣ [ ⊢A , ⊢B , D ]) = ⊢A
escape (ne′ K [ ⊢A , ⊢B , D ] neK K≡K) = ⊢A
escape (Bᵣ′ W F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext) = ⊢A
escape (emb 0<1 A) = escape A

-- Reducible type equality respect the equality relation.
escapeEq : ∀ {l Γ A B} → ([A] : Γ ⊩⟨ l ⟩ A)
            → Γ ⊩⟨ l ⟩ A ≡ B / [A]
            → Γ ⊢ A ≅ B
escapeEq (Uᵣ′ l′ l< ⊢Γ) PE.refl = ≅-Urefl ⊢Γ
escapeEq (ℕᵣ [ ⊢A , ⊢B , D ]) D′ = ≅-red D D′ ℕₙ ℕₙ (≅-ℕrefl (wf ⊢A))
escapeEq (Emptyᵣ [ ⊢A , ⊢B , D ]) D′ = ≅-red D D′ Emptyₙ Emptyₙ (≅-Emptyrefl (wf ⊢A))
escapeEq (Unitᵣ [ ⊢A , ⊢B , D ]) D′ = ≅-red D D′ Unitₙ Unitₙ (≅-Unitrefl (wf ⊢A))
escapeEq (ne′ K D neK K≡K) (ne₌ M D′ neM K≡M) =
  ≅-red (red D) (red D′) (ne neK) (ne neM) (~-to-≅ K≡M)
escapeEq (Bᵣ′ W F G D ⊢F ⊢G A≡A [F] [G] G-ext)
             (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
  ≅-red (red D) D′ ⟦ W ⟧ₙ ⟦ W ⟧ₙ A≡B
escapeEq (emb 0<1 A) A≡B = escapeEq A A≡B

-- Reducible terms are well-formed.
escapeTerm : ∀ {l Γ A t} → ([A] : Γ ⊩⟨ l ⟩ A)
              → Γ ⊩⟨ l ⟩ t ∷ A / [A]
              → Γ ⊢ t ∷ A
escapeTerm (Uᵣ′ l′ l< ⊢Γ) (Uₜ A [ ⊢t , ⊢u , d ] typeA A≡A [A]) = ⊢t
escapeTerm (ℕᵣ D) (ℕₜ n [ ⊢t , ⊢u , d ] t≡t prop) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Emptyᵣ D) (Emptyₜ e [ ⊢t , ⊢u , d ] t≡t prop) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Unitᵣ D) (Unitₜ e [ ⊢t , ⊢u , d ] prop) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (ne′ K D neK K≡K) (neₜ k [ ⊢t , ⊢u , d ] nf) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
               (Πₜ f [ ⊢t , ⊢u , d ] funcF f≡f [f] [f]₁) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
               (Σₜ p [ ⊢t , ⊢u , d ] pProd p≅p [fst] [snd]) =
  conv ⊢t (sym (subset* (red D)))
escapeTerm (emb 0<1 A) t = escapeTerm A t

-- Reducible term equality respect the equality relation.
escapeTermEq : ∀ {l Γ A t u} → ([A] : Γ ⊩⟨ l ⟩ A)
                → Γ ⊩⟨ l ⟩ t ≡ u ∷ A / [A]
                → Γ ⊢ t ≅ u ∷ A
escapeTermEq (Uᵣ′ l′ l< ⊢Γ) (Uₜ₌ A B d d′ typeA typeB A≡B [A] [B] [A≡B]) =
  ≅ₜ-red (id (Uⱼ ⊢Γ)) (redₜ d) (redₜ d′) Uₙ (typeWhnf typeA) (typeWhnf typeB) A≡B
escapeTermEq (ℕᵣ D) (ℕₜ₌ k k′ d d′ k≡k′ prop) =
  let natK , natK′ = split prop
  in  ≅ₜ-red (red D) (redₜ d) (redₜ d′) ℕₙ
             (naturalWhnf natK) (naturalWhnf natK′) k≡k′
escapeTermEq (Emptyᵣ D) (Emptyₜ₌ k k′ d d′ k≡k′ prop) =
  let natK , natK′ = esplit prop
  in  ≅ₜ-red (red D) (redₜ d) (redₜ d′) Emptyₙ
             (ne natK) (ne natK′) k≡k′
escapeTermEq {l} {Γ} {A} {t} {u} (Unitᵣ D) (Unitₜ₌ ⊢t ⊢u) =
  let t≅u = ≅ₜ-η-unit ⊢t ⊢u
      A≡Unit = subset* (red D)
  in  ≅-conv t≅u (sym A≡Unit)
escapeTermEq (ne′ K D neK K≡K)
                 (neₜ₌ k m d d′ (neNfₜ₌ neT neU t≡u)) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) (ne neK) (ne neT) (ne neU)
         (~-to-≅ₜ t≡u)
escapeTermEq (Bᵣ′ BΠ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                 (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) Πₙ (functionWhnf funcF) (functionWhnf funcG) f≡g
escapeTermEq (Bᵣ′ BΣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                 (Σₜ₌ p r d d′ pProd rProd p≅r [t] [u] [fstp] [fstr] [fst≡] [snd≡]) =
  ≅ₜ-red (red D) (redₜ d) (redₜ d′) Σₙ (productWhnf pProd) (productWhnf rProd) p≅r
escapeTermEq (emb 0<1 A) t≡u = escapeTermEq A t≡u