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

open import Data.Nat
open import Data.List using (List ; [] ; _∷_ ; length) renaming (_++_ to _++L_ )
open import Data.Vec  using (Vec ; [] ; _∷_ ) renaming (_++_ to _++V_ )
open import Data.Fin hiding (_+_ ; _≤_ )
open import Data.Product
open import Data.Maybe

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Algebra
open import Level renaming (zero to lzero ; suc to lsuc)

open import Function using () renaming (case_of_ to CASE_OF_)

data Multiplicity : Set where
  one   : Multiplicity
  omega : Multiplicity

-- Multiplicities with 0.
-- This is a deviation from the papers. Having 0 is convenient for handling uses of variables.
data Multiplicity₀ : Set where
  zero  : Multiplicity₀
  one   : Multiplicity₀
  omega : Multiplicity₀

-- Embedding
M→M₀ : Multiplicity -> Multiplicity₀
M→M₀ one   = one
M→M₀ omega = omega

-- Instead of having constructors, we have (additive) sums and
-- (multiplicative) products, together with iso-recursive types. The
-- type constructor Many can be used for representing non-linear
-- constructors.
data Ty : ℕ -> Set where
  _⊕_    : ∀ {n} -> Ty n -> Ty n -> Ty n
  tunit  : ∀ {n} -> Ty n
  _⊗_   : ∀ {n} -> Ty n -> Ty n -> Ty n
  Many   : ∀ {n} -> Multiplicity -> Ty n -> Ty n
  _#_~>_ : ∀ {n} -> Ty n -> Multiplicity -> Ty n -> Ty n
  _●     : ∀ {n} -> Ty n -> Ty n
  μ_    : ∀ {n} -> Ty (suc n) -> Ty n
  tvar   : ∀ {n} -> Fin n -> Ty n
  _↔_    : ∀ {n} -> Ty n -> Ty n -> Ty n

_⊸_ : ∀ {n} -> Ty n -> Ty n -> Ty n
t ⊸ t' = t # one ~> t'

infixr 4 _⊗_
infixr 1 _⊕_
infixr 0 _#_~>_
infixr 0 _⊸_

tbool : Ty zero
tbool = tunit ⊕ tunit

module _ where
  -- Several properties to handle recursive types.
  open import Data.Nat.Properties
  private
    lemma : ∀ {m n} -> m ≤ n -> ∃[ k ] (k + m ≡ n)
    lemma {n = n} z≤n = n , +-identityʳ n
    lemma (s≤s r) with lemma r
    ... | k , refl = k , +-suc k _

    weakenVarK : ∀ {m n k} -> k + m ≡ n -> Fin m -> Fin (k + m)
    weakenVarK {k = zero} refl  x = x
    weakenVarK {n = suc n} {suc k} eq x = suc (weakenVarK {n = n} {k = k} (suc-injective eq) x)

  weakenVar : ∀ {m n} -> m ≤ n -> Fin m -> Fin n
  weakenVar r x with lemma r
  ... | k , r' = subst Fin r' (weakenVarK r' x)

  substTyVar : ∀ {m n k} -> m + n ≤ k -> Fin (m + suc n) -> Ty k -> Ty k
  substTyVar {zero} r zero t = t
  substTyVar {zero} r (suc x) t = tvar (weakenVar r x)
  substTyVar {suc m} {k = suc k} r zero t = tvar zero
  substTyVar {suc m} (s≤s r) (suc x) t = substTyVar {m} (≤-trans r (≤-step ≤-refl)) x t

  weaken : ∀ {m n} -> m ≤ n -> Ty m -> Ty n
  weaken r (t ⊕ t₁) = weaken r t ⊕ weaken r t₁
  weaken r tunit =  tunit
  weaken r (t ⊗ t₁) = weaken r t ⊗ weaken r t₁
  weaken r (Many x t) = Many x (weaken r t)
  weaken r (t # x ~> t₁) = weaken r t # x ~> weaken r t₁
  weaken r (t ●) = weaken r t ●
  weaken r (μ t) = μ (weaken (s≤s r) t)
  weaken r (tvar x) = tvar (weakenVar r x)
  weaken r (t₁ ↔ t₂) = weaken r t₁ ↔ weaken r t₂

  substTyGen : ∀ {m n} -> Ty (m + suc n) -> Ty (m + n) -> Ty (m + n)
  substTyGen (s₁ ⊕ s₂) t = substTyGen s₁ t ⊕ substTyGen s₂ t
  substTyGen tunit t = tunit
  substTyGen (s₁ ⊗ s₂) t = substTyGen s₁ t ⊗ substTyGen s₂ t
  substTyGen (Many x s) t = Many x (substTyGen s t)
  substTyGen (s # x ~> s₁) t = substTyGen s t # x ~> substTyGen s₁ t
  substTyGen (s ●) t = (substTyGen s t) ●
  substTyGen {m} (μ s) t = μ (substTyGen {m = suc m} s (weaken (n≤1+n _) t))
  substTyGen (tvar x) t = substTyVar ≤-refl x t
  substTyGen (s₁ ↔ s₂) t = substTyGen s₁ t ↔ substTyGen s₂ t

  substTy : ∀ {n} -> Ty (suc n) -> Ty n -> Ty n
  substTy = substTyGen {zero}

module TyExamples where
  nat : ∀ {n} -> Ty n
  nat = μ (tunit ⊕ tvar zero)

  natlist : ∀ {n} -> Ty n
  natlist = μ (tunit ⊕ (nat ⊗ tvar zero))

-- Instead of using environments that maps variables to pairs of types
-- and multiplicities, we use two sort of environments: one maps
-- variables to types and the other maps variables to multiplicities.
--
-- We will use de Bruijn indices for variables, and thus type
-- environments are represented as a list of types. The treatment of
-- multiplicity environment is similar but we assume that it has the
-- same length with the corresponding type environment; so we use Vec
-- for multiplicity environments.

TyEnv : Set
TyEnv = List (Ty zero)

MultEnv : ∀ ℕ -> Set
MultEnv n = Vec Multiplicity₀ n

-----------------------------------------------------------------------------
-- Operations and properties for multiplicities

mul : Multiplicity -> Multiplicity -> Multiplicity
mul one   y = y
mul omega y = omega

mul₀ : Multiplicity₀ -> Multiplicity₀ -> Multiplicity₀
mul₀ zero y = zero
mul₀ one y = y
mul₀ omega zero = zero
mul₀ omega one = omega
mul₀ omega omega = omega

mul₀-m-zero : ∀ m -> mul₀ m zero ≡ zero
mul₀-m-zero zero = refl
mul₀-m-zero one = refl
mul₀-m-zero omega = refl

_×ₘ_ : ∀{n} -> Multiplicity -> MultEnv n -> MultEnv n
m ×ₘ Γ = Data.Vec.map (mul₀ (M→M₀ m)) Γ

add₀ : Multiplicity₀ -> Multiplicity₀ -> Multiplicity₀
add₀ zero m = m
add₀ one zero  = one
add₀ one one   = omega
add₀ one omega = omega
add₀ omega _   = omega

add₀-m-zero : ∀ m -> add₀ m zero ≡ m
add₀-m-zero zero = refl
add₀-m-zero one = refl
add₀-m-zero omega = refl

add₀-comm : ∀ x y -> add₀ x y ≡ add₀ y x
add₀-comm zero zero = refl
add₀-comm zero one = refl
add₀-comm zero omega = refl
add₀-comm one zero = refl
add₀-comm one one = refl
add₀-comm one omega = refl
add₀-comm omega zero = refl
add₀-comm omega one = refl
add₀-comm omega omega = refl

add₀-assoc : ∀ x y z -> add₀ (add₀ x y) z ≡ add₀ x (add₀ y z)
add₀-assoc zero y z = refl
add₀-assoc one zero z = refl
add₀-assoc one one zero = refl
add₀-assoc one one one = refl
add₀-assoc one one omega = refl
add₀-assoc one omega z = refl
add₀-assoc omega y z = refl

mul₀-dist-add₀ : ∀ x y z -> mul₀ x (add₀ y z) ≡ add₀ (mul₀ x y) (mul₀ x z)
mul₀-dist-add₀ zero y z = refl
mul₀-dist-add₀ one y z = refl
mul₀-dist-add₀ omega zero z = refl
mul₀-dist-add₀ omega one zero = refl
mul₀-dist-add₀ omega one one = refl
mul₀-dist-add₀ omega one omega = refl
mul₀-dist-add₀ omega omega z = refl

-----------------------------------------------------------------------------
-- Operations and properties for multiplicity environments

infixr 7 _×ₘ_
infixl 6 _+ₘ_

_+ₘ_ : ∀ {n} -> MultEnv n -> MultEnv n -> MultEnv n
[] +ₘ [] = []
(m₁ ∷ Δ₁) +ₘ (m₂ ∷ Δ₂) = add₀ m₁ m₂ ∷ (Δ₁ +ₘ Δ₂)

+ₘ-comm : ∀ {n} -> ∀ (Δ₁ Δ₂ : MultEnv n) -> Δ₁ +ₘ Δ₂ ≡ Δ₂ +ₘ Δ₁
+ₘ-comm [] [] = refl
+ₘ-comm (x₁ ∷ Δ₁) (x₂ ∷ Δ₂) =
  begin
    add₀ x₁ x₂ ∷ Δ₁ +ₘ Δ₂
    ≡⟨ cong (_∷ Δ₁ +ₘ Δ₂) (add₀-comm x₁ x₂) ⟩
    add₀ x₂ x₁ ∷ Δ₁ +ₘ Δ₂
    ≡⟨ cong (add₀ x₂ x₁ ∷_) (+ₘ-comm Δ₁ Δ₂) ⟩
    add₀ x₂ x₁ ∷ Δ₂ +ₘ Δ₁
  ∎

+ₘ-assoc : ∀ {n} -> ∀ (Δ₁ Δ₂ Δ₃ : MultEnv n) ->
           (Δ₁ +ₘ Δ₂) +ₘ Δ₃ ≡ Δ₁ +ₘ (Δ₂ +ₘ Δ₃)
+ₘ-assoc [] [] [] = refl
+ₘ-assoc (x₁ ∷ Δ₁) (x₂ ∷ Δ₂) (x₃ ∷ Δ₃) =
  begin
   add₀ (add₀ x₁ x₂) x₃ ∷ Δ₁ +ₘ Δ₂ +ₘ Δ₃
   ≡⟨ cong₂ (_∷_) (add₀-assoc x₁ x₂ _) (+ₘ-assoc Δ₁ Δ₂ _) ⟩
   add₀ x₁ (add₀ x₂ x₃) ∷ Δ₁ +ₘ (Δ₂ +ₘ Δ₃)
  ∎

-- The multiplicity environment that maps all variables into 0.
∅ : ∀ {n} -> MultEnv n
∅ = Data.Vec.replicate zero

∅-lid : ∀ {n} (Δ : MultEnv n) -> ∅ +ₘ Δ ≡ Δ
∅-lid [] = refl
∅-lid (x ∷ Δ) = cong (x ∷_) (∅-lid Δ)

∅-rid : ∀ {n} (Δ : MultEnv n) -> Δ +ₘ ∅ ≡ Δ
∅-rid [] = refl
∅-rid (x ∷ Δ) = cong₂ (_∷_) (add₀-m-zero x) (∅-rid Δ)

+ₘ-commutativeMonoid : ∀ (n : ℕ) -> CommutativeMonoid 0ℓ 0ℓ
+ₘ-commutativeMonoid n = record
                           { Carrier = MultEnv n
                           ; _≈_ = _≡_
                           ; _∙_ = _+ₘ_
                           ; ε = ∅
                           ; isCommutativeMonoid = record { isMonoid = +ₘ-isMonoid ; comm = +ₘ-comm }
                             -- record {
                             -- isSemigroup = record { isMagma = record { isEquivalence =  Relation.Binary.PropositionalEquality.isEquivalence  ;
                             --                                           ∙-cong = cong₂ (_+ₘ_) } ;
                             --                        assoc = +ₘ-assoc } ;
                             -- ; identityˡ = ∅-lid
                             -- ; comm = +ₘ-comm }
                           }
  where
    +ₘ-isMonoid : IsMonoid _≡_ _+ₘ_ ∅
    +ₘ-isMonoid = record { isSemigroup = record { isMagma = record { isEquivalence = Relation.Binary.PropositionalEquality.isEquivalence ; ∙-cong = cong₂ (_+ₘ_) } ; assoc = +ₘ-assoc } ; identity = ∅-lid , ∅-rid }

+ₘ-transpose :
  ∀ {n} (Δ₁ Δ₂ Δ₃ Δ₄ : MultEnv n) ->
  ((Δ₁ +ₘ Δ₂) +ₘ (Δ₃ +ₘ Δ₄)) ≡ ((Δ₁ +ₘ Δ₃) +ₘ (Δ₂ +ₘ Δ₄))
+ₘ-transpose Δ₁ Δ₂ Δ₃ Δ₄ =
  begin
    (Δ₁ +ₘ Δ₂) +ₘ (Δ₃ +ₘ Δ₄)
  ≡⟨ +ₘ-assoc Δ₁ Δ₂ _ ⟩
    Δ₁ +ₘ (Δ₂ +ₘ (Δ₃ +ₘ Δ₄))
  ≡⟨ cong (Δ₁ +ₘ_) (+ₘ-comm Δ₂ _) ⟩
    (Δ₁ +ₘ ((Δ₃ +ₘ Δ₄) +ₘ Δ₂))
  ≡⟨ cong (Δ₁ +ₘ_) (+ₘ-assoc Δ₃ Δ₄ _) ⟩
    (Δ₁ +ₘ (Δ₃ +ₘ (Δ₄ +ₘ Δ₂)))
  ≡⟨ cong (Δ₁ +ₘ_) (cong (Δ₃ +ₘ_) (+ₘ-comm Δ₄ _)) ⟩
    (Δ₁ +ₘ (Δ₃ +ₘ (Δ₂ +ₘ Δ₄)))
  ≡⟨ sym (+ₘ-assoc Δ₁ Δ₃ _) ⟩
    ((Δ₁ +ₘ Δ₃) +ₘ (Δ₂ +ₘ Δ₄))
  ∎

one×ₘ : ∀ {n} (Δ : MultEnv n) -> one ×ₘ Δ ≡ Δ
one×ₘ [] = refl
one×ₘ (x ∷ Δ) = cong (_∷_ x) (one×ₘ Δ)

×ₘ∅ : ∀ {n} m -> m ×ₘ ∅ {n} ≡ ∅ {n}
×ₘ∅ {zero} m = refl
×ₘ∅ {suc n} one   = cong (_∷_ zero) (×ₘ∅ one)
×ₘ∅ {suc n} omega = cong (_∷_ zero) (×ₘ∅ omega)

omega×ₘm×ₘ-omega×ₘ : ∀ {n} (m : Multiplicity) (Δ : MultEnv n) -> omega ×ₘ m ×ₘ Δ ≡ omega ×ₘ Δ
omega×ₘm×ₘ-omega×ₘ {zero}   m [] = refl
omega×ₘm×ₘ-omega×ₘ {suc n} m (zero ∷ Δ) rewrite mul₀-m-zero (M→M₀ m) = cong (zero ∷_) (omega×ₘm×ₘ-omega×ₘ {n} m Δ)
omega×ₘm×ₘ-omega×ₘ {suc n} one (one ∷ Δ)   = cong (omega ∷_) (omega×ₘm×ₘ-omega×ₘ {n} one Δ)
omega×ₘm×ₘ-omega×ₘ {suc n} omega (one ∷ Δ) = cong (omega ∷_) (omega×ₘm×ₘ-omega×ₘ {n} omega Δ)
omega×ₘm×ₘ-omega×ₘ {suc n} one (omega ∷ Δ) = cong (omega ∷_) (omega×ₘm×ₘ-omega×ₘ {n} one Δ)
omega×ₘm×ₘ-omega×ₘ {suc n} omega (omega ∷ Δ) = cong (omega ∷_) (omega×ₘm×ₘ-omega×ₘ {n} omega Δ)

mul-×ₘ : ∀ {n} m₁ m₂ (Δ : MultEnv n)  -> mul m₁ m₂ ×ₘ Δ ≡ m₁ ×ₘ (m₂ ×ₘ Δ)
mul-×ₘ one m₂ Δ = sym (one×ₘ _)
mul-×ₘ omega m₂ Δ = sym (omega×ₘm×ₘ-omega×ₘ m₂ Δ)

module _ where
  open import Data.Vec.Properties

  omega×ₘ∅-inv : ∀ {n} (Δ : MultEnv n) -> omega ×ₘ Δ ≡ ∅ -> Δ ≡ ∅
  omega×ₘ∅-inv [] eq = refl
  omega×ₘ∅-inv (x ∷ Δ) eq with  ∷-injective eq
  omega×ₘ∅-inv (zero ∷ Δ) eq | eq₁ , eq₂ = cong (zero ∷_) (omega×ₘ∅-inv Δ eq₂)

  add₀-0-0-inv : ∀ x y -> add₀ x y ≡ zero -> x ≡ zero × y ≡ zero
  add₀-0-0-inv zero zero eq = refl , refl
  add₀-0-0-inv one zero ()
  add₀-0-0-inv one one ()
  add₀-0-0-inv one omega ()

  ∅+ₘ∅-inv : ∀ {n} (Δ₁ Δ₂ : MultEnv n) -> Δ₁ +ₘ Δ₂ ≡ ∅ -> Δ₁ ≡ ∅ × Δ₂ ≡ ∅
  ∅+ₘ∅-inv [] [] eq = refl , refl
  ∅+ₘ∅-inv (x₁ ∷ Δ₁) (x₂ ∷ Δ₂) eq with ∷-injective eq
  ... | eq₁ , eq₂ with add₀-0-0-inv x₁ x₂ eq₁ | ∅+ₘ∅-inv Δ₁ Δ₂ eq₂
  ... | refl , refl | refl , refl = refl , refl

×ₘ-dist : ∀ {n} m (Δ₁ Δ₂ : MultEnv n) ->
          (m ×ₘ (Δ₁ +ₘ Δ₂)) ≡ (m ×ₘ Δ₁) +ₘ (m ×ₘ Δ₂)
×ₘ-dist m [] [] = refl
×ₘ-dist m (x₁ ∷ Δ₁) (x₂ ∷ Δ₂) =
  cong₂ (_∷_) (mul₀-dist-add₀ (M→M₀ m) x₁ x₂) (×ₘ-dist m Δ₁ Δ₂)

×ₘ-split : ∀ {n} m (Δ : MultEnv n)  -> ∃[ Δ' ] (m ×ₘ Δ ≡ Δ +ₘ Δ' )
×ₘ-split m [] = [] , refl
×ₘ-split m (x ∷ Δ) with ×ₘ-split m Δ
×ₘ-split one (x ∷ Δ) | Δ' , eq = zero ∷ Δ' , cong₂ (_∷_) (sym (add₀-m-zero x)) eq
×ₘ-split omega (zero ∷ Δ) | Δ' , eq = zero ∷ Δ' , cong (_∷_ zero) eq
×ₘ-split omega (one ∷ Δ) | Δ' , eq = one ∷ Δ' , cong (_∷_ omega) eq
×ₘ-split omega (omega ∷ Δ) | Δ' , eq = one ∷ Δ' , cong (_∷_ omega) eq

-----------------------------------------------------------------------------
-- Constraints on multiplicity environments

open import Data.Vec.Relation.Unary.All

-- all-zero Δ essentially asserts that Δ is ∅
all-zero : ∀ {n} -> Vec Multiplicity₀ n -> Set
all-zero = All (λ x -> x ≡ zero)

all-zero-∅ : ∀ {n} -> all-zero {n} ∅
all-zero-∅ {zero}  = []
all-zero-∅ {suc n} = refl ∷ all-zero-∅ {n}

all-zero-∅-inv : ∀ {n} -> (Δ : MultEnv n) -> all-zero {n} Δ -> Δ ≡ ∅
all-zero-∅-inv .[] [] = refl
all-zero-∅-inv .(zero ∷ _) (refl ∷ az) = cong (_∷_ zero) (all-zero-∅-inv _ az)

data no-omega : (m : Multiplicity₀) -> Set where
  zero : no-omega zero
  one  : no-omega one

no-omega-dist : ∀ x y -> no-omega (add₀ x y) -> no-omega x × no-omega y
no-omega-dist zero y noω   = zero , noω
no-omega-dist one zero noω = one , zero

-- all-no-omega Δ asserts that Δ(x) cannot be omega.
all-no-omega : ∀ {n} -> Vec Multiplicity₀ n -> Set
all-no-omega = All no-omega

-- Several properties of all-no-omega.

all-no-omega-∅ : ∀ {n} -> all-no-omega (∅ {n})
all-no-omega-∅ {zero}  = []
all-no-omega-∅ {suc n} = zero ∷ all-no-omega-∅

all-no-omega-dist : ∀ {n} (Δ₁ Δ₂ : MultEnv n) -> all-no-omega (Δ₁ +ₘ Δ₂) ->
                    all-no-omega Δ₁ × all-no-omega Δ₂
all-no-omega-dist [] [] ano = [] , []
all-no-omega-dist (x₁ ∷ Δ₁) (x₂ ∷ Δ₂) (noω ∷ ano)
  with no-omega-dist x₁ x₂ noω | all-no-omega-dist Δ₁ Δ₂ ano
... | no₁ , no₂ | ano₁ , ano₂ = no₁ ∷ ano₁ , no₂ ∷ ano₂

all-no-omega-dist-×ₘ :
  ∀ {n} m (Δ : MultEnv n) ->
  all-no-omega (m ×ₘ Δ) -> all-no-omega Δ
all-no-omega-dist-×ₘ m [] ano = []
all-no-omega-dist-×ₘ one (x ∷ Δ) (px ∷ ano) = px ∷ (all-no-omega-dist-×ₘ one Δ ano)
all-no-omega-dist-×ₘ omega (zero ∷ Δ) (px ∷ ano) = zero ∷ all-no-omega-dist-×ₘ omega Δ ano

all-no-omega-weaken-right :
  ∀ {n} {Δ₁ Δ₂ : MultEnv n} {m} ->
  all-no-omega (Δ₁ +ₘ m ×ₘ Δ₂) -> all-no-omega (Δ₁ +ₘ Δ₂)
all-no-omega-weaken-right {Δ₁ = Δ₁} {Δ₂} {m} ano with ×ₘ-split m Δ₂
... | Δ' , eq with all-no-omega-dist (Δ₁ +ₘ Δ₂) Δ' (subst all-no-omega lemma ano)
  where
    lemma : Δ₁ +ₘ m ×ₘ Δ₂ ≡ Δ₁ +ₘ Δ₂ +ₘ Δ'
    lemma = begin
              Δ₁ +ₘ m ×ₘ Δ₂
            ≡⟨ cong (Δ₁ +ₘ_) eq ⟩
              Δ₁ +ₘ (Δ₂ +ₘ Δ')
            ≡⟨ sym (+ₘ-assoc Δ₁ Δ₂ _) ⟩
             Δ₁ +ₘ Δ₂ +ₘ Δ'
            ∎
... | ano₁ , _ = ano₁

all-no-omega-omega×ₘ : ∀ {n} (Δ : MultEnv n) -> all-no-omega (omega ×ₘ Δ) -> Δ ≡ ∅
all-no-omega-omega×ₘ [] ano = refl
all-no-omega-omega×ₘ (zero ∷ Δ) (px ∷ ano) = cong (_∷_ zero) (all-no-omega-omega×ₘ Δ ano)

-----------------------------------------------------------------------------

-- Variables, or de Bruijn indices
data _∋_ : ∀ TyEnv  -> Ty zero -> Set where
  vz : ∀ {Γ : TyEnv} {a : Ty zero} -> (a ∷ Γ) ∋ a
  vs : ∀ {Γ : TyEnv} {a b : Ty zero} -> Γ ∋ a -> (b ∷ Γ) ∋ a

-- 'discardable' means that a corresponding variable need not be used.
data discardable : Multiplicity₀ -> Set where
  omega : discardable omega
  zero  : discardable zero

omega×ₘ-discardable : ∀ {n} (Δ : MultEnv n) ->  All discardable (omega ×ₘ Δ)
omega×ₘ-discardable [] = []
omega×ₘ-discardable (zero ∷ Δ)  = zero ∷ omega×ₘ-discardable Δ
omega×ₘ-discardable (one ∷ Δ)   = omega ∷ omega×ₘ-discardable Δ
omega×ₘ-discardable (omega ∷ Δ) = omega ∷ omega×ₘ-discardable Δ

-- 'usable' means that a corresponding variable can be used.
data usable : Multiplicity₀ -> Set where
  omega : usable omega
  one   : usable one

-- varOk means that the use of variable x in Γ is compatible with Δ; that is,
-- x is usable in Δ and other variables must be discardable in Δ.
data varOk : (Γ : TyEnv) {a : Ty zero} -> Γ ∋ a -> (Δ : MultEnv (length Γ)) -> Set where
  there :
    ∀ {Γ : TyEnv} {m a b} {x : Γ ∋ a} {Δ} ->
    (d : discardable m) ->
    (ok : varOk Γ x Δ) ->
    varOk (b ∷ Γ) (vs x) (m  ∷ Δ)
  here    :
    ∀ {Γ : TyEnv} {a} {Δ} {m} ->
      (u : usable m) ->
      (ad : All discardable Δ) ->
      varOk (a ∷ Γ) vz (m ∷ Δ)

-- varOk● is similar to varOk but is for invertible variables. The definition is simplified as
-- we assume Ξ cannot contain omega.
data varOk● : (Θ : TyEnv) {a : Ty zero} -> Θ ∋ a -> (Ξ : MultEnv (length Θ)) -> Set where
  there :
    ∀ {Θ : TyEnv} {a b} {x : Θ ∋ a} {Ξ} ->
    (ok : varOk● Θ x Ξ) ->
    varOk● (b ∷ Θ) (vs x) (zero ∷ Ξ)

  here :
    ∀ {Θ : TyEnv} {a} {Ξ} ->
    (ad : all-zero Ξ) ->
    varOk● (a ∷ Θ) vz (one ∷ Ξ)

-- Now, we are ready to define the intrinsically-typed syntax of Sparcl.
data Term : ∀ (Γ : TyEnv) -> MultEnv (length Γ) -> (Θ : TyEnv) -> MultEnv (length Θ) -> Ty zero -> Set where
  var  :
    ∀ {Γ Δ Θ A} ->
    (x : Γ ∋ A) -> (ok : varOk Γ x Δ) ->
    Term Γ Δ Θ ∅ A

  abs  :
    ∀ {Γ Δ Θ Ξ A B} -> (m : Multiplicity) ->
    Term (A ∷ Γ) (M→M₀ m ∷ Δ) Θ Ξ B ->
    Term Γ Δ Θ Ξ (A # m ~> B)

  app :
    ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B m} ->
    Term Γ Δ₁ Θ Ξ₁ (A # m ~> B) ->
    Term Γ Δ₂ Θ Ξ₂ A ->
    Term Γ (Δ₁ +ₘ m ×ₘ Δ₂) Θ (Ξ₁ +ₘ m ×ₘ Ξ₂) B

  unit :
    ∀ {Γ Δ Θ} ->
    (ad : All discardable Δ) ->
    Term Γ Δ Θ ∅ tunit

  letunit :
    ∀ {Γ Δ₀ Δ Θ Ξ₀ Ξ A} ->
    (m : Multiplicity) ->
    Term Γ Δ₀ Θ Ξ₀ tunit ->
    Term Γ Δ  Θ Ξ  A ->
    Term Γ (m ×ₘ Δ₀ +ₘ Δ) Θ (m ×ₘ Ξ₀ +ₘ Ξ) A

  pair :
    ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B} ->
    Term Γ Δ₁ Θ Ξ₁ A ->
    Term Γ Δ₂ Θ Ξ₂ B ->
    Term Γ (Δ₁ +ₘ Δ₂) Θ (Ξ₁ +ₘ Ξ₂) (A ⊗ B)

  letpair :
    ∀ {Γ Δ₀ Δ Θ Ξ₀ Ξ A B C} ->
    (m : Multiplicity) ->
    Term Γ Δ₀ Θ Ξ₀ (A ⊗ B) ->
    Term (A ∷ B ∷ Γ) (M→M₀ m ∷ M→M₀ m ∷ Δ) Θ Ξ C ->
    Term Γ (m ×ₘ Δ₀ +ₘ Δ) Θ (m ×ₘ Ξ₀ +ₘ Ξ) C

  many :
    ∀ {Γ Δ Θ Ξ A} ->
    (m : Multiplicity) ->
    Term Γ Δ Θ Ξ A ->
    Term Γ (m ×ₘ Δ) Θ (m ×ₘ Ξ) (Many m A)

  unmany :
    ∀ {Γ Δ₀ Δ Θ Ξ₀ Ξ m₀ A B} ->
    (m : Multiplicity) ->
    Term Γ Δ₀ Θ Ξ₀ (Many m₀ A) ->
    Term (A ∷ Γ) (M→M₀ (mul m m₀) ∷ Δ) Θ Ξ B ->
    Term Γ (m ×ₘ Δ₀ +ₘ Δ) Θ (m ×ₘ Ξ₀ +ₘ Ξ) B

  inl  :
    ∀ {Γ Δ Θ Ξ} {A B} ->
    Term Γ Δ Θ Ξ A ->
    Term Γ Δ Θ Ξ (A ⊕ B)

  inr :
    ∀ {Γ Δ Θ Ξ} {A B} ->
    Term Γ Δ Θ Ξ B ->
    Term Γ Δ Θ Ξ (A ⊕ B)

  case :
    ∀ {Γ Δ₀ Δ Θ Ξ₀ Ξ A B C} ->
    (m : Multiplicity) ->
    Term Γ Δ₀ Θ Ξ₀ (A ⊕ B) ->
    Term (A ∷ Γ) (M→M₀ m ∷ Δ) Θ Ξ C ->
    Term (B ∷ Γ) (M→M₀ m ∷ Δ) Θ Ξ C ->
    Term Γ (m ×ₘ Δ₀ +ₘ Δ) Θ (m ×ₘ Ξ₀ +ₘ Ξ) C

  roll :
    ∀ {Γ Δ Θ Ξ F} ->
    Term Γ Δ Θ Ξ (substTy F (μ F)) ->
    Term Γ Δ Θ Ξ (μ F)

  unroll :
    ∀ {Γ Δ Θ Ξ F} ->
    Term Γ Δ Θ Ξ (μ F) ->
    Term Γ Δ Θ Ξ (substTy F (μ F))

  unit● :
    ∀ {Γ Δ Θ} ->
    (ad : All discardable Δ) ->
    Term Γ Δ Θ ∅ (tunit ●)

  letunit● :
    ∀ {Γ Δ₀ Δ Θ Ξ₀ Ξ A} ->
    Term Γ Δ₀ Θ Ξ₀ (tunit ●) ->
    Term Γ Δ  Θ Ξ  (A ●) ->
    Term Γ (Δ₀ +ₘ Δ) Θ (Ξ₀ +ₘ Ξ) (A ●)

  pair● :
    ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B} ->
    Term Γ Δ₁ Θ Ξ₁ (A ●) ->
    Term Γ Δ₂ Θ Ξ₂ (B ●) ->
    Term Γ (Δ₁ +ₘ Δ₂) Θ (Ξ₁ +ₘ Ξ₂) ((A ⊗ B) ●)

  letpair● :
    ∀ {Γ Δ₀ Δ Θ Ξ₀ Ξ A B C} ->
    Term Γ Δ₀ Θ Ξ₀ ((A ⊗ B) ●) ->
    Term Γ Δ  (A ∷ B ∷ Θ) (one ∷ one ∷ Ξ) (C ●) ->
    Term Γ (Δ₀ +ₘ Δ) Θ (Ξ₀ +ₘ Ξ) (C ●)

  inl● :
    ∀ {Γ Δ Θ Ξ} {A B} ->
    Term Γ Δ Θ Ξ (A ●) ->
    Term Γ Δ Θ Ξ ((A ⊕ B) ●)

  inr● :
    ∀ {Γ Δ Θ Ξ} {A B} ->
    Term Γ Δ Θ Ξ (B ●) ->
    Term Γ Δ Θ Ξ ((A ⊕ B) ●)

  case● :
    ∀ {Γ Δ₀ Δ Δ' Θ Ξ₀ Ξ Ξ' A B C} ->
    Term Γ Δ₀ Θ Ξ₀ ((A ⊕ B) ●) ->
    Term Γ Δ  (A ∷ Θ) (one ∷ Ξ) (C ●) ->
    Term Γ Δ  (B ∷ Θ) (one ∷ Ξ) (C ●) ->
    Term Γ Δ' Θ Ξ' (C # omega ~> tbool) ->
    Term Γ (Δ₀ +ₘ Δ +ₘ omega ×ₘ Δ') Θ (Ξ₀ +ₘ Ξ +ₘ omega ×ₘ Ξ') (C ●)

  var● : ∀ {Γ Δ Θ Ξ A} ->
         (x : Θ ∋ A) ->
         (ad : All discardable Δ) -> varOk● Θ x Ξ ->
         Term Γ Δ Θ Ξ (A ●)

  pin : ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B} ->
        Term Γ Δ₁ Θ Ξ₁ (A ●) ->
        Term Γ Δ₂ Θ Ξ₂ (A # omega ~> B ●)  ->
        Term Γ (Δ₁ +ₘ Δ₂) Θ (Ξ₁ +ₘ Ξ₂) ((A ⊗ B) ●)

  unlift :
    ∀ {Γ Δ Θ Ξ A B}
    -> Term Γ Δ Θ Ξ (A ● ⊸ B ●)
    -> Term Γ (omega ×ₘ Δ) Θ (omega ×ₘ Ξ) (A ↔ B)

  fapp :
    ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B}
    -> Term Γ Δ₁ Θ Ξ₁ (A ↔ B)
    -> Term Γ Δ₂ Θ Ξ₂ A
    -> Term Γ (Δ₁ +ₘ omega ×ₘ Δ₂) Θ (Ξ₁ +ₘ omega ×ₘ Ξ₂) B

  bapp :
    ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B}
    -> Term Γ Δ₁ Θ Ξ₁ (A ↔ B)
    -> Term Γ Δ₂ Θ Ξ₂ B
    -> Term Γ (Δ₁ +ₘ omega ×ₘ Δ₂) Θ (Ξ₁ +ₘ omega ×ₘ Ξ₂) A

-- fwd and bwd are obtained as derived constructs.
fwd :
  ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B} ->
  Term Γ Δ₁ Θ Ξ₁ (A ● ⊸ B ●) ->
  Term Γ Δ₂ Θ Ξ₂ A ->
  Term Γ (omega ×ₘ Δ₁ +ₘ omega ×ₘ Δ₂) Θ (omega ×ₘ Ξ₁ +ₘ omega ×ₘ Ξ₂) B
fwd e1 e2 = fapp (unlift e1) e2

bwd :
  ∀ {Γ Δ₁ Δ₂ Θ Ξ₁ Ξ₂ A B} ->
  Term Γ Δ₁ Θ Ξ₁ (A ● ⊸ B ●) ->
  Term Γ Δ₂ Θ Ξ₂ B ->
  Term Γ (omega ×ₘ Δ₁ +ₘ omega ×ₘ Δ₂) Θ (omega ×ₘ Ξ₁ +ₘ omega ×ₘ Ξ₂) A
bwd e1 e2 = bapp (unlift e1) e2

-- compatΘ Θ Ξ Θ' Ξ' asserts that environments ((Θ , Ξ) and
-- (Θ' , Ξ')) differ only in variables with multiplicity zero. That
-- is, (Θ , Ξ) and (Θ' , Ξ') denote the same environement in
-- paper's representation.

data compatΘ : (Θ : TyEnv)  (Ξ : MultEnv (length Θ))
                (Θ' : TyEnv) (Ξ' : MultEnv (length Θ')) -> Set where
  compat-[] :
    compatΘ [] [] [] []

  compat-ext-here :
    ∀ {Θ Ξ Θ' Ξ' A} ->
    compatΘ Θ Ξ Θ' Ξ' ->
    compatΘ Θ Ξ (A ∷ Θ') (zero ∷ Ξ')

  compat-reduce-here :
    ∀ {Θ Ξ Θ' Ξ' A} ->
    compatΘ Θ Ξ Θ' Ξ' ->
    compatΘ (A ∷ Θ) (zero ∷ Ξ) Θ' Ξ'

  compat-skip :
    ∀ {Θ Ξ Θ' Ξ' A m } ->
    compatΘ Θ Ξ Θ' Ξ' ->
    compatΘ (A ∷ Θ) (m ∷ Ξ) (A ∷ Θ') (m ∷ Ξ')

-- Some useful examples of compatΘ

ext-id : ∀ {Θ Ξ} ->  compatΘ Θ Ξ Θ Ξ
ext-id {[]} {[]}         = compat-[]
ext-id {_ ∷ Θ} {_ ∷ Ξ} = compat-skip (ext-id {Θ} {Ξ})

smashΘ : ∀ {Θ} -> compatΘ Θ ∅ [] ∅
smashΘ {[]} = compat-[]
smashΘ {_ ∷ Θ} = compat-reduce-here smashΘ

extendΘ : ∀ {Θ} -> compatΘ [] ∅ Θ ∅
extendΘ {[]} = compat-[]
extendΘ {_ ∷ Θ} = compat-ext-here extendΘ

adjust∅Θ : ∀ {Θ Θ'} -> compatΘ Θ ∅ Θ' ∅
adjust∅Θ {[]} = extendΘ
adjust∅Θ {_ ∷ Θ} = compat-reduce-here adjust∅Θ

-- Some properties on compatΘ

compatΘ-∅ : ∀ {Θ Θ' Ξ'} -> compatΘ Θ ∅ Θ' Ξ' -> Ξ' ≡ ∅
compatΘ-∅ compat-[] = refl
compatΘ-∅ (compat-reduce-here ext) = compatΘ-∅ ext
compatΘ-∅ (compat-ext-here  ext) = cong (_∷_ zero) (compatΘ-∅ ext)
compatΘ-∅ (compat-skip ext) = cong (_∷_ zero) (compatΘ-∅ ext)

compatΘ-split :
  ∀ {Θ Ξ₁ Ξ₂ Θ' Ξ'} ->
  compatΘ Θ (Ξ₁ +ₘ Ξ₂) Θ' Ξ' ->
    ∃ λ (Ξ₁' : MultEnv (length Θ')) -> ∃ λ (Ξ₂' : MultEnv (length Θ')) ->
      compatΘ Θ Ξ₁ Θ' Ξ₁' × compatΘ Θ Ξ₂ Θ' Ξ₂' × Ξ₁' +ₘ Ξ₂' ≡ Ξ'
compatΘ-split {[]} {[]} {[]} {.[]} {.[]} compat-[] = ∅ , ∅ , compat-[] , compat-[] , refl
compatΘ-split {[]} {[]} {[]} {.(_ ∷ _)} {.(zero ∷ _)} (compat-ext-here ext)
  with compatΘ-split ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
   zero ∷ Ξ₁' , zero ∷ Ξ₂' , compat-ext-here ext₁ , compat-ext-here ext₂ , refl
compatΘ-split {x ∷ Θ} {zero ∷ Ξ₁} {.zero ∷ Ξ₂} {[]} {[]} (compat-reduce-here ext)
  with compatΘ-split ext
... | [] ,  [] , ext₁ , ext₂ , eq  =
  [] , [] , compat-reduce-here ext₁ , compat-reduce-here ext₂ , refl
compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {zero ∷ Ξ₂} {[]} {[]} ()
compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {one ∷ Ξ₂} {[]} {[]} ()
compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {omega ∷ Ξ₂} {[]} {[]} ()

compatΘ-split {x ∷ Θ} {zero ∷ Ξ₁} {x₂ ∷ Ξ₂} {x₃ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-split {x ∷ Θ} {zero ∷ Ξ₁} {x₂ ∷ Ξ₂}  ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
   zero ∷ Ξ₁' , zero ∷ Ξ₂' , compat-ext-here ext₁ , compat-ext-here ext₂ , refl
compatΘ-split {x ∷ Θ} {zero ∷ Ξ₁} {.zero ∷ Ξ₂} {x₃ ∷ Θ'} {x₄ ∷ Ξ'} (compat-reduce-here ext)
  with compatΘ-split ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , eq =
  Ξ₁' , Ξ₂' , compat-reduce-here ext₁ , compat-reduce-here ext₂ , eq
compatΘ-split {x ∷ Θ} {zero ∷ Ξ₁} {x₂ ∷ Ξ₂} {.x ∷ Θ'} {.x₂ ∷ Ξ'} (compat-skip ext)
  with compatΘ-split ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
  zero ∷ Ξ₁' , x₂ ∷ Ξ₂' , compat-skip ext₁ , compat-skip ext₂ , refl

compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {zero ∷ Ξ₂} {x₃ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {zero ∷ Ξ₂}  ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
   zero ∷ Ξ₁' , zero ∷ Ξ₂' , compat-ext-here ext₁ , compat-ext-here ext₂ , refl
compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {zero ∷ Ξ₂} {.x ∷ Θ'} {.one ∷ Ξ'} (compat-skip ext)
  with compatΘ-split ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
  one ∷ Ξ₁' , zero ∷ Ξ₂' , compat-skip ext₁ , compat-skip ext₂ , refl

compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {one ∷ Ξ₂} {x₃ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {one ∷ Ξ₂}  ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
   zero ∷ Ξ₁' , zero ∷ Ξ₂' , compat-ext-here ext₁ , compat-ext-here ext₂ , refl
compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {one ∷ Ξ₂} {.x ∷ Θ'} {.omega ∷ Ξ'} (compat-skip ext)
  with compatΘ-split ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
  one ∷ Ξ₁' , one ∷ Ξ₂' , compat-skip ext₁ , compat-skip ext₂ , refl

compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {omega ∷ Ξ₂} {x₃ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {omega ∷ Ξ₂}  ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
   zero ∷ Ξ₁' , zero ∷ Ξ₂' , compat-ext-here ext₁ , compat-ext-here ext₂ , refl
compatΘ-split {x ∷ Θ} {one ∷ Ξ₁} {omega ∷ Ξ₂} {.x ∷ Θ'} {.omega ∷ Ξ'} (compat-skip ext)
  with compatΘ-split ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
  one ∷ Ξ₁' , omega ∷ Ξ₂' , compat-skip ext₁ , compat-skip ext₂ , refl

compatΘ-split {x ∷ Θ} {omega ∷ Ξ₁} {x₂ ∷ Ξ₂} {x₃ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-split {x ∷ Θ} {omega ∷ Ξ₁} {x₂ ∷ Ξ₂}  ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
   zero ∷ Ξ₁' , zero ∷ Ξ₂' , compat-ext-here ext₁ , compat-ext-here ext₂ , refl
compatΘ-split {x ∷ Θ} {omega ∷ Ξ₁} {x₂ ∷ Ξ₂} {.x ∷ Θ'} {.omega ∷ Ξ'} (compat-skip ext)
  with compatΘ-split ext
... | Ξ₁' ,  Ξ₂' , ext₁ , ext₂ , refl =
  omega ∷ Ξ₁' , x₂ ∷ Ξ₂' , compat-skip ext₁ , compat-skip ext₂ , refl

compatΘ-preserves-all-no-omega :
  ∀ {Θ Ξ Θ' Ξ'} ->
  compatΘ Θ Ξ Θ' Ξ' -> all-no-omega Ξ -> all-no-omega Ξ'
compatΘ-preserves-all-no-omega compat-[] ano = ano
compatΘ-preserves-all-no-omega (compat-ext-here ext) ano = zero ∷ compatΘ-preserves-all-no-omega ext ano
compatΘ-preserves-all-no-omega (compat-reduce-here ext) (px ∷ ano) = compatΘ-preserves-all-no-omega ext ano
compatΘ-preserves-all-no-omega (compat-skip ext) (px ∷ ano) = px ∷ compatΘ-preserves-all-no-omega ext ano

compatΘ-preserves-all-zero :
  ∀ {Θ Ξ Θ' Ξ'} ->
  compatΘ Θ Ξ Θ' Ξ' -> all-zero Ξ -> all-zero Ξ'
compatΘ-preserves-all-zero compat-[] az = az
compatΘ-preserves-all-zero (compat-ext-here ext) az = refl ∷ compatΘ-preserves-all-zero ext az
compatΘ-preserves-all-zero (compat-reduce-here ext) (px ∷ az) = compatΘ-preserves-all-zero ext az
compatΘ-preserves-all-zero (compat-skip ext) (px ∷ az) = px ∷ compatΘ-preserves-all-zero ext az

compatΘ-preserves-varOk● :
  ∀ {Θ Ξ Θ' Ξ' A} {x : Θ ∋ A} ->
  compatΘ Θ Ξ Θ' Ξ' -> varOk● Θ x Ξ -> ∃ λ (x' : Θ' ∋ A) -> varOk● Θ' x' Ξ'
compatΘ-preserves-varOk● (compat-ext-here ext) ok with compatΘ-preserves-varOk● ext ok
... | x' , ok'  =  vs x' , there ok'
compatΘ-preserves-varOk● (compat-reduce-here ext) (there ok) = compatΘ-preserves-varOk● ext ok
compatΘ-preserves-varOk● (compat-skip ext) (there ok) with compatΘ-preserves-varOk● ext ok
... | x' , ok' = vs x' , there ok'
compatΘ-preserves-varOk● (compat-skip ext) (here ad) = vz , here (compatΘ-preserves-all-zero ext ad)

compatΘ-×ₘ :
  ∀ {Θ m Ξ Θ' Ξ'} ->
  compatΘ Θ (m ×ₘ Ξ) Θ' Ξ' ->
   ∃ λ (Ξ'' : MultEnv (length Θ')) ->
     compatΘ Θ Ξ Θ' Ξ'' × m ×ₘ Ξ'' ≡ Ξ'
compatΘ-×ₘ {[]} {m} {[]} {.[]} {.[]} compat-[] = [] , compat-[] , refl
compatΘ-×ₘ {[]} {m} {[]} {.(_ ∷ _)} {.(zero ∷ _)} (compat-ext-here ext) with compatΘ-×ₘ {[]} {m} {[]} ext
... | Ξ' , ext' , refl = zero ∷ Ξ' , compat-ext-here ext' , cong (_∷ m ×ₘ Ξ') (mul₀-m-zero _)

compatΘ-×ₘ {_ ∷ Θ} {one} {.zero ∷ Ξ} {[]} {[]} (compat-reduce-here ext) with compatΘ-×ₘ ext
... | [] , ext' , eq = [] , compat-reduce-here ext' , refl
compatΘ-×ₘ {_ ∷ Θ} {omega} {zero ∷ Ξ} {[]} {[]} (compat-reduce-here ext) with compatΘ-×ₘ ext
... | [] , ext' , eq = [] , compat-reduce-here ext' , refl

compatΘ-×ₘ {_ ∷ Θ} {one} {n ∷ Ξ} {_ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-×ₘ ext
... | Ξ'' , ext' , refl = zero ∷ Ξ'' , compat-ext-here ext' , refl
compatΘ-×ₘ {_ ∷ Θ} {one} {.zero ∷ Ξ} {_ ∷ Θ'} {n' ∷ Ξ'} (compat-reduce-here ext)
  with compatΘ-×ₘ ext
... | Ξ'' , ext' , eq = Ξ'' , compat-reduce-here ext' , eq
compatΘ-×ₘ {_ ∷ Θ} {one} {n ∷ Ξ} {_ ∷ Θ'} {.n ∷ Ξ'} (compat-skip ext)
  with compatΘ-×ₘ ext
... | Ξ'' , ext' , refl = n ∷ Ξ'' , compat-skip ext' , refl

compatΘ-×ₘ {_ ∷ Θ} {omega} {zero ∷ Ξ} {_ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-×ₘ {m = omega} {zero ∷ Ξ} ext
... | Ξ'' , ext' , refl = zero ∷ Ξ'' , compat-ext-here ext' , refl
compatΘ-×ₘ {_ ∷ Θ} {omega} {zero ∷ Ξ} {_ ∷ Θ'} {n' ∷ Ξ'} (compat-reduce-here ext)
  with compatΘ-×ₘ ext
... | Ξ'' , ext' , eq = Ξ'' , compat-reduce-here ext' , eq
compatΘ-×ₘ {_ ∷ Θ} {omega} {zero ∷ Ξ} {_ ∷ Θ'} {.zero ∷ Ξ'} (compat-skip ext)
  with compatΘ-×ₘ ext
... | Ξ'' , ext' , refl = zero ∷ Ξ'' , compat-skip ext' , refl

compatΘ-×ₘ {_ ∷ Θ} {omega} {one ∷ Ξ} {_ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-×ₘ {m = omega} {one ∷ Ξ} ext
... | Ξ'' , ext' , refl = zero ∷ Ξ'' , compat-ext-here ext' , refl
compatΘ-×ₘ {_ ∷ Θ} {omega} {one ∷ Ξ} {_ ∷ Θ'} {.omega ∷ Ξ'} (compat-skip ext)
  with compatΘ-×ₘ ext
... | Ξ'' , ext' , refl = one ∷ Ξ'' , compat-skip ext' , refl

compatΘ-×ₘ {_ ∷ Θ} {omega} {omega ∷ Ξ} {_ ∷ Θ'} {.zero ∷ Ξ'} (compat-ext-here ext)
  with compatΘ-×ₘ {m = omega} {omega ∷ Ξ} ext
... | Ξ'' , ext' , refl = zero ∷ Ξ'' , compat-ext-here ext' , refl
compatΘ-×ₘ {_ ∷ Θ} {omega} {omega ∷ Ξ} {_ ∷ Θ'} {.omega ∷ Ξ'} (compat-skip ext)
  with compatΘ-×ₘ ext
... | Ξ'' , ext' , refl = omega ∷ Ξ'' , compat-skip ext' , refl

-- Well-typed terms can also be typed compatible environments.Due to a
-- historical reason, this property is called weakenΘ-term as
-- compatΘ was initially used only for adding variables with
-- multiplicity zero.

weakenΘ-term : ∀ {Γ Δ Θ Ξ Θ' Ξ' A} ->
                  compatΘ Θ Ξ Θ' Ξ' ->
                  Term Γ Δ Θ  Ξ A ->
                  Term Γ Δ Θ' Ξ' A
weakenΘ-term ext (var x ok) with compatΘ-∅ ext
... | refl = var x ok
weakenΘ-term ext (abs m t) = abs m (weakenΘ-term ext t)
weakenΘ-term ext (app t₁ t₂) with compatΘ-split ext
... | Ξ₁' , Ξ₂' , ext₁ , ext₂ , refl with compatΘ-×ₘ ext₂
... | Ξ₂'' , ext₂' , refl = app (weakenΘ-term ext₁ t₁) (weakenΘ-term ext₂' t₂)
weakenΘ-term ext (unit ad) with compatΘ-∅ ext
... | refl = unit ad
weakenΘ-term ext (letunit m t₁ t₂) with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl with compatΘ-×ₘ ext₁
... | Ξ₁'' , ext₁' , refl = letunit m (weakenΘ-term ext₁' t₁) (weakenΘ-term ext₂ t₂)
weakenΘ-term ext (pair t₁ t₂) with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl = pair (weakenΘ-term ext₁ t₁) (weakenΘ-term ext₂ t₂)
weakenΘ-term ext (letpair m t₁ t₂) with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl with compatΘ-×ₘ ext₁
... | Ξ₁'' , ext₁' , refl = letpair m (weakenΘ-term ext₁' t₁) (weakenΘ-term ext₂ t₂)

weakenΘ-term ext (many m t) with compatΘ-×ₘ ext
... | Ξ'' , ext' , refl = many m (weakenΘ-term ext' t)

weakenΘ-term ext (unmany m' t₁ t₂) with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl with compatΘ-×ₘ ext₁
... | Ξ₁'' , ext₁' , refl = unmany m' (weakenΘ-term ext₁' t₁) (weakenΘ-term ext₂ t₂)

weakenΘ-term ext (inl t) = inl (weakenΘ-term ext t)
weakenΘ-term ext (inr t) = inr (weakenΘ-term ext t)
weakenΘ-term ext (case m t₀ t₁ t₂) with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl with compatΘ-×ₘ ext₁
... | Ξ₁'' , ext₁' , refl = case m (weakenΘ-term ext₁' t₀) (weakenΘ-term ext₂ t₁) (weakenΘ-term ext₂ t₂)
weakenΘ-term ext (roll t)   = roll (weakenΘ-term ext t)
weakenΘ-term ext (unroll t) = unroll (weakenΘ-term ext t)
weakenΘ-term ext (unit● ad) with compatΘ-∅ ext
... | refl  = unit● ad
weakenΘ-term ext (letunit● t₁ t₂)
  with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl = letunit● (weakenΘ-term ext₁ t₁) (weakenΘ-term ext₂ t₂)
weakenΘ-term ext (pair● t₁ t₂)
  with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl = pair● (weakenΘ-term ext₁ t₁) (weakenΘ-term ext₂ t₂)
weakenΘ-term ext (letpair● t₁ t₂)
  with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl = letpair● (weakenΘ-term ext₁ t₁) (weakenΘ-term (compat-skip (compat-skip ext₂)) t₂)
weakenΘ-term ext (inl● t) = inl● (weakenΘ-term ext t)
weakenΘ-term ext (inr● t) = inr● (weakenΘ-term ext t)
weakenΘ-term ext (case● t t₁ t₂ t₃)
  with compatΘ-split ext
... | _ , _ , ext₁₂ , ext₃ , refl with compatΘ-split ext₁₂
... | _ , _ , ext₁ , ext₂ , refl with compatΘ-×ₘ ext₃
... | _ , ext₃' , refl = case● (weakenΘ-term ext₁ t) (weakenΘ-term (compat-skip ext₂) t₁) (weakenΘ-term (compat-skip ext₂) t₂) (weakenΘ-term ext₃' t₃)
weakenΘ-term ext (var● x ad ok) with compatΘ-preserves-varOk● ext ok
... | x' , ok' = var● x' ad ok'
weakenΘ-term ext (pin t₁ t₂)
  with compatΘ-split ext
... | Ξ₁'  , Ξ₂' , ext₁ , ext₂ , refl = pin (weakenΘ-term ext₁ t₁) (weakenΘ-term ext₂ t₂)
weakenΘ-term ext (unlift t) =
  CASE compatΘ-×ₘ ext OF λ {
    (_ , ext' , refl) -> unlift (weakenΘ-term ext' t)
  }
weakenΘ-term ext (fapp t₁ t₂) =
  CASE compatΘ-split ext OF λ {
    (_ , _ , ext₁ , ext₂ , refl) -> CASE compatΘ-×ₘ ext₂ OF λ {
      (_ , ext₂' , refl) -> fapp (weakenΘ-term ext₁ t₁) (weakenΘ-term ext₂' t₂)
    }
  }
weakenΘ-term ext (bapp t₁ t₂) =
  CASE compatΘ-split ext OF λ {
    (_ , _ , ext₁ , ext₂ , refl) -> CASE compatΘ-×ₘ ext₂ OF λ {
      (_ , ext₂' , refl) -> bapp (weakenΘ-term ext₁ t₁) (weakenΘ-term ext₂' t₂)
    }
  }


----------------------------------------------------------------------
-- Copyright: 2013, Jan Stolarek, Lodz University of Technology     --
--                                                                  --
-- License: See LICENSE file in root of the repo                    --
-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps   --
--                                                                  --
-- Weight biased leftist heap that proves to maintain priority      --
-- invariant and uses a single-pass merging algorithm.              --
----------------------------------------------------------------------

{-# OPTIONS --sized-types #-}
module SinglePassMerge.PriorityProof where

open import Basics.Nat renaming (_≥_ to _≥ℕ_)
open import Basics
open import Sized

data Heap : {i : Size} → Priority → Set where
  empty : {i : Size} {n : Priority} → Heap {↑ i} n
  node  : {i : Size} {n : Priority} → (p : Priority) → Rank → p ≥ n →
          Heap {i} p → Heap {i} p → Heap {↑ i} n

rank : {b : Priority} → Heap b → Rank
rank empty            = zero
rank (node _ r _ _ _) = r

-- This implementation is derived in the same way as merge in
-- SinglePassMerge.NoProofs: depending on the size of new children we
-- swap parameters passed to node. Nothing really interesting.
merge : {i j : Size} {p : Nat} → Heap {i} p → Heap {j} p → Heap p
merge empty h2 = h2
merge h1 empty = h1
merge .{↑ i} .{↑ j}
  (node {i} p1 l-rank p1≥p l1 r1)
  (node {j} p2 r-rank p2≥p l2 r2)
  with order p1 p2
  | rank l1 ≥ℕ rank r1 + r-rank
  | rank l2 ≥ℕ rank r2 + l-rank
merge .{↑ i} .{↑ j}
  (node {i} p1 l-rank p1≥p l1 r1)
  (node {j} p2 r-rank p2≥p l2 r2)
  | le p1≤p2 | true | _
  = node p1 (l-rank + r-rank) p1≥p l1 (merge {i} {↑ j} r1 (node p2 r-rank p1≤p2 l2 r2))
merge .{↑ i} .{↑ j}
  (node {i} p1 l-rank p1≥p l1 r1)
  (node {j} p2 r-rank p2≥p l2 r2)
  | le p1≤p2 | false | _
  = node p1 (l-rank + r-rank) p1≥p (merge {i} {↑ j} r1 (node p2 r-rank p1≤p2 l2 r2)) l1
merge .{↑ i} .{↑ j}
  (node {i} p1 l-rank p1≥p l1 r1)
  (node {j} p2 r-rank p2≥p l2 r2)
  | ge p2≤p1 | _ | true
  = node p2 ((l-rank + r-rank)) p2≥p l2 (merge {↑ i} {j} (node p1 l-rank p2≤p1 l1 r1) r2)
merge .{↑ i} .{↑ j}
  (node {i} p1 l-rank p1≥p l1 r1)
  (node {j} p2 r-rank p2≥p l2 r2)
  | ge p2≤p1 | _ | false
  = node p2 ((l-rank + r-rank)) p2≥p (merge {↑ i} {j} (node p1 l-rank p2≤p1 l1 r1) r2) l2


module m-types where

-- Basic definitions
import container.core

-- Construction of M-types as limits
import container.m.from-nat

-- M-types via Agda coinduction
import container.m.core


module Categories.Functor.Monoidal where


{-# OPTIONS --safe --warning=error #-}

open import Sets.EquivalenceRelations
open import Functions.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_; Setω)
open import Setoids.Setoids
open import Groups.Definition
open import LogicalFormulae
open import Orders.WellFounded.Definition
open import Numbers.Naturals.Semiring
open import Groups.Lemmas

module Groups.FreeProduct.Group {i : _} {I : Set i} (decidableIndex : (x y : I) → ((x ≡ y) || ((x ≡ y) → False))) {a b : _} {A : I → Set a} {S : (i : I) → Setoid {a} {b} (A i)} {_+_ : (i : I) → (A i) → (A i) → A i} (decidableGroups : (i : I) → (x y : A i) → ((Setoid._∼_ (S i) x y)) || ((Setoid._∼_ (S i) x y) → False)) (G : (i : I) → Group (S i) (_+_ i)) where

open import Groups.FreeProduct.Definition decidableIndex decidableGroups G
open import Groups.FreeProduct.Setoid decidableIndex decidableGroups G
open import Groups.FreeProduct.Addition decidableIndex decidableGroups G

private
  plus'WDlemm : {i : I} (x1 x2 : ReducedSequenceBeginningWith i) (y : ReducedSequence) → (=RP' x1 x2) → plus' x1 y =RP plus' x2 y
  plus'WDlemm (ofEmpty i g nonZero) (ofEmpty .i g₁ nonZero₁) y x1=x2 with decidableIndex i i
  plus'WDlemm (ofEmpty i g nonZero) (ofEmpty .i h nonZero2) y x1=x2 | inl refl = prependWD g h nonZero nonZero2 y x1=x2
  plus'WDlemm (prependLetter i g nonZero {j} x1 x) (prependLetter .i h nonZero2 {j2} x2 pr) y x1=x2 with decidableIndex i i
  ... | inl refl with decidableIndex j j2
  plus'WDlemm (prependLetter i g nonZero {j} x1 x) (prependLetter .i h nonZero2 {.j} x2 pr) y x1=x2 | inl refl | inl refl = Equivalence.transitive (Setoid.eq freeProductSetoid) {prepend i g nonZero (plus' x1 y)} {prepend i h nonZero2 (plus' x1 y)} {plus' (prependLetter i h nonZero2 x2 pr) y} (prependWD g h nonZero nonZero2 (plus' x1 y) (_&&_.fst x1=x2)) (prependWD' h nonZero2 (plus' x1 y) (plus' x2 y) (plus'WDlemm x1 x2 y (_&&_.snd x1=x2)))
  ... | inr j!=j2 = exFalso (notEqualIfStartDifferent j!=j2 x1 x2 (_&&_.snd x1=x2))
  plus'WDlemm _ _ _ _ | inr bad = exFalso (bad refl)

  plus'WD : {i j : I} (x1 : ReducedSequenceBeginningWith i) (x2 : ReducedSequenceBeginningWith j) (y : ReducedSequence) → (=RP' x1 x2) → plus' x1 y =RP plus' x2 y
  plus'WD {i} {j} x1 x2 y x1=x2 with decidableIndex i j
  plus'WD {i} {.i} x1 x2 y x1=x2 | inl refl = plus'WDlemm x1 x2 y x1=x2
  plus'WD {i} {j} x1 x2 y x1=x2 | inr x = exFalso (notEqualIfStartDifferent x x1 x2 x1=x2)
  plusWD : (m n o p : ReducedSequence) → (m =RP o) → (n =RP p) → (m +RP n) =RP (o +RP p)
  plusWD empty empty empty empty m=o n=p = record {}
  plusWD empty (nonempty i x) empty (nonempty i₁ x₁) m=o n=p = n=p
  plusWD (nonempty i x) empty (nonempty j y) empty m=o record {} = Equivalence.transitive (Setoid.eq freeProductSetoid) {plus' x empty} {nonempty i x} {plus' y empty} (plusEmptyRight x) (Equivalence.transitive (Setoid.eq freeProductSetoid) {nonempty i x} {nonempty j y} {plus' y empty} m=o (Equivalence.symmetric (Setoid.eq freeProductSetoid) {plus' y empty} {nonempty j y} (plusEmptyRight y)))
  plusWD (nonempty i1 x1) (nonempty i2 x2) (nonempty i3 x3) (nonempty i4 x4) m=o n=p = (Equivalence.transitive (Setoid.eq freeProductSetoid)) {plus' x1 (nonempty i2 x2)} {plus' x3 (nonempty i2 x2)} {plus' x3 (nonempty i4 x4)} (plus'WD x1 x3 (nonempty i2 x2) m=o) (plus'WD' x3 (nonempty i2 x2) (nonempty i4 x4) n=p)

  prependAssocLemma' : {i : I} {g : A i} .(nz : Setoid._∼_ (S i) g (Group.0G (G i)) → False) (b c : ReducedSequence) → (prepend i g nz b +RP c) =RP prepend i g nz (b +RP c)
  prependAssocLemma' {i} {g} nz empty c = Equivalence.reflexive (Setoid.eq freeProductSetoid) {prepend i g _ c}
  prependAssocLemma' {i} nz (nonempty k x) c with decidableIndex i k
  prependAssocLemma' {.k} {g1} nz (nonempty k (ofEmpty .k g nonZero)) c | inl refl with decidableGroups k ((k + g1) g) (Group.0G (G k))
  prependAssocLemma' {.k} {g1} nz (nonempty k (ofEmpty .k g nonZero)) c | inl refl | inl eq1 = Equivalence.symmetric (Setoid.eq freeProductSetoid) {prepend k g1 _ (prepend k g _ c)} {c} (prependFrom' g1 g eq1 c nz nonZero)
  prependAssocLemma' {.k} {g1} nz (nonempty k (ofEmpty .k g nonZero)) c | inl refl | inr neq1 = (prependFrom g1 g neq1 c nz nonZero)
  prependAssocLemma' {.k} {g1} nz (nonempty k (prependLetter .k g nonZero x x₁)) c | inl refl with decidableGroups k ((k + g1) g) (Group.0G (G k))
  prependAssocLemma' {.k} {g1} nz (nonempty k (prependLetter .k g nonZero x x₁)) c | inl refl | inl eq1 = Equivalence.symmetric (Setoid.eq freeProductSetoid) {prepend k g1 _ (prepend k g _ (plus' x c))} {plus' x c} (prependFrom' g1 g eq1 (plus' x c) nz nonZero)
  prependAssocLemma' {.k} {g1} nz (nonempty k (prependLetter .k g nonZero x x₁)) c | inl refl | inr neq1 = prependFrom g1 g neq1 (plus' x c) nz nonZero
  prependAssocLemma' {i} {g} nz (nonempty k x) c | inr i!=k = Equivalence.reflexive (Setoid.eq freeProductSetoid) {prepend i g _ (plus' x c)}

  plusAssocLemma : {i : I} (x : ReducedSequenceBeginningWith i) (b c : ReducedSequence) → (plus' x b +RP c) =RP plus' x (b +RP c)
  plusAssocLemma (ofEmpty i g nonZero) empty c = Equivalence.reflexive (Setoid.eq freeProductSetoid) {prepend i g _ c}
  plusAssocLemma (ofEmpty i g nonZero) (nonempty j b) c with decidableIndex i j
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (ofEmpty .i g₁ nonZero₁)) c | inl refl with decidableIndex i i
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (ofEmpty .i h nonZero₁)) c | inl refl | inl refl with decidableGroups i ((i + g) h) (Group.0G (G i))
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (ofEmpty .i h nonZero₁)) c | inl refl | inl refl | inl t = Equivalence.symmetric (Setoid.eq freeProductSetoid) {prepend i g _ (prepend i h _ c)} {c} (prependFrom' g h t c _ _)
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (ofEmpty .i h nonZero₁)) c | inl refl | inl refl | inr t = prependFrom g h t c _ _
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (ofEmpty .i g₁ nonZero₁)) c | inl refl | inr bad = exFalso (bad refl)
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (prependLetter .i h nonZero₁ b x)) c | inl refl with decidableGroups i ((i + g) h) (Group.0G (G i))
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (prependLetter .i h nonZero₁ b x)) c | inl refl | inl eq1 = Equivalence.symmetric (Setoid.eq freeProductSetoid) {prepend i g _ (prepend i h _ (plus' b c))} {plus' b c} (prependFrom' g h eq1 (plus' b c) _ _)
  plusAssocLemma (ofEmpty i g nonZero) (nonempty .i (prependLetter .i h nonZero₁ b x)) c | inl refl | inr neq1 = prependFrom g h neq1 (plus' b c) nonZero _
  plusAssocLemma (ofEmpty i g nonZero) (nonempty j b) c | inr i!=j = Equivalence.reflexive (Setoid.eq freeProductSetoid) {prepend i g _ (plus' b c)}
  plusAssocLemma (prependLetter i g nonZero {j} w i!=j) b c = Equivalence.transitive (Setoid.eq freeProductSetoid) {prepend i g _ (plus' w b) +RP c} {prepend i g _ (plus' w b +RP c)} {prepend i g _ (plus' w (b +RP c))} (prependAssocLemma' nonZero (plus' w b) c) (prependWD' g nonZero (plus' w b +RP c) (plus' w (b +RP c)) (plusAssocLemma w b c))

  plusAssoc : (a b c : ReducedSequence) → ((a +RP b) +RP c) =RP (a +RP (b +RP c))
  plusAssoc empty b c = Equivalence.reflexive (Setoid.eq freeProductSetoid) {b +RP c}
  plusAssoc (nonempty i x) b c = plusAssocLemma x b c

private
  inv' : {i : I} (x : ReducedSequenceBeginningWith i) → ReducedSequence
  inv' (ofEmpty i g nonZero) = nonempty i (ofEmpty i (Group.inverse (G i) g) (λ pr → nonZero (Equivalence.transitive (Setoid.eq (S i)) (swapInv (G i) pr) (invIdent (G i)))))
  inv' (prependLetter i g nonZero {j} w i!=j) = (inv' w) +RP injection (Group.inverse (G i) g) (λ pr → nonZero (Equivalence.transitive (Setoid.eq (S i)) (swapInv (G i) pr) (invIdent (G i))))

  inv : (x : ReducedSequence) → ReducedSequence
  inv empty = empty
  inv (nonempty i w) = inv' w

private
  abstract
    lemma1 : {i j k : I} (i!=j : (i ≡ j) → False) (g : A i) (h : A j) (w : ReducedSequenceBeginningWith k) (j!=k : (j ≡ k) → False) → .(pr : _) .(pr2 : _) .(pr3 : _) → (prepend i (Group.inverse (G i) g) pr (nonempty i (prependLetter i g pr2 (prependLetter j h pr3 w j!=k) i!=j))) =RP nonempty j (prependLetter j h pr3 w j!=k)
    lemma1 {i} {j} {k} i!=j g h r j!=k pr pr2 pr3 with decidableIndex i i
    ... | inr x = exFalso (x refl)
    lemma1 {i} {j} {k} i!=j g h r j!=k pr pr2 pr3 | inl refl with decidableGroups i ((i + Group.inverse (G i) g) g) (Group.0G (G i))
    ... | inr bad = exFalso (bad (Group.invLeft (G i)))
    lemma1 {i} {j} {k} i!=j g h r j!=k pr pr2 pr3 | inl refl | inl eq1 with decidableIndex j j
    ... | inr bad = exFalso (bad refl)
    ... | inl refl = Equivalence.reflexive (Setoid.eq (S j)) ,, =RP'reflex r

  abstract
    lemma2 : {j k : I} (j!=k : (j ≡ k) → False) (h : A j) (w : ReducedSequenceBeginningWith k) .(pr : _) .(pr2 : _) → (prepend j (Group.inverse (G j) h) pr (nonempty j (prependLetter j h pr2 w j!=k))) =RP (nonempty k w)
    lemma2 {j} {k} j!=k h r pr pr2 with decidableIndex j j
    ... | inr bad = exFalso (bad refl)
    lemma2 {j} {k} j!=k h r pr pr2 | inl refl with decidableGroups j ((j + Group.inverse (G j) h) h) (Group.0G (G j))
    ... | inr bad = exFalso (bad (Group.invLeft (G j)))
    ... | inl x = =RP'reflex r

  abstract
    unpeel : (k : ReducedSequence) {j : I} (g : A j) .(pr : _) .(pr2 : _) → k =RP empty → (prepend j g pr (k +RP (nonempty j (ofEmpty j (Group.inverse (G j) g) pr2)))) =RP empty
    unpeel empty {j} g pr pr2 x with decidableIndex j j
    ... | inr bad = exFalso (bad refl)
    unpeel empty {j} g pr pr2 x | inl refl with decidableGroups j ((j + g) (Group.inverse (G j) g)) (Group.0G (G j))
    ... | inl _ = record {}
    ... | inr bad = exFalso (bad (Group.invRight (G j)))

  abstract
    invRight' : {i : I} (x : ReducedSequenceBeginningWith i) → ((nonempty i x) +RP inv (nonempty i x)) =RP empty
    invRight' {i} (ofEmpty _ g nonZero) with decidableIndex i i
    ... | inr x = exFalso (x refl)
    invRight' {i} (ofEmpty _ g nonZero) | inl refl with decidableGroups i ((i + g) (Group.inverse (G i) g)) (Group.0G (G i))
    ... | inr x = exFalso (x (Group.invRight (G i)))
    ... | inl x = record {}
    invRight' {j} (prependLetter _ g nonZero {k} (ofEmpty .k h nonZero1) j!=k) with decidableIndex k j
    ... | inl x = exFalso (j!=k (equalityCommutative x))
    invRight' {j} (prependLetter _ g nonZero {k} (ofEmpty .k h nonZero1) j!=k) | inr _ with decidableIndex k k
    ... | inr x = exFalso (x refl)
    invRight' {j} (prependLetter _ g nonZero {k} (ofEmpty .k h nonZero1) j!=k) | inr _ | inl refl with decidableGroups k ((k + h) (Group.inverse (G k) h)) (Group.0G (G k))
    ... | inr x = exFalso (x (Group.invRight (G k)))
    invRight' {j} (prependLetter _ g nonZero {k} (ofEmpty .k h nonZero1) j!=k) | inr _ | inl refl | inl _ with decidableIndex j j
    ... | inr x = exFalso (x refl)
    invRight' {j} (prependLetter _ g nonZero {k} (ofEmpty .k h nonZero1) j!=k) | inr _ | inl refl | inl _ | inl refl with decidableGroups j ((j + g) (Group.inverse (G j) g)) (Group.0G (G j))
    ... | inr bad = exFalso (bad (Group.invRight (G j)))
    ... | inl r = record {}
    invRight' {j} (prependLetter _ g nonZero {k} (prependLetter .k h nonZero1 {i} x k!=i) j!=k) rewrite refl {x = 0} = Equivalence.transitive (Setoid.eq freeProductSetoid) {prepend j g _ (prepend k h _ (plus' x ((inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) _)) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) _))))} {prepend j g nonZero (prepend k h nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G k) t)))) +RP (nonempty j (ofEmpty j (Group.inverse (G j) g) λ t → nonZero (invZeroImpliesZero (G j) t))))} {empty} (prependWD' g nonZero (prepend k h nonZero1 (plus' x ((inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) _)) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) λ t → nonZero (invZeroImpliesZero (G j) t))))) (prepend k h _ (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G k) t)))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) λ i → nonZero (invZeroImpliesZero (G j) i))) (Equivalence.symmetric (Setoid.eq freeProductSetoid) {(prepend k h _ (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) _))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) _))} {prepend k h _ (plus' x ((inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) _)) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) _)))} t)) (unpeel (prepend k h nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) _)))) g nonZero (λ t → nonZero (invZeroImpliesZero (G j) t)) (Equivalence.transitive (Setoid.eq freeProductSetoid) {prepend k h nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G k) t))))} {prepend k h nonZero1 ((plus' x (inv' x)) +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G k) t)))} {empty} (prependWD' h nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G k) t)))) (plus' x (inv' x) +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G k) t))) (Equivalence.symmetric (Setoid.eq freeProductSetoid) {plus' x (inv' x) +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G k) t))} (plusAssoc (nonempty _ x) (inv' x) (nonempty k (ofEmpty k (Group.inverse (G k) h) (λ t → nonZero1 (invZeroImpliesZero (G k) t))))))) (unpeel (plus' x (inv' x)) h nonZero1 (λ t → nonZero1 (invZeroImpliesZero (G k) t)) (invRight' x))))
      where
        t : (prepend k h nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) (λ t → nonZero1 (invZeroImpliesZero (G _) t))))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) (λ t → nonZero (invZeroImpliesZero (G j) t)))) =RP (prepend k h nonZero1 (plus' x ((inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) (λ t → nonZero1 (invZeroImpliesZero (G _) t)))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) (λ t → nonZero (invZeroImpliesZero (G j) t))))))
        t = Equivalence.transitive (Setoid.eq freeProductSetoid) {(prepend k h nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) (λ t → nonZero1 (invZeroImpliesZero (G _) t))))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) (λ t → nonZero (invZeroImpliesZero (G j) t))))} {prepend k h _ (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G _) t))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) λ t → nonZero (invZeroImpliesZero (G _) t)))} {(prepend k h nonZero1 (plus' x ((inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) (λ t → nonZero1 (invZeroImpliesZero (G _) t)))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) (λ t → nonZero (invZeroImpliesZero (G j) t))))))} (prependAssocLemma' {k} {h} nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) _))) (nonempty j (ofEmpty j (Group.inverse (G j) g) _))) (prependWD' h nonZero1 (plus' x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G _) t))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) λ t → nonZero (invZeroImpliesZero (G _) t))) (plus' x ((inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G _) t))) +RP nonempty j (ofEmpty j (Group.inverse (G j) g) λ t → nonZero (invZeroImpliesZero (G _) t)))) (plusAssocLemma x (inv' x +RP nonempty k (ofEmpty k (Group.inverse (G k) h) λ t → nonZero1 (invZeroImpliesZero (G _) t))) (nonempty j (ofEmpty j (Group.inverse (G j) g) λ t → nonZero (invZeroImpliesZero (G _) t)))))

  abstract
    invRight : (x : ReducedSequence) → (x +RP (inv x)) =RP empty
    invRight empty = record {}
    invRight (nonempty i w) = invRight' {i} w

  abstract
    invLeft' : {i : I} (x : ReducedSequenceBeginningWith i) → (inv (nonempty i x) +RP (nonempty i x)) =RP empty
    invLeft' {i} (ofEmpty .i g nonZero) with decidableIndex i i
    invLeft' {i} (ofEmpty .i g nonZero) | inl refl with decidableGroups i ((i + Group.inverse (G i) g) g) (Group.0G (G i))
    ... | inl good = record {}
    ... | inr bad = exFalso (bad (Group.invLeft (G i) {g}))
    invLeft' {i} (ofEmpty .i g nonZero) | inr x = exFalso (x refl)
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j g₁ nonZero₁) i!=j) with decidableIndex j i
    ... | inl pr = exFalso (i!=j (equalityCommutative pr))
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j g₁ nonZero₁) i!=j) | inr pr with decidableIndex i i
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j g₁ nonZero₁) i!=j) | inr pr | inl refl with decidableGroups i ((i + Group.inverse (G i) g) g) (Group.0G (G i))
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j g₁ nonZero₁) i!=j) | inr pr | inl refl | inl k with decidableIndex j j
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j h nonZero₁) i!=j) | inr pr | inl refl | inl k | inl refl with decidableGroups j ((j + Group.inverse (G j) h) h) (Group.0G (G j))
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j h nonZero₁) i!=j) | inr pr | inl refl | inl k | inl refl | inl good = record {}
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j h nonZero₁) i!=j) | inr pr | inl refl | inl k | inl refl | inr bad = exFalso (bad (Group.invLeft (G j)))
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j g₁ nonZero₁) i!=j) | inr pr | inl refl | inl k | inr bad = exFalso (bad refl)
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j g₁ nonZero₁) i!=j) | inr pr | inl refl | inr k = exFalso (k (Group.invLeft (G i) {g}))
    invLeft' {i} (prependLetter .i g nonZero {.j} (ofEmpty j g₁ nonZero₁) i!=j) | inr pr | inr bad = exFalso (bad refl)
    invLeft' {i} (prependLetter .i g nonZero {.j} (prependLetter j h nonZero1 {k} w x) i!=j) = Equivalence.transitive (Setoid.eq freeProductSetoid) {(((inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)) +RP nonempty i (ofEmpty i (Group.inverse (G i) g) _)) +RP nonempty i (prependLetter i g _ (prependLetter j h _ w x) i!=j))} {_} {empty} (plusAssoc (inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)) (nonempty i (ofEmpty i (Group.inverse (G i) g) _)) (nonempty i (prependLetter i g _ (prependLetter j h _ w x) i!=j))) (Equivalence.transitive (Setoid.eq freeProductSetoid) {((inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)) +RP (prepend i (Group.inverse (G i) g) _ (nonempty i (prependLetter i g _ (prependLetter j h _ w x) i!=j))))} {(inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)) +RP (nonempty j (prependLetter j h nonZero1 w x))} {empty} (plusWD (inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)) (prepend i (Group.inverse (G i) g) _ (nonempty i (prependLetter i g _ (prependLetter j h _ w x) i!=j))) (inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)) (nonempty j (prependLetter j h _ w x)) (Equivalence.reflexive (Setoid.eq freeProductSetoid) {inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)}) (lemma1 {i} {j} {k} i!=j g h w x (λ p → nonZero (invZeroImpliesZero (G i) p)) nonZero nonZero1)) (Equivalence.transitive (Setoid.eq freeProductSetoid) {(inv' w +RP nonempty j (ofEmpty j (Group.inverse (G j) h) _)) +RP nonempty j (prependLetter j h _ w x)} {inv' w +RP (nonempty j (ofEmpty j (Group.inverse (G j) h) λ p → nonZero1 (invZeroImpliesZero (G j) p)) +RP nonempty j (prependLetter j h nonZero1 w x))} {empty} (plusAssoc (inv' w) (nonempty j (ofEmpty j (Group.inverse (G j) h) _)) (nonempty j (prependLetter j h _ w x))) (Equivalence.transitive (Setoid.eq freeProductSetoid) {inv' w +RP (prepend j (Group.inverse (G j) h) _ (nonempty j (prependLetter j h nonZero1 w x)))} {inv' w +RP (nonempty k w)} {empty} (plusWD (inv' w) (prepend j (Group.inverse (G j) h) _ (nonempty j (prependLetter j h nonZero1 w x))) (inv' w) (nonempty k w) (Equivalence.reflexive (Setoid.eq freeProductSetoid) {inv' w}) (lemma2 {j} {k} x h w (λ p → nonZero1 (invZeroImpliesZero (G j) p)) nonZero1)) (invLeft' {k} w))))

  abstract
    invLeft : (x : ReducedSequence) → ((inv x) +RP x) =RP empty
    invLeft empty = record {}
    invLeft (nonempty i w) = invLeft' {i} w

FreeProductGroup : Group freeProductSetoid _+RP_
Group.+WellDefined FreeProductGroup {m} {n} {x} {y} m=x n=y = plusWD m n x y m=x n=y
Group.0G FreeProductGroup = empty
Group.inverse FreeProductGroup = inv
Group.+Associative FreeProductGroup {a} {b} {c} = Equivalence.symmetric (Setoid.eq freeProductSetoid) {(a +RP b) +RP c} {a +RP (b +RP c)} (plusAssoc a b c)
Group.identRight FreeProductGroup {empty} = Equivalence.reflexive (Setoid.eq freeProductSetoid) {empty}
Group.identRight FreeProductGroup {nonempty i x} rewrite refl {x = 0} = plusEmptyRight x
Group.identLeft FreeProductGroup {empty} = Equivalence.reflexive (Setoid.eq freeProductSetoid) {empty}
Group.identLeft FreeProductGroup {nonempty i x} = Equivalence.reflexive (Setoid.eq freeProductSetoid) {nonempty i x}
Group.invLeft FreeProductGroup {x} = invLeft x
Group.invRight FreeProductGroup {x} = invRight x


data ⊤ : Set where tt : ⊤

postulate
  IndexL        : Set
  Ordered       : IndexL → Set
  ¬ho-shr-morph : IndexL → IndexL
  pres-¬ord     : ∀ ind → Ordered (¬ho-shr-morph ind)
  ¬ord-morph    : ∀ ind → Ordered ind → Set

postulate tt' : ⊤

poo : ∀ ind → ¬ord-morph (¬ho-shr-morph ind) (pres-¬ord ind)
poo ind with tt | ¬ho-shr-morph ind
... | _ | _ = {!!}


{-# OPTIONS --cubical --safe #-}

module Data.Empty.UniversePolymorphic where

open import Prelude hiding (⊥)
import Data.Empty as Monomorphic

data ⊥ {ℓ} : Type ℓ where

Poly⊥⇔Mono⊥ : ∀ {ℓ} → ⊥ {ℓ} ⇔ Monomorphic.⊥
Poly⊥⇔Mono⊥ .fun      ()
Poly⊥⇔Mono⊥ .inv      ()
Poly⊥⇔Mono⊥ .leftInv  ()
Poly⊥⇔Mono⊥ .rightInv ()


module Issue1258 where

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

data Bool : Set where
  true false : Bool

postulate f : (A : Set) -> A -> Bool

Foo : Bool -> Set
Foo true = Bool
Foo false = Bool

Alpha : Bool
Beta : Foo Alpha

test : f (Foo Alpha) Beta == f Bool false

Alpha = _
Beta = Alpha
test = refl

-- Normalizing Alpha yields a metavariable, but normalizing Beta yields
-- false.


module Inductive.Examples.Unit where

open import Inductive
open import Tuple

open import Data.Fin
open import Data.Product
open import Data.List
open import Data.Vec

⊤ : Set
⊤ = Inductive (([] , []) ∷ [])

unit : ⊤
unit = construct zero [] []


data Unit : Set where
  unit : Unit

F : Unit → Set₁
F {x = unit} = Set


-- Andreas, 2014-05-08
-- Reported by guillaume.brunerie, Yesterday

{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.cc:25 -v reduce.compiled:95 #-}
-- {-# OPTIONS --show-implicit -v tc.inj:30 -v tc.conv:20 -v tc.meta.assign:10 #-}

-- The code below gives the following odd error:

-- > Incomplete pattern matching when applying Cubical._.C

-- The definition of [C] by pattern matching does not seem incomplete, but even if it were, it should be detected when type checking [C], not when using it (!).
-- The last definition [test] is the one triggering the error, if you comment it then everything typechecks.

record Unit : Set where
  constructor unit

data _==_ {i} {A : Set i} (a : A) : A → Set where
  idp : a == a

data Nat : Set where
  O : Nat
  S : Nat → Nat

record BS (B : Set) (C : B → Set) : Set where
  constructor bs
  field
    {b₁ b₂} : B
    c₁ : C b₁
    c₂ : C b₂
    p : b₁ == b₂

postulate A : Set

B : Nat → Set
C : (n : Nat) → B n → Set

B O = Unit
B (S n) = BS (B n) (C n)

-- No bug if no match on unit
-- C O _ = A
C O unit = A
C (S n) (bs {b₁} c₁ c₂ idp) = _==_ {A = _} c₁ c₂

-- Due to a bug in TypeChecking.Patterns.Match
-- a failed match of (C n b) against (C O unit)
-- turned into (C n unit).
-- This was because all patterns were matched in
-- parallel, and evaluations of successfull matches
-- (and a record constructor like unit can always
-- be successfully matched) were returned, leading
-- to a reassembly of (C n b) as (C n unit) which is
-- illtyped.

-- Now patterns are matched left to right and
-- upon failure, no further matching is performed.

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B
open _×_ public

PathOver : {A : Set} (B : A → Set)
  {x y : A} (p : x == y) (u : B x) (v : B y) → Set
PathOver B idp u v = (u == v)

syntax PathOver B p u v =
  u == v [ B ↓ p ]

pair×= : {A B : Set} {a a' : A} (p : a == a') {b b' : B} (q : b == b') → (a , b) == (a' , b')
pair×= idp idp = idp

bs= : {B : Set} {C : B → Set}
      {b₁ b₁' : B} {pb₁ : b₁ == b₁'}
      {b₂ b₂' : B} {pb₂ : b₂ == b₂'}
      {c₁ : C b₁} {c₁' : C b₁'} (pc₁ : c₁ == c₁' [ C ↓ pb₁ ])
      {c₂ : C b₂} {c₂' : C b₂'} (pc₂ : c₂ == c₂' [ C ↓ pb₂ ])
      {p : b₁ == b₂} {p' : b₁' == b₂'} (α : p == p' [ (λ u → fst u == snd u) ↓ pair×= pb₁ pb₂ ])
      → bs c₁ c₂ p == bs c₁' c₂' p'
bs= {pb₁ = idp} {pb₂ = idp} idp idp idp = idp

_=□^[_]_ : {a b c d : A} (p : a == b) (qr : (a == c) × (b == d)) (s : c == d) → Set
p =□^[ qr ] s = C (S (S O)) (bs {b₁ = bs _ _ idp} p s (bs= {pb₁ = idp} {pb₂ = idp} (fst qr) (snd qr) idp))

test : {a b : A} (p q : a == b) → (p =□^[ idp , idp ] q) == (p == q)
test p q = idp

{-
compareTerm (C n unit) =< (?0 n {b₁} c₁ c₂) : Set
term (?0 n {b₁} c₁ c₂) :>= (C n unit)
term (?0 n {b₁} c₁ c₂) :>= (C n unit)
solving _111 := (λ n {b₁} c₁ c₂ → C n unit)
-}


module Splitting where

open import Basics
open import All

data _<[_]>_ {X : Set} : List X -> List X -> List X -> Set where
  sz : [] <[ [] ]> []
  sl : forall {l ls ms rs} -> ls <[ ms ]> rs -> (l ,- ls) <[ l ,- ms ]> rs
  sr : forall {r ls ms rs} -> ls <[ ms ]> rs -> ls <[ r ,- ms ]> (r ,- rs)

riffle : {X : Set}{ls ms rs : List X} -> ls <[ ms ]> rs ->
         {P : X -> Set} -> All P ls -> All P rs -> All P ms
riffle sz <> <> = <>
riffle (sl x) (p , lp) rp = p , riffle x lp rp
riffle (sr x) lp (p , rp) = p , riffle x lp rp

srs : forall {X : Set}(xs : List X) -> [] <[ xs ]> xs
srs [] = sz
srs (x ,- xs) = sr (srs xs)

data SRS {X : Set}(ms : List X) : (xs : List X) -> [] <[ ms ]> xs -> Set where
  mkSRS : SRS ms ms (srs ms)

isSRS : {X : Set}{ms xs : List X}(i : [] <[ ms ]> xs) -> SRS ms xs i
isSRS sz = mkSRS
isSRS (sr i) with isSRS i
isSRS (sr .(srs _)) | mkSRS = mkSRS

slrs : forall {X : Set}(xs ys : List X) -> xs <[ xs +L ys ]> ys
slrs [] ys = srs ys
slrs (x ,- xs) ys = sl (slrs xs ys)

cat : forall {X}{P : X -> Set}(xs ys : List X) -> All P xs -> All P ys -> All P (xs +L ys)
cat xs ys ps qs = riffle (slrs xs ys) ps qs

data IsRiffle {X : Set}{ls ms rs : List X}(i : ls <[ ms ]> rs){P : X -> Set}
  : All P ms -> Set where
  mkRiffle : (lp : All P ls)(rp : All P rs) -> IsRiffle i (riffle i lp rp)
isRiffle : {X : Set}{ls ms rs : List X}(i : ls <[ ms ]> rs){P : X -> Set}(mp : All P ms) -> IsRiffle i mp
isRiffle sz <> = mkRiffle <> <>
isRiffle (sl i) (p , mp) with isRiffle i mp
isRiffle (sl i) (p , .(riffle i lp rp)) | mkRiffle lp rp = mkRiffle (p , lp) rp
isRiffle (sr i) (p , mp) with isRiffle i mp
isRiffle (sr i) (p , .(riffle i lp rp)) | mkRiffle lp rp = mkRiffle lp (p , rp)

mirror : {X : Set}{ls ms rs : List X} -> ls <[ ms ]> rs -> rs <[ ms ]> ls
mirror sz = sz
mirror (sl x) = sr (mirror x)
mirror (sr x) = sl (mirror x)

rotatel : {X : Set}{ls ms rs lrs rrs : List X} -> ls <[ ms ]> rs -> lrs <[ rs ]> rrs ->
  Sg (List X) \ ns -> (ls <[ ns ]> lrs) * (ns <[ ms ]> rrs)
rotatel sz sz = [] , sz , sz
rotatel (sl x) y with rotatel x y
... | _ , a , b = _ , sl a , sl b
rotatel (sr x) (sl y) with rotatel x y
... | _ , a , b = _ , sr a , sl b
rotatel (sr x) (sr y) with rotatel x y
... | _ , a , b = _ , a , sr b

rotater : {X : Set}{lls rls ls ms rs : List X} -> lls <[ ls ]> rls -> ls <[ ms ]> rs ->
  Sg (List X) \ ns -> (lls <[ ms ]> ns) * (rls <[ ns ]> rs)
rotater x y with rotatel (mirror y) (mirror x)
... | _ , a , b = _ , mirror b , mirror a

llswap : {X : Set}{ls ms lrs rrs : List X} ->
 (Sg (List X) \ rs -> (ls <[ ms ]> rs) * (lrs <[ rs ]> rrs)) ->
  Sg (List X) \ ns -> (lrs <[ ms ]> ns) * (ls <[ ns ]> rrs)
llswap (_ , x , y) with rotatel x y
... | _ , a , b = rotater (mirror a) b

insS : {X : Set}(xs : List X)(y : X)(zs : List X) -> (y ,- []) <[ (xs +L y ,- zs) ]> (xs +L zs)
insS [] y zs = sl (srs zs)
insS (x ,- xs) y zs = sr (insS xs y zs)

catS : forall {X}{as abs bs cs cds ds : List X} ->
        as <[ abs ]> bs -> cs <[ cds ]> ds ->
        (as +L cs) <[ (abs +L cds) ]> (bs +L ds)
catS sz y = y
catS (sl x) y = sl (catS x y)
catS (sr x) y = sr (catS x y)

splimap : forall {X Y}(f : X -> Y){xs xys ys} -> xs <[ xys ]> ys ->
           list f xs <[ list f xys ]> list f ys
splimap f sz = sz
splimap f (sl s) = sl (splimap f s)
splimap f (sr s) = sr (splimap f s)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Queue.Untruncated2ListInvariant where

open import Cubical.Foundations.Everything
open import Cubical.Data.Empty as ⊥
open import Cubical.Data.List
open import Cubical.Data.Maybe
open import Cubical.Data.Prod

module Untruncated2ListInvariant {ℓ} (A : Type ℓ) where

 -- Invariant
 Inv : List A → List A → Type ℓ
 Inv xs ys = ys ≡ [] → xs ≡ []

 isPropInv : (xs ys : List A) → isProp (Inv xs ys)
 isPropInv xs ys = isPropΠ λ _ → isPropXs≡[]

 Inv-ys≡ys' : {xs ys ys' : List A} → (p : ys ≡ ys') →
   (invL : Inv xs ys) → (invR : Inv xs ys') → PathP (λ i → Inv xs (p i)) invL invR
 Inv-ys≡ys' {xs = xs} p invL invR = isProp→PathP (λ i → isPropInv xs (p i)) invL invR

 inv-xs-∷ : {xs ys : List A} {y : A} → Inv xs (y ∷ ys)
 inv-xs-∷ contra = ⊥.rec (¬cons≡nil contra)

 inv-xs-∷ʳ : {xs ys : List A} → {y : A} → Inv xs (ys ∷ʳ y)
 inv-xs-∷ʳ contra = ⊥.rec (¬snoc≡nil contra)

 inv-[]-ys : {ys : List A} → Inv [] ys
 inv-[]-ys ys = refl

 inv-invalid : {xs : List A} {x : A} → Inv (xs ∷ʳ x) [] → ⊥
 inv-invalid inv = ¬snoc≡nil (inv refl)

 -- Queue
 data Q : Type ℓ where
   Q⟨_,_!_⟩ : (xs ys : List A) → (inv : Inv xs ys) → Q
   tilt : ∀ xs ys z l r → Q⟨ xs ++ [ z ] , ys ! l ⟩ ≡ Q⟨ xs , ys ++ [ z ] ! r ⟩

 Q-ys≡ys' : ∀ xs {ys ys' : List A} l r → (p : ys ≡ ys') → Q⟨ xs , ys ! l ⟩ ≡ Q⟨ xs , ys' ! r ⟩
 Q-ys≡ys' xs l r p i = Q⟨ xs , p i ! Inv-ys≡ys' p l r i ⟩

 flush-xs : ∀ xs ys l r → Q⟨ xs , ys ! l ⟩ ≡ Q⟨ [] , ys ++ rev xs ! r ⟩
 flush-xs xs ys l r = helper xs ys l r (snocView xs)
   where
     helper : ∀ xs ys l r → SnocView xs → Q⟨ xs , ys ! l ⟩ ≡ Q⟨ [] , ys ++ rev xs ! r ⟩
     helper .[] ys l r nil i = Q⟨ [] , ++-unit-r ys (~ i) ! Inv-ys≡ys' (++-unit-r ys ⁻¹) l r i  ⟩
     helper .(xs ∷ʳ x) ys l r (snoc x xs s) = move-x ∙ IH ∙ Q-ys≡ys' [] inv-[]-ys r lemma
       where
       move-x : Q⟨ xs ∷ʳ x , ys ! l ⟩ ≡ Q⟨ xs , ys ∷ʳ x ! inv-xs-∷ʳ ⟩
       move-x = tilt xs ys x l inv-xs-∷ʳ
       IH : Q⟨ xs , ys ∷ʳ x ! inv-xs-∷ʳ ⟩ ≡ Q⟨ [] , (ys ∷ʳ x) ++ rev xs ! inv-[]-ys ⟩
       IH = helper xs (ys ∷ʳ x) inv-xs-∷ʳ inv-[]-ys s
       lemma : (ys ∷ʳ x) ++ rev xs ≡ ys ++ rev (xs ∷ʳ x)
       lemma = ++-assoc ys (x ∷ []) (rev xs) ∙ cong (ys ++_) (cons≡rev-snoc x xs)

 emp : Q
 emp = Q⟨ [] , [] ! inv-[]-ys ⟩

 enq : A → Q → Q
 enq a Q⟨ xs , [] ! inv ⟩ = Q⟨ xs , a ∷ [] ! inv-xs-∷ ⟩
 enq a Q⟨ xs , y ∷ ys ! inv ⟩ = Q⟨ a ∷ xs , y ∷ ys ! inv-xs-∷ ⟩
 enq a (tilt xs [] z l r i) = proof i
   where
   proof : Q⟨ xs ++ z ∷ [] , a ∷ [] ! inv-xs-∷ ⟩ ≡ Q⟨ a ∷ xs , z ∷ [] ! inv-xs-∷ ⟩
   proof = ⊥.rec (inv-invalid l)
 enq a (tilt xs (y ∷ ys) z l r i) = tilt (a ∷ xs) (y ∷ ys) z inv-xs-∷ inv-xs-∷ i

 deq : Q → Maybe (Q × A)
 deq Q⟨ xs , [] ! inv ⟩ = nothing
 deq Q⟨ xs , y ∷ [] ! inv ⟩ = just (Q⟨ [] , rev xs ! inv-[]-ys ⟩ , y)
 deq Q⟨ xs , y₁ ∷ y₂ ∷ ys ! inv ⟩ = just (Q⟨ xs , y₂ ∷ ys ! inv-xs-∷ ⟩ , y₁)
 deq (tilt xs [] z l r i) = proof i
   where
   proof : nothing ≡ just (Q⟨ [] , rev xs ! inv-[]-ys ⟩ , z)
   proof = ⊥.rec (inv-invalid l)
 deq (tilt xs (y ∷ []) z l r i) = just (proof i , y)
   where
   proof : Q⟨ [] , rev (xs ∷ʳ z) ! inv-[]-ys ⟩ ≡ Q⟨ xs , z ∷ [] ! inv-xs-∷ ⟩
   proof = Q-ys≡ys' [] inv-[]-ys inv-xs-∷ (cons≡rev-snoc z xs ⁻¹) ∙ flush-xs xs (z ∷ []) inv-xs-∷ inv-xs-∷ ⁻¹
 deq (tilt xs (y₁ ∷ y₂ ∷ ys) z l r i) = just ((tilt xs (y₂ ∷ ys) z inv-xs-∷ inv-xs-∷ i) , y₁)


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Data.Nat.Lower where

open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Path
open import Cubical.Foundations.Transport

open import Cubical.Data.Bool
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Nat.Base
open import Cubical.Data.Nat.Properties
open import Cubical.Data.Sigma
open import Cubical.Data.Sum
open import Cubical.Data.Unit

open import Cubical.Relation.Nullary

isMonotone : (ℕ → Bool) → Type
isMonotone f = ∀ n → f n ≥ f (suc n)

isPropIsMonotone : ∀ f → isProp (isMonotone f)
isPropIsMonotone f = isPropΠ λ n → isProp≥ (f n) (f (suc n))

isPropDepIsMonotone : isPropDep isMonotone
isPropDepIsMonotone = isOfHLevel→isOfHLevelDep 1 isPropIsMonotone {_}

Monotone : Type
Monotone = Σ _ isMonotone

isSetMonotone : isSet Monotone
isSetMonotone = isSetΣ (isSet→ isSetBool) (isProp→isSet ∘ isPropIsMonotone)

private
  variable
    ℓ : Level
    m n : Monotone

private
  mz : ℕ → Bool
  mz _ = false

  ms : (ℕ → Bool) → (ℕ → Bool)
  ms _ zero = true
  ms f (suc m) = f m

  msm : ∀{f} → isMonotone f → isMonotone (ms f)
  msm _ zero = _
  msm mf (suc m) = mf m

  mp : (ℕ → Bool) → (ℕ → Bool)
  mp f k = f (suc k)

  ms-mp : ∀ f → f 0 ≡ true → ms (mp f) ≡ f
  ms-mp f p i 0 = p (~ i)
  ms-mp f p i (suc k) = f (suc k)

  mz-lemma : ∀ f → isMonotone f → f 0 ≡ false → ∀ k → false ≡ f k
  mz-lemma f  _ p zero = sym p
  mz-lemma f mf p (suc k)
    with f 1
      | inspect f 1
      | subst (_≥ f 1) p (mf 0)
  ... | false | [ q ]ᵢ | _ = mz-lemma (mp f) (mf ∘ suc) q k

msuc : Monotone → Monotone
msuc m .fst = ms (fst m)
msuc m .snd = msm (snd m)

mpred : Monotone → Monotone
mpred f .fst k = f .fst (suc k)
mpred f .snd k = f .snd (suc k)

data MView : (ℕ → Bool) → Type where
  mzv : MView mz
  msv : ∀ n → MView (ms n)

mview : ∀ f → isMonotone f → MView f
mview f mf with f 0 | inspect f 0
... |  true | [ p ]ᵢ = subst MView (ms-mp f p) (msv (mp f))
... | false | [ p ]ᵢ = subst MView (funExt (mz-lemma f mf p)) mzv

∞ : Monotone
∞ .fst _ = true
∞ .snd _ = _

Detached : (ℕ → Bool) → Type
Detached p = Σ[ n ∈ ℕ ] Bool→Type (p n)

Lower : Monotone → Type
Lower m = Detached (fst m)

Detached-ext
  : ∀{p : ℕ → Bool} (k l : Detached p) → k .fst ≡ l .fst → k ≡ l
Detached-ext {p} (k , q) (l , r) s
  = ΣPathP (s , isPropDep∘ p isPropDep-Bool→Type q r s)

Lower∞≃ℕ : Lower ∞ ≃ ℕ
Lower∞≃ℕ = isoToEquiv λ where
    .fun → fst
    .inv n → n , _
    .rightInv _ → refl
    .leftInv _ → refl
  where open Iso

private
  apart : ℕ → ℕ → Type
  apart zero zero = ⊥
  apart (suc m) (suc n) = apart m n
  apart _ _ = Unit

  ≢→apart : (i j : ℕ) → ¬ i ≡ j → apart i j
  ≢→apart zero zero ¬p = ¬p refl
  ≢→apart (suc i) (suc j) ¬p = ≢→apart i j (¬p ∘ cong suc)
  ≢→apart zero (suc _) _ = _
  ≢→apart (suc _) zero _ = _

  apart→≢ : (i j : ℕ) → apart i j → ¬ i ≡ j
  apart→≢ (suc _) zero _ = snotz
  apart→≢ zero (suc _) _ = znots
  apart→≢ (suc i) (suc j) i#j = apart→≢ i j i#j ∘ cong predℕ

  isPropApart : ∀ i j → isProp (apart i j)
  isPropApart 0 0 = isProp⊥
  isPropApart (suc i) (suc j) = isPropApart i j
  isPropApart 0 (suc _) = isPropUnit
  isPropApart (suc _) 0 = isPropUnit

_#_ : ∀{P : ℕ → Type ℓ} → Σ ℕ P → Σ ℕ P → Type
u # v = apart (fst u) (fst v)

_#?_ : ∀{P : ℕ → Type ℓ} → (u v : Σ ℕ P) → (u # v) ⊎ (fst u ≡ fst v)
u #? v = decide (fst u) (fst v) where
  decide : (m n : ℕ) → apart m n ⊎ (m ≡ n)
  decide zero zero = inr refl
  decide zero (suc _) = inl _
  decide (suc _) zero = inl _
  decide (suc m) (suc n) = map (idfun _) (cong suc) (decide m n)

#→≢ : ∀{P : ℕ → Type ℓ} (u v : Σ ℕ P) → u # v → ¬ u ≡ v
#→≢ u v d = apart→≢ (fst u) (fst v) d ∘ cong fst

isProp# : ∀{P : ℕ → Type ℓ} (u v : Σ ℕ P) → isProp (u # v)
isProp# u v = isPropApart (fst u) (fst v)

isProp#Depᵣ : ∀{P : ℕ → Type ℓ} (v : Σ ℕ P) → isPropDep (λ u → u # v)
isProp#Depᵣ v = isOfHLevel→isOfHLevelDep 1 (λ u → isProp# u v) {_} {_}

≢→# : ∀{p} (u v : Detached p) → ¬ u ≡ v → u # v
≢→# u v ¬p = ≢→apart (fst u) (fst v) (¬p ∘ Detached-ext u v)

dzero : ∀{f} → Detached (ms f)
dzero = zero , _

dsuc : ∀{f} → Detached f → Detached (ms f)
dsuc (l , p) = suc l , p

module Untangle
    {α β}
    (f : Detached (ms α) → Detached (ms β))
    (g : Detached (ms β) → Detached (ms α))
    (rinv : section f g)
    (linv : retract f g)
  where

  default : ∀{γ} → (v d : Detached (ms γ)) → v # d → Detached γ
  default (suc l , p) _ _ = l , p
  default (0 , _) (suc l , p) _ = l , p

  #-f : ∀ u v → u # v → f u # f v
  #-f u v u#v with f u #? f v
  ... | inl fu#fv = fu#fv
  ... | inr fu≡fv = Empty.rec (#→≢ u v u#v u≡v)
    where
    u≡v : u ≡ v
    u≡v = sym (linv u)
       ∙∙ cong g (Detached-ext (f u) (f v) fu≡fv)
       ∙∙ linv v

  #-g : ∀ u v → u # v → g u # g v
  #-g u v u#v with g u #? g v
  ... | inl gu#gv = gu#gv
  ... | inr gu≡gv = Empty.rec (#→≢ u v u#v u≡v)
    where
    u≡v : u ≡ v
    u≡v = sym (rinv u)
       ∙∙ cong f (Detached-ext (g u) (g v) gu≡gv)
       ∙∙ rinv v

  f- : Detached α → Detached β
  f- v = default (f (dsuc v)) (f dzero) (#-f (dsuc v) dzero _)

  g- : Detached β → Detached α
  g- v = default (g (dsuc v)) (g dzero) (#-g (dsuc v) dzero _)

  g-f-z : ∀ v u → g dzero ≡ dsuc v → g (dsuc u) ≡ dzero → g- u ≡ v
  g-f-z v u r s with g (dsuc u) | g dzero | #-g (dsuc u) dzero _
  ... | zero , _ | suc k , q | #gf
    = Detached-ext (k , q) v (cong (predℕ ∘ fst) r)
  ... | w@(suc k , _) | _ | #gf = Empty.rec (snotz (cong fst s))

  g-f-s : ∀ v u → g (dsuc u) ≡ dsuc v → g- u ≡ v
  g-f-s v u r with g (dsuc u) | #-g (dsuc u) dzero _
  ... | suc k , q | #gf = Detached-ext (k , q) v (cong (predℕ ∘ fst) r)
  ... |  zero , _ | #gf = Empty.rec (znots (cong fst r))

  g-f- : ∀(v : Detached α) → g- (f- v) ≡ v
  g-f- v with f (dsuc v) | linv (dsuc v) | #-f (dsuc v) dzero _
  g-f- v | suc j , p | r | #f = g-f-s v (j , p) r
  ... | zero , _ | r | #f with f dzero | linv dzero
  ... | suc j , p | s = g-f-z v (j , p) r s

  f-g-z : ∀ v u → f dzero ≡ dsuc v → f (dsuc u) ≡ dzero → f- u ≡ v
  f-g-z v u r s with f (dsuc u) | f dzero | #-f (dsuc u) dzero _
  ... | zero , _ | suc k , q | #fg
    = Detached-ext (k , q) v (cong (predℕ ∘ fst) r)
  ... | (suc _ , _) | _ | _ = Empty.rec (snotz (cong fst s))

  f-g-s : ∀ v u → f (dsuc u) ≡ dsuc v → f- u ≡ v
  f-g-s v u r with f (dsuc u) | #-f (dsuc u) dzero _
  ... | suc k , q | _ = Detached-ext (k , q) v (cong (predℕ ∘ fst) r)
  ... |  zero , _ | _ = Empty.rec (znots (cong fst r))

  f-g- : ∀ v → f- (g- v) ≡ v
  f-g- v with g (dsuc v) | rinv (dsuc v) | #-g (dsuc v) dzero _
  ... | suc j , q | r | _ = f-g-s v (j , q) r
  ... | zero , _ | r | _ with g dzero | rinv dzero
  ... | suc k , q | s = f-g-z v (k , q) r s

  open Iso
  iso- : Iso (Detached α) (Detached β)
  iso- .fun = f-
  iso- .inv = g-
  iso- .rightInv = f-g-
  iso- .leftInv = g-f-

iso-pred
  : ∀{α β}
  → Iso (Detached (ms α)) (Detached (ms β))
  → Iso (Detached α) (Detached β)
iso-pred i = Untangle.iso- fun inv rightInv leftInv
  where open Iso i

isInjectiveLower : Lower m ≡ Lower n → m ≡ n
isInjectiveLower {m} {n} P =
  curry ΣPathP
    (lemma (m .fst) (n .fst) (m .snd) (n .snd) (pathToIso P))
    (isPropDepIsMonotone (m .snd) (n .snd) _)
  where
  lemma
    : ∀ α β → isMonotone α → isMonotone β
    → Iso (Detached α) (Detached β)
    → α ≡ β
  lemma α β mα mβ I i k with mview α mα | mview β mβ
  ... | mzv | mzv = mz k
  lemma α β mα mβ I i 0 | msv _ | msv _
    = true
  lemma α β mα mβ I i (suc k) | msv α' | msv β'
    = lemma α' β' (mα ∘ suc) (mβ ∘ suc) (iso-pred I) i k
  lemma α β mα mβ I i k | mzv | msv β'
    = Empty.rec {A = α k ≡ β k} (Iso.inv I dzero .snd) i
  lemma α β mα mβ I i k | msv _ | mzv
    = Empty.rec {A = α k ≡ β k} (Iso.fun I dzero .snd) i


------------------------------------------------------------------------
-- Restricted hypotheses
------------------------------------------------------------------------

-- A restricted hypothesis is a hypothesis where both types are
-- sub/terms/ of either one of two given types.

open import RecursiveTypes.Syntax

module RecursiveTypes.Subterm.RestrictedHypothesis
         {n} (χ₁ χ₂ : Ty n) where

open import Category.Monad
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (module Inverse)
open import Data.List as List
open import Data.List.Relation.Unary.Any as Any
open import Data.List.Relation.Unary.Any.Properties
import Data.List.Categorical
import Data.List.Countdown as Countdown
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Membership.Propositional.Properties
import Data.List.Membership.Setoid
open import Data.Product as Prod
open import Data.Sum as Sum
open import Level
open import Relation.Nullary
open import Relation.Binary
import Relation.Binary.Construct.On as On
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl)

open RawMonad (Data.List.Categorical.monad {ℓ = zero})

open import RecursiveTypes.Subterm as ST using (_⊑_; _∗)

------------------------------------------------------------------------
-- Restricted hypotheses

-- Types which are subterms of either χ₁ or χ₂.

Subterm : Ty n → Set
Subterm σ = σ ⊑ χ₁ ⊎ σ ⊑ χ₂

-- The Subterm predicate is anti-monotone.

anti-mono : ∀ {σ₁ σ₂} → σ₂ ⊑ σ₁ → Subterm σ₁ → Subterm σ₂
anti-mono σ₂⊑σ₁ = Sum.map (ST.trans σ₂⊑σ₁) (ST.trans σ₂⊑σ₁)

-- Hypotheses where both types are subterms.

RestrictedHyp : Set
RestrictedHyp = ∃ Subterm × ∃ Subterm

-- Computes the underlying hypothesis/es.

⟨_⟩ : RestrictedHyp → Hyp n
⟨_⟩ = Prod.map proj₁ proj₁

⟨_⟩⋆ : List RestrictedHyp → List (Hyp n)
⟨_⟩⋆ = List.map ⟨_⟩

-- Equality of restricted hypotheses (ignores the subterm proofs).

_≈_ : Rel RestrictedHyp zero
_≈_ = _≡_ on ⟨_⟩

-- List membership relation for restricted hypotheses.

open Data.List.Membership.Setoid
       (record { isEquivalence =
                   On.isEquivalence (⟨_⟩) PropEq.isEquivalence })
  using () renaming (_∈_ to _⟨∈⟩_)

------------------------------------------------------------------------
-- Computing all possible restricted hypotheses

-- Computes all the subterms of the given type.

subtermsOf : ∀ τ → (∀ {σ} → σ ⊑ τ → Subterm σ) → List (∃ Subterm)
subtermsOf τ f = List.map (Prod.map id f) (ST.subtermsOf τ)

subtermsOf-complete :
  ∀ {τ} (f : ∀ {σ} → σ ⊑ τ → Subterm σ) {σ} →
  σ ⊑ τ → ∃ λ σ⊑τ → (σ , f σ⊑τ) ∈ subtermsOf τ f
subtermsOf-complete f σ⊑τ =
  Prod.map id (λ ∈ → Inverse.to (map-∈↔ _) ⟨$⟩ (_ , ∈ , refl)) $
    ST.subtermsOf-complete σ⊑τ

subtermsOf²-complete :
  ∀ {σ₁ τ₁ σ₂ τ₂}
  (f : ∀ {σ} → σ ⊑ τ₁ → Subterm σ)
  (g : ∀ {σ} → σ ⊑ τ₂ → Subterm σ) →
  (σ₁⊑τ₁ : σ₁ ⊑ τ₁) (σ₂⊑τ₂ : σ₂ ⊑ τ₂) →
  ((σ₁ , f σ₁⊑τ₁) ≲ (σ₂ , g σ₂⊑τ₂)) ⟨∈⟩
    (subtermsOf τ₁ f ⊗ subtermsOf τ₂ g)
subtermsOf²-complete f g σ₁⊑τ₁ σ₂⊑τ₂ =
  Any.map (PropEq.cong $ Prod.map proj₁ proj₁) $
    Inverse.to ⊗-∈↔ ⟨$⟩
      ( proj₂ (subtermsOf-complete f σ₁⊑τ₁)
      , proj₂ (subtermsOf-complete g σ₂⊑τ₂)
      )

-- All subterms of χ₁.

⊑-χ₁ : List (∃ Subterm)
⊑-χ₁ = subtermsOf χ₁ inj₁

-- All subterms of χ₂.

⊑-χ₂ : List (∃ Subterm)
⊑-χ₂ = subtermsOf χ₂ inj₂

-- All possible restricted hypotheses.

restrictedHyps : List RestrictedHyp
restrictedHyps = (⊑-χ₁ ⊗ ⊑-χ₂) ++ (⊑-χ₂ ⊗ ⊑-χ₁) ++
                 (⊑-χ₁ ⊗ ⊑-χ₁) ++ (⊑-χ₂ ⊗ ⊑-χ₂)

complete : ∀ h → h ⟨∈⟩ restrictedHyps
complete ((σ , inj₁ σ⊑χ₁) ≲ (τ , inj₂ τ⊑χ₂)) =
  Inverse.to ++↔ ⟨$⟩ (inj₁ $
  subtermsOf²-complete inj₁ inj₂ σ⊑χ₁ τ⊑χ₂)
complete ((σ , inj₂ σ⊑χ₂) ≲ (τ , inj₁ τ⊑χ₁)) =
  Inverse.to (++↔ {xs = ⊑-χ₁ ⊗ ⊑-χ₂}) ⟨$⟩ (inj₂ $
  Inverse.to ++↔                      ⟨$⟩ (inj₁ $
  subtermsOf²-complete inj₂ inj₁ σ⊑χ₂ τ⊑χ₁))
complete ((σ , inj₁ σ⊑χ₁) ≲ (τ , inj₁ τ⊑χ₁)) =
  Inverse.to (++↔ {xs = ⊑-χ₁ ⊗ ⊑-χ₂}) ⟨$⟩ (inj₂ $
  Inverse.to (++↔ {xs = ⊑-χ₂ ⊗ ⊑-χ₁}) ⟨$⟩ (inj₂ $
  Inverse.to ++↔                      ⟨$⟩ (inj₁ $
  subtermsOf²-complete inj₁ inj₁ σ⊑χ₁ τ⊑χ₁)))
complete ((σ , inj₂ σ⊑χ₂) ≲ (τ , inj₂ τ⊑χ₂)) =
  Inverse.to (++↔ {xs = ⊑-χ₁ ⊗ ⊑-χ₂}) ⟨$⟩ (inj₂ $
  Inverse.to (++↔ {xs = ⊑-χ₂ ⊗ ⊑-χ₁}) ⟨$⟩ (inj₂ $
  Inverse.to (++↔ {xs = ⊑-χ₁ ⊗ ⊑-χ₁}) ⟨$⟩ (inj₂ $
  subtermsOf²-complete inj₂ inj₂ σ⊑χ₂ τ⊑χ₂)))

------------------------------------------------------------------------
-- A countdown structure for restricted hypotheses

-- Equality of restricted hypotheses can be decided.

_≟_ : Decidable (_≡_ {A = Hyp n})
( σ₁ ≲  σ₂) ≟ (τ₁ ≲ τ₂) with σ₁ ≡? τ₁ | σ₂ ≡? τ₂
(.τ₁ ≲ .τ₂) ≟ (τ₁ ≲ τ₂) | yes refl | yes refl = yes refl
... | no σ₁≢τ₁ | _ = no (σ₁≢τ₁ ∘ PropEq.cong proj₁)
... | _ | no σ₂≢τ₂ = no (σ₂≢τ₂ ∘ PropEq.cong proj₂)

isDecEquivalence : IsDecEquivalence _≈_
isDecEquivalence =
  On.isDecEquivalence ⟨_⟩ $
    DecSetoid.isDecEquivalence (PropEq.decSetoid _≟_)

-- The countdown data structure can be used to keep track of (an upper
-- bound of) the number of hypotheses which have not been inserted
-- into a given list of hypotheses yet.

private
  open module C =
    Countdown (record { isDecEquivalence = isDecEquivalence })
    public hiding (empty; emptyFromList)

-- An initialised countdown structure.

empty : [] ⊕ length restrictedHyps
empty = C.emptyFromList restrictedHyps complete


{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalLevDesc where

----------------------------------------------------------------------

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

UncurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedCases E P X = Cases E P → X

CurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedCases [] P X = X
CurriedCases (l ∷ E) P X = P here → CurriedCases E (λ t → P (there t)) X

curryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : UncurriedCases E P X) → CurriedCases E P X
curryCases [] P X f = f tt
curryCases (l ∷ E) P X f = λ c → curryCases E (λ t → P (there t)) X (λ cs → f (c , cs))

uncurryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : CurriedCases E P X) → UncurriedCases E P X
uncurryCases [] P X x tt = x
uncurryCases (l ∷ E) P X f (c , cs) = uncurryCases E (λ t → P (there t)) X (f c) cs

----------------------------------------------------------------------

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

Hyps : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
Hyps I (`End j) X P i q = ⊤
Hyps I (`Rec j D) X P i (x , xs) = P j x × Hyps I D X P i xs
Hyps I (`Arg A B) X P i (a , b) = Hyps I (B a) X P i b
Hyps I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × Hyps I D X P i xs

----------------------------------------------------------------------

TagDesc : (I : Set) → Set
TagDesc I = Σ Enum (λ E → Cases E (λ _ → Desc I))

toCase : (I : Set) (E,cs : TagDesc I) → Tag (proj₁ E,cs) → Desc I
toCase I (E , cs) = case E (λ _ → Desc I) cs

toDesc : (I : Set) → TagDesc I → Desc I
toDesc I (E , cs) = `Arg (Tag E) (toCase I (E , cs))

----------------------------------------------------------------------

UncurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedEl I D X = {i : I} → El I D X i → X i

CurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedEl I (`End i) X = X i
CurriedEl I (`Rec j D) X = (x : X j) → CurriedEl I D X
CurriedEl I (`Arg A B) X = (a : A) → CurriedEl I (B a) X
CurriedEl I (`RecFun A B D) X = ((a : A) → X (B a)) → CurriedEl I D X

curryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : UncurriedEl I D X) → CurriedEl I D X
curryEl I (`End i) X cn = cn refl
curryEl I (`Rec i D) X cn = λ x → curryEl I D X (λ xs → cn (x , xs))
curryEl I (`Arg A B) X cn = λ a → curryEl I (B a) X (λ xs → cn (a , xs))
curryEl I (`RecFun A B D) X cn = λ f → curryEl I D X (λ xs → cn (f , xs))

uncurryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : CurriedEl I D X) → UncurriedEl I D X
uncurryEl I (`End i) X cn refl = cn
uncurryEl I (`Rec i D) X cn (x , xs) = uncurryEl I D X (cn x) xs
uncurryEl I (`Arg A B) X cn (a , xs) = uncurryEl I (B a) X (cn a) xs
uncurryEl I (`RecFun A B D) X cn (f , xs) = uncurryEl I D X (cn f) xs

----------------------------------------------------------------------

CasesD : (I : Set) (E : Enum) → Set
CasesD I E = Cases E (λ _ → Desc I)

Args : (I : Set) (E : Enum) (t : Tag E) (cs : CasesD I E) → Desc I
Args I E t cs = case E (λ _ → Desc I) cs t

----------------------------------------------------------------------

data μ (I : Set) (E : Enum) (cs : CasesD I E) : I → Set where
  con : (t : Tag E) → UncurriedEl I (Args I E t cs) (μ I E cs)

con2 : (I : Set) (E : Enum) (cs : CasesD I E) (t : Tag E)
  → CurriedEl I (Args I E t cs) (μ I E cs)
con2 I E cs t = curryEl I (Args I E t cs) (μ I E cs) (con t)

----------------------------------------------------------------------

UncurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : {i : I} → El I D X i → X i)
  → Set
UncurriedHyps I D X P cn =
  (i : I) (xs : El I D X i) → Hyps I D X P i xs → P i (cn xs)

CurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
CurriedHyps I (`End i) X P cn =
  P i (cn refl)
CurriedHyps I (`Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps I D X P (λ xs → cn (x , xs))
CurriedHyps I (`Arg A B) X P cn =
  (a : A) → CurriedHyps I (B a) X P (λ xs → cn (a , xs))
CurriedHyps I (`RecFun A B D) X P cn =
  (f : (a : A) → X (B a)) (ihf : (a : A) → P (B a) (f a)) → CurriedHyps I D X P (λ xs → cn (f , xs))

curryHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : UncurriedHyps I D X P cn)
  → CurriedHyps I D X P cn
curryHyps I (`End i) X P cn pf =
  pf i refl tt
curryHyps I (`Rec i D) X P cn pf =
  λ x ih → curryHyps I D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps I (`Arg A B) X P cn pf =
  λ a → curryHyps I (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)
curryHyps I (`RecFun A B D) X P cn pf =
  λ f ihf → curryHyps I D X P (λ xs → cn (f , xs)) (λ i xs ihs → pf i (f , xs) (ihf , ihs))

uncurryHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : CurriedHyps I D X P cn)
  → UncurriedHyps I D X P cn
uncurryHyps I (`End .i) X P cn pf i refl tt =
  pf
uncurryHyps I (`Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps I D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps I (`Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps I (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs
uncurryHyps I (`RecFun A B D) X P cn pf i (f , xs) (ihf , ihs) =
  uncurryHyps I D X P (λ ys → cn (f , ys)) (pf f ihf) i xs ihs

----------------------------------------------------------------------

ind :
  (I : Set)
  (E : Enum)
  (cs : CasesD I E)
  (P : (i : I) → μ I E cs i → Set)
  (pcon : (t : Tag E) → UncurriedHyps I (Args I E t cs) (μ I E cs) P (con t))
  (i : I)
  (x : μ I E cs i)
  → P i x

hyps :
  (I : Set)
  (E : Enum)
  (cs : CasesD I E)
  (P : (i : I) → μ I E cs i → Set)
  (pcon : (t : Tag E) → UncurriedHyps I (Args I E t cs) (μ I E cs) P (con t))
  (D : Desc I)
  (i : I)
  (xs : El I D (μ I E cs) i)
  → Hyps I D (μ I E cs) P i xs

ind I E cs P pcon i (con t as) = pcon t i as (hyps I E cs P pcon (Args I E t cs) i as)

hyps I E cs P pcon (`End j) i q = tt
hyps I E cs P pcon (`Rec j A) i (x , xs) = ind I E cs P pcon j x , hyps I E cs P pcon A i xs
hyps I E cs P pcon (`Arg A B) i (a , b) = hyps I E cs P pcon (B a) i b
hyps I E cs P pcon (`RecFun A B D) i (f , xs) = (λ a → ind I E cs P pcon (B a) (f a)) , hyps I E cs P pcon D i xs

----------------------------------------------------------------------

ind2 :
  (I : Set)
  (E : Enum)
  (cs : CasesD I E)
  (P : (i : I) → μ I E cs i → Set)
  (pcon : (t : Tag E) → CurriedHyps I (Args I E t cs) (μ I E cs) P (con t))
  (i : I)
  (x : μ I E cs i)
  → P i x
ind2 I E cs P pcon i x =
  ind I E cs P (λ t → uncurryHyps I (Args I E t cs) (μ I E cs) P (con t) (pcon t)) i x

elim :
  (I : Set)
  (E : Enum)
  (cs : CasesD I E)
  (P : (i : I) → μ I E cs i → Set)
  → let
    Q = λ t → CurriedHyps I (Args I E t cs) (μ I E cs) P (con t)
    X = (i : I) (x : μ I E cs i) → P i x
  in UncurriedCases E Q X
elim I E cs P ds i x =
  let Q = λ t → CurriedHyps I (Args I E t cs) (μ I E cs) P (con t)
  in ind2 I E cs P (case E Q ds) i x

elim2 :
  (I : Set)
  (E : Enum)
  (cs : CasesD I E)
  (P : (i : I) → μ I E cs i → Set)
  → let
    Q = λ t → CurriedHyps I (Args I E t cs) (μ I E cs) P (con t)
    X = (i : I) (x : μ I E cs i) → P i x
  in CurriedCases E Q X
elim2 I E cs P =
  let
    Q = λ t → CurriedHyps I (Args I E t cs) (μ I E cs) P (con t)
    X = (i : I) (x : μ I E cs i) → P i x
  in curryCases E Q X (elim I E cs P)

----------------------------------------------------------------------

ℕT : Enum
ℕT = "zero" ∷ "suc" ∷ []

VecT : Enum
VecT = "nil" ∷ "cons" ∷ []

ℕD : CasesD ⊤ ℕT
ℕD =
    `End tt
  , `Rec tt (`End tt)
  , tt

ℕ : ⊤ → Set
ℕ = μ ⊤ ℕT ℕD

zero : ℕ tt
zero = con here refl

suc : ℕ tt → ℕ tt
suc n = con (there here) (n , refl)

zero2 : ℕ tt
zero2 = con2 ⊤ ℕT ℕD here

suc2 : ℕ tt → ℕ tt
suc2 = con2 ⊤ ℕT ℕD (there here)

VecD : (A : Set) → CasesD (ℕ tt) VecT
VecD A =
    `End zero
  , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
  , tt

Vec : (A : Set) (n : ℕ tt) → Set
Vec A n = μ (ℕ tt) VecT (VecD A) n

nil : (A : Set) → Vec A zero
nil A = con here refl

cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons A n x xs = con (there here) (n , x , xs , refl)

nil2 : (A : Set) → Vec A zero
nil2 A = con2 (ℕ tt) VecT (VecD A) here

cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons2 A = con2 (ℕ tt) VecT (VecD A) (there here)

----------------------------------------------------------------------

module GenericEliminator where

  add : ℕ tt → ℕ tt → ℕ tt
  add = elim2 ⊤ ℕT ℕD _
    (λ n → n)
    (λ m ih n → suc (ih n))
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = elim2 ⊤ ℕT ℕD _
    (λ n → zero)
    (λ m ih n → add n (ih n))
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = elim2 (ℕ tt) VecT (VecD A) _
    (λ n ys → ys)
    (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = elim2 (ℕ tt) VecT (VecD (Vec A m)) _
    (nil A)
    (λ n xs xss ih → append A m xs (mult n m) ih)

----------------------------------------------------------------------


{-# OPTIONS --cubical --safe --no-import-sorts #-}
module Cubical.Algebra.Algebra where

open import Cubical.Algebra.Algebra.Base public