open import Signature

-- | In this module, we construct the free monad and the free completely
-- iterative monad over a signature Σ (see Aczel, Adamek, Milius and Velebil).
-- The first assigns to a set V of variables the set TV of finite terms over Σ
-- (that is, finite trees labelled with symbols in f ∈ ∥Σ∥ and ar(f) branching).
-- The second extends this to also allow for infinite trees, the set of those
-- is then denoted by T∞(V).
-- Categorically, T(V) is the initial (Σ + V)-algebra, whereas T∞(V) is the
-- final (Σ + V)-coalgebra.
module Terms (Σ : Sig) where

open import Function
open import Data.Empty
open import Data.Unit hiding (_≤_)
open import Data.Product as Prod renaming (Σ to ⨿)
open import Data.Nat as Nat
open import Data.Sum as Sum
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Binary hiding (_⇒_)
open import Relation.Unary hiding (_⇒_)
import Streams as Str
open import Streams hiding (corec)

-- | Natural transformations
Nat : (Set → Set) → (Set → Set) → Set₁
Nat F G = ∀{X} → F X → G X

Id : Set → Set
Id = id

least : {X : Set} (_⊑_ : Rel X _) (P : X → Set) → X → Set
least _⊑_ P x = (P x) × (∀ {y} → P y → x ⊑ y)

least-unique : {X : Set} {_⊑_ : Rel X _} → (IsTotalOrder _≡_ _⊑_) →
               {P : X → Set} → (x y : X) → least _⊑_ P x → least _⊑_ P y → x ≡ y
least-unique isTO x y (p , l₁) (q , l₂) with IsTotalOrder.total isTO x y
least-unique isTO x y (p , l₁) (q , l₂) | inj₁ x⊑y =
  IsTotalOrder.antisym isTO x⊑y (l₂ p)
least-unique isTO x y (p , l₁) (q , l₂) | inj₂ y⊑x =
  IsTotalOrder.antisym isTO (l₁ q) y⊑x

infixr 1 _⇒_
_⇒_ = Nat

data T (V : Set) : Set where
  sup : ⟪ Σ ⟫ (T V) ⊎ V → T V

rec : ∀{V X} → (f : ⟪ Σ ⟫ X ⊎ V → X) → T V → X
rec f (sup (inj₁ (s , α))) = f (inj₁ (s , λ i → rec f (α i)))
rec f (sup (inj₂ y))       = f (inj₂ y)

-- | Functor T, on morphisms
T₁ : ∀ {V W} → (V → W) → T V → T W
T₁ f = rec (sup ∘ Sum.map id f)

η : Id ⇒ T
η = sup ∘ inj₂

μ : T ∘ T ⇒ T
μ {V} = rec f
  where
    f : ⟪ Σ ⟫ (T V) ⊎ T V → T V
    f = [ sup ∘ inj₁ , id ]

-- | T is free over Σ with inclusion
ι : ⟪ Σ ⟫ ⇒ T
ι = sup ∘ inj₁ ∘ ⟪ Σ ⟫₁ η

-- | Kleisli morphsims for T∞ V
Subst : Set → Set → Set
Subst V W = V → T W

infixr 9 _•_

-- | Kleisli composition
_•_ : ∀ {U V W} → Subst V W → Subst U V → Subst U W
τ • σ = μ ∘ T₁ τ ∘ σ

-- | Application of substitutions to infinite terms
app : ∀ {V W} → Subst V W → T V → T W
app σ = μ ∘ T₁ σ

infixl 1 _≡ₛ_

_≡ₛ_ : ∀{V W} → Rel (Subst V W) _
σ ≡ₛ τ = ∀ {v} → σ v ≡ τ v

-- | Order on subsitutions
_⊑_ : ∀{V W} → Rel (Subst V W) _
σ₁ ⊑ σ₂ = ∃ λ σ → σ • σ₁ ≡ₛ σ₂

matches : ∀{V W} → T V → T W → Subst V W → Set
matches t s σ = app σ t ≡ s

-- | Most general matcher
mgm : ∀{V W} → T V → T W → Subst V W → Set
mgm t s = least _⊑_ (matches t s)

unifies : ∀{V W} → T V → T V → Subst V W → Set
unifies t s σ = app σ t ≡ app σ s

-- | Most general unifier
mgu : ∀{V W} → T V → T V → Subst V W → Set
mgu t s = least _⊑_ (unifies t s)

-- | Free variables
fv : ∀{V} → T V → Pred V _
fv (sup (inj₁ (s , α))) v = ⨿ (Sig.ar Σ s) λ i → (fv (α i) v)
fv (sup (inj₂ v₁))      v = v₁ ≡ v

isVar : ∀{V} → Pred (T V) _
isVar (sup (inj₁ x)) = ⊥
isVar (sup (inj₂ y)) = ⊤

record T∞ (V : Set) : Set where
  coinductive
  field out : ⟪ Σ ⟫ (T∞ V) ⊎ V
open T∞ public

sum-lift : {A B : Set} (R₁ : A → A → Set) (R₂ : B → B → Set) (x y : A ⊎ B) → Set
sum-lift R₁ R₂ (inj₁ x) (inj₁ y) = R₁ x y
sum-lift R₁ R₂ (inj₁ x) (inj₂ y) = ⊥
sum-lift R₁ R₂ (inj₂ x) (inj₁ y) = ⊥
sum-lift R₁ R₂ (inj₂ x) (inj₂ y) = R₂ x y

~-data : ∀{V} (R : T∞ V → T∞ V → Set) (u w : ⟪ Σ ⟫ (T∞ V) ⊎ V) → Set
~-data R = sum-lift (sig-lift R) _≡_

record _~_ {V : Set} (t s : T∞ V) : Set where
  coinductive
  field out~ : ~-data _~_ (out t) (out s)
open _~_ public

corec : ∀{V X} → (f : X → ⟪ Σ ⟫ X ⊎ V) → X → T∞ V
out (corec f x) with f x
... | inj₁ (s , α) = inj₁ (s , (λ i → corec f (α i)))
... | inj₂ v       = inj₂ v

prim-corec : ∀{V X} → (f : X → ⟪ Σ ⟫ X ⊎ V ⊎ T∞ V) → X → T∞ V
out (prim-corec {V} {X} f x) with f x
... | inj₁ (s , α)  = inj₁ (s , (λ i → prim-corec f (α i)))
... | inj₂ (inj₁ v) = inj₂ v
... | inj₂ (inj₂ t) = out t

sup∞ : ∀{V} → ⟪ Σ ⟫ (T∞ V) ⊎ V → T∞ V
out (sup∞ (inj₁ u)) = inj₁ u
out (sup∞ (inj₂ v)) = inj₂ v

-- | Functor T∞, on morphisms
T∞₁ : ∀ {V W} → (V → W) → T∞ V → T∞ W
T∞₁ f = corec (Sum.map id f ∘ out)

η∞ : Id ⇒ T∞
η∞ = sup∞ ∘ inj₂

μ∞ : T∞ ∘ T∞ ⇒ T∞
μ∞ {V} = corec f
  where
    g : T∞ V → ⟪ Σ ⟫ (T∞ (T∞ V)) ⊎ V
    g = Sum.map (⟪ Σ ⟫₁ η∞) id ∘ out

    f : T∞ (T∞ V) → ⟪ Σ ⟫ (T∞ (T∞ V)) ⊎ V
    f = [ inj₁ , g ] ∘ out

ι∞ : ⟪ Σ ⟫ ⇒ T∞
ι∞ {V} = g ∘ inj₁
  where
    g : ⟪ Σ ⟫ V ⊎ T∞ V → T∞ V
    g = prim-corec [ inj₁ ∘ ⟪ Σ ⟫₁ (inj₂ ∘ η∞) , inj₂ ∘ inj₂ ]

-- | T is a submonad of T∞
χ : T ⇒ T∞
χ = rec sup∞

-- | Kleisli morphsims for T∞ V
Subst∞ : Set → Set → Set
Subst∞ V W = V → T∞ W

infixl 1 _≡ₛ∞_

_≡ₛ∞_ : ∀{V W} → Rel (Subst∞ V W) _
σ ≡ₛ∞ τ = ∀ {v} → σ v ~ τ v

infixr 9 _•∞_

-- | Kleisli composition
_•∞_ : ∀ {U V W} → Subst∞ V W → Subst∞ U V → Subst∞ U W
τ •∞ σ = μ∞ ∘ T∞₁ τ ∘ σ

-- | Application of substitutions to infinite terms
app∞ : ∀ {V W} → Subst∞ V W → T∞ V → T∞ W
app∞ σ = μ∞ ∘ T∞₁ σ

isVar∞ : ∀{V} → Pred (T∞ V) _
isVar∞ t with out t
isVar∞ t | inj₁ x = ⊥
isVar∞ t | inj₂ v = ⊤

varNowOrLater : ∀{V} → (T∞ V → Pred V _) → T∞ V → Pred V _
varNowOrLater R t v with out t
... | inj₁ (f , α) = ∃ (λ i → R (α i) v)
... | inj₂ v₁      = v ≡ v₁

record fv∞ {V : Set} (t : T∞ V) (v : V) : Set where
  coinductive
  field isFv∞ : varNowOrLater fv∞ t v

root-matches : ∀{V} → T V → ∥ Σ ∥ → Set
root-matches (sup (inj₁ (g , _))) f = g ≡ f
root-matches (sup (inj₂ y))       f = ⊥

record RootsMatch {V : Set} (s : Stream (T V)) (f : ∥ Σ ∥) : Set where
  coinductive
  field
    hd-match : root-matches (hd s) f
    tl-match : RootsMatch (tl s) f
open RootsMatch

-- | Nasty hack: assume that RootsMatch is propositional
postulate
  RootsMatch-unique : ∀{V} {s : Stream (T V)} {f : ∥ Σ ∥}
                      (p q : RootsMatch s f) → p ≡ q

split : {V : Set} (s : Stream (T V)) (f : ∥ Σ ∥) → RootsMatch s f →
        ar Σ f → Stream (T V)
hd (split s f p i) with hd s | hd-match p
hd (split s f p i) | sup (inj₁ (.f , α)) | refl = α i
hd (split s f p i) | sup (inj₂ y) | ()
tl (split s f p i) = split (tl s) f (tl-match p) i

root-matches∞ : ∀{V} → T∞ V → ∥ Σ ∥ → Set
root-matches∞ t f with out t
root-matches∞ t f | inj₁ (g , _) = f ≡ g
root-matches∞ t f | inj₂ v       = ⊥

split∞ : {V : Set} → (t : T∞ V) (f : ∥ Σ ∥) → root-matches∞ t f →
        ar Σ f → T∞ V
split∞ t f p i with out t
split∞ t f refl i | inj₁ (.f , α) = α i
split∞ t f ()   i | inj₂ y

data AnyRootMatch {V : Set} (s : Stream (T V)) (f : ∥ Σ ∥) : Stream (T V) → Set where
  match-hd : root-matches (hd s) f → AnyRootMatch s f s
  match-tl : AnyRootMatch (tl s) f (tl s) → AnyRootMatch s f (tl s)

first-root-match : ∀{V} → Stream (T V) → ∥ Σ ∥ → ℕ → Set
first-root-match s f = least _≤_ (λ k → root-matches (s at k) f)

conv-branch : {V : Set} (R : Stream (T V) → T∞ V → Set) →
               Stream (T V) → T∞ V → T V → ⟪ Σ ⟫ (T∞ V) ⊎ V → Set
conv-branch R s t (sup (inj₁ (f , α))) (inj₁ (g , β)) =
  ⨿ (f ≡ g) λ p →
  ⨿ (RootsMatch (tl s) f) λ q →
  ∀ i → R (split (tl s) f q i) (β (subst (ar Σ) p i))
conv-branch R s t (sup (inj₁ (f , α))) (inj₂ v) = ⊥
conv-branch R s t (sup (inj₂ v)) (inj₁ (f , α)) =
  ∃ λ s' → AnyRootMatch s f s' × R s' t
conv-branch R s t (sup (inj₂ v)) (inj₂ w) = v ≡ w × R (tl s) t

{-
conv-branch : {V : Set} (R : Stream (T V) → T∞ V → Set) →
              Stream (T V) → T∞ V → Set
conv-branch R s t with hd s | out t
conv-branch R s t | sup (inj₁ (f , α)) | inj₁ (g , β) =
  ⨿ (f ≡ g) λ p →
  ⨿ (RootsMatch (tl s) f) λ q →
  ∀ i → R (split (tl s) f q i) (β (subst (ar Σ) p i))
conv-branch R s t | sup (inj₁ x) | inj₂ v       = ⊥
conv-branch R s t | sup (inj₂ v) | inj₁ (f , α) =
  ∃ λ n → first-root-match s f n × R (δ n s) t
conv-branch R s t | sup (inj₂ v) | inj₂ w       = v ≡ w × R (tl s) t
-}

-- | A sequence s of finite terms converges to a possibly infinite term,
-- if for all i, sᵢ₊₁ = sᵢ[σ] for some substitution σ : V → T V and t = sᵢ[τ]
-- for some τ : V → T∞ V.
-- Note that this coincides with convergence in the prefix metric.
record _→∞_ {V : Set} (s : Stream (T V)) (t : T∞ V) : Set where
  coinductive
  field
    conv-out : conv-branch _→∞_ s t (hd s) (out t)
{-
    hd-matches   : ∃ λ σ → hd (tl s) ≡ app σ (hd s)
    hd-prefix    : ∃ λ τ → t ~ app∞ τ (χ (hd s))
    tl-converges : tl s →∞ t
-}

open _→∞_ public

{-
lem₂ : ∀{V n f} {s : Stream (T V)} →
       first-root-match s f (suc n) → first-root-match (tl s) f n
lem₂ {n = n} {f} {s} (p , q) = (p , λ m → ≤-pred (q m))
-}

{-
lem₃ : ∀{V f} (s : Stream (T V)) → ∀{t} →
      first-root-match s f zero → s →∞ t → first-root-match (tl s) f zero
lem₃ s {t} m          c with hd s      | out t  | conv-out c
lem₃ s     (refl , q) c | sup (inj₁ _) | inj₁ _ | refl , p , _
  = (hd-match p , (λ m → z≤n))
lem₃ s     (refl , q) c | sup (inj₁ _) | inj₂ v | ()
lem₃ s     (() ,   q) c | sup (inj₂ v) | u      | r
-}

lem₆ : ∀{V} (s : Stream (T V)) → ∀{t f} →
       root-matches (hd s) f → s →∞ t → RootsMatch (tl s) f
hd-match (lem₆ s {t} m    c) with hd s | out t | conv-out c
hd-match (lem₆ s     refl c) | sup (inj₁ (f , α)) | inj₁ (.f , β) | refl , m₁ , br = hd-match m₁
hd-match (lem₆ s     refl c) | sup (inj₁ (f , α)) | inj₂ y | ()
hd-match (lem₆ s     ()   c) | sup (inj₂ v) | x | y
tl-match (lem₆ s {t} m    c) with hd s | out t | conv-out c
tl-match (lem₆ s     refl c) | sup (inj₁ (f , α)) | inj₁ (.f , β) | refl , m₁ , br = tl-match m₁
tl-match (lem₆ s     refl c) | sup (inj₁ (f , α)) | inj₂ y | ()
tl-match (lem₆ s     ()   c) | sup (inj₂ v) | x | y

lem₅ : ∀{V} (s : Stream (T V)) → ∀{t f} →
       root-matches (hd s) f → s →∞ t → tl s →∞ t
conv-out (lem₅ s {t} m    c) with hd s | out t | conv-out c
conv-out (lem₅ s     refl c) | sup (inj₁ (f , α)) | inj₁ (.f , β) | refl , m , br = {!!}
conv-out (lem₅ s     refl c) | sup (inj₁ (f , α)) | inj₂ y | ()
conv-out (lem₅ s     ()   c) | sup (inj₂ v) | x | y

lem₇ : ∀{V} (s : Stream (T V)) → ∀{t f α} →
       RootsMatch (tl s) f → s →∞ t → hd s ≡ sup (inj₁ (f , α)) →
       ∃ λ β → hd (tl s) ≡ sup (inj₁ (f , β))
lem₇ = {!!}

lem₄ : ∀{V} (s : Stream (T V)) → ∀{t} →
      s →∞ t → tl s →∞ t
lem₄ {V} s {t} p = q {s} {t} (hd s) (out t) refl refl (conv-out p)
  where
    q : ∀{s t} → (u : T V) → (x : ⟪ Σ ⟫ (T∞ V) ⊎ V) →
        hd s ≡ u → out t ≡ x → conv-branch _→∞_ s t u x → tl s →∞ t
    conv-out (q {s} {t} (sup (inj₁ (f , α))) (inj₁ (.f , β)) hs≡u ot≡x (refl , m , br))
      = subst₂ (λ u₁ u₂ → conv-branch _→∞_ (tl s) t u₁ u₂)
               (sym (proj₂ (lem₇ s m
                                 (record { conv-out =
                                   subst₂ (λ u₁ u₂ → conv-branch _→∞_ s t u₁ u₂)
                                 (sym hs≡u) (sym ot≡x) (refl , (m , br)) })
                                 hs≡u)
                    )
               )
               (sym ot≡x) (refl , tl-match m , (λ i → lem₅ (split (tl s) f m i) {!!} (br i)))
      -- conv-branch _→∞_ (tl s₁) t₁ (hd (tl s₁)) (out t₁)
      -- conv-branch _→∞_ (tl .s) .t (hd (tl .s)) (out .t)
    q (sup (inj₁ x)) (inj₂ y) hs≡u ot≡x ()
    q (sup (inj₂ y)) (inj₁ (g , β)) hs≡u ot≡x (s₁ , match-hd x , c) = lem₅ s₁ x c
    q (sup (inj₂ y)) (inj₁ (g , β)) hs≡u ot≡x (._ , match-tl m , c) = c
--    conv-out (q (sup (inj₂ y)) (inj₁ (g , β)) hs≡u ot≡x (zero , m , br)) = {!!}
--    conv-out (q {s} {t} (sup (inj₂ y)) (inj₁ x) hs≡u ot≡x (suc n , m , br)) = {!!}
--      q {s} {t} (hd (δ n s)) (inj₁ x) {!!} ot≡x {!!}
--      q (hd (tl s)) (inj₁ x) ? ot≡x br
      --q (hd (δ n s)) (out t) refl refl (conv-out br)
    q (sup (inj₂ y)) (inj₂ y₁) hs≡u ot≡x br = proj₂ br

{-
lem₄ : ∀{V} (s : Stream (T V)) → ∀{t} →
      s →∞ t → tl s →∞ t
lem₄ {V} s {t} p = q {s} {t} (hd s) (out t) refl refl (conv-out p)
  where
    q : ∀{s t} → (u : T V) → (x : ⟪ Σ ⟫ (T∞ V) ⊎ V) →
        hd s ≡ u → out t ≡ x → conv-branch _→∞_ s t u x → tl s →∞ t
    q (sup (inj₁ (f , α))) (inj₁ (.f , β)) hs≡u ot≡x (refl , m , br) = {!!}
    q (sup (inj₁ x)) (inj₂ y) hs≡u ot≡x ()
    conv-out (q (sup (inj₂ y)) (inj₁ (g , β)) hs≡u ot≡x (zero , m , br)) = {!!}
    conv-out (q {s} {t} (sup (inj₂ y)) (inj₁ x) hs≡u ot≡x (suc n , m , br)) = {!!}
--      q {s} {t} (hd (δ n s)) (inj₁ x) {!!} ot≡x {!!}
--      q (hd (tl s)) (inj₁ x) ? ot≡x br
      --q (hd (δ n s)) (out t) refl refl (conv-out br)
    q (sup (inj₂ y)) (inj₂ y₁) hs≡u ot≡x br = proj₂ br
-}
{-
lem₄ {V} s {t} p | sup (inj₁ (f , α)) | inj₁ (.f , β) | refl , m , r =
  q {!!} m r
  where
     q : {s' : Stream (T V)} {t : T∞ V} {f : ∥ Σ ∥} {β : ar Σ f → T∞ V} →
         out t ≡ inj₁ (f , β) →
         (m : RootsMatch s' f) →
         ((i : ar Σ f) → split s' f m i →∞ β i) →
         s' →∞ t
     conv-out (q {s'} {t} ts m n) with hd s' | hd-match m | out t
     conv-out (q {s'} refl m n) | sup (inj₁ (f₁ , α₁)) | refl | inj₁ (.f₁ , β₁)
       = (refl , tl-match m , (λ i → lem₄ (split s' f₁ m i) (n i)))
     conv-out (q () m₁ n) | sup (inj₁ (f₁ , α₁)) | refl | inj₂ v
     conv-out (q ts m n) | sup (inj₂ y) | () | u
lem₄ s p | sup (inj₁ x) | inj₂ y | ()
lem₄ s p | sup (inj₂ y) | inj₁ x | r = {!!}
lem₄ s p | sup (inj₂ y) | inj₂ y₁ | r = proj₂ r
-}

{-
lem₁ : ∀{V} (n k : ℕ) (s : Stream (T V)) → ∀{f g t} →
      first-root-match s f n → first-root-match s g k →
      δ n s →∞ t → δ k s →∞ t → f ≡ g
lem₁ n k s {f} {g} {t} m₁ m₂ c₁ c₂
  with s at n | s at k | m₁ | m₂
       | out t | conv-out c₁ | conv-out c₂
lem₁ zero zero s _ _ c₁ c₂
  | sup (inj₁ (f , α)) | sup (inj₁ (g , β)) | (refl , p) | (refl , q)
  | inj₁ x | w | r =
    trans (proj₁ w) (sym (proj₁ r))
lem₁ zero zero s _ _ c₁ c₂
  | sup (inj₁ (f , α)) | sup (inj₁ (g , β)) | (refl , p) | (refl , q)
  | inj₂ y | () | r
lem₁ zero zero s _ _ c₁ c₂
  | sup (inj₁ (f , α)) | sup (inj₂ y) | (refl , p) | (() , q)
  | v | w | r
lem₁ zero zero s _ _ c₁ c₂
  | sup (inj₂ y) | u | (() , p) | m₂
  | v | w | r
lem₁ zero (suc k) s m₁ m₂ c₁ c₂ | u | u₁ | m₁' | m₂'
  | v | w | r = lem₁ zero k (tl s) (lem₃ s m₁ c₁) {!m₂!} (lem₄ s c₁) c₂
lem₁ (suc n) zero s _ _ c₁ c₂ | u | u₁ | m₁ | m₂ | v | w | r = {!!}
lem₁ (suc n) (suc k) s m₁ m₂ c₁ c₂
  | u | u₁ | _ | _
  | v | w | r = lem₁ n k (tl s) (lem₂ m₁) (lem₂ m₂) c₁ c₂

lem : ∀{V} (n k : ℕ) {s : Stream (T V)} → ∀{f g t} →
      first-root-match s f n → first-root-match s g k →
      δ n s →∞ t → δ k s →∞ t → n ≡ k
lem n k p q c₁ c₂ =
  least-unique NatTO n k p (subst _ (sym (lem₁ n k _ p q c₁ c₂)) q)
  where
    NatTO = TotalOrder.isTotalOrder (DecTotalOrder.totalOrder Nat.decTotalOrder)
{-
lem n k {s} {f} {g} {t} (m₁ , p) (m₂ , q) c₁ c₂ with conv-out c₁ | conv-out c₂
lem zero zero (m₁ , p) (m₂ , q) c₁ c₂ | u | v = refl
lem zero (suc k) (m₁ , p) (m₂ , q) c₁ c₂ | u | v = {!!}
lem (suc n) zero (m₁ , p) (m₂ , q) c₁ c₂ | u | v = {!!}
lem (suc n) (suc k) {s} (m₁ , p) (m₂ , q) c₁ c₂ | u | v =
  cong suc (lem n k {tl s} (m₁ , {!!}) {!!} {!!} {!!})
-}

unique-conv : ∀{V} (s : Stream (T V)) (t₁ t₂ : T∞ V) →
              s →∞ t₁ → s →∞ t₂ → t₁ ~ t₂
out~ (unique-conv s t₁ t₂ p q)
  with hd s | out t₁ | out t₂ | conv-out p | conv-out q
out~ (unique-conv s t₁ t₂ p q)
  | sup (inj₁ (._ , α)) | inj₁ (._ , β) | inj₁ (f , γ)
  | refl , q₁ , ω₁ | refl , q₂ , ω₂
  = refl
    , (λ {i} → unique-conv (split (tl s) f q₁ i)
                           (β i)
                           (γ i)
                           (ω₁ i)
                           (subst (λ u → split (tl s) f u i →∞ γ i)
                                  (RootsMatch-unique q₂ q₁)
                                  (ω₂ i)))
out~ (unique-conv s t₁ t₂ p q)
  | sup (inj₁ x) | inj₁ x₁ | inj₂ y | y₁ | ()
out~ (unique-conv s t₁ t₂ p q)
  | sup (inj₁ x) | inj₂ y | x₁ | () | z
out~ (unique-conv s t₁ t₂ p q)
  | sup (inj₂ v) | inj₁ (f , α) | inj₁ (g , β) | (n , mg , p₁) | (k , mf , q₁)
  with s at n | s at k
out~ (unique-conv s t₁ t₂ p q)
  | sup (inj₂ v) | inj₁ (f , α) | inj₁ (.g , β) | n , m₁ , p₁ | k , (refl , r₂) , q₁
  | sup (inj₁ (f' , γ)) | sup (inj₁ (g , ρ)) =
  (lem₁ n k s ({!m₁!} , {!!}) {!!} {!!} {!!}) , {!!}
out~ (unique-conv s t₁ t₂ p q)
  | sup (inj₂ v) | inj₁ (f , α) | inj₁ (g , β) | n , mg , p₁ | k , (() , _) , q₁
  | sup (inj₁ x) | sup (inj₂ y)
out~ (unique-conv s t₁ t₂ p q)
  | sup (inj₂ v) | inj₁ (f , α) | inj₁ (g , β) | n , (() , _) , p₁ | k , mf , q₁
  | sup (inj₂ y) | b
out~ (unique-conv s t₁ t₂ p q) | sup (inj₂ y) | inj₁ x | inj₂ y₁ | y₂ | z = {!!}
out~ (unique-conv s t₁ t₂ p q) | sup (inj₂ y) | inj₂ y₁ | x₁ | y₂ | z = {!!}
-}

-- | A non-trivial substitution is a substitution σ, such that, for all v ∈ V
-- we have that either σ(v) is a non-trivial term or if it is a variable w, then
-- w = v.
-- This allows us to stop substituting the first time we hit a variable.
NonTrivSubst : Set → Set
NonTrivSubst V = ⨿ (Subst V V) λ σ → (∀ v → isVar (σ v) → σ v ≡ η v)

term-seq-from-subst-seq : ∀{V} → Stream (NonTrivSubst V) → T V → Stream (T V)
hd (term-seq-from-subst-seq Δ t) = t
tl (term-seq-from-subst-seq Δ t) = term-seq-from-subst-seq (tl Δ) (app (proj₁ (hd Δ)) t)

∞term-from-subst-seq : ∀{V} → Stream (NonTrivSubst V) → T V → T∞ V
out (∞term-from-subst-seq Δ (sup (inj₁ (s , α)))) =
  inj₁ (s , (λ i → ∞term-from-subst-seq Δ (α i)))
out (∞term-from-subst-seq Δ (sup (inj₂ v))) with proj₁ (hd Δ) v | proj₂ (hd Δ) v
... | sup (inj₁ (s , α)) | f =
  inj₁ (s , (λ i → ∞term-from-subst-seq (tl Δ) (α i)))
... | sup (inj₂ v₁)      | f with f tt
out (∞term-from-subst-seq Δ (sup (inj₂ v))) | sup (inj₂ .v) | f | refl =
  inj₂ v

{-
∞term-from-subst-seq-converges :
  ∀{V} → (Δ : Stream (NonTrivSubst V)) → (t : T V) →
  term-seq-from-subst-seq Δ t →∞ ∞term-from-subst-seq Δ t
hd-matches   (∞term-from-subst-seq-converges Δ t) = (proj₁ (hd Δ) , refl)
hd-prefix    (∞term-from-subst-seq-converges Δ t) = {!!}
tl-converges (∞term-from-subst-seq-converges Δ t) = {!∞term-from-subst-seq-converges!}
-}


{-# OPTIONS --allow-unsolved-metas #-}
postulate
  A : Set
  a : A

record Q .(x : A) : Set where
  field q : A

record R : Set where
  field s : Q _

  t : A
  t = Q.q s


open import FRP.JS.String using ( String )
open import FRP.JS.Time using ( Time ; _+_ )
open import FRP.JS.Behaviour using ( Beh ; map ; [_] ; join )
open import FRP.JS.DOM using ( DOM ; text )
open import FRP.JS.RSet using ( ⟦_⟧; ⟨_⟩ )
open import FRP.JS.Time using ( toUTCString ; every )
open import FRP.JS.Delay using ( _sec ; _min )

module FRP.JS.Demo.FastClock where

model : ⟦ Beh ⟨ Time ⟩ ⟧
model = map (λ t → t + 5 min) (every (1 sec))

view : ∀ {w} → ⟦ Beh (DOM w) ⟧
view = join (map (λ t → text [ toUTCString t ]) model)

main : ∀ {w} → ⟦ Beh (DOM w) ⟧
main = view


module _ (P : Set) where

data ⊤ : Set where tt : ⊤

foo : ⊤ → Set
foo tt = ⊤

bar : {{_ : ⊤}} → ⊤
bar {{tt}} = tt

error : foo bar → ⊤
error tt = tt


module Properties.Dec where

data ⊥ : Set where

data Dec(A : Set) : Set where
  yes : A → Dec A
  no : (A → ⊥) → Dec A


module Thesis.ANormalDTerm where

open import Thesis.ANormal public
open import Thesis.Changes public
open import Thesis.LangChanges public

ΔΔ : Context → Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δt τ • ΔΔ Γ

-- Because the standard name is so irregular.
Δτ = Δt

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = ⟦ ΔΔ Δ ⟧Context

-- [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set
-- [ ∅ ]Δ ∅ from ∅ to ∅ = ⊤
-- [ τ • Δ ]Δ dv • dρ from v1 • ρ1 to (v2 • ρ2) = [ τ ]τ dv from v1 to v2 × [ Δ ]Δ dρ from ρ1 to ρ2

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

derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
derive-dvar this = this
derive-dvar (that x) = that (derive-dvar x)

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

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm : (Δ : Context) (τ : Type) → Set where
  dvar : ∀ {Δ τ} (x : Var (ΔΔ Δ) (Δt τ)) →
    DTerm Δ τ
  dlett : ∀ {Δ τ σ τ₁} →
    (f : Var Δ (σ ⇒ τ₁)) →
    (x : Var Δ σ) →
    (t : Term (τ₁ • Δ) τ) →
    (df : Var (ΔΔ Δ) (Δτ (σ ⇒ τ₁))) →
    (dx : Var (ΔΔ Δ) (Δτ σ)) →
    (dt : DTerm (τ₁ • Δ) τ) →
    DTerm Δ τ

data DFun (Δ : Context) : (τ : Type) → Set where
  dterm : ∀ {τ} → DTerm Δ τ → DFun Δ τ
  dabs : ∀ {σ τ} → DFun (σ • Δ) τ → DFun Δ (σ ⇒ τ)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ
derive-dterm (var x) = dvar (derive-dvar x)
derive-dterm (lett f x t) =
  dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

⟦_⟧DTerm : ∀ {Δ τ} → DTerm Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
⟦ dvar x ⟧DTerm ρ dρ = ⟦ x ⟧Var dρ
⟦ dlett f x t df dx dt ⟧DTerm ρ dρ =
  let v = (⟦ x ⟧Var ρ)
  in
    ⟦ dt ⟧DTerm
      (⟦ f ⟧Var ρ v • ρ)
      (⟦ df ⟧Var dρ v (⟦ dx ⟧Var dρ) • dρ)

fromtoDeriveDTerm : ∀ {Δ τ} → (t : Term Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dterm t ⟧DTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDeriveDTerm (var x) dρρ = fromtoDeriveDVar x dρρ
fromtoDeriveDTerm (lett f x t) dρρ =
  let fromToF = fromtoDeriveDVar f dρρ
      fromToX = fromtoDeriveDVar x dρρ
      fromToFX = fromToF _ _ _ fromToX
  in fromtoDeriveDTerm t (fromToFX v• dρρ)

derive-dfun : ∀ {Δ σ} → (t : Fun Δ σ) → DFun Δ σ
derive-dfun (term t) = dterm (derive-dterm t)
derive-dfun (abs f) = dabs (derive-dfun f)

⟦_⟧DFun : ∀ {Δ τ} → DFun Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
⟦ dterm t ⟧DFun = ⟦ t ⟧DTerm
⟦ dabs df ⟧DFun ρ dρ = λ v dv → ⟦ df ⟧DFun (v • ρ) (dv • dρ)

fromtoDeriveDFun : ∀ {Δ τ} → (f : Fun Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dfun f ⟧DFun ρ1 dρ) from (⟦ f ⟧Fun ρ1) to (⟦ f ⟧Fun ρ2)
fromtoDeriveDFun (term t) = fromtoDeriveDTerm t
fromtoDeriveDFun (abs f) dρρ = λ dv v1 v2 dvv → fromtoDeriveDFun f (dvv v• dρρ)


-- Andreas, 2018-04-16, issue #3033, reported by Christian Sattler

-- The DotPatternCtx was not used inside dot patterns in ConcreteToAbstract.

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

data C : B → Set where
  c : C (f a)

foo : (b : B) → C b → Set
foo .{!f a!} c = A  -- give "f a" here

-- WAS: foo .f a c = A
-- NOW: foo .(f a) c = A


------------------------------------------------------------------------
-- Examples involving simple λ-calculi
------------------------------------------------------------------------

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

module README.Lambda where

------------------------------------------------------------------------
-- An untyped λ-calculus with constants

-- Some developments from "Operational Semantics Using the Partiality
-- Monad" by Danielsson, implemented using both the quotient
-- inductive-inductive partiality monad, and the delay monad.
--
-- These developments to a large extent mirror developments in
-- "Coinductive big-step operational semantics" by Leroy and Grall.

-- The syntax of, and a type system for, the untyped λ-calculus with
-- constants.

import Lambda.Syntax

-- Most of a virtual machine.

import Lambda.Virtual-machine

-- A compiler.

import Lambda.Compiler

-- A definitional interpreter.

import Lambda.Partiality-monad.Inductive.Interpreter
import Lambda.Delay-monad.Interpreter

-- A type soundness result.

import Lambda.Partiality-monad.Inductive.Type-soundness
import Lambda.Delay-monad.Type-soundness

-- A virtual machine.

import Lambda.Partiality-monad.Inductive.Virtual-machine
import Lambda.Delay-monad.Virtual-machine

-- Compiler correctness.

import Lambda.Partiality-monad.Inductive.Compiler-correctness
import Lambda.Delay-monad.Compiler-correctness

------------------------------------------------------------------------
-- An untyped λ-calculus without constants

-- A variant of the development above. The development above uses a
-- well-scoped variant of the untyped λ-calculus with constants. This
-- development does not use constants. This means that the interpreter
-- cannot crash, so the type soundness result has been omitted.

import Lambda.Simplified.Syntax
import Lambda.Simplified.Virtual-machine
import Lambda.Simplified.Compiler
import Lambda.Simplified.Partiality-monad.Inductive.Interpreter
import Lambda.Simplified.Delay-monad.Interpreter
import Lambda.Simplified.Partiality-monad.Inductive.Virtual-machine
import Lambda.Simplified.Delay-monad.Virtual-machine
import Lambda.Simplified.Partiality-monad.Inductive.Compiler-correctness
import Lambda.Simplified.Delay-monad.Compiler-correctness


{-# OPTIONS --type-in-type #-}
module poly0 where
open import prelude
open import functors
open import poly.core public

variable
  A B C X Y : ∫
  I A⁺ B⁺ C⁺ X⁺ Y⁺ : Set
  A⁻ : A⁺ → Set
  B⁻ : B⁺ → Set
  C⁻ : C⁺ → Set
  X⁻ : X⁺ → Set
  Y⁻ : Y⁺ → Set

∃⊤ ∃⊥ ⊤∫ ∫∫ : Set → ∫
∃⊤ a = a , λ _ → ⊤
∃⊥ a = a , λ _ → ⊥
⊤∫ a = ⊤ , λ _ → a
∫∫ a = a , λ _ → a
𝒴 𝟘 : ∫
𝒴 = ⊤ , λ _ → ⊤
𝟘  = ⊥ , λ _ → ⊥

module _ {A@(A⁺ , A⁻) B@(B⁺ , B⁻) : ∫} where
  infixl 5 _★_
  -- infix notatjon for get
  _★_ : A⁺ → (l : ∫[ A , B ]) → B⁺
  σa ★ l = get l σa
  infixr 4 _#_←_
  -- Infix notatjon for set
  _#_←_ : (a⁺ : A⁺) → (A↝B : ∫[ A , B ]) → B⁻ (a⁺ ★ A↝B) → A⁻ a⁺
  a⁺ # l ← b⁻ = π₂ (l a⁺) b⁻
  _↕_ : (get : A⁺ → B⁺) → (set : (a⁺ : A⁺) → B⁻ (get a⁺) → A⁻ a⁺) → ∫[ A , B ]
  g ↕ s = λ a⁺ → (g a⁺) , (s a⁺)

module _ {A@(A⁺ , A⁻) C@(C⁺ , C⁻) : ∫} (l : ∫[ A , C ]) where
    -- vertical and cartesian factorization
    Factor : Σ[ B ∈ ∫ ] (∫[ A , B ]) × (∫[ B , C ])
    Factor = (A⁺ , C⁻ ∘ get l)
           , id ↕ set l
           , get l ↕ λ _ → id

module lenses (f : A⁺ → B⁺) where
    constant : ∫[ ∃⊥ A⁺ , ∃⊥ B⁺ ]
    emitter  : ∫[ ∃⊤ A⁺ , ∃⊤ B⁺ ]
    sensor   : ∫[ ⊤∫ B⁺ , ⊤∫ A⁺ ]
    constant a⁺ = f a⁺ , id
    emitter  a⁺ = f a⁺ , λ _ → tt
    sensor   _  = tt   , f
open lenses public
enclose : ((a⁺ : A⁺) → B⁻ a⁺) → ∫[ (A⁺ , B⁻) , 𝒴 ]
enclose f a⁺ = tt , λ _ → f a⁺
auto : ∫[ ∃⊤ A⁺ , 𝒴 ]
auto = enclose λ _ → tt

{-
lift∫ : (f : Set → Set) → ∫ → ∫
lift∫ f (A⁺ , A⁻) = A⁺ , f ∘ A⁻

liftLens : ∀ {A B} (f : Set → Set) → ∫[ A , B ] → ∫[ lift∫ f A , lift∫ f B ]
liftLens f l a⁺ with l a⁺
... | b⁺ , setb = b⁺ , φ setb
-}

{-
module lift_comonad (f : Set → Set) {A : ∫} ⦃ f_monad : Monad f ⦄ where
    extract : lift∫ f A ↝ A
    extract a⁺ = a⁺ , η f_monad
    -- id ↕ λ _ → η
    duplicate : lift∫ f A ↝ lift∫ f (lift∫ f A)
    duplicate a⁺ = a⁺ , μ
    -}

module poly-ops where
  infixl 6 _⊗_
  infixl 5 _⊕_
  _⊕_ _⊗_ _⊠_ _⊚_ : ∫ → ∫ → ∫
  (A⁺ , A⁻) ⊕ (B⁺ , B⁻) = (A⁺ ⊎ B⁺) , (A⁻ ⨄ B⁻) -- coproduct
  (A⁺ , A⁻) ⊗ (B⁺ , B⁻) = (A⁺ × B⁺) , (A⁻ ⨃ B⁻) -- product
  (A⁺ , A⁻) ⊠ (B⁺ , B⁻) = (A⁺ × B⁺) , (A⁻ ⨉ B⁻) -- juxtapose
  (A⁺ , A⁻) ⊚ (B⁺ , B⁻) = (Σ[ a⁺ ∈ A⁺ ](A⁻ a⁺ → B⁺)) -- compose
                        , λ (_ , bs) → ∃ (B⁻ ∘ bs)

  -- N-ary
  Σ⊕ : (I → ∫) → ∫
  Σ⊕ {I = I} A = Σ I (π₁ ∘ A) , λ (i , a⁺) → π₂ (A i) a⁺
  Π⊗ : (I → ∫) → ∫
  Π⊗ {I = I} a = ((i : I) → π₁ (a i))
               , λ a⁺ → Σ[ i ∈ I ](π₂ (a i) (a⁺ i))
  Π⊠ : (I → ∫) → ∫
  Π⊠ {I = I} a = ((i : I) → π₁ (a i))
               , (λ a⁺ → (i : I) -> π₂ (a i) (a⁺ i))
  _ᵒ_ : ∫ → ℕ → ∫
  _ ᵒ ℕz = 𝒴
  a ᵒ ℕs n = a ⊚ (a ᵒ n)
open poly-ops public

module lens-ops where
  _⟦+⟧_ : ∀ {a b x y} → ∫[ a , b ] → ∫[ x , y ] → ∫[ a ⊕ x , b ⊕ y ] -- coproduct
  _⟦|⟧_ : ∀ {a b x  } → ∫[ a , x ] → ∫[ b , x ] → ∫[ a ⊕ b ,     x ] -- copair
  _⟦⊗⟧_ : ∀ {a b x y} → ∫[ a , b ] → ∫[ x , y ] → ∫[ a ⊗ x , b ⊗ y ] -- product
  _⟦×⟧_ : ∀ {x a b  } → ∫[ x , a ] → ∫[ x , b ] → ∫[ x     , a ⊗ b ] -- pair
  _⟦⊠⟧_ : ∀ {a b x y} → ∫[ a , b ] → ∫[ x , y ] → ∫[ a ⊠ x , b ⊠ y ] -- juxtaposition
  _⟦⊚⟧_ : ∀ {a b x y} → ∫[ a , b ] → ∫[ x , y ] → ∫[ a ⊚ x , b ⊚ y ] -- composition

  (a↝b ⟦+⟧ x↝y) = λ{(Σ₁ a⁺) → let b⁺ , setb = a↝b a⁺ in Σ₁ b⁺  , setb
                   ;(Σ₂ x⁺) → let y⁺ , sety = x↝y x⁺ in Σ₂ y⁺  , sety}

  (a↝x ⟦|⟧ b↝x) = λ{(Σ₁ a⁺) → a↝x a⁺
                   ;(Σ₂ b⁺) → b↝x b⁺}

  (a↝b ⟦⊗⟧ x↝y) (a⁺ , x⁺) with a↝b a⁺ | x↝y x⁺
  ... | b⁺ , setb | y⁺ , sety = (b⁺ , y⁺)
                  , λ{(Σ₁ b⁻) → Σ₁ (setb b⁻)
                     ;(Σ₂ y⁻) → Σ₂ (sety y⁻)}

  _⟦×⟧_ x↝a x↝b x⁺ with x↝a x⁺ | x↝b x⁺
  ... | a⁺ , seta | b⁺ , setb = (a⁺ , b⁺) , λ{(Σ₁ a⁻) → seta a⁻
                                             ;(Σ₂ b⁻) → setb b⁻}

  _⟦⊠⟧_ a↝b x↝y (a⁺ , x⁺) = ((a⁺ ★ a↝b) , (x⁺ ★ x↝y))
            , λ (b⁻ , y⁻) → (a⁺ # a↝b ← b⁻) , (x⁺ # x↝y ← y⁻)

  (a↝b ⟦⊚⟧ x↝y) (a⁺ , a⁻→x⁺) with a↝b a⁺
  ... | b⁺ , setb = (b⁺ , get x↝y ∘ a⁻→x⁺ ∘ setb)
                  , λ (b⁻ , y⁻) → let a⁻ = setb b⁻
                                  in a⁻ , (a⁻→x⁺ a⁻ # x↝y ← y⁻)

  -- N-ary
  Π⟦⊠⟧ : {as bs : I → ∫}
        → ((i : I) → (∫[ as i , bs i ]))
        → ∫[ Π⊠ as , Π⊠ bs ]
  Π⟦⊠⟧ ls as⁺ = (λ i → as⁺ i ★ ls i)
          , (λ dbs i → as⁺ i # ls i ← dbs i)
  _⟦ᵒ⟧_ : ∫[ A , B ] → (n : ℕ) → ∫[ A ᵒ n , B ᵒ n ]
  _⟦ᵒ⟧_ {a} {b} l = go where
    go : (n : ℕ) → ∫[ a ᵒ n , b ᵒ n ]
    go ℕz    = 𝒾 {x = 𝒴}
    go (ℕs n) = l ⟦⊚⟧ (go n)
open lens-ops public


------------------------------------------------------------------------
-- Queue instances for the queues in Queue.Simple
------------------------------------------------------------------------

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

open import Equality

module Queue.Simple.Instances
  {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺)
  where

open Derived-definitions-and-properties eq

open import Prelude

open import Queue eq
open import Queue.Simple eq as Q using (Queue)

private
  variable
    ℓ ℓ₁ ℓ₂ : Level

instance

  -- Instances.

  Queue-is-queue : Is-queue (λ A → Queue A) (λ _ → ↑ _ ⊤) ℓ
  Queue-is-queue .Is-queue.to-List                   = λ _ → Q.to-List
  Queue-is-queue .Is-queue.from-List                 = Q.from-List
  Queue-is-queue .Is-queue.to-List-from-List         = Q.to-List-from-List
  Queue-is-queue .Is-queue.enqueue                   = Q.enqueue
  Queue-is-queue .Is-queue.to-List-enqueue {q = q}   = Q.to-List-enqueue q
  Queue-is-queue .Is-queue.dequeue                   = λ _ → Q.dequeue
  Queue-is-queue .Is-queue.to-List-dequeue {q = q}   = Q.to-List-dequeue q
  Queue-is-queue .Is-queue.dequeue⁻¹                 = Q.dequeue⁻¹
  Queue-is-queue .Is-queue.to-List-dequeue⁻¹ {x = x} = Q.to-List-dequeue⁻¹ x

  Queue-is-queue-with-map : Is-queue-with-map (λ A → Queue A) ℓ₁ ℓ₂
  Queue-is-queue-with-map .Is-queue-with-map.map                 = Q.map
  Queue-is-queue-with-map .Is-queue-with-map.to-List-map {q = q} =
    Q.to-List-map q


module Data.List.Equiv.Id where

import Lvl
open import Functional
open import Function.Names as Names using (_⊜_)
import      Function.Equals as Fn
open import Data.Boolean
open import Data.Option
open import Data.Option.Equiv.Id
open import Data.Option.Proofs using ()
open import Data.List
open import Data.List.Equiv
open import Data.List.Functions
open import Logic
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Relator.Equals
open import Structure.Function
open import Structure.Function.Domain
import      Structure.Function.Names as Names
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Relator.Properties
open import Structure.Setoid using (Equiv) renaming (_≡_ to _≡ₛ_)
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₑ ℓₑₗ ℓₑₒ ℓₑ₁ ℓₑ₂ ℓₑₗ₁ ℓₑₗ₂ : Lvl.Level
private variable T A B : Type{ℓ}
private variable n : ℕ

open import Relator.Equals
open import Relator.Equals.Proofs

private variable l l₁ l₂ : List(T)
private variable a b x : T
private variable f : A → B
private variable P : List(T) → Stmt{ℓ}

[⊰]-general-cancellation : ((a ⊰ l₁) ≡ (b ⊰ l₂)) → (a ≡ b) ∧ (l₁ ≡ l₂)
[⊰]-general-cancellation p = [∧]-intro (L p) (R p) where
  R : ((a ⊰ l₁) ≡ (b ⊰ l₂)) → (l₁ ≡ l₂)
  R p = congruence₁(tail) p

  L : ((a ⊰ l₁) ≡ (b ⊰ l₂)) → (a ≡ b)
  L {l₁ = ∅}     {l₂ = ∅}      [≡]-intro = [≡]-intro
  L {l₁ = ∅}     {l₂ = _ ⊰ _} p with () ← R p
  L {l₁ = _ ⊰ _} {l₂ = _ ⊰ _} p = injective(Some) (congruence₁(first) p)

instance
  List-Id-extensionality : Extensionality([≡]-equiv {T = List(T)})
  Extensionality.generalized-cancellationᵣ List-Id-extensionality = [∧]-elimₗ ∘ [⊰]-general-cancellation
  Extensionality.generalized-cancellationₗ List-Id-extensionality = [∧]-elimᵣ ∘ [⊰]-general-cancellation
  Extensionality.case-unequality           List-Id-extensionality ()

open import Data.List.Proofs

initial-0-length : (initial(0)(l) ≡ ∅)
initial-0-length {l = ∅}     = reflexivity(_≡_)
initial-0-length {l = x ⊰ l} = reflexivity(_≡_)
{-# REWRITE initial-0-length #-}

multiply-singleton-repeat : (singleton(l) ++^ n ≡ repeat(l)(n))
multiply-singleton-repeat {l = l} {n = 𝟎}   = reflexivity(_≡_)
multiply-singleton-repeat {l = l} {n = 𝐒 n} = congruence₁(l ⊰_) (multiply-singleton-repeat {l = l} {n = n})

module _ {f g : A → B} where
  map-function-raw : (f ⊜ g) → (map f ⊜ map g)
  map-function-raw p {∅} = reflexivity(_≡_)
  map-function-raw p {x ⊰ l} rewrite p{x} = congruence₁(g(x) ⊰_) (map-function-raw p {l})

module _ {f g : A → List(B)} where
  concatMap-function-raw : (f ⊜ g) → (concatMap f ⊜ concatMap g)
  concatMap-function-raw p {∅}                  = reflexivity(_≡_)
  concatMap-function-raw p {x ⊰ l} rewrite p{x} = congruence₁(g(x) ++_) (concatMap-function-raw p {l})

module _ {ℓ₁ ℓ₂ ℓ₃} {A : Type{ℓ₁}} {B : Type{ℓ₂}} {C : Type{ℓ₃}} {f : B → C}{g : A → B} where
  map-preserves-[∘] : (map(f ∘ g) ⊜ (map f ∘ map g))
  map-preserves-[∘] {x = ∅}     = reflexivity(_≡_)
  map-preserves-[∘] {x = x ⊰ l} = congruence₁(f(g(x)) ⊰_) (map-preserves-[∘] {x = l})

map-preserves-id : (map id ⊜ id{T = List(T)})
map-preserves-id {x = ∅} = reflexivity(_≡_)
map-preserves-id {x = x ⊰ l} = congruence₁(x ⊰_) (map-preserves-id {x = l})
{-# REWRITE map-preserves-id #-}

concatMap-[++] : (concatMap f (l₁ ++ l₂) ≡ (concatMap f l₁ ++ concatMap f l₂))
concatMap-[++] {f = f} {∅}      {l₂} = reflexivity(_≡_)
concatMap-[++] {f = f} {x ⊰ l₁} {l₂} =
  (f(x) ++ concatMap f (l₁ ++ l₂))             🝖-[ congruence₁(f(x) ++_) (concatMap-[++] {f = f} {l₁} {l₂}) ]
  (f(x) ++ (concatMap f l₁ ++ concatMap f l₂)) 🝖-[ associativity(_++_) {x = f(x)}{y = concatMap f l₁}{z = concatMap f l₂} ]-sym
  (f(x) ++ concatMap f l₁ ++ concatMap f l₂)   🝖-end

module _ {ℓ₁ ℓ₂ ℓ₃} {A : Type{ℓ₁}} {B : Type{ℓ₂}} {C : Type{ℓ₃}} {f : B → List(C)}{g : A → List(B)} where
  concatMap-[∘] : (concatMap(concatMap f ∘ g)) ⊜ (concatMap f ∘ concatMap g)
  concatMap-[∘] {∅}     = reflexivity(_≡_)
  concatMap-[∘] {x ⊰ l} =
    (concatMap(concatMap f ∘ g)) (x ⊰ l)                  🝖[ _≡_ ]-[]
    (concatMap f ∘ g) x ++ concatMap(concatMap f ∘ g) l   🝖-[ congruence₁((concatMap f ∘ g) x ++_) (concatMap-[∘] {l}) ]
    (concatMap f ∘ g) x ++ (concatMap f ∘ concatMap g) l  🝖[ _≡_ ]-[]
    (concatMap f (g(x))) ++ (concatMap f (concatMap g l)) 🝖-[ concatMap-[++] {f = f}{l₁ = g(x)}{l₂ = concatMap g l} ]-sym
    concatMap f (g(x) ++ concatMap g l)                   🝖[ _≡_ ]-[]
    concatMap f (concatMap g (x ⊰ l))                     🝖[ _≡_ ]-[]
    (concatMap f ∘ concatMap g) (x ⊰ l)                   🝖-end

concatMap-singleton : (concatMap{A = T} singleton) ⊜ id
concatMap-singleton {x = ∅} = reflexivity(_≡_)
concatMap-singleton {x = x ⊰ l} = congruence₁(x ⊰_) (concatMap-singleton {x = l})

concatMap-concat-map : (concatMap f l ≡ concat(map f l))
concatMap-concat-map        {l = ∅} = reflexivity(_≡_)
concatMap-concat-map {f = f}{l = x ⊰ l} =
  concatMap f (x ⊰ l)     🝖[ _≡_ ]-[]
  f(x) ++ concatMap f l   🝖[ _≡_ ]-[ congruence₂ᵣ(_++_)(f(x)) (concatMap-concat-map {l = l}) ]
  f(x) ++ concat(map f l) 🝖[ _≡_ ]-[]
  concat(f(x) ⊰ map f l)  🝖[ _≡_ ]-[]
  concat(map f (x ⊰ l))   🝖-end

foldₗ-lastElem-equivalence : (last{T = T} ⊜ foldₗ (const Option.Some) Option.None)
foldₗ-lastElem-equivalence {x = ∅}         = reflexivity(_≡_)
foldₗ-lastElem-equivalence {x = x ⊰ ∅}     = reflexivity(_≡_)
foldₗ-lastElem-equivalence {x = x ⊰ y ⊰ l} = foldₗ-lastElem-equivalence {x = y ⊰ l}

{-
foldₗ-reverse-equivalence : (reverse{T = T} ⊜ foldₗ (Functional.swap(_⊰_)) ∅)
foldₗ-reverse-equivalence {x = ∅} = reflexivity(_≡_)
foldₗ-reverse-equivalence {x = x ⊰ l} =
  reverse (x ⊰ l)                                           🝖[ _≡_ ]-[]
  (postpend x ∘ reverse) l                                  🝖[ _≡_ ]-[ congruence₁(postpend x) (foldₗ-reverse-equivalence {x = l}) ]
  (postpend x ∘ foldₗ (Functional.swap(_⊰_)) ∅) l           🝖[ _≡_ ]-[ {!!} ]
  foldₗ (Functional.swap(_⊰_)) (Functional.swap(_⊰_) ∅ x) l 🝖[ _≡_ ]-[]
  foldₗ (Functional.swap(_⊰_)) (singleton(x)) l             🝖[ _≡_ ]-[]
  foldₗ (Functional.swap(_⊰_)) ∅ (x ⊰ l)                    🝖-end
-}

foldᵣ-function : ⦃ equiv : Equiv{ℓₑ}(B) ⦄ → ∀{_▫_ : A → B → B} ⦃ oper : BinaryOperator(_▫_) ⦄ → Function ⦃ equiv-B = equiv ⦄ (foldᵣ(_▫_) a)
foldᵣ-function {a = a} ⦃ equiv ⦄ {_▫_ = _▫_} ⦃ oper ⦄ = intro p where
  p : Names.Congruence₁ ⦃ equiv-B = equiv ⦄ (foldᵣ(_▫_) a)
  p {∅}       {∅}       xy = reflexivity(Equiv._≡_ equiv)
  p {x₁ ⊰ l₁} {x₂ ⊰ l₂} xy =
    foldᵣ(_▫_) a (x₁ ⊰ l₁) 🝖[ Equiv._≡_ equiv ]-[]
    x₁ ▫ (foldᵣ(_▫_) a l₁) 🝖[ Equiv._≡_ equiv ]-[ congruence₂(_▫_) ⦃ oper ⦄ ([∧]-elimₗ([⊰]-general-cancellation xy)) (p {l₁} {l₂} ([∧]-elimᵣ([⊰]-general-cancellation xy))) ]
    x₂ ▫ (foldᵣ(_▫_) a l₂) 🝖[ Equiv._≡_ equiv ]-[]
    foldᵣ(_▫_) a (x₂ ⊰ l₂) 🝖-end

foldᵣ-function₊-raw : ∀{l₁ l₂ : List(A)} ⦃ equiv : Equiv{ℓₑ}(B) ⦄ {_▫₁_ _▫₂_ : A → B → B} ⦃ oper₁ : BinaryOperator(_▫₁_) ⦄ ⦃ oper₂ : BinaryOperator ⦃ [≡]-equiv ⦄ ⦃ equiv ⦄ ⦃ equiv ⦄ (_▫₂_) ⦄ {a₁ a₂ : B} → (∀{x y} → (_≡ₛ_ ⦃ equiv ⦄ (x ▫₁ y) (x ▫₂ y))) → (_≡ₛ_ ⦃ equiv ⦄ a₁ a₂) → (l₁ ≡ l₂) → (foldᵣ(_▫₁_) a₁ l₁ ≡ₛ foldᵣ(_▫₂_) a₂ l₂)
foldᵣ-function₊-raw {l₁ = ∅} {∅} ⦃ equiv ⦄ {_▫₁_} {_▫₂_} ⦃ oper₁ ⦄ ⦃ oper₂ ⦄ {a₁} {a₂} opeq aeq leq = aeq
foldᵣ-function₊-raw {l₁ = x₁ ⊰ l₁} {x₂ ⊰ l₂} ⦃ equiv ⦄ {_▫₁_} {_▫₂_} ⦃ oper₁ ⦄ ⦃ oper₂ ⦄ {a₁} {a₂} opeq aeq leq =
  foldᵣ(_▫₁_) a₁ (x₁ ⊰ l₁)  🝖[ Equiv._≡_ equiv ]-[]
  x₁ ▫₁ (foldᵣ(_▫₁_) a₁ l₁) 🝖[ Equiv._≡_ equiv ]-[ congruence₂(_▫₁_) ⦃ oper₁ ⦄ ([∧]-elimₗ([⊰]-general-cancellation leq)) (foldᵣ-function₊-raw {l₁ = l₁} {l₂} ⦃ equiv ⦄ {_▫₁_}{_▫₂_} ⦃ oper₁ ⦄ ⦃ oper₂ ⦄ {a₁}{a₂} opeq aeq ([∧]-elimᵣ([⊰]-general-cancellation leq))) ]
  x₂ ▫₁ (foldᵣ(_▫₂_) a₂ l₂) 🝖[ Equiv._≡_ equiv ]-[ opeq{x₂}{foldᵣ(_▫₂_) a₂ l₂} ]
  x₂ ▫₂ (foldᵣ(_▫₂_) a₂ l₂) 🝖[ Equiv._≡_ equiv ]-[]
  foldᵣ(_▫₂_) a₂ (x₂ ⊰ l₂)  🝖[ Equiv._≡_ equiv ]-end

map-binaryOperator : BinaryOperator {A₁ = A → B} ⦃ equiv-A₁ = Fn.[⊜]-equiv ⦃ [≡]-equiv ⦄ ⦄ ⦃ equiv-A₂ = [≡]-equiv ⦄ (map)
map-binaryOperator = intro p where
  p : Names.Congruence₂(map)
  p {f} {g} {∅}       {∅}       fg xy = reflexivity(_≡_)
  p {f} {g} {x₁ ⊰ l₁} {x₂ ⊰ l₂} fg xy = congruence₂(_⊰_) ba rec where
    ba : f(x₁) ≡ g(x₂)
    ba =
      f(x₁) 🝖[ _≡_ ]-[ Fn._⊜_.proof fg {x₁} ]
      g(x₁) 🝖[ _≡_ ]-[ congruence₁(g) ([∧]-elimₗ([⊰]-general-cancellation xy)) ]
      g(x₂) 🝖-end
    rec : map f(l₁) ≡ map g(l₂)
    rec =
      map f(l₁) 🝖[ _≡_ ]-[ p fg ([∧]-elimᵣ([⊰]-general-cancellation xy)) ]
      map g(l₂) 🝖-end

count-of-[++] : ∀{P} → (count P (l₁ ++ l₂) ≡ count P l₁ + count P l₂)
count-of-[++] {l₁ = ∅}       {l₂ = l₂} {P = P} = reflexivity(_≡_)
count-of-[++] {l₁ = x₁ ⊰ l₁} {l₂ = l₂} {P = P} with P(x₁) | count-of-[++] {l₁ = l₁} {l₂ = l₂} {P = P}
... | 𝑇 | p = congruence₁ 𝐒(p)
... | 𝐹 | p = p

-- TODO Is this true?: count-single-equality-equivalence : (∀{P} → count P l₁ ≡ count P l₂) ↔ (∀{x} → (count (x ≡?_) l₁ ≡ count (x ≡?_) l₂))


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

module Dodo.Binary.SplittableOrder where

-- Stdlib imports
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open import Level using (Level; _⊔_)
open import Function using (_∘_)
open import Data.Empty using (⊥-elim)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_; proj₁; proj₂; ∃-syntax)
open import Relation.Nullary using (¬_)
open import Relation.Unary using (Pred)
open import Relation.Binary using (Rel; REL; Transitive; Trichotomous; Tri; tri<; tri≈; tri>)
open import Relation.Binary.Construct.Closure.Transitive using (TransClosure; [_]; _∷_; _++_)
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Binary.Equality
open import Dodo.Binary.Immediate
open import Dodo.Binary.Trichotomous
open import Dodo.Binary.Transitive
open import Dodo.Binary.Domain
open import Dodo.Binary.Filter

open import Function using (flip)

-- # Definitions #

-- For any `R x y` there exists a /path/ from `x` to `y`.
SplittableOrder : {a ℓ : Level} {A : Set a} (R : Rel A ℓ) → Set (a ⊔ ℓ)
SplittableOrder R = R ⇔₂ TransClosure (immediate R)

-- # Properties #

module _ {a ℓ : Level} {A : Set a} {R : Rel A ℓ} where

  splittable-trans : SplittableOrder R → Transitive R
  splittable-trans splitR Rij Rjk =
    ⇔₂-apply-⊇₂ splitR (⇔₂-apply-⊆₂ splitR Rij ++ ⇔₂-apply-⊆₂ splitR Rjk)

  splittable-flip : SplittableOrder R → SplittableOrder (flip R)
  splittable-flip splitR = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : flip R ⊆₂' TransClosure (immediate (flip R))
    ⊆-proof _ _ = ⁺-map _ imm-flip ∘ ⁺-flip ∘ ⇔₂-apply-⊆₂ splitR

    ⊇-proof : TransClosure (immediate (flip R)) ⊆₂' flip R
    ⊇-proof _ _ = ⇔₂-apply-⊇₂ splitR ∘ ⁺-flip ∘ ⁺-map _ imm-flip

-- # Operations #

-- Split the left-most element from the ordered relation chain
splitˡ : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → SplittableOrder R
  → {x y : A}
  → R x y
    --------------------------------------------------
  → immediate R x y ⊎ ∃[ z ] (immediate R x z × R z y)
splitˡ splitR Rxy with ⇔₂-apply-⊆₂ splitR Rxy
... | [ immRxy ] = inj₁ immRxy
... | _∷_ {x} {z} {y} immRxz immR⁺zy = inj₂ (z , immRxz , ⇔₂-apply-⊇₂ splitR immR⁺zy)

-- Split the right-most element from the ordered relation chain
splitʳ : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → SplittableOrder R
  → {x y : A}
  → R x y
    --------------------------------------------------
  → immediate R x y ⊎ ∃[ z ] (R x z × immediate R z y)
splitʳ {A = A} {R = R} splitR Rxy = lemma (⇔₂-apply-⊆₂ splitR Rxy)
  where
  lemma : ∀ {x y : A} → TransClosure (immediate R) x y → immediate R x y ⊎ ∃[ z ] (R x z × immediate R z y)
  lemma [ immRxy ] = inj₁ immRxy
  lemma ( _∷_ {x} {z} {y} immRxz immR⁺zy ) with lemma immR⁺zy
  ... | inj₁ immRzy = inj₂ (z , proj₁ immRxz , immRzy)
  ... | inj₂ (w , Rzw , immRwy) = inj₂ (w , splittable-trans splitR (proj₁ immRxz) Rzw , immRwy)

-- Splits the given left-most element from the chain.
unsplitˡ : ∀ {a ℓ₁ ℓ₂ : Level} {A : Set a} {_≈_ : Rel A ℓ₁} {R : Rel A ℓ₂}
  → Trichotomous _≈_ R
  → SplittableOrder R
  → {x y z : A}
  → R x z
  → immediate R x y
  → y ≈ z ⊎ R y z
unsplitˡ triR splitR {x} {y} {z} Rxz immRxy with splitˡ splitR Rxz
unsplitˡ triR splitR {x} {y} {z} Rxz immRxy | inj₁ immRxz = inj₁ (tri-immʳ triR immRxy immRxz)
unsplitˡ triR splitR {x} {y} {z} Rxz immRxy | inj₂ (v , immRxv , Rvz) with triR y z
unsplitˡ triR splitR {x} {y} {z} Rxz immRxy | inj₂ (v , immRxv , Rvz) | tri<  Ryz y≢z ¬Rzy = inj₂ Ryz
unsplitˡ triR splitR {x} {y} {z} Rxz immRxy | inj₂ (v , immRxv , Rvz) | tri≈ ¬Ryz y≡z ¬Rzy = inj₁ y≡z
unsplitˡ triR splitR {x} {y} {z} Rxz immRxy | inj₂ (v , immRxv , Rvz) | tri> ¬Ryz y≢z  Rzy = ⊥-elim (proj₂ immRxy (z , Rxz , [ Rzy ]))

-- Splits the given right-most element from the chain.
unsplitʳ : ∀ {a ℓ₁ ℓ₂ : Level} {A : Set a} {_≈_ : Rel A ℓ₁} {R : Rel A ℓ₂}
  → Trichotomous _≈_ R
  → SplittableOrder R
  → {x y z : A}
  → R x z
  → immediate R y z
  → x ≈ y ⊎ R x y
unsplitʳ triR splitR {x} {y} {z} Rxz iRyz with splitʳ splitR Rxz
unsplitʳ triR splitR {x} {y} {z} Rxz iRyz | inj₁ iRxz = inj₁ (tri-immˡ triR iRxz iRyz)
unsplitʳ triR splitR {x} {y} {z} Rxz iRyz | inj₂ (v , Rxv , iRvz) with triR x y
unsplitʳ triR splitR {x} {y} {z} Rxz iRyz | inj₂ (v , Rxv , iRvz) | tri<  Rxy x≢y ¬Ryx = inj₂ Rxy
unsplitʳ triR splitR {x} {y} {z} Rxz iRyz | inj₂ (v , Rxv , iRvz) | tri≈ ¬Rxy x≡y ¬Ryx = inj₁ x≡y
unsplitʳ triR splitR {x} {y} {z} Rxz iRyz | inj₂ (v , Rxv , iRvz) | tri> ¬Rxy x≢y  Ryx = ⊥-elim (proj₂ iRyz (x , Ryx , [ Rxz ]))

splittable-imm-udr : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → SplittableOrder R
  → udr R ⇔₁ udr (immediate R)
splittable-imm-udr {R = R} splitR = ⇔: ⊆-proof ⊇-proof
  where
  ⊆-proof : udr R ⊆₁' udr (immediate R)
  ⊆-proof x (inj₁ (y , Rxy)) = inj₁ (⁺-dom (⇔₂-apply-⊆₂ splitR Rxy))
  ⊆-proof y (inj₂ (x , Rxy)) = inj₂ (⁺-codom (⇔₂-apply-⊆₂ splitR Rxy))

  ⊇-proof : udr (immediate R) ⊆₁' udr R
  ⊇-proof x (inj₁ (y , Rxy)) = inj₁ (y , proj₁ Rxy)
  ⊇-proof y (inj₂ (x , Rxy)) = inj₂ (x , proj₁ Rxy)

-- | If any value in the chain of R satisfies P, it remains splittable after lifting.
--
-- The chain is traversed /to the left/.
filter-splittableˡ : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → SplittableOrder R
  → (P : Pred A ℓ)
  → (∀ {x y : A} → P y → R x y → P x)
    ---------------------------------
  → SplittableOrder (filter-rel P R)
filter-splittableˡ {A = A} {R = R} splitR P f = ⇔: ⊆-proof ⊇-proof
  where
  lemma⊆-imm : ∀ {x y : A} → (Px : P x) → (Py : P y) → immediate R x y → immediate (filter-rel P R) (with-pred x Px) (with-pred y Py)
  lemma⊆-imm {x} {y} Px Py (Rxy , ¬∃z) = Rxy , ¬∃z'
    where
    ¬∃z' : ¬ (∃[ z ] filter-rel P R (with-pred x Px) z × TransClosure (filter-rel P R) z (with-pred y Py))
    ¬∃z' (with-pred z Pz , Rxz , R⁺zy) = ¬∃z (z , Rxz , ⁺-strip-filter R⁺zy)

  lemma⊆ : ∀ {x y : A} → (Px : P x) → (Py : P y) → TransClosure (immediate R) x y
    → TransClosure (immediate (filter-rel P R)) (with-pred x Px) (with-pred y Py)
  lemma⊆ Px Py [ iRxy ] = [ lemma⊆-imm Px Py iRxy ]
  lemma⊆ Px Py ( iRxz ∷ iR⁺zy ) =
    let Pz = ⁺-predˡ (λ Pz → f Pz ∘ proj₁) iR⁺zy Py
    in lemma⊆-imm Px Pz iRxz ∷ lemma⊆ Pz Py iR⁺zy

  ⊆-proof : filter-rel P R ⊆₂' TransClosure (immediate (filter-rel P R))
  ⊆-proof (with-pred x Px) (with-pred y Py) Rxy = lemma⊆ Px Py (⇔₂-apply-⊆₂ splitR Rxy)

  lemma⊇-imm : ∀ {x y : A} → (Px : P x) → (Py : P y) → immediate (filter-rel P R) (with-pred x Px) (with-pred y Py)
    → immediate R x y
  lemma⊇-imm {x} {y} Px Py (Rxy , ¬∃z) = (Rxy , ¬∃z')
    where
    ¬∃z' : ¬ (∃[ z ] R x z × TransClosure R z y)
    ¬∃z' (z , Rxz , R⁺zy) =
      let Pz = ⁺-predˡ f R⁺zy Py
      in ¬∃z (with-pred z Pz , Rxz , ⁺-filter-relˡ f Pz Py R⁺zy)

  lemma⊇ : ∀ {x y : A} → (Px : P x) → (Py : P y)
    → TransClosure (immediate (filter-rel P R)) (with-pred x Px) (with-pred y Py)
    → TransClosure (immediate R) x y
  lemma⊇ Px Py [ iRxy ] = [ lemma⊇-imm Px Py iRxy ]
  lemma⊇ Px Py ( _∷_ {_} {with-pred z Pz} iRxz iR⁺zy ) = lemma⊇-imm Px Pz iRxz ∷ lemma⊇ Pz Py iR⁺zy

  ⊇-proof : TransClosure (immediate (filter-rel P R)) ⊆₂' filter-rel P R
  ⊇-proof (with-pred x Px) (with-pred y Py) Rxy = ⇔₂-apply-⊇₂ splitR (lemma⊇ Px Py Rxy)

-- | If any value in the chain of R satisfies P, it remains splittable after lifting.
--
-- The chain is traversed /to the right/.
filter-splittableʳ : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → SplittableOrder R
  → (P : Pred A ℓ)
  → (∀ {x y : A} → P x → R x y → P y)
    ---------------------------------
  → SplittableOrder (filter-rel P R)
filter-splittableʳ {A = A} {R = R} splitR P f = ⇔: ⊆-proof ⊇-proof
  where
  lemma⊆-imm : ∀ {x y : A} → (Px : P x) → (Py : P y) → immediate R x y → immediate (filter-rel P R) (with-pred x Px) (with-pred y Py)
  lemma⊆-imm {x} {y} Px Py (Rxy , ¬∃z) = Rxy , ¬∃z'
    where
    ¬∃z' : ¬ (∃[ z ] filter-rel P R (with-pred x Px) z × TransClosure (filter-rel P R) z (with-pred y Py))
    ¬∃z' (with-pred z Pz , Rxz , R⁺zy) = ¬∃z (z , Rxz , ⁺-strip-filter R⁺zy)

  lemma⊆ : ∀ {x y : A} → (Px : P x) → (Py : P y) → TransClosure (immediate R) x y
    → TransClosure (immediate (filter-rel P R)) (with-pred x Px) (with-pred y Py)
  lemma⊆ Px Py [ iRxy ] = [ lemma⊆-imm Px Py iRxy ]
  lemma⊆ Px Py ( iRxz ∷ iR⁺zy ) =
    let Pz = f Px (proj₁ iRxz)
    in lemma⊆-imm Px Pz iRxz ∷ lemma⊆ Pz Py iR⁺zy

  ⊆-proof : filter-rel P R ⊆₂' TransClosure (immediate (filter-rel P R))
  ⊆-proof (with-pred x Px) (with-pred y Py) Rxy = lemma⊆ Px Py (⇔₂-apply-⊆₂ splitR Rxy)

  lemma⊇-imm : ∀ {x y : A} → (Px : P x) → (Py : P y) → immediate (filter-rel P R) (with-pred x Px) (with-pred y Py)
    → immediate R x y
  lemma⊇-imm {x} {y} Px Py (Rxy , ¬∃z) = Rxy , ¬∃z'
    where
    ¬∃z' : ¬ (∃[ z ] R x z × TransClosure R z y)
    ¬∃z' (z , Rxz , R⁺zy) =
      let Pz = f Px Rxz
      in ¬∃z (with-pred z Pz , Rxz , ⁺-filter-relʳ f Pz Py R⁺zy)

  lemma⊇ : ∀ {x y : A} → (Px : P x) → (Py : P y)
    → TransClosure (immediate (filter-rel P R)) (with-pred x Px) (with-pred y Py)
    → TransClosure (immediate R) x y
  lemma⊇ Px Py [ iRxy ] = [ lemma⊇-imm Px Py iRxy ]
  lemma⊇ Px Py ( _∷_ {_} {with-pred z Pz} iRxz iR⁺zy ) = lemma⊇-imm Px Pz iRxz ∷ lemma⊇ Pz Py iR⁺zy

  ⊇-proof : TransClosure (immediate (filter-rel P R)) ⊆₂' filter-rel P R
  ⊇-proof (with-pred x Px) (with-pred y Py) Rxy = ⇔₂-apply-⊇₂ splitR (lemma⊇ Px Py Rxy)


{-

This file contains:
  - Some alternative inductive definitions of James, and they give the same results.

  The most relevant one is called `𝕁Red` because it is much simpler.
  It has fewer constructors, among which the 2-dimensional constructor `coh`
  has a form essentially more clearer, and it avoids indexes.

-}
{-# OPTIONS --safe #-}
module Cubical.HITs.James.Inductive.Reduced where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Univalence

open import Cubical.Data.Nat
open import Cubical.HITs.SequentialColimit
open import Cubical.HITs.James.Inductive.Base
  renaming (𝕁ames to 𝕁amesConstruction ; 𝕁ames∞ to 𝕁ames∞Construction)

private
  variable
    ℓ : Level

module _
  ((X , x₀) : Pointed ℓ) where

  infixr 5 _∷_

  -- Inductive James with fewer constructors

  data 𝕁Red : Type ℓ where
    [] : 𝕁Red
    _∷_  : X → 𝕁Red → 𝕁Red
    unit : (x : X)(xs : 𝕁Red) → x₀ ∷ x ∷ xs ≡ x ∷ x₀ ∷ xs
    coh  : (xs : 𝕁Red) → refl ≡ unit x₀ xs

  data 𝕁Red∞ : Type ℓ where
    inl : 𝕁Red → 𝕁Red∞
    push : (xs : 𝕁Red) → inl xs ≡ inl (x₀ ∷ xs)

  -- Auxiliary constructions
  -- The following square of types is defined as HIT over I × I.
  -- Notice that the constructor `incl∷` can be seen parametrized by i, `coh` by both i j,
  -- and other constructors are constant.

  data 𝕁Square (i j : I) : Type ℓ where
    []    : 𝕁Square i j
    _∷_   : X → 𝕁Square i j → 𝕁Square i j
    incl  : 𝕁Square i j → 𝕁Square i j
    unit  : (xs : 𝕁Square i j) → incl xs ≡ x₀ ∷ xs
    incl∷ : (x : X)(xs : 𝕁Square i j) → unit (x ∷ xs) i ≡ x ∷ unit xs i
    coh   : (xs : 𝕁Square i j) →
      PathP (λ k → unit (unit xs (i ∨ k)) i ≡ unit (unit xs i) (i ∨ j ∨ k))
            (λ k → unit (unit xs i) (i ∨ j ∧ k)) (incl∷ x₀ xs)

  -- What we need actually is its diagonal.
  𝕁Path : I → Type ℓ
  𝕁Path i = 𝕁Square i (~ i)

  -- If you expand the very definition at end points,
  -- you will find that `𝕁Red` is almost a deformation retraction of `𝕁1`,
  -- and `𝕁0` is almost the same as the original inductive definition of James.
  -- That explains why the isomorphisms given bellow are mainly of c-c, c-v and refls.
  𝕁0 = 𝕁Path i0
  𝕁1 = 𝕁Path i1

  data 𝕁Path∞ (i : I) : Type ℓ where
    inl : 𝕁Path i → 𝕁Path∞ i
    push : (xs : 𝕁Path i) → inl xs ≡ inl (unit xs i)

  𝕁0∞ = 𝕁Path∞ i0
  𝕁1∞ = 𝕁Path∞ i1

  -- The equivalence 𝕁1 ≃ 𝕁Red
  -- This part reduces the constructors.

  𝕁1→𝕁Red : 𝕁1 → 𝕁Red
  𝕁1→𝕁Red [] = []
  𝕁1→𝕁Red (x ∷ xs) = x ∷ 𝕁1→𝕁Red xs
  𝕁1→𝕁Red (incl xs) = x₀ ∷ 𝕁1→𝕁Red xs
  𝕁1→𝕁Red (incl∷ x xs i) = unit x (𝕁1→𝕁Red xs) i
  𝕁1→𝕁Red (unit xs i) = x₀ ∷ 𝕁1→𝕁Red xs
  𝕁1→𝕁Red (coh xs i j) = coh (𝕁1→𝕁Red xs) i j

  𝕁Red→𝕁1 : 𝕁Red → 𝕁1
  𝕁Red→𝕁1 [] = []
  𝕁Red→𝕁1 (x ∷ xs) = x ∷ 𝕁Red→𝕁1 xs
  𝕁Red→𝕁1 (unit x xs i) = incl∷ x (𝕁Red→𝕁1 xs) i
  𝕁Red→𝕁1 (coh xs i j) = coh (𝕁Red→𝕁1 xs) i j

  𝕁Red→𝕁1→𝕁Red : (xs : 𝕁Red) → 𝕁1→𝕁Red (𝕁Red→𝕁1 xs) ≡ xs
  𝕁Red→𝕁1→𝕁Red [] = refl
  𝕁Red→𝕁1→𝕁Red (x ∷ xs) t = x ∷ 𝕁Red→𝕁1→𝕁Red xs t
  𝕁Red→𝕁1→𝕁Red (unit x xs i) t = unit x (𝕁Red→𝕁1→𝕁Red xs t) i
  𝕁Red→𝕁1→𝕁Red (coh xs i j) t = coh (𝕁Red→𝕁1→𝕁Red xs t) i j

  𝕁1→𝕁Red→𝕁1 : (xs : 𝕁1) → 𝕁Red→𝕁1 (𝕁1→𝕁Red xs) ≡ xs
  𝕁1→𝕁Red→𝕁1 [] = refl
  𝕁1→𝕁Red→𝕁1 (x ∷ xs) t = x ∷ 𝕁1→𝕁Red→𝕁1 xs t
  𝕁1→𝕁Red→𝕁1 (incl xs) = (λ t → x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs t) ∙ sym (unit xs)
  𝕁1→𝕁Red→𝕁1 (incl∷ x xs i) t = incl∷ x (𝕁1→𝕁Red→𝕁1 xs t) i
  𝕁1→𝕁Red→𝕁1 (unit xs i) j =
    hcomp (λ k → λ
      { (i = i0) → compPath-filler (λ t → x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs t) (sym (unit xs)) k j
      ; (i = i1) → x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs j
      ; (j = i0) → x₀ ∷ 𝕁Red→𝕁1 (𝕁1→𝕁Red xs)
      ; (j = i1) → unit xs (i ∨ ~ k)})
    (x₀ ∷ 𝕁1→𝕁Red→𝕁1 xs j)
  𝕁1→𝕁Red→𝕁1 (coh xs i j) t = coh (𝕁1→𝕁Red→𝕁1 xs t) i j

  𝕁Red∞→𝕁1∞ : 𝕁Red∞ → 𝕁1∞
  𝕁Red∞→𝕁1∞ (inl xs) = inl (𝕁Red→𝕁1 xs)
  𝕁Red∞→𝕁1∞ (push xs i) = push (𝕁Red→𝕁1 xs) i

  𝕁1∞→𝕁Red∞ : 𝕁1∞ → 𝕁Red∞
  𝕁1∞→𝕁Red∞ (inl xs) = inl (𝕁1→𝕁Red xs)
  𝕁1∞→𝕁Red∞ (push xs i) = push (𝕁1→𝕁Red xs) i

  𝕁Red∞→𝕁1∞→𝕁Red∞ : (xs : 𝕁Red∞) → 𝕁1∞→𝕁Red∞ (𝕁Red∞→𝕁1∞ xs) ≡ xs
  𝕁Red∞→𝕁1∞→𝕁Red∞ (inl xs) t = inl (𝕁Red→𝕁1→𝕁Red xs t)
  𝕁Red∞→𝕁1∞→𝕁Red∞ (push xs i) t = push (𝕁Red→𝕁1→𝕁Red xs t) i

  𝕁1∞→𝕁Red∞→𝕁1∞ : (xs : 𝕁1∞) → 𝕁Red∞→𝕁1∞ (𝕁1∞→𝕁Red∞ xs) ≡ xs
  𝕁1∞→𝕁Red∞→𝕁1∞ (inl xs) t = inl (𝕁1→𝕁Red→𝕁1 xs t)
  𝕁1∞→𝕁Red∞→𝕁1∞ (push xs i) t = push (𝕁1→𝕁Red→𝕁1 xs t) i

  𝕁1∞≃𝕁Red∞ : 𝕁1∞ ≃ 𝕁Red∞
  𝕁1∞≃𝕁Red∞ = isoToEquiv (iso 𝕁1∞→𝕁Red∞ 𝕁Red∞→𝕁1∞ 𝕁Red∞→𝕁1∞→𝕁Red∞ 𝕁1∞→𝕁Red∞→𝕁1∞)

  -- The equivalence 𝕁ames ≃ 𝕁0
  -- This part removes the indexes.

  private
    𝕁ames  = 𝕁amesConstruction  (X , x₀)
    𝕁ames∞ = 𝕁ames∞Construction (X , x₀)

  index : 𝕁0 → ℕ
  index [] = 0
  index (x ∷ xs) = 1 + index xs
  index (incl xs) = 1 + index xs
  index (incl∷ x xs i) = 2 + index xs
  index (unit xs i) = 1 + index xs
  index (coh xs i j) = 2 + index xs

  𝕁ames→𝕁0 : {n : ℕ} → 𝕁ames n → 𝕁0
  𝕁ames→𝕁0 [] = []
  𝕁ames→𝕁0 (x ∷ xs) = x ∷ 𝕁ames→𝕁0 xs
  𝕁ames→𝕁0 (incl xs) = incl (𝕁ames→𝕁0 xs)
  𝕁ames→𝕁0 (incl∷ x xs i) = incl∷ x (𝕁ames→𝕁0 xs) i
  𝕁ames→𝕁0 (unit xs i) = unit (𝕁ames→𝕁0 xs) i
  𝕁ames→𝕁0 (coh xs i j) = coh (𝕁ames→𝕁0 xs) i j

  𝕁0→𝕁ames : (xs : 𝕁0) → 𝕁ames (index xs)
  𝕁0→𝕁ames [] = []
  𝕁0→𝕁ames (x ∷ xs) = x ∷ 𝕁0→𝕁ames xs
  𝕁0→𝕁ames (incl xs) = incl (𝕁0→𝕁ames xs)
  𝕁0→𝕁ames (incl∷ x xs i) = incl∷ x (𝕁0→𝕁ames xs) i
  𝕁0→𝕁ames (unit xs i) = unit (𝕁0→𝕁ames xs) i
  𝕁0→𝕁ames (coh xs i j) = coh (𝕁0→𝕁ames xs) i j

  𝕁0→𝕁ames→𝕁0 : (xs : 𝕁0) → 𝕁ames→𝕁0 (𝕁0→𝕁ames xs) ≡ xs
  𝕁0→𝕁ames→𝕁0 [] = refl
  𝕁0→𝕁ames→𝕁0 (x ∷ xs) t = x ∷ 𝕁0→𝕁ames→𝕁0 xs t
  𝕁0→𝕁ames→𝕁0 (incl xs) t = incl (𝕁0→𝕁ames→𝕁0 xs t)
  𝕁0→𝕁ames→𝕁0 (incl∷ x xs i) t = incl∷ x (𝕁0→𝕁ames→𝕁0 xs t) i
  𝕁0→𝕁ames→𝕁0 (unit xs i) t = unit (𝕁0→𝕁ames→𝕁0 xs t) i
  𝕁0→𝕁ames→𝕁0 (coh xs i j) t = coh (𝕁0→𝕁ames→𝕁0 xs t) i j

  index-path : {n : ℕ}(xs : 𝕁ames n) → index (𝕁ames→𝕁0 xs) ≡ n
  index-path [] = refl
  index-path (x ∷ xs) t = 1 + index-path xs t
  index-path (incl xs) t = 1 + index-path xs t
  index-path (incl∷ x xs i) t = 2 + index-path xs t
  index-path (unit xs i) t = 1 + index-path xs t
  index-path (coh xs i j) t = 2 + index-path xs t

  𝕁ames→𝕁0→𝕁ames : {n : ℕ}(xs : 𝕁ames n)
    → PathP (λ i → 𝕁ames (index-path xs i)) (𝕁0→𝕁ames (𝕁ames→𝕁0 xs)) xs
  𝕁ames→𝕁0→𝕁ames [] = refl
  𝕁ames→𝕁0→𝕁ames (x ∷ xs) t = x ∷ 𝕁ames→𝕁0→𝕁ames xs t
  𝕁ames→𝕁0→𝕁ames (incl xs) t = incl (𝕁ames→𝕁0→𝕁ames xs t)
  𝕁ames→𝕁0→𝕁ames (incl∷ x xs i) t = incl∷ x (𝕁ames→𝕁0→𝕁ames xs t) i
  𝕁ames→𝕁0→𝕁ames (unit xs i) t = unit (𝕁ames→𝕁0→𝕁ames xs t) i
  𝕁ames→𝕁0→𝕁ames (coh xs i j) t = coh (𝕁ames→𝕁0→𝕁ames xs t) i j

  𝕁ames∞→𝕁0∞ : 𝕁ames∞ → 𝕁0∞
  𝕁ames∞→𝕁0∞ (inl xs) = inl (𝕁ames→𝕁0 xs)
  𝕁ames∞→𝕁0∞ (push xs i) = push (𝕁ames→𝕁0 xs) i

  𝕁0∞→𝕁ames∞ : 𝕁0∞ → 𝕁ames∞
  𝕁0∞→𝕁ames∞ (inl xs) = inl (𝕁0→𝕁ames xs)
  𝕁0∞→𝕁ames∞ (push xs i) = push (𝕁0→𝕁ames xs) i

  𝕁ames∞→𝕁0∞→𝕁ames∞ : (xs : 𝕁ames∞) → 𝕁0∞→𝕁ames∞ (𝕁ames∞→𝕁0∞ xs) ≡ xs
  𝕁ames∞→𝕁0∞→𝕁ames∞ (inl xs) t = inl (𝕁ames→𝕁0→𝕁ames xs t)
  𝕁ames∞→𝕁0∞→𝕁ames∞ (push xs i) t = push (𝕁ames→𝕁0→𝕁ames xs t) i

  𝕁0∞→𝕁ames∞→𝕁0∞ : (xs : 𝕁0∞) → 𝕁ames∞→𝕁0∞ (𝕁0∞→𝕁ames∞ xs) ≡ xs
  𝕁0∞→𝕁ames∞→𝕁0∞ (inl xs) t = inl (𝕁0→𝕁ames→𝕁0 xs t)
  𝕁0∞→𝕁ames∞→𝕁0∞ (push xs i) t = push (𝕁0→𝕁ames→𝕁0 xs t) i

  𝕁ames∞≃𝕁0∞ : 𝕁ames∞ ≃ 𝕁0∞
  𝕁ames∞≃𝕁0∞ = isoToEquiv (iso 𝕁ames∞→𝕁0∞ 𝕁0∞→𝕁ames∞ 𝕁0∞→𝕁ames∞→𝕁0∞ 𝕁ames∞→𝕁0∞→𝕁ames∞)

  -- The main equivalence:

  𝕁ames∞≃𝕁Red∞ : 𝕁ames∞ ≃ 𝕁Red∞
  𝕁ames∞≃𝕁Red∞ = compEquiv 𝕁ames∞≃𝕁0∞ (compEquiv (pathToEquiv (λ i → 𝕁Path∞ i)) 𝕁1∞≃𝕁Red∞)

  -- Test of canonicity
  private
    -- It's good for [].
    eq1 : 𝕁ames∞≃𝕁Red∞ .fst (inl []) ≡ inl []
    eq1 = refl

    -- Without regularity, "obvious" equality doesn't hold definitionally.
    eq2 : (x : X) → 𝕁ames∞≃𝕁Red∞ .fst (inl (x ∷ [])) ≡ inl (x ∷ [])
    eq2 _ = transportRefl _


{-# OPTIONS --allow-unsolved-metas #-}

module Control.Monad.Free where

open import Prelude

data Free (F : Type a → Type a) (A : Type a) : Type (ℓsuc a) where
  lift : F A → Free F A

  return : A → Free F A
  _>>=_ : Free F B → (B → Free F A) → Free F A

  >>=-idˡ   : isSet A → (f : B → Free F A) (x : B) → (return x >>= f) ≡ f x
  >>=-idʳ   : isSet A → (x : Free F A) → (x >>= return) ≡ x
  >>=-assoc : isSet A → (xs : Free F C) (f : C → Free F B) (g : B → Free F A) → ((xs >>= f) >>= g) ≡ (xs >>= (λ x → f x >>= g))

  trunc : isSet A → isSet (Free F A)

data FreeF (F : Type a → Type a)  (P : ∀ {T} → Free F T → Type b) (A : Type a) : Type (ℓsuc a ℓ⊔ b) where
  liftF : F A → FreeF F P A
  returnF : A → FreeF F P A
  bindF : (xs : Free F B) (P⟨xs⟩ : P xs) (k : B → Free F A) (P⟨∘k⟩ : ∀ x → P (k x)) → FreeF F P A

private
  variable
    F : Type a → Type a
    G : Type b → Type b
    p : Level
    P : ∀ {T} → Free F T → Type p

⟪_⟫ : FreeF F P A → Free F A
⟪ liftF x ⟫ = lift x
⟪ returnF x ⟫ = return x
⟪ bindF xs P⟨xs⟩ k P⟨∘k⟩ ⟫ = xs >>= k

Alg : (F : Type a → Type a) (P : ∀ {T} → Free F T → Type b) → Type _
Alg F P = ∀ {A} → (xs : FreeF F P A) → P ⟪ xs ⟫

record Coherent {a p} {F : Type a → Type a} {P : ∀ {T} → Free F T → Type p} (ψ : Alg F P) : Type (ℓsuc a ℓ⊔ p) where
  field
    c-set : ∀ {T} → isSet T → ∀ xs → isSet (P {T = T} xs) -- possibly needs to be isSet T → isSet (P {T = T} xs)

    c->>=idˡ : ∀ (isb : isSet B) (f : A → Free F B) Pf x → ψ (bindF (return x) (ψ (returnF x)) f Pf) ≡[ i ≔ P (>>=-idˡ isb f x i) ]≡ Pf x
    c->>=idʳ : ∀ (isa : isSet A) (x : Free F A) Px → ψ (bindF x Px return (λ y → ψ (returnF y))) ≡[ i ≔ P (>>=-idʳ isa x i) ]≡ Px
    c->>=assoc : ∀ (isa : isSet A)
      (xs : Free F C) Pxs
      (f : C → Free F B) Pf
      (g : B → Free F A) Pg →
      ψ (bindF (xs >>= f) (ψ (bindF xs Pxs f Pf)) g Pg)
        ≡[ i ≔ P (>>=-assoc isa xs f g i) ]≡
          ψ (bindF xs Pxs (λ x → f x >>= g) λ x → ψ (bindF (f x) (Pf x) g Pg))
open Coherent public

Ψ : (F : Type a → Type a) (P : ∀ {T} → Free F T → Type p) → Type _
Ψ F P = Σ (Alg F P) Coherent

infixr 1 Ψ
syntax Ψ F (λ v → e) = Ψ[ v ⦂ F * ] ⇒ e

Φ : (Type a → Type a) → Type b → Type _
Φ A B = Ψ A (λ _ → B)

⟦_⟧ : Ψ F P → (xs : Free F A) → P xs
⟦ alg ⟧ (lift x) = alg .fst (liftF x)
⟦ alg ⟧ (return x) = alg .fst (returnF x)
⟦ alg ⟧ (xs >>= k) = alg .fst (bindF xs (⟦ alg ⟧ xs) k (⟦ alg ⟧ ∘ k))
⟦ alg ⟧ (>>=-idˡ iss f k i) = alg .snd .c->>=idˡ iss f (⟦ alg ⟧ ∘ f) k i
⟦ alg ⟧ (>>=-idʳ iss xs i) = alg .snd .c->>=idʳ iss xs (⟦ alg ⟧ xs) i
⟦ alg ⟧ (>>=-assoc iss xs f g i) = alg .snd .c->>=assoc iss xs (⟦ alg ⟧ xs) f (⟦ alg ⟧ ∘ f) g (⟦ alg ⟧ ∘ g) i
⟦ alg ⟧ (trunc AIsSet xs ys p q i j) =
  isOfHLevel→isOfHLevelDep 2
    (alg .snd .c-set AIsSet)
    (⟦ alg ⟧ xs) (⟦ alg ⟧ ys)
    (cong ⟦ alg ⟧ p) (cong ⟦ alg ⟧ q)
    (trunc AIsSet xs ys p q)
    i j

prop-coh : {alg : Alg F P} → (∀ {T} → isSet T → ∀ xs → isProp (P {T} xs)) → Coherent alg
prop-coh P-isProp .c-set TIsSet xs = isProp→isSet (P-isProp TIsSet xs)
prop-coh {P = P} P-isProp .c->>=idˡ iss f Pf x =
  toPathP (P-isProp iss (f x) (transp (λ i → P (>>=-idˡ iss f x i)) i0 _) _)
prop-coh {P = P} P-isProp .c->>=idʳ iss x Px =
  toPathP (P-isProp iss x (transp (λ i → P (>>=-idʳ iss x i)) i0 _) _)
prop-coh {P = P} P-isProp .c->>=assoc iss xs Pxs f Pf g Pg =
  toPathP (P-isProp iss (xs >>= (λ x → f x >>= g)) (transp (λ i → P (>>=-assoc iss xs f g i)) i0 _) _)

-- infix 4 _⊜_
-- record AnEquality (F : Type a → Type a) (A : Type a) : Type (ℓsuc a) where
--   constructor _⊜_
--   field lhs rhs : Free F A
-- open AnEquality public

-- EqualityProof-Alg : (F : Type a → Type a) (P : ∀ {A} → Free F A → AnEquality G A) → Type _
-- EqualityProof-Alg F P = Alg F (λ xs → let Pxs = P xs in lhs Pxs ≡ rhs Pxs)

-- eq-coh : {P : ∀ {A} → Free F A → AnEquality G A} {alg : EqualityProof-Alg F P} → Coherent alg
-- eq-coh {P = P} = prop-coh λ xs → let Pxs = P xs in trunc (lhs Pxs) (rhs Pxs)

open import Algebra

module _ {F : Type a → Type a} where
  freeMonad : SetMonad a (ℓsuc a)
  freeMonad .SetMonad.𝐹 = Free F
  freeMonad .SetMonad.isSetMonad .IsSetMonad._>>=_ = _>>=_
  freeMonad .SetMonad.isSetMonad .IsSetMonad.return = return
  freeMonad .SetMonad.isSetMonad .IsSetMonad.>>=-idˡ = >>=-idˡ
  freeMonad .SetMonad.isSetMonad .IsSetMonad.>>=-idʳ = >>=-idʳ
  freeMonad .SetMonad.isSetMonad .IsSetMonad.>>=-assoc = >>=-assoc
  freeMonad .SetMonad.isSetMonad .IsSetMonad.trunc = trunc

module _ {ℓ} (mon : SetMonad ℓ ℓ) where
  module F = SetMonad mon

  open F using (𝐹)

  module _ {G : Type ℓ → Type ℓ} (h : ∀ {T} → G T → 𝐹 T) where
    ⟦_⟧′ : Free G A → 𝐹 A
    ⟦ lift x ⟧′ = h x
    ⟦ return x ⟧′ = F.return x
    ⟦ xs >>= k ⟧′ = ⟦ xs ⟧′ F.>>= λ x → ⟦ k x ⟧′
    ⟦ >>=-idˡ iss f x i ⟧′ = F.>>=-idˡ iss (⟦_⟧′ ∘ f) x i
    ⟦ >>=-idʳ iss xs i ⟧′ = F.>>=-idʳ iss ⟦ xs ⟧′ i
    ⟦ >>=-assoc iss xs f g i ⟧′ = F.>>=-assoc iss ⟦ xs ⟧′ (⟦_⟧′ ∘ f) (⟦_⟧′ ∘ g) i

    ⟦ trunc iss xs ys p q i j ⟧′ =
      isOfHLevel→isOfHLevelDep 2
        (λ xs → F.trunc iss)
        ⟦ xs ⟧′ ⟦ ys ⟧′
        (cong ⟦_⟧′ p) (cong ⟦_⟧′ q)
        (trunc iss xs ys p q)
        i j

    module _ (hom : SetMonadHomomorphism freeMonad {F = G} ⟶ mon) where
      module Hom = SetMonadHomomorphism_⟶_ hom
      open Hom using (f)

      uniq-alg : (inv : ∀ {A : Type _} → (x : G A) → f (lift x) ≡ h x) → Ψ[ xs ⦂ G * ] ⇒ ⟦ xs ⟧′ ≡ f xs
      uniq-alg inv .snd = prop-coh λ iss xs → F.trunc iss _ _
      uniq-alg inv .fst (liftF x) = sym (inv x)
      uniq-alg inv .fst (returnF x) = sym (Hom.return-homo x)
      uniq-alg inv .fst (bindF xs P⟨xs⟩ k P⟨∘k⟩) = cong₂ F._>>=_ P⟨xs⟩ (funExt P⟨∘k⟩) ; Hom.>>=-homo xs k

      uniq : (inv : ∀ {A : Type _} → (x : G A) → f (lift x) ≡ h x) → (xs : Free G A) → ⟦ xs ⟧′ ≡ f xs
      uniq inv = ⟦ uniq-alg inv ⟧

open import Cubical.Foundations.HLevels using (isSetΠ)

module _ {ℓ} (fun : Functor ℓ ℓ) where
  open Functor fun using (map; 𝐹)
  module _ {B : Type ℓ} (BIsSet : isSet B) where

    cata-alg : (𝐹 B → B) → Ψ 𝐹 λ {T} _ → (T → B) → B
    cata-alg ϕ .fst (liftF x) h = ϕ (map h x)
    cata-alg ϕ .fst (returnF x) h = h x
    cata-alg ϕ .fst (bindF _ P⟨xs⟩ _ P⟨∘k⟩) h = P⟨xs⟩ (flip P⟨∘k⟩ h)
    cata-alg ϕ .snd .c-set _ _ = isSetΠ λ _ → BIsSet
    cata-alg ϕ .snd .c->>=idˡ isb f Pf x = refl
    cata-alg ϕ .snd .c->>=idʳ isa x Px = refl
    cata-alg ϕ .snd .c->>=assoc isa xs Pxs f Pf g Pg = refl

    cata : (A → B) → (𝐹 B → B) → Free 𝐹 A → B
    cata h ϕ xs = ⟦ cata-alg ϕ ⟧ xs h

_>>_ : Free F A → Free F B → Free F B
xs >> ys = xs >>= const ys


{-# OPTIONS --cubical #-}

open import Agda.Primitive.Cubical
open import Agda.Builtin.Cubical.Path

data S1 : Set where
  base : S1
  loop : base ≡ base

postulate
  weird : S1 → I

bad : (x : S1) → I
bad base     = {!!}
bad (loop x) = {!!}


module Test.Numeral where
import Lvl
open import Relator.Equals{Lvl.𝟎}

  module One where
    test0 : (0 mod 1) ≡ 0
    test0 = [≡]-intro

    test1 : (1 mod 1) ≡ 0
    test1 = [≡]-intro

    test2 : (2 mod 1) ≡ 0
    test2 = [≡]-intro

    test3 : (3 mod 1) ≡ 0
    test3 = [≡]-intro

    test4 : (4 mod 1) ≡ 0
    test4 = [≡]-intro

    test5 : (5 mod 1) ≡ 0
    test5 = [≡]-intro

    test6 : (6 mod 1) ≡ 0
    test6 = [≡]-intro

    test7 : (7 mod 1) ≡ 0
    test7 = [≡]-intro

    test8 : (8 mod 1) ≡ 0
    test8 = [≡]-intro

    test9 : (9 mod 1) ≡ 0
    test9 = [≡]-intro

    test10 : (10 mod 1) ≡ 0
    test10 = [≡]-intro

    test11 : (11 mod 1) ≡ 0
    test11 = [≡]-intro

  module Two where
    test0 : (0 mod 2) ≡ 0
    test0 = [≡]-intro

    test1 : (1 mod 2) ≡ 1
    test1 = [≡]-intro

    test2 : (2 mod 2) ≡ 0
    test2 = [≡]-intro

    test3 : (3 mod 2) ≡ 1
    test3 = [≡]-intro

    test4 : (4 mod 2) ≡ 0
    test4 = [≡]-intro

    test5 : (5 mod 2) ≡ 1
    test5 = [≡]-intro

    test6 : (6 mod 2) ≡ 0
    test6 = [≡]-intro

    test7 : (7 mod 2) ≡ 1
    test7 = [≡]-intro

    test8 : (8 mod 2) ≡ 0
    test8 = [≡]-intro

    test9 : (9 mod 2) ≡ 1
    test9 = [≡]-intro

    test10 : (10 mod 2) ≡ 0
    test10 = [≡]-intro

    test11 : (11 mod 2) ≡ 1
    test11 = [≡]-intro

  module Three where
    test0 : (0 mod 3) ≡ 0
    test0 = [≡]-intro

    test1 : (1 mod 3) ≡ 1
    test1 = [≡]-intro

    test2 : (2 mod 3) ≡ 2
    test2 = [≡]-intro

    test3 : (3 mod 3) ≡ 0
    test3 = [≡]-intro

    test4 : (4 mod 3) ≡ 1
    test4 = [≡]-intro

    test5 : (5 mod 3) ≡ 2
    test5 = [≡]-intro

    test6 : (6 mod 3) ≡ 0
    test6 = [≡]-intro

    test7 : (7 mod 3) ≡ 1
    test7 = [≡]-intro

    test8 : (8 mod 3) ≡ 2
    test8 = [≡]-intro

    test9 : (9 mod 3) ≡ 0
    test9 = [≡]-intro

    test10 : (10 mod 3) ≡ 1
    test10 = [≡]-intro

    test11 : (11 mod 3) ≡ 2
    test11 = [≡]-intro


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

module Cubical.HITs.Truncation.Properties where
open import Cubical.Data.NatMinusOne
open import Cubical.HITs.Truncation.Base

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Equiv.PathSplit
open isPathSplitEquiv
open import Cubical.Modalities.Modality
open Modality

open import Cubical.Data.Empty.Base as ⊥ renaming (rec to ⊥rec ; elim to ⊥elim)
open import Cubical.Data.Nat hiding (elim)
open import Cubical.Data.Sigma
open import Cubical.Data.Bool
open import Cubical.Data.Unit
open import Cubical.HITs.Sn.Base
open import Cubical.HITs.S1
open import Cubical.HITs.Susp
open import Cubical.HITs.Nullification as Null hiding (rec; elim)

open import Cubical.HITs.PropositionalTruncation as PropTrunc
  renaming (∥_∥ to ∥_∥₁; ∣_∣ to ∣_∣₁; squash to squash₁) using ()
open import Cubical.HITs.SetTruncation       as SetTrunc  using (∥_∥₂; ∣_∣₂; squash₂)
open import Cubical.HITs.GroupoidTruncation  as GpdTrunc  using (∥_∥₃; ∣_∣₃; squash₃)
open import Cubical.HITs.2GroupoidTruncation as 2GpdTrunc using (∥_∥₄; ∣_∣₄; squash₄)

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ
    B : Type ℓ'

sphereFill : (n : ℕ) (f : S₊ n → A) → Type _
sphereFill {A = A} n f = Σ[ top ∈ A ] ((x : S₊ n) → top ≡ f x)

isSphereFilled : ℕ → Type ℓ → Type ℓ
isSphereFilled n A = (f : S₊ n → A) → sphereFill n f

isSphereFilled∥∥ : {n : ℕ} → isSphereFilled n (HubAndSpoke A n)
isSphereFilled∥∥ f = (hub f) , (spoke f)

isSphereFilled→isOfHLevel : (n : ℕ) → isSphereFilled n A → isOfHLevel (suc n) A
isSphereFilled→isOfHLevel {A = A} zero h x y = sym (snd (h f) true) ∙ snd (h f) false
  where
    f : Bool → A
    f true = x
    f false = y
isSphereFilled→isOfHLevel {A = A} (suc zero) h x y =
  J (λ y q → (p : x ≡ y) → q ≡ p) (helper x)
  where
  helper : (x : A) (p : x ≡ x) → refl ≡ p
  helper x p i j =
    hcomp (λ k → λ { (i = i0) → h S¹→A .snd base k
                   ; (i = i1) → p j
                   ; (j = i0) → h S¹→A .snd base (i ∨ k)
                   ; (j = i1) → h S¹→A .snd base (i ∨ k)})
          (h S¹→A .snd (loop j) i)
    where
    S¹→A : S¹ → A
    S¹→A base = x
    S¹→A (loop i) = p i
isSphereFilled→isOfHLevel {A = A} (suc (suc n)) h x y =
  isSphereFilled→isOfHLevel (suc n) (helper h x y)
  where
    helper : {n : ℕ} → isSphereFilled (suc (suc n)) A → (x y : A) → isSphereFilled (suc n) (x ≡ y)
    helper {n = n} h x y f = sym (snd (h f') north) ∙ (snd (h f') south) , r
      where
        f' : Susp (S₊ (suc n)) → A
        f' north = x
        f' south = y
        f' (merid u i) = f u i

        r : (s : S₊ (suc n)) → sym (snd (h f') north) ∙ (snd (h f') south) ≡ f s
        r s i j = hcomp
                    (λ k →
                       λ { (i = i1) → snd (h f') (merid s j) k
                         ; (j = i0) → snd (h f') north (k ∨ (~ i))
                         ; (j = i1) → snd (h f') south k
                         })
                  (snd (h f') north (~ i ∧ ~ j))

isOfHLevel→isSphereFilled : (n : ℕ) → isOfHLevel (suc n) A → isSphereFilled n A
isOfHLevel→isSphereFilled zero h f = (f true) , (λ _ → h _ _)
isOfHLevel→isSphereFilled {A = A} (suc zero) h f = (f base) , toPropElim (λ _ → h _ _) refl
isOfHLevel→isSphereFilled {A = A} (suc (suc n)) h =
  helper λ x y → isOfHLevel→isSphereFilled (suc n) (h x y)
  where
    helper : {n : ℕ} → ((x y : A) → isSphereFilled (suc n) (x ≡ y))
                     → isSphereFilled (suc (suc n)) A
    helper {n = n} h f = f north , r
      where
      r : (x : S₊ (suc (suc n))) → f north ≡ f x
      r north = refl
      r south = h (f north) (f south) (λ x → cong f (merid x)) .fst
      r (merid x i) j = hcomp (λ k → λ { (i = i0) → f north
                                       ; (i = i1) → h (f north) (f south) (λ x → cong f (merid x)) .snd x (~ k) j
                                       ; (j = i0) → f north
                                       ; (j = i1) → f (merid x i) }) (f (merid x (i ∧ j)))

isOfHLevelTrunc : (n : ℕ) → isOfHLevel n (∥ A ∥ n)
isOfHLevelTrunc zero = isOfHLevelUnit* 0
isOfHLevelTrunc (suc n) = isSphereFilled→isOfHLevel n isSphereFilled∥∥

rec : {n : HLevel}
      {B : Type ℓ'} →
      isOfHLevel (suc n) B →
      (A → B) →
      hLevelTrunc (suc n) A →
      B
rec h g ∣ x ∣ = g x
rec {n = n} {B = B} hB g (hub f) = isOfHLevel→isSphereFilled n hB (λ x → rec hB g (f x)) .fst
rec {n = n} hB g (spoke f x i) =
  isOfHLevel→isSphereFilled n hB (λ x → rec hB g (f x)) .snd x i

elim : {n : ℕ}
      {B : ∥ A ∥ (suc n) → Type ℓ'}
      (hB : (x : ∥ A ∥ (suc n)) → isOfHLevel (suc n) (B x))
      (g : (a : A) → B (∣ a ∣))
      (x : ∥ A ∥ (suc n)) →
      B x
elim hB g (∣ a ∣ ) = g a
elim {B = B} hB g (hub f) =
  isOfHLevel→isSphereFilled _ (hB (hub f)) (λ x → subst B (sym (spoke f x)) (elim hB g (f x)) ) .fst
elim {B = B} hB g (spoke f x i) =
  toPathP {A = λ i → B (spoke f x (~ i))}
    (sym (isOfHLevel→isSphereFilled _ (hB (hub f)) (λ x → subst B (sym (spoke f x)) (elim hB g (f x))) .snd x))
    (~ i)

elim2 : {n : ℕ}
       {B : ∥ A ∥ (suc n) → ∥ A ∥ (suc n) → Type ℓ'}
       (hB : ((x y : ∥ A ∥ (suc n)) → isOfHLevel (suc n) (B x y)))
       (g : (a b : A) → B ∣ a ∣ ∣ b ∣)
       (x y : ∥ A ∥ (suc n)) →
       B x y
elim2 {n = n} hB g = elim (λ _ → isOfHLevelΠ (suc n) (λ _ → hB _ _)) λ a →
                    elim (λ _ → hB _ _) (λ b → g a b)

elim3 : {n : ℕ}
       {B : (x y z : ∥ A ∥ (suc n)) → Type ℓ'}
       (hB : ((x y z : ∥ A ∥ (suc n)) → isOfHLevel (suc n) (B x y z)))
       (g : (a b c : A) → B (∣ a ∣) ∣ b ∣ ∣ c ∣)
       (x y z : ∥ A ∥ (suc n)) →
       B x y z
elim3 {n = n} hB g = elim2 (λ _ _ → isOfHLevelΠ (suc n) (hB _ _)) λ a b →
                    elim (λ _ → hB _ _ _) (λ c → g a b c)

isContr→isContr∥ : (n : ℕ) → isContr A → isContr (∥ A ∥ n)
isContr→isContr∥ zero _ = tt* , (λ _ _ → tt*)
isContr→isContr∥ (suc n) contr = ∣ fst contr ∣ , (elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _)
                                                      (λ a i → ∣ snd contr a i ∣))

isOfHLevelMin→isOfHLevel : {n m : ℕ} → isOfHLevel (min n m) A → isOfHLevel n A × isOfHLevel m A
isOfHLevelMin→isOfHLevel {n = zero} {m = m} h = h , isContr→isOfHLevel m h
isOfHLevelMin→isOfHLevel {n = suc n} {m = zero} h = (isContr→isOfHLevel (suc n) h) , h
isOfHLevelMin→isOfHLevel {A = A} {n = suc n} {m = suc m} h =
    subst (λ x → isOfHLevel x A) (helper n m)
          (isOfHLevelPlus (suc n ∸ (suc (min n m))) h)
  , subst (λ x → isOfHLevel x A) ((λ i → m ∸ (minComm n m i) + suc (minComm n m i)) ∙ helper m n)
          (isOfHLevelPlus (suc m ∸ (suc (min n m))) h)
  where
  helper : (n m : ℕ) → n ∸ min n m + suc (min n m) ≡ suc n
  helper zero zero = refl
  helper zero (suc m) = refl
  helper (suc n) zero = cong suc (+-comm n 1)
  helper (suc n) (suc m) = +-suc _ _ ∙ cong suc (helper n m)

ΣTruncElim : ∀ {ℓ ℓ' ℓ''} {A : Type ℓ} {n m : ℕ}
              {B : (x : ∥ A ∥ (suc n)) → Type ℓ'}
              {C : (Σ[ a ∈ (∥ A ∥ (suc n)) ] (∥ B a ∥ (suc m))) → Type ℓ''}
            → ((x : (Σ[ a ∈ (∥ A ∥ (suc n)) ] (∥ B a ∥ (suc m)))) → isOfHLevel (min (suc n) (suc m)) (C x))
            → ((a : A) (b : B (∣ a ∣)) → C (∣ a ∣ , ∣ b ∣))
            → (x : (Σ[ a ∈ (∥ A ∥ (suc n)) ] (∥ B a ∥ (suc m)))) → (C x)
ΣTruncElim {n = n} {m = m} {B = B} {C = C} hB g (a , b) =
  elim {B = λ a → (b :  (∥ B a ∥ (suc m))) → C (a , b)}
       (λ x → isOfHLevelΠ (suc n) λ b → isOfHLevelMin→isOfHLevel (hB (x , b)) .fst )
       (λ a → elim (λ _ → isOfHLevelMin→isOfHLevel (hB (∣ a ∣ , _)) .snd) λ b → g a b)
       a b

truncIdempotentIso : (n : ℕ) → isOfHLevel n A → Iso (∥ A ∥ n) A
truncIdempotentIso zero hA = isContr→Iso (isOfHLevelUnit* 0) hA
Iso.fun (truncIdempotentIso (suc n) hA) = rec hA λ a → a
Iso.inv (truncIdempotentIso (suc n) hA) = ∣_∣
Iso.rightInv (truncIdempotentIso (suc n) hA) _ = refl
Iso.leftInv (truncIdempotentIso (suc n) hA) = elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) λ _ → refl

truncIdempotent≃ : (n : ℕ) → isOfHLevel n A → ∥ A ∥ n ≃ A
truncIdempotent≃ n hA = isoToEquiv (truncIdempotentIso n hA)

truncIdempotent : (n : ℕ) → isOfHLevel n A → ∥ A ∥ n ≡ A
truncIdempotent n hA = ua (truncIdempotent≃ n hA)

HLevelTruncModality : ∀ {ℓ} (n : HLevel) → Modality ℓ
isModal       (HLevelTruncModality n) = isOfHLevel n
isModalIsProp (HLevelTruncModality n) = isPropIsOfHLevel n
◯             (HLevelTruncModality n) = hLevelTrunc n
◯-isModal     (HLevelTruncModality n) = isOfHLevelTrunc n
η (HLevelTruncModality zero) _ = tt*
η (HLevelTruncModality (suc n)) = ∣_∣
◯-elim (HLevelTruncModality zero) cB _ tt* = cB tt* .fst
◯-elim (HLevelTruncModality (suc n)) = elim
◯-elim-β (HLevelTruncModality zero) cB f a = cB tt* .snd (f a)
◯-elim-β (HLevelTruncModality (suc n)) = λ _ _ _ → refl
◯-=-isModal (HLevelTruncModality zero) x y = (isOfHLevelUnit* 1 x y) , (isOfHLevelUnit* 2 x y _)
◯-=-isModal (HLevelTruncModality (suc n)) = isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n))

-- universal property

univTrunc : ∀ {ℓ} (n : HLevel) {B : TypeOfHLevel ℓ n} → Iso (hLevelTrunc n A → B .fst) (A → B .fst)
univTrunc zero {B , lev} = isContr→Iso (isOfHLevelΠ 0 (λ _ → lev)) (isOfHLevelΠ 0 λ _ → lev)
Iso.fun (univTrunc (suc n) {B , lev}) g a = g ∣ a ∣
Iso.inv (univTrunc (suc n) {B , lev}) = rec lev
Iso.rightInv (univTrunc (suc n) {B , lev}) b = refl
Iso.leftInv (univTrunc (suc n) {B , lev}) b = funExt (elim (λ x → isOfHLevelPath _ lev _ _)
                                                            λ a → refl)

-- functorial action

map : {n : HLevel} {B : Type ℓ'} (g : A → B)
  → hLevelTrunc n A → hLevelTrunc n B
map {n = zero} g = λ _ → tt*
map {n = suc n} g = rec (isOfHLevelTrunc _) (λ a → ∣ g a ∣)

mapCompIso : {n : HLevel} {B : Type ℓ'} → (Iso A B) → Iso (hLevelTrunc n A) (hLevelTrunc n B)
mapCompIso {n = zero} {B} _ = isContr→Iso (isOfHLevelUnit* 0) (isOfHLevelUnit* 0)
Iso.fun (mapCompIso {n = (suc n)} g) = map (Iso.fun g)
Iso.inv (mapCompIso {n = (suc n)} g) = map (Iso.inv g)
Iso.rightInv (mapCompIso {n = (suc n)} g) = elim (λ x → isOfHLevelPath _ (isOfHLevelTrunc _) _ _) λ b → cong ∣_∣ (Iso.rightInv g b)
Iso.leftInv (mapCompIso {n = (suc n)} g) = elim (λ x → isOfHLevelPath _ (isOfHLevelTrunc _) _ _) λ a → cong ∣_∣ (Iso.leftInv g a)

mapId : {n : HLevel} → ∀ t → map {n = n} (idfun A) t ≡ t
mapId {n = 0} tt* = refl
mapId {n = (suc n)} =
  elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) (λ _ → refl)

-- equivalences to prop/set/groupoid truncations

propTruncTrunc1Iso : Iso ∥ A ∥₁ (∥ A ∥ 1)
Iso.fun propTruncTrunc1Iso = PropTrunc.rec (isOfHLevelTrunc 1) ∣_∣
Iso.inv propTruncTrunc1Iso = rec squash₁ ∣_∣₁
Iso.rightInv propTruncTrunc1Iso = elim (λ _ → isOfHLevelPath 1 (isOfHLevelTrunc 1) _ _) (λ _ → refl)
Iso.leftInv propTruncTrunc1Iso = PropTrunc.elim (λ _ → isOfHLevelPath 1 squash₁ _ _) (λ _ → refl)

propTrunc≃Trunc1 : ∥ A ∥₁ ≃ ∥ A ∥ 1
propTrunc≃Trunc1 = isoToEquiv propTruncTrunc1Iso

propTrunc≡Trunc1 : ∥ A ∥₁ ≡ ∥ A ∥ 1
propTrunc≡Trunc1 = ua propTrunc≃Trunc1

setTruncTrunc2Iso : Iso ∥ A ∥₂ (∥ A ∥ 2)
Iso.fun setTruncTrunc2Iso = SetTrunc.rec (isOfHLevelTrunc 2) ∣_∣
Iso.inv setTruncTrunc2Iso = rec squash₂ ∣_∣₂
Iso.rightInv setTruncTrunc2Iso = elim (λ _ → isOfHLevelPath 2 (isOfHLevelTrunc 2) _ _) (λ _ → refl)
Iso.leftInv setTruncTrunc2Iso = SetTrunc.elim (λ _ → isOfHLevelPath 2 squash₂ _ _) (λ _ → refl)

setTrunc≃Trunc2 : ∥ A ∥₂ ≃ ∥ A ∥ 2
setTrunc≃Trunc2 = isoToEquiv setTruncTrunc2Iso

propTrunc≡Trunc2 : ∥ A ∥₂ ≡ ∥ A ∥ 2
propTrunc≡Trunc2 = ua setTrunc≃Trunc2

groupoidTruncTrunc3Iso : Iso ∥ A ∥₃ (∥ A ∥ 3)
Iso.fun groupoidTruncTrunc3Iso = GpdTrunc.rec (isOfHLevelTrunc 3) ∣_∣
Iso.inv groupoidTruncTrunc3Iso = rec squash₃ ∣_∣₃
Iso.rightInv groupoidTruncTrunc3Iso = elim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) (λ _ → refl)
Iso.leftInv groupoidTruncTrunc3Iso = GpdTrunc.elim (λ _ → isOfHLevelPath 3 squash₃ _ _) (λ _ → refl)

groupoidTrunc≃Trunc3 : ∥ A ∥₃ ≃ ∥ A ∥ 3
groupoidTrunc≃Trunc3 = isoToEquiv groupoidTruncTrunc3Iso

groupoidTrunc≡Trunc3 : ∥ A ∥₃ ≡ ∥ A ∥ 3
groupoidTrunc≡Trunc3 = ua groupoidTrunc≃Trunc3

2GroupoidTruncTrunc4Iso : Iso ∥ A ∥₄ (∥ A ∥ 4)
Iso.fun 2GroupoidTruncTrunc4Iso = 2GpdTrunc.rec (isOfHLevelTrunc 4) ∣_∣
Iso.inv 2GroupoidTruncTrunc4Iso = rec squash₄ ∣_∣₄
Iso.rightInv 2GroupoidTruncTrunc4Iso = elim (λ _ → isOfHLevelPath 4 (isOfHLevelTrunc 4) _ _) (λ _ → refl)
Iso.leftInv 2GroupoidTruncTrunc4Iso = 2GpdTrunc.elim (λ _ → isOfHLevelPath 4 squash₄ _ _) (λ _ → refl)

2GroupoidTrunc≃Trunc4 : ∥ A ∥₄ ≃ ∥ A ∥ 4
2GroupoidTrunc≃Trunc4 = isoToEquiv 2GroupoidTruncTrunc4Iso

2GroupoidTrunc≡Trunc4 : ∥ A ∥₄ ≡ ∥ A ∥ 4
2GroupoidTrunc≡Trunc4 = ua 2GroupoidTrunc≃Trunc4

isContr→isContrTrunc : ∀ {ℓ} {A : Type ℓ} (n : ℕ) → isContr A → isContr (hLevelTrunc n A)
isContr→isContrTrunc zero contr = isOfHLevelUnit* 0
isContr→isContrTrunc (suc n) contr =
  ∣ fst contr ∣ , (elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) λ a → cong ∣_∣ (snd contr a))

truncOfProdIso : (n : ℕ) → Iso (hLevelTrunc n (A × B)) (hLevelTrunc n A × hLevelTrunc n B)
truncOfProdIso 0 = isContr→Iso (isOfHLevelUnit* 0) (isOfHLevel× 0 (isOfHLevelUnit* 0) (isOfHLevelUnit* 0))
Iso.fun (truncOfProdIso (suc n)) = rec (isOfHLevelΣ (suc n) (isOfHLevelTrunc (suc n)) (λ _ → isOfHLevelTrunc (suc n))) λ {(a , b) → ∣ a ∣ , ∣ b ∣}
Iso.inv (truncOfProdIso (suc n)) (a , b) = rec (isOfHLevelTrunc (suc n))
                                          (λ a → rec (isOfHLevelTrunc (suc n))
                                                      (λ b → ∣ a , b ∣)
                                                       b)
                                          a
Iso.rightInv (truncOfProdIso (suc n)) (a , b) =
  elim {B = λ a → Iso.fun (truncOfProdIso (suc n)) (Iso.inv (truncOfProdIso (suc n)) (a , b)) ≡ (a , b)}
       (λ _ → isOfHLevelPath (suc n) (isOfHLevelΣ (suc n) (isOfHLevelTrunc (suc n)) (λ _ → isOfHLevelTrunc (suc n))) _ _)
       (λ a → elim {B = λ b → Iso.fun (truncOfProdIso (suc n)) (Iso.inv (truncOfProdIso (suc n)) (∣ a ∣ , b)) ≡ (∣ a ∣ , b)}
                    (λ _ → isOfHLevelPath (suc n) (isOfHLevelΣ (suc n) (isOfHLevelTrunc (suc n)) (λ _ → isOfHLevelTrunc (suc n))) _ _)
                    (λ b → refl) b) a
Iso.leftInv (truncOfProdIso (suc n)) = elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) λ a → refl

---- ∥ Ω A ∥ ₙ ≡ Ω ∥ A ∥ₙ₊₁  ----

  {- Proofs of Theorem 7.3.12. and Corollary 7.3.13. in the HoTT book  -}

module ΩTrunc {X : Type ℓ} {n : HLevel} where
  {- We define the fibration P to show a more general result  -}
  P : ∥ X ∥ (2 + n) → ∥ X ∥ (2 + n) → Type ℓ
  P x y =  elim2 (λ _ _  → isOfHLevelTypeOfHLevel (suc n))
                 (λ a b → ∥ a ≡ b ∥ (suc n) , isOfHLevelTrunc (suc n)) x y .fst

  {- We will need P to be of hLevel n + 3  -}
  hLevelP : (a b : ∥ X ∥ (2 + n)) → isOfHLevel (2 + n) (P a b)
  hLevelP  =
    elim2 (λ x y → isProp→isOfHLevelSuc (suc n) (isPropIsOfHLevel (2 + n)))
          (λ a b → isOfHLevelSuc (suc n) (isOfHLevelTrunc (suc n)))

  {- decode function from P x y to x ≡ y -}
  decode-fun : (x y : ∥ X ∥ (2 + n)) → P x y → x ≡ y
  decode-fun =
    elim2 (λ u v → isOfHLevelΠ (2 + n)(λ _ → isOfHLevelSuc (2 + n) (isOfHLevelTrunc (2 + n)) u v))
          decode*
      where
      decode* : (u v : X) → P ∣ u ∣ ∣ v ∣ → Path (∥ X ∥ (2 + n)) ∣ u ∣ ∣ v ∣
      decode* u v =
        rec (isOfHLevelTrunc (2 + n) ∣ u ∣ ∣ v ∣) (cong ∣_∣)

  {- auxiliary function r used to define encode -}
  r : (u : ∥ X ∥ (2 + n)) → P u u
  r = elim (λ x → hLevelP x x) (λ a → ∣ refl ∣)

  {- encode function from x ≡ y to P x y -}
  encode-fun : (x y : ∥ X ∥ (2 + n)) → x ≡ y → P x y
  encode-fun x y p = subst (P x) p (r x)

  {- We need the following two lemmas on the functions behaviour for refl -}
  dec-refl : (x : ∥ X ∥ (2 + n)) → decode-fun x x (r x) ≡ refl
  dec-refl =
    elim (λ x → isOfHLevelSuc (1 + n)
                  (isOfHLevelSuc (1 + n)
                     (isOfHLevelTrunc (2 + n) x x)
                     (decode-fun x x (r x)) refl))
         (λ _ → refl)

  enc-refl : (x : ∥ X ∥ (2 + n)) → encode-fun x x refl ≡ r x
  enc-refl x = transportRefl (r x)

  {- decode-fun is a right-inverse -}
  P-rinv : (u v : ∥ X ∥ (2 + n)) (x : Path (∥ X ∥ (2 + n)) u v)
         → decode-fun u v (encode-fun u v x) ≡ x
  P-rinv u v = J (λ y p → decode-fun u y (encode-fun u y p) ≡ p)
                 (cong (decode-fun u u) (enc-refl u) ∙ dec-refl u)

  {- decode-fun is a left-inverse -}
  P-linv : (u v : ∥ X ∥ (2 + n)) (x : P u v)
         → encode-fun u v (decode-fun u v x) ≡ x
  P-linv =
    elim2 (λ x y → isOfHLevelΠ (2 + n) (λ z → isOfHLevelSuc (2 + n) (hLevelP x y) _ _))
          helper
    where
    helper : (a b : X) (p : P ∣ a ∣ ∣ b ∣)
           → encode-fun _ _ (decode-fun ∣ a ∣ ∣ b ∣ p) ≡ p
    helper a b =
      elim (λ x → hLevelP ∣ a ∣ ∣ b ∣ _ _)
           (J (λ y p → encode-fun ∣ a ∣ ∣ y ∣ (decode-fun _ _ ∣ p ∣) ≡ ∣ p ∣)
              (enc-refl ∣ a ∣))

  {- The final Iso established -}
  IsoFinal : (x y : ∥ X ∥ (2 + n)) → Iso (x ≡ y) (P x y)
  Iso.fun (IsoFinal x y) = encode-fun x y
  Iso.inv (IsoFinal x y) = decode-fun x y
  Iso.rightInv (IsoFinal x y) = P-linv x y
  Iso.leftInv (IsoFinal x y) = P-rinv x y

PathIdTruncIso : {a b : A} (n : HLevel) → Iso (Path (∥ A ∥ (suc n)) ∣ a ∣ ∣ b ∣) (∥ a ≡ b ∥ n)
PathIdTruncIso zero = isContr→Iso ((isOfHLevelTrunc 1 _ _)
                    , isOfHLevelPath 1 (isOfHLevelTrunc 1) ∣ _ ∣ ∣ _ ∣ _) (isOfHLevelUnit* 0)
PathIdTruncIso (suc n) = ΩTrunc.IsoFinal ∣ _ ∣ ∣ _ ∣

PathIdTrunc : {a b : A} (n : HLevel) → (Path (∥ A ∥ (suc n)) ∣ a ∣ ∣ b ∣) ≡ (∥ a ≡ b ∥ n)
PathIdTrunc n = isoToPath (PathIdTruncIso n)

PathΩ : {a : A} (n : HLevel) → (Path (∥ A ∥ (suc n)) ∣ a ∣ ∣ a ∣) ≡ (∥ a ≡ a ∥ n)
PathΩ n = PathIdTrunc n

{- Special case using direct defs of truncations -}
PathIdTrunc₀Iso : {a b : A} → Iso (∣ a ∣₂ ≡ ∣ b ∣₂) ∥ a ≡ b ∥₁
PathIdTrunc₀Iso = compIso (congIso setTruncTrunc2Iso)
                    (compIso (ΩTrunc.IsoFinal ∣ _ ∣ ∣ _ ∣)
                             (invIso propTruncTrunc1Iso))

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

truncOfTruncIso : (n m : HLevel) → Iso (hLevelTrunc n A) (hLevelTrunc n (hLevelTrunc (m + n) A))
truncOfTruncIso zero m = isContr→Iso (isOfHLevelUnit* 0) (isOfHLevelUnit* 0)
Iso.fun (truncOfTruncIso (suc n) zero) = rec (isOfHLevelTrunc (suc n)) λ a → ∣ ∣ a ∣ ∣
Iso.fun (truncOfTruncIso (suc n) (suc m)) = rec (isOfHLevelTrunc (suc n)) λ a → ∣ ∣ a ∣ ∣
Iso.inv (truncOfTruncIso (suc n) zero) =  rec (isOfHLevelTrunc (suc n))
                                               (rec (isOfHLevelTrunc (suc n))
                                                     λ a → ∣ a ∣)
Iso.inv (truncOfTruncIso (suc n) (suc m)) =  rec (isOfHLevelTrunc (suc n))
                                                  (rec (isOfHLevelPlus (suc m) (isOfHLevelTrunc (suc n)))
                                                        λ a → ∣ a ∣)
Iso.rightInv (truncOfTruncIso (suc n) zero) =
  elim (λ x → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _ )
       (elim (λ x → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _ )
              λ a → refl)
Iso.rightInv (truncOfTruncIso (suc n) (suc m)) =
  elim (λ x → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _ )
               (elim (λ x → isOfHLevelPath ((suc m) + (suc n)) (isOfHLevelPlus (suc m) (isOfHLevelTrunc (suc n))) _ _ )
                      λ a → refl)
Iso.leftInv (truncOfTruncIso (suc n) zero) = elim (λ x → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) λ a → refl
Iso.leftInv (truncOfTruncIso (suc n) (suc m)) = elim (λ x → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) λ a → refl

truncOfTruncEq : (n m : ℕ) → (hLevelTrunc n A) ≃ (hLevelTrunc n (hLevelTrunc (m + n) A))
truncOfTruncEq n m = isoToEquiv (truncOfTruncIso n m)

truncOfTruncIso2 : (n m : HLevel) → Iso (hLevelTrunc (m + n) (hLevelTrunc n A)) (hLevelTrunc n A)
truncOfTruncIso2 n m = truncIdempotentIso (m + n) (isOfHLevelPlus m (isOfHLevelTrunc n))

truncOfΣIso : ∀ {ℓ ℓ'} (n : HLevel) {A : Type ℓ} {B : A → Type ℓ'}
       → Iso (hLevelTrunc n (Σ A B)) (hLevelTrunc n (Σ A λ x → hLevelTrunc n (B x)))
truncOfΣIso zero = idIso
Iso.fun (truncOfΣIso (suc n)) = map λ {(a , b) → a , ∣ b ∣}
Iso.inv (truncOfΣIso (suc n)) =
  rec (isOfHLevelTrunc (suc n))
        (uncurry λ a → rec (isOfHLevelTrunc (suc n)) λ b → ∣ a , b ∣)
Iso.rightInv (truncOfΣIso (suc n)) =
  elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _)
         (uncurry λ a → elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _)
         λ b → refl)
Iso.leftInv (truncOfΣIso (suc n)) =
  elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _) λ {(a , b) → refl}


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

open import lib.Basics
open import lib.NType2
open import lib.Equivalence2
open import lib.types.Unit
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Paths
open import lib.types.TLevel
open import lib.types.Truncation

module lib.NConnected where

is-connected : ∀ {i} → ℕ₋₂ → Type i → Type i
is-connected n A = is-contr (Trunc n A)

has-conn-fibers : ∀ {i j} {A : Type i} {B : Type j} → ℕ₋₂ → (A → B) → Type (lmax i j)
has-conn-fibers {A = A} {B = B} n f =
  Π B (λ b → is-connected n (hfiber f b))

{- all types are -2-connected -}
-2-conn : ∀ {i} (A : Type i) → is-connected -2 A
-2-conn A = Trunc-level

{- all inhabited types are -1-connected -}
inhab-conn : ∀ {i} {A : Type i} (a : A) → is-connected -1 A
inhab-conn a = has-level-in ([ a ] , prop-has-all-paths [ a ])

{- connectedness is a prop -}
is-connected-is-prop : ∀ {i} {n : ℕ₋₂} {A : Type i}
  → is-prop (is-connected n A)
is-connected-is-prop = is-contr-is-prop

{- "induction principle" for n-connected maps (where codomain is n-type) -}
abstract
  pre∘-conn-is-equiv : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂}
    → {h : A → B} → has-conn-fibers n h
    → (∀ {k} (P : B → n -Type k) → is-equiv (λ (s : Π B (fst ∘ P)) → s ∘ h))
  pre∘-conn-is-equiv {A = A} {B = B} {n = n} {h = h} c P = is-eq f g f-g g-f
    where f : Π B (fst ∘ P) → Π A (fst ∘ P ∘ h)
          f k a = k (h a)

          helper : Π A (fst ∘ P ∘ h)
            → (b : B) → Trunc n (Σ A (λ a → h a == b)) → (fst (P b))
          helper t b r =
            Trunc-rec {{snd (P b)}}
              (λ x → transport (λ y → fst (P y)) (snd x) (t (fst x)))
              r

          g : Π A (fst ∘ P ∘ h) → Π B (fst ∘ P)
          g t b = helper t b (contr-center (c b))

          f-g : ∀ t → f (g t) == t
          f-g t = λ= $ λ a → transport
            (λ r →  Trunc-rec {{snd (P (h a))}} _ r == t a)
            (! (contr-path(c (h a)) [ (a , idp) ]))
            idp

          g-f : ∀ k → g (f k) == k
          g-f k = λ= $ λ (b : B) →
            Trunc-elim {{λ r → =-preserves-level {x = helper (k ∘ h) b r} (snd (P b))}}
                       (λ x → lemma (fst x) b (snd x)) (contr-center (c b))
            where
            lemma : ∀ xl → ∀ b → (p : h xl == b) →
              helper (k ∘ h) b [ (xl , p) ] == k b
            lemma xl ._ idp = idp

conn-extend : ∀ {i j k} {A : Type i} {B : Type j} {n : ℕ₋₂}
  → {h : A → B} → has-conn-fibers n h
  → (P : B → n -Type k)
  → Π A (fst ∘ P ∘ h) → Π B (fst ∘ P)
conn-extend c P f = is-equiv.g (pre∘-conn-is-equiv c P) f

conn-out = conn-extend

conn-extend-β : ∀ {i j k} {A : Type i} {B : Type j} {n : ℕ₋₂}
  {h : A → B} (c : has-conn-fibers n h)
  (P : B → n -Type k) (f : Π A (fst ∘ P ∘ h))
  → ∀ a → (conn-extend c P f (h a)) == f a
conn-extend-β c P f = app= (is-equiv.f-g (pre∘-conn-is-equiv c P) f)

{- generalized "almost induction principle" for maps into ≥n-types
   TODO: rearrange this to use ≤T?                                 -}
conn-extend-general : ∀ {i j} {A : Type i} {B : Type j} {n k : ℕ₋₂}
  → {f : A → B} → has-conn-fibers n f
  → ∀ {l} (P : B → (k +2+ n) -Type l)
  → ∀ t → has-level k (Σ (Π B (fst ∘ P)) (λ s → (s ∘ f) == t))
conn-extend-general {k = ⟨-2⟩} c P t =
  equiv-is-contr-map (pre∘-conn-is-equiv c P) t
conn-extend-general {B = B} {n = n} {k = S k'} {f = f} c P t = has-level-in
  λ {(g , p) (h , q) →
    equiv-preserves-level (e g h p q)
      {{conn-extend-general {k = k'} c (Q g h) (app= (p ∙ ! q))}} }
  where
    Q : (g h : Π B (fst ∘ P)) → B → (k' +2+ n) -Type _
    Q g h b = ((g b == h b) , has-level-apply (snd (P b)) _ _)

    app=-ap : ∀ {i j k} {A : Type i} {B : Type j} {C : B → Type k}
      (f : A → B) {g h : Π B C} (p : g == h)
      → app= (ap (λ k → k ∘ f) p) == (app= p ∘ f)
    app=-ap f idp = idp

    move-right-on-right-econv : ∀ {i} {A : Type i} {x y z : A}
      (p : x == y) (q : x == z) (r : y == z)
      → (p == q ∙ ! r) ≃ (p ∙ r == q)
    move-right-on-right-econv {x = x} p idp idp =
      (_ , pre∙-is-equiv (∙-unit-r p))

    lemma : ∀ g h p q → (H : g ∼ h)
      → ((H ∘ f) == app= (p ∙ ! q))
         ≃ (ap (λ v → v ∘ f) (λ= H) ∙ q == p)
    lemma g h p q H =
      move-right-on-right-econv (ap (λ v → v ∘ f) (λ= H)) p q
      ∘e transport (λ w → (w == app= (p ∙ ! q))
                      ≃ (ap (λ v → v ∘ f) (λ= H) == p ∙ ! q))
                   (app=-ap f (λ= H) ∙ ap (λ k → k ∘ f) (λ= $ app=-β H))
                   (ap-equiv app=-equiv _ _ ⁻¹)

    e : ∀ g h p q  →
      (Σ (g ∼ h) (λ r → (r ∘ f) == app= (p ∙ ! q)))
      ≃ ((g , p) == (h , q))
    e g h p q =
      ((=Σ-econv _ _ ∘e Σ-emap-r (λ u → ↓-app=cst-econv ∘e !-equiv))
      ∘e (Σ-emap-l _ λ=-equiv)) ∘e Σ-emap-r (lemma g h p q)

conn-in : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂} {h : A → B}
  → (∀ (P : B → n -Type (lmax i j))
     → Σ (Π A (fst ∘ P ∘ h) → Π B (fst ∘ P))
         (λ u → ∀ (t : Π A (fst ∘ P ∘ h)) → u t ∘ h ∼ t))
  → has-conn-fibers n h
conn-in {A = A} {B = B} {h = h} sec b =
  let s = sec (λ b → (Trunc _ (hfiber h b) , Trunc-level))
  in has-level-in (fst s (λ a → [ a , idp ]) b ,
      Trunc-elim (λ k → transport
                   (λ v → fst s (λ a → [ a , idp ]) (fst v) == [ fst k , snd v ])
                   (contr-path (pathfrom-is-contr (h (fst k))) (b , snd k))
                   (snd s (λ a → [ a , idp ]) (fst k))))

abstract
  pointed-conn-in : ∀ {i} {n : ℕ₋₂} (A : Type i) (a₀ : A)
    → has-conn-fibers {A = ⊤} n (cst a₀) → is-connected (S n) A
  pointed-conn-in {n = n} A a₀ c = has-level-in
    ([ a₀ ] ,
     Trunc-elim
       (λ a → Trunc-rec
             (λ x → ap [_] (snd x)) (contr-center $ c a)))

abstract
  pointed-conn-out : ∀ {i} {n : ℕ₋₂} (A : Type i) (a₀ : A)
    {{_ : is-connected (S n) A}} → has-conn-fibers {A = ⊤} n (cst a₀)
  pointed-conn-out {n = n} A a₀ {{c}} a = has-level-in
    (point ,
     λ y → ! (cancel point)
           ∙ (ap out $ contr-has-all-paths (into point) (into y))
           ∙ cancel y)
    where
      into-aux : Trunc n (Σ ⊤ (λ _ → a₀ == a)) → Trunc n (a₀ == a)
      into-aux = Trunc-fmap snd

      into : Trunc n (Σ ⊤ (λ _ → a₀ == a))
        → [_] {n = S n} a₀ == [ a ]
      into = <– (Trunc=-equiv [ a₀ ] [ a ]) ∘ into-aux

      out-aux : Trunc n (a₀ == a) → Trunc n (Σ ⊤ (λ _ → a₀ == a))
      out-aux = Trunc-fmap (λ p → (tt , p))

      out : [_] {n = S n} a₀ == [ a ] → Trunc n (Σ ⊤ (λ _ → a₀ == a))
      out = out-aux ∘ –> (Trunc=-equiv [ a₀ ] [ a ])

      cancel : (x : Trunc n (Σ ⊤ (λ _ → a₀ == a))) → out (into x) == x
      cancel x =
        out (into x)
          =⟨ ap out-aux (<–-inv-r (Trunc=-equiv [ a₀ ] [ a ]) (into-aux x)) ⟩
        out-aux (into-aux x)
          =⟨ Trunc-fmap-∘ _ _ x ⟩
        Trunc-fmap (λ q → (tt , (snd q))) x
          =⟨ Trunc-elim {P = λ x → Trunc-fmap (λ q → (tt , snd q)) x == x}
               (λ _ → idp) x ⟩
        x =∎

      point : Trunc n (Σ ⊤ (λ _ → a₀ == a))
      point = out $ contr-has-all-paths [ a₀ ] [ a ]

prop-over-connected :  ∀ {i j} {A : Type i} {a : A} {{p : is-connected 0 A}}
  → (P : A → hProp j)
  → fst (P a) → Π A (fst ∘ P)
prop-over-connected P x = conn-extend (pointed-conn-out _ _) P (λ _ → x)

{- Connectedness of a truncated type -}
instance
  Trunc-preserves-conn : ∀ {i} {A : Type i} {n : ℕ₋₂} {m : ℕ₋₂}
    → is-connected n A → is-connected n (Trunc m A)
  Trunc-preserves-conn {n = ⟨-2⟩} _ = Trunc-level
  Trunc-preserves-conn {A = A} {n = S n} {m} c = lemma (contr-center c) (contr-path c)
    where
    lemma : (x₀ : Trunc (S n) A) → (∀ x → x₀ == x) → is-connected (S n) (Trunc m A)
    lemma = Trunc-elim
      (λ a → λ p → has-level-in ([ [ a ] ] ,
        Trunc-elim
          (Trunc-elim
            {{λ _ → =-preserves-level
                      (Trunc-preserves-level (S n) Trunc-level)}}
            (λ x → <– (Trunc=-equiv [ [ a ] ] [ [ x ] ])
               (Trunc-fmap (ap [_])
                 (–> (Trunc=-equiv [ a ] [ x ]) (p [ x ])))))))

{- Connectedness of a Σ-type -}
abstract
 instance
  Σ-conn : ∀ {i} {j} {A : Type i} {B : A → Type j} {n : ℕ₋₂}
    → is-connected n A → (∀ a → is-connected n (B a))
    → is-connected n (Σ A B)
  Σ-conn {A = A} {B = B} {n = ⟨-2⟩} cA cB = -2-conn (Σ A B)
  Σ-conn {A = A} {B = B} {n = S m} cA cB =
    Trunc-elim
      {P = λ ta → (∀ tx → ta == tx) → is-connected (S m) (Σ A B)}
      (λ a₀ pA →
        Trunc-elim
          {P = λ tb → (∀ ty → tb == ty) → is-connected (S m) (Σ A B)}
          (λ b₀ pB → has-level-in
            ([ a₀ , b₀ ] ,
              Trunc-elim
                {P = λ tp → [ a₀ , b₀ ] == tp}
                (λ {(r , s) →
                  Trunc-rec
                    (λ pa → Trunc-rec
                      (λ pb → ap [_] (pair= pa (from-transp! B pa pb)))
                      (–> (Trunc=-equiv [ b₀ ] [ transport! B pa s ])
                          (pB [ transport! B pa s ])))
                    (–> (Trunc=-equiv [ a₀ ] [ r ]) (pA [ r ]))})))
          (contr-center (cB a₀)) (contr-path (cB a₀)))
      (contr-center cA) (contr-path cA)

  ×-conn : ∀ {i} {j} {A : Type i} {B : Type j} {n : ℕ₋₂}
    → is-connected n A → is-connected n B
    → is-connected n (A × B)
  ×-conn cA cB = Σ-conn cA (λ _ → cB)

{- connectedness of a path space -}
abstract
 instance
  path-conn : ∀ {i} {A : Type i} {x y : A} {n : ℕ₋₂}
    → is-connected (S n) A → is-connected n (x == y)
  path-conn {x = x} {y = y} cA =
    equiv-preserves-level (Trunc=-equiv [ x ] [ y ])
      {{has-level-apply (contr-is-prop cA) [ x ] [ y ]}}

{- an n-Type which is n-connected is contractible -}
connected-at-level-is-contr : ∀ {i} {A : Type i} {n : ℕ₋₂}
  {{pA : has-level n A}} {{cA : is-connected n A}} → is-contr A
connected-at-level-is-contr {{pA}} {{cA}} =
  equiv-preserves-level (unTrunc-equiv _) {{cA}}

{- if A is n-connected and m ≤ n, then A is m-connected -}
connected-≤T : ∀ {i} {m n : ℕ₋₂} {A : Type i}
  → m ≤T n → {{_ : is-connected n A}} → is-connected m A
connected-≤T {m = m} {n = n} {A = A} leq =
  transport (λ B → is-contr B)
            (ua (Trunc-fuse A m n) ∙ ap (λ k → Trunc k A) (minT-out-l leq))
            (Trunc-preserves-level m ⟨⟩)

{- Equivalent types have the same connectedness -}
equiv-preserves-conn : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂} (e : A ≃ B)
  {{_ : is-connected n A}} → is-connected n B
equiv-preserves-conn {n = n} e = equiv-preserves-level (Trunc-emap e)

{- Composite of two connected functions is connected -}
∘-conn : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  → {n : ℕ₋₂} → (f : A → B) → (g : B → C)
  → has-conn-fibers n f
  → has-conn-fibers n g
  → has-conn-fibers n (g ∘ f)
∘-conn {n = n} f g cf cg =
  conn-in (λ P → conn-extend cg P ∘ conn-extend cf (P ∘ g) , lemma P)
    where
      lemma : ∀ P h x → conn-extend cg P (conn-extend cf (P ∘ g) h) (g (f x)) == h x
      lemma P h x =
        conn-extend cg P (conn-extend cf (P ∘ g) h) (g (f x))
          =⟨ conn-extend-β cg P (conn-extend cf (P ∘ g) h) (f x) ⟩
        conn-extend cf (P ∘ g) h (f x)
          =⟨ conn-extend-β cf (P ∘ g) h x ⟩
        h x
          =∎


module Issue731 where

data empty : Set where

foo : empty → _
foo ()

bar : empty → Set
bar = foo

{- But when I want to know what are the constraints (C-c C-= in
emacs), I get the following error instead:

No binding for builtin thing LEVELZERO, use {-# BUILTIN LEVELZERO
name #-} to bind it to 'name'
when checking that the expression foo has type empty → Set

I’m not sure it is a bug, but it seems a bit strange to get an error
message when doing C-c C-= -}

-- Now displays correctly:
-- _4 := foo [blocked by problem 3]
-- [3] _2 =< Set : Set _1
-- _1 = (.Agda.Primitive.lsuc .Agda.Primitive.lzero)
-- _1 = (.Agda.Primitive.lsuc .Agda.Primitive.lzero)