module Pi-.NoRepeat where
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Relation.Binary.Core
open import Relation.Binary
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Nat.Properties
open import Data.List as L
open import Function using (_∘_)
open import Pi-.Syntax
open import Pi-.Opsem
open import Pi-.AuxLemmas
import RevNoRepeat

-- Forward deterministic
deterministic : ∀ {st st₁ st₂} → st ↦ st₁ → st ↦ st₂ → st₁ ≡ st₂
deterministic (↦⃗₁ {b = b₁}) (↦⃗₁ {b = b₂}) with base-is-prop _ b₁ b₂
... | refl = refl
deterministic ↦⃗₂ ↦⃗₂ = refl
deterministic ↦⃗₃ ↦⃗₃ = refl
deterministic ↦⃗₄ ↦⃗₄ = refl
deterministic ↦⃗₅ ↦⃗₅ = refl
deterministic ↦⃗₆ ↦⃗₆ = refl
deterministic ↦⃗₇ ↦⃗₇ = refl
deterministic ↦⃗₈ ↦⃗₈ = refl
deterministic ↦⃗₉ ↦⃗₉ = refl
deterministic ↦⃗₁₀ ↦⃗₁₀ = refl
deterministic ↦⃗₁₁ ↦⃗₁₁ = refl
deterministic ↦⃗₁₂ ↦⃗₁₂ = refl
deterministic {［ c ∣ _ ∣ κ ］◁} {⟨ _ ∣ v ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］▷} ↦⃖₁ r with Lemma₅ r
... | refl , refl with Lemma₆ r
... | refl , refl with Lemma₇ r
... | refl with v
... | ()
deterministic {［ c ∣ _ ∣ _ ］◁} {⟨ _ ∣ v ∣ _ ⟩◁} {⟨ _ ∣ v' ∣ _ ⟩◁} ↦⃖₁ r with Lemma₁ r
... | refl , refl with Lemma₂ r
deterministic {［ unite₊l  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ y        ∣ κ ⟩◁} {⟨ _ ∣ inj₂ y        ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ uniti₊l  ∣ _ ∣ κ ］◁} {⟨ _ ∣ v             ∣ κ ⟩◁} {⟨ _ ∣ v             ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ swap₊    ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₁ x        ∣ κ ⟩◁} {⟨ _ ∣ inj₁ x        ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ swap₊    ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ y        ∣ κ ⟩◁} {⟨ _ ∣ inj₂ y        ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocl₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₁ x        ∣ κ ⟩◁} {⟨ _ ∣ inj₁ x        ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocl₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₁ x        ∣ κ ⟩◁} {⟨ _ ∣ inj₂ (inj₁ y) ∣ κ ⟩◁} ↦⃖₁ (() ) | refl , refl | refl , refl
deterministic {［ assocl₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₁ x        ∣ κ ⟩◁} {⟨ _ ∣ inj₂ (inj₂ z) ∣ κ ⟩◁} ↦⃖₁ (() ) | refl , refl | refl , refl
deterministic {［ assocl₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ (inj₁ y) ∣ κ ⟩◁} {⟨ _ ∣ inj₂ (inj₁ y) ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocl₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ (inj₂ z) ∣ κ ⟩◁} {⟨ _ ∣ inj₂ (inj₂ z) ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocr₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₁ (inj₁ x) ∣ κ ⟩◁} {⟨ _ ∣ inj₁ (inj₁ x) ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocr₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₁ (inj₂ y) ∣ κ ⟩◁} {⟨ _ ∣ inj₁ (inj₂ y) ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocr₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ z        ∣ κ ⟩◁} {⟨ _ ∣ inj₁ (inj₁ x) ∣ κ ⟩◁} ↦⃖₁ (() ) | refl , refl | refl , refl
deterministic {［ assocr₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ z        ∣ κ ⟩◁} {⟨ _ ∣ inj₁ (inj₂ y) ∣ κ ⟩◁} ↦⃖₁ (() ) | refl , refl | refl , refl
deterministic {［ assocr₊  ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ z        ∣ κ ⟩◁} {⟨ _ ∣ inj₂ z        ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ unite⋆l  ∣ _ ∣ κ ］◁} {⟨ _ ∣ (tt , v)      ∣ κ ⟩◁} {⟨ _ ∣ (tt , v)      ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ uniti⋆l  ∣ _ ∣ κ ］◁} {⟨ _ ∣ v             ∣ κ ⟩◁} {⟨ _ ∣ v             ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ swap⋆    ∣ _ ∣ κ ］◁} {⟨ _ ∣ (x , y)       ∣ κ ⟩◁} {⟨ _ ∣ (x , y)       ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocl⋆  ∣ _ ∣ κ ］◁} {⟨ _ ∣ (x , (y , z)) ∣ κ ⟩◁} {⟨ _ ∣ (x , (y , z)) ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ assocr⋆  ∣ _ ∣ κ ］◁} {⟨ _ ∣ ((x , y) , z) ∣ κ ⟩◁} {⟨ _ ∣ ((x , y) , z) ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ dist     ∣ _ ∣ κ ］◁} {⟨ _ ∣ (inj₁ x , z)  ∣ κ ⟩◁} {⟨ _ ∣ (inj₁ x , z)  ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ dist     ∣ _ ∣ κ ］◁} {⟨ _ ∣ (inj₂ y , z)  ∣ κ ⟩◁} {⟨ _ ∣ (inj₂ y , z)  ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ factor   ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₁ (x , z)  ∣ κ ⟩◁} {⟨ _ ∣ inj₁ (x , z)  ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ factor   ∣ _ ∣ κ ］◁} {⟨ _ ∣ inj₂ (y , z)  ∣ κ ⟩◁} {⟨ _ ∣ inj₂ (y , z)  ∣ κ ⟩◁} ↦⃖₁ ↦⃖₁ | refl , refl | refl , refl = refl
deterministic {［ unite₊l ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ uniti₊l ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ swap₊   ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ assocl₊ ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ assocr₊ ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ unite⋆l ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ uniti⋆l ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ swap⋆   ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ assocl⋆ ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ assocr⋆ ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ dist    ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ factor  ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁ ()
deterministic {［ id↔     ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} (↦⃖₁ {b = ()})
deterministic {［ _ ⨾ _   ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} (↦⃖₁ {b = ()})
deterministic {［ _ ⊕ _   ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} (↦⃖₁ {b = ()})
deterministic {［ _ ⊗ _   ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} (↦⃖₁ {b = ()})
deterministic {［ η₊      ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} (↦⃖₁ {b = ()})
deterministic {［ ε₊      ∣ _ ∣ _ ］◁} {⟨ _ ∣ _ ∣ _ ⟩◁} {［ _ ∣ _ ∣ _ ］◁} (↦⃖₁ {b = ()})
deterministic ↦⃖₂ ↦⃖₂ = refl
deterministic ↦⃖₃ ↦⃖₃ = refl
deterministic ↦⃖₄ ↦⃖₄ = refl
deterministic ↦⃖₅ ↦⃖₅ = refl
deterministic ↦⃖₆ ↦⃖₆ = refl
deterministic ↦⃖₇ ↦⃖₇ = refl
deterministic ↦⃖₈ ↦⃖₈ = refl
deterministic ↦⃖₉ ↦⃖₉ = refl
deterministic ↦⃖₁₀ ↦⃖₁₀ = refl
deterministic {［ c₁ ⊕ c₂ ∣ inj₁ v ∣ κ ］◁} {［ c₁ ∣ v ∣ ☐⊕ c₂ • κ ］◁} {⟨ _ ∣ x ∣ _ ⟩◁} ↦⃖₁₁ r with Lemma₁ r
... | refl , refl with Lemma₂ r
... | refl , refl with Lemma₃ r
... | inj₂ refl with Lemma₄ r
... | inj₁ ()
... | inj₂ ()
deterministic {［ c₁ ⊕ c₂ ∣ _ ∣ _ ］◁} {［ _ ∣ _ ∣ _ ］◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁₁ ↦⃖₁₁ = refl
deterministic {［ c₁ ⊕ c₂ ∣ inj₂ v ∣ _ ］◁} {［ _ ∣ _ ∣ _ ］◁} {⟨ _ ∣ x ∣ _ ⟩◁} ↦⃖₁₂ r with Lemma₁ r
... | refl , refl with Lemma₂ r
... | refl , refl with Lemma₃ r
... | inj₂ refl with Lemma₄ r
... | inj₁ ()
... | inj₂ ()
deterministic {［ c₁ ⊕ c₂ ∣ _ ∣ _ ］◁} {［ _ ∣ _ ∣ _ ］◁} {［ _ ∣ _ ∣ _ ］◁} ↦⃖₁₂ ↦⃖₁₂ = refl
deterministic {［ η₊ ∣ inj₁ v ∣ _ ］◁} {［ η₊ ∣ _ ∣ _ ］▷} {［ _ ∣ _ ∣ _ ］▷} ↦η₁ ↦η₁ = refl
deterministic {［ η₊ ∣ inj₁ v ∣ _ ］◁} {［ η₊ ∣ _ ∣ _ ］▷} {⟨ η₊ ∣ v' ∣ _ ⟩◁} ↦η₁ r with Lemma₁ r
... | refl , refl with Lemma₂ r
... | refl , refl with v'
... | ()
deterministic {［ η₊ ∣ inj₂ (- v) ∣ _ ］◁} {［ η₊ ∣ _ ∣ _ ］▷} {［ _ ∣ _ ∣ _ ］▷} ↦η₂ ↦η₂ = refl
deterministic {［ η₊ ∣ inj₂ (- v) ∣ _ ］◁} {［ η₊ ∣ _ ∣ _ ］▷} {⟨ η₊ ∣ v' ∣ _ ⟩◁} ↦η₂ r with Lemma₁ r
... | refl , refl with Lemma₂ r
... | refl , refl with v'
... | ()
deterministic ↦ε₁ ↦ε₁ = refl
deterministic ↦ε₂ ↦ε₂ = refl

-- Backward deterministic
deterministicᵣₑᵥ : ∀ {st st₁ st₂} → st₁ ↦ st → st₂ ↦ st → st₁ ≡ st₂
deterministicᵣₑᵥ {［ c ∣ _ ∣ κ ］▷} {⟨ c ∣ v ∣ κ ⟩▷} {⟨ c' ∣ v' ∣ κ' ⟩▷} ↦⃗₁ r with Lemma₈ r
... | refl , refl with Lemma₉ r
deterministicᵣₑᵥ {［ unite₊l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ y        ∣ κ ⟩▷} {⟨ _ ∣ inj₂ y        ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ uniti₊l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v             ∣ κ ⟩▷} {⟨ _ ∣ v             ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ swap₊    ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₁ x        ∣ κ ⟩▷} {⟨ _ ∣ inj₁ x        ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ swap₊    ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ y        ∣ κ ⟩▷} {⟨ _ ∣ inj₂ y        ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocl₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₁ x        ∣ κ ⟩▷} {⟨ _ ∣ inj₁ x        ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocl₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₁ x        ∣ κ ⟩▷} {⟨ _ ∣ inj₂ (inj₁ y) ∣ κ ⟩▷} ↦⃗₁ () | refl , refl | refl , refl
deterministicᵣₑᵥ {［ assocl₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₁ x        ∣ κ ⟩▷} {⟨ _ ∣ inj₂ (inj₂ z) ∣ κ ⟩▷} ↦⃗₁ () | refl , refl | refl , refl
deterministicᵣₑᵥ {［ assocl₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ (inj₁ y) ∣ κ ⟩▷} {⟨ _ ∣ inj₂ (inj₁ y) ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocl₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ (inj₂ z) ∣ κ ⟩▷} {⟨ _ ∣ inj₂ (inj₂ z) ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocr₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₁ (inj₁ x) ∣ κ ⟩▷} {⟨ _ ∣ inj₁ (inj₁ x) ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocr₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₁ (inj₂ y) ∣ κ ⟩▷} {⟨ _ ∣ inj₁ (inj₂ y) ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocr₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ z        ∣ κ ⟩▷} {⟨ _ ∣ inj₁ (inj₁ x) ∣ κ ⟩▷} ↦⃗₁ () | refl , refl | refl , refl
deterministicᵣₑᵥ {［ assocr₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ z        ∣ κ ⟩▷} {⟨ _ ∣ inj₁ (inj₂ y) ∣ κ ⟩▷} ↦⃗₁ () | refl , refl | refl , refl
deterministicᵣₑᵥ {［ assocr₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ z        ∣ κ ⟩▷} {⟨ _ ∣ inj₂ z        ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ unite⋆l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ (tt , v)      ∣ κ ⟩▷} {⟨ _ ∣ (tt , v)      ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ uniti⋆l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v             ∣ κ ⟩▷} {⟨ _ ∣ v             ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ swap⋆    ∣ _ ∣ κ ］▷} {⟨ _ ∣ (x , y)       ∣ κ ⟩▷} {⟨ _ ∣ (x , y)       ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocl⋆  ∣ _ ∣ κ ］▷} {⟨ _ ∣ (x , (y , z)) ∣ κ ⟩▷} {⟨ _ ∣ (x , (y , z)) ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ assocr⋆  ∣ _ ∣ κ ］▷} {⟨ _ ∣ ((x , y) , z) ∣ κ ⟩▷} {⟨ _ ∣ ((x , y) , z) ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ dist     ∣ _ ∣ κ ］▷} {⟨ _ ∣ (inj₁ x , z)  ∣ κ ⟩▷} {⟨ _ ∣ (inj₁ x , z)  ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ dist     ∣ _ ∣ κ ］▷} {⟨ _ ∣ (inj₂ y , z)  ∣ κ ⟩▷} {⟨ _ ∣ (inj₂ y , z)  ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ factor   ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₁ (x , z)  ∣ κ ⟩▷} {⟨ _ ∣ inj₁ (x , z)  ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ factor   ∣ _ ∣ κ ］▷} {⟨ _ ∣ inj₂ (y , z)  ∣ κ ⟩▷} {⟨ _ ∣ inj₂ (y , z)  ∣ κ ⟩▷} ↦⃗₁ ↦⃗₁ | refl , refl | refl , refl = refl
deterministicᵣₑᵥ {［ unite₊l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ uniti₊l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ swap₊    ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ assocl₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ assocr₊  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ unite⋆l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ uniti⋆l  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ swap⋆    ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ assocl⋆  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ assocr⋆  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ dist     ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ factor   ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} ↦⃗₁ ()
deterministicᵣₑᵥ {［ id↔      ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} (↦⃗₁ {b = ()})
deterministicᵣₑᵥ {［ c₁ ⨾ c₂  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} (↦⃗₁ {b = ()})
deterministicᵣₑᵥ {［ c₁ ⊕ c₂  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} (↦⃗₁ {b = ()})
deterministicᵣₑᵥ {［ c₁ ⊗ c₂  ∣ _ ∣ κ ］▷} {⟨ _ ∣ v  ∣ κ ⟩▷} {［ c' ∣ v' ∣ κ' ］▷} (↦⃗₁ {b = ()})
deterministicᵣₑᵥ {［ c ∣ _ ∣ κ ］▷} {⟨ c ∣ v ∣ κ ⟩▷} {［ _ ∣ _ ∣ _ ］◁} ↦⃗₁ r with Lemma₅ r
... | refl , refl with Lemma₆ r
... | refl , refl with Lemma₇ r
... | refl with v
... | ()
deterministicᵣₑᵥ ↦⃗₂ ↦⃗₂ = refl
deterministicᵣₑᵥ ↦⃗₃ ↦⃗₃ = refl
deterministicᵣₑᵥ ↦⃗₄ ↦⃗₄ = refl
deterministicᵣₑᵥ ↦⃗₅ ↦⃗₅ = refl
deterministicᵣₑᵥ ↦⃗₆ ↦⃗₆ = refl
deterministicᵣₑᵥ ↦⃗₇ ↦⃗₇ = refl
deterministicᵣₑᵥ ↦⃗₈ ↦⃗₈ = refl
deterministicᵣₑᵥ ↦⃗₉ ↦⃗₉ = refl
deterministicᵣₑᵥ ↦⃗₁₀ ↦⃗₁₀ = refl
deterministicᵣₑᵥ {［ c₁ ⊕ c₂ ∣ inj₁ v ∣ κ ］▷} {_} {⟨ _ ∣ _ ∣ _ ⟩▷} ↦⃗₁₁ r with Lemma₈ r
... | refl , refl with Lemma₉ r
... | refl , refl with Lemma₁₀ r
... | inj₂ refl with Lemma₁₁ r
... | inj₁ ()
... | inj₂ ()
deterministicᵣₑᵥ {［ c₁ ⊕ c₂ ∣ inj₁ v ∣ κ ］▷} {_} {［ _ ∣ _ ∣ _ ］▷} ↦⃗₁₁ ↦⃗₁₁ = refl
deterministicᵣₑᵥ {［ c₁ ⊕ c₂ ∣ inj₂ v ∣ κ ］▷} {_} {⟨ _ ∣ _ ∣ _ ⟩▷} ↦⃗₁₂ r with Lemma₈ r
... | refl , refl with Lemma₉ r
... | refl , refl with Lemma₁₀ r
... | inj₂ refl with Lemma₁₁ r
... | inj₁ ()
... | inj₂ ()
deterministicᵣₑᵥ {［ c₁ ⊕ c₂ ∣ inj₂ v ∣ κ ］▷} {_} {［ _ ∣ _ ∣ _ ］▷} ↦⃗₁₂ ↦⃗₁₂ = refl
deterministicᵣₑᵥ (↦⃖₁ {b = b₁}) (↦⃖₁ {b = b₂})  with base-is-prop _ b₁ b₂
... | refl = refl
deterministicᵣₑᵥ ↦⃖₂ ↦⃖₂ = refl
deterministicᵣₑᵥ ↦⃖₃ ↦⃖₃ = refl
deterministicᵣₑᵥ ↦⃖₄ ↦⃖₄ = refl
deterministicᵣₑᵥ ↦⃖₅ ↦⃖₅ = refl
deterministicᵣₑᵥ ↦⃖₆ ↦⃖₆ = refl
deterministicᵣₑᵥ ↦⃖₇ ↦⃖₇ = refl
deterministicᵣₑᵥ ↦⃖₈ ↦⃖₈ = refl
deterministicᵣₑᵥ ↦⃖₉ ↦⃖₉ = refl
deterministicᵣₑᵥ ↦⃖₁₀ ↦⃖₁₀ = refl
deterministicᵣₑᵥ ↦⃖₁₁ ↦⃖₁₁ = refl
deterministicᵣₑᵥ ↦⃖₁₂ ↦⃖₁₂ = refl
deterministicᵣₑᵥ {_} {［ η₊ ∣ inj₁ _ ∣ _ ］◁} {⟨ _ ∣ v ∣ _ ⟩▷} ↦η₁ r with Lemma₈ r
... | refl , refl with Lemma₉ r
... | refl , refl with Lemma₁₀ r
... | inj₁ ()
... | inj₂ ()
deterministicᵣₑᵥ {_} {［ η₊ ∣ inj₁ v ∣ _ ］◁} {［ _ ∣ _ ∣ _ ］◁} ↦η₁ ↦η₁ = refl
deterministicᵣₑᵥ {_} {［ η₊ ∣ inj₂ (- v) ∣ _ ］◁} {⟨ c ∣ x ∣ x₁ ⟩▷} ↦η₂ r with Lemma₈ r
... | refl , refl with Lemma₉ r
... | refl , refl with Lemma₁₀ r
... | inj₁ ()
... | inj₂ ()
deterministicᵣₑᵥ {_} {［ η₊ ∣ inj₂ (- v) ∣ _ ］◁} {［ _ ∣ _ ∣ _ ］◁} ↦η₂ ↦η₂ = refl
deterministicᵣₑᵥ ↦ε₁ ↦ε₁ = refl
deterministicᵣₑᵥ ↦ε₂ ↦ε₂ = refl

-- Non-repeating Lemma
open RevNoRepeat (record { State = State
                         ; _↦_ = _↦_
                         ; deterministic = deterministic
                         ; deterministicᵣₑᵥ = deterministicᵣₑᵥ }) public

NoRepeatPi- : ∀ {A B stₙ stₘ n m} (c : A ↔ B) (v : ⟦ A ⟧)
            → n < m
            → ⟨ c ∣ v ∣ ☐ ⟩▷ ↦[ n ] stₙ
            → ⟨ c ∣ v ∣ ☐ ⟩▷ ↦[ m ] stₘ
            → stₙ ≢ stₘ
NoRepeatPi- c v n<m st₀↦stₙ st₀↦stₘ = NoRepeat (λ ()) n<m st₀↦stₙ st₀↦stₘ


------------------------------------------------------------------------------
-- The unary numbers are FOTC total natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Data.Nat.UnaryNumbers.TotalityATP where

open import FOTC.Base
open import FOTC.Data.Nat.Type
open import FOTC.Data.Nat.UnaryNumbers

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

postulate
  0-N : N 0'
  1-N : N 1'
  2-N : N 2'
  3-N : N 3'
  4-N : N 4'
  5-N : N 5'
{-# ATP prove 0-N #-}
{-# ATP prove 1-N #-}
{-# ATP prove 2-N #-}
{-# ATP prove 3-N #-}
{-# ATP prove 4-N #-}
{-# ATP prove 5-N #-}

postulate
  10-N : N 10'
  11-N : N 11'
{-# ATP prove 10-N #-}
{-# ATP prove 11-N #-}

postulate 89-N : N 89'
{-# ATP prove 89-N #-}

postulate
  90-N : N 90'
  91-N : N 91'
  92-N : N 92'
  93-N : N 93'
  94-N : N 94'
  95-N : N 95'
  96-N : N 96'
  97-N : N 97'
  98-N : N 98'
  99-N : N 99'
{-# ATP prove 90-N #-}
{-# ATP prove 91-N #-}
{-# ATP prove 92-N #-}
{-# ATP prove 93-N #-}
{-# ATP prove 94-N #-}
{-# ATP prove 95-N #-}
{-# ATP prove 96-N #-}
{-# ATP prove 97-N #-}
{-# ATP prove 98-N #-}
{-# ATP prove 99-N #-}

postulate
  100-N : N 100'
  101-N : N 101'
{-# ATP prove 100-N #-}
{-# ATP prove 101-N #-}

postulate 111-N : N 111'
{-# ATP prove 111-N #-}


-- Andreas, 2016-10-09, issue #2223

-- The level constraint solver needs to combine constraints
-- from different contexts and modules.
-- The parameter refinement broke this test case.

-- {-# OPTIONS -v tc.with.top:25 #-}
-- {-# OPTIONS -v tc.conv.nat:40 #-}
-- {-# OPTIONS -v tc.constr.add:45 #-}

open import Common.Level

module _ (a ℓ : Level) where

module Function where

  mutual
    X : Level
    X = _  -- Agda 2.5.1.1 solves this level meta

    X<=a : Set (X ⊔ a) → Set a
    X<=a A = A

    test : Set₁
    test with (lsuc ℓ)
    ... | _ = Set

      where
        a<=X : Set (X ⊔ a) → Set X
        a<=X A = A

-- Should solve all metas.


module SHE-Prelude where

record Functor (T : Set -> Set) : Set1 where
  field
    -- OPERATIONS ----------------------------------------------
    map     : forall {X Y} -> (X -> Y) -> T X -> T Y

record Applicative (T : Set -> Set) : Set1 where
  field
    -- OPERATIONS ----------------------------------------------
    pure         : forall {X} -> X -> T X
    _<*>_        : forall {X Y} -> T (X -> Y) -> T X -> T Y

data Zero : Set where

magic : forall {l}{A : Set l} -> Zero -> A
magic ()

record One : Set where
  constructor <>
open One public
{-# COMPILED_DATA One () () #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Homomorphism proofs for multiplication over polynomials
------------------------------------------------------------------------

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

open import Tactic.RingSolver.Core.Polynomial.Parameters

module Tactic.RingSolver.Core.Polynomial.Homomorphism.Multiplication
  {r₁ r₂ r₃ r₄}
  (homo : Homomorphism r₁ r₂ r₃ r₄)
  where

open import Data.Nat.Base as ℕ          using (ℕ; suc; zero; _<′_; _≤′_; ≤′-step; ≤′-refl)
open import Data.Nat.Properties    using (≤′-trans)
open import Data.Nat.Induction
open import Data.Product           using (_×_; _,_; proj₁; proj₂; map₁)
open import Data.List.Kleene
open import Data.Vec               using (Vec)
open import Function
open import Induction.WellFounded
open import Relation.Unary

open Homomorphism homo hiding (_^_)

open import Tactic.RingSolver.Core.Polynomial.Homomorphism.Lemmas homo
open import Tactic.RingSolver.Core.Polynomial.Homomorphism.Addition homo
open import Tactic.RingSolver.Core.Polynomial.Base from
open import Tactic.RingSolver.Core.Polynomial.Reasoning to
open import Tactic.RingSolver.Core.Polynomial.Semantics homo
open import Algebra.Operations.Ring rawRing

reassoc : ∀ {y} x z → x * (y * z) ≈ y * (x * z)
reassoc {y} x z = sym (*-assoc x y z) ⟨ trans ⟩ ((≪* *-comm x y) ⟨ trans ⟩ *-assoc y x z)

mutual
  ⊠-step′-hom : ∀ {n} → (a : Acc _<′_ n) → (xs ys : Poly n) → ∀ ρ → ⟦ ⊠-step′ a xs ys ⟧ ρ ≈ ⟦ xs ⟧ ρ * ⟦ ys ⟧ ρ
  ⊠-step′-hom a (x ⊐ p) = ⊠-step-hom a x p

  ⊠-step-hom : ∀ {i n}
             → (a : Acc _<′_ n)
             → (xs : FlatPoly i)
             → (i≤n : i ≤′ n)
             → (ys : Poly n)
             → ∀ ρ → ⟦ ⊠-step a xs i≤n ys ⟧ ρ ≈ ⟦ xs ⊐ i≤n ⟧ ρ * ⟦ ys ⟧ ρ
  ⊠-step-hom a (Κ x) i≤n = ⊠-Κ-hom a x
  ⊠-step-hom a (⅀ xs) i≤n = ⊠-⅀-hom a xs i≤n

  ⊠-Κ-hom : ∀ {n}
          → (a : Acc _<′_ n)
          → ∀ x
          → (ys : Poly n)
          → ∀ ρ
          → ⟦ ⊠-Κ a x ys ⟧ ρ ≈ ⟦ x ⟧ᵣ * ⟦ ys ⟧ ρ
  ⊠-Κ-hom (acc _)  x (Κ y  ⊐ i≤n) ρ = *-homo x y
  ⊠-Κ-hom (acc wf) x (⅀ xs ⊐ i≤n) ρ =
    begin
      ⟦ ⊠-Κ-inj (wf _ i≤n) x xs ⊐↓ i≤n ⟧ ρ
    ≈⟨ ⊐↓-hom (⊠-Κ-inj (wf _ i≤n) x xs) i≤n ρ ⟩
      ⅀?⟦ ⊠-Κ-inj (wf _ i≤n) x xs ⟧ (drop-1 i≤n ρ)
    ≈⟨ ⊠-Κ-inj-hom (wf _ i≤n) x xs (drop-1 i≤n ρ) ⟩
      ⟦ x ⟧ᵣ * ⅀⟦ xs ⟧ (drop-1 i≤n ρ)
    ∎

  ⊠-Κ-inj-hom : ∀ {n}
              → (a : Acc _<′_ n)
              → (x : Raw.Carrier)
              → (xs : Coeff n +)
              → ∀ ρ
              → ⅀?⟦ ⊠-Κ-inj a x xs ⟧ ρ ≈ ⟦ x ⟧ᵣ * ⅀⟦ xs ⟧ ρ
  ⊠-Κ-inj-hom {n} a x xs (ρ , Ρ) =
    poly-mapR
      ρ
      Ρ
      (⊠-Κ a x)
      (⟦ x ⟧ᵣ *_)
      (*-cong refl)
      reassoc
      (distribˡ ⟦ x ⟧ᵣ)
      (λ ys → ⊠-Κ-hom a x ys Ρ)
      (zeroʳ _)
      xs

  ⊠-⅀-hom : ∀ {i n}
          → (a : Acc _<′_ n)
          → (xs : Coeff i +)
          → (i<n : i <′ n)
          → (ys : Poly n)
          → ∀ ρ
          → ⟦ ⊠-⅀ a xs i<n ys ⟧ ρ ≈ ⅀⟦ xs ⟧ (drop-1 i<n ρ) * ⟦ ys ⟧ ρ
  ⊠-⅀-hom (acc wf) xs i<n (⅀ ys ⊐ j≤n) = ⊠-match-hom (acc wf) (inj-compare i<n j≤n) xs ys
  ⊠-⅀-hom (acc wf) xs i<n (Κ y  ⊐ _) ρ =
    begin
      ⟦ ⊠-Κ-inj (wf _ i<n) y xs ⊐↓ i<n ⟧ ρ
    ≈⟨ ⊐↓-hom (⊠-Κ-inj (wf _ i<n) y xs) i<n ρ ⟩
      ⅀?⟦ ⊠-Κ-inj (wf _ i<n) y xs ⟧ (drop-1 i<n ρ)
    ≈⟨ ⊠-Κ-inj-hom (wf _ i<n) y xs (drop-1 i<n ρ) ⟩
      ⟦ y ⟧ᵣ * ⅀⟦ xs ⟧ (drop-1 i<n ρ)
    ≈⟨ *-comm _ _ ⟩
      ⅀⟦ xs ⟧ (drop-1 i<n ρ) * ⟦ y ⟧ᵣ
    ∎

  ⊠-⅀-inj-hom : ∀ {i k}
              → (a : Acc _<′_ k)
              → (i<k : i <′ k)
              → (xs : Coeff i +)
              → (ys : Poly k)
              → ∀ ρ
              → ⟦ ⊠-⅀-inj a i<k xs ys ⟧ ρ ≈ ⅀⟦ xs ⟧ (drop-1 i<k ρ) * ⟦ ys ⟧ ρ
  ⊠-⅀-inj-hom (acc wf) i<k x (⅀ ys ⊐ j≤k) = ⊠-match-hom (acc wf) (inj-compare i<k j≤k) x ys
  ⊠-⅀-inj-hom (acc wf) i<k x (Κ y ⊐ j≤k) ρ =
    begin
      ⟦ ⊠-Κ-inj (wf _ i<k) y x ⊐↓ i<k ⟧ ρ
    ≈⟨ ⊐↓-hom (⊠-Κ-inj (wf _ i<k) y x) i<k ρ ⟩
      ⅀?⟦ ⊠-Κ-inj (wf _ i<k) y x ⟧ (drop-1 i<k ρ)
    ≈⟨ ⊠-Κ-inj-hom (wf _ i<k) y x (drop-1 i<k ρ) ⟩
      ⟦ y ⟧ᵣ * ⅀⟦ x ⟧ (drop-1 i<k ρ)
    ≈⟨ *-comm _ _ ⟩
      ⅀⟦ x ⟧ (drop-1 i<k ρ) * ⟦ y ⟧ᵣ
    ∎

  ⊠-match-hom : ∀ {i j n}
              → (a : Acc _<′_ n)
              → {i<n : i <′ n}
              → {j<n : j <′ n}
              → (ord : InjectionOrdering i<n j<n)
              → (xs : Coeff i +)
              → (ys : Coeff j +)
              → (Ρ : Vec Carrier n)
              → ⟦ ⊠-match a ord xs ys ⟧ Ρ
              ≈ ⅀⟦ xs ⟧ (drop-1 i<n Ρ) * ⅀⟦ ys ⟧ (drop-1 j<n Ρ)
  ⊠-match-hom {j = j} (acc wf) (inj-lt i≤j-1 j≤n) xs ys Ρ′ =
    let (ρ , Ρ) = drop-1 j≤n Ρ′
        xs′ = ⅀⟦ xs ⟧ (drop-1 (≤′-trans (≤′-step i≤j-1) j≤n) Ρ′)
    in
    begin
      ⟦ poly-map ( (⊠-⅀-inj (wf _ j≤n) i≤j-1 xs)) ys ⊐↓ j≤n ⟧ Ρ′
    ≈⟨ ⊐↓-hom (poly-map ( (⊠-⅀-inj (wf _ j≤n) i≤j-1 xs)) ys) j≤n Ρ′ ⟩
      ⅀?⟦ poly-map ( (⊠-⅀-inj (wf _ j≤n) i≤j-1 xs)) ys ⟧ (ρ , Ρ)
    ≈⟨ poly-mapR ρ Ρ (⊠-⅀-inj (wf _ j≤n) i≤j-1 xs)
                     (_ *_)
                     (*-cong refl)
                     reassoc
                     (distribˡ _)
                     (λ y → ⊠-⅀-inj-hom (wf _ j≤n) i≤j-1 xs y _)
                     (zeroʳ _) ys ⟩
       ⅀⟦ xs ⟧ (drop-1 i≤j-1 Ρ) * ⅀⟦ ys ⟧ (ρ , Ρ)
    ≈⟨ ≪* trans-join-coeffs-hom i≤j-1 j≤n xs Ρ′ ⟩
      xs′ * ⅀⟦ ys ⟧ (ρ , Ρ)
    ∎
  ⊠-match-hom (acc wf) (inj-gt i≤n j≤i-1) xs ys Ρ′ =
    let (ρ , Ρ) = drop-1 i≤n Ρ′
        ys′ = ⅀⟦ ys ⟧ (drop-1 (≤′-step j≤i-1 ⟨ ≤′-trans ⟩ i≤n) Ρ′)
    in
    begin
      ⟦ poly-map ( (⊠-⅀-inj (wf _ i≤n) j≤i-1 ys)) xs ⊐↓ i≤n ⟧ Ρ′
    ≈⟨ ⊐↓-hom (poly-map ( (⊠-⅀-inj (wf _ i≤n) j≤i-1 ys)) xs) i≤n Ρ′ ⟩
      ⅀?⟦ poly-map ( (⊠-⅀-inj (wf _ i≤n) j≤i-1 ys)) xs ⟧ (ρ , Ρ)
    ≈⟨ poly-mapR ρ Ρ (⊠-⅀-inj (wf _ i≤n) j≤i-1 ys)
                     (_ *_)
                     (*-cong refl)
                     reassoc
                     (distribˡ _)
                     (λ x → ⊠-⅀-inj-hom (wf _ i≤n) j≤i-1 ys x _)
                     (zeroʳ _) xs ⟩
      ⅀⟦ ys ⟧ (drop-1 j≤i-1 Ρ) * ⅀⟦ xs ⟧ (ρ , Ρ)
    ≈⟨ ≪* trans-join-coeffs-hom j≤i-1 i≤n ys Ρ′ ⟩
      ys′ * ⅀⟦ xs ⟧ (ρ , Ρ)
    ≈⟨ *-comm ys′ _ ⟩
      ⅀⟦ xs ⟧ (ρ , Ρ) * ys′
    ∎
  ⊠-match-hom (acc wf) (inj-eq ij≤n) xs ys Ρ =
    begin
      ⟦ ⊠-coeffs (wf _ ij≤n) xs ys ⊐↓ ij≤n ⟧ Ρ
    ≈⟨ ⊐↓-hom (⊠-coeffs (wf _ ij≤n) xs ys) ij≤n Ρ ⟩
      ⅀?⟦ ⊠-coeffs (wf _ ij≤n) xs ys ⟧ (drop-1 ij≤n Ρ)
    ≈⟨ ⊠-coeffs-hom (wf _ ij≤n) xs ys (drop-1 ij≤n Ρ) ⟩
      ⅀⟦ xs ⟧ (drop-1 ij≤n Ρ) * ⅀⟦ ys ⟧ (drop-1 ij≤n Ρ)
    ∎

  ⊠-coeffs-hom : ∀ {n}
               → (a : Acc _<′_ n)
               → (xs ys : Coeff n +)
               → ∀ ρ → ⅀?⟦ ⊠-coeffs a xs ys ⟧ ρ ≈ ⅀⟦ xs ⟧ ρ * ⅀⟦ ys ⟧ ρ
  ⊠-coeffs-hom a xs (y ≠0 Δ j & []) (ρ , Ρ) =
    begin
      ⅀?⟦ poly-map (⊠-step′ a y) xs ⍓* j ⟧ (ρ , Ρ)
    ≈⟨ sym (pow′-hom j (poly-map (⊠-step′ a y) xs) ρ Ρ) ⟩
      ⅀?⟦ poly-map (⊠-step′ a y) xs ⟧ (ρ , Ρ) *⟨ ρ ⟩^ j
    ≈⟨ pow-mul-cong (poly-mapR ρ Ρ (⊠-step′ a y) (⟦ y ⟧ Ρ *_) (*-cong refl) reassoc (distribˡ _) (λ z → ⊠-step′-hom a y z Ρ) (zeroʳ _) xs) ρ j ⟩
      (⟦ y ⟧ Ρ * ⅀⟦ xs ⟧ (ρ , Ρ)) *⟨ ρ ⟩^ j
    ≈⟨ pow-opt _ ρ j ⟩
      (ρ ^ j) * (⟦ y ⟧ Ρ * ⅀⟦ xs ⟧ (ρ , Ρ))
    ≈⟨ sym (*-assoc _ _ _) ⟩
      (ρ ^ j) * ⟦ y ⟧ Ρ * ⅀⟦ xs ⟧ (ρ , Ρ)
    ≈⟨ *-comm _ _ ⟩
      ⅀⟦ xs ⟧ (ρ , Ρ) * ((ρ ^ j) * ⟦ y ⟧ Ρ)
    ≈⟨ *≫ sym (pow-opt _ ρ j) ⟩
      ⅀⟦ xs ⟧ (ρ , Ρ) * (⟦ y ⟧ Ρ *⟨ ρ ⟩^ j)
    ∎
  ⊠-coeffs-hom a xs (y ≠0 Δ j & ∹ ys) (ρ , Ρ) =
    let xs′ = ⅀⟦ xs ⟧ (ρ , Ρ)
        y′  = ⟦ y ⟧ Ρ
        ys′ = ⅀⟦ ys ⟧ (ρ , Ρ)
    in
    begin
      ⅀?⟦ para (⊠-cons a y ys) xs ⍓* j ⟧ (ρ , Ρ)
    ≈⟨ sym (pow′-hom j (para (⊠-cons a y ys) xs) ρ Ρ) ⟨ trans ⟩ pow-opt _ ρ j ⟩
      ρ ^ j * ⅀?⟦ para (⊠-cons a y ys) xs ⟧ (ρ , Ρ)
    ≈⟨ *≫ ⊠-cons-hom a y ys xs ρ Ρ ⟩
     ρ ^ j * (xs′ * (ρ * ys′ + y′))
    ≈⟨ sym (*-assoc _ _ _) ⟨ trans ⟩ (≪* *-comm _ _) ⟨ trans ⟩ *-assoc _ _ _ ⟨ trans ⟩ (*≫ sym (pow-opt _ ρ j))⟩
      xs′ * ((ρ * ys′ + y′) *⟨ ρ ⟩^ j)
    ∎

  ⊠-cons-hom : ∀ {n}
             → (a : Acc _<′_ n)
             → (y : Poly n)
             → (ys xs : Coeff n +)
             → (ρ : Carrier)
             → (Ρ : Vec Carrier n)
             → ⅀?⟦ para (⊠-cons a y ys) xs ⟧ (ρ , Ρ)
             ≈ ⅀⟦ xs ⟧ (ρ , Ρ) * (ρ * ⅀⟦ ys ⟧ (ρ , Ρ) + ⟦ y ⟧ Ρ)
  -- ⊠-cons-hom a y [] xs ρ Ρ = {!!}
  ⊠-cons-hom a y ys xs ρ Ρ = poly-foldR ρ Ρ (⊠-cons a y ys) (flip _*_ (ρ * ⅀⟦ ys ⟧ (ρ , Ρ) + ⟦ y ⟧ Ρ)) (flip *-cong refl) (λ x y → sym (*-assoc x y _)) step (zeroˡ _) xs
    where
    step = λ { (z ⊐ j≤n) {ys₁} zs ys≋zs →
      let x′  = ⟦ z ⊐ j≤n ⟧ Ρ
          xs′ = ⅀?⟦ zs ⟧ (ρ , Ρ)
          y′  = ⟦ y ⟧ Ρ
          ys′ = ⅀⟦ ys ⟧ (ρ , Ρ)
          step = λ y → ⊠-step-hom a z j≤n y Ρ
      in
      begin
        ρ * ⅀?⟦ ⊞-coeffs (poly-map ( (⊠-step a z j≤n)) ys) ys₁ ⟧ (ρ , Ρ) + ⟦ ⊠-step a z j≤n y ⟧ Ρ
      ≈⟨ (*≫ ⊞-coeffs-hom (poly-map (⊠-step a z j≤n) ys) _ (ρ , Ρ)) ⟨ +-cong ⟩ ⊠-step-hom a z j≤n y Ρ ⟩
        ρ * (⅀?⟦ poly-map (⊠-step a z j≤n) ys ⟧ (ρ , Ρ) + ⅀?⟦ ys₁ ⟧ (ρ , Ρ)) + x′ * y′
      ≈⟨ ≪+ *≫ (poly-mapR ρ Ρ (⊠-step a z j≤n) (x′ *_) (*-cong refl) reassoc (distribˡ _) step (zeroʳ _) ys ⟨ +-cong ⟩ ys≋zs) ⟩
        ρ * (x′ * ys′ + xs′ * (ρ * ys′ + y′)) + (x′ * y′)
      ≈⟨ ≪+ distribˡ _ _ _ ⟩
        ρ * (x′ * ys′) + ρ * (xs′ * (ρ * ys′ + y′)) + (x′ * y′)
      ≈⟨ (≪+ +-comm _ _) ⟨ trans ⟩ +-assoc _ _ _ ⟩
        ρ * (xs′ * (ρ * ys′ + y′)) + (ρ * (x′ * ys′) + (x′ * y′))
      ≈⟨ sym (*-assoc _ _ _) ⟨ +-cong ⟩ ((≪+ (sym (*-assoc _ _ _) ⟨ trans ⟩ (≪* *-comm _ _) ⟨ trans ⟩ *-assoc _ _ _)) ⟨ trans ⟩ sym (distribˡ _ _ _)) ⟩
        ρ * xs′ * (ρ * ys′ + y′) + x′ * (ρ * ys′ + y′)
      ≈⟨ sym (distribʳ _ _ _) ⟩
        (ρ * xs′ + x′) * (ρ * ys′ + y′)
      ∎ }

⊠-hom : ∀ {n} (xs ys : Poly n) →
        ∀ ρ → ⟦ xs ⊠ ys ⟧ ρ ≈ ⟦ xs ⟧ ρ * ⟦ ys ⟧ ρ
⊠-hom (xs ⊐ i≤n) = ⊠-step-hom (<′-wellFounded _) xs i≤n


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

open import Base
open import Homotopy.Pushout
open import Homotopy.VanKampen.Guide

module Homotopy.VanKampen.Code.LemmaPackB {i} (d : pushout-diag i)
  (l : legend i (pushout-diag.C d)) where

  open pushout-diag d
  open legend l

  open import Homotopy.Truncation
  open import Homotopy.PathTruncation
  open import Homotopy.VanKampen.SplitCode d l

  abstract
    trans-q-code-a : ∀ {a₁ a₂} (q : a₁ ≡ a₂) {a₃} (p : _ ≡₀ a₃)
      → transport (λ x → code-a x a₃) q (a a₁ p)
      ≡ a a₂ (proj (! q) ∘₀ p)
    trans-q-code-a refl p = ap (λ x → a _ x) $ ! $ refl₀-left-unit p

    trans-!q-code-a : ∀ {a₁ a₂} (q : a₂ ≡ a₁) {a₃} (p : _ ≡₀ a₃)
      → transport (λ x → code-a x a₃) (! q) (a a₁ p)
      ≡ a a₂ (proj q ∘₀ p)
    trans-!q-code-a refl p = ap (λ x → a _ x) $ ! $ refl₀-left-unit p

    trans-q-code-ba : ∀ {a₁ a₂} (q : a₁ ≡ a₂) {a₃} n co (p : _ ≡₀ a₃)
      → transport (λ x → code-a x a₃) q (ba a₁ n co p)
      ≡ ba a₂ n (transport (λ x → code-b x (g $ loc n)) q co) p
    trans-q-code-ba refl n co p = refl

    trans-q-code-ab : ∀ {a₁ a₂} (q : a₁ ≡ a₂) {b₃} n co (p : _ ≡₀ b₃)
      → transport (λ x → code-b x b₃) q (ab a₁ n co p)
      ≡ ab a₂ n (transport (λ x → code-a x (f $ loc n)) q co) p
    trans-q-code-ab refl n co p = refl


module Class.MonadTrans where

open import Class.Monad
open import Level

record MonadTrans {a} (T : (Set a -> Set a) -> Set a -> Set a) : Set (suc a) where
  field
    embed : {A : Set a} {M : Set a -> Set a} {{_ : Monad M}} -> M A -> T M A

open MonadTrans {{...}} public


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra where

open import Cubical.Algebra.CommAlgebra.Base public
open import Cubical.Algebra.CommAlgebra.Properties public


------------------------------------------------------------------------------
-- Testing the translation of definitions
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module Issue4 where

postulate
  D    : Set
  _≡_  : D → D → Set
  refl : ∀ {a} → a ≡ a
  P    : D → Set

-- We test the translation of a definition where we need to erase proof terms.
foo : ∀ {a} → P a → ∀ {b} → P b → a ≡ a
foo {a} Pa {b} Pb = bar
  where
  c : D
  c = a
  {-# ATP definition c #-}

  postulate bar : c ≡ a
  {-# ATP prove bar #-}


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

open import Relation.Nullary.Decidable using (toWitness; fromWitness)
open import Relation.Nullary using (yes; no)
open import Function using (_∘_)

import Data.Empty as Empty
import Data.Product as Product
import Data.Product.Properties as Productₚ
import Data.Unit as Unit
import Data.Nat.Base as Nat
import Data.Vec.Base as Vec
import Data.Vec.Properties as Vecₚ
import Data.Fin.Base as Fin
import Data.Vec.Relation.Unary.All as All

open Empty using (⊥-elim)
open Unit using (tt)
open Nat using (ℕ; zero; suc)
open Vec using (Vec; []; _∷_)
open All using (All; []; _∷_)
open Fin using (Fin ; zero ; suc)
open Product using (_×_; _,_; proj₁; proj₂)

import PiCalculus.Syntax
open PiCalculus.Syntax.Scoped
open import PiCalculus.Semantics
open import PiCalculus.LinearTypeSystem.Algebras

module PiCalculus.LinearTypeSystem.Framing (Ω : Algebras) where
open Algebras Ω
open import PiCalculus.LinearTypeSystem Ω
open import PiCalculus.LinearTypeSystem.ContextLemmas Ω

private
  variable
    n : ℕ
    i j : Fin n
    idx : Idx
    idxs : Idxs n
    γ : PreCtx n
    t : Type
    x y z : Usage idx
    Γ Θ Δ Ξ : Ctx idxs
    P Q : Scoped n

∋-frame : {idxs : Idxs n} {Γ Θ Δ Ξ Ψ : Ctx idxs} {x : Usage idx ²}
        → Γ ≔ Δ ⊗ Θ → Ξ ≔ Δ ⊗ Ψ
        → Γ ∋[ i ] x ▹ Θ
        → Ξ ∋[ i ] x ▹ Ψ

∋-frame (Γ≔ , x≔) (Ξ≔ , x'≔) (zero xyz)
  rewrite ⊗-uniqueˡ Γ≔ ⊗-idˡ | ⊗-unique Ξ≔ ⊗-idˡ
  | ∙²-uniqueˡ x≔ xyz = zero x'≔
∋-frame (Γ≔ , x≔) (Ξ≔ , x'≔) (suc x)
  rewrite ∙²-uniqueˡ x≔ ∙²-idˡ | ∙²-unique x'≔ ∙²-idˡ
  = suc (∋-frame Γ≔ Ξ≔ x)

⊢-frame : {γ : PreCtx n} {idxs : Idxs n} {Γ Δ Θ Ξ Ψ : Ctx idxs}
        → Γ ≔ Δ ⊗ Θ → Ξ ≔ Δ ⊗ Ψ
        → γ ； Γ ⊢ P ▹ Θ
        → γ ； Ξ ⊢ P ▹ Ψ

⊢-frame Γ≔ Ξ≔ 𝟘 rewrite ⊗-uniqueˡ Γ≔ ⊗-idˡ | ⊗-unique Ξ≔ ⊗-idˡ = 𝟘
⊢-frame Γ≔ Ξ≔ (ν t m μ ⊢P)
  = ν t m μ (⊢-frame {Δ = _ -, (μ , μ)} (Γ≔ , ∙²-idʳ) (Ξ≔ , ∙²-idʳ) ⊢P)
⊢-frame Γ≔ Ξ≔ ((t , ∋i) ⦅⦆ ⊢P) with ∋-⊗ ∋i | ⊢-⊗ ⊢P
⊢-frame Γ≔ Ξ≔ ((t , ∋i) ⦅⦆ ⊢P) | _ , i≔ , _ | (_ -, _) , (P≔ , x≔) =
  let iP≔           = ⊗-comp i≔ P≔ Γ≔
      _ , i'≔ , P'≔ = ⊗-assoc Ξ≔ iP≔
   in (t , ∋-frame i≔ i'≔ ∋i) ⦅⦆ ⊢-frame (P≔ , x≔) (P'≔ , x≔) ⊢P
⊢-frame Γ≔ Ξ≔ ((ti , ∋i) ⟨ tj , ∋j ⟩ ⊢P) with ∋-⊗ ∋i | ∋-⊗ ∋j | ⊢-⊗ ⊢P
⊢-frame Γ≔ Ξ≔ ((ti , ∋i) ⟨ tj , ∋j ⟩ ⊢P) | _ , i≔ , _ | _ , j≔ , _ | _ , P≔ =
  let _ , ij≔ , _    = ⊗-assoc⁻¹ i≔ j≔
      [ij]P≔         = ⊗-comp ij≔ P≔ Γ≔
      _ , ij'≔ , P'≔ = ⊗-assoc Ξ≔ [ij]P≔
      ij≔            = ⊗-comp i≔ j≔ ij≔
      _ , i'≔ , j'≔  = ⊗-assoc ij'≔ ij≔
   in (ti , ∋-frame i≔ i'≔ ∋i) ⟨ tj , ∋-frame j≔ j'≔ ∋j ⟩ ⊢-frame P≔ P'≔ ⊢P
⊢-frame Γ≔ Ξ≔ (⊢P ∥ ⊢Q) with ⊢-⊗ ⊢P | ⊢-⊗ ⊢Q
⊢-frame Γ≔ Ξ≔ (⊢P ∥ ⊢Q) | _ , P≔ | _ , Q≔ =
  let PQ≔           = ⊗-comp P≔ Q≔ Γ≔
      _ , P'≔ , Q'≔ = ⊗-assoc Ξ≔ PQ≔
   in ⊢-frame P≔ P'≔ ⊢P ∥ ⊢-frame Q≔ Q'≔ ⊢Q


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

open import HoTT
open import homotopy.HSpace renaming (HSpaceStructure to HSS)
open import homotopy.WedgeExtension

module homotopy.Pi2HSusp where

module Pi2HSusp {i} {X : Ptd i}
  {{_ : has-level 1 (de⊙ X)}}
  {{_ : is-connected 0 (de⊙ X)}}
  (H-X : HSS X) where

  {- TODO this belongs somewhere else, but where? -}
  private
    Type=-ext : ∀ {i} {A B : Type i} (p q : A == B)
      → (coe p ∼ coe q) → p == q
    Type=-ext p q α =
      ! (ua-η p)
      ∙ ap ua (Subtype=-out is-equiv-prop (λ= α))
      ∙ ua-η q

  module μ = ConnectedHSpace H-X
  μ = μ.μ
  private
    A = de⊙ X
    e = pt X

  back : south == north
  back = ! (merid e)

  private
    P : Susp A → Type i
    P x = Trunc 1 (north == x)

  module Codes = SuspRec A A (λ a → ua (μ.r-equiv a))

  Codes : Susp A → Type i
  Codes = Codes.f

  Codes-level : (x : Susp A) → has-level 1 (Codes x)
  Codes-level = Susp-elim ⟨⟩ ⟨⟩
    (λ _ → prop-has-all-paths-↓)

  encode'₀ : {x : Susp A} → (north == x) → Codes x
  encode'₀ α = transport Codes α e

  encode' : {x : Susp A} → P x → Codes x
  encode' {x} = Trunc-rec {{Codes-level x}} encode'₀

  import homotopy.SuspAdjointLoop as SAL
  η : A → north == north
  η = fst (SAL.η X)

  decodeN' : A → P north
  decodeN' = [_] ∘ η

  abstract
    transport-Codes-mer : (a a' : A)
      → transport Codes (merid a) a' == μ a a'
    transport-Codes-mer a a' =
      coe (ap Codes (merid a)) a'
        =⟨ Codes.merid-β a |in-ctx (λ w → coe w a') ⟩
      coe (ua (μ.r-equiv a)) a'
        =⟨ coe-β (μ.r-equiv a) a' ⟩
      μ a a' ∎

    transport-Codes-mer-e-! : (a : A)
      → transport Codes back a == a
    transport-Codes-mer-e-! a =
      coe (ap Codes back) a
        =⟨ ap-! Codes (merid e) |in-ctx (λ w → coe w a) ⟩
      coe (! (ap Codes (merid e))) a
        =⟨ Codes.merid-β e |in-ctx (λ w → coe (! w) a) ⟩
      coe (! (ua (μ.r-equiv e))) a
        =⟨ Type=-ext (ua (μ.r-equiv e)) idp (λ x → coe-β _ x ∙ μ.unit-l x)
          |in-ctx (λ w → coe (! w) a) ⟩
      coe (! idp) a ∎

  abstract
    encode'-decodeN' : (a : A) → encode' (decodeN' a) == a
    encode'-decodeN' a =
      transport Codes (merid a ∙ back) e
        =⟨ transp-∙ {B = Codes} (merid a) back e ⟩
      transport Codes back (transport Codes (merid a) e)
        =⟨ transport-Codes-mer a e ∙ μ.unit-r a
          |in-ctx (λ w → transport Codes back w) ⟩
      transport Codes back a
        =⟨ transport-Codes-mer-e-! a ⟩
      a ∎

  add-path-and-inverse-l : ∀ {k} {B : Type k} {x y z : B}
    → (p : y == x) (q : y == z)
    → q == (p ∙ ! p) ∙ q
  add-path-and-inverse-l p q = ap (λ s → s ∙ q) (! (!-inv-r p))

  add-path-and-inverse-r : ∀ {k} {B : Type k} {x y z : B}
    → (p : x == y) (q : z == y)
    → p == (p ∙ ! q) ∙ q
  add-path-and-inverse-r p q =
    ! (∙-unit-r p) ∙ ap (λ s → p ∙ s) (! (!-inv-l q)) ∙ ! (∙-assoc p (! q) q)

  homomorphism-l : (a' : A) → merid (μ e a') == (merid a' ∙ back) ∙ merid e
  homomorphism-l a' = ap merid (μ.unit-l a') ∙ add-path-and-inverse-r (merid a') (merid e)

  homomorphism-r : (a : A) → merid (μ a e) == (merid e ∙ back) ∙ merid a
  homomorphism-r a = ap merid (μ.unit-r a) ∙ add-path-and-inverse-l (merid e) (merid a)

  homomorphism-l₁ : (a' : A) → [ merid (μ e a') ]₁ == [ (merid a' ∙ back) ∙ merid e ]₁
  homomorphism-l₁ = ap [_]₁ ∘ homomorphism-l

  homomorphism-r₁ : (a : A) → [ merid (μ a e) ]₁ == [ (merid e ∙ back) ∙ merid a ]₁
  homomorphism-r₁ = ap [_]₁ ∘ homomorphism-r

  abstract
    homomorphism-args : args {i} {i} {A} {e} {A} {e}
    homomorphism-args =
      record {
        m = -1; n = -1;
        P = λ a a' → (Q a a' , ⟨⟩);
        f = homomorphism-r₁;
        g = homomorphism-l₁;
        p = ap (λ {(p₁ , p₂) → ap [_] (ap merid p₁ ∙ p₂)})
               (pair×= (! μ.coh) (coh (merid e)))
      }
      where
        Q : A → A → Type i
        Q a a' = [ merid (μ a a' ) ]₁ == [ (merid a' ∙ back) ∙ merid a ]₁
        coh : {B : Type i} {b b' : B} (p : b == b')
          → add-path-and-inverse-l p p == add-path-and-inverse-r p p
        coh idp = idp

    module HomomorphismExt =
      WedgeExt {i} {i} {A} {e} {A} {e} homomorphism-args

    homomorphism : (a a' : A)
      → [ merid (μ a a' ) ]₁ == [ (merid a' ∙ back) ∙ merid a ]₁
    homomorphism = HomomorphismExt.ext

    homomorphism-β-l : (a' : A) → homomorphism e a' == homomorphism-l₁ a'
    homomorphism-β-l = HomomorphismExt.β-r

    homomorphism-β-r : (a : A) → homomorphism a e == homomorphism-r₁ a
    homomorphism-β-r = HomomorphismExt.β-l

  decode' : {x : Susp A} → Codes x → P x
  decode' {x} = Susp-elim {P = λ x → Codes x → P x}
                 decodeN'
                 (λ a → [ merid a ])
                 (λ a → ↓-→-from-transp (λ= $ STS a))
                 x
    where
    abstract
      STS : (a a' : A) → transport P (merid a) (decodeN' a')
                         == [ merid (transport Codes (merid a) a') ]
      STS a a' =
        transport P (merid a) [ merid a' ∙ back ]
          =⟨ transport-Trunc' (north ==_) (merid a) _ ⟩
        [ transport (north ==_) (merid a) (merid a' ∙ back) ]
          =⟨ ap [_] (transp-cst=idf {A = Susp A} (merid a) _) ⟩
        [ (merid a' ∙ back) ∙ merid a ]
          =⟨ ! (homomorphism a a') ⟩
        [ merid (μ a a') ]
          =⟨ ap ([_] ∘ merid) (! (transport-Codes-mer a a')) ⟩
        [ merid (transport Codes (merid a) a') ] ∎

  decode'-encode' : {x : Susp A} (tα : P x)
    → decode' {x} (encode' {x} tα) == tα
  decode'-encode' {x} = Trunc-elim
    {P = λ tα → decode' {x} (encode' {x} tα) == tα}
    -- FIXME: Agda very slow (looping?) when omitting the next line
    {{λ _ → =-preserves-level Trunc-level}}
    (J (λ y p → decode' {y} (encode' {y} [ p ]) == [ p ])
        (ap [_] (!-inv-r (merid e))))

  eq' : Trunc 1 (Ω (⊙Susp (de⊙ X))) ≃ A
  eq' = equiv encode' decodeN' encode'-decodeN' decode'-encode'

  ⊙decodeN : ⊙Trunc 1 X ⊙→ ⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X)))
  ⊙decodeN = ⊙Trunc-fmap (SAL.η X)

  decodeN : Trunc 1 A → Trunc 1 (Ω (⊙Susp (de⊙ X)))
  decodeN = fst ⊙decodeN

  encodeN : Trunc 1 (Ω (⊙Susp (de⊙ X))) → Trunc 1 A
  encodeN = [_] ∘ encode' {x = north}

  ⊙encodeN : ⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X))) ⊙→ ⊙Trunc 1 X
  ⊙encodeN = encodeN , idp

  eq : Trunc 1 (Ω (⊙Susp (de⊙ X))) ≃ Trunc 1 A
  eq = encodeN ,
    replace-inverse (snd ((unTrunc-equiv A)⁻¹ ∘e eq'))
      {decodeN}
      (Trunc-elim (λ _ → idp))

  ⊙eq : ⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X))) ⊙≃ ⊙Trunc 1 X
  ⊙eq = ≃-to-⊙≃ eq idp

  abstract
    ⊙decodeN-⊙encodeN : ⊙decodeN ⊙∘ ⊙encodeN == ⊙idf _
    ⊙decodeN-⊙encodeN =
      ⊙λ=' {X = ⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X)))} {Y = ⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X)))}
           decode'-encode' $
      ↓-idf=cst-in $
      ! (∙-unit-r (ap [_] (!-inv-r (merid (pt X)))))

    ⊙<–-⊙eq : ⊙<– ⊙eq == ⊙decodeN
    ⊙<–-⊙eq =
      –>-is-inj (pre⊙∘-equiv {Z = ⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X)))} ⊙eq) (⊙<– ⊙eq) ⊙decodeN $
      (⊙<– ⊙eq) ⊙∘ ⊙encodeN
        =⟨ ⊙<–-inv-l ⊙eq ⟩
      ⊙idf _
        =⟨ ! ⊙decodeN-⊙encodeN ⟩
      ⊙decodeN ⊙∘ ⊙encodeN =∎

    ⊙encodeN-⊙decodeN : ⊙encodeN ⊙∘ ⊙decodeN == ⊙idf _
    ⊙encodeN-⊙decodeN =
      ⊙encodeN ⊙∘ ⊙decodeN
        =⟨ ap (⊙encodeN ⊙∘_) (! ⊙<–-⊙eq) ⟩
      ⊙encodeN ⊙∘ ⊙<– ⊙eq
        =⟨ ⊙<–-inv-r ⊙eq ⟩
      ⊙idf _ =∎

  ⊙eq⁻¹ : ⊙Trunc 1 X ⊙≃ ⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X)))
  ⊙eq⁻¹ = ⊙decodeN , snd (eq ⁻¹)

  iso : Ω^S-group 0 (⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X))))
      ≃ᴳ Ω^S-group 0 (⊙Trunc 1 X)
  iso = Ω^S-group-emap 0 ⊙eq

  abstract
    π₂-Susp : πS 1 (⊙Susp (de⊙ X)) ≃ᴳ πS 0 X
    π₂-Susp =
      πS 1 (⊙Susp (de⊙ X))
        ≃ᴳ⟨ πS-Ω-split-iso 0 (⊙Susp (de⊙ X)) ⟩
      πS 0 (⊙Ω (⊙Susp (de⊙ X)))
        ≃ᴳ⟨ Ω^S-group-Trunc-fuse-diag-iso 0 (⊙Ω (⊙Susp (de⊙ X))) ⁻¹ᴳ ⟩
      Ω^S-group 0 (⊙Trunc 1 (⊙Ω (⊙Susp (de⊙ X))))
        ≃ᴳ⟨ iso ⟩
      Ω^S-group 0 (⊙Trunc 1 X)
        ≃ᴳ⟨ Ω^S-group-Trunc-fuse-diag-iso 0 X ⟩
      πS 0 X ≃ᴳ∎

module Pi2HSuspNaturality {i} {X Y : Ptd i}
  (f : X ⊙→ Y)
  {{_ : has-level 1 (de⊙ X)}} {{_ : has-level 1 (de⊙ Y)}}
  {{_ : is-connected 0 (de⊙ X)}} {{_ : is-connected 0 (de⊙ Y)}}
  (H-X : HSS X) (H-Y : HSS Y) where

  import homotopy.SuspAdjointLoop as SAL
  private
    module Π₂X = Pi2HSusp H-X
    module Π₂Y = Pi2HSusp H-Y

  ⊙decodeN-natural :
    Π₂Y.⊙decodeN ◃⊙∘
    ⊙Trunc-fmap f ◃⊙idf
    =⊙∘
    ⊙Trunc-fmap (⊙Ω-fmap (⊙Susp-fmap (fst f))) ◃⊙∘
    Π₂X.⊙decodeN ◃⊙idf
  ⊙decodeN-natural = =⊙∘-in $
    Π₂Y.⊙decodeN ⊙∘ ⊙Trunc-fmap f
      =⟨ ⊙λ= (⊙Trunc-fmap-⊙∘ (SAL.η Y) f) ⟩
    ⊙Trunc-fmap (SAL.η Y ⊙∘ f)
      =⟨ ap ⊙Trunc-fmap (SAL.η-natural f) ⟩
    ⊙Trunc-fmap (⊙Ω-fmap (⊙Susp-fmap (fst f)) ⊙∘ SAL.η X)
      =⟨ ! (⊙λ= (⊙Trunc-fmap-⊙∘ (⊙Ω-fmap (⊙Susp-fmap (fst f))) (SAL.η X))) ⟩
    ⊙Trunc-fmap (⊙Ω-fmap (⊙Susp-fmap (fst f))) ⊙∘ Π₂X.⊙decodeN =∎

  ⊙encodeN-natural :
    Π₂Y.⊙encodeN ◃⊙∘
    ⊙Trunc-fmap (⊙Ω-fmap (⊙Susp-fmap (fst f))) ◃⊙idf
    =⊙∘
    ⊙Trunc-fmap f ◃⊙∘
    Π₂X.⊙encodeN ◃⊙idf
  ⊙encodeN-natural =
    Π₂Y.⊙encodeN ◃⊙∘
    ⊙Trunc-fmap (⊙Ω-fmap (⊙Susp-fmap (fst f))) ◃⊙idf
      =⊙∘⟨ 2 & 0 & =⊙∘-in {gs = Π₂X.⊙decodeN ◃⊙∘ Π₂X.⊙encodeN ◃⊙idf} $
           ! Π₂X.⊙decodeN-⊙encodeN ⟩
    Π₂Y.⊙encodeN ◃⊙∘
    ⊙Trunc-fmap (⊙Ω-fmap (⊙Susp-fmap (fst f))) ◃⊙∘
    Π₂X.⊙decodeN ◃⊙∘
    Π₂X.⊙encodeN ◃⊙idf
      =⊙∘⟨ 1 & 2 & !⊙∘ ⊙decodeN-natural ⟩
    Π₂Y.⊙encodeN ◃⊙∘
    Π₂Y.⊙decodeN ◃⊙∘
    ⊙Trunc-fmap f ◃⊙∘
    Π₂X.⊙encodeN ◃⊙idf
      =⊙∘⟨ 0 & 2 & =⊙∘-in {gs = ⊙idf-seq} Π₂Y.⊙encodeN-⊙decodeN ⟩
    ⊙Trunc-fmap f ◃⊙∘
    Π₂X.⊙encodeN ◃⊙idf ∎⊙∘


-- Andreas, 2012-03-09 do not solve relevant meta variable by irr. constraint
module Issue351a where

open import Common.Irrelevance
open import Common.Equality

data Bool : Set where
  true false : Bool

-- the Boolean b is not(!) constrained by the equation
f : (b : Bool) -> squash b ≡ squash true -> Bool
f b _ = b

test = f _ refl
-- meta needs to remain unsolved


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.List.Relation.Binary.Lex.NonStrict directly.
------------------------------------------------------------------------

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

module Data.List.Relation.Lex.NonStrict where

open import Data.List.Relation.Binary.Lex.NonStrict public

{-# WARNING_ON_IMPORT
"Data.List.Relation.Lex.NonStrict was deprecated in v1.0.
Use Data.List.Relation.Binary.Lex.NonStrict instead."
#-}


module UniDB.Morph.WeakenPrime where

open import UniDB.Spec
open import UniDB.Morph.ShiftsPrime
open import Function

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

data Weaken` : MOR where
  baseW : {γ : Dom} → Weaken` γ γ
  stepW : {γ₁ γ₂ : Dom} → Weaken` γ₁ γ₂  → Weaken` γ₁ (suc γ₂)

lkWeakenIx` : {γ₁ γ₂ : Dom} → Weaken` γ₁ γ₂ → Ix γ₁ → Ix γ₂
lkWeakenIx` baseW     i = i
lkWeakenIx` (stepW ξ) i = suc (lkWeakenIx` ξ i)

instance
  iLkWeaken` : {T : STX} {{vrT : Vr T}} → Lk T Weaken`
  lk {{iLkWeaken`}} ξ i = vr (lkWeakenIx` ξ i)

  iWkmWeaken` : Wkm Weaken`
  Wkm.wkm iWkmWeaken` zero    = baseW
  Wkm.wkm iWkmWeaken` (suc δ) = stepW (wkm {Weaken`} δ)

  iIdmWeaken` : Idm Weaken`
  idm {{iIdmWeaken`}} γ = baseW

  iWkWeaken` : {γ₁ : Dom} → Wk (Weaken` γ₁)
  wk₁ {{iWkWeaken`}} ξ = stepW ξ
  wk {{iWkWeaken`}} zero x = x
  wk {{iWkWeaken`}} (suc δ) x = wk₁ (wk δ x)
  wk-zero {{iWkWeaken`}} x = refl
  wk-suc {{iWkWeaken`}} δ x = refl

lkWeakenIx`-wkm : {γ : Dom} (δ : Dom) (i : Ix γ) →
  lkWeakenIx` (wkm {Weaken`} δ) i ≡ wk δ i
lkWeakenIx`-wkm zero    i = refl
lkWeakenIx`-wkm (suc δ) i = cong suc (lkWeakenIx`-wkm δ i)

instance
  iLkWkmWeaken` : {T : STX} {{vrT : Vr T}} → LkWkm T Weaken`
  lk-wkm {{iLkWkmWeaken` {T}}} δ i = cong (vr {T}) (lkWeakenIx`-wkm δ i)

  iCompWeaken` : Comp Weaken`
  _⊙_ {{iCompWeaken`}} ξ baseW      = ξ
  _⊙_ {{iCompWeaken`}} ξ (stepW ξ₂) = stepW (ξ ⊙ ξ₂)

wk-comp` : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Weaken` γ₁ γ₂) (ξ₂ : Weaken` γ₂ γ₃)
  (δ : Dom) → wk δ (ξ₁ ⊙ ξ₂) ≡ ξ₁ ⊙ wk δ ξ₂
wk-comp` ξ₁ ξ₂ zero    = refl
wk-comp` ξ₁ ξ₂ (suc δ) = cong stepW (wk-comp` ξ₁ ξ₂ δ)

lkIx-wk-weaken` : {γ₁ γ₂ : Dom} (δ : Dom) (ξ : Weaken` γ₁ γ₂) (i : Ix γ₁) →
  lk {Ix} {Weaken`} (wk δ ξ) i ≡ wk δ (lk {Ix} {Weaken`} ξ i)
lkIx-wk-weaken` zero    ξ i = refl
lkIx-wk-weaken` (suc δ) ξ i = cong suc (lkIx-wk-weaken` δ ξ i)

module _ (T : STX) {{vrT : Vr T}}  {{wkT : Wk T}} {{wkVrT : WkVr T}} where

  lk-wk₁-weaken` :
    {γ₁ γ₂ : Dom} (ξ : Weaken` γ₁ γ₂) (i : Ix γ₁) →
    lk {T} {Weaken`} (wk₁ ξ) i ≡ wk₁ (lk {T} {Weaken`} ξ i)
  lk-wk₁-weaken` ξ i = sym (wk₁-vr {T} (lk {Ix} {Weaken`} ξ i) )

  lk-wk-weaken` :
    {γ₁ γ₂ : Dom} (δ : Dom) (ξ : Weaken` γ₁ γ₂) (i : Ix γ₁) →
    lk {T} {Weaken`} (wk δ ξ) i ≡ wk δ (lk {T} {Weaken`} ξ i)
  lk-wk-weaken` δ ξ i = trans
    (cong (vr {T}) (lkIx-wk-weaken` δ ξ i))
    (sym (wk-vr {T} δ (lk {Ix} {Weaken`} ξ i)))

lkWeakenIx`-comp :
  {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Weaken` γ₁ γ₂) (ξ₂ : Weaken` γ₂ γ₃)
  (i : Ix γ₁) →
  lkWeakenIx` ((iCompWeaken` Comp.⊙ ξ₁) ξ₂) i ≡
  lkWeakenIx` ξ₂ (lkWeakenIx` ξ₁ i)
lkWeakenIx`-comp ξ₁ baseW      i = refl
lkWeakenIx`-comp ξ₁ (stepW ξ₂) i = cong suc (lkWeakenIx`-comp ξ₁ ξ₂ i)

instance
  iLkRenWeaken` : {T : STX} {{vrT : Vr T}} → LkRen T Weaken`
  lk-ren {{iLkRenWeaken`}} ξ i = refl

  iLkRenCompWeaken` : {T : STX} {{vrT : Vr T}} → LkRenComp T Weaken`
  lk-ren-comp {{iLkRenCompWeaken` {T}}} ξ₁ ξ₂ i =
    cong (vr {T}) (lkWeakenIx`-comp ξ₁ ξ₂ i)

  iCompIdmWeaken` : CompIdm Weaken`
  ⊙-idm {{iCompIdmWeaken`}} ξ = refl
  idm-⊙ {{iCompIdmWeaken`}} baseW = refl
  idm-⊙ {{iCompIdmWeaken`}} (stepW ξ) = cong stepW (idm-⊙ {Weaken`} ξ)

  iCompAssocWeaken` : CompAssoc Weaken`
  ⊙-assoc {{iCompAssocWeaken`}} ξ₁ ξ₂ baseW      = refl
  ⊙-assoc {{iCompAssocWeaken`}} ξ₁ ξ₂ (stepW ξ₃) =
    cong stepW (⊙-assoc {Weaken`} ξ₁ ξ₂ ξ₃)

⊙-wkm-weaken` : {γ₁ γ₂ : Dom} (ξ : Weaken` γ₁ γ₂) (δ : Dom) →
  ξ ⊙ wkm {Weaken`} δ ≡ wk δ ξ
⊙-wkm-weaken` ξ zero = refl
⊙-wkm-weaken` ξ (suc δ) = cong stepW (⊙-wkm-weaken` ξ δ)

extensionality-weaken` : {γ₁ γ₂ : Dom} (ξ₁ ξ₂ : Weaken` γ₁ γ₂)
  (hyp : (i : Ix γ₁) → lk {Ix} ξ₁ i ≡ lk {Ix} ξ₂ i) →
  ξ₁ ≡ ξ₂
extensionality-weaken` baseW baseW           hyp = refl
extensionality-weaken` baseW (stepW ξ₂)      hyp = case hyp zero of λ ()
extensionality-weaken` (stepW ξ₁) baseW      hyp = case hyp zero of λ ()
extensionality-weaken` (stepW ξ₁) (stepW ξ₂) hyp =
  cong stepW (extensionality-weaken` ξ₁ ξ₂ (suc-inj ∘ hyp))

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


------------------------------------------------------------------------
-- An alternative definition of the partiality monad: a variant of the
-- delay monad quotiented by a notion of weak bisimilarity
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --sized-types #-}

module Partiality-monad.Coinductive.Alternative where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (⊥)

open import Bijection equality-with-J using (_↔_)
open import Function-universe equality-with-J hiding (⊥↔⊥)
open import H-level equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
open import Quotient equality-with-paths

import Delay-monad.Alternative as A
import Delay-monad.Alternative.Equivalence as A
import Delay-monad.Alternative.Weak-bisimilarity as A
import Delay-monad.Bisimilarity as B
import Partiality-monad.Coinductive as C

-- The partiality monad, defined as the alternative definition of the
-- delay monad quotiented by weak bisimilarity.

_⊥ : ∀ {a} → Type a → Type a
A ⊥ = A.Delay A / A._≈_

-- The partiality monad is a set.

⊥-is-set : ∀ {a} {A : Type a} → Is-set (A ⊥)
⊥-is-set = /-is-set

-- This definition of the partiality monad is isomorphic to the one in
-- Partiality-monad.Coinductive, for sets, assuming extensionality.

⊥↔⊥ : ∀ {a} {A : Type a} →
      Is-set A →
      B.Extensionality a →
      A ⊥ ↔ A C.⊥
⊥↔⊥ {A = A} A-set delay-ext = D↔D /-cong lemma
  where
  D↔D = A.Delay↔Delay delay-ext

  lemma : (x y : A.Delay A) →
          x A.≈ y ⇔ ∥ _↔_.to D↔D x B.≈ _↔_.to D↔D y ∥
  lemma x y =
    x A.≈ y                            ↔⟨ inverse $ ∥∥↔ (A.≈-propositional x y) ⟩
    ∥ x A.≈ y ∥                        ↝⟨ ∥∥-cong-⇔ (A.≈⇔≈ A-set x y) ⟩□
    ∥ _↔_.to D↔D x B.≈ _↔_.to D↔D y ∥  □


-- 2010-10-02, see issue 334

module TerminationInfiniteRecord where

record Empty : Set where
  inductive
  constructor empty
  field
    fromEmpty : Empty

elimEmpty : Empty -> Set
elimEmpty (empty e) = elimEmpty e

-- this no longer termination checks
-- and it should not, since it is translated to
-- elimEmpty e' = elimEmpty (fromEmpty e')


module nodcap.NF.Show where

open import Data.String using (String)

open import nodcap.Base
open import nodcap.NF.Typing

import nodcap.Show as S

showTerm : {Γ : Environment} → ⊢ⁿᶠ Γ → String
showTerm {Γ} x = S.showTerm (fromNF x)


{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Program.Mirror.StructurallySmaller.StructurallySmaller where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Program.Mirror.Type

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

{-# TERMINATING #-}
foo : ∀ {ts} → Tree ts → D
foo (tree d fnil)           = d
foo (tree d (fcons Tt Fts)) = foo (tree d Fts)

{-# TERMINATING #-}
bar : ∀ {ts} → Tree ts → D
bar (tree d fnil)           = d
bar (tree d (fcons Tt Fts)) = helper (bar Tt) (bar (tree d Fts))
  where
  postulate helper : D → D → D

{-# TERMINATING #-}
bar₁ : ∀ ts → Tree ts → D
bar₁ .(node d []) (tree d fnil) = d
bar₁ .(node d (t ∷ ts)) (tree d (fcons {t} {ts} Tt Fts))
  = helper (bar₁ t Tt) (bar₁ (node d ts) (tree d Fts))
  where
  postulate helper : D → D → D


-- Pattern matching on a datatype in Prop is disallowed

{-# OPTIONS --enable-prop #-}

open import Agda.Builtin.Bool

data TestProp : Prop where
  p₁ p₂ : TestProp

toBool : TestProp → Bool
toBool p₁ = true
toBool p₂ = false


-- 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 --sized-types #-}

open import Data.Product
open import Data.Empty
open import Data.Sum
open import Data.Vec
open import Data.List as List
open import Data.Unit
open import Data.Fin
open import Data.Bool renaming (Bool to 𝔹)
open import Relation.Unary using (_∈_; _⊆_;_∉_)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Size
open import Codata.Thunk

open import is-lib.InfSys
open import Common using (Message)

module FairSubtyping-IS {𝕋 : Set} (message : Message 𝕋) where

  open Message message
  open import SessionType message
  open import Session message
  open import Transitions message
  open import Convergence message
  open import Divergence message
  open import Discriminator message
  open import Action message using (Action)
  open import Subtyping message
  open import FairSubtyping message as FS
  open import HasTrace message
  open import Compliance message
  open import FairCompliance message
  open import Trace message
  open import FairCompliance-IS message

  private
    U : Set
    U = SessionType × SessionType

  data FSubIS-RN : Set where
    nil-any end-def : FSubIS-RN
    ii oo : FSubIS-RN

  data FSubCOIS-RN : Set where
    co-conv : FSubCOIS-RN

  nil-any-r : FinMetaRule U
  nil-any-r .Ctx = SessionType
  nil-any-r .comp T =
    [] ,
    ------------------
    (nil , T)

  end-def-r : FinMetaRule U
  end-def-r .Ctx = Σ[ (T , S) ∈ SessionType × SessionType ] End T × Defined S
  end-def-r .comp ((T , S) , _) =
    [] ,
    ------------------
    (T , S)

  ii-r : MetaRule U
  ii-r .Ctx = Σ[ (f , g) ∈ Continuation × Continuation ] dom f ⊆ dom g
  ii-r .Pos ((f , _) , _) = Σ[ t ∈ 𝕋 ] t ∈ dom f
  ii-r .prems ((f , g) , _) (t , _) = f t .force , g t .force
  ii-r .conclu ((f , g) , _) = inp f , inp g

  oo-r : MetaRule U
  oo-r .Ctx = Σ[ (f , g) ∈ Continuation × Continuation ] dom g ⊆ dom f × Witness g
  oo-r .Pos ((_ , g) , _) = Σ[ t ∈ 𝕋 ] t ∈ dom g
  oo-r .prems ((f , g) , _) (t , _) = f t .force , g t .force
  oo-r .conclu ((f , g) , _) = out f , out g

  co-conv-r : FinMetaRule U
  co-conv-r .Ctx = Σ[ (T , S) ∈ SessionType × SessionType ] T ↓ S
  co-conv-r .comp ((T , S) , _) =
    [] ,
    ------------------
    (T , S)

  FSubIS : IS U
  FSubIS .Names = FSubIS-RN
  FSubIS .rules nil-any = from nil-any-r
  FSubIS .rules end-def = from end-def-r
  FSubIS .rules ii = ii-r
  FSubIS .rules oo = oo-r

  FSubCOIS : IS U
  FSubCOIS .Names = FSubCOIS-RN
  FSubCOIS .rules co-conv = from co-conv-r

  _≤F_ : SessionType → SessionType → Set
  T ≤F S = FCoInd⟦ FSubIS , FSubCOIS ⟧ (T , S)

  _≤Fᵢ_ : SessionType → SessionType → Set
  T ≤Fᵢ S = Ind⟦ FSubIS ∪ FSubCOIS ⟧ (T , S)

  _≤Fc_ : SessionType → SessionType → Set
  T ≤Fc S = CoInd⟦ FSubIS ⟧ (T , S)

  {- Specification using _⊢_ is correct wrt FairSubtypingS -}

  FSSpec-⊢ : U → Set
  FSSpec-⊢ (T , S) = ∀{R} → R ⊢ T → R ⊢ S

  spec-sound : ∀{T S} → FairSubtypingS T S → FSSpec-⊢ (T , S)
  spec-sound fs fc = fc-complete (fs (fc-sound fc))

  spec-complete : ∀{T S} → FSSpec-⊢ (T , S) → FairSubtypingS T S
  spec-complete fs fc = fc-sound (fs (fc-complete fc))

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

  {- Soundness -}
  -- Using bounded coinduction wrt SpecAux

  ≤Fᵢ->↓ : ∀{S T} → S ≤Fᵢ T → S ↓ T
  ≤Fᵢ->↓ (fold (inj₁ nil-any , _ , refl , _)) = nil-converges
  ≤Fᵢ->↓ (fold (inj₁ end-def , (_ , (end , def)) , refl , _)) = end-converges end def
  ≤Fᵢ->↓ (fold (inj₁ ii , _ , refl , pr)) = converge (pre-conv-inp-back λ x → ↓->preconv (≤Fᵢ->↓ (pr (_ , x))))
  ≤Fᵢ->↓ (fold (inj₁ oo , (_ , (incl , (t , ok-t))) , refl , pr)) =
    converge
      λ _ _ → [] , t , none , (_ , incl ok-t , step (out (incl ok-t)) refl) , (_ , ok-t , step (out ok-t) refl) , ≤Fᵢ->↓ (pr (t , ok-t))
  ≤Fᵢ->↓ (fold (inj₂ co-conv , (_ , conv) , refl , _)) = conv

  SpecAux : U → Set
  SpecAux (R , T) = Σ[ S ∈ SessionType ] S ≤F T × R ⊢ S

  ≤Fᵢ->defined : ∀{S T} → Defined S → S ≤Fᵢ T → Defined T
  ≤Fᵢ->defined def fs = conv->defined def (≤Fᵢ->↓ fs)

  spec-bounded-rec : ∀{R S} T → T ≤Fᵢ S → R ⊢ T → R ⊢ᵢ S
  spec-bounded-rec _ fs fc =
    let _ , reds , succ = con-sound (≤Fᵢ->↓ fs) (fc-sound fc) in
    maysucceed->⊢ᵢ reds succ

  spec-bounded : SpecAux ⊆ λ (R , S) → R ⊢ᵢ S
  spec-bounded (T , fs , fc) = spec-bounded-rec T (fcoind-to-ind fs) fc

  spec-cons : SpecAux ⊆ ISF[ FCompIS ] SpecAux
  spec-cons {(R , T)} (S , fs , fc) with fc .CoInd⟦_⟧.unfold
  spec-cons {(R , T)} (S , fs , fc) | client-end , ((_ , (win , def)) , _) , refl , _ =
    client-end , ((R , _) , (win , ≤Fᵢ->defined def (fcoind-to-ind fs))) , refl , λ ()
  spec-cons {(out r , _)} ((inp f) , fs , fc) | oi , (((.r , .f) , wit-r) , _) , refl , pr with fs .CoInd⟦_⟧.unfold
  ... | end-def , (((.(inp f) , _) , (inp e , _)) , _) , refl , _ = ⊥-elim (e _ (proj₂ (fc->defined (pr wit-r))))
  ... | ii , (((.f , g) , _) , _) , refl , pr' = oi , (_ , wit-r) , refl , λ wit → _ , pr' (_ , proj₂ (fc->defined (pr wit))) , pr wit
  spec-cons {(inp r , T)} (out f , fs , fc) | io , (((.r , .f) , wit-f) , _) , refl , pr with fs .CoInd⟦_⟧.unfold
  ... | end-def , (((.(out f) , _) , (out e , _)) , _) , refl , _ = ⊥-elim (e _ (proj₂ wit-f))
  ... | oo , (((.f , g) , (incl , wit-g)) , _) , refl , pr' = io , (_ , wit-g) , refl , λ wit → _ , pr' wit , pr (_ , incl (proj₂ wit))

  spec-aux-sound : SpecAux ⊆ λ (R , S) → R ⊢ S
  spec-aux-sound = bounded-coind[ FCompIS , FCompCOIS ] SpecAux spec-bounded spec-cons

  fs-sound : ∀{T S} → T ≤F S → FSSpec-⊢ (T , S)
  fs-sound {T} fs fc = spec-aux-sound (T , fs , fc)

  {- Soundness & Completeness of Sub wrt ≤Fc -}

  ≤Fc->sub : ∀{S T} → S ≤Fc T → ∀ {i} → Sub S T i
  ≤Fc->sub fs with fs .CoInd⟦_⟧.unfold
  ... | nil-any , _ , refl , _ = nil<:any
  ... | end-def , (_ , (end , def)) , refl , _ = end<:def end def
  ... | ii , ((f , g) , incl) , refl , pr = inp<:inp incl λ x → λ where .force → if-def x
    where
      if-def : (t : 𝕋) → ∀{i} → Sub (f t .force) (g t .force) i
      if-def t with t ∈? f
      ... | yes ok-t = ≤Fc->sub (pr (_ , ok-t))
      ... | no no-t = subst (λ x → Sub x (g t .force) _) (sym (not-def->nil no-t)) nil<:any
  ... | oo , (_ , (incl , wit)) , refl , pr = out<:out wit incl λ ok-x → λ where .force → ≤Fc->sub (pr (_ , ok-x))

  sub->≤Fc : ∀{S T} → (∀{i} → Sub S T i) → S ≤Fc T
  CoInd⟦_⟧.unfold (sub->≤Fc fs) with fs
  ... | nil<:any = nil-any , _ , refl , λ ()
  ... | end<:def end def = end-def , (_ , (end , def)) , refl , λ ()
  ... | inp<:inp incl pr = ii , (_ , incl) , refl , λ (p , _) → sub->≤Fc (pr p .force)
  ... | out<:out wit incl pr = oo , (_ , (incl , wit)) , refl , λ (_ , ok) → sub->≤Fc (pr ok .force)

  {- Auxiliary -}

  -- Only premise for rules using sample-cont in ⊢
  sample-cont-prem : ∀{f : Continuation}{t R} → R ⊢ f t .force
    → (pos : Σ[ p ∈ 𝕋 ] p ∈ dom (sample-cont t R nil)) → (sample-cont t R nil) (proj₁ pos) .force ⊢ f (proj₁ pos) .force
  sample-cont-prem {f} {t} pr (p , ok-p) with p ?= t
  ... | yes refl = pr
  sample-cont-prem {f} {t} pr (p , ()) | no ¬eq

  -- Premises using sample-cont-dual in ⊢
  sample-cont-prems : ∀{f : Continuation}{t} → t ∉ dom f
    → (pos : Σ[ p ∈ 𝕋 ] p ∈ dom f) → (sample-cont t nil win) (proj₁ pos) .force ⊢ f (proj₁ pos) .force
  sample-cont-prems {f} {t} no-t (p , ok-p) with p ?= t
  ... | yes refl = ⊥-elim (no-t ok-p)
  ... | no ¬eq = win⊢def ok-p

  -- Premises using sample-cont-dual in ⊢
  sample-cont-prems' : ∀{f : Continuation}{t R} → R ⊢ f t .force
    → (pos : Σ[ p ∈ 𝕋 ] p ∈ dom f) → (sample-cont t R win) (proj₁ pos) .force ⊢ f (proj₁ pos) .force
  sample-cont-prems' {f} {t} pr (p , ok-p) with p ?= t
  ... | yes refl = pr
  ... | no ¬eq = win⊢def ok-p

  spec-inp->incl : ∀{f g} → FSSpec-⊢ (inp f , inp g) → dom f ⊆ dom g
  spec-inp->incl {f} {g} fs {t} ok-t with fs (apply-fcoind oi ((sample-cont t win nil , f) , wit-cont out) (sample-cont-prem {f} {t} (win⊢def ok-t))) .CoInd⟦_⟧.unfold
  ... | client-end , ((_ , (out e , _)) , _) , refl , _ = ⊥-elim (e t (proj₂ (wit-cont out)))
  ... | oi , _ , refl , pr = proj₂ (fc->defined (pr (t , proj₂ (wit-cont out))))

  spec-out->incl : ∀{f g} → FSSpec-⊢ (out f , out g) → Witness f → dom g ⊆ dom f
  spec-out->incl {f} {g} fs wit {t} ok-t with t ∈? f
  ... | yes ok = ok
  ... | no no-t with (fs (apply-fcoind io ((sample-cont t nil win ,  f) , wit) (sample-cont-prems {f} {t} no-t))) .CoInd⟦_⟧.unfold
  ... | client-end , ((_ , (() , _)) , _) , refl , _
  ... | io , _ , refl , pr = ⊥-elim (cont-not-def (proj₁ (fc->defined (pr (t , ok-t)))))

  spec-out->wit : ∀{f g} → Witness f →  FSSpec-⊢ (out f , out g) → Witness g
  spec-out->wit {f} {g} wit-f fs with Empty? g
  ... | inj₂ wit = wit
  ... | inj₁ e with (fs (apply-fcoind io ((full-cont win , f) , wit-f) λ (_ , ok) → win⊢def ok)) .CoInd⟦_⟧.unfold
  ... | client-end , ((_ , (() , _)) , _) , refl , _
  ... | io , ((_ , wit-g) , _) , refl , _ = ⊥-elim (e _ (proj₂ wit-g))

  {- Boundedness & Consistency -}

  fsspec-cons : FSSpec-⊢ ⊆ ISF[ FSubIS ] FSSpec-⊢
  fsspec-cons {nil , T} fs = nil-any , _ , refl , λ ()
  fsspec-cons {inp f , nil} fs with (fs (apply-fcoind client-end ((win , _) , (Win-win , inp)) λ ())) .CoInd⟦_⟧.unfold
  ... | client-end , ((_ , (_ , ())) , _) , refl , _
  fsspec-cons {inp f , inp g} fs = ii , ((f , g) , spec-inp->incl fs) , refl ,
    λ (p , _) {R} fc-r-f →
      let wit = wit-cont (proj₁ (fc->defined fc-r-f)) in
      let fc-Or-Ig = fs (apply-fcoind oi ((sample-cont p R nil , f) , wit) (sample-cont-prem {f} {p} fc-r-f)) in
      let fc-r-g = ⊢-after-out {sample-cont p R nil} {g} {p} (proj₂ wit) fc-Or-Ig in
      subst (λ x → x ⊢ g p .force) (sym force-eq) fc-r-g
  fsspec-cons {inp f , out g} fs with Empty? f
  ... | inj₁ e = end-def , (_ , (inp e , out)) , refl , λ ()
  ... | inj₂ (t , ok-t) with (fs (apply-fcoind oi ((sample-cont t win nil , f) , wit-cont out) (sample-cont-prem {f} {t} (win⊢def ok-t)))) .CoInd⟦_⟧.unfold
  ... | client-end , ((_ , (out e , out)) , _) , refl , _ = ⊥-elim (e t (proj₂ (wit-cont out)))
  fsspec-cons {out f , nil} fs with (fs (apply-fcoind client-end ((win , _) , (Win-win , out)) λ ())) .CoInd⟦_⟧.unfold
  ... | client-end , ((_ , (_ , ())) , _) , refl , _
  fsspec-cons {out f , inp g} fs with Empty? f
  ... | inj₁ e = end-def , (_ , (out e , inp)) , refl , λ ()
  ... | inj₂ (t , ok-t) with (fs (apply-fcoind io ((full-cont win , f) , (t , ok-t)) λ (_ , ok-p) → win⊢def ok-p)) .CoInd⟦_⟧.unfold
  ... | client-end , ((_ , (() , inp)) , _) , refl , _
  fsspec-cons {out f , out g} fs with Empty? f
  ... | inj₁ e = end-def , (_ , (out e , out)) , refl , λ ()
  ... | inj₂ (t , ok-t) =
    let wit-g = spec-out->wit (t , ok-t) fs in
    let incl = spec-out->incl fs (t , ok-t) in
    oo , ((f , g) , (incl , wit-g)) , refl , λ (p , ok-p) {R} fc-r-f →
      let fc-Ir-Og = fs (apply-fcoind io ((sample-cont p R win , f) , (t , ok-t)) (sample-cont-prems' {f} {p} fc-r-f)) in
      let fc-r-g = ⊢-after-in {sample-cont p R win} {g} {p} ok-p fc-Ir-Og in
      subst (λ x → x ⊢ g p .force) (sym force-eq) fc-r-g

  fsspec->sub : ∀{S T} → FSSpec-⊢ (S , T) → S ≤Fc T
  fsspec->sub = coind[ FSubIS ] FSSpec-⊢ fsspec-cons

  postulate
    not-conv-div : ∀{T S} → ¬ T ↓ S → T ↑ S

  fs-convergence : ∀{T S} → FairSubtypingS T S → T ↓ S
  fs-convergence {T} {S} fs with Common.excluded-middle {T ↓ S}
  fs-convergence {T} {S} fs | yes p = p
  fs-convergence {T} {S} fs | no p =
    let div = not-conv-div p in
    let sub = ≤Fc->sub (fsspec->sub (spec-sound fs)) in
    let d-comp = discriminator-compliant sub div in
    let ¬d-comp = discriminator-not-compliant sub div in
    ⊥-elim (¬d-comp (fs d-comp))

  fsspec-bounded : ∀{S T} → FSSpec-⊢ (S , T) → S ≤Fᵢ T
  fsspec-bounded fs = apply-ind (inj₂ co-conv) (_ , (fs-convergence (spec-complete fs))) λ ()

  {- Completeness -}

  fs-complete : ∀{S T} → FSSpec-⊢ (S , T) → S ≤F T
  fs-complete = bounded-coind[ FSubIS , FSubCOIS ] FSSpec-⊢ fsspec-bounded fsspec-cons


open import Prelude hiding (subst)

module Implicits.Substitutions.MetaType where

open import Implicits.Syntax.Type
open import Implicits.Syntax.MetaType

open import Data.Fin.Substitution
open import Data.Star as Star hiding (map)
open import Data.Star.Properties
open import Data.Nat.Properties.Simple
open import Data.Vec hiding ([_])

module MetaTypeTypeSubst where

  MetaSub : (ℕ → ℕ → Set) → ℕ → ℕ → ℕ → Set
  MetaSub T m ν μ = Sub (T m) ν μ

  record MetaLift (T : ℕ → ℕ → Set) : Set where
    field
      simple : ∀ {m} → Simple (T m)
      lift : ∀ {m ν} → T m ν → MetaType m ν

  module MetaTypeApp {T} (l : MetaLift T) where
    open MetaLift l

    infixl 8 _/_

    mutual
      _s/_ : ∀ {m μ ν} → MetaSimpleType m ν → MetaSub T m ν μ → MetaType m μ
      tvar x s/ σ = lift (lookup x σ)
      mvar x s/ σ = simpl (mvar x)
      (a →' b) s/ σ = simpl ((a / σ) →' (b / σ))
      tc c s/ σ = simpl (tc c)

      _/_ : ∀ {m μ ν} → MetaType m ν → MetaSub T m ν μ → MetaType m μ
      simpl x / σ = (x s/ σ)
      (a ⇒ b) / σ = (a / σ) ⇒ (b / σ)
      (∀' a)   / σ = ∀' (a / σ ↑)
        where
          open Simple simple

    module _ {m : ℕ} where
      open Application (record { _/_ = _/_ {m = m} }) public using (_/✶_)
      open Simple (simple {m})

      →'-/✶-↑✶ : ∀ k {n n' a b} (ρs : Subs (T m) n n') →
              (simpl (a →' b)) /✶ ρs ↑✶ k ≡ simpl ((a /✶ ρs ↑✶ k) →' (b /✶ ρs ↑✶ k))
      →'-/✶-↑✶ k ε        = refl
      →'-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (→'-/✶-↑✶ k ρs) refl

      ⇒-/✶-↑✶ : ∀ k {n n' a b} (ρs : Subs (T m) n n') →
              (a ⇒ b) /✶ ρs ↑✶ k ≡ (a /✶ ρs ↑✶ k) ⇒ (b /✶ ρs ↑✶ k)
      ⇒-/✶-↑✶ k ε        = refl
      ⇒-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (⇒-/✶-↑✶ k ρs) refl

      tc-/✶-↑✶ : ∀ k {c n n'} (ρs : Subs (T m) n n') →
              (simpl (tc c)) /✶ ρs ↑✶ k ≡ simpl (tc c)
      tc-/✶-↑✶ k ε        = refl
      tc-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (tc-/✶-↑✶ k ρs) refl

      mvar-/✶-↑✶ : ∀ k {n n' c} (ρs : Subs (T m) n n') →
              (simpl (mvar c)) /✶ ρs ↑✶ k ≡ simpl (mvar c)
      mvar-/✶-↑✶ k ε        = refl
      mvar-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (mvar-/✶-↑✶ k ρs) refl

      ∀'-/✶-↑✶ : ∀ k {n n' a} (ρs : Subs (T m) n n') →
              (∀' a) /✶ ρs ↑✶ k ≡ ∀' (a /✶ ρs ↑✶ (suc k))
      ∀'-/✶-↑✶ k ε = refl
      ∀'-/✶-↑✶ k (x ◅ ρs) = cong₂ _/_ (∀'-/✶-↑✶ k ρs) refl

  Fin′ : ℕ → ℕ → Set
  Fin′ m ν = Fin ν

  module Lifted {m} {T} (lift : MetaLift T) where
    application : Application (MetaType m) (T m)
    application = record { _/_ = MetaTypeApp._/_ lift }

    open MetaLift lift public
    open Application application public
    open Simple (simple {m}) public

  varLift : MetaLift Fin′
  varLift = record {
      simple = record { var = Prelude.id ; weaken = suc }
      ; lift = (λ n → simpl (tvar n))
    }

  infixl 8 _/Var_

  _/Var_ : ∀ {m n k} → MetaType m n → Sub Fin n k → MetaType m k
  _/Var_ = MetaTypeApp._/_ varLift

  simple : ∀ {m} → Simple (MetaType m)
  simple = record { var = λ x → simpl (tvar x); weaken = λ x → x /Var VarSubst.wk }

  termLift : MetaLift MetaType
  termLift = record { simple = simple; lift = Prelude.id }

  private
    module ExpandSubst {n : ℕ} where
      app : Application (MetaType n) (MetaType n)
      app = record { _/_ = MetaTypeApp._/_ termLift }

      subst : Subst (MetaType n)
      subst = record
        { simple      = simple
        ; application = app
        }

      open Subst subst public

  open ExpandSubst public hiding (var; simple)

module MetaTypeMetaSubst where

  MetaSub : (ℕ → ℕ → Set) → ℕ → ℕ → ℕ → Set
  MetaSub T ν m m' = Sub (flip T ν) m m'

  record ExpandSimple (T : ℕ → ℕ → Set) : Set where
    field
      simple : ∀ {ν} → Simple (flip T ν)

    module _ {ν : ℕ} where
      open Simple (simple {ν}) public

  record ExpandApp (T : ℕ → ℕ → Set) : Set where
    field
      app : ∀ {ν} → Application (flip MetaType ν) (flip T ν)

    module _ {ν : ℕ} where
      open Application (app {ν}) public

  record MetaLift (T : ℕ → ℕ → Set) : Set where
    field
      exp-simple : ExpandSimple T
      lift : ∀ {m ν} → T m ν → MetaType m ν
      tpweaken : ∀ {m ν} → T m ν → T m (suc ν)

    open ExpandSimple exp-simple using (simple; _↑; weaken) renaming (var to evar)

    _↑tp : ∀ {m m' ν} → MetaSub T ν m m' → MetaSub T (suc ν) m m'
    _↑tp s = map tpweaken s

    field
      comm-weaken-tpweaken : ∀ {m ν} (a : T m ν) → weaken (tpweaken a) ≡ tpweaken (weaken a)
      tpweaken-var : ∀ {ν m} (n : Fin m) → (tpweaken {ν = ν} (evar n)) ≡ evar n

    _↑tp⋆_ : ∀ {m m' ν} → MetaSub T ν m m' → (k : ℕ) → MetaSub T (k + ν) m m'
    s ↑tp⋆ zero = s
    s ↑tp⋆ suc k = (s ↑tp⋆ k) ↑tp

  module MetaTypeApp {T} (l : MetaLift T) where
    open MetaLift l

    infixl 8 _/_

    mutual
      _s/_  : ∀ {m n ν} → MetaSimpleType m ν → MetaSub T ν m n → MetaType n ν
      tvar x s/ σ = simpl (tvar x)
      mvar x s/ σ = lift (lookup x σ)
      (a →' b) s/ σ = simpl ((a / σ) →' (b / σ))
      tc c s/ σ = simpl (tc c)

      _/_ : ∀ {m n ν} → MetaType m ν → MetaSub T ν m n → MetaType n ν
      simpl x / σ = (x s/ σ)
      (a ⇒ b) / σ = (a / σ) ⇒ (b / σ)
      (∀' a)   / σ = ∀' (a / σ ↑tp)

    open ExpandApp (record { app = record { _/_ = _/_ } }) hiding (_/_)
    open ExpandSimple exp-simple

  Fin′ : ℕ → ℕ → Set
  Fin′ m ν = Fin m

  module Lifted {T} (lift : MetaLift T) where
    open ExpandApp (record { app = record { _/_ = MetaTypeApp._/_ lift }}) public
    open MetaLift lift public
    open ExpandSimple exp-simple public

  module _ where
    private
      exp-simple : ExpandSimple Fin′
      exp-simple = record { simple = record { var = Prelude.id ; weaken = suc }}

    open ExpandSimple exp-simple

    varLift : MetaLift Fin′
    varLift = record {
        tpweaken = Prelude.id
        ; exp-simple = exp-simple
        ; lift = (λ n → simpl (mvar n))
        ; comm-weaken-tpweaken = λ s → refl
        ; tpweaken-var = λ n → refl }

  infixl 8 _/Var_

  _/Var_ : ∀ {m m' ν} → MetaType m ν → Sub Fin m m' → MetaType m' ν
  _/Var_ = MetaTypeApp._/_ varLift

  simple : ∀ {ν} → Simple (flip MetaType ν)
  simple = record { var = λ x → simpl (mvar x); weaken = λ x → x /Var VarSubst.wk }

  module _ where
    exp-simple : ExpandSimple MetaType
    exp-simple = record { simple = simple }

    open ExpandSimple exp-simple
    module MTTS = MetaTypeTypeSubst

    _↑⋆tp_ : ∀ {m m' ν} → MetaSub MetaType ν m m' → ∀ k → MetaSub MetaType (k + ν) m m'
    x ↑⋆tp zero = x
    x ↑⋆tp (suc k) = map MTTS.weaken (x ↑⋆tp k)

    _↑tp : ∀ {m m' ν} → MetaSub MetaType ν m m' → MetaSub MetaType (suc ν) m m'
    x ↑tp = x ↑⋆tp 1

    tp-weaken = MTTS.weaken

    comm-tp/var-/var : ∀ {ν ν' m m'} (a : MetaType m ν) {s : Sub Fin ν ν'} {s' : Sub Fin m m'} →
                       (a MTTS./Var s) /Var s' ≡ (a /Var s') MTTS./Var s
    comm-tp/var-/var (a ⇒ b) = cong₂ _⇒_ (comm-tp/var-/var a) (comm-tp/var-/var b)
    comm-tp/var-/var (∀' a) = cong ∀' (comm-tp/var-/var a)
    comm-tp/var-/var (simpl (tvar x)) = refl
    comm-tp/var-/var (simpl (mvar x)) = refl
    comm-tp/var-/var (simpl (a →' b)) = cong₂ (λ u v → simpl (u →' v)) (comm-tp/var-/var a)
                                          (comm-tp/var-/var b)
    comm-tp/var-/var (simpl (tc c)) = refl

    comm-weaken-tpweaken : ∀ {m ν} (a : MetaType m ν) → weaken (tp-weaken a) ≡ tp-weaken (weaken a)
    comm-weaken-tpweaken (a ⇒ b) = cong₂ _⇒_ (comm-weaken-tpweaken a) (comm-weaken-tpweaken b)
    comm-weaken-tpweaken (∀' a) = cong ∀' (comm-tp/var-/var a)
    comm-weaken-tpweaken (simpl (tvar x)) = refl
    comm-weaken-tpweaken (simpl (mvar x)) = refl
    comm-weaken-tpweaken (simpl (a →' b)) = cong₂ (λ u v → simpl (u →' v)) (comm-weaken-tpweaken a)
                                              (comm-weaken-tpweaken b)
    comm-weaken-tpweaken (simpl (tc c)) = refl

    open import Data.Vec.Properties

    termLift : MetaLift MetaType
    termLift = record {
        tpweaken = MetaTypeTypeSubst.weaken
        ; exp-simple = exp-simple
        ; lift = Prelude.id
        ; comm-weaken-tpweaken = comm-weaken-tpweaken
        ; tpweaken-var = λ n → refl}

  private
    module ExpandSubst {n : ℕ} where
      app : Application (flip MetaType n) (flip MetaType n)
      app = record { _/_ = MetaTypeApp._/_ termLift }

      subst : Subst (flip MetaType n)
      subst = record
        { simple      = simple
        ; application = app
        }

      open Subst subst public

  open ExpandSubst public hiding (var; simple)

  open-meta-k : ∀ {m ν} k → (a : MetaType m (k + suc ν)) → MetaType (suc m) (k + ν)
  open-meta-k {m} {ν} k a = (weaken a) MetaTypeTypeSubst./
      (MetaTypeTypeSubst.sub (simpl (mvar zero)) MetaTypeTypeSubst.↑⋆ k)

  open-meta : ∀ {m ν} → (a : MetaType m (suc ν)) → MetaType (suc m) ν
  open-meta a = open-meta-k zero a

  _◁m₁ : ∀ {ν m} (r : MetaType m ν) → ℕ
  _◁m₁ (a ⇒ b) = b ◁m₁
  _◁m₁ (∀' r) = 1 + r ◁m₁
  _◁m₁ (simpl x) = zero

  -- heads of metatypes
  _◁m : ∀ {ν m} (r : MetaType m ν) → (MetaType ((r ◁m₁) + m) ν)
  (a ⇒ b) ◁m = b ◁m
  ∀' r ◁m = open-meta (r ◁m)
  simpl x ◁m = simpl x

  smeta-weaken : ∀ {m ν} → MetaSimpleType m ν → MetaSimpleType (suc m) ν
  smeta-weaken (tc x) = tc x
  smeta-weaken (tvar n) = tvar n
  smeta-weaken (mvar m) = mvar (suc m)
  smeta-weaken (a →' b) = weaken a →' weaken b


{-# OPTIONS --prop --without-K --rewriting #-}

open import Calf.CostMonoid

module Calf.Types.Eq where

open import Calf.Prelude
open import Calf.Metalanguage
open import Calf.PhaseDistinction
open import Relation.Binary.PropositionalEquality

postulate
  eq : (A : tp pos) → val A → val A → tp pos
  eq/intro : ∀ {A v1 v2} → v1 ≡ v2 → val (eq A v1 v2)
  eq/ref : ∀ {A v1 v2} → cmp (F (eq A v1 v2)) → v1 ≡ v2

  eq/uni : ∀ {A v1 v2} → (p q : cmp (F (eq A v1 v2))) →
    (u : ext) → p ≡ q


open import Data.Product using ( proj₁ ; proj₂ )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Relation.Binary.PropositionalEquality using ( refl )
open import Web.Semantic.DL.ABox.Interp using ( ⌊_⌋ ; ind ; _*_ )
open import Web.Semantic.DL.ABox.Interp.Morphism using ( _,_ )
open import Web.Semantic.DL.ABox.Model using
  ( _⊨a_ ; on-bnode ; bnodes ; _,_ ; ⊨a-resp-≲ )
open import Web.Semantic.DL.Category.Composition using ( _∙_ )
open import Web.Semantic.DL.Category.Properties.Composition.Lemmas using
  ( compose-left ; compose-right ; compose-resp-⊨a )
open import Web.Semantic.DL.Category.Properties.Tensor.Lemmas using
  ( tensor-up ; tensor-down ; tensor-resp-⊨a )
open import Web.Semantic.DL.Category.Object using ( Object ; IN ; fin )
open import Web.Semantic.DL.Category.Morphism using
  ( _⇒_ ; BN ; impl ; _⊑_ ; _≣_ ; _,_ )
open import Web.Semantic.DL.Category.Tensor using ( _⊗_ ; _⟨⊗⟩_ )
open import Web.Semantic.DL.Category.Unit using ( I )
open import Web.Semantic.DL.Category.Wiring using
  ( wires-≈ ; wires-≈⁻¹ ; symm )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox )
open import Web.Semantic.DL.TBox.Interp using ( Δ ; _⊨_≈_ ; ≈-refl ; ≈-sym )
open import Web.Semantic.DL.TBox.Interp.Morphism using ( ≲-refl )
open import Web.Semantic.Util using
  ( _∘_ ; False ; ⊎-swap
  ; _⊕_⊕_ ; inode ; bnode ; enode ; left ; right ; up ; down )

module Web.Semantic.DL.Category.Properties.Tensor.SymmNatural
  {Σ : Signature} {S T : TBox Σ} where

symm-natural : ∀ {A₁ A₂ B₁ B₂ : Object S T} (F₁ : A₁ ⇒ B₁) (F₂ : A₂ ⇒ B₂) →
  ((F₁ ⟨⊗⟩ F₂) ∙ symm B₁ B₂ ≣ symm A₁ A₂ ∙ (F₂ ⟨⊗⟩ F₁))
symm-natural {A₁} {A₂} {B₁} {B₂} F₁ F₂ = (LHS⊑RHS , RHS⊑LHS) where

  LHS⊑RHS : (F₁ ⟨⊗⟩ F₂) ∙ symm B₁ B₂ ⊑ symm A₁ A₂ ∙ (F₂ ⟨⊗⟩ F₁)
  LHS⊑RHS J J⊨STA J⊨LHS = (f , J⊨RHS) where

    f : False ⊕ (IN A₂ ⊎ IN A₁) ⊕ (BN F₂ ⊎ BN F₁) → Δ ⌊ J ⌋
    f (inode ())
    f (bnode (inj₁ x)) = ind J (inode (inj₂ x))
    f (bnode (inj₂ x)) = ind J (inode (inj₁ x))
    f (enode (inj₁ v)) = ind J (bnode (inode (inj₂ v)))
    f (enode (inj₂ v)) = ind J (bnode (inode (inj₁ v)))

    lemma₀ : ∀ x →
      ⌊ J ⌋ ⊨ ind J (inode (⊎-swap x)) ≈ f (bnode x)
    lemma₀ (inj₁ x) = ≈-refl ⌊ J ⌋
    lemma₀ (inj₂ y) = ≈-refl ⌊ J ⌋

    lemma₁ : ∀ x →
      ⌊ J ⌋ ⊨ ind J (left (up x)) ≈ on-bnode f (ind J) (right (down x))
    lemma₁ (inode x) = ≈-refl ⌊ J ⌋
    lemma₁ (bnode v) = ≈-refl ⌊ J ⌋
    lemma₁ (enode y) = wires-≈ ⊎-swap (proj₂ (fin (B₂ ⊗ B₁)) (inj₂ y))
      (compose-right (F₁ ⟨⊗⟩ F₂) (symm B₁ B₂) J J⊨LHS)

    lemma₂ : ∀ x →
      ⌊ J ⌋ ⊨ ind J (left (down x)) ≈ on-bnode f (ind J) (right (up x))
    lemma₂ (inode x) = ≈-refl ⌊ J ⌋
    lemma₂ (bnode v) = ≈-refl ⌊ J ⌋
    lemma₂ (enode y) = wires-≈ ⊎-swap (proj₂ (fin (B₂ ⊗ B₁)) (inj₁ y))
      (compose-right (F₁ ⟨⊗⟩ F₂) (symm B₁ B₂) J J⊨LHS)

    J⊨RHS : bnodes J f ⊨a impl (symm A₁ A₂ ∙ (F₂ ⟨⊗⟩ F₁))
    J⊨RHS = compose-resp-⊨a (symm A₁ A₂) (F₂ ⟨⊗⟩ F₁) (bnodes J f)
      (wires-≈⁻¹ ⊎-swap lemma₀ (proj₁ (fin (A₂ ⊗ A₁))))
      (tensor-resp-⊨a F₂ F₁ (right * bnodes J f)
        (⊨a-resp-≲ (≲-refl ⌊ J ⌋ , lemma₂) (impl F₂)
          (tensor-down F₁ F₂ (left * J)
            (compose-left (F₁ ⟨⊗⟩ F₂) (symm B₁ B₂) J J⊨LHS)))
        (⊨a-resp-≲ (≲-refl ⌊ J ⌋ , lemma₁) (impl F₁)
          (tensor-up F₁ F₂ (left * J)
            (compose-left (F₁ ⟨⊗⟩ F₂) (symm B₁ B₂) J J⊨LHS))))

  RHS⊑LHS : symm A₁ A₂ ∙ (F₂ ⟨⊗⟩ F₁) ⊑ (F₁ ⟨⊗⟩ F₂) ∙ symm B₁ B₂
  RHS⊑LHS J J⊨STA J⊨RHS = (f , J⊨LHS) where

    f : ((BN F₁ ⊎ BN F₂) ⊕ (IN B₁ ⊎ IN B₂) ⊕ False) → Δ ⌊ J ⌋
    f (inode (inj₁ v)) = ind J (bnode (enode (inj₂ v)))
    f (inode (inj₂ v)) = ind J (bnode (enode (inj₁ v)))
    f (bnode (inj₁ y)) = ind J (enode (inj₂ y))
    f (bnode (inj₂ y)) = ind J (enode (inj₁ y))
    f (enode ())

    lemma₀ : ∀ x → ⌊ J ⌋ ⊨ f (bnode (⊎-swap x)) ≈ ind J (enode x)
    lemma₀ (inj₁ y) = ≈-refl ⌊ J ⌋
    lemma₀ (inj₂ y) = ≈-refl ⌊ J ⌋

    lemma₁ : ∀ x →
      ⌊ J ⌋ ⊨ ind J (right (down x)) ≈ on-bnode f (ind J) (left (up x))
    lemma₁ (inode x) = ≈-sym ⌊ J ⌋
      (wires-≈ ⊎-swap (proj₂ (fin (A₂ ⊗ A₁)) (inj₂ x))
        (compose-left (symm A₁ A₂) (F₂ ⟨⊗⟩ F₁) J J⊨RHS))
    lemma₁ (bnode v) = ≈-refl ⌊ J ⌋
    lemma₁ (enode y) = ≈-refl ⌊ J ⌋

    lemma₂ : ∀ x →
      ⌊ J ⌋ ⊨ ind J (right (up x)) ≈ on-bnode f (ind J) (left (down x))
    lemma₂ (inode x) = ≈-sym ⌊ J ⌋
      (wires-≈ ⊎-swap (proj₂ (fin (A₂ ⊗ A₁)) (inj₁ x))
        (compose-left (symm A₁ A₂) (F₂ ⟨⊗⟩ F₁) J J⊨RHS))
    lemma₂ (bnode v) = ≈-refl ⌊ J ⌋
    lemma₂ (enode y) = ≈-refl ⌊ J ⌋

    J⊨LHS : bnodes J f ⊨a impl ((F₁ ⟨⊗⟩ F₂) ∙ symm B₁ B₂)
    J⊨LHS = compose-resp-⊨a (F₁ ⟨⊗⟩ F₂) (symm B₁ B₂) (bnodes J f)
      (tensor-resp-⊨a F₁ F₂ (left * bnodes J f)
        (⊨a-resp-≲ (≲-refl ⌊ J ⌋ , lemma₁) (impl F₁)
          (tensor-down F₂ F₁ (right * J)
            (compose-right (symm A₁ A₂) (F₂ ⟨⊗⟩ F₁) J J⊨RHS)))
        (⊨a-resp-≲ (≲-refl ⌊ J ⌋ , lemma₂) (impl F₂)
          (tensor-up F₂ F₁ (right * J)
            (compose-right (symm A₁ A₂) (F₂ ⟨⊗⟩ F₁) J J⊨RHS))))
      (wires-≈⁻¹ ⊎-swap lemma₀ (proj₁ (fin (B₂ ⊗ B₁))))


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

open import Agda.Primitive renaming (Set to _X_X_)

test : _X_X₁_
test = _X_X_


-- Andreas, 2019-08-17, issue #1346

open import Issue1346

-- Repeating the definitions of Issue1346.agda

private
  test₁ : List⁺ Bool
  test₁ = true ∷ false ∷ []  -- mixing _∷_ of _×_ and List

  test₂ : ∀{A : Set} → A → List A × List⁺ A × List⁺ A
  test₂ a = [] , a ∷ [] , a ∷ a ∷ []  -- mixing _,_ and _∷_ of _×_


-- {-# OPTIONS -v tc.conv.level:60 #-}
-- {-# OPTIONS -v tc.conv:30 #-}

{- Agda development version: Wed Oct 30 16:30:06 GMT 2013

   The last line of code triggers the following error,
   but replacing '_' with 'a' typechecks just fine.

   Bug.agda:32,8-11
   tt != a of type ⊤
   when checking that the expression s _ has type P tt → P a

   Changing 'Set (q a)' to 'Set' in line 26 suppresses the error.
-}

-- Andreas, 2013-10-31  Fixed by retrying sort comparison after
-- successful type comparison (which might have solve the missing level metas).

module Issue930 where

open import Common.Level

data ⊤ : Set where
  tt : ⊤

postulate
  q : ⊤ → Level
  P : (a : ⊤) → Set (q a)
  s : (a : ⊤) → P tt → P a
  a : ⊤
  g : (P tt → P a) → ⊤

v : ⊤
v = g (s _)

{-
coerce term      v  = s ?1
       from type t1 = P tt → P ?1
       to type   t2 = P tt → P a
equalSort
  Set (q tt ⊔ q ?1) == Set (q a ⊔ q tt)
compareAtom q tt == q a : Level
compareTerm tt == a : ⊤
sort comparison failed  -- THIS ERROR IS CAUGHT, BUT RETHROWN AT THE END
compareTerm P tt → P ?1 =< P tt → P a : Set (q tt ⊔ q ?1)
compare function types
  t1 = P tt → P ?1
  t2 = P tt → P a
equalSort
  Set (q ?1) == Set (q a)
compareTerm ?1 == a : ⊤
attempting shortcut ?1 := a
solving _13 := a

-}


open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst)
open import Data.Sum

import SingleSorted.AlgebraicTheory as SS

module SingleSorted.Combinators where

module Sum {𝓈} (Σ₁ Σ₂ : SS.Signature) (T₁ : SS.Theory 𝓈 Σ₁) (T₂ : SS.Theory 𝓈 Σ₂) where

  -- disjoint sum of signatures
  S : SS.Signature
  S = record { oper = SS.Signature.oper Σ₁  ⊎  SS.Signature.oper Σ₂
             ; oper-arity = [ SS.Signature.oper-arity Σ₁ , SS.Signature.oper-arity Σ₂ ]
             }

  inj-term-l : ∀ {Γ : SS.Context} →  SS.Signature.Term Σ₁ Γ → SS.Signature.Term S Γ
  inj-term-l {Γ} (SS.Signature.tm-var x) = SS.Signature.tm-var x
  inj-term-l {Γ} (SS.Signature.tm-oper f ts) = SS.Signature.tm-oper (inj₁ f) λ{ i → inj-term-l (ts i)}

  inj-term-r : ∀ {Γ : SS.Context} →  SS.Signature.Term Σ₂ Γ → SS.Signature.Term S Γ
  inj-term-r {Γ} (SS.Signature.tm-var x) = SS.Signature.tm-var x
  inj-term-r {Γ} (SS.Signature.tm-oper f ts) = SS.Signature.tm-oper (inj₂ f) λ{ i → inj-term-r (ts i)}

  coerce₁ : SS.Signature.Equation Σ₁ → SS.Signature.Equation S
  coerce₁ eq = record { eq-ctx = SS.Signature.Equation.eq-ctx eq
                      ; eq-lhs = inj-term-l (SS.Signature.Equation.eq-lhs eq)
                      ; eq-rhs = inj-term-l (SS.Signature.Equation.eq-rhs eq)
                      }

  coerce₂ : SS.Signature.Equation Σ₂ → SS.Signature.Equation S
  coerce₂ eq = record { eq-ctx = SS.Signature.Equation.eq-ctx eq
                      ; eq-lhs = inj-term-r (SS.Signature.Equation.eq-lhs eq)
                      ; eq-rhs = inj-term-r (SS.Signature.Equation.eq-rhs eq)
                      }

  -- define a theory with the set of axioms a union of the axioms of both theories
  T : SS.Theory 𝓈 S
  T = record { ax = SS.Theory.ax T₁ ⊎ SS.Theory.ax T₂
             ; ax-eq = [ (λ a → coerce₁ (SS.Theory.ax-eq T₁ a)) , (λ a → coerce₂ (SS.Theory.ax-eq T₂ a)) ]
             }


{-# OPTIONS --copatterns #-}

open import Common.Prelude
open import Common.Product

postulate
  A : Set
  B : A → Set
  f : ∀ a → B a

bla : ∃ B
{-# NON_TERMINATING #-}
proj₁ bla = proj₁ bla
proj₂ bla = f (proj₁ bla)

T : Bool → Set
T true  = Bool
T false = Bool

test : (∀ b → T b) → ∃ T
{-# NON_TERMINATING #-}
proj₁ (test f) = proj₁ (test f)
proj₂ (test f) = f (proj₁ (test f))


----------------------------------------------------------------------
-- Functional small-step semantics
----------------------------------------------------------------------

module SystemF.Reduction where

open import Codata.Musical.Notation
open import Category.Monad
open import Category.Monad.Partiality.All
open import Data.Maybe as Maybe using (Maybe; just; nothing; map)
open import Data.Maybe.Relation.Unary.All as MaybeAll using (nothing; just)
open import Data.Maybe.Relation.Unary.Any as MaybeAny using (just)
open import Data.Nat using (ℕ; _+_)
open import Data.Unit using (tt)
open import Data.Vec using ([])
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)
open import Relation.Nullary

open import PartialityAndFailure as PF
open PF.Equality hiding (fail)
open PF.Equivalence
private
  open module M {f} = RawMonad (PF.monad {f}) using (_>>=_; return)

open import SystemF.Type
open import SystemF.Term
open import SystemF.WtTerm
open import SystemF.Eval hiding (type-soundness)

open TypeSubst       using () renaming (_[/_]  to _[/tp_])
open TermTypeSubst   using () renaming (_[/_]  to _[/tmTp_])
open TermTermSubst   using () renaming (_[/_]  to _[/tmTm_])
open WtTermTypeSubst using () renaming (_[/_]′ to _[/⊢tmTp_])
open WtTermTermSubst using () renaming (_[/_]  to _[/⊢tmTm_])

----------------------------------------------------------------------
-- Functional call-by-value small-step semantics in the partiality
-- monad

-- The functional presentation of the small-step semantics below is
-- heavily inspired by Danielsson's ICFP'12 paper "Operational
-- Semantics Using the Partiality Monad".  Whereas the paper
-- illustrates the technique to give a functional abstract machine
-- semantics (i.e. the semantics of a "VM"), we skip the compilation
-- step and directly reduce terms, which results in a (functional)
-- structural operational semantics (SOS).  We adopt many of the
-- conventions used in the accompanying code, which can be found at
--
--   http://www.cse.chalmers.se/~nad/publications/danielsson-semantics-partiality-monad.tgz
--
-- As pointed out in Danielsson's paper, the functional presentation
-- of the semantics feels rather natural in that it follows the form
-- of an interpreter, and it has the added advantage of proving that
-- the semantics are deterministic and computable "for free".
--
-- For more information about Danielson's paper see
--
--   http://www.cse.chalmers.se/~nad/publications/danielsson-semantics-partiality-monad.html

----------------------------------------------------------------------
-- Small-step call-by-value reduction

-- Results of reduction steps
data Result (m n : ℕ) : Set where
  continue : (t : Term m n) → Result m n  -- further reducible term
  done     : (v : Val m n)  → Result m n  -- irreducible value

-- Take a single reduction step (if possible).
step : ∀ {m n} → Term m n → Maybe (Result m n)
step (var x)                 = nothing
step (Λ t)                   = just (done (Λ t))
step (λ' a t)                = just (done (λ' a t))
step (μ a t)                 = just (continue (t [/tmTm μ a t ]))
step (t [ a ])               with step t
... | just (continue t′)     = just (continue (t′ [ a ]))
... | just (done (Λ t′))     = just (continue (t′ [/tmTp a ]))
... | just (done _)          = nothing
... | nothing                = nothing
step {m} {n} (s · t)         with step s
... | just (continue s′)     = just (continue (s′ · t))
... | just (done v)          = nested v
  where -- Call-by-value: only reduce (s · t) if s is a value.
    nested : Val m n → Maybe (Result m n)
    nested v with step t
    nested v         | (just (continue t′)) = just (continue (⌜ v ⌝ · t′))
    nested (λ' _ s′) | (just (done v)) = just (continue (s′ [/tmTm ⌜ v ⌝ ]))
    nested _         | (just (done _)) = nothing
    nested _         | nothing         = nothing
... | nothing                = nothing
step (fold a t)              with step t
... | just (continue t′)     = just (continue (fold a t′))
... | just (done v)          = just (done (fold a v))
... | nothing                = nothing
step (unfold a t)            with step t
... | just (continue t′)     = just (continue (unfold a t′))
... | just (done (fold _ v)) = just (done v)
... | just (done _)          = nothing
... | nothing                = nothing

----------------------------------------------------------------------
-- Type soundness

infix 4 _⊢res_∈_ _⊢res?_∈_

-- Well-typedness lifted to results of reduction steps.
data _⊢res_∈_ {m n} (Γ : Ctx m n) : Result m n → Type n → Set where
  ⊢continue : ∀ {t a} → Γ ⊢    t ∈ a → Γ ⊢res continue t ∈ a
  ⊢done     : ∀ {v a} → Γ ⊢val v ∈ a → Γ ⊢res done v     ∈ a

-- Well-typedness lifted to possibly undefined reduction steps.
_⊢res?_∈_ : ∀ {m n} → Ctx m n → Maybe (Result m n) → Type n → Set
Γ ⊢res? r? ∈ a = MaybeAll.All (λ r → Γ ⊢res r ∈ a) r?

-- Preservation of well-typedness: a well-typed term reduces in one
-- step to a result of the same type or fails to reduce.
⊢step : ∀ {m n} {Γ : Ctx m n} {t a} → Γ ⊢ t ∈ a → Γ ⊢res? step t ∈ a
⊢step (var x)   = nothing
⊢step (Λ ⊢t)    = just (⊢done (Λ ⊢t))
⊢step (λ' a ⊢t) = just (⊢done (λ' a ⊢t))
⊢step (μ a ⊢t)  = just (⊢continue (⊢t [/⊢tmTm μ a ⊢t ]))
⊢step {t = t [ a ]} (⊢t [ .a ]) with step t | ⊢step ⊢t
... | just ._ | just (⊢continue ⊢t′) = just (⊢continue (⊢t′ [ a ]))
... | just ._ | just (⊢done (Λ ⊢t′)) = just (⊢continue (⊢t′ [/⊢tmTp a ]))
... | nothing | nothing              = nothing
⊢step {m} {n} {Γ} {s · t} {b} (⊢s · ⊢t) with step s | ⊢step ⊢s
... | just ._ | just (⊢continue ⊢s′) = just (⊢continue (⊢s′ · ⊢t))
... | just (done (λ' a s′)) | just (⊢done (λ' .a ⊢s′)) = nested
  where
    nested : Γ ⊢res? step ((λ' a s′) · t) ∈ b
    nested with step t | ⊢step ⊢t
    ... | just ._ | just (⊢continue ⊢t′) = just (⊢continue ((λ' a ⊢s′) · ⊢t′))
    ... | just ._ | just (⊢done v) = just (⊢continue (⊢s′ [/⊢tmTm ⊢⌜ v ⌝ ]))
    ... | nothing | nothing        = nothing
... | nothing | nothing = nothing
⊢step {t = fold a t} (fold .a ⊢t) with step t | ⊢step ⊢t
... | just ._ | just (⊢continue ⊢t′) = just (⊢continue (fold a ⊢t′))
... | just ._ | just (⊢done ⊢v)      = just (⊢done (fold a ⊢v))
... | nothing | nothing              = nothing
⊢step {t = unfold a t} (unfold .a ⊢t) with step t | ⊢step ⊢t
... | just ._ | just (⊢continue ⊢t′)      = just (⊢continue (unfold a ⊢t′))
... | just ._ | just (⊢done (fold .a ⊢v)) = just (⊢done ⊢v)
... | nothing | nothing                   = nothing

-- Progress: reduction of well-typed closed terms does not fail.
progress : ∀ {t} {a : Type 0} → [] ⊢ t ∈ a → Maybe.Is-just (step t)
progress (var ())
progress (Λ t) = just tt
progress (λ' a t) = just tt
progress (μ a t) = just tt
progress {t [ a ]} (⊢t [ .a ]) with step t | ⊢step ⊢t | progress ⊢t
... | just ._ | just (⊢continue _) | just tt = just tt
... | just ._ | just (⊢done (Λ _)) | just tt = just tt
progress {s · t} (⊢s · ⊢t) with step s | ⊢step ⊢s | progress ⊢s
... | just ._               | just (⊢continue _)     | just tt = just tt
... | just (done (λ' a s′)) | just (⊢done (λ' .a _)) | just tt = nested
  where
    nested : Maybe.Is-just (step ((λ' a s′) · t))
    nested with step t | ⊢step ⊢t | progress ⊢t
    ... | just ._ | just (⊢continue _) | just tt = just tt
    ... | just ._ | just (⊢done _)     | just tt = just tt
progress {fold a t} (fold .a ⊢t) with step t | ⊢step ⊢t | progress ⊢t
... | just ._ | just (⊢continue _) | just tt = just tt
... | just ._ | just (⊢done _)     | just tt = just tt
progress {unfold a t} (unfold .a ⊢t) with step t | ⊢step ⊢t | progress ⊢t
... | just ._ | just (⊢continue _)       | just tt = just tt
... | just ._ | just (⊢done (fold .a _)) | just tt = just tt

infix 7 _↓ ⊢_↓

-- Evaluation of untyped (open) terms in the partiality monad via
-- repeated reduction.
_↓ : ∀ {m n} → Term m n → Comp m n
t ↓ with step t
... | just (continue t′) = later (♯ (t′ ↓))
... | just (done v)      = return v
... | nothing            = fail

-- Evaluation of closed terms preserves well-typedness.
⊢_↓ : ∀ {t a} → [] ⊢ t ∈ a → [] ⊢comp t ↓ ∈ a
⊢_↓ {t} ⊢t with step t | ⊢step ⊢t | progress ⊢t
... | just (continue t′) | just (⊢continue ⊢t′) | just tt = later (♯ ⊢ ⊢t′ ↓)
... | just (done v)      | just (⊢done ⊢v)      | just tt = now (just ⊢v)
... | nothing            | _                    | ()

-- Type soundness: evaluation of well-typed terms does not fail.
type-soundness : ∀ {t a} → [] ⊢ t ∈ a → ¬ t ↓ ≈ fail
type-soundness ⊢t = does-not-fail ⊢ ⊢t ↓

----------------------------------------------------------------------
-- Strong bisimilarity of big-step and small-step semantics

open PF.AlternativeEquality
  renaming (return to returnP; fail to failP; _>>=_ to _>>=P_)

-- Lemma: values don't reduce.
step-val : ∀ {m n} (v : Val m n) → step ⌜ v ⌝ ≡ just (done v)
step-val (Λ a)      = P.refl
step-val (λ' a t)   = P.refl
step-val (fold a v) with step ⌜ v ⌝ | step-val v
... | just (continue t) | ()
... | just (done w) | w≡v = P.cong (map (lower a)) w≡v
  where lower : ∀ {m n} → Type (1 + n) → Result m n → Result m n
        lower a (done v)     = done (fold a v)
        lower a (continue t) = continue t
... | nothing | ()

-- Lemma: _↓ "preserves" values.
↓-val : ∀ {m n} (v : Val m n) → ⌜ v ⌝ ↓ ≡ return v
↓-val v with step ⌜ v ⌝ | step-val v
↓-val v | just (continue t) | ()
↓-val v | just (done w) | w≡v = P.cong toComp w≡v
  where toComp : ∀ {m n} → Maybe (Result m n) → Comp m n
        toComp (just (continue t′)) = later (♯ (t′ ↓))
        toComp (just (done v))      = return v
        toComp nothing              = fail
↓-val v | nothing | ()

mutual
  infix 7 _[_]⇓≅↓′ _·⇓≅↓′_

  -- A helper lemma relating reduction and evaluation of type
  -- application.
  _[_]⇓≅↓′ : ∀ {m n} (t : Term m n) (a : Type n) →
             (t ↓) [ a ]⇓ ≅P (t [ a ]) ↓
  t [ a ]⇓≅↓′ with step t
  ... | just (continue t′)     = later (♯ (t′ [ a ]⇓≅↓′))
  ... | just (done (Λ t′))     = later (♯ ⇓≅↓′ (t′ [/tmTp a ]) )
  ... | just (done (λ' _ _))   = failP
  ... | just (done (fold _ _)) = failP
  ... | nothing                = failP

  -- A helper lemma relating reduction and evaluation of term
  -- application.
  _·⇓≅↓′_ : ∀ {m n} (s : Term m n) (t : Term m n) →
            (s ↓) ·⇓ (t ↓) ≅P (s · t) ↓
  s ·⇓≅↓′ t with step s
  s ·⇓≅↓′ t | just (continue s′)     = later (♯ (s′ ·⇓≅↓′ t))
  s ·⇓≅↓′ t | just (done v)          with step t
  s ·⇓≅↓′ t | just (done v)          | just (continue t′) = later (♯ subst v)
    where
      subst : ∀ v → (return v) ·⇓ (t′ ↓) ≅P (⌜ v ⌝ · t′) ↓
      subst v with ⌜ v ⌝ ↓ | ↓-val v | ⌜ v ⌝ ·⇓≅↓′ t′
      subst v | now (just .v) | P.refl | v≅t′ = v≅t′
      subst _ | now nothing   | ()     | _
      subst _ | later x₁      | ()     | _
  s ·⇓≅↓′ t | just (done (Λ s′))     | just (done w) = failP
  s ·⇓≅↓′ t | just (done (λ' a s′))  | just (done w) =
    later (♯ ⇓≅↓′ (s′ [/tmTm ⌜ w ⌝ ]))
  s ·⇓≅↓′ t | just (done (fold x v)) | just (done w) = failP
  s ·⇓≅↓′ t | just (done v)          | nothing       = failP
  s ·⇓≅↓′ t | nothing                                = failP

  -- A helper lemma relating reduction and evaluation of recursive
  -- type folding.
  fold⇓≅↓′ : ∀ {m n} (a : Type (1 + n)) (t : Term m n) →
             fold⇓ a (t ↓) ≅P (fold a t) ↓
  fold⇓≅↓′ a t with step t
  ... | just (continue t′) = later (♯ fold⇓≅↓′ a t′)
  ... | just (done v)      = returnP P.refl
  ... | nothing            = failP

  -- A helper lemma relating reduction and evaluation of recursive
  -- type unfolding.
  unfold⇓≅↓′ : ∀ {m n} (a : Type (1 + n)) (t : Term m n) →
               unfold⇓ a (t ↓) ≅P (unfold a t) ↓
  unfold⇓≅↓′ a t with step t
  ... | just (continue t′) = later (♯ unfold⇓≅↓′ a t′)
  ... | just (done (Λ _))      = failP
  ... | just (done (λ' _ _))   = failP
  ... | just (done (fold _ v)) = returnP P.refl
  ... | nothing                = failP

  -- Big-step evaluation and small-step reduction are strongly bisimliar.
  ⇓≅↓′ : ∀ {m n} (t : Term m n) → t ⇓ ≅P t ↓
  ⇓≅↓′ (var x)        = failP
  ⇓≅↓′ (Λ t)          = returnP P.refl
  ⇓≅↓′ (λ' a t)       = returnP P.refl
  ⇓≅↓′ (μ a t)        = later (♯ ⇓≅↓′ (t [/tmTm μ a t ]))
  ⇓≅↓′ (t [ a ])      =
    (t [ a ]) ⇓       ≅⟨ complete ([]-comp t a) ⟩
    (t ⇓) [ a ]⇓      ≅⟨ (⇓≅↓′ t) >>=P (λ v → (_ ∎)) ⟩
    (t ↓) [ a ]⇓      ≅⟨ t [ a ]⇓≅↓′ ⟩
    (t [ a ]) ↓       ∎
  ⇓≅↓′ (s · t)        =
    (s · t) ⇓         ≅⟨ complete (·-comp s t) ⟩
    (s ⇓) ·⇓ (t ⇓)    ≅⟨ (⇓≅↓′ s >>=P λ v → ⇓≅↓′ t >>=P λ w → (_ ∎)) ⟩
    (s ↓) ·⇓ (t ↓)    ≅⟨ s ·⇓≅↓′ t ⟩
    (s · t) ↓         ∎
  ⇓≅↓′ (fold a t)     =
    (fold a t) ⇓      ≅⟨ complete (fold-comp a t) ⟩
    fold⇓ a (t ⇓)     ≅⟨ (⇓≅↓′ t) >>=P (λ v → (_ ∎)) ⟩
    fold⇓ a (t ↓)     ≅⟨ fold⇓≅↓′ a t ⟩
    (fold a t) ↓      ∎
  ⇓≅↓′ (unfold a t)   =
    (unfold a t) ⇓    ≅⟨ complete (unfold-comp a t) ⟩
    unfold⇓ a (t ⇓)   ≅⟨ (⇓≅↓′ t) >>=P (λ v → (_ ∎)) ⟩
    unfold⇓ a (t ↓)   ≅⟨ unfold⇓≅↓′ a t ⟩
    (unfold a t) ↓    ∎

-- Big-step evaluation and small-step reduction are strongly bisimliar.
⇓≅↓ : ∀ {m n} (t : Term m n) → t ⇓ ≅ t ↓
⇓≅↓ t = sound (⇓≅↓′ t)


open import Relation.Binary using (IsDecEquivalence)
open import Agda.Builtin.Equality

module UnifyWith (FunctionName : Set) ⦃ isDecEquivalenceA : IsDecEquivalence (_≡_ {A = FunctionName}) ⦄ where

open import UnifyTermF FunctionName
open import UnifyMguF FunctionName
open import UnifyMguCorrectF FunctionName

open import Data.Fin using (Fin; suc; zero)
open import Data.Nat hiding (_≤_)
open import Relation.Binary.PropositionalEquality renaming ([_] to [[_]])
open import Function using (_∘_; id; case_of_; _$_; flip)
open import Relation.Nullary
open import Data.Product renaming (map to _***_)
open import Data.Empty
open import Data.Maybe
open import Category.Functor
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})
open import Data.Sum
open import Data.Maybe using (maybe; maybe′; nothing; just; monad; Maybe)
open import Data.List renaming (_++_ to _++L_)
open ≡-Reasoning
open import Data.Vec using (Vec; []; _∷_) renaming (_++_ to _++V_; map to mapV)

open import Data.Unit

-- moved to UnifyMguCorrectF


-- Andreas, 2016-01-21, issue 1791
-- With-clause stripping for copatterns with "polymorphic" field.

-- {-# OPTIONS -v tc.with.strip:60 #-}

postulate anything : ∀{A : Set} → A

record Wrap (A : Set) : Set where
  field unwrap : A

record Pointed (M : Set → Set) : Set₁ where
  field point : ∀{A} → M A  -- field type starts with hidden quantifier!

test : Pointed Wrap
Wrap.unwrap (Pointed.point test) with Set₂
... | _ = anything

-- should succeed