------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties related to list membership
------------------------------------------------------------------------

-- List membership is defined in Data.List.Any. This module does not
-- treat the general variant of list membership, parametrised on a
-- setoid, only the variant where the equality is fixed to be
-- propositional equality.

module Data.List.Any.Membership where

open import Algebra
open import Category.Monad
open import Data.Bool
open import Data.Empty
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence using (module Equivalence)
import Function.Injection as Inj
open import Function.Inverse as Inv using (_↔_; module Inverse)
import Function.Related as Related
open import Function.Related.TypeIsomorphisms
open import Data.List as List
open import Data.List.Any as Any using (Any; here; there)
open import Data.List.Any.Properties
open import Data.Nat as Nat
import Data.Nat.Properties as NatProp
open import Data.Product as Prod
open import Data.Sum as Sum
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; _≗_)
import Relation.Binary.Properties.DecTotalOrder as DTOProperties
import Relation.Binary.Sigma.Pointwise as Σ
open import Relation.Unary using (_⟨×⟩_)
open import Relation.Nullary
open import Relation.Nullary.Negation

open Any.Membership-≡
private
  module ×⊎ {k ℓ} = CommutativeSemiring (×⊎-CommutativeSemiring k ℓ)
  open module ListMonad {ℓ} = RawMonad (List.monad {ℓ = ℓ})

------------------------------------------------------------------------
-- Properties relating _∈_ to various list functions

-- Isomorphisms.

map-∈↔ : ∀ {a b} {A : Set a} {B : Set b} {f : A → B} {y xs} →
         (∃ λ x → x ∈ xs × y ≡ f x) ↔ y ∈ List.map f xs
map-∈↔ {a} {b} {f = f} {y} {xs} =
  (∃ λ x → x ∈ xs × y ≡ f x)  ↔⟨ Any↔ {a = a} {p = b} ⟩
  Any (λ x → y ≡ f x) xs      ↔⟨ map↔ {a = a} {b = b} {p = b} ⟩
  y ∈ List.map f xs           ∎
  where open Related.EquationalReasoning

concat-∈↔ : ∀ {a} {A : Set a} {x : A} {xss} →
            (∃ λ xs → x ∈ xs × xs ∈ xss) ↔ x ∈ concat xss
concat-∈↔ {a} {x = x} {xss} =
  (∃ λ xs → x ∈ xs × xs ∈ xss)  ↔⟨ Σ.cong {a₁ = a} {b₁ = a} {b₂ = a} Inv.id $ ×⊎.*-comm _ _ ⟩
  (∃ λ xs → xs ∈ xss × x ∈ xs)  ↔⟨ Any↔ {a = a} {p = a} ⟩
  Any (Any (_≡_ x)) xss         ↔⟨ concat↔ {a = a} {p = a} ⟩
  x ∈ concat xss                ∎
  where open Related.EquationalReasoning

>>=-∈↔ : ∀ {ℓ} {A B : Set ℓ} {xs} {f : A → List B} {y} →
         (∃ λ x → x ∈ xs × y ∈ f x) ↔ y ∈ (xs >>= f)
>>=-∈↔ {ℓ} {xs = xs} {f} {y} =
  (∃ λ x → x ∈ xs × y ∈ f x)  ↔⟨ Any↔ {a = ℓ} {p = ℓ} ⟩
  Any (Any (_≡_ y) ∘ f) xs    ↔⟨ >>=↔ {ℓ = ℓ} {p = ℓ} ⟩
  y ∈ (xs >>= f)              ∎
  where open Related.EquationalReasoning

⊛-∈↔ : ∀ {ℓ} {A B : Set ℓ} (fs : List (A → B)) {xs y} →
       (∃₂ λ f x → f ∈ fs × x ∈ xs × y ≡ f x) ↔ y ∈ fs ⊛ xs
⊛-∈↔ {ℓ} fs {xs} {y} =
  (∃₂ λ f x → f ∈ fs × x ∈ xs × y ≡ f x)       ↔⟨ Σ.cong {a₁ = ℓ} {b₁ = ℓ} {b₂ = ℓ} Inv.id (∃∃↔∃∃ {a = ℓ} {b = ℓ} {p = ℓ} _) ⟩
  (∃ λ f → f ∈ fs × ∃ λ x → x ∈ xs × y ≡ f x)  ↔⟨ Σ.cong {a₁ = ℓ} {b₁ = ℓ} {b₂ = ℓ}
                                                         Inv.id ((_ ∎) ⟨ ×⊎.*-cong {ℓ = ℓ} ⟩ Any↔ {a = ℓ} {p = ℓ}) ⟩
  (∃ λ f → f ∈ fs × Any (_≡_ y ∘ f) xs)        ↔⟨ Any↔ {a = ℓ} {p = ℓ} ⟩
  Any (λ f → Any (_≡_ y ∘ f) xs) fs            ↔⟨ ⊛↔ ⟩
  y ∈ fs ⊛ xs                                  ∎
  where open Related.EquationalReasoning

⊗-∈↔ : ∀ {A B : Set} {xs ys} {x : A} {y : B} →
       (x ∈ xs × y ∈ ys) ↔ (x , y) ∈ (xs ⊗ ys)
⊗-∈↔ {A} {B} {xs} {ys} {x} {y} =
  (x ∈ xs × y ∈ ys)                ↔⟨ ⊗↔′ ⟩
  Any (_≡_ x ⟨×⟩ _≡_ y) (xs ⊗ ys)  ↔⟨ Any-cong helper (_ ∎) ⟩
  (x , y) ∈ (xs ⊗ ys)              ∎
  where
  open Related.EquationalReasoning

  helper : (p : A × B) → (x ≡ proj₁ p × y ≡ proj₂ p) ↔ (x , y) ≡ p
  helper (x′ , y′) = record
    { to         = P.→-to-⟶ (uncurry $ P.cong₂ _,_)
    ; from       = P.→-to-⟶ < P.cong proj₁ , P.cong proj₂ >
    ; inverse-of = record
      { left-inverse-of  = λ _ → P.cong₂ _,_ (P.proof-irrelevance _ _)
                                             (P.proof-irrelevance _ _)
      ; right-inverse-of = λ _ → P.proof-irrelevance _ _
      }
    }

-- Other properties.

filter-∈ : ∀ {a} {A : Set a} (p : A → Bool) (xs : List A) {x} →
           x ∈ xs → p x ≡ true → x ∈ filter p xs
filter-∈ p []       ()          _
filter-∈ p (x ∷ xs) (here refl) px≡true rewrite px≡true = here refl
filter-∈ p (y ∷ xs) (there pxs) px≡true with p y
... | true  = there (filter-∈ p xs pxs px≡true)
... | false =        filter-∈ p xs pxs px≡true

------------------------------------------------------------------------
-- Properties relating _∈_ to various list functions

-- Various functions are monotone.

mono : ∀ {a p} {A : Set a} {P : A → Set p} {xs ys} →
       xs ⊆ ys → Any P xs → Any P ys
mono xs⊆ys =
  _⟨$⟩_ (Inverse.to Any↔) ∘′
  Prod.map id (Prod.map xs⊆ys id) ∘
  _⟨$⟩_ (Inverse.from Any↔)

map-mono : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) {xs ys} →
           xs ⊆ ys → List.map f xs ⊆ List.map f ys
map-mono f xs⊆ys =
  _⟨$⟩_ (Inverse.to map-∈↔) ∘
  Prod.map id (Prod.map xs⊆ys id) ∘
  _⟨$⟩_ (Inverse.from map-∈↔)

_++-mono_ : ∀ {a} {A : Set a} {xs₁ xs₂ ys₁ ys₂ : List A} →
            xs₁ ⊆ ys₁ → xs₂ ⊆ ys₂ → xs₁ ++ xs₂ ⊆ ys₁ ++ ys₂
_++-mono_ xs₁⊆ys₁ xs₂⊆ys₂ =
  _⟨$⟩_ (Inverse.to ++↔) ∘
  Sum.map xs₁⊆ys₁ xs₂⊆ys₂ ∘
  _⟨$⟩_ (Inverse.from ++↔)

concat-mono : ∀ {a} {A : Set a} {xss yss : List (List A)} →
              xss ⊆ yss → concat xss ⊆ concat yss
concat-mono {a} xss⊆yss =
  _⟨$⟩_ (Inverse.to $ concat-∈↔ {a = a}) ∘
  Prod.map id (Prod.map id xss⊆yss) ∘
  _⟨$⟩_ (Inverse.from $ concat-∈↔ {a = a})

>>=-mono : ∀ {ℓ} {A B : Set ℓ} (f g : A → List B) {xs ys} →
           xs ⊆ ys → (∀ {x} → f x ⊆ g x) →
           (xs >>= f) ⊆ (ys >>= g)
>>=-mono {ℓ} f g xs⊆ys f⊆g =
  _⟨$⟩_ (Inverse.to $ >>=-∈↔ {ℓ = ℓ}) ∘
  Prod.map id (Prod.map xs⊆ys f⊆g) ∘
  _⟨$⟩_ (Inverse.from $ >>=-∈↔ {ℓ = ℓ})

_⊛-mono_ : ∀ {ℓ} {A B : Set ℓ}
             {fs gs : List (A → B)} {xs ys : List A} →
           fs ⊆ gs → xs ⊆ ys → (fs ⊛ xs) ⊆ (gs ⊛ ys)
_⊛-mono_ {fs = fs} {gs} fs⊆gs xs⊆ys =
  _⟨$⟩_ (Inverse.to $ ⊛-∈↔ gs) ∘
  Prod.map id (Prod.map id (Prod.map fs⊆gs (Prod.map xs⊆ys id))) ∘
  _⟨$⟩_ (Inverse.from $ ⊛-∈↔ fs)

_⊗-mono_ : {A B : Set} {xs₁ ys₁ : List A} {xs₂ ys₂ : List B} →
           xs₁ ⊆ ys₁ → xs₂ ⊆ ys₂ → (xs₁ ⊗ xs₂) ⊆ (ys₁ ⊗ ys₂)
xs₁⊆ys₁ ⊗-mono xs₂⊆ys₂ =
  _⟨$⟩_ (Inverse.to ⊗-∈↔) ∘
  Prod.map xs₁⊆ys₁ xs₂⊆ys₂ ∘
  _⟨$⟩_ (Inverse.from ⊗-∈↔)

any-mono : ∀ {a} {A : Set a} (p : A → Bool) →
           ∀ {xs ys} → xs ⊆ ys → T (any p xs) → T (any p ys)
any-mono {a} p xs⊆ys =
  _⟨$⟩_ (Equivalence.to $ any⇔ {a = a}) ∘
  mono xs⊆ys ∘
  _⟨$⟩_ (Equivalence.from $ any⇔ {a = a})

map-with-∈-mono :
  ∀ {a b} {A : Set a} {B : Set b}
    {xs : List A} {f : ∀ {x} → x ∈ xs → B}
    {ys : List A} {g : ∀ {x} → x ∈ ys → B}
  (xs⊆ys : xs ⊆ ys) → (∀ {x} → f {x} ≗ g ∘ xs⊆ys) →
  map-with-∈ xs f ⊆ map-with-∈ ys g
map-with-∈-mono {f = f} {g = g} xs⊆ys f≈g {x} =
  _⟨$⟩_ (Inverse.to map-with-∈↔) ∘
  Prod.map id (Prod.map xs⊆ys (λ {x∈xs} x≡fx∈xs → begin
    x               ≡⟨ x≡fx∈xs ⟩
    f x∈xs          ≡⟨ f≈g x∈xs ⟩
    g (xs⊆ys x∈xs)  ∎)) ∘
  _⟨$⟩_ (Inverse.from map-with-∈↔)
  where open P.≡-Reasoning

-- Other properties.

filter-⊆ : ∀ {a} {A : Set a} (p : A → Bool) →
           (xs : List A) → filter p xs ⊆ xs
filter-⊆ _ []       = λ ()
filter-⊆ p (x ∷ xs) with p x | filter-⊆ p xs
... | false | hyp = there ∘ hyp
... | true  | hyp =
  λ { (here  eq)      → here eq
    ; (there ∈filter) → there (hyp ∈filter)
    }

------------------------------------------------------------------------
-- Other properties

-- Only a finite number of distinct elements can be members of a
-- given list.

finite : ∀ {a} {A : Set a}
         (f : Inj.Injection (P.setoid ℕ) (P.setoid A)) →
         ∀ xs → ¬ (∀ i → Inj.Injection.to f ⟨$⟩ i ∈ xs)
finite         inj []       ∈[]   with ∈[] zero
... | ()
finite {A = A} inj (x ∷ xs) ∈x∷xs = excluded-middle helper
  where
  open Inj.Injection inj

  module DTO = DecTotalOrder Nat.decTotalOrder
  module STO = StrictTotalOrder
                 (DTOProperties.strictTotalOrder Nat.decTotalOrder)
  module CS  = CommutativeSemiring NatProp.commutativeSemiring

  not-x : ∀ {i} → ¬ (to ⟨$⟩ i ≡ x) → to ⟨$⟩ i ∈ xs
  not-x {i} ≢x with ∈x∷xs i
  ... | here  ≡x  = ⊥-elim (≢x ≡x)
  ... | there ∈xs = ∈xs

  helper : ¬ Dec (∃ λ i → to ⟨$⟩ i ≡ x)
  helper (no ≢x)        = finite inj  xs (λ i → not-x (≢x ∘ _,_ i))
  helper (yes (i , ≡x)) = finite inj′ xs ∈xs
    where
    open P

    f : ℕ → A
    f j with STO.compare i j
    f j | tri< _ _ _ = to ⟨$⟩ suc j
    f j | tri≈ _ _ _ = to ⟨$⟩ suc j
    f j | tri> _ _ _ = to ⟨$⟩ j

    ∈-if-not-i : ∀ {j} → i ≢ j → to ⟨$⟩ j ∈ xs
    ∈-if-not-i i≢j = not-x (i≢j ∘ injective ∘ trans ≡x ∘ sym)

    lemma : ∀ {k j} → k ≤ j → suc j ≢ k
    lemma 1+j≤j refl = NatProp.1+n≰n 1+j≤j

    ∈xs : ∀ j → f j ∈ xs
    ∈xs j with STO.compare i j
    ∈xs j  | tri< (i≤j , _) _ _ = ∈-if-not-i (lemma i≤j ∘ sym)
    ∈xs j  | tri> _ i≢j _       = ∈-if-not-i i≢j
    ∈xs .i | tri≈ _ refl _      =
      ∈-if-not-i (NatProp.m≢1+m+n i ∘
                  subst (_≡_ i ∘ suc) (sym $ proj₂ CS.+-identity i))

    injective′ : Inj.Injective {B = P.setoid A} (→-to-⟶ f)
    injective′ {j} {k} eq with STO.compare i j | STO.compare i k
    ... | tri< _ _ _         | tri< _ _ _         = cong pred                                   $ injective eq
    ... | tri< _ _ _         | tri≈ _ _ _         = cong pred                                   $ injective eq
    ... | tri< (i≤j , _) _ _ | tri> _ _ (k≤i , _) = ⊥-elim (lemma (DTO.trans k≤i i≤j)           $ injective eq)
    ... | tri≈ _ _ _         | tri< _ _ _         = cong pred                                   $ injective eq
    ... | tri≈ _ _ _         | tri≈ _ _ _         = cong pred                                   $ injective eq
    ... | tri≈ _ i≡j _       | tri> _ _ (k≤i , _) = ⊥-elim (lemma (subst (_≤_ k) i≡j k≤i)       $ injective eq)
    ... | tri> _ _ (j≤i , _) | tri< (i≤k , _) _ _ = ⊥-elim (lemma (DTO.trans j≤i i≤k)     $ sym $ injective eq)
    ... | tri> _ _ (j≤i , _) | tri≈ _ i≡k _       = ⊥-elim (lemma (subst (_≤_ j) i≡k j≤i) $ sym $ injective eq)
    ... | tri> _ _ (j≤i , _) | tri> _ _ (k≤i , _) =                                               injective eq

    inj′ = record
      { to        = →-to-⟶ {B = P.setoid A} f
      ; injective = injective′
      }


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

open import Base
open import Homotopy.PullbackDef

{- In this file we prove that if two diagrams are equivalent (there are
   equivalences between the types and the squares are commutative), then the
   natural map between the pullbacks is also an equivalence -}

module Homotopy.PullbackInvariantEquiv {i}
    (d d' : pullback-diag i) where

private
  pullback-to-pullback : ∀ {i} {A A' : Set i} (p : A ≡ A')
    {B B' : Set i} (q : B ≡ B') {C C' : Set i} (r : C ≡ C')
    {f : A → C} {f' : A' → C'}
    (s : (a : A) → f' ((transport _ p) a) ≡ transport _ r (f a))
    {g : B → C} {g' : B' → C'}
    (t : (b : B) → transport _ r (g b) ≡ g' ((transport _ q) b))
    → pullback (diag A , B , C , f , g) → pullback (diag A' , B' , C' , f' , g')
  pullback-to-pullback p q r s t (a , b , e) =
    (transport _ p a , transport _ q b , (s a ∘ (ap (transport _ r) e ∘ t b)))

  transport-pullback : ∀ {i} {A A' : Set i} (p : A ≡ A')
    {B B' : Set i} (q : B ≡ B') {C C' : Set i} (r : C ≡ C')
    {f : A → C} {f' : A' → C'} (s : f' ◯ (transport _ p) ≡ transport _ r ◯ f)
    {g : B → C} {g' : B' → C'} (t : transport _ r ◯ g ≡ g' ◯ (transport _ q))
    → transport pullback (pullback-diag-raw-eq p q r {f' = f'} s {g' = g'} t)
      ≡ pullback-to-pullback p q r (happly s) (happly t)
  transport-pullback refl refl refl refl refl =
    funext (λ r → ap (λ u → _ , _ , u)
                  (! (ap-id _) ∘ ! (refl-right-unit _)))

  transport-pullback-funext : ∀ {i} {A A' : Set i} (p : A ≡ A')
    {B B' : Set i} (q : B ≡ B') {C C' : Set i} (r : C ≡ C')
    {f : A → C} {f' : A' → C'}
    (s : (a : A) → f' ((transport _ p) a) ≡ transport _ r (f a))
    {g : B → C} {g' : B' → C'}
    (t : (b : B) → transport _ r (g b) ≡ g' ((transport _ q) b))
    → transport pullback (pullback-diag-raw-eq p q r {f' = f'} (funext s)
                                                     {g' = g'} (funext t))
      ≡ pullback-to-pullback p q r s t
  transport-pullback-funext p q r s t =
    transport-pullback p q r (funext s) (funext t)
    ∘ (ap (λ u → pullback-to-pullback p q r u (happly (funext t)))
           (happly-funext s)
    ∘ ap (λ u → pullback-to-pullback p q r s u) (happly-funext t))

  path-to-eq-ap : ∀ {i j} {A : Set i} (P : A → Set j) {x y : A} (p : x ≡ y)
    → π₁ (path-to-eq (ap P p)) ≡ transport P p
  path-to-eq-ap P refl = refl

open pullback-diag d
open pullback-diag d' renaming (A to A'; B to B'; C to C'; f to f'; g to g')

module PullbackInvariantEquiv (eqA : A ≃ A') (eqB : B ≃ B') (eqC : C ≃ C')
           (p : (a : A) → f' (eqA ☆ a) ≡ eqC ☆ (f a))
           (q : (b : B) → eqC ☆ (g b) ≡ g' (eqB ☆ b)) where

  private
    d≡d' : d ≡ d'
    d≡d' = pullback-diag-eq eqA eqB eqC p q

    pullback-equiv-pullback : pullback d ≃ pullback d'
    pullback-equiv-pullback = path-to-eq (ap pullback d≡d')

    h : (a : A) → f' ((transport (λ v → v) (eq-to-path eqA) a))
                  ≡ transport (λ v → v) (eq-to-path eqC) (f a)
    h a = ap f' (trans-id-eq-to-path eqA a)
          ∘ (p a ∘ (! (trans-id-eq-to-path eqC (f a))))

    h' : (b : B) → transport (λ v → v) (eq-to-path eqC) (g b)
                   ≡ g' ((transport (λ v → v) (eq-to-path eqB) b))
    h' b = trans-id-eq-to-path eqC (g b)
           ∘ (q b ∘ ap g' (! (trans-id-eq-to-path eqB b)))

  pullback-to-equiv-pullback : pullback d → pullback d'
  pullback-to-equiv-pullback (a , b , e) =
    ((eqA ☆ a) , (eqB ☆ b) , (p a ∘ (ap (π₁ eqC) e ∘ q b)))

  private
    pb-to-pb-equal-pb-to-equiv-pb : (x : pullback d)
      → pullback-to-pullback (eq-to-path eqA) (eq-to-path eqB) (eq-to-path eqC)
                             h h' x
        ≡ pullback-to-equiv-pullback x
    pb-to-pb-equal-pb-to-equiv-pb (a , b , h) =
      pullback-eq d' (trans-id-eq-to-path eqA a)
        (trans-id-eq-to-path eqB b)
        (concat-assoc (ap f' (trans-id (eq-to-path eqA) a ∘ _) ∘ _) _ _
         ∘ (concat-assoc (ap f' (trans-id (eq-to-path eqA) a ∘ _)) _ _
         ∘ whisker-left (ap f' (trans-id (eq-to-path eqA) a ∘ _))
        (concat-assoc (p a) _ _
         ∘ whisker-left (p a)
        (whisker-left (! (trans-id (eq-to-path eqC) (f a) ∘ _))
          (concat-assoc (ap (transport (λ v → v) (eq-to-path eqC)) h) _ _
           ∘ whisker-left (ap (transport (λ v → v) (eq-to-path eqC)) h)
          (concat-assoc (trans-id (eq-to-path eqC) (g b) ∘ _) _ _
           ∘ whisker-left (trans-id (eq-to-path eqC) (g b) ∘ _)
          (concat-assoc (q b) _ _
           ∘ (whisker-left (q b)
          (concat-ap g' (! (trans-id (eq-to-path eqB) b ∘ _)) _
           ∘ ap (ap g')
             (opposite-left-inverse (trans-id (eq-to-path eqB) b ∘ _)))
           ∘ refl-right-unit (q b)))))
         ∘ move!-right-on-left (trans-id (eq-to-path eqC) (f a) ∘ _) _ _
         (! (concat-assoc (ap (transport (λ v → v) (eq-to-path eqC)) h)
                (trans-id (eq-to-path eqC) (g b) ∘ _) _)
         ∘ ((whisker-right (q b)
              (homotopy-naturality (transport (λ v → v) (eq-to-path eqC))
                 (π₁ eqC)
                 (λ t → trans-id (eq-to-path eqC) t
                        ∘ ap (λ u → π₁ u t) (eq-to-path-right-inverse eqC))
                 h))
           ∘ concat-assoc (trans-id (eq-to-path eqC) (f a) ∘ _) (ap (π₁ eqC) h)
               (q b)))))))

    pb-equiv-pb-equal-pb-to-equiv-pb
      : π₁ pullback-equiv-pullback ≡ pullback-to-equiv-pullback
    pb-equiv-pb-equal-pb-to-equiv-pb =
        path-to-eq-ap pullback d≡d'
        ∘ (transport-pullback-funext (eq-to-path eqA) (eq-to-path eqB)
                                     (eq-to-path eqC) h h'
        ∘ funext pb-to-pb-equal-pb-to-equiv-pb)

  abstract
    pullback-invariant-is-equiv : is-equiv pullback-to-equiv-pullback
    pullback-invariant-is-equiv =
      transport is-equiv pb-equiv-pb-equal-pb-to-equiv-pb
                (π₂ pullback-equiv-pullback)

  pullback-invariant-equiv : pullback d ≃ pullback d'
  pullback-invariant-equiv =
    (pullback-to-equiv-pullback , pullback-invariant-is-equiv)

open PullbackInvariantEquiv public


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

module Issue3564-2 where

open import Issue3564


open import Everything

module Test.Test6 where

module TestReflexivity where

  postulate

    X : Set
    F : X → X → Set
    instance ReflexivityF : Reflexivity.class F

  test : ∀ {y} → F y y
  test {y = y} = reflexivity

  {-
  Goal: F y y
  Have: {𝔬 : Ł} {𝔒 : Set 𝔬} {𝔯 : Ł} {_∼_ : 𝔒 → 𝔒 → Set 𝔯}
        {{r : 𝓡eflexivity {𝔬} {𝔒} {𝔯} _∼_}} {x  : 𝔒} →
        x ∼ x
  ————————————————————————————————————————————————————————————
  y : X

  _𝔬1 : Ł
  _𝔒1 : Set _𝔬1
  _𝔯1 : Ł
  __∼1_ : _𝔒1 → _𝔒1 → Set _𝔯1
  _r1 : 𝓡eflexivity {_𝔬1} {_𝔒1} {_𝔯1} __∼1_
  _x1 : _𝔒1

  __∼1_ _x1 _x1 = F y y

  __∼1_ := λ s t → F s t
  _x1 := y

  __∼1_ := λ s t → F t s
  _x1 := y

  __∼1_ := λ s t → F y y

  λ {𝔬} {𝔒} {𝔯} {_∼_} → 𝓡eflexivity.reflexivity
  -}

module _Indexed where

  record I (M : Set) (N : M → Set) : Set where
    field f : ∀ {m} → N m

  open I ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    instance iB : I A B

  test : ∀ {a} → B a
  test {a = a} = f

module IndexedTotal1Var where

  record Indexed (M : Set) (N : M → Set) : Set where
    field fooI : ∀ {m} → N m

  open Indexed ⦃ … ⦄

  record Total (N : Set) : Set where
    field fooT : N

  open Total ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    B' : A → Set
    instance iIndexed : Indexed A B
    instance iTotal : ∀ {x} → Total (B x)
    instance iIndexed' : Indexed A B'
    instance iTotal' : ∀ {x} → Total (B' x)

  testIndexed : ∀ {a} → B a
  testIndexed {a = a} = fooI

  testTotal : ∀ {a} → B a
  testTotal {a = a} = fooT

  {-

  Goal: B a
  Have: {M : Set} {N : M → Set} {{r : R M N}} {m : M} → N m
  ————————————————————————————————————————————————————————————
  a : A

  _M : Set
  _N : _M → Set
  _r : R _M _N
  _m : _M

  _N _m = B a

  no unconstrained metavariables in type of _r because _M occurs in the type of _N and _N _m = B a

  candidate#1
  _r := iR : R A B
  _M = A
  _M := A
  _N = B
  _N := B

  now we can solve for _m:
  _N := B
  _N _m = B a
  B _m = B a
  _m = a
  _m := a

  -}

module Indexed≡Total2Prop where

  open import Oscar.Data.Proposequality

  record Indexed {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) (S : ∀ {m} → N m → N m → Set) {F : ∀ {m} (n : N m) → Set} ⦃ _ : (λ {m} (n : N m) → S n (s n)) ≡ F ⦄ : Set where
    field fooI : ∀ {m} {n : N m} → S n (s n)

  open Indexed ⦃ … ⦄

  record Total {N : Set} (s : N → N) (S : N → N → Set) : Set where
    field fooT : ∀ n → S n (s n)

  open Total ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    f : ∀ {x} → B x → B x
    F : ∀ {x} → B x → B x → Set

    instance iIndexed : Indexed B f F ⦃ ∅ ⦄
    instance iTotal : ∀ {x} → Total (f {x}) (F {x})

  testIndexed : ∀ {a} {b : B a} → F b (f b)
  testIndexed = fooI ⦃ ∅ ⦄

  testTotal : ∀ {a} (b : B a) → F b (f b)
  testTotal = fooT {S = F}

module Indexed≡Total1Prop where

  open import Oscar.Data.Proposequality

  record Indexed {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) (S : ∀ {m} → N m → Set) {F : ∀ {m} (n : N m) → Set} ⦃ _ : (λ {m} (n : N m) → S (s n)) ≡ F ⦄ : Set where
    field fooI : ∀ {m} {n : N m} → S (s n)

  open Indexed ⦃ … ⦄

  record Total {N : Set} (s : N → N) (S : N → Set) : Set where
    field fooT : ∀ n → S (s n)

  open Total ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    f : ∀ {x} → B x → B x
    F : ∀ {x} → B x → Set

    instance iIndexed : Indexed B f F ⦃ ∅ ⦄
    instance iTotal : ∀ {x} → Total (f {x}) (F {x})

  testIndexed : ∀ {a} {b : B a} → F (f b)
  testIndexed = fooI ⦃ ∅ ⦄

  testTotal : ∀ {a} (b : B a) → F (f b)
  testTotal = fooT {S = F}

module Indexed≡Total1Prop<Constraint where

  open import Oscar.Data.Proposequality

  data Luft {a} {A : Set a} (x : A) : Set where
    instance ∅ : Luft x

  record Indexed {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) (S : ∀ {m} → N m → Set) ⦃ _ : Luft (λ {m} → s {m}) ⦄ : Set where
    field fooI : ∀ {m} {n : N m} → S (s n)

  open Indexed ⦃ … ⦄

  record Total {N : Set} (s : N → N) (S : N → Set) : Set where
    field fooT : ∀ n → S (s n)

  open Total ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    f : ∀ {x} → B x → B x
    F : ∀ {x} → B x → Set

    instance iIndexed : Indexed B f F
    instance iTotal : ∀ {x} → Total (f {x}) (F {x})

  testIndexed : ∀ {a} {b : B a} → F (f b)
  testIndexed = fooI ⦃ ∅ ⦄

  testTotal : ∀ {a} (b : B a) → F (f b)
  testTotal = fooT {S = F}

module Indexed≡Total2Prop<Constraint-Multi where

  open import Oscar.Data.Proposequality

  data Luft {a} {A : Set a} (x : A) : Set where
    instance ∅ : Luft x

  record Indexed {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) (S : ∀ {m} → N m → N m → Set) ⦃ _ : Luft (λ {m} → s {m}) ⦄ : Set where
    field fooI : ∀ {m} {n : N m} → S n (s n)

  open Indexed ⦃ … ⦄

  record Total {N : Set} (s : N → N) (S : N → N → Set) : Set where
    field fooT : ∀ n → S n (s n)

  open Total ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    f f' : ∀ {x} → B x → B x
    F F' : ∀ {x} → B x → B x → Set

    instance _ : Indexed B f F
    instance _ : Indexed B f' F
    instance _ : Indexed B f F'
    instance _ : Indexed B f' F'
    instance _ : ∀ {x} → Total (f {x}) (F {x})

  testIndexed : ∀ {a} {b : B a} → F b (f b)
  testIndexed = fooI ⦃ ∅ ⦄

  testIndexed2 : ∀ {a} {b : B a} → F (f b) (f (f b))
  testIndexed2 = fooI ⦃ ∅ ⦄

  testTotal : ∀ {a} (b : B a) → F b (f b)
  testTotal = fooT {S = F}

module Indexed≡Total2Prop<Constraint-Multi-2Fun where

  open import Oscar.Data.Proposequality

  data Luft {a} {A : Set a} (x : A) : Set where
    instance ∅ : Luft x

  record Indexed {M : Set} (N : M → Set) (s t : ∀ {m} → N m → N m) (S : ∀ {m} → N m → N m → Set) ⦃ _ : Luft (λ {m} → s {m}) ⦄ ⦃ _ : Luft (λ {m} → t {m}) ⦄ : Set where
    field fooI : ∀ {m} {n : N m} → S (t n) (s n)

  fooI : {M : Set} {N : M → Set} {s t : ∀ {m} → N m → N m} {S : ∀ {m} → N m → N m → Set} ⦃ _ : Indexed N s t S ⦄ → ∀ {m} {n : N m} → S (t n) (s n)
  fooI ⦃ I ⦄ = Indexed.fooI I -- equivalently, fooI = Indexed.fooI ⦃ ∅ ⦄ ⦃ ∅ ⦄ !

  record Total {N : Set} (s t : N → N) (S : N → N → Set) ⦃ _ : Luft s ⦄ ⦃ _ : Luft t ⦄ : Set where
    field fooT : ∀ {n} → S (t n) (s n)

  fooT : {N : Set} {s t : N → N} {S : N → N → Set} ⦃ _ : Total s t S ⦄ → ∀ {n : N} → S (t n) (s n)
  fooT ⦃ I ⦄ = Total.fooT I

  IndexedTotal : {M : Set} (N : M → Set) (s t : ∀ {m} → N m → N m) (S : ∀ {m} → N m → N m → Set) → Set
  IndexedTotal _ s t S = ∀ {x} → Total (s {x}) (t {x}) (S {x})

  postulate
    A : Set
    B : A → Set
    f f' : ∀ {x} → B x → B x
    g g' : ∀ {x} → B x → B x
    F F' : ∀ {x} → B x → B x → Set

    instance _ : Indexed B f f F
    instance _ : Indexed B f' g F
    instance _ : Indexed B f g F'
    instance _ : Indexed B f' g F'
    instance _ : IndexedTotal B f f F
    instance _ : IndexedTotal B f' g F
    instance _ : IndexedTotal B f g F'
    instance _ : IndexedTotal B f' g F'
    instance _ : Indexed B f g F
    -- instance _ : Indexed B (λ b → f (g' b)) (λ b → g (g' b)) F -- this would overlap with the above
    instance _ : ∀ {x} → Total (f {x}) (g {x}) (F {x})

  testIndexed : ∀ {a} {b : B a} → F (g b) (f b)
  testIndexed = fooI

  testIndexed2 : ∀ {a} {b : B a} → F (g (g' b)) (f (g' b))
  testIndexed2 = fooI

  testIndexed3 : ∀ {a} {b : B a} → F (f (g' b)) (f (g' b))
  testIndexed3 = fooI

  testTotal : ∀ {a} {b : B a} → F (g b) (f b)
  testTotal = fooT

module Indexed≡Total2Prop<Constraint-Multi-2Fun-NoIndexedRecord where

  open import Oscar.Data.Proposequality

  data Luft {a} {A : Set a} (x : A) : Set where
    instance ∅ : Luft x

  record Total {N : Set} (s t : N → N) (S : N → N → Set) ⦃ _ : Luft s ⦄ ⦃ _ : Luft t ⦄ : Set where
    field fooT : ∀ {n} → S (t n) (s n)

  fooT : {N : Set} {s t : N → N} {S : N → N → Set} ⦃ _ : Total s t S ⦄ → ∀ {n : N} → S (t n) (s n)
  fooT ⦃ I ⦄ = Total.fooT I

  Indexed : {M : Set} (N : M → Set) (s t : ∀ {m} → N m → N m) (S : ∀ {m} → N m → N m → Set) (x : M) → Set
  Indexed _ s t S x = Total (s {x}) (t {x}) (S {x})

  IndexedTotal : {M : Set} (N : M → Set) (s t : ∀ {m} → N m → N m) (S : ∀ {m} → N m → N m → Set) → Set
  IndexedTotal _ s t S = ∀ {x} → Total (s {x}) (t {x}) (S {x})

  fooI : {M : Set} {N : M → Set} {s t : ∀ {m} → N m → N m} {S : ∀ {m} → N m → N m → Set} ⦃ _ : IndexedTotal N s t S ⦄ → ∀ {m} {n : N m} → S (t n) (s n)
  fooI = fooT

  fooI' : {M : Set} {N : M → Set} → ∀ {m} {s t : N m → N m} {S : N m → N m → Set} ⦃ _ : Total s t S ⦄ → {n : N m} → S (t n) (s n)
  fooI' = fooT

  postulate
    A : Set
    B : A → Set
    f f' : ∀ {x} → B x → B x
    g g' : ∀ {x} → B x → B x
    F F' : ∀ {x} → B x → B x → Set

    instance _ : IndexedTotal B f f F
    instance _ : IndexedTotal B f' g F
    instance _ : IndexedTotal B f g F'
    instance _ : IndexedTotal B f' g F'
    instance _ : IndexedTotal B f g F
    -- instance _ : Indexed B (λ b → f (g' b)) (λ b → g (g' b)) F -- this would overlap with the above
    -- instance _ : ∀ {x} → Total (f {x}) (g {x}) (F {x})

  module _ {a a' : A} (b : B a) (b' : B a') where
    postulate instance _ : Total (g {a'}) f' F
    postulate instance i2 : Indexed B g f' F a
    testTotal' : F (g _) (f _)
    testTotal' = fooT {n = b}
    testTotal'2 : F (f' _) (g _)
    testTotal'2 = fooT {n = b'}
    testTotal'2I : F (f' b') (g _)
    testTotal'2I = fooI {m = a'} -- use fooI when instance given by Total
    testTotal'2I' : F (f' b') (g b')
    testTotal'2I' = fooI' {N = B}
    testTotal'3 : F (f' b) (g b)
    testTotal'3 = fooI {m = a} -- or by Indexed
    testTotal'3' : F (f' b) (g b)
    testTotal'3' = fooI' {N = B}

  testTotalLhs : ∀ {a} {b : B a} → _
  testTotalLhs {a} {b} = fooT {s = f'} {S = F'} {n = b}

  testIndexed : ∀ {a} {b : B a} → F (g b) (f b)
  testIndexed {a} {b} = fooI {S = λ {x} → F {x}} -- use fooI when instance given by IndexedTotal
{-
Have: {M : Set} {N : M → Set} {s t : {m : M} → N m → N m}
      {S : {m : M} → N m → N m → Set}
      {{_ : Indexed {M} N s t S {{∅}} {{∅}}}} {m : M} {n : N m} →
      S {m} (t {m} n) (s {m} n)

Have: {N : Set} {s t : N → N} {S : N → N → Set}
      {{_ : Total {N} s t S {{∅}} {{∅}}}} {n : N} →
      S (t n) (s n)
-}

  testIndexed2 : ∀ {a} {b : B a} → F (g (g' b)) (f (g' b))
  testIndexed2 = fooT

  testIndexed3 : ∀ {a} {b : B a} → F (f (g' b)) (f (g' b))
  testIndexed3 = fooT

  testTotal : ∀ {a} {b : B a} → F (g b) (f b)
  testTotal = fooT

module Indexed≡Total1Prop+Data where

  open import Oscar.Data.Proposequality

  data [_/_/_]≡_ {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) (S : ∀ {m} → N m → Set) (F : ∀ {m} (n : N m) → Set) : Set where
    instance ∅ : [ N / s / S ]≡ F

  record Indexed {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) (S : ∀ {m} → N m → Set) ⦃ _ : [ N / s / S ]≡ λ {m} (n : N m) → S (s n) ⦄ : Set where
    field fooI : ∀ {m} {n : N m} → S (s n)

  open Indexed ⦃ … ⦄

  record Total {N : Set} (s : N → N) (S : N → Set) : Set where
    field fooT : ∀ n → S (s n)

  open Total ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    f : ∀ {x} → B x → B x
    F : ∀ {x} → B x → Set

    instance iIndexed : Indexed B f F ⦃ ∅ ⦄
    instance iTotal : ∀ {x} → Total (f {x}) (F {x})

  testIndexed : ∀ {a} {b : B a} → F (f b)
  testIndexed = fooI ⦃ ∅ ⦄

  testTotal : ∀ {a} (b : B a) → F (f b)
  testTotal = fooT {S = F}

module Indexed≡Total1Prop+Data2 where

  open import Oscar.Data.Proposequality

  data [_/_] {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) : Set where
    instance ∅ : [ N / s ]

  record Indexed {M : Set} (N : M → Set) (s : ∀ {m} → N m → N m) (S : ∀ {m} → N m → Set) ⦃ _ : [ N / s ] ⦄ : Set where
    field fooI : ∀ {m} {n : N m} → S (s n)

  open Indexed ⦃ … ⦄

  record Total {N : Set} (s : N → N) (S : N → Set) : Set where
    field fooT : ∀ n → S (s n)

  open Total ⦃ … ⦄

  postulate
    A : Set
    B : A → Set
    f : ∀ {x} → B x → B x
    F : ∀ {x} → B x → Set

    instance iIndexed : Indexed B f F ⦃ ∅ ⦄
    instance iTotal : ∀ {x} → Total (f {x}) (F {x})

  testIndexed : ∀ {a} {b : B a} → F (f b)
  testIndexed = fooI ⦃ ∅ ⦄

  testTotal : ∀ {a} (b : B a) → F (f b)
  testTotal = fooT {S = F}


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

--open import HoTT
open import homotopy.3x3.PushoutPushout
open import homotopy.3x3.Transpose
import homotopy.3x3.To as To
import homotopy.3x3.From as From
open import homotopy.3x3.Common

module homotopy.3x3.ToFrom {i} (d : Span^2 {i}) where

open Span^2 d
open M d hiding (Pushout^2)
open M (transpose d) using () renaming (A₀∙ to A∙₀; A₂∙ to A∙₂; A₄∙ to A∙₄;
                                        module F₁∙ to F∙₁; f₁∙ to f∙₁;
                                        module F₃∙ to F∙₃; f₃∙ to f∙₃;
                                        v-h-span to h-v-span)
open M using (Pushout^2)

open To d
open From d

open import homotopy.3x3.ToFromInit d
open import homotopy.3x3.ToFrom2 d
open import homotopy.3x3.ToFrom3 d

to-from-g-g : (c : A₂₂) → (to-from-g-l (f₁₂ c) , ↓-='-out (apd (to-from-r ∘ f∙₃) (glue c)) , ↓-='-out (apd (ap to ∘ ap from ∘ glue) (glue c))
                        =□□ ↓-='-out (apd glue (glue c)) , ↓-='-out (apd (to-from-l ∘ f∙₁) (glue c)) , to-from-g-r (f₃₂ c))
to-from-g-g c = coh _ lemma1 lemma3 _ _ (↓-='-out (apd glue (glue c))) lemma2
                    where
                open M2 c
                open M3 c

to-from-g-g' : (c : A₂₂) → to-from-g-l (f₁₂ c) == to-from-g-r (f₃₂ c) [ (λ c → (to-from-l (f∙₁ c) , glue c =□ ap to (ap from (glue c)) , to-from-r (f∙₃ c))) ↓ glue c ]
to-from-g-g' c = ↓-=□-in (to-from-g-g c)

module ToFromG = PushoutElim {d = span _ _ _ f₁₂ f₃₂} {P = λ c → (to-from-l (f∙₁ c) , glue c =□ ap to (ap from (glue c)) , to-from-r (f∙₃ c))}
                 to-from-g-l to-from-g-r to-from-g-g'

to-from-g : (c : A∙₂) → (to-from-l (f∙₁ c) , glue c =□ ap to (ap from (glue c)) , to-from-r (f∙₃ c))
to-from-g = ToFromG.f

to-from-g' : (c : A∙₂) → to-from-l (f∙₁ c) == to-from-r (f∙₃ c) [ (λ z → to (from z) == z) ↓ glue c ]
to-from-g' c = ↓-∘=idf-in to from (to-from-g c)

to-from : (x : Pushout^2 (transpose d)) → to (from x) == x
to-from = Pushout-elim to-from-l to-from-r to-from-g'


-- Andreas, 2014-10-23
-- We want to split on hidden variables.

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

f : {n : ℕ}  → Set₁
f = Set
  where
  g : {n : ℕ} → Set → Set
  g _ = {!.n!}


open import Prelude
open import Nat
open import core

module binders-disjoint-checks where
  -- these are fairly mechanical lemmas that show that the
  -- judgementally-defined binders-disjoint is really a type-directed
  -- function
  mutual
    lem-bdσ-lam : ∀{σ x τ d} → binders-disjoint-σ σ (·λ_[_]_ x τ d) → binders-disjoint-σ σ d
    lem-bdσ-lam BDσId = BDσId
    lem-bdσ-lam (BDσSubst x₁ bd) = BDσSubst (lem-bd-lam x₁) (lem-bdσ-lam bd)

    lem-bd-lam :  ∀{ d1 x τ1 d} → binders-disjoint d1 (·λ_[_]_ x  τ1 d) → binders-disjoint d1 d
    lem-bd-lam BDConst = BDConst
    lem-bd-lam BDVar = BDVar
    lem-bd-lam (BDLam bd (UBLam2 x₂ x₃)) = BDLam (lem-bd-lam bd) x₃
    lem-bd-lam (BDHole x₁) = BDHole (lem-bdσ-lam x₁)
    lem-bd-lam (BDNEHole x₁ bd) = BDNEHole (lem-bdσ-lam x₁) (lem-bd-lam bd)
    lem-bd-lam (BDAp bd bd₁) = BDAp (lem-bd-lam bd) (lem-bd-lam bd₁)
    lem-bd-lam (BDCast bd) = BDCast (lem-bd-lam bd)
    lem-bd-lam (BDFailedCast bd) = BDFailedCast (lem-bd-lam bd)

  mutual
    lem-bdσ-hole : ∀{d u σ σ'} → binders-disjoint-σ σ ⦇⌜ d ⌟⦈⟨ u , σ' ⟩ → binders-disjoint-σ σ d
    lem-bdσ-hole BDσId = BDσId
    lem-bdσ-hole (BDσSubst x bd) = BDσSubst (lem-bd-hole x) (lem-bdσ-hole bd)

    lem-bd-hole : ∀{d1 d u σ} → binders-disjoint d1 ⦇⌜ d ⌟⦈⟨ u , σ ⟩ → binders-disjoint d1 d
    lem-bd-hole BDConst = BDConst
    lem-bd-hole BDVar = BDVar
    lem-bd-hole (BDLam bd (UBNEHole x₁ x₂)) = BDLam (lem-bd-hole bd) x₂
    lem-bd-hole (BDHole x) = BDHole (lem-bdσ-hole x)
    lem-bd-hole (BDNEHole x bd) = BDNEHole (lem-bdσ-hole x) (lem-bd-hole bd)
    lem-bd-hole (BDAp bd bd₁) = BDAp (lem-bd-hole bd) (lem-bd-hole bd₁)
    lem-bd-hole (BDCast bd) = BDCast (lem-bd-hole bd)
    lem-bd-hole (BDFailedCast bd) = BDFailedCast (lem-bd-hole bd)

  mutual
    lem-bdσ-cast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ (d ⟨ τ1 ⇒ τ2 ⟩) → binders-disjoint-σ σ d
    lem-bdσ-cast BDσId = BDσId
    lem-bdσ-cast (BDσSubst x bd) = BDσSubst (lem-bd-cast x) (lem-bdσ-cast bd)

    lem-bd-cast : ∀{d1 d τ1 τ2} → binders-disjoint d1 (d ⟨ τ1 ⇒ τ2 ⟩) → binders-disjoint d1 d
    lem-bd-cast BDConst = BDConst
    lem-bd-cast BDVar = BDVar
    lem-bd-cast (BDLam bd (UBCast x₁)) = BDLam (lem-bd-cast bd) x₁
    lem-bd-cast (BDHole x) = BDHole (lem-bdσ-cast x)
    lem-bd-cast (BDNEHole x bd) = BDNEHole (lem-bdσ-cast x) (lem-bd-cast bd)
    lem-bd-cast (BDAp bd bd₁) = BDAp (lem-bd-cast bd) (lem-bd-cast bd₁)
    lem-bd-cast (BDCast bd) = BDCast (lem-bd-cast bd)
    lem-bd-cast (BDFailedCast bd) = BDFailedCast (lem-bd-cast bd)

  mutual
    lem-bdσ-failedcast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) → binders-disjoint-σ σ d
    lem-bdσ-failedcast BDσId = BDσId
    lem-bdσ-failedcast (BDσSubst x bd) = BDσSubst (lem-bd-failedcast x) (lem-bdσ-failedcast bd)

    lem-bd-failedcast : ∀{d1 d τ1 τ2} → binders-disjoint d1 (d ⟨ τ1 ⇒⦇-⦈⇏ τ2 ⟩) → binders-disjoint d1 d
    lem-bd-failedcast BDConst = BDConst
    lem-bd-failedcast BDVar = BDVar
    lem-bd-failedcast (BDLam bd (UBFailedCast x₁)) = BDLam (lem-bd-failedcast bd) x₁
    lem-bd-failedcast (BDHole x) = BDHole (lem-bdσ-failedcast x)
    lem-bd-failedcast (BDNEHole x bd) = BDNEHole (lem-bdσ-failedcast x) (lem-bd-failedcast bd)
    lem-bd-failedcast (BDAp bd bd₁) = BDAp (lem-bd-failedcast bd) (lem-bd-failedcast bd₁)
    lem-bd-failedcast (BDCast bd) = BDCast (lem-bd-failedcast bd)
    lem-bd-failedcast (BDFailedCast bd) = BDFailedCast (lem-bd-failedcast bd)

  mutual
    lem-bdσ-into-cast : ∀{σ d τ1 τ2} → binders-disjoint-σ σ d → binders-disjoint-σ σ (d ⟨ τ1 ⇒ τ2 ⟩)
    lem-bdσ-into-cast BDσId = BDσId
    lem-bdσ-into-cast (BDσSubst x bd) = BDσSubst (lem-bd-into-cast x) (lem-bdσ-into-cast bd)

    lem-bd-into-cast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint d1 (d2 ⟨ τ1 ⇒ τ2 ⟩)
    lem-bd-into-cast BDConst = BDConst
    lem-bd-into-cast BDVar = BDVar
    lem-bd-into-cast (BDLam bd x₁) = BDLam (lem-bd-into-cast bd) (UBCast x₁)
    lem-bd-into-cast (BDHole x) = BDHole (lem-bdσ-into-cast x)
    lem-bd-into-cast (BDNEHole x bd) = BDNEHole (lem-bdσ-into-cast x) (lem-bd-into-cast bd)
    lem-bd-into-cast (BDAp bd bd₁) = BDAp (lem-bd-into-cast bd) (lem-bd-into-cast bd₁)
    lem-bd-into-cast (BDCast bd) = BDCast (lem-bd-into-cast bd)
    lem-bd-into-cast (BDFailedCast bd) = BDFailedCast (lem-bd-into-cast bd)


module _ where

open import Agda.Primitive.Cubical

postulate
  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ

{-# BUILTIN PATHP        PathP     #-}


module Int where

open import Agda.Builtin.FromNat
open import Agda.Builtin.FromNeg
open import Data.Char hiding (fromNat)
open import Data.Integer hiding (_≤_; suc)
open import Data.Integer.Literals
open import Data.List
open import Data.Nat hiding (_≤_)
open import Data.String
open import Data.Unit hiding (_≤_)
open import Function
open import Show

postulate
  Int : Set
  primShow : Int → List Char
  primFromInteger : ℤ → Int
  primToInteger : Int → ℤ
  primMinBound : Int
  primMaxBound : Int

{-# COMPILE GHC Int = type Int #-}
{-# COMPILE GHC primShow = show #-}
{-# COMPILE GHC primFromInteger = fromInteger #-}
{-# COMPILE GHC primToInteger = toInteger #-}
{-# COMPILE GHC primMinBound = minBound #-}
{-# COMPILE GHC primMaxBound = maxBound #-}

instance ShowInt : Show Int
ShowInt = fromHaskell primShow

instance Numberℤ : Number ℤ
Numberℤ = number

-- Its values can be automatically derived as instance arguments, but
-- is otherwise identical to the standard library version
data _ℕ≤_ : ℕ → ℕ → Set where
  instance z≤n : ∀ {n}                 → zero  ℕ≤ n
  instance s≤s : ∀ {m n} {{m≤n : m ℕ≤ n}} → suc m ℕ≤ suc n

-- Its values can be automatically derived as instance arguments, but
-- is otherwise identical to the standard library version
data _≤_ : ℤ → ℤ → Set where
  instance -≤- : {m n : ℕ} → {{n≤m : n ℕ≤ m}} → -[1+ m ] ≤ -[1+ n ]
  instance -≤+ : {m n : ℕ} → (-[1+ m ]) ≤ (+ n)
  instance +≤+ : {m n : ℕ} → {{m≤n : m ℕ≤ n}} → (+ m) ≤ (+ n)

-- Use a literal for the bound so that Agda can automatically check
-- the constraints for fromNat and fromNeg. Value taken from
-- https://hackage.haskell.org/package/base-4.12.0.0/docs/Prelude.html#t:Int
maxBound : ℤ
maxBound = 536870911

-- Use the actual bound in compiled code
{-# COMPILE GHC maxBound = toInteger (maxBound :: Int) #-}

instance NumberInt : Number Int
NumberInt = record { Constraint = Constraint ; fromNat = fromNatInt }
  where
    Constraint : ℕ → Set
    Constraint n = (+ n) ≤ maxBound

    fromNatInt : ∀ n → {{_ : Constraint n}} → Int
    fromNatInt n = primFromInteger (+ n)


{-# OPTIONS --cubical #-}

open import Agda.Builtin.Cubical.Path

data I : Set where
  zero one : I
  zero≡one : zero ≡ one


module _ where

module A where

  infix 0 c

  syntax c x = + x

  data D₁ : Set where
    b : D₁
    c : D₁ → D₁

module B where

  infix 1 c

  syntax c x = + x

  data D₂ : Set where
    c : A.D₁ → D₂

open A
open B

test₁ : D₂
test₁ = + + + b

test₂ : D₂ → D₁
test₂ (+ + x) = x
test₂ (+ b)   = + + + b


module Equiv where

  import Prelude
  import Eq

  open Prelude
  open Eq

  data Equiv (a : Set) : Set1 where
    equiv :  (_==_  : a -> a -> Set)
          -> (refl  : (x : a) -> x == x)
          -> (sym   : (x y : a) -> x == y -> y == x)
          -> (trans : (x y z : a) -> x == y -> y == z -> x == z)
          -> Equiv a

  rel : {a : Set} -> Equiv a -> (a -> a -> Set)
  rel (equiv _==_ _ _ _) = _==_

  data Decidable {a : Set} (eq : a -> a -> Set) : Set where
    dec : ((x y : a) -> Either (eq x y) (Not (eq x y))) -> Decidable eq

  private
    boolFunctionsDecidable'
      : {a : Set}
      -> (f : a -> a -> Bool)
      -> (x y : a)
      -> (b : Bool)
      -> (b =^= f x y)
      -> Either (T' f x y) (Not (T' f x y))
    boolFunctionsDecidable' eq x y True  p = left (leibnizSubst p T unit)
    boolFunctionsDecidable' eq x y False p =
      right (not (\xy -> leibnizSubst (leibnizSym p) T xy))

  boolFunctionsDecidable
    : {a : Set} -> (f : a -> a -> Bool) -> Decidable (T' f)
  boolFunctionsDecidable f =
    dec (\x y -> boolFunctionsDecidable' f x y (f x y) leibnizRefl)

  data DecidableEquiv (a : Set) : Set1 where
    decEquiv : (eq : Equiv a) -> Decidable (rel eq) -> DecidableEquiv a

  rel' :  {a : Set} -> (eq : DecidableEquiv a) -> (a -> a -> Set)
  rel' (decEquiv eq _) = rel eq

  refl : {a : Set} -> (eq : DecidableEquiv a) -> {x : a} -> rel' eq x x
  refl (decEquiv (equiv _ refl' _ _) _) = refl' _

  sym : {a : Set} -> (eq : DecidableEquiv a) -> {x y : a}
      -> rel' eq x y -> rel' eq y x
  sym (decEquiv (equiv _ _ sym' _) _) = sym' _ _

  trans : {a : Set} -> (eq : DecidableEquiv a) -> {x y z : a}
      -> rel' eq x y -> rel' eq y z -> rel' eq x z
  trans (decEquiv (equiv _ _ _ trans') _) = trans' _ _ _

  decRel :  {a : Set} -> (eq : DecidableEquiv a) -> (x y : a)
         -> Either (rel' eq x y) (Not (rel' eq x y))
  decRel (decEquiv _ (dec f)) = f

  private

    decRelI :  {a : Set} -> (eq : a -> a -> Set) -> {x y : a}
             -> Either (eq x y) (Not (eq x y)) -> Bool
    decRelI _ (left _)  = True
    decRelI _ (right _) = False

  decRel' : {a : Set} -> DecidableEquiv a -> (a -> a -> Bool)
  decRel' eq x y = decRelI (rel' eq) (decRel eq x y)

  private
    pairEq :  {a b : Set} -> DecidableEquiv a -> DecidableEquiv b
           -> (p1 p2 : Pair a b) -> Set
    pairEq a b (pair x1 x2) (pair y1 y2) = Pair (rel' a x1 y1) (rel' b x2 y2)

    refl' :  {a b : Set} -> (da : DecidableEquiv a) -> (db : DecidableEquiv b)
          -> (x : Pair a b) -> pairEq da db x x
    refl' a b (pair x1 x2) = pair (refl a) (refl b)

    sym' :  {a b : Set} -> (da : DecidableEquiv a) -> (db : DecidableEquiv b)
         -> (x y : Pair a b) -> pairEq da db x y -> pairEq da db y x
    sym' a b (pair x1 x2) (pair y1 y2) (pair xy1 xy2) =
      pair (sym a xy1) (sym b xy2)

    trans'
      :  {a b : Set} -> (da : DecidableEquiv a) -> (db : DecidableEquiv b)
      -> (x y z : Pair a b)
      -> pairEq da db x y -> pairEq da db y z -> pairEq da db x z
    trans' a b (pair x1 x2) (pair y1 y2)
           (pair z1 z2) (pair xy1 xy2) (pair yz1 yz2) =
      pair (trans a xy1 yz1) (trans b xy2 yz2)

    dec'' :  {a b : Set} -> {da : DecidableEquiv a} -> {db : DecidableEquiv b}
          -> {x1 y1 : a} -> {x2 y2 : b}
          -> Either (rel' da x1 y1) (Not (rel' da x1 y1))
          -> Either (rel' db x2 y2) (Not (rel' db x2 y2))
          -> Either (pairEq da db (pair x1 x2) (pair y1 y2))
                    (Not (pairEq da db (pair x1 x2) (pair y1 y2)))
    dec'' (left xy1)         (left xy2)         = left (pair xy1 xy2)
    dec'' _                  (right (not nxy2)) =
      right (not (\xy -> nxy2 (snd xy)))
    dec'' (right (not nxy1)) (left _)           =
      right (not (\xy -> nxy1 (fst xy)))

    dec' :  {a b : Set} -> (da : DecidableEquiv a) -> (db : DecidableEquiv b)
         -> (x y : Pair a b) -> Either (pairEq da db x y) (Not (pairEq da db x y))
    dec' a b (pair x1 x2) (pair y1 y2) =
      dec'' {_} {_} {a} {b} (decRel a x1 y1) (decRel b x2 y2)

  pairEquiv
    :  {a b : Set} -> DecidableEquiv a -> DecidableEquiv b
    -> DecidableEquiv (Pair a b)
  pairEquiv a b = decEquiv (equiv (pairEq a b)
                                  (refl' a b) (sym' a b) (trans' a b))
                           (dec (dec' a b))


-- Andreas, 2014-11-02

record U : Set where
  coinductive
  constructor inn
  field       out : U

f : U → U
f u = {!u!}


module _ {A : Set} where

postulate B : Set

postulate
  H : {A : Set} → Set

test-H : Set
test-H = H {A = B}

record R {A : Set} : Set where
  constructor rc
  field f : A

test-R : Set
test-R = R {A = B}

test-f : ∀ B → R {A = B} → B
test-f B = R.f {A = B}

module N {A : Set} where

module test-N = N {A = B}


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

open import Base

module Spaces.LoopSpaceDecidableWedgeCircles {i} (A : Set i) (eq : has-dec-eq A)
  where

open import Spaces.WedgeCircles A renaming (wedge-circles to WA; base to baseWA)
open import Algebra.FreeGroup A renaming (freegroup to FA)
open import Algebra.FreeGroupProps A
open import Algebra.FreeGroupAsReducedWords A eq
open import Spaces.FlatteningLoopSpaceWedgeCircles A (dec-eq-is-set eq)

-- We can now prove that [tot-cover] is contractible using [CA-rec]
-- (because [CA-rec] means that [tot-cover] is the Cayley graph of FA)
P-CA-contr : (x : tot-cover) → Set _
P-CA-contr x = x ≡ CA-z e

-- We first prove it on points coming from reduced words
CA-contr-base-reduced-word : (w : reduced-word)
  → P-CA-contr (CA-z (reduced-to-freegroup w))
CA-contr-base-reduced-word (ε , red) = refl
CA-contr-base-reduced-word ((x ∷ w) , red) =
  ! (CA-e x _)
  ∘ CA-contr-base-reduced-word (w , tail-is-reduced x w red)
CA-contr-base-reduced-word ((x ′∷ w) , red) =
  (CA-e x _ ∘ ap CA-z (right-inverse-· x _))
  ∘ CA-contr-base-reduced-word (w , tail'-is-reduced x w red)

-- Then on every point
CA-contr-base : (u : FA) → P-CA-contr (CA-z u)
CA-contr-base u =
  ap CA-z (! (inv₂ u)) ∘ (CA-contr-base-reduced-word (freegroup-to-reduced u))

-- Now we prove that it’s true on paths, coming from reduced words
abstract
  CA-contr-loop-reduced-word : (t : A) (w : reduced-word) →
    (ap CA-z (reduced-to-freegroup-mul-reduce t w)
    ∘ ! (CA-e t (reduced-to-freegroup w)))
    ∘ (CA-contr-base-reduced-word w)
    ≡ CA-contr-base-reduced-word (mul-reduce t w)
  CA-contr-loop-reduced-word t (ε , red) = refl
  CA-contr-loop-reduced-word t ((x ∷ w) , red) = refl
  CA-contr-loop-reduced-word t ((x ′∷ w) , red) with (eq t x)
  CA-contr-loop-reduced-word x ((.x ′∷ w) , red) | inl refl =
    -- With the notations below, what we have to prove
    -- is [ (ap CA-z (! p) ∘ ! q) ∘ ((q ∘ ap CA-z p) ∘ r) ≡ r ]
    concat-assoc (ap CA-z (! p)) _ _
    ∘ (ap (λ t₁ → t₁ ∘ (! q ∘ ((q ∘ ap CA-z p) ∘ r))) (ap-opposite CA-z p)
    ∘ move!-right-on-left (ap CA-z p) (! q ∘ ((q ∘ ap CA-z p) ∘ r)) r
      (move!-right-on-left q ((q ∘ ap CA-z p) ∘ r) (ap CA-z p ∘ r)
      (concat-assoc q _ _))) where
    fw : FA
    fw = reduced-to-freegroup (w , tail'-is-reduced x w red)

    p : x · (x ⁻¹· fw) ≡ fw
    p = right-inverse-· x fw

    q : CA-z (x ⁻¹· fw) ≡ CA-z (x · (x ⁻¹· fw))
    q = CA-e x (x ⁻¹· fw)

    r : CA-z fw ≡ CA-z e
    r = CA-contr-base-reduced-word (w , tail'-is-reduced x w red)
  CA-contr-loop-reduced-word t ((x ′∷ w) , red) | inr different = refl

-- And finally for every path
CA-contr-loop : (t : A) (u : FA)
  → transport P-CA-contr (CA-e t u) (CA-contr-base u) ≡ (CA-contr-base (t · u))
CA-contr-loop t u =
  -- Idea:
  --
  -- We need to prove
  --   [p u ∘ (ap CA-z (q u) ∘ for-red u)
  --    ≡ ap CA-z (q (t · u)) ∘ for-red (t · u)]
  --
  -- [CA-contr-loop-reduced-word] gives
  -- that [(ap CA-z comp ∘ p (k u)) ∘ for-red u ≡ for-red (t · u)]

  trans-id≡cst (CA-e t u) (CA-contr-base u)
  ∘ (! (concat-assoc (p u) (ap CA-z (q u)) (for-red u))
  ∘ (whisker-right (for-red u) {q = p u ∘ ap CA-z (q u)}
       {r = ap CA-z (q (t · u)) ∘ (ap CA-z comp ∘ p (k u))}
    (! (homotopy-naturality f g p (q u))
    ∘ (whisker-right (p (k u)) {q = ap f (q u)}
         {r = ap CA-z (q (t · u)) ∘ ap CA-z comp}
      (ap-compose CA-z (λ u₁ → t · u₁) (q u)
      ∘ (ap (ap CA-z) (π₁ (freegroup-is-set _ _ _ _))
      ∘ ap-concat CA-z (q (t · u)) comp))
    ∘ concat-assoc (ap CA-z (q (t · u))) (ap CA-z comp) (p (k u))))
  ∘ (concat-assoc (ap CA-z (q (t · u))) (ap CA-z comp ∘ p (k u))
       (for-red u)
       ∘ whisker-left (ap CA-z (q (t · u)))
           auie))) where
  f : FA → tot-cover
  f u = CA-z (t · u)

  g : FA → tot-cover
  g u = CA-z u

  p : (u : FA) → f u ≡ g u
  p u = ! (CA-e t u)

  k : FA → FA
  k u = reduced-to-freegroup (freegroup-to-reduced u)

  q : (u : FA) → u ≡ k u
  q u = ! (inv₂ u)

  for-red : (u : FA) → CA-z (k u) ≡ CA-z e
  for-red u = CA-contr-base-reduced-word (freegroup-to-reduced u)

  comp : k (t · u) ≡ t · (k u)
  comp = reduced-to-freegroup-mul-reduce t (freegroup-to-reduced u)

  auie : (ap CA-z comp ∘ p (k u)) ∘ for-red u ≡ for-red (t · u)
  auie = CA-contr-loop-reduced-word t (freegroup-to-reduced u)

-- Hence, [CA] is contractible
CA-contr : (x : tot-cover) → P-CA-contr x
CA-contr = equivCA.CA-rec P-CA-contr CA-contr-base CA-contr-loop

abstract
  tot-cover-is-contr : is-contr tot-cover
  tot-cover-is-contr = (CA-z e , λ x → CA-contr x)

-- We define now a fiberwise map between the two fibrations [path-fib]
-- and [universal-cover]
fiberwise-map : (x : WA) → (path-fib x → universal-cover x)
fiberwise-map x q = transport universal-cover (! q) e

-- This induces an equivalence on the total spaces, because both total spaces
-- are contractible
total-equiv : is-equiv (total-map fiberwise-map)
total-equiv = contr-to-contr-is-equiv (total-map fiberwise-map)
                                      tot-path-fib-is-contr
                                      tot-cover-is-contr

-- Hence an equivalence fiberwise
fiberwise-map-is-equiv : (x : WA) → is-equiv (fiberwise-map x)
fiberwise-map-is-equiv x = fiberwise-is-equiv fiberwise-map total-equiv x

-- We can then conclude that the based loop space of the wedge of circles on [A]
-- is equivalent to the free group on [A], where [A] is any discrete set (i.e.
-- with decidable equality)
ΩWA≃FA : (baseWA ≡ baseWA) ≃ FA
ΩWA≃FA = (fiberwise-map baseWA , fiberwise-map-is-equiv baseWA)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Strings
------------------------------------------------------------------------

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

module Data.String where

open import Data.Vec as Vec using (Vec)
open import Data.Char as Char using (Char)

------------------------------------------------------------------------
-- Re-export contents of base, and decidability of equality

open import Data.String.Base public
open import Data.String.Properties using (_≟_; _==_) public

------------------------------------------------------------------------
-- Operations

toVec : (s : String) → Vec Char (length s)
toVec s = Vec.fromList (toList s)


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

open import Agda.Primitive
open import Prelude
import GSeTT.Syntax

{- Syntax for a globular type theory, with arbitrary term constructors -}
module Globular-TT.Syntax {l} (index : Set l) where

  data Pre-Ty : Set (lsuc l)
  data Pre-Tm : Set (lsuc l)
  data Pre-Sub : Set (lsuc l)
  data Pre-Ctx : Set (lsuc l)

  data Pre-Ty where
    ∗ : Pre-Ty
    ⇒ : Pre-Ty → Pre-Tm → Pre-Tm → Pre-Ty

  data Pre-Tm where
    Var : ℕ → Pre-Tm
    Tm-constructor : ∀ (i : index) → Pre-Sub → Pre-Tm

  data Pre-Sub where
    <> : Pre-Sub
    <_,_↦_> : Pre-Sub → ℕ → Pre-Tm → Pre-Sub

  data Pre-Ctx where
    ⊘ : Pre-Ctx
    _∙_#_ : Pre-Ctx → ℕ → Pre-Ty → Pre-Ctx

  C-length : Pre-Ctx → ℕ
  C-length ⊘ = O
  C-length (Γ ∙ _ # _) = S (C-length Γ)

  -- Equality elimination
  ⇒= : ∀ {A B t t' u u'} → A == B → t == t' → u == u' → ⇒ A t u == ⇒ B t' u'
  ⇒= idp idp idp = idp

  =⇒ : ∀ {A B t t' u u'} → ⇒ A t u == ⇒ B t' u' → ((A == B) × (t == t')) × (u == u')
  =⇒ idp = (idp , idp) , idp

  Var= : ∀ {v w} → v == w → Var v == Var w
  Var= idp = idp

  Tm-constructor= : ∀ {i j γ δ} → i == j → γ == δ → (Tm-constructor i γ) == (Tm-constructor j δ)
  Tm-constructor= idp idp = idp

  =Tm-constructor : ∀ {i j γ δ} → (Tm-constructor i γ) == (Tm-constructor j δ) → i == j × γ == δ
  =Tm-constructor idp = idp , idp

  <,>= : ∀ {γ δ x y t u} → γ == δ → x == y → t == u → < γ , x ↦ t > == < δ , y ↦ u >
  <,>= idp idp idp = idp

  =<,> : ∀ {γ δ x y t u} → < γ , x ↦ t > == < δ , y ↦ u > → ((γ == δ) × (x == y)) × (t == u)
  =<,> idp = (idp , idp) , idp

  ∙= : ∀ {Γ Δ x y A B} → Γ == Δ → x == y → A == B → (Γ ∙ x # A) == (Δ ∙ y # B)
  ∙= idp idp idp = idp

  {- Action of substitutions on types and terms and substitutions on a syntactical level -}
  _[_]Pre-Ty : Pre-Ty → Pre-Sub → Pre-Ty
  _[_]Pre-Tm : Pre-Tm → Pre-Sub → Pre-Tm
  _∘_ : Pre-Sub → Pre-Sub → Pre-Sub

  ∗ [ σ ]Pre-Ty = ∗
  ⇒ A t u [ σ ]Pre-Ty = ⇒ (A [ σ ]Pre-Ty) (t [ σ ]Pre-Tm) (u [ σ ]Pre-Tm)
  Var x [ <> ]Pre-Tm = Var x
  Var x [ < σ , v ↦ t > ]Pre-Tm = if x ≡ v then t else ((Var x) [ σ ]Pre-Tm)
  Tm-constructor i γ [ σ ]Pre-Tm = Tm-constructor i (γ ∘ σ)
  <> ∘ γ = <>
  < γ , x ↦ t > ∘ δ = < γ ∘ δ , x ↦ t [ δ ]Pre-Tm >

  _#_∈_ : ℕ → Pre-Ty → Pre-Ctx → Set (lsuc l)
  _ # _ ∈ ⊘ = ⊥
  x # A ∈ (Γ ∙ y # B) = (x # A ∈ Γ) + ((x == y) × (A == B))

  {- dimension of types -}
  dim : Pre-Ty → ℕ
  dim ∗ = O
  dim (⇒ A t u) = S (dim A)

  dim[] : ∀ (A : Pre-Ty) (γ : Pre-Sub) → dim (A [ γ ]Pre-Ty) == dim A
  dim[] ∗ γ = idp
  dim[] (⇒ A x x₁) γ = S= (dim[] A γ)

  dimC : Pre-Ctx → ℕ
  dimC ⊘ = O
  dimC (Γ ∙ x # A) = max (dimC Γ) (dim A)

  {- Identity and canonical projection -}
  Pre-id : ∀ (Γ : Pre-Ctx) → Pre-Sub
  Pre-id ⊘ = <>
  Pre-id (Γ ∙ x # A) = < Pre-id Γ , x ↦ Var x >

  Pre-π : ∀ (Γ : Pre-Ctx) (x : ℕ) (A : Pre-Ty) → Pre-Sub
  Pre-π Γ x A = Pre-id Γ

  {- Translation of GSeTT to a globular-TT -}
  GPre-Ctx : GSeTT.Syntax.Pre-Ctx → Pre-Ctx
  GPre-Ty : GSeTT.Syntax.Pre-Ty → Pre-Ty
  GPre-Tm : GSeTT.Syntax.Pre-Tm → Pre-Tm

  GPre-Ctx nil = ⊘
  GPre-Ctx (Γ :: (x , A)) = (GPre-Ctx Γ) ∙ x # (GPre-Ty A)
  GPre-Ty GSeTT.Syntax.∗ = ∗
  GPre-Ty (GSeTT.Syntax.⇒ A t u) = ⇒ (GPre-Ty A) (GPre-Tm t) (GPre-Tm u)
  GPre-Tm (GSeTT.Syntax.Var x) = Var x

  {- Depth of a term -}
  depth : Pre-Tm → ℕ
  depthS : Pre-Sub → ℕ

  depth (Var x) = O
  depth (Tm-constructor i γ) = S (depthS γ)

  depthS <> = O
  depthS < γ , x ↦ t > = max (depthS γ) (depth t)


module Selective.Examples.Fibonacci where

open import Selective.ActorMonad
open import Prelude

open import Debug
open import Data.Nat.Show using (show)

data End : Set where
  END : End

ℕ-message : MessageType
ℕ-message = [ ValueType ℕ ]ˡ

End-message : MessageType
End-message = [ ValueType End ]ˡ

Client-to-Server : InboxShape
Client-to-Server = ℕ-message ∷ [ End-message ]ˡ

Server-to-Client : InboxShape
Server-to-Client = [ ℕ-message ]ˡ

ServerInterface : InboxShape
ServerInterface = [ ReferenceType Server-to-Client ]ˡ ∷ Client-to-Server

ClientInterface : InboxShape
ClientInterface = [ ReferenceType Client-to-Server ]ˡ ∷ Server-to-Client

ServerRefs : TypingContext
ServerRefs = [ Server-to-Client ]ˡ

constServerRefs : {A : Set₁} → (A → TypingContext)
constServerRefs _ = ServerRefs

data ServerAction : Set₁ where
  Next : ℕ → ServerAction
  Done : ServerAction

server : ∀ {i} → ActorM i ServerInterface ⊤₁ [] constServerRefs
server = wait-for-client ∞>> run-fibonacci 1
  where
    wait-for-client = selective-receive (λ {
      (Msg Z _) → true
      ; (Msg (S _) _) → false }) >>= λ {
        record { msg = (Msg Z _) } → return tt
        ; record { msg = (Msg (S _) _) ; msg-ok = () } }
    wait-for-value : ∀ {i} → ∞ActorM i ServerInterface ServerAction ServerRefs constServerRefs
    wait-for-value = selective-receive (λ {
      (Msg Z _) → false
      ; (Msg (S Z) _) → true
      ; (Msg (S (S Z)) _) → true
      ; (Msg (S (S (S ()))) x₁) }) >>= λ {
        record { msg = (Msg Z _) ; msg-ok = () }
        ; record { msg = (Msg (S Z) (n ∷ [])) } → return₁ (Next n)
        ; record { msg = (Msg (S (S Z)) _) } → return₁ Done
        ; record { msg = (Msg (S (S (S ()))) _) }
        }
    run-fibonacci : ℕ → ∀ {i} → ∞ActorM i ServerInterface ⊤₁ ServerRefs constServerRefs
    run-fibonacci x .force = begin do
      Next n ← wait-for-value
        where Done → return _
      let next = x + n
      Z ![t: Z ] [ lift next ]ᵃ
      (run-fibonacci next)

ClientRefs : TypingContext
ClientRefs = [ Client-to-Server ]ˡ

constClientRefs : {A : Set₁} → (A → TypingContext)
constClientRefs _ = ClientRefs

client : ∀ {i} → ActorM i ClientInterface ⊤₁ [] constClientRefs
client = wait-for-server ∞>> run 10 0
  where
    wait-for-server : ∀ {i} → ∞ActorM i ClientInterface ⊤₁ [] constClientRefs
    wait-for-server = selective-receive (λ {
      (Msg Z _) → true
      ; (Msg (S _) _) → false }) >>= λ {
        record { msg = (Msg Z _) ; msg-ok = msg-ok } → return tt
        ; record { msg = (Msg (S _) _) ; msg-ok = () }
        }
    wait-for-value : ∀ {i} → ∞ActorM i ClientInterface (Lift (lsuc lzero) ℕ) ClientRefs constClientRefs
    wait-for-value = do
      record { msg = Msg (S Z) (n ∷ []) } ← selective-receive (λ {
        (Msg Z _) → false
        ; (Msg (S Z) _) → true
        ; (Msg (S (S ())) _) })
        where
          record { msg = (Msg Z _) ; msg-ok = () }
          record { msg = (Msg (S (S ())) x₁) }
      return n
    run : ℕ → ℕ → ∀ {i} → ∞ActorM i ClientInterface ⊤₁ ClientRefs constClientRefs
    run zero x = Z ![t: S Z ] [ lift END ]ᵃ
    run (suc todo) x .force = begin do
      (Z ![t: Z ] ((lift x) ∷ []))
      (lift n) ← wait-for-value
      let next = x + n
      run (debug (show next) todo) next

spawner : ∀ {i} → ∞ActorM i [] ⊤₁ [] (λ _ → ClientInterface ∷ [ ServerInterface ]ˡ)
spawner = do
  spawn server
  spawn client
  S Z ![t: Z ] [ [ Z ]>: ⊆-suc ⊆-refl ]ᵃ
  Z ![t: Z ] [ [ S Z ]>: ⊆-suc ⊆-refl ]ᵃ


open import Nat
open import Prelude
open import core
open import contexts
open import lemmas-disjointness
open import exchange
open import lemmas-freshG

-- this module contains all the proofs of different weakening structural
-- properties that we use for the hypothetical judgements
module weakening where
  mutual
    weaken-subst-Δ : ∀{Δ1 Δ2 Γ σ Γ'} → Δ1 ## Δ2
                                     → Δ1 , Γ ⊢ σ :s: Γ'
                                     → (Δ1 ∪ Δ2) , Γ ⊢ σ :s: Γ'
    weaken-subst-Δ disj (STAId x) = STAId x
    weaken-subst-Δ disj (STASubst subst x) = STASubst (weaken-subst-Δ disj subst) (weaken-ta-Δ1 disj x)

    weaken-ta-Δ1 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2
                                  → Δ1 , Γ ⊢ d :: τ
                                  → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
    weaken-ta-Δ1 disj TAConst = TAConst
    weaken-ta-Δ1 disj (TAVar x₁) = TAVar x₁
    weaken-ta-Δ1 disj (TALam x₁ wt) = TALam x₁ (weaken-ta-Δ1 disj wt)
    weaken-ta-Δ1 disj (TAAp wt wt₁) = TAAp (weaken-ta-Δ1 disj wt) (weaken-ta-Δ1 disj wt₁)
    weaken-ta-Δ1 {Δ1} {Δ2} {Γ} disj (TAEHole {u = u} {Γ' = Γ'} x x₁) = TAEHole (x∈∪l Δ1 Δ2 u _ x ) (weaken-subst-Δ disj x₁)
    weaken-ta-Δ1 {Δ1} {Δ2} {Γ} disj (TANEHole {Γ' = Γ'} {u = u} x wt x₁) = TANEHole (x∈∪l Δ1 Δ2 u _ x) (weaken-ta-Δ1 disj wt) (weaken-subst-Δ disj x₁)
    weaken-ta-Δ1 disj (TACast wt x) = TACast (weaken-ta-Δ1 disj wt) x
    weaken-ta-Δ1 disj (TAFailedCast wt x x₁ x₂) = TAFailedCast (weaken-ta-Δ1 disj wt) x x₁ x₂
    weaken-ta-Δ1 disj (TAFst wt) = TAFst (weaken-ta-Δ1 disj wt)
    weaken-ta-Δ1 disj (TASnd wt) = TASnd (weaken-ta-Δ1 disj wt)
    weaken-ta-Δ1 disj (TAPair wt wt₁) = TAPair (weaken-ta-Δ1 disj wt) (weaken-ta-Δ1 disj wt₁)

  -- this is a little bit of a time saver. since ∪ is commutative on
  -- disjoint contexts, and we need that premise anyway in both positions,
  -- there's no real reason to repeat the inductive argument above
  weaken-ta-Δ2 : ∀{Δ1 Δ2 Γ d τ} → Δ1 ## Δ2
                                → Δ2 , Γ ⊢ d :: τ
                                → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
  weaken-ta-Δ2 {Δ1} {Δ2} {Γ} {d} {τ} disj D = tr (λ q → q , Γ ⊢ d :: τ) (∪comm Δ2 Δ1 (##-comm disj)) (weaken-ta-Δ1 (##-comm disj) D)

  -- note that these statements are somewhat stronger than usual. this is
  -- because we don't have implcit α-conversion. this reifies the
  -- often-silent on paper assumption that if you collide with a bound
  -- variable you can just α-convert it away and not worry.

  -- used in both cases below, so factored into a lemma to save repeated code
  lem-reassoc : {A : Set} {Γ Γ' : A ctx} {x : Nat} {τ : A} → (x # Γ') → (Γ ,, (x , τ)) ∪ Γ' == (Γ ∪ Γ') ,, (x , τ)
  lem-reassoc {A} {Γ} {Γ'} {x} {τ} apt with lem-apart-sing-disj apt
  ... | disj = (∪assoc Γ (■ (x , τ)) Γ' disj) ·
                 (ap1 (λ qq → Γ ∪ qq) (∪comm (■ (x , τ)) (Γ') disj) ·
                   ! (∪assoc Γ Γ' (■ (x , τ)) (##-comm disj)))

  -- first we prove a general form of weakening, that you can add any
  -- context Γ as long as it's fresh with respect to e
  mutual
    weaken-synth-∪ : ∀{e τ Γ Γ'} → freshΓ Γ' e → Γ ⊢ e => τ → (Γ ∪ Γ')  ⊢ e => τ
    weaken-synth-∪ frsh SConst = SConst
    weaken-synth-∪ frsh (SAsc x) = SAsc (weaken-ana-∪ (freshΓ-asc frsh) x)
    weaken-synth-∪ {Γ = Γ} {Γ' = Γ'} frsh (SVar {x = x} x₁) = SVar (x∈∪l Γ Γ' x _ x₁)
    weaken-synth-∪ frsh (SAp x wt x₁ x₂) = SAp x (weaken-synth-∪ (freshΓ-ap1 frsh) wt)
                                                      x₁
                                                      (weaken-ana-∪ (freshΓ-ap2 frsh) x₂)
    weaken-synth-∪ frsh SEHole = SEHole
    weaken-synth-∪ frsh (SNEHole x wt) = SNEHole x (weaken-synth-∪ (freshΓ-nehole frsh) wt)
    weaken-synth-∪ {Γ = Γ} {Γ' = Γ'} frsh (SLam {e = e} {τ2 = τ2} {x = x}  x₁ wt)
      with ctxindirect Γ' x
    ... | Inl qq = abort (lem-fresh-lam2 (frsh x qq))
    ... | Inr qq = SLam (apart-parts Γ Γ' x x₁ qq)
                             (tr (λ qq → qq ⊢ e => τ2) (lem-reassoc {Γ = Γ} qq)
                                                       (weaken-synth-∪ (freshΓ-lam2 frsh) wt))
    weaken-synth-∪ frsh (SFst wt x) = SFst (weaken-synth-∪ (freshΓ-fst frsh) wt) x
    weaken-synth-∪ frsh (SSnd wt x) = SSnd (weaken-synth-∪ (freshΓ-snd frsh) wt) x
    weaken-synth-∪ frsh (SPair hd wt wt₁) = SPair hd (weaken-synth-∪ (freshΓ-pair1 frsh) wt) (weaken-synth-∪ (freshΓ-pair2 frsh) wt₁)

    weaken-ana-∪ : ∀{e τ Γ Γ'} → freshΓ Γ' e →  Γ ⊢ e <= τ → (Γ ∪ Γ') ⊢ e <= τ
    weaken-ana-∪ frsh (ASubsume x x₁) = ASubsume (weaken-synth-∪ frsh x) x₁
    weaken-ana-∪ {Γ = Γ} {Γ' = Γ'} frsh (ALam {e = e} {τ2 = τ2} {x = x} x₁ x₂ wt)
      with ctxindirect Γ' x
    ... | Inl qq = abort (lem-fresh-lam1 (frsh x qq))
    ... | Inr qq = ALam (apart-parts Γ Γ' x x₁ qq)
                        x₂
                        (tr (λ qq → qq ⊢ e <= τ2) (lem-reassoc {Γ = Γ} qq)
                                                  (weaken-ana-∪ (freshΓ-lam1 frsh) wt))

  -- it follows from this that if the term is closed, you can weaken with
  -- any context that's fresh in e
  weaken-synth-closed : ∀{e τ Γ} → freshΓ Γ e → ∅ ⊢ e => τ → Γ ⊢ e => τ
  weaken-synth-closed {e} {τ} {Γ} f wt = tr (λ qq → qq ⊢ e => τ) ∅∪1 (weaken-synth-∪ f wt)

  weaken-ana-closed : ∀{e τ Γ} → freshΓ Γ e → ∅ ⊢ e <= τ → Γ ⊢ e <= τ
  weaken-ana-closed {e} {τ} {Γ} f wt = tr (λ qq → qq ⊢ e <= τ) ∅∪1 (weaken-ana-∪ f wt)

  -- the very structural forms also follow from the union weakening, since
  -- ,, is defined by ∪
  weaken-synth : ∀{ x Γ e τ τ'} → freshe x e
                                  → Γ ⊢ e => τ
                                  → (Γ ,, (x , τ')) ⊢ e => τ
  weaken-synth f wt = weaken-synth-∪ (fresh-freshΓ f) wt

  weaken-ana : ∀{x Γ e τ τ'} → freshe x e
                               → Γ ⊢ e <= τ
                               → (Γ ,, (x , τ')) ⊢ e <= τ
  weaken-ana f wt = weaken-ana-∪ (fresh-freshΓ f) wt

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     envfresh x σ →
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) )
    weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) =
      STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst))
               (weaken-ta x₁ x₃)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃)
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-extend1 Γ (flip x₁) x₄) (exchange-ta-Γ {Γ = Γ} (flip x₁) (weaken-ta x₃ wt))
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃)
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃)
    weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃
    weaken-ta (FFst frsh) (TAFst wt) = TAFst (weaken-ta frsh wt)
    weaken-ta (FSnd frsh) (TASnd wt) = TASnd (weaken-ta frsh wt)
    weaken-ta (FPair frsh frsh₁) (TAPair wt wt₁) = TAPair (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)


-- Andreas, 2012-09-13 respect irrelevance at meta-var creation
-- {-# OPTIONS -v tc.conv.irr:20 #-}
module Issue168-irrelevant where

data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

module Id .(A : Set) where
  id : Nat → Nat
  id zero     = zero
  id (suc xs) = suc (id xs)
open Id Nat

postulate
  P : Nat → Set
  lemma : ∀ n → P (id n)

foo : P zero
foo = lemma _


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Canonical model equipment for Kripke-style semantics.

module BasicIS4.Equipment.KripkeDyadicCanonical where

open import BasicIS4.Syntax.Common public

module Syntax
    (_⊢_    : Cx² Ty Ty → Ty → Set)
    (mono²⊢ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊢ A → Π′ ⊢ A)
    (up      : ∀ {A Π} → Π ⊢ (□ A) → Π ⊢ (□ □ A))
    (down    : ∀ {A Π} → Π ⊢ (□ A) → Π ⊢ A)
    (lift    : ∀ {A Γ Δ} → (Γ ⁏ Δ) ⊢ A → (□⋆ Γ ⁏ Δ) ⊢ (□ A))
  where

  -- Worlds.

  Worldᶜ : Set
  Worldᶜ = Cx² Ty Ty

  -- Intuitionistic accessibility.

  infix 3 _≤ᶜ_
  _≤ᶜ_ : Worldᶜ → Worldᶜ → Set
  _≤ᶜ_ = _⊆²_

  refl≤ᶜ : ∀ {w} → w ≤ᶜ w
  refl≤ᶜ = refl⊆²

  trans≤ᶜ : ∀ {w w′ w″} → w ≤ᶜ w′ → w′ ≤ᶜ w″ → w ≤ᶜ w″
  trans≤ᶜ = trans⊆²

  bot≤ᶜ : ∀ {w} → ∅² ≤ᶜ w
  bot≤ᶜ = bot⊆²

  -- The canonical modal accessibility, based on the T axiom.

  infix 3 _Rᶜ_
  _Rᶜ_ : Worldᶜ → Worldᶜ → Set
  w Rᶜ w′ = ∀ {A} → w ⊢ (□ A) → w′ ⊢ A

  reflRᶜ : ∀ {w} → w Rᶜ w
  reflRᶜ = down

  transRᶜ : ∀ {w w′ w″} → w Rᶜ w′ → w′ Rᶜ w″ → w Rᶜ w″
  transRᶜ ζ ζ′ = ζ′ ∘ ζ ∘ up

  botRᶜ : ∀ {w} → ∅² Rᶜ w
  botRᶜ = mono²⊢ bot≤ᶜ ∘ down

  liftRᶜ : ∀ {Γ Δ} → Γ ⁏ Δ Rᶜ □⋆ Γ ⁏ Δ
  liftRᶜ = down ∘ lift ∘ down

  -- Composition of accessibility.

  infix 3 _≤⨾Rᶜ_
  _≤⨾Rᶜ_ : Worldᶜ → Worldᶜ → Set
  _≤⨾Rᶜ_ = _≤ᶜ_ ⨾ _Rᶜ_

  infix 3 _R⨾≤ᶜ_
  _R⨾≤ᶜ_ : Worldᶜ → Worldᶜ → Set
  _R⨾≤ᶜ_ = _Rᶜ_ ⨾ _≤ᶜ_

  refl≤⨾Rᶜ : ∀ {w} → w ≤⨾Rᶜ w
  refl≤⨾Rᶜ {w} = w , (refl≤ᶜ , reflRᶜ)

  reflR⨾≤ᶜ : ∀ {w} → w R⨾≤ᶜ w
  reflR⨾≤ᶜ {w} = w , (reflRᶜ , refl≤ᶜ)

  -- Persistence condition, after Iemhoff; included by Ono.
  --
  --   w′      v′  →           v′
  --   ◌───R───●   →           ●
  --   │           →         ╱
  --   ≤  ξ,ζ      →       R
  --   │           →     ╱
  --   ●           →   ●
  --   w           →   w

  ≤⨾R→Rᶜ : ∀ {v′ w} → w ≤⨾Rᶜ v′ → w Rᶜ v′
  ≤⨾R→Rᶜ (w′ , (ξ , ζ)) = ζ ∘ mono²⊢ ξ

  -- Brilliance condition, after Iemhoff.
  --
  --           v′  →           v′
  --           ●   →           ●
  --           │   →         ╱
  --      ζ,ξ  ≤   →       R
  --           │   →     ╱
  --   ●───R───◌   →   ●
  --   w       v   →   w

  R⨾≤→Rᶜ : ∀ {w v′} → w R⨾≤ᶜ v′ → w Rᶜ v′
  R⨾≤→Rᶜ (v , (ζ , ξ)) = mono²⊢ ξ ∘ ζ

  -- Minor persistence condition, included by Božić and Došen.
  --
  --   w′      v′  →           v′
  --   ◌───R───●   →           ●
  --   │           →           │
  --   ≤  ξ,ζ      →           ≤
  --   │           →           │
  --   ●           →   ●───R───◌
  --   w           →   w       v
  --
  --                   w″  →                   w″
  --                   ●   →                   ●
  --                   │   →                   │
  --             ξ′,ζ′ ≤   →                   │
  --                   │   →                   │
  --           ●───R───◌   →                   ≤
  --           │       v′  →                   │
  --      ξ,ζ  ≤           →                   │
  --           │           →                   │
  --   ●───R───◌           →   ●───────R───────◌
  --   w       v           →   w               v″

  ≤⨾R→R⨾≤ᶜ : ∀ {v′ w} → w ≤⨾Rᶜ v′ → w R⨾≤ᶜ v′
  ≤⨾R→R⨾≤ᶜ {v′} ξ,ζ = v′ , (≤⨾R→Rᶜ ξ,ζ , refl≤ᶜ)

  transR⨾≤ᶜ : ∀ {w′ w w″} → w R⨾≤ᶜ w′ → w′ R⨾≤ᶜ w″ → w R⨾≤ᶜ w″
  transR⨾≤ᶜ {w′} (v , (ζ , ξ)) (v′ , (ζ′ , ξ′)) = let v″ , (ζ″ , ξ″) = ≤⨾R→R⨾≤ᶜ (w′ , (ξ , ζ′))
                                                  in  v″ , (transRᶜ ζ ζ″ , trans≤ᶜ ξ″ ξ′)

  ≤→Rᶜ : ∀ {v′ w} → w ≤ᶜ v′ → w Rᶜ v′
  ≤→Rᶜ {v′} ξ = ≤⨾R→Rᶜ (v′ , (ξ , reflRᶜ))

  -- Minor brilliance condition, included by Ewald and Alechina et al.
  --
  --           v′  →   w′      v′
  --           ●   →   ◌───R───●
  --           │   →   │
  --      ζ,ξ  ≤   →   ≤
  --           │   →   │
  --   ●───R───◌   →   ●
  --   w       v   →   w
  --
  --           v′      w″  →   v″              w″
  --           ◌───R───●   →   ◌───────R───────●
  --           │           →   │
  --           ≤  ξ′,ζ′    →   │
  --   v       │           →   │
  --   ◌───R───●           →   ≤
  --   │       w′          →   │
  --   ≤  ξ,ζ              →   │
  --   │                   →   │
  --   ●                   →   ●
  --   w                   →   w

  R⨾≤→≤⨾Rᶜ : ∀ {w v′} → w R⨾≤ᶜ v′ → w ≤⨾Rᶜ v′
  R⨾≤→≤⨾Rᶜ {w} ζ,ξ = w , (refl≤ᶜ , R⨾≤→Rᶜ ζ,ξ)

  trans≤⨾Rᶜ : ∀ {w′ w w″} → w ≤⨾Rᶜ w′ → w′ ≤⨾Rᶜ w″ → w ≤⨾Rᶜ w″
  trans≤⨾Rᶜ {w′} (v , (ξ , ζ)) (v′ , (ξ′ , ζ′)) = let v″ , (ξ″ , ζ″) = R⨾≤→≤⨾Rᶜ (w′ , (ζ , ξ′))
                                                  in  v″ , (trans≤ᶜ ξ ξ″ , transRᶜ ζ″ ζ′)

  ≤→Rᶜ′ : ∀ {w v′} → w ≤ᶜ v′ → w Rᶜ v′
  ≤→Rᶜ′ {w} ξ = R⨾≤→Rᶜ (w , (reflRᶜ , ξ))

  -- Infimum (greatest lower bound) of accessibility.
  --
  --   w′
  --   ●
  --   │
  --   ≤  ξ,ζ
  --   │
  --   ◌───R───●
  --   w       v

  infix 3 _≤⊓Rᶜ_
  _≤⊓Rᶜ_ : Worldᶜ → Worldᶜ → Set
  _≤⊓Rᶜ_ = _≤ᶜ_ ⊓ _Rᶜ_

  infix 3 _R⊓≤ᶜ_
  _R⊓≤ᶜ_ : Worldᶜ → Worldᶜ → Set
  _R⊓≤ᶜ_ = _Rᶜ_ ⊓ _≤ᶜ_

  ≤⊓R→R⊓≤ᶜ : ∀ {w′ v} → w′ ≤⊓Rᶜ v → v R⊓≤ᶜ w′
  ≤⊓R→R⊓≤ᶜ (w , (ξ , ζ)) = w , (ζ , ξ)

  R⊓≤→≤⊓Rᶜ : ∀ {w′ v} → v R⊓≤ᶜ w′ → w′ ≤⊓Rᶜ v
  R⊓≤→≤⊓Rᶜ (w , (ζ , ξ)) = w , (ξ , ζ)

  -- Supremum (least upper bound) of accessibility.
  --
  --   w′      v′
  --   ●───R───◌
  --           │
  --      ξ,ζ  ≤
  --           │
  --           ●
  --           v

  infix 3 _≤⊔Rᶜ_
  _≤⊔Rᶜ_ : Worldᶜ → Worldᶜ → Set
  _≤⊔Rᶜ_ = _≤ᶜ_ ⊔ _Rᶜ_

  infix 3 _R⊔≤ᶜ_
  _R⊔≤ᶜ_ : Worldᶜ → Worldᶜ → Set
  _R⊔≤ᶜ_ = _Rᶜ_ ⊔ _≤ᶜ_

  ≤⊔R→R⊔≤ᶜ : ∀ {w′ v} → w′ ≤⊔Rᶜ v → v R⊔≤ᶜ w′
  ≤⊔R→R⊔≤ᶜ (v′ , (ξ , ζ)) = v′ , (ζ , ξ)

  R⊔≤→≤⊔Rᶜ : ∀ {w′ v} → v R⊔≤ᶜ w′ → w′ ≤⊔Rᶜ v
  R⊔≤→≤⊔Rᶜ (v′ , (ζ , ξ)) = v′ , (ξ , ζ)

  -- Infimum-to-supremum condition, included by Ewald.
  --
  --   w′          →   w′      v′
  --   ●           →   ●───R───◌
  --   │           →           │
  --   ≤  ξ,ζ      →           ≤
  --   │           →           │
  --   ◌───R───●   →           ●
  --   w       v   →           v

  -- NOTE: This could be more precise.
  ≤⊓R→≤⊔Rᶜ : ∀ {v w′} → w′ ≤⊓Rᶜ v → v ≤⊔Rᶜ w′
  ≤⊓R→≤⊔Rᶜ {v} {w′} (w , (ξ , ζ)) =
    (w′ ⧺² v) , (weak⊆²⧺₂ , mono²⊢ (weak⊆²⧺₁ v) ∘ down)

  -- Supremum-to-infimum condition.
  --
  --   w′      v′  →   w′
  --   ●───R───◌   →   ●
  --           │   →   │
  --      ξ,ζ  ≤   →   ≤
  --           │   →   │
  --           ●   →   ◌───R───●
  --           v   →   w       v

  -- NOTE: This could be more precise.
  ≤⊔R→≤⊓Rᶜ : ∀ {w′ v} → v ≤⊔Rᶜ w′ → w′ ≤⊓Rᶜ v
  ≤⊔R→≤⊓Rᶜ (v′ , (ξ , ζ)) = ∅² , (bot≤ᶜ , botRᶜ)


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; subst₂; cong)
open import Data.Nat.Base
open import Data.Fin hiding (_+_; #_)
open import Data.Product using (∃; _×_; _,_; ∃-syntax)

open import DeBruijn
open import Substitution using (rename-subst-commute; subst-commute)
open import Beta

infix 3 _⇉_

data _⇉_ : ∀ {n} → Term n → Term n → Set where

  ⇉-c : ∀ {n} {x : Fin n}
      ---------
    → # x ⇉ # x

  ⇉-ƛ : ∀ {n} {M M′ : Term (suc n)}
    → M ⇉ M′
      ----------
    → ƛ M ⇉ ƛ M′

  ⇉-ξ : ∀ {n} {M M′ N N′ : Term n}
    → M ⇉ M′
    → N ⇉ N′
      ---------------
    → M · N ⇉ M′ · N′

  ⇉-β : ∀ {n} {M M′ : Term (suc n)} {N N′ : Term n}
    → M ⇉ M′
    → N ⇉ N′
      ---------------------
    → (ƛ M) · N ⇉ M′ [ N′ ]

par-subst : ∀ {n m} → Subst n m → Subst n m → Set
par-subst σ σ′ = ∀ {x} → σ x ⇉ σ′ x

par-rename : ∀ {n m} {ρ : Rename n m} {M M′ : Term n}
  → M ⇉ M′
    ------------------------
  → rename ρ M ⇉ rename ρ M′
par-rename ⇉-c         = ⇉-c
par-rename (⇉-ƛ p)     = ⇉-ƛ (par-rename p)
par-rename (⇉-ξ p₁ p₂) = ⇉-ξ (par-rename p₁) (par-rename p₂)
par-rename {n}{m}{ρ} (⇉-β {n}{N}{N′}{M}{M′} p₁ p₂)
    with ⇉-β (par-rename {ρ = ext ρ} p₁) (par-rename {ρ = ρ} p₂)
... | G rewrite rename-subst-commute {n}{m}{N′}{M′}{ρ} = G

par-subst-exts : ∀ {n m} {σ σ′ : Subst n m}
  → par-subst σ σ′
    ---------------------------
  → par-subst (exts σ) (exts σ′)
par-subst-exts s {x = zero} = ⇉-c
par-subst-exts s {x = suc x} = par-rename s

subst-par : ∀ {n m} {σ σ′ : Subst n m} {M M′ : Term n}
  → par-subst σ σ′
  → M ⇉ M′
    ----------------------
  → subst σ M ⇉ subst σ′ M′
subst-par {M = # x} s ⇉-c = s
subst-par {n}{m}{σ}{σ′} {ƛ N} s (⇉-ƛ p) =
  ⇉-ƛ (subst-par {σ = exts σ}{σ′ = exts σ′}
         (λ {x} → par-subst-exts s {x = x}) p)
subst-par {M = L · M} s (⇉-ξ p₁ p₂) =
  ⇉-ξ (subst-par s p₁) (subst-par s p₂)
subst-par {n}{m}{σ}{σ′} {(ƛ N) · M} s (⇉-β {M′ = M′}{N′ = N′} p₁ p₂)
    with ⇉-β (subst-par {σ = exts σ}{σ′ = exts σ′}{M = N}
                        (λ {x} → par-subst-exts s {x = x}) p₁)
             (subst-par {σ = σ} s p₂)
... | G rewrite subst-commute {N = M′}{M = N′}{σ = σ′} = G

par-subst-zero : ∀ {n} {M M′ : Term n}
  → M ⇉ M′
    ----------------------------------------
  → par-subst (subst-zero M) (subst-zero M′)
par-subst-zero M⇉M′ {zero} = M⇉M′
par-subst-zero M⇉M′ {suc x} = ⇉-c

sub-par : ∀ {n} {M M′ : Term (suc n)} {N N′ : Term n}
  → M ⇉ M′
  → N ⇉ N′
    -------------------
  → M [ N ] ⇉ M′ [ N′ ]
sub-par M⇉M′ N⇉N′ = subst-par (par-subst-zero N⇉N′) M⇉M′

par-refl : ∀ {n} {M : Term n}
    -----
  → M ⇉ M
par-refl {M = # x}   = ⇉-c
par-refl {M = ƛ N}   = ⇉-ƛ par-refl
par-refl {M = L · M} = ⇉-ξ par-refl par-refl

beta-par : ∀ {n} {M N : Term n}
  → M —→ N
    ------
  → M ⇉ N
beta-par {M = L · M} (—→-ξₗ r) = ⇉-ξ (beta-par {M = L} r) par-refl
beta-par {M = L · M} (—→-ξᵣ r) = ⇉-ξ par-refl (beta-par {M = M} r)
beta-par {M = ƛ N} (—→-ƛ r) = ⇉-ƛ (beta-par r)
beta-par {M = (ƛ N) · M} —→-β = ⇉-β par-refl par-refl

par-betas : ∀ {n} {M N : Term n}
  → M ⇉ N
    ------
  → M —↠ N
par-betas {M = # _} (⇉-c {x = x}) = # x ∎
par-betas {M = ƛ M} (⇉-ƛ p) = —↠-cong-ƛ (par-betas p)
par-betas {M = M · N} (⇉-ξ p₁ p₂) = —↠-cong (par-betas p₁) (par-betas p₂)
par-betas {M = (ƛ M) · N} (⇉-β {M′ = M′}{N′ = N′} p₁ p₂) =
  let a : (ƛ M) · N —↠ (ƛ M′) · N
      a = —↠-congₗ (—↠-cong-ƛ (par-betas p₁))
      b : (ƛ M′) · N —↠ (ƛ M′) · N′
      b = —↠-congᵣ (par-betas p₂)
      c = (ƛ M′) · N′ —→⟨ —→-β ⟩ M′ [ N′ ] ∎ in
  —↠-trans (—↠-trans a b) c

infix  3 _⇉*_
infixr 3 _⇉⟨_⟩_
infix  4 _∎

data _⇉*_ : ∀ {n} → Term n → Term n → Set where

  _∎ : ∀ {n} (M : Term n)
      ------
    → M ⇉* M

  _⇉⟨_⟩_ : ∀ {n} {L N : Term n} (M : Term n)
    → M ⇉  L
    → L ⇉* N
      ------
    → M ⇉* N

betas-pars : ∀ {n} {M N : Term n}
  → M —↠ N
    ------
  → M ⇉* N
betas-pars (M ∎) = M ∎
betas-pars (M —→⟨ b ⟩ bs) = M ⇉⟨ beta-par b ⟩ betas-pars bs

pars-betas : ∀ {n} {M N : Term n}
  → M ⇉* N
    ------
  → M —↠ N
pars-betas (M ∎) = M ∎
pars-betas (M ⇉⟨ p ⟩ ps) = —↠-trans (par-betas p) (pars-betas ps)


-- Andreas, 2016-12-30, issues #555 and #1886, reported by nad

-- Hidden parameters can be omitted in the repetition
-- of the parameter list.

record R {a} (A : Set a) : Set a

record R A where
  constructor c
  field f : A

testR : ∀{a}{A : Set a}(x : A) → R A
testR x = c x

data D {a} (A : Set a) : Set a

data D A where
  c : A → D A

testD : ∀{a}{A : Set a}(x : A) → D A
testD x = c x

-- Now, c is overloaded, should still work.
testR' : ∀{a}{A : Set a}(x : A) → R A
testR' x = c x


------------------------------------------------------------------------
-- Up-to techniques via
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

module Up-to.Via where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude
open import Prelude.Size

open import Bijection equality-with-J as Bijection using (_↔_)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level.Closure equality-with-J using (ext⁻¹)

open import Indexed-container
open import Indexed-container.Combinators
  hiding (id) renaming (_∘_ to _⊚_)
open import Relation
open import Up-to

-- The property of being an up-to technique via another (or the same)
-- relation transformer. This is an adaptation of Definition 6.3.25 in
-- Pous and Sangiorgi's "Enhancements of the bisimulation proof
-- method".

Up-to-technique-via :
  ∀ {ℓ} {I : Type ℓ} →
  Container I I → Trans ℓ I → Trans ℓ I → Type (lsuc ℓ)
Up-to-technique-via C F G =
  Extensive G
    ×
  (∀ R → R ⊆ ⟦ C ⟧ (F R) → G R ⊆ ⟦ C ⟧ (G R))

-- If F is an up-to technique via G, then F is an up-to technique.
--
-- A corresponding result is mentioned by Pous and Sangiorgi right
-- after Definition 6.3.25.

up-to-via→up-to :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F G} →
  Up-to-technique-via C F G → Up-to-technique C F
up-to-via→up-to {C = C} {F} {G} up-to {R} =
  R ⊆ ⟦ C ⟧ (F R)    ↝⟨ proj₂ up-to _ ⟩
  G R ⊆ ⟦ C ⟧ (G R)  ↝⟨ unfold C ⟩
  G R ⊆ ν C ∞        ↝⟨ (λ hyp {_} x → hyp (proj₁ up-to R x)) ⟩□
  R ⊆ ν C ∞          □

-- If F is an up-to technique, then F is an up-to technique via
-- _∪ ν C ∞.

up-to→up-to-via :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F} →
  Up-to-technique C F → Up-to-technique-via C F (_∪ ν C ∞)
up-to→up-to-via {C = C} {F} up-to =
    (λ R →
       R          ⊆⟨ inj₁ ⟩∎
       R ∪ ν C ∞  ∎)
  , λ R →
      R ⊆ ⟦ C ⟧ (F R)                ↝⟨ up-to ⟩
      R ⊆ ν C ∞                      ↝⟨ (λ hyp {_} →

          R ∪ ν C ∞                            ⊆⟨ [ hyp {_} , id ] ⟩
          ν C ∞                                ⊆⟨ ν-out _ ⟩
          ⟦ C ⟧ (ν C ∞)                        ⊆⟨ map C inj₂ ⟩∎
          ⟦ C ⟧ (R ∪ ν C ∞)                    ∎) ⟩

      R ∪ ν C ∞ ⊆ ⟦ C ⟧ (R ∪ ν C ∞)  □

-- A lemma that corresponds to Pous and Sangiorgi's Lemma 6.3.27: If G
-- satisfies certain properties, then Up-to-technique-via C F is
-- closed under G ∘_.

up-to-via-∘ :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F G H} →
  Extensive G →
  (∀ R → R ⊆ ⟦ C ⟧ R → G R ⊆ ⟦ C ⟧ (G R)) →
  Up-to-technique-via C F H →
  Up-to-technique-via C F (G ∘ H)
up-to-via-∘ {C = C} {F} {G} {H} extensive pres up-to =
    (λ R →
       R        ⊆⟨ proj₁ up-to _ ⟩
       H R      ⊆⟨ extensive _ ⟩∎
       G (H R)  ∎)
  , λ R →
      R ⊆ ⟦ C ⟧ (F R)            ↝⟨ proj₂ up-to _ ⟩
      H R ⊆ ⟦ C ⟧ (H R)          ↝⟨ pres _ ⟩□
      G (H R) ⊆ ⟦ C ⟧ (G (H R))  □

mutual

  -- If the container F is an up-to technique via a symmetric relation
  -- transformer, then ν ⟷[ C ⊚ F ] ∞ is contained in ν ⟷[ C ] ∞. This
  -- result corresponds to Pous and Sangiorgi's Proposition 6.3.28.

  up-to-via→ν-∘⊆ν :
    ∀ {ℓ} {I : Type ℓ} {C : Container (I × I) (I × I)} {F G} →
    Symmetric swap G →
    Up-to-technique-via C ⟦ F ⟧ G →
    ν ⟷[ C ⊚ F ] ∞ ⊆ ν ⟷[ C ] ∞
  up-to-via→ν-∘⊆ν symm up-to = up-to-via²→ν-∘⊆ν refl symm up-to up-to

  -- A generalisation of the result above.

  up-to-via²→ν-∘⊆ν :
    ∀ {ℓ} {I : Type ℓ} {C₁ C₂ : Container I I} {F₁ F₂ G} {f : I → I} →
    f ∘ f ≡ id →
    Symmetric f G →
    Up-to-technique-via C₁ ⟦ F₁ ⟧ G →
    Up-to-technique-via C₂ ⟦ F₂ ⟧ G →
    ν (C₁ ⊚ F₁ ⊗ reindex f (C₂ ⊚ F₂)) ∞ ⊆ ν (C₁ ⊗ reindex f C₂) ∞
  up-to-via²→ν-∘⊆ν {ℓ} {I} {C₁} {C₂} {F₁} {F₂} {G} {f}
                   inv symm up-to₁ up-to₂ =
                                                       $⟨ (λ {_} → ν-out _) ⟩
    R ⊆ ⟦ C₁ ⊚ F₁ ⊗ reindex f (C₂ ⊚ F₂) ⟧ R            ↝⟨ ⊆-congʳ _ $ ⟦⊗⟧↔ _ (C₁ ⊚ F₁) (reindex f (C₂ ⊚ F₂)) ⟩
    R ⊆ ⟦ C₁ ⊚ F₁ ⟧ R ∩ ⟦ reindex f (C₂ ⊚ F₂) ⟧ R      ↝⟨ from-isomorphism implicit-ΠΣ-comm F.∘
                                                          implicit-∀-cong _ (from-isomorphism ΠΣ-comm) ⟩
    R ⊆ ⟦ C₁ ⊚ F₁ ⟧ R × R ⊆ ⟦ reindex f (C₂ ⊚ F₂) ⟧ R  ↝⟨ Σ-map lemma₁ lemma₂ ⟩
    G R ⊆ ⟦ C₁ ⟧ (G R) × G R ⊆ ⟦ reindex f C₂ ⟧ (G R)  ↝⟨ _⇔_.from (from-isomorphism implicit-ΠΣ-comm F.∘
                                                                    implicit-∀-cong _ (from-isomorphism ΠΣ-comm)) ⟩
    G R ⊆ ⟦ C₁ ⟧ (G R) ∩ ⟦ reindex f C₂ ⟧ (G R)        ↝⟨ _⇔_.from $ ⊆-congʳ _ $ ⟦⊗⟧↔ _ C₁ (reindex f C₂) ⟩
    G R ⊆ ⟦ C₁ ⊗ reindex f C₂ ⟧ (G R)                  ↝⟨ unfold (C₁ ⊗ reindex f C₂) ⟩
    G R ⊆ ν (C₁ ⊗ reindex f C₂) ∞                      ↝⟨ (λ hyp {_} x → hyp (proj₁ up-to₁ R x)) ⟩□
    R ⊆ ν (C₁ ⊗ reindex f C₂) ∞                        □
    where
    R = ν (C₁ ⊚ F₁ ⊗ reindex f (C₂ ⊚ F₂)) ∞

    I↔I : I ↔ I
    I↔I = Bijection.bijection-from-involutive-family
            (λ _ _ → f) (λ _ _ → ext⁻¹ inv) tt tt

    ∘⊆⇔⊆∘ : {S₁ S₂ : Rel ℓ I} → S₁ ∘ f ⊆ S₂ ⇔ S₁ ⊆ S₂ ∘ f
    ∘⊆⇔⊆∘ {S₁ = S₁} {S₂} =
      (∀ {p} → S₁ (f p) → S₂ p)  ↔⟨ Bijection.implicit-Π↔Π ⟩
      (∀ p → S₁ (f p) → S₂ p)    ↝⟨ Π-cong _ I↔I (λ _ → →-cong _ F.id (≡⇒↝ _ $ cong S₂ $ ext⁻¹ (sym inv) _)) ⟩
      (∀ p → S₁ p → S₂ (f p))    ↔⟨ inverse Bijection.implicit-Π↔Π ⟩□
      (∀ {p} → S₁ p → S₂ (f p))  □

    lemma₁ =
      R ⊆ ⟦ C₁ ⊚ F₁ ⟧ R      ↝⟨ ⊆-congʳ _ (⟦∘⟧↔ _ C₁) ⟩
      R ⊆ ⟦ C₁ ⟧ (⟦ F₁ ⟧ R)  ↝⟨ proj₂ up-to₁ _ ⟩□
      G R ⊆ ⟦ C₁ ⟧ (G R)     □

    lemma₂ =
      R ⊆ ⟦ reindex f (C₂ ⊚ F₂) ⟧ R    ↝⟨ ⊆-congʳ _ $ ⟦reindex⟧↔ _ (C₂ ⊚ F₂) ⟩
      R ⊆ ⟦ C₂ ⊚ F₂ ⟧ (R ∘ f) ∘ f      ↝⟨ ⊆-congʳ _ (⟦∘⟧↔ _ C₂) ⟩
      R ⊆ ⟦ C₂ ⟧ (⟦ F₂ ⟧ (R ∘ f)) ∘ f  ↝⟨ _⇔_.from ∘⊆⇔⊆∘ ⟩
      R ∘ f ⊆ ⟦ C₂ ⟧ (⟦ F₂ ⟧ (R ∘ f))  ↝⟨ proj₂ up-to₂ _ ⟩
      G (R ∘ f) ⊆ ⟦ C₂ ⟧ (G (R ∘ f))   ↝⟨ involution→other-symmetry G inv symm _ ⊆-cong-→ ⟦⟧-cong _ C₂ (symm _) ⟩
      G R ∘ f ⊆ ⟦ C₂ ⟧ (G R ∘ f)       ↝⟨ _⇔_.to ∘⊆⇔⊆∘ ⟩
      G R ⊆ ⟦ C₂ ⟧ (G R ∘ f) ∘ f       ↝⟨ _⇔_.from $ ⊆-congʳ _ $ ⟦reindex⟧↔ _ C₂ ⟩
      G R ⊆ ⟦ reindex f C₂ ⟧ (G R)     □

-- If F is monotone and compatible, then F is an up-to technique via
-- F ^ω_. This result corresponds to Pous and Sangiorgi's
-- Theorem 6.3.26.

monotone→compatible→up-to-via :
  ∀ {ℓ} {I : Type ℓ} {C : Container I I} {F} →
  Monotone F →
  Compatible C F → Up-to-technique-via C F (F ^ω_)
monotone→compatible→up-to-via {C = C} {F} mono comp =
    (λ R →
       R       ⊆⟨ 0 ,_ ⟩∎
       F ^ω R  ∎)
  , λ R R⊆ →
      F ^ω R          ⊆⟨ compatible→^ω-post-fixpoint _ mono comp R⊆ ⟩∎
      ⟦ C ⟧ (F ^ω R)  ∎


-- Andreas 2012-07-07
module Issue674 where

record unit : Set where
  constructor tt

module A ⦃ t : unit ⦄ (i : unit) where
  id : unit → unit
  id x = x

open A {{t = _}} tt

module N = A {{ tt }} tt
open N

open A {{tt}} tt

module M = A tt
open M

open A tt
-- the last statement caused a panic when inserting the instance meta
-- because due to open it found candidates in scope that were not
-- in the signature yet


module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive
open import Data.Empty

[_]τ_from_to_ : ∀ (τ : Type) → (dv : Chτ τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

-- This can't be a datatype, since it wouldn't be strictly positive as it
-- appears on the left of an arrow in the function case, which then can be
-- contained in nested "fromto-validity" proofs.
sumfromto : ∀ (σ τ : Type) → (dv : SumChange2 {A = ⟦ σ ⟧Type} {B = ⟦ τ ⟧Type}) → (v1 v2 : ⟦ sum σ τ ⟧Type) → Set
sumfromto σ τ (ch₁ da) (inj₁ a1) (inj₁ a2) = [ σ ]τ da from a1 to a2
-- These fallback equations unfortunately don't hold definitionally, they're
-- split on multiple cases, so the pattern match is a mess.
--
-- To "case split" on validity, I typically copy-paste the pattern match from
-- fromto→⊕ and change the function name :-(.
sumfromto σ τ (ch₁ da) _ _ = ⊥
sumfromto σ τ (ch₂ db) (inj₂ b1) (inj₂ b2) = [ τ ]τ db from b1 to b2
sumfromto σ τ (ch₂ db) _ _ = ⊥
sumfromto σ τ (rp (inj₂ b2)) (inj₁ a1) (inj₂ b2') = b2 ≡ b2'
sumfromto σ τ (rp (inj₁ a2)) (inj₂ b1) (inj₁ a2') = a2 ≡ a2'
sumfromto σ τ (rp s) _ _ = ⊥

[ σ ⇒ τ ]τ df from f1 to f2 =
  ∀ (da : Chτ σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ]τ da from a1 to a2 → [ τ ]τ df a1 da from f1 a1 to f2 a2
[ int ]τ dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ]τ (da , db) from (a1 , b1) to (a2 , b2) = [ σ ]τ da from a1 to a2 × [ τ ]τ db from b1 to b2
[ sum σ τ ]τ dv from v1 to v2 = sumfromto σ τ (convert dv) v1 v2

data [_]Γ_from_to_ : ∀ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ]τ dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ]τ v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₁ a2) = ⊝-fromto a1 a2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₂ b2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₁ a2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₂ b2) = ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ]τ nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa rewrite fromto→⊕ da a1 a2 daa = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb rewrite fromto→⊕ db b1 b2 dbb = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveConst : ∀ {τ} c →
  [ τ ]τ ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst (lit n) = sym (right-id-int n)
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = daa
fromtoDeriveConst rinj db b1 b2 dbb = dbb
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa df f1 f2 dff dg g1 g2 dgg = dff da a1 a2 daa
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb df f1 f2 dff dg g1 g2 dgg = dgg db b1 b2 dbb
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

open import Postulate.Extensionality

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Chτ (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ]τ da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨ cong (λ □ → □ (a ⊕ da)) (fromto→⊕ df f1 f2 dff)⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Chτ (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ]τ da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ]τ da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da _ _ daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ dv v1 v2 → [ τ ]τ dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Chτ τ) → valid v dv → [ τ ]τ dv from v to (v ⊕ dv)

fromto→valid {int} = λ dv v1 v2 x → tt
fromto→valid {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = (fromto→valid da _ _ daa) , (fromto→valid db _ _ dbb)
fromto→valid {σ ⇒ τ} df f1 f2 dff = λ a da ada →
  fromto→valid (df a da) (f1 a) (f2 (a ⊕ da)) (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto a da ada)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa = sv₁ a1 da (fromto→valid da a1 a2 daa)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb = sv₂ b1 db (fromto→valid db b1 b2 dbb)
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = svrp₂ b1 a2
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = svrp₁ a1 b2
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid da _ _ daa)
    body : [ τ ]τ df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ da _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)
valid→fromto {sum σ τ} .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) = valid→fromto a da ada
valid→fromto {sum σ τ} .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) = valid→fromto b db bdb
valid→fromto {sum σ τ} .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) = refl
valid→fromto {sum σ τ} .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) = refl

correctDeriveOplus : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ t ⟧Term ρ1) ⊕ (⟦ t ⟧ΔTerm ρ1 dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplus τ t dρρ = fromto→⊕ _ _ _ (fromtoDerive τ t dρρ)

-- Getting to the original equation 1 from PLDI'14.

open import New.LangOps

correctDeriveOplusτ : ∀ {Γ} τ → (t : Term Γ τ)
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit t) (derive t) ⟧Term dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplusτ τ t {dρ = dρ} {ρ1 = ρ1} dρρ
  rewrite oplusτ-equiv _ dρ _ (⟦ fit t ⟧Term dρ) (⟦ derive t ⟧Term dρ)
  | sym (fit-sound t dρρ)
  = correctDeriveOplus τ t dρρ

deriveGivesDerivative : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ)→
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app f a ⟧Term ρ1) ⊕ (⟦ app f a ⟧ΔTerm ρ1 dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative σ τ f a dρρ = correctDeriveOplus τ (app f a) dρρ

deriveGivesDerivative₂ : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) (derive a)) ⟧Term dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative₂ σ τ f a dρρ = correctDeriveOplusτ τ (app f a) dρρ

-- Proof of the original equation 1 from PLDI'14.
eq1 : ∀ {Γ} σ τ →
  {nilρ : ChΓ Γ} {ρ : ⟦ Γ ⟧Context} → [ Γ ]Γ nilρ from ρ to ρ →
  ∀ (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) (da : Term (ΔΓ Γ) (Δt σ)) →
  (daa : [ σ ]τ (⟦ da ⟧Term nilρ) from (⟦ a ⟧Term ρ) to (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ)) →
    ⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) da) ⟧Term nilρ ≡ ⟦ app (fit f) (app₂ (oplusτo σ) (fit a) da) ⟧Term nilρ
eq1 σ τ {nilρ} {ρ} dρρ f a da daa
  rewrite
    oplusτ-equiv _ nilρ _ (⟦ fit (app f a) ⟧Term nilρ) (⟦ (app₂ (derive f) (fit a) da) ⟧Term nilρ)
  | sym (fit-sound f dρρ)
  | oplusτ-equiv _ nilρ _ (⟦ fit a ⟧Term nilρ) (⟦ da ⟧Term nilρ)
  | sym (fit-sound a dρρ)
  = fromto→⊕ (⟦ f ⟧ΔTerm ρ nilρ (⟦ a ⟧Term ρ) (⟦ da ⟧Term nilρ)) _ _
    (fromtoDerive _ f dρρ (⟦ da ⟧Term nilρ) (⟦ a ⟧Term ρ)
      (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ) daa)


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

open import HoTT

module homotopy.SuspensionLoopSpaceInverse where

{- corollary about inversion in ⊙Trunc k (⊙Ω (⊙Susp (de⊙ X))) -}
private
  custom-path-alg : ∀ {l} {A : Type l}
    {n s : A} (p q : n == s)
    → ! (p ∙ ! q) == ! (! q) ∙ (! p ∙ q) ∙' ! q
  custom-path-alg p q@idp = ap ! (∙-unit-r p) ∙ ! (∙-unit-r (! p))

  Ω-!-Susp-flip-seq : ∀ {i} (X : Ptd i) (x : de⊙ X)
    → ! (merid x ∙ ! (merid (pt X)))
      =-=
      Ω-fmap (⊙Susp-flip X) (σloop X x)
  Ω-!-Susp-flip-seq X x =
    ! (merid x ∙ ! (merid (pt X)))
      =⟪ custom-path-alg (merid x) (merid (pt X)) ⟫
    ! (! (merid (pt X))) ∙ (! (merid x) ∙ merid (pt X)) ∙' ! (merid (pt X))
      =⟪ ap (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
            (! (Susp-flip-σloop X x)) ⟫
    ! (! (merid (pt X))) ∙ ap Susp-flip (σloop X x) ∙' ! (merid (pt X))
      =⟪ ! (Ω-fmap-β (⊙Susp-flip X) (merid x ∙ ! (merid (pt X)))) ⟫
    Ω-fmap (⊙Susp-flip X) (σloop X x) ∎∎

  Ω-!-Susp-flip' : ∀ {i} (X : Ptd i)
    → Ω-! ∘ σloop X ∼ Ω-fmap (⊙Susp-flip X) ∘ σloop X
  Ω-!-Susp-flip' X x = ↯ (Ω-!-Susp-flip-seq X x)

  ⊙Ω-!-Susp-flip' : ∀ {i} (X : Ptd i)
    → ⊙Ω-! ◃⊙∘
      ⊙σloop X ◃⊙idf
      =⊙∘
      ⊙Ω-fmap (⊙Susp-flip X) ◃⊙∘
      ⊙σloop X ◃⊙idf
  ⊙Ω-!-Susp-flip' X = ⊙seq-λ= (Ω-!-Susp-flip' X) $ !ₛ $
    ↯ (Ω-!-Susp-flip-seq X (pt X)) ◃∙
    ap (Ω-fmap (⊙Susp-flip X)) (!-inv-r (merid (pt X))) ◃∙
    snd (⊙Ω-fmap (⊙Susp-flip X)) ◃∎
      =ₛ⟨ 0 & 1 & expand (Ω-!-Susp-flip-seq X (pt X)) ⟩
    custom-path-alg (merid (pt X)) (merid (pt X)) ◃∙
    ap (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
       (! (Susp-flip-σloop X (pt X))) ◃∙
    ! (Ω-fmap-β (⊙Susp-flip X) (merid (pt X) ∙ ! (merid (pt X)))) ◃∙
    ap (Ω-fmap (⊙Susp-flip X)) (!-inv-r (merid (pt X))) ◃∙
    snd (⊙Ω-fmap (⊙Susp-flip X)) ◃∎
      =ₛ⟨ 2 & 2 & !ₛ $ homotopy-naturality
            (λ p → ! (! (merid (pt X))) ∙ ap Susp-flip p ∙' ! (merid (pt X)))
            (λ p → Ω-fmap (⊙Susp-flip X) p)
            (λ p → ! (Ω-fmap-β (⊙Susp-flip X) p))
            (!-inv-r (merid (pt X))) ⟩
    custom-path-alg (merid (pt X)) (merid (pt X)) ◃∙
    ap (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
       (! (Susp-flip-σloop X (pt X))) ◃∙
    ap (λ p → ! (! (merid (pt X))) ∙ ap Susp-flip p ∙' ! (merid (pt X)))
       (!-inv-r (merid (pt X))) ◃∙
    ! (Ω-fmap-β (⊙Susp-flip X) idp) ◃∙
    snd (⊙Ω-fmap (⊙Susp-flip X)) ◃∎
      =ₛ⟨ 3 & 2 & pre-rotate'-in $ Ω-fmap-pt (⊙Susp-flip X) ⟩
    custom-path-alg (merid (pt X)) (merid (pt X)) ◃∙
    ap (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
       (! (Susp-flip-σloop X (pt X))) ◃∙
    ap (λ p → ! (! (merid (pt X))) ∙ ap Susp-flip p ∙' ! (merid (pt X)))
       (!-inv-r (merid (pt X))) ◃∙
    ap (! (! (merid (pt X))) ∙_) (∙'-unit-l (snd (⊙Susp-flip X))) ◃∙
    !-inv-l (snd (⊙Susp-flip X)) ◃∎
      =ₛ₁⟨ 2 & 1 & ap-∘ (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
                        (ap Susp-flip)
                        (!-inv-r (merid (pt X))) ⟩
    custom-path-alg (merid (pt X)) (merid (pt X)) ◃∙
    ap (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
       (! (Susp-flip-σloop X (pt X))) ◃∙
    ap (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
       (ap (ap Susp-flip) (!-inv-r (merid (pt X)))) ◃∙
    ap (! (! (merid (pt X))) ∙_) (∙'-unit-l (snd (⊙Susp-flip X))) ◃∙
    !-inv-l (snd (⊙Susp-flip X)) ◃∎
      =ₛ⟨ 1 & 2 & ap-seq-=ₛ (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X))) $
                  !ₛ $ post-rotate-out $ pre-rotate-in $ Susp-flip-σloop-pt X ⟩
    custom-path-alg (merid (pt X)) (merid (pt X)) ◃∙
    ap (λ q → ! (! (merid (pt X))) ∙ q ∙' ! (merid (pt X)))
       (!-inv-l (merid (pt X))) ◃∙
    ap (! (! (merid (pt X))) ∙_) (∙'-unit-l (! (merid (pt X)))) ◃∙
    !-inv-l (! (merid (pt X))) ◃∎
      =ₛ⟨ custom-path-alg-coh (merid (pt X)) ⟩
    ap ! (!-inv-r (merid (pt X))) ◃∎
      =ₛ⟨ 1 & 0 & contract ⟩
    ap ! (!-inv-r (merid (pt X))) ◃∙
    idp ◃∎ ∎ₛ
    where
    custom-path-alg-coh : ∀ {l} {A : Type l}
      {n s : A} (p : n == s)
      → custom-path-alg p p ◃∙
        ap (λ q → ! (! p) ∙ q ∙' ! p) (!-inv-l p) ◃∙
        ap (! (! p) ∙_) (∙'-unit-l (! p)) ◃∙
        !-inv-l (! p) ◃∎
        =ₛ
        ap ! (!-inv-r p) ◃∎
    custom-path-alg-coh p@idp = =ₛ-in idp

⊙Ω-!-⊙Susp-flip : ∀ {i} (X : Ptd i) (n : ℕ₋₂)
  → is-equiv (Trunc-fmap {n = n} (σloop X))
  → ⊙Trunc-fmap {n = n} ⊙Ω-! == ⊙Trunc-fmap {n = n} (⊙Ω-fmap (⊙Susp-flip X))
⊙Ω-!-⊙Susp-flip X n is-eq =
  –>-is-inj
    (pre⊙∘-equiv
      {Z = ⊙Trunc n (⊙Ω (⊙Susp (de⊙ X)))}
      (⊙Trunc-fmap {n = n} (⊙σloop X) , is-eq))
    (⊙Trunc-fmap {n = n} ⊙Ω-!)
    (⊙Trunc-fmap {n = n} (⊙Ω-fmap (⊙Susp-flip X)))
    (=⊙∘-out (⊙Trunc-fmap-seq-=⊙∘ {n = n} (⊙Ω-!-Susp-flip' X)))