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

open import Prelude
open import GSeTT.Syntax
open import GSeTT.Rules
open import GSeTT.Disks
open import GSeTT.Uniqueness-Derivations
open import GSeTT.Dec-Type-Checking
open import CaTT.Ps-contexts
open import CaTT.Relation
open import CaTT.Uniqueness-Derivations-Ps

module CaTT.Decidability-ps where
  ∅-is-not-ps : ∀ x A → ¬ (nil ⊢ps x # A)
  ∅-is-not-ps x A ∅⊢psx with psvar ∅⊢psx
  ... | var _ ()

  ps-carrier : ∀{Γ A B C x y z} → ((Γ :: (x , A)) :: (y , B)) ⊢ps z # C → ((Σ Pre-Tm λ a → (⇒ A a (Var x) == B)) × (x == length Γ)) × (y == S (length Γ))
  ps-carrier (psd Γ⊢ps) = ps-carrier Γ⊢ps
  ps-carrier (pse _ idp idp idp idp idp) = ((_ , idp) , idp) , idp

  Γ+⊢ps→Γ⊢ps : ∀ {Γ x A a y B z} → ((Γ :: (y , B)) :: (z , ⇒ B (Var a) (Var y))) ⊢ps x # A → Γ ⊢ps a # B
  Γ+⊢ps→Γ⊢ps (psd Γ⊢ps) = Γ+⊢ps→Γ⊢ps Γ⊢ps
  Γ+⊢ps→Γ⊢ps (pse Γ⊢ps idp idp p idp idp) = transport ((=Var (snd (fst (=⇒ p)))) ^) Γ⊢ps

  𝔻0-var : ∀ x A → Pre-𝔻 0 ⊢t (Var x) # A → x == 0
  𝔻0-var x A (var _ (inr (idp , _))) = idp

  𝔻0-type : ∀ x A → Pre-𝔻 0 ⊢t (Var x) # A → A == ∗
  𝔻0-type x A (var _ (inr (idp , idp))) = idp

  ⊢psx→⊢ps : ∀ {Γ x A} → Γ ⊢ps x # A → Γ ⊢ps
  ⊢psx→⊢ps {A = ∗} Γ⊢psx = ps Γ⊢psx
  ⊢psx→⊢ps {A = ⇒ A (Var _) (Var _)} Γ⊢psx = ⊢psx→⊢ps (psd Γ⊢psx)

  dec-⊢-dim : ∀ {Γ} → Γ ⊢C → (n : ℕ) → dec (Σ (ℕ × Pre-Ty) (λ (x , A) → (Γ ⊢t (Var x) # A) × (dim A == n)))
  dec-⊢-dim {nil} _ n = inr λ{((x , A) , ((var _ ())  , _))}
  dec-⊢-dim {Γ :: (x , A)} Γ+⊢@(cc Γ⊢ _ _) n with eqdecℕ (dim A) n
  ... | inl idp = inl ((x , A) , (var Γ+⊢ (inr (idp , idp)) , idp))
  ... | inr dimA≠n with dec-⊢-dim Γ⊢ n
  ... | inl ((y , B) , ((var _ y∈Γ) , dimB=n)) = inl ((y , B ), (var Γ+⊢ (inl y∈Γ) , dimB=n))
  ... | inr ¬∃y = inr λ{((z , C) , ((var _ (inl z∈Γ)) , idp)) → ¬∃y ((z , C) , (var Γ⊢ z∈Γ , idp));
                        ((z , C) , ((var _ (inr (idp , idp))) , idp)) → dimA≠n idp}

  dim-pse : ∀ {Γ x A y B} → ((Γ :: (x , A)) :: (y , B)) ⊢ps y # B → (∀ z C → ((Γ :: (x , A)) :: (y , B)) ⊢ps z # C → dim C ≤ dim B)
  dim-pse Γ⊢psy z C (psd Γ⊢psf) = Sn≤m→n≤m (dim-pse Γ⊢psy _ _ Γ⊢psf)
  dim-pse Γ⊢psy z C (pse Γ⊢psz idp idp idp idp idp) = n≤n _

  private
    tgt-⟿ : ∀ {Γ x A y z a} → Γ ⊢t Var x # ⇒ A (Var y) (Var z) → Γ , x ⟿ a → z ≠ a → Γ , z ⟿ a
    tgt-⟿ Γ⊢x (∂⁺⟿ Γ⊢'x) z≠a with unique-type Γ⊢x Γ⊢'x idp
    ... | idp = ⊥-elim (z≠a idp)
    tgt-⟿ Γ⊢x (x⟿∂⁺ Γ⊢'x x⟿a) z≠a with unique-type Γ⊢x Γ⊢'x idp
    ... | idp = x⟿a

  ⇒≠∗ : ∀ {A t u} → ⇒ A t u ≠ ∗
  ⇒≠∗ ()

  dec-Σ⊢T : ∀ {Γ t} → dec (Σ Pre-Ty λ A → Γ ⊢t t # A)
  dec-Σ⊢T {nil} {Var x} = inr λ{(_ , var _ ())}
  dec-Σ⊢T {Γ+@(Γ :: (y , B))} {Var x} with dec-⊢C Γ+ | eqdecℕ x y
  ... | inr Γ+⊬ | _ = inr λ (A , Γ+⊢x) → Γ+⊬ (Γ⊢t:A→Γ⊢ Γ+⊢x)
  ... | inl Γ+⊢ | inl idp = inl (B , var Γ+⊢ (inr (idp , idp)))
  ... | inl Γ+⊢ | inr x≠y with dec-Σ⊢T {Γ} {Var x}
  ... | inl (A , Γ⊢x)= inl (A , wkt Γ⊢x Γ+⊢)
  ... | inr Γ⊬x = inr λ{ (B , var _ (inr (idp , idp))) → x≠y idp;
                         (B , var (cc Γ⊢ _ _) (inl x#B∈Γ)) → Γ⊬x (B , var Γ⊢ x#B∈Γ)}

  dec-⟿ : ∀ Γ x y → dec (Γ , x ⟿ y)
  dec-⟿-aux : ∀ Γ x A y → Γ ⊢t (Var x) # A → dec (Γ , x ⟿ y)
  dec-⟿-aux Γ x ∗ y Γ⊢x = inr λ{(∂⁺⟿ Γ⊢'x) → ⇒≠∗ (unique-type Γ⊢'x Γ⊢x idp) ; (x⟿∂⁺ Γ⊢'x _) → ⇒≠∗ (unique-type Γ⊢'x Γ⊢x idp)}
  dec-⟿-aux Γ x (⇒ A (Var _) (Var z)) y Γ⊢x with eqdecℕ z y | dec-⟿-aux Γ z A y (Γ⊢tgt (Γ⊢t:A→Γ⊢A Γ⊢x))
  ... | inl idp | _ = inl (∂⁺⟿ Γ⊢x)
  ... | inr _ | inl x⟿z = inl (x⟿∂⁺ Γ⊢x x⟿z)
  ... | inr z≠y | inr ¬x⟿z = inr λ x⟿y → ¬x⟿z (tgt-⟿ Γ⊢x x⟿y z≠y)
  dec-⟿ Γ x y with dec-Σ⊢T {Γ} {Var x}
  ... | inr Γ⊬x = inr λ{(∂⁺⟿ Γ⊢x) → Γ⊬x (_ , Γ⊢x) ; (x⟿∂⁺ Γ⊢x _) → Γ⊬x (_ , Γ⊢x)}
  ... | inl (A , Γ⊢x) = dec-⟿-aux Γ x A y Γ⊢x

  Γ⊢psx-dim-⟿ : ∀ {Γ x A y B} → Γ ⊢ps x # A → Γ ⊢ps y # B → dim B < dim A → Γ , x ⟿ y
  Γ⊢psx-dim-⟿ Γ⊢psx pss dB<dA with 𝔻0-type _ _ (psvar Γ⊢psx)
  ... | idp = ⊥-elim (Sn≰n _ dB<dA)
  Γ⊢psx-dim-⟿ {Γ} {x} {A} {y} {B} Γ⊢psx (psd Γ⊢psf) dB<dA with eqdecℕ (S (dim B)) (dim A)
  ... | inl SdB=dA = transport {B = λ a → Γ , a ⟿ y} (Γ⊢psx-dim Γ⊢psf Γ⊢psx SdB=dA) (∂⁺⟿ (psvar Γ⊢psf))
  ... | inr SdB≠dA = T⟿ (Γ⊢psx-dim-⟿ Γ⊢psx Γ⊢psf (≤×≠→< dB<dA SdB≠dA)) (∂⁺⟿ (psvar Γ⊢psf))
  Γ⊢psx-dim-⟿ Γ⊢psx Γ⊢psy@(pse _ idp idp idp idp idp) dB<dA = ⊥-elim (Sn≰n _ (≤T dB<dA (dim-pse Γ⊢psy _ _ Γ⊢psx)))

  ⟿→psx : ∀ {Γ x A y} → Γ ⊢ps x # A → Γ , x ⟿ y → Σ Pre-Ty λ B → Γ ⊢ps y # B
  ⟿→psx Γ⊢psx (∂⁺⟿ Γ⊢x) with unique-type (psvar Γ⊢psx) Γ⊢x idp
  ... | idp = _ , (psd Γ⊢psx)
  ⟿→psx Γ⊢psx (x⟿∂⁺ Γ⊢x z⟿y) with unique-type (psvar Γ⊢psx) Γ⊢x idp
  ... | idp = ⟿→psx (psd Γ⊢psx) z⟿y

  pse-max : ∀ {Γ x A y B} → ((Γ :: (x , A)) :: (y , B)) ⊢ps y # B → (∀ z C → ((Γ :: (x , A)) :: (y , B)) ⊢ps z # C → (y == z) + (((Γ :: (x , A)) :: (y , B)) , y ⟿ z))
  pse-max {B = B} Γ⊢psy z C Γ⊢psz with ℕ-trichotomy (dim B) (dim C)
  ... | inl (inl dimB<dimC) = ⊥-elim (Sn≰n _ (≤T dimB<dimC (dim-pse Γ⊢psy _ _ Γ⊢psz)) )
  ... | inl (inr dimC<dimB) = inr (Γ⊢psx-dim-⟿ Γ⊢psy Γ⊢psz dimC<dimB)
  ... | inr dimB=dimC = inl (Γ⊢psx-dim Γ⊢psy Γ⊢psz dimB=dimC)

  ⊢psx→max : ∀ {Γ x A} → Γ ⊢ps x # A → (Σ (ℕ × Pre-Ty) λ (y , B) → (Γ ⊢ps y # B) × (∀ z C → Γ ⊢ps z # C → (y == z) + (Γ , y ⟿ z)))
  ⊢psx→max pss = (0 , ∗) , (pss , λ z C 𝔻0⊢psx → inl (𝔻0-var z C (psvar 𝔻0⊢psx) ^))
  ⊢psx→max (psd Γ⊢psx) = ⊢psx→max Γ⊢psx
  ⊢psx→max {((Γ :: (_ , B)) :: (_ , C))} {x} {A} Γ+⊢ps@(pse Γ⊢psx idp idp idp idp idp) = (S (length Γ) , C) , (Γ+⊢ps , pse-max Γ+⊢ps)

  -- TODO : move case_of_ in Prelude
  case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
  case x of f = f x

  ill-formed-1st-var : ∀ {y A} → ¬ ((nil :: (S y , A)) ⊢C)
  ill-formed-1st-var (cc _ _ ())

  ill-formed-1st-type : ∀ {y A a b} → ¬ ((nil :: (y , ⇒ A a b)) ⊢C)
  ill-formed-1st-type (cc _ (ar (var _ ()) _) _)

  dec-⊢psx-max : ∀ {Γ} → dec (Σ (ℕ × Pre-Ty) λ (x , A) → (Γ ⊢ps x # A) × (∀ y B → Γ ⊢ps y # B → (x == y) + (Γ , x ⟿ y)))
  dec-⊢psx-max {nil} = inr λ ((x , A) , (nil⊢psx , _ )) → ∅-is-not-ps _ _ nil⊢psx
  dec-⊢psx-max {nil :: (O , ∗)} = inl ((0 , ∗) , (pss , λ y B  𝔻0⊢psy → inl (𝔻0-var _ _ (psvar 𝔻0⊢psy) ^)))
  dec-⊢psx-max {nil :: (O , ⇒ _ _ _)} = inr λ ((x , A) , (Γ⊢psx , _ )) → ill-formed-1st-type (psv Γ⊢psx)
  dec-⊢psx-max {nil :: (S z , C)} = inr λ ((x , A) , (Γ⊢psx , _ )) → ill-formed-1st-var (psv Γ⊢psx)
  dec-⊢psx-max {(Γ :: (z , C)) :: (f , ∗)} = inr λ ((x , A) , (Γ+⊢psx , _)) → ⇒≠∗ (snd (fst (fst (ps-carrier Γ+⊢psx))))
  dec-⊢psx-max {(Γ :: (z , C)) :: (f , ⇒ D (Var a) (Var b))} with eqdec-PreTy C D | eqdecℕ z (length Γ) | eqdecℕ (length Γ) b | eqdecℕ f (S (length Γ))
  ... | inr C≠D | _ | _ | _  = inr λ ((x , A) , (Γ+⊢psx , _)) → C≠D (fst (fst (=⇒ (snd (fst (fst (ps-carrier Γ+⊢psx)))))))
  ... | inl idp | inr z≠l | _ | _  = inr λ ((x , A) , (Γ+⊢psx , _)) → z≠l (snd (fst (ps-carrier Γ+⊢psx)))
  ... | inl idp | inl idp | inr l≠b | _  = inr λ ((x , A) , (Γ+⊢psx , _)) → l≠b (=Var (snd (=⇒ (snd (fst (fst (ps-carrier Γ+⊢psx)))))))
  ... | inl idp | inl idp | inl idp | inr f≠Sl  = inr λ ((x , A) , (Γ+⊢psx , _)) → f≠Sl (snd (ps-carrier Γ+⊢psx))
  ... | inl idp | inl idp | inl idp | inl idp with dec-⊢psx-max {Γ}
  ... | inr ¬Γ⊢ps = inr λ ((x , A) , (Γ+⊢psx , _)) → ¬Γ⊢ps (⊢psx→max (Γ+⊢ps→Γ⊢ps Γ+⊢psx))
  ... | inl ((c , E) , (Γ⊢psc , cmax)) with eqdecℕ c a | eqdec-PreTy E C
  ... | inl idp | inl idp = let Γ+⊢ps = pse Γ⊢psc idp idp idp idp idp in inl ((S (length Γ) , ⇒ C (Var a) (Var (length Γ))) , (Γ+⊢ps , pse-max Γ+⊢ps))
  ... | inl idp | inr E≠C = inr λ ((x , A) , (Γ+⊢psx , _)) → E≠C (unique-type (psvar Γ⊢psc) (psvar (Γ+⊢ps→Γ⊢ps Γ+⊢psx)) idp)
  ... | inr c≠a | _ with dec-⟿ Γ c a
  ... | inr ¬c⟿a = inr λ ((x , A) , (Γ+⊢psx , _)) → case cmax _ _ (Γ+⊢ps→Γ⊢ps Γ+⊢psx) of λ{(inl c=a) → c≠a c=a; (inr c⟿a) → ¬c⟿a c⟿a }
  ... | inl c⟿a with (⟿→psx Γ⊢psc c⟿a)
  ... | (F , Γ⊢psa) with eqdec-PreTy F C
  ... | inl idp = let Γ+⊢ps = pse Γ⊢psa idp idp idp idp idp in inl ((S (length Γ) , ⇒ C (Var a) (Var (length Γ))) , (Γ+⊢ps  , pse-max Γ+⊢ps))
  ... | inr F≠C = inr λ ((x , A) , (Γ+⊢psx , _)) → F≠C (unique-type (psvar Γ⊢psa) (psvar (Γ+⊢ps→Γ⊢ps Γ+⊢psx)) idp)

  dec-⊢ps : ∀ Γ → dec(Γ ⊢ps)
  dec-⊢ps Γ with dec-⊢psx-max {Γ}
  ... | inl ((x , A) , (Γ⊢psx , _)) = inl (⊢psx→⊢ps Γ⊢psx)
  ... | inr ¬Γ⊢psx = inr λ {(ps Γ⊢psy) → ¬Γ⊢psx (⊢psx→max Γ⊢psy)}


open import Agda.Builtin.Bool

works : Bool → Bool
works b with b | true
... | b′ | _ = b′

fails : Bool → Bool
fails b with b′ ← b | true
... | _ = b′


module _ where

open import Issue1839.A
open import Issue1839.B

X : DontPrintThis    -- should display as PrintThis
X = {!!}


{-# OPTIONS --safe #-}
{-
Builds bismulation for the cumulative hierarchy and shows that it
is equivalent to equality though it lives in a lower universe.
-}

module Cubical.HITs.CumulativeHierarchy.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function
open import Cubical.Foundations.Transport
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Functions.Embedding
open import Cubical.Functions.Logic as L
open import Cubical.Data.Sigma
open import Cubical.HITs.PropositionalTruncation as P hiding (elim; elim2)
open import Cubical.HITs.SetQuotients as Q using (_/_; setQuotUniversal; eq/; squash/)

open import Cubical.HITs.CumulativeHierarchy.Base
  renaming (elim to elimInternal)
import Cubical.HITs.PropositionalTruncation.Monad as PropMonad

private
  variable
    ℓ ℓ' : Level
    X Y : Type ℓ
    a b : V ℓ

infix 4 _≊_
infix 7 _∈ₛ_ _⊆_ _⊆ₛ_

------------
-- "bisimulation"
-----------

-- bisimulation is needed to define a quotient in the correct universe when
-- implementing the map : V ℓ → Σ[ X : Type ℓ ] (X → V ℓ)
-- Quotienting by Path (V ℓ) or via eqImage would lead to X : Type (ℓ-suc ℓ)

_∼_ : (s t : V ℓ) → hProp ℓ
_∼_ = elim2 eliminator where
  goalProp : (X : Type ℓ) (ix : X → V ℓ)
           → (Y : Type ℓ) (iy : Y → V ℓ)
           → (rec : X → Y → hProp ℓ)
           → hProp ℓ
  goalProp X ix Y iy rec = (∀[ a ∶ X ] ∃[ b ∶ Y ] rec a b) ⊓ (∀[ b ∶ Y ] ∃[ a ∶ X ] rec a b)

  ⇔-swap : X ⊓′ Y → Y ⊓′ X
  ⇔-swap (p , q) = (q , p)

  open PropMonad
  lemma : {X₁ X₂ Y : Type ℓ} {ix₁ : X₁ → V ℓ} {ix₂ : X₂ → V ℓ} (iy : Y → V ℓ)
        → {rec₁ : X₁ → Y → hProp ℓ} {rec₂ : X₂ → Y → hProp ℓ}
        → (rec₁→₂ : (x₁ : X₁) → ∃[ (x₂ , p) ∈ fiber ix₂ (ix₁ x₁) ] rec₂ x₂ ≡ rec₁ x₁)
        → (rec₂→₁ : (x₂ : X₂) → ∃[ (x₁ , p) ∈ fiber ix₁ (ix₂ x₂) ] rec₁ x₁ ≡ rec₂ x₂)
        → ⟨ goalProp X₁ ix₁ Y iy rec₁ ⇒ goalProp X₂ ix₂ Y iy rec₂ ⟩
  lemma _ rec₁→₂ rec₂→₁ (X₁→Y , Y→X₁) =
    (λ x₂ → do ((x₁ , c_) , xr₁) ← rec₂→₁ x₂
               (y , yr) ← X₁→Y x₁
               ∣ y , subst fst (λ i → xr₁ i y) yr ∣₁
    ) ,
    (λ y → do (x₁ , xr₁) ← Y→X₁ y
              ((x₂ , _) , xr₂) ← rec₁→₂ x₁
              ∣ x₂ , subst fst (λ i → xr₂ (~ i) y) xr₁ ∣₁
    )

  open Elim2Set
  eliminator : Elim2Set (λ _ _ → isSetHProp)
  ElimSett2 eliminator = goalProp
  ElimEqSnd eliminator X ix Y₁ Y₂ iy₁ iy₂ eq rec₁ rec₂ rec₁→₂ rec₂→₁ =
    ⇔toPath (⇔-swap ∘ lemma ix rec₁→₂ rec₂→₁ ∘ ⇔-swap)
            (⇔-swap ∘ lemma ix rec₂→₁ rec₁→₂ ∘ ⇔-swap)
  ElimEqFst eliminator X₁ X₂ ix₁ ix₂ eq Y iy rec₁ rec₂ rec₁→₂ rec₂→₁ =
    ⇔toPath (lemma iy rec₁→₂ rec₂→₁)
            (lemma iy rec₂→₁ rec₁→₂)

_≊_ : (s t : V ℓ) → Type ℓ
s ≊ t = ⟨ s ∼ t ⟩

∼refl : (a : V ℓ) → a ≊ a
∼refl = elimProp (λ a → isProp⟨⟩ (a ∼ a))
                 (λ X ix rec → (λ x → ∣ x , rec x ∣₁) , (λ x → ∣ x , rec x ∣₁))

-- keep in mind that the left and right side here live in different universes
identityPrinciple : (a ≊ b) ≃ (a ≡ b)
identityPrinciple {a = a} {b = b} =
  isoToEquiv (iso from into (λ _ → setIsSet _ _ _ _) (λ _ → isProp⟨⟩ (a ∼ b) _ _))
  where
  open PropMonad

  eqImageXY : {X Y : Type ℓ} {ix : X → V ℓ} {iy : Y → V ℓ} → (∀ x y → ⟨ ix x ∼ iy y ⟩ → ix x ≡ iy y)
            → ⟨ sett X ix ∼ sett Y iy ⟩ → eqImage ix iy
  eqImageXY rec rel = (λ x → do (y , y∼x) ← fst rel x ; ∣ y , sym (rec _ _ y∼x) ∣₁)
                    , (λ y → do (x , x∼y) ← snd rel y ; ∣ x ,      rec _ _ x∼y  ∣₁)

  from : a ≊ b → a ≡ b
  from = elimProp propB eliminator a b where
    prop∼ : {a : V ℓ} → ∀ b → isProp (a ≊ b → a ≡ b)
    prop∼ {a = a} b = isPropΠ λ _ → setIsSet a b
    propB : (a : V ℓ) → isProp (∀ b → a ≊ b → a ≡ b)
    propB a = isPropΠ prop∼
    eliminator :
      ∀ (X : Type _) (ix : X → V _)
      → ((x : X) (b₁ : V _) → ix x ≊ b₁ → ix x ≡ b₁)
      → (b₁ : V _) → sett X ix ≊ b₁ → sett X ix ≡ b₁
    eliminator X ix rec =
      elimProp prop∼ λ Y iy _ → seteq X Y ix iy ∘ eqImageXY (λ x y → rec x (iy y))

  into : a ≡ b → a ≊ b
  into = J (λ b _ → a ≊ b) (∼refl a)

------------
-- Monic presentation of sets
-----------

-- like fiber, but in a lower universe
repFiber : (f : X → V ℓ) (b : V ℓ) → Type _
repFiber f b = Σ[ a ∈ _ ] f a ≊ b

repFiber≃fiber : (f : X → V ℓ) (b : V ℓ) → repFiber f b ≃ fiber f b
repFiber≃fiber f b = Σ-cong-equiv (idEquiv _) (λ _ → identityPrinciple)

-- projecting out a representing type together with the embedding
MonicPresentation : (a : V ℓ) → Type (ℓ-suc ℓ)
MonicPresentation {ℓ} a =  Σ[ (X , ix , _) ∈ Embedding (V ℓ) ℓ ] (a ≡ sett X ix)

isPropMonicPresentation : (a : V ℓ) → isProp (MonicPresentation a)
isPropMonicPresentation a ((X₁ , ix₁ , isEmb₁) , p) ((X₂ , ix₂ , isEmb₂) , q) =
  ΣPathP ( equivFun (EmbeddingIP _ _) (fiberwise1 , fiberwise2)
         , isProp→PathP (λ i → setIsSet a _) p q)
  where
  open PropMonad
  fiberwise1 : ∀ b → fiber ix₁ b → fiber ix₂ b
  fiberwise1 b fbx₁ =
    proof (_ , isEmbedding→hasPropFibers isEmb₂ b)
    by subst (λ A → ⟨ b ∈ A ⟩) (sym p ∙ q) ∣ fbx₁ ∣₁

  fiberwise2 : ∀ b → fiber ix₂ b → fiber ix₁ b
  fiberwise2 b fbx₂ =
    proof (_ , isEmbedding→hasPropFibers isEmb₁ b)
    by subst (λ A → ⟨ b ∈ A ⟩) (sym q ∙ p) ∣ fbx₂ ∣₁

sett-repr : (X : Type ℓ) (ix : X → V ℓ) → MonicPresentation (sett X ix)
sett-repr {ℓ} X ix = (Rep , ixRep , isEmbIxRep) , seteq X Rep ix ixRep eqImIxRep where
  Kernel : X → X → Type ℓ
  Kernel x y = ix x ≊ ix y
  Rep : Type ℓ
  Rep = X / Kernel
  ixRep : Rep → V ℓ
  ixRep = invEq (setQuotUniversal setIsSet) (ix , λ _ _ → equivFun identityPrinciple)
  isEmbIxRep : isEmbedding ixRep
  isEmbIxRep = hasPropFibers→isEmbedding propFibers where
    propFibers : ∀ y → (a b : Σ[ p ∈ Rep ] (ixRep p ≡ y)) → a ≡ b
    propFibers y (p₁ , m) (p₂ , n) =
      ΣPathP {B = λ _ p → ixRep p ≡ y} (goal , isProp→PathP (λ _ → setIsSet _ _) _ _)
      where
      lemma : ∀ {p₁ p₂} → (p : ixRep Q.[ p₁ ] ≡ y) (q : ixRep Q.[ p₂ ] ≡ y) → Kernel p₁ p₂
      lemma m n = invEquiv identityPrinciple .fst (m ∙ sym n)
      prop₁ : ∀ p₁ → isProp ((ixRep p₁ ≡ y) → p₁ ≡ p₂)
      prop₁ p₁ = isPropΠ λ eq → squash/ p₁ p₂
      prop₂ : ∀ {p₁} p₂ → isProp ((ixRep p₂ ≡ y) → Q.[ p₁ ] ≡ p₂)
      prop₂ {p₁} p₂ = isPropΠ λ eq → squash/ Q.[ p₁ ] p₂
      goal : p₁ ≡ p₂
      goal = Q.elimProp prop₁ (λ p₁ m → Q.elimProp prop₂ (λ p₂ n → eq/ p₁ p₂ (lemma m n)) p₂ n) p₁ m

  eqImIxRep : eqImage ix ixRep
  eqImIxRep = (λ x → ∣ Q.[ x ] , refl ∣₁) , Q.elimProp (λ _ → P.squash₁) (λ b → ∣ b , refl ∣₁)

data DeepMonicPresentation (a : V ℓ) : Type (ℓ-suc ℓ) where
  dmp : (mp@((_ , ix , _) , _) : MonicPresentation a)
      → (rec : ∀ x → DeepMonicPresentation (ix x))
      → DeepMonicPresentation a

isPropDeepMonicPresentation : (a : V ℓ) → isProp (DeepMonicPresentation a)
isPropDeepMonicPresentation a (dmp mx rx) (dmp my ry) i = dmp (mx≡my i) (recprop i) where
  mx≡my : mx ≡ my
  mx≡my = isPropMonicPresentation a mx my
  recprop : PathP (λ i → (x : mx≡my i .fst .fst) → DeepMonicPresentation (mx≡my i .fst .snd .fst x)) rx ry
  recprop = toPathP (funExt λ x → isPropDeepMonicPresentation _ _ _)

V-deeprepr : (a : V ℓ) → DeepMonicPresentation a
V-deeprepr = elimProp isPropDeepMonicPresentation λ X ix rec → dmp (sett-repr X ix) (Q.elimProp (λ _ → isPropDeepMonicPresentation _) rec)

V-repr : (a : V ℓ) → MonicPresentation a
-- "Cannot eliminate fibrant type DeepMonicPresentation a
--  unless target type is also fibrant"
-- V-repr = let (dmp mp _) = (V-deeprepr a) in mp
V-repr a = case (V-deeprepr a) return (λ _ → MonicPresentation a) of λ { (dmp mp _) → mp }

private
  MonicDataF : Type (ℓ-suc ℓ) → Type (ℓ-suc ℓ)
  MonicDataF {ℓ} T = Embedding T ℓ

  V-fixpoint : V ℓ ≃ MonicDataF (V ℓ)
  V-fixpoint {ℓ} =
    V ℓ ≃⟨ invEquiv (Σ-contractSnd λ a → inhProp→isContr (V-repr a) (isPropMonicPresentation a)) ⟩
    (Σ[ a ∈ V ℓ ] MonicPresentation a) ≃⟨ boringswap ⟩
    (Σ[ (X , ix , _) ∈ MonicDataF (V ℓ) ] singl (sett X ix)) ≃⟨ Σ-contractSnd (λ _ → isContrSingl _) ⟩
    MonicDataF (V ℓ) ■ where
    boringswap : (Σ[ a ∈ V ℓ ] MonicPresentation a) ≃ (Σ[ (X , ix , _) ∈ MonicDataF (V ℓ) ] singl (sett X ix))
    boringswap = isoToEquiv (iso
      (λ (a , (X , ix , emb) , p) → (X , ix , emb) , a , sym p)
      (λ ((X , ix , emb) , a , p) → a , (X , ix , emb) , sym p)
      (λ _ → refl)
      λ _ → refl)

  -- note the problem of making this a datatype directly: MonicDataF is *not* strictly positive!

-- an elimination principle based on the monic presentation
elim : (B : V ℓ → Type ℓ')
     → ((X : Type ℓ) (ix : X → V ℓ) (emb : isEmbedding ix) (rec : ∀ x → B (ix x)) → B (sett X ix))
     → (a : V ℓ) → B a
elim B alg = elimDMP ∘ V-deeprepr where
  elimDMP : ∀ {a} → DeepMonicPresentation a → B a
  elimDMP (dmp ((X , ix , emb) , p) rec) = subst B (sym p) (alg X ix emb (λ x → elimDMP (rec x)))

⟪_⟫ : (s : V ℓ) → Type ℓ
⟪ X ⟫ = V-repr X .fst .fst

⟪_⟫↪ : (s : V ℓ) → ⟪ s ⟫ → V ℓ
⟪ X ⟫↪ = V-repr X .fst .snd .fst

isEmb⟪_⟫↪ : (s : V ℓ) → isEmbedding ⟪ s ⟫↪
isEmb⟪ X ⟫↪ = V-repr X .fst .snd .snd

⟪_⟫-represents : (s : V ℓ) → s ≡ sett ⟪ s ⟫ ⟪ s ⟫↪
⟪ X ⟫-represents = V-repr X .snd

isPropRepFiber : (a b : V ℓ) → isProp (repFiber ⟪ a ⟫↪ b)
isPropRepFiber a b =
  Embedding-into-isProp→isProp
    (Equiv→Embedding (repFiber≃fiber ⟪ a ⟫↪ b))
    (isEmbedding→hasPropFibers isEmb⟪ a ⟫↪ b)

-- while ∈ is hProp (ℓ-suc ℓ), ∈ₛ is in ℓ
_∈ₛ_ : (a b : V ℓ) → hProp ℓ
a ∈ₛ b = repFiber ⟪ b ⟫↪ a , isPropRepFiber b a

∈-asFiber : {a b : V ℓ} → ⟨ a ∈ b ⟩ → fiber ⟪ b ⟫↪ a
∈-asFiber {a = a} {b = b} =
  subst (λ br → ⟨ a ∈ br ⟩ → fiber ⟪ b ⟫↪ a) (sym ⟪ b ⟫-represents) asRep
  where
  asRep : ⟨ a ∈ sett ⟪ b ⟫ ⟪ b ⟫↪ ⟩ → fiber ⟪ b ⟫↪ a
  asRep = P.propTruncIdempotent≃ (isEmbedding→hasPropFibers isEmb⟪ b ⟫↪ a) .fst
∈-fromFiber : {a b : V ℓ} → fiber ⟪ b ⟫↪ a → ⟨ a ∈ b ⟩
∈-fromFiber {a = a} {b = b} = subst (λ br → ⟨ a ∈ br ⟩) (sym ⟪ b ⟫-represents) ∘ ∣_∣₁

∈∈ₛ : {a b : V ℓ} → ⟨ a ∈ b ⇔ a ∈ₛ b ⟩
∈∈ₛ {a = a} {b = b} = leftToRight , rightToLeft where
  repEquiv : repFiber ⟪ b ⟫↪ a ≃ fiber ⟪ b ⟫↪ a
  repEquiv = repFiber≃fiber ⟪ b ⟫↪ a
  leftToRight : ⟨ (a ∈ b) ⇒ a ∈ₛ b ⟩
  leftToRight a∈b = invEq repEquiv (∈-asFiber {b = b} a∈b)
  rightToLeft : ⟨ a ∈ₛ b ⇒ (a ∈ b) ⟩
  rightToLeft a∈ₛb = ∈-fromFiber {b = b} (equivFun repEquiv a∈ₛb)

ix∈ₛ : {X : Type ℓ} {ix : X → V ℓ}
     → (x : X) → ⟨ ix x ∈ₛ sett X ix ⟩
ix∈ₛ {X = X} {ix = ix} x = ∈∈ₛ {a = ix x} {b = sett X ix} .fst ∣ x , refl ∣₁

∈ₛ⟪_⟫↪_ : (a : V ℓ) (ix : ⟪ a ⟫) → ⟨ ⟪ a ⟫↪ ix ∈ₛ a ⟩
∈ₛ⟪ a ⟫↪ ix = ix , ∼refl (⟪ a ⟫↪ ix)

-- also here, the left side is in level (ℓ-suc ℓ) while the right is in ℓ
presentation : (a : V ℓ) → (Σ[ v ∈ V ℓ ] ⟨ v ∈ₛ a ⟩) ≃ ⟪ a ⟫
presentation a = isoToEquiv (iso into from (λ _ → refl) retr) where
  into : Σ[ v ∈ V _ ] ⟨ v ∈ₛ a ⟩ → ⟪ a ⟫
  into = fst ∘ snd
  from : ⟪ a ⟫ → Σ[ v ∈ V _ ] ⟨ v ∈ₛ a ⟩
  from ⟪a⟫ = ⟪ a ⟫↪ ⟪a⟫ , ∈ₛ⟪ a ⟫↪ ⟪a⟫
  retr : retract into from
  retr s = Σ≡Prop (λ v → (v ∈ₛ a) .snd) (equivFun identityPrinciple (s .snd .snd))

-- subset relation, once in level (ℓ-suc ℓ) and once in ℓ
_⊆_ : (a b : V ℓ) → hProp (ℓ-suc ℓ)
a ⊆ b = ∀[ x ] x ∈ₛ a ⇒ x ∈ₛ b

⊆-refl : (a : V ℓ) → ⟨ a ⊆ a ⟩
⊆-refl a = λ _ xa → xa

_⊆ₛ_ : (a b : V ℓ) → hProp ℓ
a ⊆ₛ b = ∀[ x ] ⟪ a ⟫↪ x ∈ₛ b

⊆⇔⊆ₛ : (a b : V ℓ) → ⟨ a ⊆ b ⇔ a ⊆ₛ b ⟩
⊆⇔⊆ₛ a b =
    (λ s → invEq curryEquiv s ∘ invEq (presentation a))
  , (λ s x xa → subst (λ x → ⟨ x ∈ₛ b ⟩) (equivFun identityPrinciple (xa .snd)) (s (xa .fst)))

-- the homotopy definition of equality as an hProp, we know this is equivalent to bisimulation
infix 4 _≡ₕ_
_≡ₕ_ : (a b : V ℓ) → hProp (ℓ-suc ℓ)
_≡ₕ_ a b = (a ≡ b) , setIsSet a b

-- extensionality
extensionality : ⟨ ∀[ a ∶ V ℓ ] ∀[ b ] (a ⊆ b) ⊓ (b ⊆ a) ⇒ (a ≡ₕ b) ⟩
extensionality {ℓ = ℓ} a b imeq = ⟪ a ⟫-represents ∙∙ settab ∙∙ sym ⟪ b ⟫-represents where
  abpth : Path (Embedding _ _) (⟪ a ⟫ , ⟪ a ⟫↪ , isEmb⟪ a ⟫↪) (⟪ b ⟫ , ⟪ b ⟫↪ , isEmb⟪ b ⟫↪)
  abpth = equivFun (EmbeddingIP _ _)
    ( (λ p → equivFun (repFiber≃fiber ⟪ b ⟫↪ p) ∘ imeq .fst p ∘ invEq (repFiber≃fiber ⟪ a ⟫↪ p))
    , (λ p → equivFun (repFiber≃fiber ⟪ a ⟫↪ p) ∘ imeq .snd p ∘ invEq (repFiber≃fiber ⟪ b ⟫↪ p))
    )
  settab : sett ⟪ a ⟫ ⟪ a ⟫↪ ≡ sett ⟪ b ⟫ ⟪ b ⟫↪
  settab i = sett (abpth i .fst) (abpth i .snd .fst)

extInverse : ⟨ ∀[ a ∶ V ℓ ] ∀[ b ] (a ≡ₕ b) ⇒ (a ⊆ b) ⊓ (b ⊆ a) ⟩
extInverse a b a≡b = subst (λ b → ⟨ (a ⊆ b) ⊓ (b ⊆ a) ⟩) a≡b (⊆-refl a , ⊆-refl a)

set≡-characterization : {a b : V ℓ} → (a ≡ₕ b) ≡ (a ⊆ b) ⊓ (b ⊆ a)
set≡-characterization = ⇔toPath (extInverse _ _) (extensionality _ _)


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

open import Definition.Typed.EqualityRelation

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

open import Definition.Typed
open import Definition.Typed.Properties
import Definition.Typed.Weakening as Wk
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Reflexivity
open import Definition.LogicalRelation.Properties.Universe
open import Definition.LogicalRelation.Properties.Escape

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Weak head expansion of reducible types.
redSubst* : ∀ {A B l Γ}
          → Γ ⊢ A ⇒* B
          → Γ ⊩⟨ l ⟩ B
          → ∃ λ ([A] : Γ ⊩⟨ l ⟩ A)
          → Γ ⊩⟨ l ⟩ A ≡ B / [A]
redSubst* D (Uᵣ′ l′ l< ⊢Γ) rewrite redU* D =
  Uᵣ′ l′ l< ⊢Γ , PE.refl
redSubst* D (ℕᵣ [ ⊢B , ⊢ℕ , D′ ]) =
  let ⊢A = redFirst* D
  in  ℕᵣ ([ ⊢A , ⊢ℕ , D ⇨* D′ ]) , D′
redSubst* D (Emptyᵣ [ ⊢B , ⊢Empty , D′ ]) =
  let ⊢A = redFirst* D
  in  Emptyᵣ ([ ⊢A , ⊢Empty , D ⇨* D′ ]) , D′
redSubst* D (Unitᵣ [ ⊢B , ⊢Unit , D′ ]) =
  let ⊢A = redFirst* D
  in  Unitᵣ ([ ⊢A , ⊢Unit , D ⇨* D′ ]) , D′
redSubst* D (ne′ K [ ⊢B , ⊢K , D′ ] neK K≡K) =
  let ⊢A = redFirst* D
  in  (ne′ K [ ⊢A , ⊢K , D ⇨* D′ ] neK K≡K)
  ,   (ne₌ _ [ ⊢B , ⊢K , D′ ] neK K≡K)
redSubst* D (Bᵣ′ W F G [ ⊢B , ⊢ΠFG , D′ ] ⊢F ⊢G A≡A [F] [G] G-ext) =
  let ⊢A = redFirst* D
  in  (Bᵣ′ W F G [ ⊢A , ⊢ΠFG , D ⇨* D′ ] ⊢F ⊢G A≡A [F] [G] G-ext)
  ,   (B₌ _ _ D′ A≡A (λ ρ ⊢Δ → reflEq ([F] ρ ⊢Δ))
        (λ ρ ⊢Δ [a] → reflEq ([G] ρ ⊢Δ [a])))
redSubst* D (emb 0<1 x) with redSubst* D x
redSubst* D (emb 0<1 x) | y , y₁ = emb 0<1 y , y₁

-- Weak head expansion of reducible terms.
redSubst*Term : ∀ {A t u l Γ}
              → Γ ⊢ t ⇒* u ∷ A
              → ([A] : Γ ⊩⟨ l ⟩ A)
              → Γ ⊩⟨ l ⟩ u ∷ A / [A]
              → Γ ⊩⟨ l ⟩ t ∷ A / [A]
              × Γ ⊩⟨ l ⟩ t ≡ u ∷ A / [A]
redSubst*Term t⇒u (Uᵣ′ .⁰ 0<1 ⊢Γ) (Uₜ A [ ⊢t , ⊢u , d ] typeA A≡A [u]) =
  let [d]  = [ ⊢t , ⊢u , d ]
      [d′] = [ redFirst*Term t⇒u , ⊢u , t⇒u ⇨∷* d ]
      q = redSubst* (univ* t⇒u) (univEq (Uᵣ′ ⁰ 0<1 ⊢Γ) (Uₜ A [d] typeA A≡A [u]))
  in Uₜ A [d′] typeA A≡A (proj₁ q)
  ,  Uₜ₌ A A [d′] [d] typeA typeA A≡A (proj₁ q) [u] (proj₂ q)
redSubst*Term t⇒u (ℕᵣ D) (ℕₜ n [ ⊢u , ⊢n , d ] n≡n prop) =
  let A≡ℕ  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡ℕ
      t⇒u′ = conv* t⇒u A≡ℕ
  in  ℕₜ n [ ⊢t , ⊢n , t⇒u′ ⇨∷* d ] n≡n prop
  ,   ℕₜ₌ n n [ ⊢t , ⊢n , t⇒u′ ⇨∷* d ] [ ⊢u , ⊢n , d ]
          n≡n (reflNatural-prop prop)
redSubst*Term t⇒u (Emptyᵣ D) (Emptyₜ n [ ⊢u , ⊢n , d ] n≡n prop) =
  let A≡Empty  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡Empty
      t⇒u′ = conv* t⇒u A≡Empty
  in  Emptyₜ n [ ⊢t , ⊢n , t⇒u′ ⇨∷* d ] n≡n prop
  ,   Emptyₜ₌ n n [ ⊢t , ⊢n , t⇒u′ ⇨∷* d ] [ ⊢u , ⊢n , d ]
          n≡n (reflEmpty-prop prop)
redSubst*Term t⇒u (Unitᵣ D) (Unitₜ n [ ⊢u , ⊢n , d ] prop) =
  let A≡Unit  = subset* (red D)
      ⊢t   = conv (redFirst*Term t⇒u) A≡Unit
      t⇒u′ = conv* t⇒u A≡Unit
  in  Unitₜ n [ ⊢t , ⊢n , t⇒u′ ⇨∷* d ] prop
  ,   Unitₜ₌ ⊢t ⊢u
redSubst*Term t⇒u (ne′ K D neK K≡K) (neₜ k [ ⊢t , ⊢u , d ] (neNfₜ neK₁ ⊢k k≡k)) =
  let A≡K  = subset* (red D)
      [d]  = [ ⊢t , ⊢u , d ]
      [d′] = [ conv (redFirst*Term t⇒u) A≡K , ⊢u , conv* t⇒u A≡K ⇨∷* d ]
  in  neₜ k [d′] (neNfₜ neK₁ ⊢k k≡k) , neₜ₌ k k [d′] [d] (neNfₜ₌ neK₁ neK₁ k≡k)
redSubst*Term {A} {t} {u} {l} {Γ} t⇒u (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                  [u]@(Πₜ f [d]@([ ⊢t , ⊢u , d ]) funcF f≡f [f] [f]₁) =
  let A≡ΠFG = subset* (red D)
      t⇒u′  = conv* t⇒u A≡ΠFG
      [d′] = [ conv (redFirst*Term t⇒u) A≡ΠFG , ⊢u , conv* t⇒u A≡ΠFG ⇨∷* d ]
      [u′] = Πₜ f [d′] funcF f≡f [f] [f]₁
  in  [u′]
  ,   Πₜ₌ f f [d′] [d] funcF funcF f≡f [u′] [u]
          (λ [ρ] ⊢Δ [a] → reflEqTerm ([G] [ρ] ⊢Δ [a]) ([f]₁ [ρ] ⊢Δ [a]))
redSubst*Term {A} {t} {u} {l} {Γ} t⇒u (Σᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                  [u]@(Σₜ p [d]@([ ⊢t , ⊢u , d ]) pProd p≅p [fst] [snd]) =
  let A≡ΣFG = subset* (red D)
      t⇒u′  = conv* t⇒u A≡ΣFG
      [d′] = [ conv (redFirst*Term t⇒u) A≡ΣFG , ⊢u , conv* t⇒u A≡ΣFG ⇨∷* d ]
      [u′] = Σₜ p [d′] pProd p≅p [fst] [snd]
  in  [u′]
  ,   Σₜ₌ p p [d′] [d] pProd pProd p≅p [u′] [u] [fst] [fst]
          (reflEqTerm ([F] Wk.id (wf ⊢F)) [fst])
          (reflEqTerm ([G] Wk.id (wf ⊢F) [fst]) [snd])
redSubst*Term t⇒u (emb 0<1 x) [u] = redSubst*Term t⇒u x [u]

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

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


{-# OPTIONS --cubical #-}

module Erased-cubical-Open-public.Cubical where

-- It instantiates and exports code from
-- Erased-cubical-Open-public.Erased.

open import Erased-cubical-Open-public.Erased Set public


-- Andreas 2016-01-06

-- {-# OPTIONS -v error.checkclause:60 #-}

data D : Set where
  c : D

test : (x y z : D) → Set
test _ c _ with D
test x y z | _ = D

-- Expected output: clause should be printed as is in error message,
-- including underscore patterns.


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

module Erased-cubical.Without-K where

data D : Set where
  c : D


------------------------------------------------------------------------
-- "Equational" reasoning combinator setup
------------------------------------------------------------------------

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

open import Prelude

open import Labelled-transition-system

module Bisimilarity.Classical.Equational-reasoning-instances
         {ℓ} {lts : LTS ℓ} where

open import Bisimilarity.Classical lts

open import Equational-reasoning

instance

  reflexive∼ : Reflexive _∼_
  reflexive∼ = is-reflexive reflexive-∼

  symmetric∼ : Symmetric _∼_
  symmetric∼ = is-symmetric symmetric-∼

  trans∼∼ : Transitive _∼_ _∼_
  trans∼∼ = is-transitive transitive-∼

  convert∼∼ : Convertible _∼_ _∼_
  convert∼∼ = is-convertible id


module Issue4373.A where

postulate
  T : Set
  instance t : T


-- Modified: Andreas, 2011-04-11 freezing metas, removed unused uni.poly

{-# OPTIONS --guardedness-preserving-type-constructors #-}

module UnusedArgsInPositivity where

open import Common.Coinduction

module Ex₁ where
  data Unit : Set where
    unit : Unit

  unused : Set → Unit → Set → Set
  unused X unit Y = Y

  mutual

    data D : Set where
      d : (x : Unit) → (El x x → D) → D

    El : Unit → Unit → Set
    El unit x = unused D x Unit

module Ex₂ where

  data Maybe (A : Set) : Set where

  data Rec (A : ∞ Set) : Set where
    fold : ♭ A → Rec A

  mutual

    data Data : Set where
      maybe : ∞ Data -> Data
      sigma : (A : Data) → (El A → Data) -> Data

    El : Data → Set
    El (maybe A) = Rec (♯ Maybe (El (♭ {A = Data} A)))
    El (sigma A B) = El A

  {- This fails for 2 reasons:
     1. Rec doesn't preserve guardedness (hence -no-termination-check)
     2. Data "appears" in the definition of El
  The 1st one is now fixed.
  It is not clear how to fix the 2nd. Irrelevant parameters?
  -}

{-
/Users/txa/current/AIMXI/DataGuard.agda:15,8-12
Data is not strictly positive, because it occurs in the type of the
constructor sigma in the definition of Data, which occurs in the
second argument to ♭ in the first argument to El in the second
argument to Maybe in the first clause in the definition of
.DataGuard.♯-0, which occurs in the third clause in the definition
of El.
-}

module Ex₃ where
  data D (A : Set) : Set where
    d : D A

  data E : Set where
    e : (D E → E) → E


open import Common.Prelude
open import Common.Equality

test : "foo" ≡ "bar" → Set₁
test refl = Set


{-

This file contains:
  - Path lemmas used in the colimit-equivalence proof.

Verbose, indeed. But should be simple. The length mainly thanks to:
  - Degenerate cubes that seem "obvious", but have to be constructed manually;
  - J rule is cubersome to use, especially when iteratively applied,
    also it is overcomplicated to construct JRefl in nested cases.

-}
{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.HITs.James.Inductive.Coherence where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Function

private
  variable
    ℓ ℓ' : Level

-- Lots of degenerate cubes used as intial input to J rule

private
  module _
    {A : Type ℓ}(a : A) where

    degenerate1 : (i j k : I) → A
    degenerate1 i j k =
      hfill (λ k → λ
        { (i = i0) → a
        ; (i = i1) → doubleCompPath-filler (refl {x = a}) refl refl k j
        ; (j = i0) → a
        ; (j = i1) → a})
      (inS a) k

    degenerate1' : (i j k : I) → A
    degenerate1' i j k =
      hfill (λ k → λ
        { (i = i0) → a
        ; (i = i1) → compPath-filler (refl {x = a}) refl k j
        ; (j = i0) → a
        ; (j = i1) → a})
      (inS a) k

    degenerate1'' : (i j k : I) → A
    degenerate1'' i j k =
      hfill (λ k → λ
        { (i = i0) → a
        ; (i = i1) → compPath-filler (refl {x = a}) (refl ∙ refl) k j
        ; (j = i0) → a
        ; (j = i1) → degenerate1 i k i1})
      (inS a) k

    module _
      {B : Type ℓ'}(f : A → B) where

      degenerate2 : (i j k : I) → B
      degenerate2 i j k =
        hfill (λ k → λ
          { (i = i0) → f a
          ; (i = i1) → doubleCompPath-filler (refl {x = f a}) refl refl k j
          ; (j = i0) → f a
          ; (j = i1) → f a })
        (inS (f a)) k

      degenerate3 : (i j k : I) → B
      degenerate3 i j k =
        hfill (λ k → λ
          { (i = i0) → f (doubleCompPath-filler (refl {x = a}) refl refl k j)
          ; (i = i1) → doubleCompPath-filler (refl {x = f a}) refl refl k j
          ; (j = i0) → f a
          ; (j = i1) → f a })
        (inS (f a)) k

      someCommonDegenerateCube : (i j k : I) → B
      someCommonDegenerateCube i j k =
        hcomp (λ l → λ
          { (i = i0) → f a
          ; (i = i1) → degenerate3 k j l
          ; (j = i0) → f a
          ; (j = i1) → f a
          ; (k = i0) → f (degenerate1 i j l)
          ; (k = i1) → degenerate2 i j l })
        (f a)

    degenerate4 : (i j k : I) → A
    degenerate4 i j k =
      hfill (λ k → λ
        { (i = i0) → compPath-filler (refl {x = a}) (refl ∙∙ refl ∙∙ refl) k j
        ; (i = i1) → doubleCompPath-filler (refl {x = a}) refl refl j k
        ; (j = i0) → a
        ; (j = i1) → (refl {x = a} ∙∙ refl ∙∙ refl) k })
      (inS a) k

    degenerate5 : (i j k : I) → A
    degenerate5 i j k =
      hcomp (λ l → λ
        { (i = i0) → compPath-filler (refl {x = a}) (refl ∙∙ refl ∙∙ refl) k j
        ; (i = i1) → doubleCompPath-filler (refl {x = a}) refl refl (j ∧ ~ l) k
        ; (j = i0) → a
        ; (j = i1) → doubleCompPath-filler (refl {x = a}) refl refl (~ i ∨ ~ l) k
        ; (k = i0) → a
        ; (k = i1) → degenerate4 i j i1 })
      (degenerate4 i j k)

    degenerate5' : (i j k : I) → A
    degenerate5' i j k =
      hfill (λ k → λ
        { (i = i0) → doubleCompPath-filler (refl {x = a}) refl (refl ∙ refl) k j
        ; (i = i1) → a
        ; (j = i0) → a
        ; (j = i1) → compPath-filler (refl {x = a}) refl (~ i) k })
      (inS a) k

-- Cubes of which mostly are constructed by J rule

module _
  {A : Type ℓ}{a : A} where

  coh-helper-refl :
    (q' : a ≡ a)(h : refl ≡ q')
    → refl ≡ refl ∙∙ refl ∙∙ q'
  coh-helper-refl q' h i j =
    hcomp (λ k → λ
      { (i = i0) → a
      ; (i = i1) → doubleCompPath-filler refl refl q' k j
      ; (j = i0) → a
      ; (j = i1) → h i k })
    a

  coh-helper' :
    (b : A)(p : a ≡ b)
    (c : A)(q : b ≡ c)
    (q' : b ≡ c)(r : PathP (λ i → p i ≡ q i) p q')
    → refl ≡ (sym q) ∙∙ refl ∙∙ q'
  coh-helper' = J> J> coh-helper-refl

  coh-helper'-Refl1 : coh-helper' _ refl ≡ J> coh-helper-refl
  coh-helper'-Refl1 = transportRefl _

  coh-helper'-Refl2 : coh-helper' _ refl _ refl ≡ coh-helper-refl
  coh-helper'-Refl2 = (λ i → coh-helper'-Refl1 i _ refl) ∙ transportRefl _

  coh-helper :
    {b c : A}(p : a ≡ b)(q q' : b ≡ c)
    (h : PathP (λ i → p i ≡ q i) p q')
    → refl ≡ (sym q) ∙∙ refl ∙∙ q'
  coh-helper p = coh-helper' _ p _

  coh-helper-Refl : coh-helper-refl ≡ coh-helper refl refl
  coh-helper-Refl = sym coh-helper'-Refl2

module _
  {A : Type ℓ}{B : Type ℓ'}{a b c d : A} where

  doubleCompPath-cong-filler :
    {a' b' c' d' : B} (f : A → B)
    {pa : f a ≡ a'}{pb : f b ≡ b'}{pc : f c ≡ c'}{pd : f d ≡ d'}
    (p : a ≡ b)(q : b ≡ c)(r : c ≡ d)
    {p' : a' ≡ b'}{q' : b' ≡ c'}{r' : c' ≡ d'}
    (h   : PathP (λ i → pa i ≡ pb i) (cong f p) p')
    (h'  : PathP (λ i → pb i ≡ pc i) (cong f q) q')
    (h'' : PathP (λ i → pc i ≡ pd i) (cong f r) r')
    → (i j k : I) → B
  doubleCompPath-cong-filler f p q r {p' = p'} {q' = q'} {r' = r'}  h h' h'' i j k =
    hfill (λ k → λ
      { (i = i0) → f (doubleCompPath-filler p q r k j)
      ; (i = i1) → doubleCompPath-filler p' q' r' k j
      ; (j = i0) → h   i (~ k)
      ; (j = i1) → h'' i  k })
    (inS (h' i j)) k

  doubleCompPath-cong : (f : A → B)
    (p : a ≡ b)(q : b ≡ c)(r : c ≡ d)
    → cong f (p ∙∙ q ∙∙ r) ≡ cong f p ∙∙ cong f q ∙∙ cong f r
  doubleCompPath-cong f p q r i j =
    doubleCompPath-cong-filler f
      {pa = refl} {pb = refl} {pc = refl} {pd = refl}
      p q r refl refl refl i j i1

module _
  {A : Type ℓ}{a b c : A} where

  comp-cong-square' :
    (p : a ≡ b)(q : a ≡ c)
    (r : b ≡ c)(h : r ≡ sym p ∙∙ refl ∙∙ q)
    → p ∙ r ≡ q
  comp-cong-square' p q r h i j =
    hcomp (λ k → λ
      { (i = i0) → compPath-filler p r k j
      ; (i = i1) → doubleCompPath-filler (sym p) refl q j k
      ; (j = i0) → a
      ; (j = i1) → h i k })
    (p j)

  module _
    {B : Type ℓ'} where

    comp-cong-square : (f : A → B)
      (p : a ≡ b)(q : b ≡ c)
      → cong f (p ∙ q) ≡ cong f p ∙ cong f q
    comp-cong-square f p q i j =
      hcomp (λ k → λ
        { (i = i0) → f (compPath-filler p q k j)
        ; (i = i1) → compPath-filler (cong f p) (cong f q) k j
        ; (j = i0) → f a
        ; (j = i1) → f (q k) })
      (f (p j))

module _
  {A : Type ℓ}{B : Type ℓ'}{a b c : A}
  (f : A → B)(p : a ≡ b)
  (q : f a ≡ f c)(r : b ≡ c)
  (h : cong f r ≡ sym (cong f p) ∙∙ refl ∙∙ q) where

  comp-cong-helper-filler : (i j k : I) → B
  comp-cong-helper-filler i j k =
    hfill (λ k → λ
      { (i = i0) → comp-cong-square f p r (~ k) j
      ; (i = i1) → q j
      ; (j = i0) → f a
      ; (j = i1) → f c })
    (inS (comp-cong-square' _ _ _ h i j)) k

  comp-cong-helper : cong f (p ∙ r) ≡ q
  comp-cong-helper i j =
    comp-cong-helper-filler i j i1

module _
  {A : Type ℓ}{a : A} where

  push-helper-refl :
    (q' : a ≡ a)(h : refl ≡ q')
    → refl ≡ refl ∙ q'
  push-helper-refl q' h i j =
    hcomp (λ k → λ
      { (i = i0) → a
      ; (i = i1) → compPath-filler refl q' k j
      ; (j = i0) → a
      ; (j = i1) → h i k })
    a

  push-helper' :
    (b : A)(p : a ≡ b)
    (c : A)(q : b ≡ c)
    (q' : c ≡ c)(h : refl ≡ q')
    → PathP (λ i → p i ≡ q i) p (q ∙ q')
  push-helper' = J> J> push-helper-refl

  push-helper'-Refl1 : push-helper' _ refl ≡ J> push-helper-refl
  push-helper'-Refl1 = transportRefl _

  push-helper'-Refl2 : push-helper' _ refl _ refl ≡ push-helper-refl
  push-helper'-Refl2 = (λ i → push-helper'-Refl1 i _ refl) ∙ transportRefl _

  push-helper : {b c : A}
    (p : a ≡ b)(q : b ≡ c)(q' : c ≡ c)(h : refl ≡ q')
    → PathP (λ i → p i ≡ q i) p (q ∙ q')
  push-helper p = push-helper' _ p _

  push-helper-Refl : push-helper-refl ≡ push-helper refl refl
  push-helper-Refl = sym push-helper'-Refl2

module _
  {A : Type ℓ}{B : Type ℓ'}{a : A}(f : A → B) where

  push-helper-cong-Type : {b c : A}
    (p : a ≡ b)(q : b ≡ c)
    (q' : c ≡ c)(sqr : refl ≡ q')
    → Type _
  push-helper-cong-Type p q q' sqr =
    SquareP
      (λ i j → f (push-helper p q _ sqr i j)
          ≡ push-helper (cong f p) (cong f q) _ (λ i j → f (sqr i j)) i j)
      (λ i j → f (p i))
      (λ i j → comp-cong-square f q q' j i)
      (λ i j → f (p i)) (λ i j → f (q i))

  push-helper-cong-refl : push-helper-cong-Type refl refl refl refl
  push-helper-cong-refl =
    transport (λ t →
      SquareP
        (λ i j → f (push-helper-Refl t _ (λ i j → a) i j)
          ≡ push-helper-Refl t _ (λ i j → f a) i j)
        (λ i j → f a)
        (λ i j → comp-cong-square f (refl {x = a}) refl j i)
        (λ i j → f a) (λ i j → f a))
        (λ i j k → someCommonDegenerateCube a f i j k)

  push-helper-cong' :
    (b : A)(p : a ≡ b)
    (c : A)(q : b ≡ c)
    (q' : c ≡ c)(sqr : refl ≡ q')
    → push-helper-cong-Type p q q' sqr
  push-helper-cong' = J> J> J> push-helper-cong-refl

  push-helper-cong : ∀ {b c} p q q' sqr → push-helper-cong-Type {b = b} {c = c} p q q' sqr
  push-helper-cong p = push-helper-cong' _ p _

module _
  {A : Type ℓ}{a : A} where

  push-coh-helper-Type : {b c : A}
    (p : a ≡ b)(q q' : b ≡ c)
    (sqr : PathP (λ i → p i ≡ q i) p q')
    → Type _
  push-coh-helper-Type p q q' sqr =
    SquareP
      (λ i j → push-helper p q _ (coh-helper _ _ _ sqr) i j ≡ sqr i j)
      (λ i j → p i)
      (λ i j → comp-cong-square' q q' _ refl j i)
      (λ i j → p i) (λ i j → q i)

  push-coh-helper-refl' :
    SquareP
      (λ i j → push-helper-refl _ (coh-helper-refl _ (λ i j → a)) i j ≡ a)
      (λ i j → a)
      (λ i j → comp-cong-square' (refl {x = a}) refl _ refl j i)
      (λ i j → a)
      (λ i j → a)
  push-coh-helper-refl' i j k =
    hcomp (λ l → λ
      { (i = i0) → a
      ; (i = i1) → degenerate5 a k j l
      ; (j = i0) → a
      ; (j = i1) → degenerate1 a i l (~ k)
      ; (k = i0) → degenerate1'' a i j l
      ; (k = i1) → a })
    a

  push-coh-helper-refl : push-coh-helper-Type refl refl refl refl
  push-coh-helper-refl =
    transport (λ t →
      SquareP
      (λ i j → push-helper-Refl t _ (coh-helper-Refl t _ (λ i j → a)) i j ≡ a)
      (λ i j → a)
      (λ i j → comp-cong-square' (refl {x = a}) refl _ refl j i)
      (λ i j → a) (λ i j → a)) push-coh-helper-refl'

  push-coh-helper' :
    (b : A)(p : a ≡ b)
    (c : A)(q : b ≡ c)
    (q' : b ≡ c)(sqr : PathP (λ i → p i ≡ q i) p q')
    → push-coh-helper-Type p q q' sqr
  push-coh-helper' = J> J> J> push-coh-helper-refl

  push-coh-helper : ∀ {b c} p q q' sqr → push-coh-helper-Type {b = b} {c = c} p q q' sqr
  push-coh-helper p q q' sqr = push-coh-helper' _ p _ q q' sqr

module _
  {A : Type ℓ}{a : A} where

  push-square-helper-refl :
    refl ∙∙ refl ∙∙ (refl ∙ refl) ≡ refl {x = a}
  push-square-helper-refl i j = degenerate5' a i j i1

  push-square-helper' :
    (b : A)(q  : a ≡ b)
    (c : A)(q' : b ≡ c)
    → sym q ∙∙ refl ∙∙ (q ∙ q') ≡ q'
  push-square-helper' = J> J> push-square-helper-refl

  push-square-helper'-Refl1 : push-square-helper' _ refl ≡ J> push-square-helper-refl
  push-square-helper'-Refl1 = transportRefl _

  push-square-helper'-Refl2 : push-square-helper' _ refl _ refl ≡ push-square-helper-refl
  push-square-helper'-Refl2 = (λ i → push-square-helper'-Refl1 i _ refl) ∙ transportRefl _

  push-square-helper : {b c : A}
    (q : a ≡ b)(q' : b ≡ c)
    → sym q ∙∙ refl ∙∙ (q ∙ q') ≡ q'
  push-square-helper p = push-square-helper' _ p _

  push-square-helper-Refl : push-square-helper-refl ≡ push-square-helper refl refl
  push-square-helper-Refl = sym push-square-helper'-Refl2

module _
  {A : Type ℓ}{a : A} where

  coh-cube-helper-Type :
    {b c : A}(p : a ≡ b)(q : b ≡ c)
    (q' : c ≡ c)(sqr : refl ≡ q')
    → Type _
  coh-cube-helper-Type {c = c} p q q' sqr =
    SquareP
      (λ i j → coh-helper _ _ _ (push-helper p q q' sqr) i j ≡ sqr i j)
      (λ i j → c)
      (λ i j → push-square-helper q q' j i)
      (λ i j → c) (λ i j → c)

  coh-cube-helper-refl' :
    SquareP
      (λ i j → coh-helper-refl _ (push-helper-refl refl (λ i j → a)) i j ≡ a)
      (λ i j → a)
      (λ i j → push-square-helper-refl {a = a} j i)
      (λ i j → a) (λ i j → a)
  coh-cube-helper-refl' i j k =
    hcomp (λ l → λ
      { (i = i0) → a
      ; (i = i1) → degenerate5' a k j l
      ; (j = i0) → a
      ; (j = i1) → degenerate1' a i l (~ k)
      ; (k = i0) → degenerate1'' a i j l
      ; (k = i1) → a })
    a

  coh-cube-helper-refl : coh-cube-helper-Type refl refl refl refl
  coh-cube-helper-refl =
    transport (λ t →
      SquareP
      (λ i j → coh-helper-Refl t _ (push-helper-Refl t refl (λ i j → a)) i j ≡ a)
      (λ i j → a)
      (λ i j → push-square-helper-Refl {a = a} t j i)
      (λ i j → a) (λ i j → a)) coh-cube-helper-refl'

  coh-cube-helper' :
    (b : A)(p : a ≡ b)
    (c : A)(q : b ≡ c)
    (q' : c ≡ c)(sqr : refl ≡ q')
    → coh-cube-helper-Type p q q' sqr
  coh-cube-helper' = J> J> J> coh-cube-helper-refl

  coh-cube-helper : ∀ {b c} p q q' sqr → coh-cube-helper-Type {b = b} {c = c} p q q' sqr
  coh-cube-helper p q q' sqr = coh-cube-helper' _ p _ q q' sqr

module _
  {A : Type ℓ}{B : Type ℓ'}{a : A}(f : A → B) where

  coh-helper-cong-Type : {b c : A}{a' b' c' : B}
    (pa : f a ≡ a')(pb : f b ≡ b')(pc : f c ≡ c')
    {p  : a  ≡ b }(q  r  : b  ≡ c )
    {p' : a' ≡ b'}{q' r' : b' ≡ c'}
    (h   : PathP (λ i → pa i ≡ pb i) (cong f p) p')
    (h'  : PathP (λ i → pb i ≡ pc i) (cong f q) q')
    (h'' : PathP (λ i → pb i ≡ pc i) (cong f r) r')
    (sqr  : PathP (λ i → p  i ≡ q  i) p  r)
    (sqr' : PathP (λ i → p' i ≡ q' i) p' r')
    → Type _
  coh-helper-cong-Type pa pb pc q r h h' h'' sqr sqr' =
    SquareP
      (λ i j → f (coh-helper _ _ _ sqr i j) ≡ coh-helper _ _ _ (λ i j → sqr' i j) i j)
      (λ i j → pc j)
      (λ i j → doubleCompPath-cong-filler f (sym q) refl r (λ i j → h' i (~ j)) (λ i j → pb i) h'' j i i1)
      (λ i j → pc j) (λ i j → pc j)

  coh-helper-cong-refl : coh-helper-cong-Type refl refl refl refl refl refl refl refl refl refl
  coh-helper-cong-refl =
    transport (λ t →
      SquareP
      (λ i j → f (coh-helper-Refl t _ (λ i j → a) i j) ≡ coh-helper-Refl t _ (λ i j → f a) i j)
      (λ i j → f a)
      (λ i j → doubleCompPath-cong-filler f refl refl refl (λ i j → f a) (λ i j → f a) (λ i j → f a) j i i1)
      (λ i j → f a) (λ i j → f a))
      (λ i j k → someCommonDegenerateCube a f i j k)

  coh-helper-cong' :
    (b : A)(p : a ≡ b)
    (c : A)(q : b ≡ c)
    (a' : B)(pa : f a ≡ a')
    (b' : B)(pb : f b ≡ b')
    (c' : B)(pc : f c ≡ c')
    (r : b ≡ c)(sqr  : PathP (λ i → p  i ≡ q  i) p r)
    (p' : a' ≡ b')(h   : PathP (λ i → pa i ≡ pb i) (cong f p) p')
    (q' : b' ≡ c')(h'  : PathP (λ i → pb i ≡ pc i) (cong f q) q')
    (r' : b' ≡ c')(h'' : PathP (λ i → pb i ≡ pc i) (cong f r) r')
    (sqr' : PathP (λ i → p' i ≡ q' i) p' r')
    (hsqr : SquareP (λ i j → h i j ≡ h' i j) (λ i j → f (sqr i j)) sqr' h h'')
    → coh-helper-cong-Type pa pb pc q r h h' h'' sqr sqr'
  coh-helper-cong' = J> J> J> J> J> J> J> J> J> J> coh-helper-cong-refl

  coh-helper-cong :
    ∀ {b c a' b' c' pa pb pc} p q r {p' q' r' h h' h''} sqr {sqr'}
    (hsqr : SquareP (λ i j → f (sqr i j) ≡ sqr' i j)
      (λ i j → h j i) (λ i j → h'' j i) (λ i j → h j i) (λ i j → h' j i))
    → coh-helper-cong-Type {b = b} {c = c} {a' = a'} {b' = b'} {c' = c'}
        pa pb pc q r {p' = p'} {q' = q'} {r' = r'} h h' h'' sqr sqr'
  coh-helper-cong p q r sqr hsqr =
    coh-helper-cong' _ p _ q _ _ _ _ _ _ r sqr _ _ _ _ _ _ _ (λ i j k → hsqr j k i)


------------------------------------------------------------------------
-- Compiler correctness
------------------------------------------------------------------------

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

module Lambda.Simplified.Delay-monad.Compiler-correctness where

import Equality.Propositional as E
open import Prelude
open import Prelude.Size

open import Monad E.equality-with-J
open import Vec.Function E.equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity
open import Delay-monad.Monad

open import Lambda.Simplified.Compiler
open import Lambda.Simplified.Delay-monad.Interpreter
open import Lambda.Simplified.Delay-monad.Virtual-machine
open import Lambda.Simplified.Syntax
open import Lambda.Simplified.Virtual-machine

private
  module C = Closure Code
  module T = Closure Tm

-- Compiler correctness.

mutual

  ⟦⟧-correct :
    ∀ {i n} t {ρ : T.Env n} {c s}
      {k : T.Value → Delay (Maybe C.Value) ∞} →
    (∀ v → [ i ] exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≈ k v) →
    [ i ] exec ⟨ comp t c , s , comp-env ρ ⟩ ≈ ⟦ t ⟧ ρ >>= k

  ⟦⟧-correct (var x) {ρ} {c} {s} {k} hyp =
    exec ⟨ var x ∷ c , s , comp-env ρ ⟩                 ≳⟨⟩
    exec ⟨ c , val (comp-val (ρ x)) ∷ s , comp-env ρ ⟩  ≈⟨ hyp (ρ x) ⟩∼
    k (ρ x)                                             ∼⟨⟩
    ⟦ var x ⟧ ρ >>= k                                   ∎

  ⟦⟧-correct (ƛ t) {ρ} {c} {s} {k} hyp =
    exec ⟨ clo (comp t (ret ∷ [])) ∷ c , s , comp-env ρ ⟩   ≳⟨⟩
    exec ⟨ c , val (comp-val (T.ƛ t ρ)) ∷ s , comp-env ρ ⟩  ≈⟨ hyp (T.ƛ t ρ) ⟩∼
    k (T.ƛ t ρ)                                             ∼⟨⟩
    ⟦ ƛ t ⟧ ρ >>= k                                         ∎

  ⟦⟧-correct (t₁ · t₂) {ρ} {c} {s} {k} hyp =
    exec ⟨ comp t₁ (comp t₂ (app ∷ c)) , s , comp-env ρ ⟩      ≈⟨ (⟦⟧-correct t₁ λ v₁ → ⟦⟧-correct t₂ λ v₂ → ∙-correct v₁ v₂ hyp) ⟩∼

    (⟦ t₁ ⟧ ρ >>= λ v₁ → ⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂ >>= k)    ∼⟨ (⟦ t₁ ⟧ ρ ∎) >>=-cong (λ _ → associativity′ (⟦ t₂ ⟧ ρ) _ _) ⟩

    (⟦ t₁ ⟧ ρ >>= λ v₁ → (⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂) >>= k)  ∼⟨ associativity′ (⟦ t₁ ⟧ ρ) _ _ ⟩

    ⟦ t₁ · t₂ ⟧ ρ >>= k                                        ∎

  ∙-correct :
    ∀ {i n} v₁ v₂ {ρ : T.Env n} {c s}
      {k : T.Value → Delay (Maybe C.Value) ∞} →
    (∀ v → [ i ] exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩ ≈ k v) →
    [ i ] exec ⟨ app ∷ c
               , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s
               , comp-env ρ
               ⟩ ≈
          v₁ ∙ v₂ >>= k
  ∙-correct (T.ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} hyp =
    exec ⟨ app ∷ c
         , val (comp-val v₂) ∷ val (comp-val (T.ƛ t₁ ρ₁)) ∷ s
         , comp-env ρ
         ⟩                                                     ≈⟨ later (λ { .force →

      exec ⟨ comp t₁ (ret ∷ [])
           , ret c (comp-env ρ) ∷ s
           , cons (comp-val v₂) (comp-env ρ₁)
           ⟩                                                        ≡⟨ E.cong (λ ρ′ →
                                                                                exec ⟨ comp t₁ (ret ∷ []) , ret c (comp-env ρ) ∷ s , ρ′ ⟩) $
                                                                              E.sym comp-cons ⟩
      exec ⟨ comp t₁ (ret ∷ [])
           , ret c (comp-env ρ) ∷ s
           , comp-env (cons v₂ ρ₁)
           ⟩                                                        ≈⟨ ⟦⟧-correct t₁ (λ v →

        exec ⟨ ret ∷ []
             , val (comp-val v) ∷ ret c (comp-env ρ) ∷ s
             , comp-env (cons v₂ ρ₁)
             ⟩                                                           ≳⟨⟩

        exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩                   ≈⟨ hyp v ⟩∎

        k v                                                              ∎) ⟩∼

      ⟦ t₁ ⟧ (cons v₂ ρ₁) >>= k                                     ∎ }) ⟩∎

    T.ƛ t₁ ρ₁ ∙ v₂ >>= k                                       ∎

-- Note that the equality that is used here is syntactic.

correct :
  ∀ t →
  exec ⟨ comp t [] , [] , nil ⟩ ≈
  ⟦ t ⟧ nil >>= λ v → return (just (comp-val v))
correct t =
  exec ⟨ comp t [] , [] , nil ⟩                     ≡⟨ E.cong (λ ρ → exec ⟨ comp t [] , [] , ρ ⟩) $ E.sym comp-nil ⟩
  exec ⟨ comp t [] , [] , comp-env nil ⟩            ≈⟨ ⟦⟧-correct t (λ v → return (just (comp-val v)) ∎) ⟩
  (⟦ t ⟧ nil >>= λ v → return (just (comp-val v)))  ∎


module Values where

open import Data.Bool
open import Data.List
open import Data.List.All
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Relation.Binary.PropositionalEquality

open import Typing
open import Syntax
open import Global
open import Channel

mutual
-- a value indexed by a *relevant* session context, which is "used up" by the value
  data Val (G : SCtx) : Type → Set where
    VUnit : (inaG : Inactive G)
      → Val G TUnit
    VInt  : (i : ℕ)
      → (inaG : Inactive G)
      → Val G TInt
    VPair : ∀ {t₁ t₂ G₁ G₂}
      → (ss-GG₁G₂ : SSplit G G₁ G₂)
      → (v₁ : Val G₁ t₁)
      → (v₂ : Val G₂ t₂)
      → Val G (TPair t₁ t₂)
    VChan : ∀ {s}
      → (ce : ChannelEnd)
      → (cr : ChannelRef G ce s)
      → Val G (TChan s)
    VFun : ∀ {φ lu t₁ t₂}
      → (lu ≡ LL ⊎ All Unr φ)
      → (ϱ : VEnv G φ)
      → (e : Expr (t₁ ∷ φ) t₂)
      → Val G (TFun lu t₁ t₂)

  -- type environment-indexed value environment
  -- session context G describes the entire environment, it splits over all (channel) values
  data VEnv (G : SCtx) : TCtx → Set where
    vnil : (ina : Inactive G) → VEnv G []
    vcons : ∀{t φ G₁ G₂} → (ssp : SSplit G G₁ G₂) → (v : Val G₁ t) → (ϱ : VEnv G₂ φ) → VEnv G (t ∷ φ)

unrestricted-val :  ∀ {t G} → Unr t → Val G t → Inactive G
unrestricted-venv : ∀ {φ G} → All Unr φ → VEnv G φ → Inactive G

unrestricted-val UUnit (VUnit x) = x
unrestricted-val UInt (VInt i x) = x
unrestricted-val (UPair unrt unrt₁) (VPair x v v₁) =
  ssplit-inactive x (unrestricted-val unrt v) (unrestricted-val unrt₁ v₁)
unrestricted-val {TFun UU t₁ t₂} UFun (VFun (inj₁ ()) ϱ e)
unrestricted-val {TFun UU t₁ t₂} UFun (VFun (inj₂ unr-φ) ϱ e) = unrestricted-venv unr-φ ϱ

unrestricted-venv unr-φ (vnil ina) = ina
unrestricted-venv (px ∷ unr-φ) (vcons ssp v ϱ) =
  ssplit-inactive ssp (unrestricted-val px v) (unrestricted-venv unr-φ ϱ)

-- access a value in an indexed environment
access : ∀ {φ t} {G : SCtx} → VEnv G φ → t ∈ φ → ∃ λ G₁ → ∃ λ G₂ → Inactive G₂ × SSplit G G₁ G₂ × Val G₁ t
access (vcons ssp v ϱ) (here allUnr) =  _ , _ , unrestricted-venv allUnr ϱ , ssp , v
access (vcons ssp x₀ ϱ) (there unrX₀ x) with access ϱ x
access (vcons ssp x₀ ϱ) (there unrX₀ x) | G₁ , G₂ , inaG₂ , ssp12 , v with ssplit-compose4 ssp ssp12
... | Gi , ssp1 , ssp2 = G₁ , Gi , ssplit-inactive ssp2 (unrestricted-val unrX₀ x₀) inaG₂ , ssp1 , v

-- coerce a value to a supertype
coerce : ∀ {G t t'} → Val G t → SubT t t' → Val G t'
coerce (VUnit inaG) sub-unit = VUnit inaG
coerce (VInt i inaG) sub-int = VInt i inaG
coerce (VPair ss-GG₁G₂ v v₁) (sub-pair t≤t' t≤t'') = VPair ss-GG₁G₂ (coerce v t≤t') (coerce v₁ t≤t'')
coerce (VChan b vcr) (sub-chan s≲s') = VChan b (vcr-coerce vcr s≲s')
coerce (VFun lu ϱ e) (sub-fun t≤t' t≤t'') = VFun lu ϱ (expr-coerce e t≤t'' t≤t')

rewrite-ssplit : ∀ {G G' G₁ G₂} → G ≡ G' → SSplit G G₁ G₂ → SSplit G' G₁ G₂
rewrite-ssplit p ssp rewrite p = ssp

rewrite-ssplit1 : ∀ {G G₁ G₁' G₂} → G₁ ≡ G₁' → SSplit G G₁ G₂ → SSplit G G₁' G₂
rewrite-ssplit1 p ssp rewrite p = ssp

-- split environment according to type context split
split-env : ∀ {Φ Φ₁ Φ₂} {G : SCtx}
  → Split Φ Φ₁ Φ₂
  → VEnv G Φ
  → Σ (SCtx × SCtx) λ { (G₁ , G₂) → SSplit G G₁ G₂ × VEnv G₁ Φ₁ × VEnv G₂ Φ₂ }
split-env{G = G} [] (vnil ina) =  (G , G) , inactive-ssplit-trivial ina , vnil ina , vnil ina
split-env (dupl unrt sp) (vcons ssp v ϱ) with split-env sp ϱ | unrestricted-val unrt v
split-env (dupl unrt sp) (vcons ssp v ϱ) | (G₁' , G₂') , ssp12 , ϱ₁' , ϱ₂' | unr-v rewrite inactive-left-ssplit ssp unr-v with ssplit-compose4 ssp ssp12 | ssplit-compose3 ssp ssp12
... | Gi , ssp-GG1Gi , ssp-GiG1G2' | Gi-1 , ssp-GGiG2' , ssp-GiG1G1' =
  let p₁ = (inactive-left-ssplit ssp-GiG1G1' unr-v) in
  let p₂ = (inactive-left-ssplit ssp-GiG1G2' unr-v) in
  (G₁' , G₂') ,  ssp12 , vcons (rewrite-ssplit p₁ ssp-GiG1G1') v ϱ₁' , vcons (rewrite-ssplit p₂ ssp-GiG1G2') v ϱ₂'
split-env (drop px sp) (vcons ssp v ϱ)
  rewrite inactive-left-ssplit ssp (unrestricted-val px v)
  = split-env sp ϱ
split-env (left sp) (vcons ssp v ϱ) with split-env sp ϱ
split-env{G = G} (left sp) (vcons ssp v ϱ) | (G₁' , G₂') , ssp12 , ϱ₁' , ϱ₂' with ssplit-compose3 ssp ssp12
... | Gi , ssp-GiG2' , ssp-GiG1G1' = (Gi , G₂') , ssp-GiG2' , vcons ssp-GiG1G1' v ϱ₁' , ϱ₂'
split-env (rght sp) (vcons ssp v ϱ) with split-env sp ϱ
split-env (rght sp) (vcons ssp v ϱ) | (G₁' , G₂') , ssp12 , ϱ₁' , ϱ₂' with ssplit-compose4 ssp ssp12
...| Gi , ssp-GG1'Gi , ssp-GiG1G2' = (G₁' , Gi) , ssp-GG1'Gi , ϱ₁' , vcons ssp-GiG1G2' v ϱ₂'


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Homotopy.HopfInvariant.Base where

open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.Group.Base
open import Cubical.Homotopy.Group.SuspensionMap

open import Cubical.Relation.Nullary

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Wedge
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.GradedCommutativity
open import Cubical.ZCohomology.Gysin

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

open import Cubical.Data.Sigma
open import Cubical.Data.Int hiding (_+'_)
open import Cubical.Data.Nat renaming (_+_ to _+ℕ_ ; _·_ to _·ℕ_)
open import Cubical.Data.Unit

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.ZAction
open import Cubical.Algebra.Group.Exact
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int
open import Cubical.Algebra.Group.Instances.Unit

open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.Wedge
open import Cubical.HITs.Truncation
  renaming (rec to trRec)
open import Cubical.HITs.SetTruncation
  renaming (rec to sRec ; elim to sElim ; elim2 to sElim2 ; map to sMap)
open import Cubical.HITs.PropositionalTruncation
  renaming (rec to pRec)

-- The pushout of the hopf invariant
HopfInvariantPush : (n : ℕ)
             → (f : S₊ (3 +ℕ n +ℕ n) → S₊ (2 +ℕ n))
             → Type _
HopfInvariantPush n f = Pushout (λ _ → tt) f

Hopfα : (n : ℕ)
     → (f : S₊∙ (3 +ℕ n +ℕ n) →∙ S₊∙ (2 +ℕ n))
     → coHom (2 +ℕ n) (HopfInvariantPush n (fst f))
Hopfα n f = ∣ (λ { (inl x) → 0ₖ _
                ; (inr x) → ∣ x ∣
                ; (push a i) → help a (~ i)}) ∣₂
  where
  help : (a : S₊ (3 +ℕ n +ℕ n)) → ∣ fst f a ∣ ≡ 0ₖ (2 +ℕ n)
  help = sphereElim _ (λ _ → isOfHLevelPlus' {n = n} (3 +ℕ n)
         (isOfHLevelPath' (3 +ℕ n) (isOfHLevelTrunc (4 +ℕ n)) _ _))
                                    (cong ∣_∣ₕ (snd f))

Hopfβ : (n : ℕ)
     → (f : S₊∙ (3 +ℕ n +ℕ n) →∙ S₊∙ (2 +ℕ n))
     → coHom (4 +ℕ (n +ℕ n)) (HopfInvariantPush n (fst f))
Hopfβ n f = fst (MV.d _ _ _ (λ _ → tt) (fst f) (3 +ℕ n +ℕ n)) ∣ ∣_∣ ∣₂

-- To define the Hopf invariant, we need to establish the
-- non-trivial isos of Hⁿ(HopfInvariant).
module _ (n : ℕ) (f : S₊∙ (3 +ℕ n +ℕ n) →∙ S₊∙ (2 +ℕ n)) where
  module M = MV _ _ _ (λ _ → tt) (fst f)
  ¬lemHopf : (n m : ℕ) → ¬ suc (suc (m +ℕ n)) ≡ suc n
  ¬lemHopf zero zero p = snotz (cong predℕ p)
  ¬lemHopf (suc n) zero p = ¬lemHopf n zero (cong predℕ p)
  ¬lemHopf zero (suc m) p = snotz (cong predℕ p)
  ¬lemHopf (suc n) (suc m) p =
    ¬lemHopf n (suc m) (cong (suc ∘ suc )
      (sym (+-suc m n)) ∙ (cong predℕ p))

  SphereHopfCohomIso :
    GroupEquiv
      (coHomGr (3 +ℕ n +ℕ n) (S₊ (3 +ℕ n +ℕ n)))
      ((coHomGr (suc (3 +ℕ n +ℕ n)) (HopfInvariantPush _ (fst f))))
  fst (fst SphereHopfCohomIso) =
    fst (MV.d _ _ _ (λ _ → tt) (fst f) (3 +ℕ n +ℕ n))
  snd (fst SphereHopfCohomIso) = help
    where
      abstract
        help : isEquiv (fst (MV.d _ _ _ (λ _ → tt) (fst f)
                                 (3 +ℕ n +ℕ n)))
        help =
          SES→isEquiv
            (isContr→≡UnitGroup
              (isContrΣ (GroupIsoUnitGroup→isContr (invGroupIso (Hⁿ-Unit≅0 _)))
                        λ _ → GroupIsoUnitGroup→isContr
                            (invGroupIso (Hⁿ-Sᵐ≅0 _ _ (¬lemHopf n n)))))
            (isContr→≡UnitGroup
              (isContrΣ (GroupIsoUnitGroup→isContr
                        (invGroupIso (Hⁿ-Unit≅0 _)))
                        λ _ → GroupIsoUnitGroup→isContr
                          (invGroupIso (Hⁿ-Sᵐ≅0 _ _ (¬lemHopf n (suc n))))))
              (M.Δ (3 +ℕ n +ℕ n))
              (M.d (3 +ℕ n +ℕ n))
              (M.i (4 +ℕ n +ℕ n))
              (M.Ker-d⊂Im-Δ _)
              (M.Ker-i⊂Im-d _)
  snd SphereHopfCohomIso = d-inv
    where
      -- Currently, type checking is very slow without the abstract flag.
      -- TODO : Remove abstract
      abstract
        d-inv : IsGroupHom (snd (coHomGr (3 +ℕ n +ℕ n) (S₊ (3 +ℕ n +ℕ n))))
                  (fst (MV.d _ _ _ (λ _ → tt) (fst f) (3 +ℕ n +ℕ n)))
                  (snd (coHomGr (suc (3 +ℕ n +ℕ n))
                       (Pushout (λ _ → tt) (fst f))))
        d-inv = snd (MV.d _ _ _ (λ _ → tt) (fst f) (3 +ℕ n +ℕ n))

  Hopfβ-Iso : GroupIso (coHomGr (suc (3 +ℕ n +ℕ n))
                                (HopfInvariantPush _ (fst f)))
                       ℤGroup
  fst Hopfβ-Iso = compIso (invIso (equivToIso (fst SphereHopfCohomIso)))
                           (fst (Hⁿ-Sⁿ≅ℤ (suc (suc (n +ℕ n)))))
  snd Hopfβ-Iso = grHom
    where
      abstract
        grHom :
          IsGroupHom (coHomGr (suc (3 +ℕ n +ℕ n))
                              (Pushout (λ _ → tt) (fst f)) .snd)
                     (λ x → Iso.fun (fst ((Hⁿ-Sⁿ≅ℤ (suc (suc (n +ℕ n))))))
                       (invEq (fst SphereHopfCohomIso) x))
                     (ℤGroup .snd)
        grHom = snd (compGroupIso
                  (GroupEquiv→GroupIso (invGroupEquiv (SphereHopfCohomIso)))
                  (Hⁿ-Sⁿ≅ℤ (suc (suc (n +ℕ n)))))

Hⁿ-Sⁿ≅ℤ-nice-generator : (n : ℕ) → Iso.inv (fst (Hⁿ-Sⁿ≅ℤ (suc n))) 1 ≡ ∣ ∣_∣ ∣₂
Hⁿ-Sⁿ≅ℤ-nice-generator zero = Iso.leftInv (fst (Hⁿ-Sⁿ≅ℤ (suc zero))) _
Hⁿ-Sⁿ≅ℤ-nice-generator (suc n) =
  (λ i → Iso.inv (fst (suspensionAx-Sn (suc n) (suc n)))
                  (Hⁿ-Sⁿ≅ℤ-nice-generator n i))
     ∙ cong ∣_∣₂
       (funExt λ { north → refl
                 ; south → cong ∣_∣ₕ (merid north)
                 ; (merid a i) j → ∣ compPath-filler (merid a)
                                      (sym (merid north)) (~ j) i ∣ₕ})

Hopfβ↦1 : (n : ℕ) (f : S₊∙ (3 +ℕ n +ℕ n) →∙ S₊∙ (2 +ℕ n))
  → Iso.fun (fst (Hopfβ-Iso n f)) (Hopfβ n f) ≡ 1
Hopfβ↦1 n f =
    sym (cong (Iso.fun (fst (Hopfβ-Iso n f))) lem)
  ∙ Iso.rightInv (fst (Hopfβ-Iso n f)) (pos 1)
  where
  lem : Iso.inv (fst (Hopfβ-Iso n f)) (pos 1) ≡ Hopfβ n f
  lem = (λ i → fst (MV.d _ _ _ (λ _ → tt) (fst f) (3 +ℕ n +ℕ n))
               (Hⁿ-Sⁿ≅ℤ-nice-generator _ i))
    ∙ cong ∣_∣₂ (funExt (λ { (inl x) → refl
                          ; (inr x) → refl
                          ; (push a i) → refl}))

module _ (n : ℕ) (f : S₊∙ (3 +ℕ n +ℕ n) →∙ S₊∙ (2 +ℕ n)) where
  private
    2+n = 2 +ℕ n
    H = HopfInvariantPush n (fst f)

    H→Sphere : coHom 2+n H → coHom 2+n (S₊ (suc (suc n)))
    H→Sphere = sMap (_∘ inr)

    grHom : IsGroupHom (snd (coHomGr 2+n H))
                       H→Sphere (snd (coHomGr 2+n (S₊ (suc (suc n)))))
    grHom =
      makeIsGroupHom
        (sElim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _)
          λ f g → refl)

    preSphere→H : (g : (S₊ (suc (suc n)) → coHomK 2+n))
                 → H → coHomK (2 +ℕ n)
    preSphere→H g (inl x) = 0ₖ _
    preSphere→H g (inr x) = g x -ₖ g north
    preSphere→H g (push a i) = lem a i
      where
      lem : (a : S₊ (suc (suc (suc (n +ℕ n)))))
          → 0ₖ (suc (suc n)) ≡ g (fst f a) -ₖ g north
      lem =
        sphereElim _
          (λ x → isOfHLevelPlus' {n = n} (3 +ℕ n)
                    (isOfHLevelTrunc (4 +ℕ n) _ _))
                    (sym (rCancelₖ _ (g north))
                     ∙ cong (λ x → g x -ₖ g north) (sym (snd f)))

    Sphere→H : coHom 2+n (S₊ (suc (suc n))) → coHom 2+n H
    Sphere→H = sMap preSphere→H

    conCohom2+n : (x : _) → ∥ x ≡ 0ₖ (suc (suc n)) ∥₁
    conCohom2+n =
      coHomK-elim _ (λ _ → isProp→isOfHLevelSuc (suc n) squash₁) ∣ refl ∣₁

  HIPSphereCohomIso :
    Iso (coHom (2 +ℕ n) (HopfInvariantPush n (fst f)))
        (coHom (2 +ℕ n) (S₊ (2 +ℕ n)))
  Iso.fun HIPSphereCohomIso = H→Sphere
  Iso.inv HIPSphereCohomIso = Sphere→H
  Iso.rightInv HIPSphereCohomIso =
    sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
      λ g → pRec (squash₂ _ _)
                  (λ p → cong ∣_∣₂ (funExt λ x → cong (g x +ₖ_) (cong (-ₖ_) p)
                                 ∙ rUnitₖ _ (g x)))
                  (conCohom2+n (g north))
  Iso.leftInv HIPSphereCohomIso =
    sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
      λ g →
       pRec (squash₂ _ _)
        (pRec (isPropΠ (λ _ → squash₂ _ _))
         (λ gn gtt →
          trRec (isProp→isOfHLevelSuc n (squash₂ _ _))
            (λ r → cong ∣_∣₂ (funExt λ {
                          (inl x) → sym gtt
                        ; (inr x) → (λ i → g (inr x) -ₖ gn i)
                                    ∙ rUnitₖ _ (g (inr x))
                        ; (push a i)
                          → sphereElim _
                               {A = λ a →
                                 PathP (λ i → preSphere→H (λ x → g (inr x))
                                                            (push a i)
                                      ≡ g (push a i))
                                     (sym gtt)
                                     ((λ i → g (inr (fst f a)) -ₖ gn i)
                                     ∙ rUnitₖ _ (g (inr (fst f a))))}
               (λ _ → isOfHLevelPathP' (suc (suc (suc (n +ℕ n))))
                        (isOfHLevelPath (suc (suc (suc (suc (n +ℕ n)))))
                         (isOfHLevelPlus' {n = n} (suc (suc (suc (suc n))))
                          (isOfHLevelTrunc (suc (suc (suc (suc n)))))) _ _) _ _)
                               r a i}))
                       (push-helper g gtt gn))
               (conCohom2+n (g (inr north))))
             (conCohom2+n (g (inl tt)))
    where
    push-helper : (g : HopfInvariantPush n (fst f) → coHomK (suc (suc n)))
     → (gtt : g (inl tt) ≡ 0ₖ (suc (suc n)))
     → (gn : g (inr north) ≡ 0ₖ (suc (suc n)))
     → hLevelTrunc (suc n)
             (PathP (λ i → preSphere→H (λ x → g (inr x)) (push north i)
                          ≡ g (push north i))
             (sym gtt)
             ((λ i → g (inr (fst f north)) -ₖ gn i)
              ∙ rUnitₖ _ (g (inr (fst f north)))))
    push-helper g gtt gn =
      isConnectedPathP _ (isConnectedPath _ (isConnectedKn _) _ _) _ _ .fst

  Hopfα-Iso : GroupIso (coHomGr (2 +ℕ n) (HopfInvariantPush n (fst f))) ℤGroup
  Hopfα-Iso =
    compGroupIso
      (HIPSphereCohomIso , grHom)
      (Hⁿ-Sⁿ≅ℤ (suc n))

Hopfα-Iso-α : (n : ℕ) (f : _)
            → Iso.fun (fst (Hopfα-Iso n f)) (Hopfα n f)
            ≡ 1
Hopfα-Iso-α n f =
    sym (cong (Iso.fun (fst (Hⁿ-Sⁿ≅ℤ (suc n)))) (Hⁿ-Sⁿ≅ℤ-nice-generator n))
  ∙ Iso.rightInv (fst (Hⁿ-Sⁿ≅ℤ (suc n))) (pos 1)
  where
  hz : Iso.fun (HIPSphereCohomIso n f) (Hopfα n f) ≡ ∣ ∣_∣ ∣₂
  hz = refl

⌣-α : (n : ℕ) → (f : S₊∙ (3 +ℕ (n +ℕ n)) →∙ S₊∙ (2 +ℕ n)) → _
⌣-α n f = Hopfα n f ⌣ Hopfα n f

HopfInvariant : (n : ℕ)
             → (f : S₊∙ (3 +ℕ (n +ℕ n)) →∙ S₊∙ (2 +ℕ n))
             → ℤ
HopfInvariant n f = Iso.fun (fst (Hopfβ-Iso n f))
  (subst (λ x → coHom x (HopfInvariantPush n (fst f)))
         (λ i → suc (suc (suc (+-suc n n i))))
         (⌣-α n f))

HopfInvariant-π' : (n : ℕ) → π' (3 +ℕ (n +ℕ n)) (S₊∙ (2 +ℕ n)) → ℤ
HopfInvariant-π' n = sRec isSetℤ (HopfInvariant n)

HopfInvariant-π : (n : ℕ) → π (3 +ℕ (n +ℕ n)) (S₊∙ (2 +ℕ n)) → ℤ
HopfInvariant-π n =  sRec isSetℤ λ x → HopfInvariant-π' n ∣ Ω→SphereMap _ x ∣₂

-- Elimination principle for the pushout defining the Hopf Invariant
HopfInvariantPushElim :
       ∀ {ℓ} n → (f : _)
    → {P : HopfInvariantPush n f → Type ℓ}
    → (isOfHLevel (suc (suc (suc (suc (n +ℕ n))))) (P (inl tt)))
    → (e : P (inl tt))
       (g : (x : _) → P (inr x))
       (r : PathP (λ i → P (push north i)) e (g (f north)))
    → (x : _) → P x
HopfInvariantPushElim n f {P = P} hlev e g r (inl x) = e
HopfInvariantPushElim n f {P = P} hlev e g r (inr x) = g x
HopfInvariantPushElim n f {P = P} hlev e g r (push a i₁) = help a i₁
  where
  help : (a : Susp (Susp (S₊ (suc (n +ℕ n)))))
       → PathP (λ i → P (push a i)) e (g (f a))
  help =
    sphereElim _
      (sphereElim _
        (λ _ → isProp→isOfHLevelSuc (suc (suc (n +ℕ n)))
                                      (isPropIsOfHLevel _))
                  (isOfHLevelPathP' (suc (suc (suc (n +ℕ n))))
                    (subst (isOfHLevel (suc (suc (suc (suc (n +ℕ n))))))
                           (cong P (push north))
                           hlev) _ _)) r


module _ (A : Set) where

open import Issue1701.ModParamsToLose
module ParamA = Param A
open ParamA

failed : (A → A) → A → A
failed G = S.F
  module fails where
    module S = r A G


{-# OPTIONS --without-K #-}
module module-layout where
 f : Set1
 f = Set


-- Andreas, 2012-04-18, bug reported by sanzhiyan
-- {-# OPTIONS -v tc.with:100 #-}
module Issue610-4 where

import Common.Level
open import Common.Equality

data ⊥ : Set where
record ⊤ : Set where

record A : Set₁ where
  constructor set
  field
    .a : Set

.ack : A → Set
ack x = A.a x

hah : set ⊤ ≡ set ⊥
hah = refl

-- SHOULD FAIL for the same reason that the next decl fails
.moo : ⊥
moo with cong ack hah
moo | q = subst (λ x → x) q _

{- FAILS
.moo' : ⊥
moo' = subst (λ x → x) (cong ack hah) _
-}

baa : .⊥ → ⊥
baa ()

yoink : ⊥
yoink = baa moo


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.PKCS
import      LibraBFT.Impl.Types.LedgerInfoWithSignatures as LedgerInfoWithSignatures
open import LibraBFT.ImplShared.Consensus.Types

module LibraBFT.Impl.Types.CryptoProxies where

addToLi : AccountAddress → Signature → LedgerInfoWithSignatures → LedgerInfoWithSignatures
addToLi = LedgerInfoWithSignatures.addSignature


-- Andreas, 2019-02-17, issue #3417
--
-- We want to see highlighting for all the warnings,
-- even if the last thing is a hard error.

open import Agda.Builtin.Nat

reachable : Nat → Nat
reachable zer = 0
reachable (suc n) = suc (reachable n)

coverage : Nat → Nat
coverage zero = zero

Termination : Set
Termination = Termination

data Positivity : Set where
  abs : (Positivity → Nat) → Positivity

Universe : Set
Universe = Set

-- Problem was: Termination and Positivity got no highlighting.


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

module Generics.Telescope where

open import Data.String using (String)
open import Generics.Prelude hiding (curry)

private variable
  l     : Level
  A B   : Set l
  a x y : A

data Telescope (A : Set l) : Setω

private variable T : Telescope A

levelOfTel : Telescope A → Level
⟦_⟧tel     : (T : Telescope A) → A → Set (levelOfTel T)

infixl 7 _⊢<_>_ _⊢_

data Telescope A where
  ε      : Telescope A
  _⊢<_>_ : ∀ (T : Telescope A) (ai : String × ArgInfo) {ℓ} (f : Σ A ⟦ T ⟧tel → Set ℓ) → Telescope A

_⊢_ : ∀ (T : Telescope A) {ℓ} (f : Σ A ⟦ T ⟧tel → Set ℓ) → Telescope A
T ⊢ f = T ⊢< "_" , arg-info visible (modality relevant quantity-ω) > f

extendTel : (T : Telescope A) (f : ∀ {x} → ⟦ T ⟧tel x → Set l) → Telescope A
extendTel T f = T ⊢ f ∘ proj₂

infixr 3 extendTel
syntax extendTel A (λ x → B) = x ∶ A , B

levelOfTel ε = lzero
levelOfTel (_⊢<_>_ T _ {ℓ} f) = levelOfTel T ⊔ ℓ

⟦ ε ⟧tel x = ⊤
⟦ T ⊢< n , i > f ⟧tel x = Σ[ t ∈ ⟦ T ⟧tel x ] < relevance i > f (x , t)

hideInfo : ArgInfo → ArgInfo
hideInfo i = arg-info hidden (getModality i)

ExTele : Telescope ⊤ → Setω
ExTele T = Telescope (⟦ T ⟧tel tt)

⟦_,_⟧xtel : (P : Telescope ⊤) (I : ExTele P) → Set (levelOfTel P ⊔ levelOfTel I)
⟦ P , V ⟧xtel = Σ (⟦ P ⟧tel tt) ⟦ V ⟧tel

⟦_,_&_⟧xtel : (P : Telescope ⊤) (V I : ExTele P) → Set (levelOfTel P ⊔ levelOfTel V ⊔ levelOfTel I)
⟦ P , V & I ⟧xtel = Σ[ p ∈ ⟦ P ⟧tel tt ] ⟦ V ⟧tel p × ⟦ I ⟧tel p

----------------------
-- Telescope currying

Curried′ : (T : Telescope A) → (⟦ T ⟧tel x → Set l) → Set (l ⊔ levelOfTel T)
Curried′ ε P = P tt
Curried′ (T ⊢< ai > g) P = Curried′ T λ t → Π< ai > (g (_ , t)) λ y → P (t , y)

Pred′ : (T : Telescope A) → (⟦ T ⟧tel x → Set l) → Set (l ⊔ levelOfTel T)
Pred′ ε P = P tt
Pred′ (T ⊢< n , i > g) P = Pred′ T λ t → Π< n , hideInfo i > (g (_ , t)) λ y → P (t , y)

uncurry′ : (T : Telescope A) (P : ⟦ T ⟧tel x → Set l) (B : Curried′ T P) → (y : ⟦ T ⟧tel x) → P y
uncurry′ ε P B tt = B
uncurry′ (T ⊢< i > f) P B (tx , gx) =
  app< i > (uncurry′ T (λ p → Π< i > (f (_ , p)) (λ y → P (p , y))) B tx) _

curry′ : (T : Telescope A) (P : ⟦ T ⟧tel x → Set l) → ((y : ⟦ T ⟧tel x) → P y) → Curried′ T P
curry′ ε P f = f tt
curry′ (T ⊢< i > S) P f =
  curry′ T _ λ t → fun< i > λ s → f (t , s)

unpred′ : (T : Telescope A) (P : ⟦ T ⟧tel x → Set l) (B : Pred′ T P) → (y : ⟦ T ⟧tel x) → P y
unpred′ ε P B tt = B
unpred′ (T ⊢< n , i > f) P B (tx , gx) =
  app< n , hideInfo i > (unpred′ T (λ p → Π< n , hideInfo i > (f (_ , p)) λ y → P (p , y)) B tx) _

pred′ : (T : Telescope A) (P : ⟦ T ⟧tel x → Set l) → ((y : ⟦ T ⟧tel x) → P y) → Pred′ T P
pred′ ε P f = f tt
pred′ (T ⊢< n , i > S) P f =
  pred′ T _ λ t → fun< n , hideInfo i > λ s → f (t , s)

Curried : ∀ P (I : ExTele P) {ℓ} (Pr : ⟦ P , I ⟧xtel → Set ℓ) → Set (levelOfTel P ⊔ levelOfTel I ⊔ ℓ)
Curried P I {ℓ} Pr = Curried′ P λ p → Curried′ I λ i → Pr (p , i)

curry : ∀ {P} {I : ExTele P} {ℓ} {Pr : ⟦ P , I ⟧xtel → Set ℓ}
      → ((pi : ⟦ P , I ⟧xtel) →  Pr pi) → Curried P I Pr
curry f = curry′ _ _ λ p → curry′ _ _ λ i → f (p , i)

uncurry : ∀ P (I : ExTele P) {ℓ} {Pr : ⟦ P , I ⟧xtel → Set ℓ} → Curried P I Pr → (pi : ⟦ P , I ⟧xtel) → Pr pi
uncurry P I C (p , i) = uncurry′ I _ (uncurry′ P _ C p) i

-- Type of parametrized, indexed sets: (p₁ : A₁) ... (pₙ : Aₙ) (i₁ : B₁) ... (iₚ : Bₚ) → Set ℓ
Indexed : ∀ P (I : ExTele P) ℓ → Set (levelOfTel P ⊔ levelOfTel I ⊔ lsuc ℓ)
Indexed P I ℓ = Curried P I (const (Set ℓ))

unindexed : ∀ P (I : ExTele P) ℓ → Indexed P I ℓ → ⟦ P , I ⟧xtel → Set ℓ
unindexed P I ℓ = uncurry P I

-- Type of predicates on parametrized & indexed families:
--   {p₁ : A₁} ... {pₙ : Aₙ} {i₁ : B₁} ... {iₚ : Bₚ} → X (p₁ ... iₚ) → Set ℓ
Pred : ∀ P (I : ExTele P) {a} (X : ⟦ P , I ⟧xtel → Set a) ℓ
     → Set (levelOfTel P ⊔ levelOfTel I ⊔ a ⊔ lsuc ℓ)
Pred P I X ℓ = Pred′ P λ p → Pred′ I λ i → X (p , i) → Set ℓ

unpred : ∀ P (I : ExTele P) {a} {X : ⟦ P , I ⟧xtel → Set a} ℓ → Pred P I X ℓ
       → (pi : ⟦ P , I ⟧xtel) → X pi → Set ℓ
unpred P I ℓ C (p , i) = unpred′ I _ (unpred′ P _ C p) i


------------------------------------------------------------------------
-- The Agda standard library
--
-- The irrelevance axiom
------------------------------------------------------------------------

module Irrelevance where

import Level

------------------------------------------------------------------------
-- The irrelevance axiom

-- There is no guarantee that this axiom is sound. Use it at your own
-- risk.

postulate
  .irrelevance-axiom : ∀ {a} {A : Set a} → .A → A

{-# BUILTIN IRRAXIOM irrelevance-axiom #-}


------------------------------------------------------------------------
-- Fω with interval kinds
------------------------------------------------------------------------

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

-- Author: Sandro Stucki
-- Copyright (c) 2017-2021 EPFL

-- The code in this repository contains an Agda mechanization of the
-- type system Fω extended with interval kinds ("F omega int").  An
-- interval kind `A..B' represents a type interval bounded by a pair
-- of types `A', `B'.  It is inhabited by all proper types `C : A..B'
-- that are both supertypes of `A' and subtypes of `B'.  Interval
-- kinds are flexible enough to express various features found in
-- other type systems, such as
--
--  * F-<:-style bounded polymorphism,
--  * bounded type operators,
--  * singleton kinds and first-class type definitions.
--
-- The mechanization includes a small-step operational call-by-value
-- semantics, declarative and canonical presentations of typing and
-- kinding, along with (syntactic) proofs of various meta-theoretic
-- properties, such as
--
--  * weak normalization of types (and kinds) via hereditary substitution,
--  * subject reduction for types (w.r.t. full β-reduction),
--  * type safety (progress & preservation) w.r.t. to the CBV semantics,
--  * undecidability of subtyping.
--
-- For more details on Fω with interval kinds, see my PhD thesis
-- "Higher-Order Subtyping with Type Intervals", which is available at
--
--   http://dx.doi.org/10.5075/epfl-thesis-8014
--
-- The code makes heavy use of the Agda standard library, which is
-- freely available at
--
--   https://github.com/agda/agda-stdlib/
--
-- The code has been tested using Agda 2.6.1.3 and version 1.6 of
-- the Agda standard library.

module README where

------------------------------------------------------------------------
-- Modules related to Fω with interval kinds.

-- Syntax of (untyped) terms along with support for substitutions,
-- (untyped) hereditary substitutions and normalization.
open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization

-- Weak equality of (untyped) terms up to kind annotations in
-- abstractions.
open import FOmegaInt.Syntax.WeakEquality

-- Variants of β-reduction/equivalence and properties thereof.
open import FOmegaInt.Reduction.Cbv
open import FOmegaInt.Reduction.Full

-- Typing, kinding, subtyping, etc. along with corresponding
-- substitution lemmas.
open import FOmegaInt.Typing

-- An alternate presentation of kinding and subtyping that is better
-- suited for proving functionality and validity lemmas, along with a
-- proof that the two presentations are equivalent.
open import FOmegaInt.Kinding.Declarative
open import FOmegaInt.Kinding.Declarative.Validity
open import FOmegaInt.Kinding.Declarative.Equivalence

-- Soundness of normalization w.r.t. to declarative kinding.
open import FOmegaInt.Kinding.Declarative.Normalization

-- Simple kinding of types, (hereditary) substitution lemmas.
open import FOmegaInt.Kinding.Simple

-- Lemmas about η-expansion of simply kinded and normalization and
-- simultaneous simplification of declaratively kinded types.
open import FOmegaInt.Kinding.Simple.EtaExpansion
open import FOmegaInt.Kinding.Simple.Normalization

-- Canonical kinding of types along with (hereditary) substitution,
-- validity and inversion lemmas for canonical kinding and subtyping.
open import FOmegaInt.Kinding.Canonical
open import FOmegaInt.Kinding.Canonical.HereditarySubstitution
open import FOmegaInt.Kinding.Canonical.Validity
open import FOmegaInt.Kinding.Canonical.Inversion

-- Lifting of weak (untyped) kind and type equality to canonical kind
-- and type equality.
open import FOmegaInt.Kinding.Canonical.WeakEquality

-- Equivalence of canonical and declarative kinding.
open import FOmegaInt.Kinding.Canonical.Equivalence

-- Generation of typing and inversion of declarative subtyping in the
-- empty context.
open import FOmegaInt.Typing.Inversion

-- Type safety (preservation/subject reduction and progress).
open import FOmegaInt.Typing.Preservation
open import FOmegaInt.Typing.Progress

-- Encodings and properties of higher-order extremal types, interval
-- kinds and bounded quantifiers.
open import FOmegaInt.Typing.Encodings

-- A reduced variant of the canonical system to be used in the
-- undecidability proof.
open import FOmegaInt.Kinding.Canonical.Reduced

-- Setup for the undecidability proof: syntax and lemmas for the SK
-- combinator calculus, and support for encoding/decoding SK terms and
-- equality proofs into types and subtyping derivations.
open import FOmegaInt.Undecidable.SK
open import FOmegaInt.Undecidable.Encoding
open import FOmegaInt.Undecidable.Decoding

-- Undecidability of subtyping
open import FOmegaInt.Undecidable

------------------------------------------------------------------------
-- Modules containing generic functionality

-- Extra lemmas that are derivable in the substitution framework of
-- the Agda standard library, as well as support for binary (term)
-- relations lifted to substitutions, typed substitutions, and typed
-- relations lifted to substitutions.
open import Data.Context
open import Data.Context.WellFormed
open import Data.Context.Properties
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Fin.Substitution.Relation
open import Data.Fin.Substitution.Typed
open import Data.Fin.Substitution.TypedRelation

-- Support for generic reduction relations.
open import Relation.Binary.Reduction

-- Relational reasoning for transitive relations.
open import Relation.Binary.TransReasoning


-- MIT License

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

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

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

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

{-# OPTIONS --guardedness #-}

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

open import Relation.Nullary
open import Relation.Unary using (_∪_; _∩_; Satisfiable)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (Star; ε; _◅_)

open import Common

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

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

data Session : Set where
  _#_  : (T : SessionType) (S : SessionType) -> Session

data Reduction : Session -> Session -> Set where
  sync : ∀{α R R' T T'} (r : Transition R (co-action α) R') (t : Transition T α T') -> Reduction (R # T) (R' # T')

Reductions : Session -> Session -> Set
Reductions = Star Reduction

Reduce : Session -> Set
Reduce S = Satisfiable (Reduction S)

data Success : Session -> Set where
  win#def : ∀{T S} (w : Win T) (def : Defined S) -> Success (T # S)

ProgressS : Session -> Set
ProgressS = Success ∪ Reduce

MaySucceed : Session -> Set
MaySucceed S = Satisfiable (Reductions S ∩ Success)

InvariantS : (Session -> Set) -> Session -> Set
InvariantS P S = ∀{S'} -> Reductions S S' -> P S'

ImplyS : (Session -> Set) -> SessionType -> SessionType -> Set
ImplyS P T S = ∀{R} -> P (R # T) -> P (R # S)

ComplianceS : Session -> Set
ComplianceS = InvariantS ProgressS

FairComplianceS : Session -> Set
FairComplianceS = InvariantS MaySucceed

SubtypingS : SessionType -> SessionType -> Set
SubtypingS = ImplyS ComplianceS

FairSubtypingS : SessionType -> SessionType -> Set
FairSubtypingS = ImplyS FairComplianceS

ConvergenceS : SessionType -> SessionType -> Set
ConvergenceS T S = ∀{R} -> FairComplianceS (R # T) -> MaySucceed (R # S)

unzip-red* : ∀{T T' S S'} -> Reductions (T # S) (T' # S') ->
             ∃[ φ ] (Transitions T (co-trace φ) T' × Transitions S φ S')
unzip-red* ε = _ , refl , refl
unzip-red* (sync r t ◅ reds) =
  let _ , tr , sr = unzip-red* reds in
  _ , step r tr , step t sr

zip-red* : ∀{φ T T' S S'} ->
           Transitions T (co-trace φ) T' ->
           Transitions S φ S' ->
           Reductions (T # S) (T' # S')
zip-red* refl refl = ε
zip-red* (step t tr) (step s sr) = sync t s ◅ zip-red* tr sr

zip-traces :
  ∀{R T φ}
  (rφ : R HasTrace (co-trace φ))
  (tφ : T HasTrace φ) ->
  Reductions (R # T) (after rφ # after tφ)
zip-traces (_ , _ , rr) (_ , _ , tr) = zip-red* rr tr

success-not-reduce : ∀{S S'} → Success S → ¬ (Reduction S S')
success-not-reduce (win#def win _) (sync r _) = win-reduces-⊥ win r


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

module Cubical.HITs.DunceCap where

open import Cubical.HITs.DunceCap.Base public
open import Cubical.HITs.DunceCap.Properties public


-- There was a bug when scope checking with clauses.
module WithScopeError where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

f : Nat -> Nat
f n with y
  where y = suc n
f n | x = y x


{-# OPTIONS --no-sized-types --no-guardedness #-}
module Agda.Builtin.TrustMe where

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Erase

private
  postulate
    unsafePrimTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y

primTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y
primTrustMe = primEraseEquality unsafePrimTrustMe

{-# DISPLAY primEraseEquality unsafePrimTrustMe = primTrustMe #-}


-- Andreas, 2016-12-29, issue #2366
-- With clauses need to be printed in fresh environment,
-- as they DON'T shadow the pattern variables of the parent clause.
-- (These are not even in scope)

-- {-# OPTIONS -v error.checkclause:60 #-}

open import Agda.Builtin.List

test : {A : Set} → List A → List A
test (x ∷ y ∷ ys) with []
test (x ∷ xs) | q = []
test _ = []

-- ERROR WAS:
-- With clause pattern xs is not an instance of its parent pattern y ∷ ys
-- when checking that the clause
-- test (x ∷ y ∷ ys) with []
-- test (x₁ ∷ xs) | q = []
-- has type {A : Set} → List A → List A
-- NOTE THE x₁!

-- Expected error:
-- With clause pattern xs is not an instance of its parent pattern y ∷ ys
-- when checking that the clause
-- test (x ∷ y ∷ ys) with []
-- test (x ∷ xs) | q = []
-- has type {A : Set} → List A → List A


{-# OPTIONS --allow-unsolved-metas #-}
module TermNode where

open import OscarPrelude
open import TermCode

record TermNode : Set
 where
  inductive
  field
    children : List (TermCode × TermNode)
    number : Nat

open TermNode public

open import Membership

_child∈_ : TermCode → TermNode → Set
_child∈_ 𝔠 𝔫 = 𝔠 ∈ (fst <$> children 𝔫)

_child∉_ : TermCode → TermNode → Set
𝔠 child∉ 𝔫 = ¬ (𝔠 child∈ 𝔫)

open import DecidableMembership

_child∈?_ : (𝔠 : TermCode) → (𝔫 : TermNode) → Dec $ 𝔠 child∈ 𝔫
c child∈? record { children = cs } = c ∈? (fst <$> cs)

getChild : {𝔠 : TermCode} → (𝔫 : TermNode) → 𝔠 child∈ 𝔫 → TermNode
getChild {𝔠} (record { children = [] ; number = number₁ }) ()
getChild {._} (record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }) zero = snd₁
getChild {𝔠} (𝔫@record { children = x ∷ children₁ ; number = number₁ }) (suc x₁) = getChild record 𝔫 { children = children₁ } x₁

addChild : {𝔠 : TermCode} (𝔫 : TermNode) → 𝔠 child∉ 𝔫 → TermNode → TermNode
addChild {𝔠} 𝔫 𝔠∉𝔫 𝔫' =
  record 𝔫 { children = (𝔠 , 𝔫') ∷ children 𝔫 }

setChild : {𝔠 : TermCode} (𝔫 : TermNode) → 𝔠 child∈ 𝔫 → TermNode → TermNode
setChild {𝔠} record { children = [] ; number = number₁ } () 𝔫'
setChild 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } (zero) 𝔫' =
  record 𝔫 { children = ((fst₁ , 𝔫') ∷ children₁) }
setChild {𝔠} 𝔫@record { children = (x ∷ children₁) ; number = number₁ } (suc 𝔠∈𝔫) 𝔫' =
  record 𝔫 { children = (x ∷ children (setChild (record 𝔫 { children = children₁ }) 𝔠∈𝔫 𝔫')) }

setGet-ok : ∀ {𝔠} 𝔫 → (𝔠∈𝔫 : 𝔠 child∈ 𝔫) → setChild 𝔫 𝔠∈𝔫 (getChild 𝔫 𝔠∈𝔫) ≡ 𝔫
setGet-ok record { children = [] ; number = number₁ } ()
setGet-ok record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } (zero) = refl
setGet-ok record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } (suc 𝔠∈𝔫) rewrite setGet-ok (record { children = children₁ ; number = number₁ }) 𝔠∈𝔫 = refl

storeTermCodes : List TermCode → Nat → StateT TermNode Identity Nat
storeTermCodes [] 𝔑 = return 𝔑
storeTermCodes (𝔠 ∷ 𝔠s) 𝔑 =
  𝔫 ← get -|
  case 𝔠 child∈? 𝔫 of λ
  { (no 𝔠∉tests) →
    let 𝔑' , 𝔫' = runIdentity $
                  runStateT
                    (storeTermCodes 𝔠s $ suc 𝔑)
                    (record
                      { children = []
                      ; number = suc 𝔑 }) in
    put ((addChild 𝔫 𝔠∉tests 𝔫')) ~|
    return 𝔑'
  ; (yes 𝔠∈tests) →
    let 𝔑' , 𝔫' = runIdentity $
                  runStateT
                    (storeTermCodes 𝔠s $ suc 𝔑)
                    ((getChild 𝔫 𝔠∈tests)) in
    put ((setChild 𝔫 𝔠∈tests 𝔫')) ~|
    return 𝔑' }

storeTermCodes[] : (𝔫 : TermNode) (𝔑 : Nat) → (runIdentity $ runStateT (storeTermCodes [] 𝔑) 𝔫) ≡ (𝔑 , 𝔫)
storeTermCodes[] 𝔫 𝔑 = refl

--{-# REWRITE storeTermCodes[] #-}

storeTermCodes' : List TermCode → StateT Nat (StateT TermNode Identity) ⊤
storeTermCodes' 𝔠s =
  𝔑 ← get -|
  tn ← lift get -|
  (let 𝔑' , tn' = runIdentity $ runStateT (storeTermCodes 𝔠s 𝔑) tn in
   put 𝔑' ~| lift (put tn') ~| return tt)

open import Term
open import Vector

mutual

  storeTerm : Term → StateT Nat (StateT TermNode Identity) ⊤
  storeTerm τ@(variable _) = storeTermCodes' (encodeTerm τ)
  storeTerm τ@(function _ τs) = storeTermCodes' (encodeTerm τ) ~| storeTerms τs

  storeTerms : Terms → StateT Nat (StateT TermNode Identity) ⊤
  storeTerms ⟨ ⟨ [] ⟩ ⟩ = return tt
  storeTerms ⟨ ⟨ τ ∷ τs ⟩ ⟩ = storeTerm τ ~| storeTerms ⟨ ⟨ τs ⟩ ⟩ ~| return tt

module ExampleStoreTerm where

  open import FunctionName
  open import VariableName

  example-Term₁ : Term
  example-Term₁ =
    (function ⟨ 2 ⟩
              ⟨ ⟨ variable ⟨ 0 ⟩
              ∷ function ⟨ 3 ⟩
                         ⟨ ⟨ variable ⟨ 2 ⟩ ∷ [] ⟩ ⟩
              ∷ variable ⟨ 5 ⟩
              ∷ []
              ⟩ ⟩
    )

  example-Term₂ : Term
  example-Term₂ =
    (function ⟨ 2 ⟩
              ⟨ ⟨ variable ⟨ 0 ⟩
              ∷ variable ⟨ 2 ⟩
              ∷ function ⟨ 3 ⟩
                         ⟨ ⟨ variable ⟨ 2 ⟩ ∷ [] ⟩ ⟩
              ∷ variable ⟨ 5 ⟩
              ∷ []
              ⟩ ⟩
    )

  topNode : TermNode
  topNode = record { children = [] ; number = 0 }

  example-storeTerm : (⊤ × Nat) × TermNode
  example-storeTerm = runIdentity $ runStateT (runStateT (storeTerm example-Term₁ >> storeTerm example-Term₂) 0) topNode

NodeStateT = StateT TermNode
TopNodeState = StateT Nat (NodeStateT Identity)

open import LiteralFormula
open import IsLiteralFormula

storeLiteralFormulaTerms : LiteralFormula → StateT Nat (StateT TermNode Identity) ⊤
storeLiteralFormulaTerms ⟨ atomic 𝑃 τs ⟩ = storeTerms τs
storeLiteralFormulaTerms ⟨ logical 𝑃 τs ⟩ = storeTerms τs

open import 𝓢equent

storeSequentLiteralFormulaTerms : 𝓢equent LiteralFormula → StateT Nat (StateT TermNode Identity) ⊤′
storeSequentLiteralFormulaTerms (φˢs ⊢ φᵗ) = sequence $ storeLiteralFormulaTerms <$> ({!φᵗ!} ∷ φˢs)


-- Andreas, 2016-12-28, issue #2360 reported by m0davis
-- Ambigous projection in with-clause triggered internal error

postulate
  A : Set
  a : A

module M (X : Set) where
  record R : Set where
    field f : X

-- Opening two instantiations of M creates and ambiguous projection

open M A using (module R)
open M A

test : R
R.f test with a
R.f test | _ = a  -- WAS: triggered __IMPOSSIBLE__

-- should succeed


-- Tests for withNormalisation

module _ where

open import Agda.Builtin.Reflection
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality
open import Agda.Builtin.Bool
open import Agda.Builtin.Unit
open import Agda.Builtin.List

infixl 4 _>>=_
_>>=_ = bindTC

F : Bool → Set
F false = Nat
F true  = Bool

data D (b : Bool) : Set where

_&&_ : Bool → Bool → Bool
true  && x = x
false && _ = false

postulate
  reflected : ∀ {a} {A : Set a} → Term → A

pattern vArg x = arg (arg-info visible relevant) x

useReflected : Term → Term → TC ⊤
useReflected hole goal =
  quoteTC goal >>= λ `goal →
  unify hole (def (quote reflected) (vArg `goal ∷ []))

macro
  error : Term → TC ⊤
  error hole =
    inferType hole >>= λ goal → typeError (termErr goal ∷ [])

  reflect : Term → TC ⊤
  reflect hole = inferType hole >>= useReflected hole

  reflectN : Term → TC ⊤
  reflectN hole = withNormalisation true (inferType hole) >>= useReflected hole

test₁ : D (true && false)
test₁ = reflect

test₂ : D (true && false)
test₂ = reflectN

pattern `D x = def (quote D) (vArg x ∷ [])
pattern `true = con (quote true) []
pattern `false = con (quote false) []
pattern _`&&_ x y = def (quote _&&_) (vArg x ∷ vArg y ∷ [])

check₁ : test₁ ≡ reflected (`D (`true `&& `false))
check₁ = refl

check₂ : test₂ ≡ reflected (`D `false)
check₂ = refl


module Ex6AgdaSetup where

{- This file contains all the basic types you need for the editor. You should
   read and understand the Agda in this file, but not bother too much about
   the funny compiler directives. -}

open import CS410-Prelude
open import CS410-Nat

record _**_ (S T : Set) : Set where
  constructor _,_
  field
    outl : S
    outr : T
open _**_
{-# COMPILED_DATA _**_ (,) (,) #-}
infixr 4 _**_ _,_

_<=_ : Nat -> Nat -> Two
zero   <=  y      = tt
suc x  <=  zero   = ff
suc x  <=  suc y  = x <= y

_++_ : {A : Set} -> List A -> List A -> List A
[]         ++ ys = ys
(x :: xs)  ++ ys = x :: (xs ++ ys)

{- Here are backward lists, which are useful when the closest element is
   conceptually at the right end. They aren't really crucial as you could use
   ordinary lists but think of the data as being reversed, but I prefer to
   keep my thinking straight and use data which look like what I have in mind. -}

data Bwd (X : Set) : Set where
  []    : Bwd X
  _<:_  : Bwd X -> X -> Bwd X
infixl 3 _<:_

{- You will need access to characters, imported from Haskell. You can write
   character literals like 'c'. You also get strings, with String literals like
   "fred" -}

postulate       -- Haskell has a monad for doing IO, which we use at the top level
  IO      : Set -> Set
  return  : {A : Set} -> A -> IO A
  _>>=_   : {A B : Set} -> IO A -> (A -> IO B) -> IO B
infixl 1 _>>=_
{-# BUILTIN IO IO #-}
{-# COMPILED_TYPE IO IO #-}
{-# COMPILED return (\ _ -> return)    #-}
{-# COMPILED _>>=_  (\ _ _ -> (>>=)) #-}

{- Here's the characterization of keys I give you -}
data Direction : Set where up down left right : Direction
data Modifier : Set where normal shift control : Modifier
data Key : Set where
  char       : Char -> Key
  arrow      : Modifier -> Direction -> Key
  enter      : Key
  backspace  : Key
  delete     : Key
  escape     : Key
  tab        : Key
data Event : Set where
  key     : (k : Key) -> Event
  resize  : (w h : Nat) -> Event

{- This type classifies the difference between two editor states. -}
data Change : Set where
  allQuiet    : Change      -- the buffer should be exactly the same
  cursorMove  : Change      -- the cursor has moved but the text is the same
  lineEdit    : Change      -- only the text on the current line has changed
  bigChange   : Change      -- goodness knows!

{- This type collects the things you're allowed to do with the text window. -}
data Action : Set where
  goRowCol : Nat -> Nat -> Action    -- send the cursor somewhere
  sendText : List Char -> Action     -- send some text
  move     : Direction -> Nat -> Action  -- which way and how much
  fgText   : Colour -> Action
  bgText   : Colour -> Action

{- I wire all of that stuff up to its Haskell counterpart. -}
{-# IMPORT ANSIEscapes #-}
{-# IMPORT HaskellSetup #-}
{-# COMPILED_DATA Direction
      ANSIEscapes.Dir
      ANSIEscapes.DU ANSIEscapes.DD ANSIEscapes.DL ANSIEscapes.DR #-}
{-# COMPILED_DATA Modifier
      HaskellSetup.Modifier
      HaskellSetup.Normal HaskellSetup.Shift HaskellSetup.Control #-}
{-# COMPILED_DATA Key
      HaskellSetup.Key
      HaskellSetup.Char HaskellSetup.Arrow HaskellSetup.Enter
      HaskellSetup.Backspace HaskellSetup.Delete HaskellSetup.Escape
      HaskellSetup.Tab #-}
{-# COMPILED_DATA Event
      HaskellSetup.Event
      HaskellSetup.Key HaskellSetup.Resize #-}
{-# COMPILED_DATA Change
      HaskellSetup.Change
      HaskellSetup.AllQuiet HaskellSetup.CursorMove HaskellSetup.LineEdit
      HaskellSetup.BigChange #-}
{-# COMPILED_DATA Action HaskellSetup.Action
      HaskellSetup.GoRowCol HaskellSetup.SendText HaskellSetup.Move
      HaskellSetup.FgText HaskellSetup.BgText #-}

{- This is the bit of code I wrote to animate your code. -}
postulate
  mainLoop : {B : Set} ->             -- buffer type
    -- INITIALIZER
    (List (List Char) -> B) ->        -- make a buffer from some lines of text
    -- KEYSTROKE HANDLER
    (Key -> B ->                      -- keystroke and buffer in
     Change ** B) ->                 -- change report and buffer out
    -- RENDERER
    ((Nat ** Nat) ->                 -- height and width of screen
     (Nat ** Nat) ->                 -- top line number, left column number
     (Change ** B) ->           -- change report and buffer to render
     (List Action **                 -- how to update the display
      (Nat ** Nat))) ->              -- new top line number, left column number
    -- PUT 'EM TOGETHER AND YOU'VE GOT AN EDITOR!
    IO One
{-# COMPILED mainLoop (\ _ -> HaskellSetup.mainLoop) #-}

{- You can use this to put noisy debug messages in Agda code. So
      trace "fred" tt
   evaluates to tt, but prints "fred" in the process. -}
postulate
  trace : {A : Set} -> String -> A -> A
{-# IMPORT Debug.Trace #-}
{-# COMPILED trace (\ _ -> Debug.Trace.trace) #-}

{- You can use this to print an error message when you don't know what else to do.
   It's very useful for filling in unfinished holes to persuade the compiler to
   compile your code even though it isn't finished: you get an error if you try
   to run a missing bit. -}
postulate
  error : {A : Set} -> String -> A
{-# COMPILED error (\ _ -> error) #-}

{- Equality -}
{- x == y is a type whenever x and y are values in the same type -}
{-
data _==_ {X : Set}(x : X) : X -> Set where
  refl : x == x  -- and x == y has a constructor only when y actually is x!
infixl 1 _==_
-- {-# BUILTIN EQUALITY _==_ #-}
-- {-# BUILTIN REFL refl #-}
{-# COMPILED_DATA _==_ HaskellSetup.EQ HaskellSetup.Refl #-}

within_turn_into_because_ :
   {X Y : Set}(f : X -> Y)(x x' : X) ->
   x == x' -> f x == f x'
within f turn x into .x because refl = refl
                     -- the dot tells Agda that *only* x can go there

symmetry : {X : Set}{x x' : X} -> x == x' -> x' == x
symmetry refl = refl

transitivity : {X : Set}{x0 x1 x2 : X} -> x0 == x1 -> x1 == x2 -> x0 == x2
transitivity refl refl = refl
-}

within_turn_into_because_ :
    {X Y : Set}(f : X -> Y)(x x' : X) ->
    x == x' -> f x == f x'
within f turn x into .x because refl = refl

{-
postulate
  _==_ : {X : Set} -> X -> X -> Set   -- the evidence that two X-values are equal
  refl : {X : Set}{x : X} -> x == x
  symmetry : {X : Set}{x x' : X} -> x == x' -> x' == x
  transitivity : {X : Set}{x0 x1 x2 : X} -> x0 == x1 -> x1 == x2 -> x0 == x2
  within_turn_into_because_ :
    {X Y : Set}(f : X -> Y)(x x' : X) ->
    x == x' -> f x == f x'
infix 1 _==_

{-# COMPILED_TYPE _==_ HaskellSetup.EQ #-}

{- Here's an example. -}

additionAssociative : (x y z : Nat) -> (x + y) + z == x + (y + z)
additionAssociative zero y z    = refl
additionAssociative (suc x) y z
  = within suc turn ((x + y) + z) into (x + (y + z))
      because additionAssociative x y z
-}


module Implicits.Resolution.Ambiguous.Undecidable where

open import Prelude hiding (Dec)

open import Relation.Nullary
open import Relation.Nullary.Decidable as DecM
open import Function.Equivalence using (_⇔_; equivalence)
open import Relation.Binary.HeterogeneousEquality as H using ()

open import Implicits.Syntax
open import Implicits.Resolution.Ambiguous.Resolution
open import Implicits.Resolution.Ambiguous.Semantics
open import Implicits.Resolution.Ambiguous.SystemFEquiv
open import Implicits.Resolution.Embedding
open import Implicits.Resolution.Embedding.Lemmas

open import SystemF.Everything as F using ()

{-
  Assuming undecidability of the type inhabitation problem for System F
  (as proven by e.g. Barendregt) we can prove the undecidability of Ambiguous resolution
-}

private
  -- type of inhabitation problem decider
  ?:-Dec : Set
  ?:-Dec = ∀ {n ν} (Γ : F.Ctx ν n) (a : F.Type ν) → Dec (∃ λ t → Γ F.⊢ t ∈ a)

module Undecidable (?:-undec : ¬ ?:-Dec) where

  -- type of decider for ambiguous resolution
  ⊢ᵣ-Dec : Set
  ⊢ᵣ-Dec = ∀ {ν} (Δ : ICtx ν) (a : Type ν) → Dec (Δ ⊢ᵣ a)

  -- proof that such a decider would imply a decider for type inhabitation problem
  reduction : ⊢ᵣ-Dec → ?:-Dec
  reduction f Γ x = DecM.map (equivalent' Γ x) (f ⟦ Γ ⟧ctx← ⟦ x ⟧tp←)

  -- completing the proof
  undecidable : ¬ ⊢ᵣ-Dec
  undecidable f = ?:-undec (reduction f)


-- Sometimes we can't infer a record type

module InferRecordTypes-2 where

record R : Set₁ where
  field
    x₁ : Set
    x₂ : Set

bad = record { x₃ = Set }


{-# OPTIONS --copatterns --show-implicit #-}

module Issue940 where

module _ (A : Set) where

  record Box : Set where
    constructor box
    field
      unbox : A

  open Box

  postulate x : A

  ex : Box
  ex = box x -- works

  ex' : Box
  unbox ex' = x

  -- Error WAS:
  -- An internal error has occurred. Please report this as a bug.
  -- Location of the error: src/full/Agda/TypeChecking/Substitute.hs:326

postulate
  A : Set

ok : Box A
Box.unbox ok = x A -- works


------------------------------------------------------------------------------
-- Testing nested axioms
------------------------------------------------------------------------------

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

module NestedAxioms.B where

open import NestedAxioms.A

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

postulate
  c : D
  b≡c : b ≡ c
{-# ATP axiom b≡c #-}


module Fail.TupleType where

open import Haskell.Prelude

idT : ∀ {as} → Tuple as → Tuple as
idT x = x

{-# COMPILE AGDA2HS idT #-}


-- Andreas, 2016-08-26, issue 2152
-- Option --allow-unsolved-metas is not --safe

Unsolved : Set
Unsolved = ?