{-# OPTIONS --cubical --no-import-sorts --allow-unsolved-metas #-}

module Number.Instances.QuoInt where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)
open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Foundations.Logic renaming (inl to inlᵖ; inr to inrᵖ)

open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Sigma
open import Cubical.Data.Bool using (not)
open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥) -- `⊥` and `elim`
open import Cubical.Foundations.Logic renaming (¬_ to ¬ᵖ_; inl to inlᵖ; inr to inrᵖ)
open import Function.Base using (it; _∋_; _$_)

open import Cubical.HITs.PropositionalTruncation --.Properties

open import Utils using (!_; !!_)
open import MoreLogic.Reasoning
open import MoreLogic.Definitions
open import MoreLogic.Properties
open import MorePropAlgebra.Definitions hiding (_≤''_)
open import MorePropAlgebra.Structures
open import MorePropAlgebra.Bundles
open import MorePropAlgebra.Consequences
open import Number.Structures2
open import Number.Bundles2

open import Number.Instances.Nat using (lemma10''; lemma12'') renaming
  ( _<_ to _<ⁿ_
  ; <-irrefl  to <ⁿ-irrefl
  ; <-cotrans to <ⁿ-cotrans
  ; suc-creates-< to sucⁿ-creates-<ⁿ
  ; 0<suc to 0<ⁿsuc
  )
open import Data.Nat.Base using () renaming
  ( _⊔_ to maxⁿ
  ; _⊓_ to minⁿ
  ; _+_ to _+ⁿ_
  )

open import Cubical.HITs.Ints.QuoInt
open import Cubical.HITs.Ints.QuoInt.Properties
open import Cubical.Data.Nat using (suc; zero; ℕ) renaming
  ( +-comm to +ⁿ-comm )
open import Cubical.Data.Nat.Order using () renaming
  ( <-trans to <ⁿ-trans
  ; _<_ to _<ⁿᵗ_
  ; _≟_ to _≟ⁿ_
  ; lt to ltⁿ
  ; gt to gtⁿ
  ; eq to eqⁿ
  ; ¬-<-zero to ¬-<ⁿ-zero
  )

-- hProp-valued _<_
_<_ : ∀(x y : ℤ) → hProp ℓ-zero
x < y with sign x | sign y
... | spos | spos = abs x <ⁿ abs y
... | spos | sneg = ⊥
... | sneg | spos = ⊤ -- ↯ NOTE: exploiting this specific behaviour of `sign` is not much different from using just `Int`
... | sneg | sneg = abs y <ⁿ abs x

-- _<_ on a representation `λ x → (sign x , abs x)` of QuoInt
_<ʳ_ : ∀(x y : Sign × ℕ) → hProp ℓ-zero
(spos , x) <ʳ (spos , y) = x <ⁿ y
(spos , x) <ʳ (sneg , y) = ⊥
(sneg , x) <ʳ (spos , y) = ⊤
(sneg , x) <ʳ (sneg , y) = y <ⁿ x

<≡<ʳ : ∀ x y → x < y ≡ (sign x , abs x) <ʳ (sign y , abs y)
<≡<ʳ x y with sign x | sign y
... | spos | spos = refl
... | spos | sneg = refl
... | sneg | spos = refl
... | sneg | sneg = refl

-- different version of _<_
_<'_ : ℤ → ℤ → hProp ℓ-zero
pos      n₀  <' pos      n₁  = n₀ <ⁿ n₁
pos      n₀  <' neg      n₁  = ⊥
neg      0   <' pos      0   = ⊥
neg      0   <' pos (suc n₁) = ⊤
neg (suc n₀) <' pos      0   = ⊤
neg (suc n₀) <' pos (suc n₁) = ⊤
neg      n₀  <' neg      n₁  = n₁ <ⁿ n₀
pos      n₀  <' posneg   j   = lemma10'' n₀    j
neg      0   <' posneg   j   = lemma10'' 0  (~ j)
neg (suc n₀) <' posneg   j   = lemma12'' n₀ (~ j)
posneg   i   <' pos      0   = lemma10'' 0     i
posneg   i   <' pos (suc n₁) = lemma12'' n₁    i
posneg   i   <' neg      n₁  = lemma10'' n₁ (~ i)
posneg   i   <' posneg   j   = lemma10'' 0 ((i ∨ j) ∧ ~(i ∧ j))

<'≡< : ∀ x y → x <' y ≡ x < y
<'≡< (pos  zero  ) (pos  zero  ) = refl
<'≡< (pos  zero  ) (pos (suc y)) = refl
<'≡< (pos (suc x)) (pos  zero  ) = refl
<'≡< (pos (suc x)) (pos (suc y)) = refl
<'≡< (pos  zero  ) (neg  zero  ) = sym (lemma10'' _)
<'≡< (pos  zero  ) (neg (suc y)) = refl
<'≡< (pos (suc x)) (neg  zero  ) = sym (lemma10'' _)
<'≡< (pos (suc x)) (neg (suc y)) = refl
<'≡< (neg  zero  ) (pos  zero  ) = sym (lemma10'' _)
<'≡< (neg  zero  ) (pos (suc y)) = sym (lemma12'' _)
<'≡< (neg (suc x)) (pos  zero  ) = refl
<'≡< (neg (suc x)) (pos (suc y)) = refl
<'≡< (neg  zero  ) (neg  zero  ) = refl
<'≡< (neg  zero  ) (neg (suc y)) = lemma10'' _
<'≡< (neg (suc x)) (neg  zero  ) = lemma12'' _
<'≡< (neg (suc x)) (neg (suc y)) = refl
<'≡< (pos  zero  ) (posneg i) j = lemma10'' 0 (~ j ∧ i)
<'≡< (pos (suc x)) (posneg i) j = lemma10'' (suc x) (~ j ∧ i)
<'≡< (neg  zero  ) (posneg i) j = lemma10'' 0 (~ j ∧ ~ i)
<'≡< (neg (suc x)) (posneg i) j = lemma12'' x (j ∨ ~ i)
<'≡< (posneg i) (pos  zero  ) j = lemma10'' 0 (~ j ∧ i)
<'≡< (posneg i) (pos (suc y)) j = lemma12'' y (~ j ∧ i)
<'≡< (posneg i) (neg  zero  ) j = lemma10'' 0 (~ j ∧ ~ i)
<'≡< (posneg i) (neg (suc y)) j = lemma10'' (suc y) (j ∨ ~ i)
<'≡< (posneg i) (posneg   j ) k = lemma10'' 0 (((i ∨ j) ∧ ~ i ∨ ~ j) ∧ ~ k)

min : ℤ → ℤ → ℤ
min x y with sign x | sign y
... | spos | spos = pos (minⁿ (abs x) (abs y))
... | spos | sneg = y
... | sneg | spos = x
... | sneg | sneg = neg (maxⁿ (abs x) (abs y))

max : ℤ → ℤ → ℤ
max x y with sign x | sign y
... | spos | spos = pos (maxⁿ (abs x) (abs y))
... | spos | sneg = x
... | sneg | spos = y
... | sneg | sneg = neg (minⁿ (abs x) (abs y))

<-irrefl : (a : ℤ) → [ ¬ (a < a) ]
<-irrefl (pos zero)    = <ⁿ-irrefl 0
<-irrefl (pos (suc n)) = <ⁿ-irrefl (suc n)
<-irrefl (neg zero)    = <ⁿ-irrefl 0
<-irrefl (neg (suc n)) = <ⁿ-irrefl (suc n)
<-irrefl (posneg i) p  = <ⁿ-irrefl 0 p

<-trans : (a b c : ℤ) → [ a < b ] → [ b < c ] → [ a < c ]
<-trans a b c a<b b<c with sign a | sign b | sign c
  | pathTo⇒ (<≡<ʳ a b) a<b
  | pathTo⇒ (<≡<ʳ b c) b<c
  | pathTo⇐ (<≡<ʳ a c)
... | spos | spos | spos | a<b' | b<c' | p = p (<ⁿ-trans a<b' b<c')
... | spos | spos | sneg | a<b' | b<c' | p = p b<c'
... | spos | sneg | spos | a<b' | b<c' | p = p (⊥-elim a<b')
... | spos | sneg | sneg | a<b' | b<c' | p = p a<b'
... | sneg | spos | spos | a<b' | b<c' | p = p a<b'
... | sneg | spos | sneg | a<b' | b<c' | p = p (⊥-elim b<c')
... | sneg | sneg | spos | a<b' | b<c' | p = p b<c'
... | sneg | sneg | sneg | a<b' | b<c' | p = p (<ⁿ-trans b<c' a<b')

<-cotrans : (a b : ℤ) → [ a < b ] → (x : ℤ) → [ (a < x) ⊔ (x < b) ]
<-cotrans a b a<b c with sign a , abs a | sign b , abs b | sign c , abs c
  | pathTo⇒ (<≡<ʳ a b) a<b
  | pathTo⇐ (λ i → (<≡<ʳ a c) i ⊔ (<≡<ʳ c b) i)
... | spos , a' | spos , b' | spos , c' | a<b' | p = p (<ⁿ-cotrans _ _ a<b' c')
... | spos , a' | spos , b' | sneg , c' | a<b' | p = p (inrᵖ tt)
... | sneg , a' | spos , b' | spos , c' | a<b' | p = p (inlᵖ tt)
... | sneg , a' | spos , b' | sneg , c' | a<b' | p = p (inrᵖ tt)
... | sneg , a' | sneg , b' | spos , c' | a<b' | p = p (inlᵖ tt)
... | sneg , a' | sneg , b' | sneg , c' | a<b' | p = p (pathTo⇒ (⊔-comm (b' <ⁿ c') (c' <ⁿ a')) (<ⁿ-cotrans _ _ a<b' c'))

data Trichotomy (m n : ℤ) : Type₀ where
  lt : [ m < n ] → Trichotomy m n
  eq :   m ≡ n   → Trichotomy m n
  gt : [ n < m ] → Trichotomy m n

record Reveal'_·_is_ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
                   (f⁻¹ : B → A)
                   (y : B) (x : A)
                   : Type ℓ where
  eta-equality
  constructor [_]ⁱ'
  field eq' : x ≡ f⁻¹ y

inspect' : ∀{ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
          (f⁻¹ : B → A) (f : A → B) (x : A) → f⁻¹ (f x) ≡ x → Reveal' f⁻¹ · (f x) is x
inspect' f⁻¹ f x p = [ sym p ]ⁱ'

reprℤ : ℤ → Sign × ℕ
reprℤ z = sign z , abs z

reprℤ⁻¹ : Sign × ℕ → ℤ
reprℤ⁻¹ (s , n) = signed s n

reprℤ-id : ∀ z → reprℤ⁻¹ (reprℤ z) ≡ z
reprℤ-id (pos  zero  ) = refl
reprℤ-id (pos (suc n)) = refl
reprℤ-id (neg  zero  ) = posneg
reprℤ-id (neg (suc n)) = refl
reprℤ-id (posneg   i ) = λ j → posneg (i ∧ j)

inspect-reprℤ : (x : ℤ) → Reveal' reprℤ⁻¹ · (reprℤ x) is x
inspect-reprℤ a = inspect' reprℤ⁻¹ reprℤ a (reprℤ-id a)

-- abs : ℤ → ℕ
-- abs (signed _ n) = n
-- abs (posneg i) = zero

-- NOTE: this would be easier to get from `Int≡QuoInt`
_≟_ : ∀ m n → Trichotomy m n
m ≟ n with reprℤ m | reprℤ n
  | inspect-reprℤ m
  | inspect-reprℤ n
  | abs m ≟ⁿ abs n
  | pathTo⇐ (<≡<ʳ m n)
  | pathTo⇐ (<≡<ʳ n m)
... | spos , m' | spos , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | ltⁿ x | p | q = lt (p (transport (λ i → [ abs (m≡ i) <ⁿ abs (n≡ i) ]) x))
... | spos , m' | spos , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | eqⁿ x | p | q = let m'≡n' = (λ i → abs (m≡ (~ i))) ∙ x ∙ (λ i → abs (n≡ i))
                                                                    in eq (transport (λ i → (m≡ (~ i)) ≡ (n≡ (~ i))) (λ i → pos (m'≡n' i)))
... | spos , m' | spos , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | gtⁿ x | p | q = gt (q (transport (λ i → [ abs (n≡ i) <ⁿ abs (m≡ i) ]) x))
... | spos , m' | sneg , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | o     | p | q = gt (q tt)
... | sneg , m' | spos , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | o     | p | q = lt (p tt)
... | sneg , m' | sneg , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | ltⁿ x | p | q = gt (q (transport (λ i → [ abs (m≡ i) <ⁿ abs (n≡ i) ]) x))
... | sneg , m' | sneg , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | eqⁿ x | p | q = let m'≡n' = (λ i → abs (m≡ (~ i))) ∙ x ∙ (λ i → abs (n≡ i))
                                                                    in eq (transport (λ i → (m≡ (~ i)) ≡ (n≡ (~ i))) (λ i → neg (m'≡n' i)))
... | sneg , m' | sneg , n' | [ m≡ ]ⁱ' | [ n≡ ]ⁱ' | gtⁿ x | p | q = lt (p (transport (λ i → [ abs (n≡ i) <ⁿ abs (m≡ i) ]) x))

is-min : (x y z : ℤ) → [ ¬ᵖ (min x y < z) ⇔ ¬ᵖ (x < z) ⊓ ¬ᵖ (y < z) ]
is-min = {!  !}

is-max : (x y z : ℤ) → [ ¬ᵖ (z < max x y) ⇔ ¬ᵖ (z < x) ⊓ ¬ᵖ (z < y) ]
is-max = {!  !}

sucℤ-pos-suc : ∀ n → sucℤ (pos n) ≡ pos (suc n)
sucℤ-pos-suc x = refl -- holds definitionally

+-preserves-pos : ∀ x y → pos x + pos y ≡ pos (x +ⁿ y)
+-preserves-pos zero y = refl
+-preserves-pos (suc x) zero = transport (λ i → sucℤ (+-comm (pos 0) (pos x) i) ≡ pos (suc (+ⁿ-comm 0 x i))) refl
+-preserves-pos (suc x) (suc y) = λ i → sucℤ (+-preserves-pos x (suc y) i)

-- +-reflects-< : ∀ a b x → [ (a + x) < (b + x) ] → [ a < b ]
-- +-reflects-< a b x a+x<b+x with reprℤ a | reprℤ b | reprℤ x | reprℤ (a + x) | reprℤ (b + x)
--   | inspect-reprℤ a
--   | inspect-reprℤ b
--   | inspect-reprℤ x
--   | inspect-reprℤ (a + x)
--   | inspect-reprℤ (b + x)
--   | pathTo⇒ (<≡<ʳ (a + x) (b + x)) a+x<b+x
--   | pathTo⇐ (<≡<ʳ a b)
-- ... | spos , a' | spos , b' | sx , x' | spos , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | spos , a' | spos , b' | sx , x' | sneg , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | spos , a' | spos , b' | sx , x' | sneg , a+x | sneg , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | spos , a' | sneg , b' | sx , x' | spos , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | spos , a' | sneg , b' | sx , x' | sneg , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | spos , a' | sneg , b' | sx , x' | sneg , a+x | sneg , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | sneg , a' | spos , b' | sx , x' | spos , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | sneg , a' | spos , b' | sx , x' | sneg , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | sneg , a' | spos , b' | sx , x' | sneg , a+x | sneg , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | sneg , a' | sneg , b' | sx , x' | spos , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | sneg , a' | sneg , b' | sx , x' | sneg , a+x | spos , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}
-- ... | sneg , a' | sneg , b' | sx , x' | sneg , a+x | sneg , b+x | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | [ x≡ ]ⁱ' | [ a+x≡ ]ⁱ' | [ b+x≡ ]ⁱ' | p | q = q {!   !}

+-identity-posˡ : ∀ a → pos zero + a ≡ a
+-identity-posˡ a = refl

+-identity-posʳ : ∀ a → a + pos zero ≡ a
+-identity-posʳ a = +-comm a (pos zero) ∙ +-identity-posˡ a

-- -_ : ℤ → ℤ
-- - signed s n = signed (not s) n
-- - posneg i   = posneg (~ i)
--
-- _+_ : ℤ → ℤ → ℤ
-- (signed _ zero) + n = n
-- (posneg _)      + n = n
-- (pos (suc m))   + n = sucℤ  (pos m + n)
-- (neg (suc m))   + n = predℤ (neg m + n)

pos≡-neg : ∀ n → pos n ≡ - neg n
pos≡-neg n = refl

-pos≡neg : ∀ n → - pos n ≡ neg n
-pos≡neg n = refl

suc-neg-suc≡neg : ∀ n → sucℤ (neg (suc n)) ≡ neg n
suc-neg-suc≡neg n = refl

pos+neg≡0 : ∀ n → pos n + neg n ≡ 0
pos+neg≡0 zero = sym posneg
pos+neg≡0 (suc n) = transport (
  pos n + neg n                ≡ pos 0 ≡⟨ (λ i → +-comm (pos n) (neg n) i ≡ pos 0) ⟩
  neg n + pos n                ≡ pos 0 ≡⟨ refl ⟩
  (sucℤ (neg (suc n)) + pos n) ≡ pos 0 ≡⟨ (λ i → sucℤ-+ˡ (neg (suc n)) (pos n) (~ i) ≡ pos 0) ⟩
  sucℤ (neg (suc n) + pos n)   ≡ pos 0 ≡⟨ (λ i → sucℤ (+-comm (pos n) (neg (suc n)) (~ i)) ≡ pos 0) ⟩
  sucℤ (pos n + neg (suc n))   ≡ pos 0 ∎) (pos+neg≡0 n)

neg+pos≡0 : ∀ n → neg n + pos n ≡ 0
neg+pos≡0 n = +-comm (neg n) (pos n) ∙ pos+neg≡0 n

+-inverseʳ : ∀ a → a + (- a) ≡ 0
+-inverseʳ a with reprℤ a | inspect-reprℤ a
... | spos , a' | [ a≡ ]ⁱ' = transport (λ i → a≡ (~ i) + (- a≡ (~ i)) ≡ pos 0) (pos+neg≡0 a')
... | sneg , a' | [ a≡ ]ⁱ' = transport (λ i → a≡ (~ i) + (- a≡ (~ i)) ≡ pos 0) (neg+pos≡0 a')

+-inverseˡ : ∀ a → (- a) + a ≡ 0
+-inverseˡ a = +-comm (- a) a ∙ +-inverseʳ a

+-inverse : (x : ℤ) → (x + (- x) ≡ pos 0) × ((- x) + x ≡ pos 0)
+-inverse x .fst = +-inverseʳ x
+-inverse x .snd = +-inverseˡ x

-- -on-reprℤ : ∀ a → (sign (- a) , abs (- a)) ≡ (not (sign a) , abs a)
-- -on-reprℤ (pos zero) = {!   !} -- Goal (spos , 0) ≡ (sneg , 0)
-- -on-reprℤ (pos (suc n)) = {!   !}
-- -on-reprℤ (neg n) = {!   !}
-- -on-reprℤ (posneg i) = {!   !}

-flips-< : ∀ a b → [ a < b ] → [ (- b) < (- a) ]
-flips-< a b a<b with reprℤ a | reprℤ b
  | inspect-reprℤ a
  | inspect-reprℤ b
  | pathTo⇒ (<≡<ʳ a b) a<b
  | pathTo⇐ (<≡<ʳ (- b) (- a))
... | spos , zero   | spos , zero   | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r p)
... | sneg , zero   | spos , zero   | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r (⊥-elim $ <-irrefl a $ subst (λ p → [ a < p ]) (b≡ ∙ posneg ∙ sym a≡) a<b))
... | sneg , zero   | sneg , zero   | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r p)
... | spos , zero   | spos , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r tt)
... | sneg , zero   | spos , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r tt)
... | sneg , zero   | sneg , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r p)
... | spos , suc a' | spos , zero   | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r (¬-<ⁿ-zero p))
... | sneg , suc a' | spos , zero   | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r (0<ⁿsuc _))
... | sneg , suc a' | sneg , zero   | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r (0<ⁿsuc _))
... | spos , suc a' | spos , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r p)
... | sneg , suc a' | spos , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r tt)
... | sneg , suc a' | sneg , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (sym λ i → fst ((sign (- b≡ i) , abs (- b≡ i)) <ʳ (sign (- a≡ i) , abs (- a≡ i)))) in q (r p)

-- suc-reflects-< : ∀ a b → [ sucℤ a < sucℤ b ] → [ a < b ]
-- suc-reflects-< (pos zero) (pos zero) sa<sb = ⊥-elim $ <-irrefl (pos 1) sa<sb
-- suc-reflects-< (pos zero) (pos (suc n₁)) sa<sb = sucⁿ-creates-<ⁿ 0 (suc n₁) .snd sa<sb
-- suc-reflects-< (pos zero) (neg zero) sa<sb = {!   !}
-- suc-reflects-< (pos zero) (neg (suc n₁)) sa<sb = {!   !}
-- suc-reflects-< (pos (suc n₀)) (pos zero) sa<sb = {!   !}
-- suc-reflects-< (pos (suc n₀)) (pos (suc n₁)) sa<sb = {!   !}
-- suc-reflects-< (pos (suc n₀)) (neg zero) sa<sb = {!   !}
-- suc-reflects-< (pos (suc n₀)) (neg (suc n₁)) sa<sb = {!   !}
-- suc-reflects-< (neg zero) (pos zero) sa<sb = {!   !}
-- suc-reflects-< (neg zero) (pos (suc n₁)) sa<sb = {!   !}
-- suc-reflects-< (neg zero) (neg zero) sa<sb = {!   !}
-- suc-reflects-< (neg zero) (neg (suc n₁)) sa<sb = {!   !}
-- suc-reflects-< (neg (suc n₀)) (pos zero) sa<sb = {!   !}
-- suc-reflects-< (neg (suc n₀)) (pos (suc n₁)) sa<sb = {!   !}
-- suc-reflects-< (neg (suc n₀)) (neg zero) sa<sb = {!   !}
-- suc-reflects-< (neg (suc n₀)) (neg (suc n₁)) sa<sb = {!   !}
-- suc-reflects-< (signed s₀ n₀) (posneg j) sa<sb = {!   !}
-- suc-reflects-< (posneg i) (signed s₁ n₁) sa<sb = {!   !}
-- suc-reflects-< (posneg i) (posneg j) sa<sb = {!   !}

suc-reflects-< : ∀ a b → [ sucℤ a < sucℤ b ] → [ a < b ]
suc-reflects-< a b sa<sb with reprℤ a | reprℤ b
  | inspect-reprℤ a
  | inspect-reprℤ b
  | pathTo⇒ (<≡<ʳ (sucℤ a) (sucℤ b)) sa<sb
  | pathTo⇐ (<≡<ʳ a b)
... | spos , a' | spos , b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (λ i → [ (sign (sucℤ (a≡ i)) , abs (sucℤ (a≡ i))) <ʳ (sign (sucℤ (b≡ i)) , abs (sucℤ (b≡ i))) ]) p
                                                          in q (sucⁿ-creates-<ⁿ a' b' .snd r)
-- ... | spos , a' | sneg , b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (λ i → [ (sign (sucℤ (a≡ i)) , abs (sucℤ (a≡ i))) <ʳ (sign (sucℤ (b≡ i)) , abs (sucℤ (b≡ i))) ]) p
--                                                           in q {!  !}
... | spos , a' | sneg , 0 | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (λ i → [ (sign (sucℤ (a≡ i)) , abs (sucℤ (a≡ i))) <ʳ (sign (sucℤ (b≡ i)) , abs (sucℤ (b≡ i))) ]) p
                                                          in q (¬-<ⁿ-zero $ sucⁿ-creates-<ⁿ a' 0 .snd r)
... | spos , a' | sneg , suc 0 | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (λ i → [ (sign (sucℤ (a≡ i)) , abs (sucℤ (a≡ i))) <ʳ (sign (sucℤ (b≡ i)) , abs (sucℤ (b≡ i))) ]) p
                                                          in q (¬-<ⁿ-zero r)
... | spos , a' | sneg , suc (suc b') | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (λ i → [ (sign (sucℤ (a≡ i)) , abs (sucℤ (a≡ i))) <ʳ (sign (sucℤ (b≡ i)) , abs (sucℤ (b≡ i))) ]) p
                                                          in q r
... | sneg , a' | spos , b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = q tt
... | sneg , zero | sneg , zero | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = q (⊥-elim $ <-irrefl (sucℤ a) $ subst (λ p → [ sucℤ a < sucℤ p ]) (b≡ ∙ sym a≡) sa<sb)
... | sneg , zero | sneg , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = q {!   !}
... | sneg , suc a' | sneg , zero | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = q (0<ⁿsuc _)
... | sneg , suc a' | sneg , suc b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (λ i → [ (sign (sucℤ (a≡ i)) , abs (sucℤ (a≡ i))) <ʳ (sign (sucℤ (b≡ i)) , abs (sucℤ (b≡ i))) ]) p
                                                                    in q {!   !}
-- ... | sneg , a' | sneg , b' | [ a≡ ]ⁱ' | [ b≡ ]ⁱ' | p | q = let r = transport (λ i → [ (- sucℤ (b≡ i)) < (- sucℤ (a≡ i)) ] )
                                                          -- in q {!  sa<sb  !}

-- [ (a + pos (suc n)) < (b + pos (suc n)) ] →

+-reflects-< : ∀ a b x → [ (a + x) < (b + x) ] → [ a < b ]
+-reflects-< a b (pos (suc n)) a+x<b+x = +-reflects-< a b (pos n) {!   !}
+-reflects-< a b (neg (suc n)) a+x<b+x = {!   !}
-- +-reflects-< a b (pos zero) a+x<b+x = pathTo⇒ (λ i → +-identity-posʳ a i < +-identity-posʳ b i) a+x<b+x
+-reflects-< a b (pos zero) a+x<b+x = pathTo⇒ (λ i → +-comm a (pos zero) i < +-comm b (pos zero) i) a+x<b+x
+-reflects-< a b (neg zero) a+x<b+x = pathTo⇒ (λ i → +-comm a (neg zero) i < +-comm b (neg zero) i) a+x<b+x
+-reflects-< a b (posneg i) a+x<b+x = pathTo⇒ (λ j → +-comm a (posneg i) j < +-comm b (posneg i) j) a+x<b+x

+-<-ext : (w x y z : ℤ) → [ (w + x) < (y + z) ] → [ (w < y) ⊔ (x < z) ]
+-<-ext w x y z r with w ≟ y | x ≟ z
... | lt w<y | q = inlᵖ w<y
... | eq w≡y | q = inrᵖ {! +-injˡ y x z   !}
... | gt y<w | q = {!   !}

·-preserves-< : (x y z : ℤ) → [ 0 < z ] → [ x < y ] → [ (x * z) < (y * z) ]
·-preserves-< = {!  !}

+-Semigroup : [ isSemigroup _+_ ]
+-Semigroup .IsSemigroup.is-set   = isSetℤ
+-Semigroup .IsSemigroup.is-assoc = +-assoc

·-Semigroup : [ isSemigroup _*_ ]
·-Semigroup .IsSemigroup.is-set   = isSetℤ
·-Semigroup .IsSemigroup.is-assoc = *-assoc

+-Monoid : [ isMonoid 0 _+_ ]
+-Monoid .IsMonoid.is-Semigroup = +-Semigroup
+-Monoid .IsMonoid.is-identity x = +-identityʳ x , refl

·-Monoid : [ isMonoid 1 _*_ ]
·-Monoid .IsMonoid.is-Semigroup = ·-Semigroup
·-Monoid .IsMonoid.is-identity x = *-identityʳ x , *-identityˡ x

is-Semiring : [ isSemiring 0 1 _+_ _*_ ]
is-Semiring .IsSemiring.+-Monoid = +-Monoid
is-Semiring .IsSemiring.·-Monoid = ·-Monoid
is-Semiring .IsSemiring.+-comm   = +-comm
is-Semiring .IsSemiring.is-dist x y z = sym (*-distribˡ x y z) , sym (*-distribʳ x y z)

is-CommSemiring : [ isCommSemiring 0 1 _+_ _*_ ]
is-CommSemiring .IsCommSemiring.is-Semiring = is-Semiring
is-CommSemiring .IsCommSemiring.·-comm      = *-comm

<-StrictLinearOrder : [ isStrictLinearOrder _<_ ]
<-StrictLinearOrder .IsStrictLinearOrder.is-irrefl = <-irrefl
<-StrictLinearOrder .IsStrictLinearOrder.is-trans  a b c = <-trans a b c
<-StrictLinearOrder .IsStrictLinearOrder.is-tricho a b with a ≟ b
... | lt a<b = inl (inl a<b)
... | eq a≡b = inr ∣ a≡b ∣
... | gt b<a = inl (inr b<a)

≤-isLattice : [ isLattice (λ x y → ¬ᵖ (y < x)) min max ]
≤-isLattice .IsLattice.≤-PartialOrder = linearorder⇒partialorder _ (≤'-isLinearOrder <-StrictLinearOrder)
≤-isLattice .IsLattice.is-min         = is-min
≤-isLattice .IsLattice.is-max         = is-max

is-LinearlyOrderedCommSemiring : [ isLinearlyOrderedCommSemiring 0 1 _+_ _*_ _<_ min max ]
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.is-CommSemiring     = is-CommSemiring
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.<-StrictLinearOrder = <-StrictLinearOrder
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.≤-isLattice         = ≤-isLattice
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.+-<-ext             = +-<-ext
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.·-preserves-<       = ·-preserves-<

is-LinearlyOrderedCommRing : [ isLinearlyOrderedCommRing 0 1 _+_ _*_ -_ _<_ min max ]
is-LinearlyOrderedCommRing .IsLinearlyOrderedCommRing.is-LinearlyOrderedCommSemiring = is-LinearlyOrderedCommSemiring
is-LinearlyOrderedCommRing .IsLinearlyOrderedCommRing.+-inverse                      = +-inverse

ℤbundle : LinearlyOrderedCommRing {ℓ-zero} {ℓ-zero}
ℤbundle .LinearlyOrderedCommRing.Carrier                    = ℤ
ℤbundle .LinearlyOrderedCommRing.0f                         = 0
ℤbundle .LinearlyOrderedCommRing.1f                         = 1
ℤbundle .LinearlyOrderedCommRing._+_                        = _+_
ℤbundle .LinearlyOrderedCommRing._·_                        = _*_
ℤbundle .LinearlyOrderedCommRing.-_                         = -_
ℤbundle .LinearlyOrderedCommRing.min                        = min
ℤbundle .LinearlyOrderedCommRing.max                        = max
ℤbundle .LinearlyOrderedCommRing._<_                        = _<_
ℤbundle .LinearlyOrderedCommRing.is-LinearlyOrderedCommRing = is-LinearlyOrderedCommRing


-- There was a bug where Confuse and confusing were considered
-- projection-like even though they have absurd clauses.
module _ (A : Set) where

data D : Set where
  d : D

data P : D → Set where

Confuse : (d : D) (p : P d) → Set
Confuse x ()

confusing : (d : D) (p : P d) → Confuse d p
confusing x ()

test : (x : P d) → Set
test x with confusing d x
test x | e = A


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

open import OscarPrelude
open import Formula

infix 15 _╱_
record Sequent : Set
 where
  constructor _╱_
  field
    statement : Formula
    suppositions : List Formula

open Sequent public

instance EqSequent : Eq Sequent
Eq._==_ EqSequent ( φᵗ₁ ╱ φˢs₁ ) ( φᵗ₂ ╱ φˢs₂ ) = decEq₂ (cong statement) (cong suppositions) (φᵗ₁ ≟ φᵗ₂) (φˢs₁ ≟ φˢs₂)

open import HasNegation

instance HasNegationSequent : HasNegation Sequent
HasNegation.~ HasNegationSequent ( φᵗ ╱ φˢs ) = ~ φᵗ ╱ φˢs

open import 𝓐ssertion

instance 𝓐ssertionSequent : 𝓐ssertion Sequent
𝓐ssertionSequent = record {}

open import HasSatisfaction

instance HasSatisfactionSequent : HasSatisfaction Sequent
HasSatisfaction._⊨_ HasSatisfactionSequent I (φᵗ ╱ φˢs) = I ⊨ φˢs → I ⊨ φᵗ

open import HasDecidableValidation

instance HasDecidableValidationSequent : HasDecidableValidation Sequent
HasDecidableValidationSequent = {!!}

open import HasSubstantiveDischarge

instance HasSubstantiveDischargeSequentSequent : HasSubstantiveDischarge Sequent Sequent
HasSubstantiveDischarge._≽_ HasSubstantiveDischargeSequentSequent (+ᵗ ╱ +ᵖs) (-ᵗ ╱ -ᵖs) = {!!} -- +ᵗ ≽ -ᵗ × +ᵖs ≽ -ᵖs -- use "unification into", from John's "Natural Deduction"

open import HasDecidableSubstantiveDischarge

instance HasDecidableSubstantiveDischargeSequentSequent : HasDecidableSubstantiveDischarge Sequent Sequent
HasDecidableSubstantiveDischarge._≽?_ HasDecidableSubstantiveDischargeSequentSequent = {!!}


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

{-
  The moral of the story is best told by comparing RegularVsConstructedMoreSimpler and RegularVsConstructed-EnhancedReg:
  * aliased type constructors can lose information about their dependencies, leading to some inconvenience when using a function which takes those dependencies implicitly
  * expressing those constructors as records (instead of as aliases) averts the above inconvenience
  * the loss of information happens when the resultant type is made from projections on the dependencies, where only a proper subset of all the possible projections are used
  TODO: what if instead of projections, we use a function? (try one that's abstract, and one that case splits on arguments)
    - see ProjectedMorality ... so far it looks like it doesn't matter --- not sure why
  TODO: what if the argument type (the one that's losing information) were data instead of record?
    - see DataMorality ... weirdness!
-}

module AgdaFeaturePitfallInstanceResolution where

record Symmetry {B : Set₁} (_∼_ : B → B → Set) : Set₁ where
  field symmetry : ∀ {x y} → x ∼ y → y ∼ x

Property : Set → Set₁
Property A = A → Set

Extension : {A : Set} → Property A → Set
Extension P = ∀ f → P f

postulate PropertyEquivalence : ∀ {P : Set} → Property P → Property P → Set

record Regular : Set where
  no-eta-equality

  infixr 5 _,_
  record Σ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) : Set₁ where
    constructor _,_
    field
      π₀ : 𝔒
      π₁ : 𝔓 π₀

  open Σ public

  ExtensionProperty : ∀ (𝔒 : Set) → Set₁
  ExtensionProperty 𝔒 = Σ (Property 𝔒) Extension

  _≈_ : {𝔒 : Set} → ExtensionProperty 𝔒 → ExtensionProperty 𝔒 → Set
  _≈_ P Q = PropertyEquivalence (π₀ P) (π₀ Q)

  record Instance : Set where
    no-eta-equality

    postulate instance _ : ∀ {𝔒 : Set} → Symmetry (_≈_ {𝔒 = 𝔒})
    open Symmetry ⦃ … ⦄

    module Test {𝔒 : Set} where

      test1-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-fails P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-fails {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-works {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

  record Function : Set where
    no-eta-equality

    postulate symmetry : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈ y → y ≈ x
    -- normalises to   : {𝔒 : Set} {x y : Σ (𝔒 → Set) (λ P → (f : 𝔒) → P f)} → PropertyEquivalence (π₀ x) (π₀ y) → PropertyEquivalence (π₀ y) (π₀ x)

    module Test {𝔒 : Set} where

      test1-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-fails P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-fails {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-works {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

record Revamped : Set where
  no-eta-equality

  record ExtensionProperty (𝔒 : Set) : Set₁ where
    constructor _,_
    field
      π₀ : Property 𝔒
      π₁ : Extension π₀

  open ExtensionProperty

  _≈_ : {𝔒 : Set} → ExtensionProperty 𝔒 → ExtensionProperty 𝔒 → Set
  _≈_ P Q = PropertyEquivalence (π₀ P) (π₀ Q)

  record Instance : Set where
    no-eta-equality

    postulate instance _ : ∀ {𝔒 : Set} → Symmetry (_≈_ {𝔒 = 𝔒})
    open Symmetry ⦃ … ⦄

    module Test {𝔒 : Set} where

      test1-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-fails P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-fails {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-works {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

  record Function : Set where
    no-eta-equality

    postulate symmetry : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈ y → y ≈ x
    -- normalises to   : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → PropertyEquivalence (π₀ x) (π₀ y) → PropertyEquivalence (π₀ y) (π₀ x)

    module Test {𝔒 : Set} where

      test1-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-fails P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-fails : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-fails {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-works {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

record PostulatedExtensionProperty : Set where
  no-eta-equality

  postulate
    ExtensionProperty : Set → Set₁
    π₀ : {𝔒 : Set} → ExtensionProperty 𝔒 → Property 𝔒
    π₁ : {𝔒 : Set} → (P : ExtensionProperty 𝔒) → Extension (π₀ P)
    _,_ : {𝔒 : Set} → (π₀ : Property 𝔒) → Extension π₀ → ExtensionProperty 𝔒

  _≈_ : {𝔒 : Set} → ExtensionProperty 𝔒 → ExtensionProperty 𝔒 → Set
  _≈_ P Q = PropertyEquivalence (π₀ P) (π₀ Q)

  record Instance : Set where
    no-eta-equality

    postulate instance _ : ∀ {𝔒 : Set} → Symmetry (_≈_ {𝔒 = 𝔒})
    open Symmetry ⦃ … ⦄

    module Test {𝔒 : Set} where

      test1-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-works P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-inexpressible : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-inexpressible {P} {Q} P≈Q = {!!} -- symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-inexpressible : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-inexpressible {P} {Q} P≈Q = {!!} -- symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

  record Function : Set where
    no-eta-equality

    postulate symmetry : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈ y → y ≈ x
    -- normalises to   : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → PropertyEquivalence (π₀ x) (π₀ y) → PropertyEquivalence (π₀ y) (π₀ x)

    module Test {𝔒 : Set} where

      test1-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-works P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-inexpressible : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-inexpressible {P} {Q} P≈Q = {!!} -- symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-inexpressible : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-inexpressible {P} {Q} P≈Q = {!!} -- symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

record Constructed : Set where
  no-eta-equality

  infixr 5 _,_
  record Σ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) : Set₁ where
    constructor _,_
    field
      π₀ : 𝔒
      π₁ : 𝔓 π₀

  open Σ public

  ExtensionProperty : Set → Set₁
  ExtensionProperty 𝔒 = Σ (Property 𝔒) Extension

  record _≈_ {𝔒 : Set} (P Q : ExtensionProperty 𝔒) : Set where
    constructor ∁
    field
      π₀ : PropertyEquivalence (π₀ P) (π₀ Q)

  record Instance : Set where
    no-eta-equality

    postulate instance _ : {𝔒 : Set} → Symmetry (_≈_ {𝔒 = 𝔒})
    open Symmetry ⦃ … ⦄

    module Test {𝔒 : Set} where

      test1-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-works P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-works {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-works {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

  record Function : Set where
    no-eta-equality

    postulate symmetry : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈ y → y ≈ x
    -- normalises to   : {𝔒 : Set} {x y : Σ (𝔒 → Set) (λ P → (f : 𝔒) → P f)} → x ≈ y → y ≈ x

    module Test {𝔒 : Set} where

      test1-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test1-works P≈Q = symmetry P≈Q

      test2-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test2-works {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test3-works {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-works : {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
      test4-works {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

record RegularVsConstructed : Set where
  no-eta-equality

  infixr 5 _,_
  record Σ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) : Set₁ where
    constructor _,_
    field
      π₀ : 𝔒
      π₁ : 𝔓 π₀

  open Σ public

  ExtensionProperty : Set → Set₁
  ExtensionProperty 𝔒 = Σ (Property 𝔒) Extension

  record _≈R_ {𝔒 : Set} (P Q : ExtensionProperty 𝔒) : Set where
    constructor ∁
    field
      π₀ : PropertyEquivalence (π₀ P) (π₀ Q)

  _≈F_ : {𝔒 : Set} → ExtensionProperty 𝔒 → ExtensionProperty 𝔒 → Set
  _≈F_ P Q = PropertyEquivalence (π₀ P) (π₀ Q)

  record Instance : Set where
    no-eta-equality

    postulate instance _ : {𝔒 : Set} → Symmetry (_≈R_ {𝔒 = 𝔒})
    postulate instance _ : {𝔒 : Set} → Symmetry (_≈F_ {𝔒 = 𝔒})
    open Symmetry ⦃ … ⦄

    module Test {𝔒 : Set} where

      test1-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test1-worksR P≈Q = symmetry P≈Q

      test2-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test2-worksR {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test3-worksR {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test4-worksR {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

      test1-failsF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test1-failsF P≈Q = symmetry P≈Q

      test2-worksF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test2-worksF {P} {Q} P≈Q = symmetry {x = P} {y = Q} P≈Q

      test3-failsF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test3-failsF {P} {Q} P≈Q = symmetry {x = _ , _} {y = _ , _} P≈Q

      test4-worksF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test4-worksF {P} {Q} P≈Q = symmetry {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

  record Function : Set where
    no-eta-equality

    postulate symmetryR : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈R y → y ≈R x
    postulate symmetryF : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈F y → y ≈F x

    module Test {𝔒 : Set} where

      test1-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test1-worksR P≈Q = symmetryR P≈Q

      test2-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test2-worksR {P} {Q} P≈Q = symmetryR {x = P} {y = Q} P≈Q

      test3-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test3-worksR {P} {Q} P≈Q = symmetryR {x = _ , _} {y = _ , _} P≈Q

      test4-worksR : {P Q : ExtensionProperty 𝔒} → P ≈R Q → Q ≈R P
      test4-worksR {P} {Q} P≈Q = symmetryR {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

      test1-failsF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test1-failsF P≈Q = symmetryF P≈Q

      test2-worksF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test2-worksF {P} {Q} P≈Q = symmetryF {x = P} {y = Q} P≈Q

      test3-failsF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test3-failsF {P} {Q} P≈Q = symmetryF {x = _ , _} {y = _ , _} P≈Q

      test4-worksF : {P Q : ExtensionProperty 𝔒} → P ≈F Q → Q ≈F P
      test4-worksF {P} {Q} P≈Q = symmetryF {x = _ , π₁ P} {y = _ , π₁ Q} P≈Q

record RegularVsConstructedSimpler : Set where
  no-eta-equality

  infixr 5 _,_
  record Σ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) : Set₁ where
    constructor _,_
    field
      π₀ : 𝔒
      π₁ : 𝔓 π₀

  open Σ public

  postulate Prop : Set₁
  postulate Ext : Prop → Set
  postulate PropEq : Prop → Set

  ExtProp : Set₁
  ExtProp = Σ Prop Ext

  record ≈C_ (P : ExtProp) : Set where
    constructor ∁
    field
      π₀ : PropEq (π₀ P)

  ≈R_ : ExtProp → Set
  ≈R_ P = PropEq (π₀ P)

  record Instance : Set where
    no-eta-equality

    record Class {B : Set₁} (∼_ : B → Set) : Set₁ where
      field foo : ∀ {x} → ∼ x → Set
    open Class ⦃ … ⦄

    postulate instance _ : Class ≈C_
    postulate instance _ : Class ≈R_

    module Test where

      test1-worksC : {P : ExtProp} → ≈C P → Set
      test1-worksC P≈Q = foo P≈Q

      test2-worksC : {P : ExtProp} → ≈C P → Set
      test2-worksC {P} P≈Q = foo {x = P} P≈Q

      test3-worksC : {P : ExtProp} → ≈C P → Set
      test3-worksC {P} P≈Q = foo {x = _ , _} P≈Q

      test4-worksC : {P : ExtProp} → ≈C P → Set
      test4-worksC {P} P≈Q = foo {x = _ , π₁ P} P≈Q

      test1-failsR : {P : ExtProp} → ≈R P → Set
      test1-failsR P≈Q = foo P≈Q

      test2-worksR : {P : ExtProp} → ≈R P → Set
      test2-worksR {P} P≈Q = foo {x = P} P≈Q

      test3-failsR : {P : ExtProp} → ≈R P → Set
      test3-failsR {P} P≈Q = foo {x = _ , _} P≈Q

      test4-worksR : {P : ExtProp} → ≈R P → Set
      test4-worksR {P} P≈Q = foo {x = _ , π₁ P} P≈Q

  record Function : Set where
    no-eta-equality

    postulate fooC : {x : ExtProp} → ≈C x → Set
    postulate fooR : {x : ExtProp} → ≈R x → Set

    module Test where

      test1-worksC : {P : ExtProp} → ≈C P → Set
      test1-worksC P≈Q = fooC P≈Q

      test2-worksC : {P : ExtProp} → ≈C P → Set
      test2-worksC {P} P≈Q = fooC {x = P} P≈Q

      test3-worksC : {P : ExtProp} → ≈C P → Set
      test3-worksC {P} P≈Q = fooC {x = _ , _} P≈Q

      test4-worksC : {P : ExtProp} → ≈C P → Set
      test4-worksC {P} P≈Q = fooC {x = _ , π₁ P} P≈Q

      test1-failsR : {P : ExtProp} → ≈R P → Set
      test1-failsR P≈Q = fooR P≈Q

      test2-worksR : {P : ExtProp} → ≈R P → Set
      test2-worksR {P} P≈Q = fooR {x = P} P≈Q

      test3-failsR : {P : ExtProp} → ≈R P → Set
      test3-failsR {P} P≈Q = fooR {x = _ , _} P≈Q

      test4-worksR : {P : ExtProp} → ≈R P → Set
      test4-worksR {P} P≈Q = fooR {x = _ , π₁ P} P≈Q

record RegularVsConstructedMoreSimpler : Set where
  no-eta-equality

  infixr 5 _,_
  record Σ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) : Set₁ where
    constructor _,_
    field
      π₀ : 𝔒
      π₁ : Set

  open Σ

  postulate Prop : Set₁
  postulate Ext : Prop → Set
  postulate PropEq : Prop → Set

  ExtProp : Set₁
  ExtProp = Σ Prop Ext

  Reg : ExtProp → Set
  Reg P = PropEq (π₀ P)

  record Con (P : ExtProp) : Set where
    constructor ∁
    field
      π₀ : Reg P

  module Instance where

    record Class {B : Set₁} (F : B → Set) : Set₁ where
      field foo : ∀ {x} → F x → Set
    open Class ⦃ … ⦄

    postulate instance _ : Class Reg
    postulate instance _ : Class Con
    postulate instance _ : Class Ext
    postulate instance _ : Class PropEq

    test1-failsR : {P : ExtProp} → Reg P → Set
    test1-failsR P≈Q = foo P≈Q

    test2-worksR : {P : ExtProp} → Reg P → Set
    test2-worksR {P} P≈Q = foo {x = P} P≈Q

    test3-failsR : {P : ExtProp} → Reg P → Set
    test3-failsR {P} P≈Q = foo {x = _ , _} P≈Q

    test4-worksR : {P : ExtProp} → Reg P → Set
    test4-worksR {P} P≈Q = foo {x = _ , π₁ P} P≈Q

    test1-worksC : {P : ExtProp} → Con P → Set
    test1-worksC P≈Q = foo P≈Q

    test2-worksC : {P : ExtProp} → Con P → Set
    test2-worksC {P} P≈Q = foo {x = P} P≈Q

    test3-worksC : {P : ExtProp} → Con P → Set
    test3-worksC {P} P≈Q = foo {x = _ , _} P≈Q

    test4-worksC : {P : ExtProp} → Con P → Set
    test4-worksC {P} P≈Q = foo {x = _ , π₁ P} P≈Q

  module Function where

    postulate fooR : {x : ExtProp} → Reg x → Set
    postulate fooC : {x : ExtProp} → Con x → Set

    test1-failsR : {P : ExtProp} → Reg P → Set
    test1-failsR P≈Q = fooR P≈Q

    test2-worksR : {P : ExtProp} → Reg P → Set
    test2-worksR {P} P≈Q = fooR {x = P} P≈Q

    test3-failsR : {P : ExtProp} → Reg P → Set
    test3-failsR {P} P≈Q = fooR {x = _ , _} P≈Q

    test4-worksR : {P : ExtProp} → Reg P → Set
    test4-worksR {P} P≈Q = fooR {x = _ , π₁ P} P≈Q

    test1-worksC : {P : ExtProp} → Con P → Set
    test1-worksC P≈Q = fooC P≈Q

    test2-worksC : {P : ExtProp} → Con P → Set
    test2-worksC {P} P≈Q = fooC {x = P} P≈Q

    test3-worksC : {P : ExtProp} → Con P → Set
    test3-worksC {P} P≈Q = fooC {x = _ , _} P≈Q

    test4-worksC : {P : ExtProp} → Con P → Set
    test4-worksC {P} P≈Q = fooC {x = _ , π₁ P} P≈Q

module RegularVsConstructed-EnhancedReg where

  infixr 5 _,_
  record Σ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) : Set₁ where
    constructor _,_
    field
      π₀ : 𝔒
      π₁ : Set

  open Σ

  postulate Prop : Set₁
  postulate Ext : Prop → Set
  postulate PropEq : Prop → Set → Set

  ExtProp : Set₁
  ExtProp = Σ Prop Ext

  Reg : ExtProp → Set
  Reg P = PropEq (π₀ P) (π₁ P)

  record Con (P : ExtProp) : Set where
    constructor ∁
    field
      π₀ : Reg P

  module Instance where

    record Class {B : Set₁} (F : B → Set) : Set₁ where
      field foo : ∀ {x} → F x → Set
    open Class ⦃ … ⦄

    postulate instance _ : Class Reg
    postulate instance _ : Class Con
    postulate instance _ : Class Ext

    test1-failsR : {P : ExtProp} → Reg P → Set
    test1-failsR P≈Q = foo P≈Q

    test2-worksR : {P : ExtProp} → Reg P → Set
    test2-worksR {P} P≈Q = foo {x = P} P≈Q

    test3-failsR : {P : ExtProp} → Reg P → Set
    test3-failsR {P} P≈Q = foo {x = _ , _} P≈Q

    test4-worksR : {P : ExtProp} → Reg P → Set
    test4-worksR {P} P≈Q = foo {x = _ , π₁ P} P≈Q

    test1-worksC : {P : ExtProp} → Con P → Set
    test1-worksC P≈Q = foo P≈Q

    test2-worksC : {P : ExtProp} → Con P → Set
    test2-worksC {P} P≈Q = foo {x = P} P≈Q

    test3-worksC : {P : ExtProp} → Con P → Set
    test3-worksC {P} P≈Q = foo {x = _ , _} P≈Q

    test4-worksC : {P : ExtProp} → Con P → Set
    test4-worksC {P} P≈Q = foo {x = _ , π₁ P} P≈Q

  module Function where

    postulate fooR : {x : ExtProp} → Reg x → Set
    postulate fooC : {x : ExtProp} → Con x → Set

    test1-failsR : {P : ExtProp} → Reg P → Set
    test1-failsR P≈Q = fooR P≈Q

    test2-worksR : {P : ExtProp} → Reg P → Set
    test2-worksR {P} P≈Q = fooR {x = P} P≈Q

    test3-failsR : {P : ExtProp} → Reg P → Set
    test3-failsR {P} P≈Q = fooR {x = _ , _} P≈Q

    test4-worksR : {P : ExtProp} → Reg P → Set
    test4-worksR {P} P≈Q = fooR {x = _ , π₁ P} P≈Q

    test1-worksC : {P : ExtProp} → Con P → Set
    test1-worksC P≈Q = fooC P≈Q

    test2-worksC : {P : ExtProp} → Con P → Set
    test2-worksC {P} P≈Q = fooC {x = P} P≈Q

    test3-worksC : {P : ExtProp} → Con P → Set
    test3-worksC {P} P≈Q = fooC {x = _ , _} P≈Q

    test4-worksC : {P : ExtProp} → Con P → Set
    test4-worksC {P} P≈Q = fooC {x = _ , π₁ P} P≈Q

record ProjectedMorality : Set where
  no-eta-equality

  infixr 5 _,_
  record Σ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) : Set₁ where
    constructor _,_
    field
      π₀ : 𝔒
      π₁ : Set

  open Σ

  postulate Prop : Set₁
  postulate Ext : Prop → Set
  postulate PropEq : Prop → Set

  Reg : Σ Prop Ext → Set
  Reg P = PropEq (π₀ P)

  postulate bar : ∀ {𝔒 : Set₁} → 𝔒 → 𝔒
  postulate qux : ∀ {𝔒} {𝔓 : 𝔒 → Set} → Σ 𝔒 𝔓 → Σ 𝔒 𝔓
  postulate fake-π₀ : ∀ {𝔒} {𝔓 : 𝔒 → Set} → Σ 𝔒 𝔓 → 𝔒

  abstract

    abstracted-π₀ : ∀ {𝔒} {𝔓 : 𝔒 → Set} → Σ 𝔒 𝔓 → 𝔒
    abstracted-π₀ x = π₀ x

  Reg-using-abstracted-projection : Σ Prop Ext → Set
  Reg-using-abstracted-projection (P0 , P1) = PropEq (abstracted-π₀ {𝔒 = Prop} {𝔓 = Ext} (P0 , P1))

  Reg-using-q : Σ Prop Ext → Set
  Reg-using-q x = PropEq (π₀ (qux x))

  Reg-using-fake-π₀ : Σ Prop Ext → Set
  Reg-using-fake-π₀ x = PropEq (fake-π₀ x)

  record Con (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg P

  record Con-using-abstracted-projection (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg-using-abstracted-projection P

  record Con-using-q (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg-using-q P

  record Con-using-fake-π₀ (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg-using-fake-π₀ P

  record Class {B : Set₁} (F : B → Set) : Set₁ where
    field foo : ∀ {x} → F x → Set
  open Class ⦃ … ⦄

  postulate instance _ : Class Reg
  postulate instance _ : Class Reg-using-abstracted-projection
  postulate instance _ : Class Reg-using-q
  postulate instance _ : Class Reg-using-fake-π₀
  postulate instance _ : Class Con
  postulate instance _ : Class Con-using-abstracted-projection
  postulate instance _ : Class Con-using-q
  postulate instance _ : Class Con-using-fake-π₀

  test1-failsR : ∀ {P} → Reg P → Set
  test1-failsR = foo

  test1-failsRap : ∀ {P} → Reg-using-abstracted-projection P → Set
  test1-failsRap = foo

  test1-failsRq : ∀ {P} → Reg-using-q P → Set
  test1-failsRq = foo

  test1-failsRf : ∀ {P} → Reg-using-fake-π₀ P → Set
  test1-failsRf = foo

  test1-worksC : ∀ {P} → Con P → Set
  test1-worksC = foo

  test1-worksCap : ∀ {P} → Con-using-abstracted-projection P → Set
  test1-worksCap = foo

  test1-worksCq : ∀ {P} → Con-using-q P → Set
  test1-worksCq = foo

  test1-worksCf : ∀ {P} → Con-using-fake-π₀ P → Set
  test1-worksCf = foo

record DataMorality : Set where
  no-eta-equality

  module _ (𝔒 : Set₁) (𝔓 : 𝔒 → Set) where

    data Σ : Set₁ where
      _,_ : 𝔒 → Set → Σ

  module _ {𝔒 : Set₁} {𝔓 : 𝔒 → Set} where

    dπ₀ : Σ _ 𝔓 → 𝔒
    dπ₀ (x , _) = x

    dπ₁ : Σ _ 𝔓 → Set
    dπ₁ (_ , y) = y

  postulate Prop : Set₁
  postulate Ext : Prop → Set
  postulate PropEq : Prop → Set

  Reg : Σ Prop Ext → Set
  Reg P = PropEq (dπ₀ P)

  postulate bar : ∀ {𝔒 : Set₁} → 𝔒 → 𝔒
  postulate qux : ∀ {𝔒} {𝔓 : 𝔒 → Set} → Σ 𝔒 𝔓 → Σ 𝔒 𝔓
  postulate fake-π₀ : ∀ {𝔒} {𝔓 : 𝔒 → Set} → Σ 𝔒 𝔓 → 𝔒

  abstract

    abstracted-π₀ : ∀ {𝔒} {𝔓 : 𝔒 → Set} → Σ 𝔒 𝔓 → 𝔒
    abstracted-π₀ x = dπ₀ x

  Reg-using-abstracted-projection : Σ Prop Ext → Set
  Reg-using-abstracted-projection (P0 , P1) = PropEq (abstracted-π₀ {𝔒 = Prop} {𝔓 = Ext} (P0 , P1))

  Reg-using-q : Σ Prop Ext → Set
  Reg-using-q x = PropEq (dπ₀ (qux x))

  Reg-using-fake-π₀ : Σ Prop Ext → Set
  Reg-using-fake-π₀ x = PropEq (fake-π₀ x)

  record Con (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg P

  record Con-using-abstracted-projection (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg-using-abstracted-projection P

  record Con-using-q (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg-using-q P

  record Con-using-fake-π₀ (P : Σ Prop Ext) : Set where
    constructor ∁
    field
      π₀ : Reg-using-fake-π₀ P

  record Class {B : Set₁} (F : B → Set) : Set₁ where
    field foo : ∀ {x} → F x → Set
  open Class ⦃ … ⦄

  postulate instance _ : Class Reg
  postulate instance _ : Class Reg-using-abstracted-projection
  postulate instance _ : Class Reg-using-q
  postulate instance _ : Class Reg-using-fake-π₀
  postulate instance _ : Class Con
  postulate instance _ : Class Con-using-abstracted-projection
  postulate instance _ : Class Con-using-q
  postulate instance _ : Class Con-using-fake-π₀

  test1-failsR : ∀ {P} → Reg P → Set
  test1-failsR = foo

  test1-failsRap : ∀ {P} → Reg-using-abstracted-projection P → Set
  test1-failsRap = foo -- woah, it actually works. why?

  test1-failsRq : ∀ {P} → Reg-using-q P → Set
  test1-failsRq = foo -- NB this doesn't fail if instance of Class Reg is excluded

  test1-failsRf : ∀ {P} → Reg-using-fake-π₀ P → Set
  test1-failsRf = foo -- NB this doesn't fail if instance of Class Reg is excluded

  test1-worksC : ∀ {P} → Con P → Set
  test1-worksC = foo

  test1-worksCap : ∀ {P} → Con-using-abstracted-projection P → Set
  test1-worksCap = foo

  test1-worksCq : ∀ {P} → Con-using-q P → Set
  test1-worksCq = foo

  test1-worksCf : ∀ {P} → Con-using-fake-π₀ P → Set
  test1-worksCf = foo

module RevampedSimpleFailure where

  record ExtensionProperty (𝔒 : Set) : Set₁ where
    field
      π₀ : Property 𝔒
      π₁ : Extension π₀

  open ExtensionProperty

  _≈_ : {𝔒 : Set} → ExtensionProperty 𝔒 → ExtensionProperty 𝔒 → Set
  _≈_ P Q = PropertyEquivalence (π₀ P) (π₀ Q)

  postulate symmetry : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈ y → y ≈ x
  -- normalises to   : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → PropertyEquivalence (π₀ x) (π₀ y) → PropertyEquivalence (π₀ y) (π₀ x)

  test-fails : {𝔒 : Set} {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
  test-fails P≈Q = symmetry P≈Q

module PostulatedExtensionPropertySimpleSuccess where

  postulate
    ExtensionProperty : Set → Set₁
    π₀ : {𝔒 : Set} → ExtensionProperty 𝔒 → Property 𝔒

  _≈_ : {𝔒 : Set} → ExtensionProperty 𝔒 → ExtensionProperty 𝔒 → Set
  _≈_ P Q = PropertyEquivalence (π₀ P) (π₀ Q)

  postulate symmetry : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → x ≈ y → y ≈ x
  -- normalises to   : ∀ {𝔒} {x y : ExtensionProperty 𝔒} → PropertyEquivalence (π₀ {𝔒} x) (π₀ {𝔒} y) → PropertyEquivalence (π₀ {𝔒} y) (π₀ {𝔒} x)

  test-works : {𝔒 : Set} {P Q : ExtensionProperty 𝔒} → P ≈ Q → Q ≈ P
  test-works P≈Q = symmetry P≈Q

module RevampedVerySimpleFailure where

  -- was PropertyEquivalence : ∀ {P : Set} → Property P → Property P → Set
  postulate _∼_ : Set → Set → Set

  record ExtensionProperty : Set₁ where
    field
      π₀ : Set -- was Property 𝔒
      π₁ : Set -- was Extension π₀

  open ExtensionProperty

  postulate symmetry : ∀ {x y : ExtensionProperty} → π₀ x ∼ π₀ y → π₀ y ∼ π₀ x

  postulate x y : ExtensionProperty

  test-fails : π₀ x ∼ π₀ y → π₀ y ∼ π₀ x
  test-fails = symmetry

module PostulatedExtensionPropertyVerySimpleSuccess where

  postulate _∼_ : Set → Set → Set

  postulate
    ExtensionProperty : Set₁
    π₀ : ExtensionProperty → Set

  postulate symmetry : ∀ {x y : ExtensionProperty} → π₀ x ∼ π₀ y → π₀ y ∼ π₀ x

  postulate x y : ExtensionProperty

  test-works : π₀ x ∼ π₀ y → π₀ y ∼ π₀ x
  test-works P≈Q = symmetry P≈Q

module RevampedEvenSimplerFailure where

  -- was _∼_, which was PropertyEquivalence
  postulate F : Set → Set

  record ExtensionProperty : Set₁ where
    field
      π₀ : Set
      π₁ : Set

  open ExtensionProperty

  postulate symmetry : ∀ {x : ExtensionProperty} → F (π₀ x) → Set

  postulate x : ExtensionProperty
  postulate Fpx : F (π₀ x)

  test-fails1 : Set
  test-fails1 = symmetry Fpx

  test-fails2 : Set
  test-fails2 = symmetry {x = record { π₀ = π₀ x ; π₁ = _}} Fpx

  test-works-arbitrarily : Set
  test-works-arbitrarily = symmetry {x = record { π₀ = π₀ x ; π₁ = F (F (π₁ x)) }} Fpx

module PostulatedExtensionPropertyEvenSimplerSuccess where

  postulate F : Set → Set

  postulate
    ExtensionProperty : Set₁
    π₀ : ExtensionProperty → Set

  postulate symmetry : ∀ {x : ExtensionProperty} → F (π₀ x) → Set

  postulate x : ExtensionProperty
  postulate Fpx : F (π₀ x)

  test-works1 : Set
  test-works1 = symmetry Fpx

  test-works2 : Set
  test-works2 = symmetry {x = x} Fpx

module RevampedEvenSimplerFailureClassified where

  postulate F : Set → Set

  record ExtensionProperty : Set₁ where
    field
      π₀ : Set
      π₁ : Set

  open ExtensionProperty

  record Symmetry' (R : Set → Set) : Set₁ where
    field symmetry : ∀ {x : ExtensionProperty} → R (π₀ x) → Set
  open Symmetry' ⦃ … ⦄

  postulate instance _ : Symmetry' F

  postulate x : ExtensionProperty
  postulate Fpx : F (π₀ x)

  test-fails1 : Set
  test-fails1 = symmetry Fpx

  test-fails2 : Set
  test-fails2 = symmetry {x = record { π₀ = π₀ x ; π₁ = _}} Fpx

  test-works-arbitrarily : Set
  test-works-arbitrarily = symmetry {x = record { π₀ = π₀ x ; π₁ = F (F (π₁ x)) }} Fpx

module PostulatedExtensionPropertyEvenSimplerSuccessClassified where

  postulate F : Set → Set

  postulate
    ExtensionProperty : Set₁
    π₀ : ExtensionProperty → Set

  record Symmetry' (R : Set → Set) : Set₁ where
    field symmetry : ∀ {x : ExtensionProperty} → R (π₀ x) → Set
  open Symmetry' ⦃ … ⦄

  postulate instance _ : Symmetry' F

  postulate x : ExtensionProperty
  postulate Fpx : F (π₀ x)

  test-works1 : Set
  test-works1 = symmetry Fpx

  test-works2 : Set
  test-works2 = symmetry {x = x} Fpx

module RevampedVsPostulated where

  record R : Set₁ where
    field
      f1 : Set
      f2 : Set

  open R

  postulate fooR : ∀ {x : R} → f1 x → Set

  postulate r : R
  postulate f1r : f1 r

  test-fails1 : Set
  test-fails1 = fooR f1r

  postulate
    S : Set₁
    g1 : S → Set

  postulate fooS : ∀ {x : S} → g1 x → Set

  postulate s : S
  postulate g1s : g1 s

  test-works1 : Set
  test-works1 = fooS g1s


{-# OPTIONS --without-K #-}
module container.m.from-nat.bisimulation where

open import level
open import sum
open import equality
open import function
open import container.core
open import container.m.coalgebra as MC hiding (IsMor ; _⇒_)
open import container.m.from-nat.coalgebra hiding (X)
open import hott.level

module Def {la lb lc} {C : Container la lb lc} (𝓧 : Coalg C (lb ⊔ lc)) where

  open Container C
  open Σ 𝓧 renaming (proj₁ to X ; proj₂ to γ)
  open MC C using (IsMor ; _⇒_)

  -- Σ-closure of an indexed binary relation
  Σ₂[_] : (∀ {i} → X i → X i → Set (lb ⊔ lc)) → I → Set _
  Σ₂[ _∼_ ] i = Σ (X i) λ x → Σ (X i) λ x′ → x ∼ x′

  -- projections
  module _ {_∼_ : ∀ {i} → X i → X i → Set _} (i : I) where

    Σ₂-proj₁ : Σ₂[ _∼_ ] i → X i
    Σ₂-proj₁ = proj₁

    Σ₂-proj₂ : Σ₂[ _∼_ ] i → X i
    Σ₂-proj₂ = proj₁ ∘' proj₂

    Σ₂-proj₃ : (r : Σ₂[ _∼_ ] i) → _∼_ (Σ₂-proj₁ r) (Σ₂-proj₂ r)
    Σ₂-proj₃ = proj₂ ∘' proj₂

  -- Definition 16 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
  -- bisimulation definition
  record Bisim (_∼_ : ∀ {i} → X i → X i → Set _): Set(lb ⊔ lc ⊔ lsuc la) where
    field
      α : Σ₂[ _∼_ ] →ⁱ F Σ₂[ _∼_ ]
      π₁-Mor : IsMor (_ , α) 𝓧 Σ₂-proj₁
      π₂-Mor : IsMor (_ , α) 𝓧 Σ₂-proj₂

    𝓑 : Coalg C _
    𝓑 = _ , α

    π₁ : 𝓑 ⇒ 𝓧
    π₁ = _ , π₁-Mor

    π₂ : 𝓑 ⇒ 𝓧
    π₂ = _ , π₂-Mor

  -- Lemma 17 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
  Δ : Bisim (λ {i} → _≡_)
  Δ = record { α = α ; π₁-Mor = π₁-Mor ; π₂-Mor = π₂-Mor }
    where α : Σ₂[ _≡_ ] →ⁱ F Σ₂[ _≡_ ]
          α i (x , ._ , refl) = proj₁ (γ _ x)
                                  , λ b → (proj₂ (γ _ x) b) , (_ , refl)
          π₁-Mor : IsMor (_ , α) 𝓧 _
          π₁-Mor = funextⁱ helper
            where helper : (i : I) → (p : Σ₂[ _≡_ ] i) → _
                  helper i (m , ._ , refl) = refl
          π₂-Mor : IsMor (_ , α) 𝓧 _
          π₂-Mor = funextⁱ helper
            where helper : (i : I) → (p : Σ₂[ _≡_ ] i) → _
                  helper i (m , ._ , refl) = refl

--------------------------------------------------------------------------------
-- coinduction proof principle

module _ {la lb lc} {C : Container la lb lc} where

  open Container C
  open MC C using (IsMor ; _⇒_)

  private
    𝓜 : Coalg C (lb ⊔ lc)
    𝓜 = 𝓛 C
    unfold : ∀ (𝓧 : Coalg C (lb ⊔ lc)) → 𝓧 ⇒ 𝓜
    unfold 𝓧 = proj₁ $ lim-terminal C 𝓧
    unfold-universal = λ {ℓ} (𝓧 : Coalg C ℓ) → proj₂ (lim-terminal C 𝓧)

  open Σ 𝓜 renaming (proj₁ to M ; proj₂ to out) ; open Def 𝓜

  module _ {_∼_ : ∀ {i} → M i → M i → Set (lb ⊔ lc)} (B : Bisim _∼_) where

    -- Theorem 18 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
    -- coinduction proof principle
    cpp : ∀ {i} {m m′ : M i} → m ∼ m′ → m ≡ m′
    cpp {i} p = funext-invⁱ (proj₁ $ apΣ π₁=π₂) i (_ , _ , p)
      where open Bisim B
            abstract
              π₁=π₂ : π₁ ≡ π₂
              π₁=π₂ = (sym $ unfold-universal 𝓑 π₁) · unfold-universal 𝓑 π₂

    -- In particular, provided that the bisimulation _∼_ is reflexive, we have:
    module _ (∼-refl : ∀ {i} {m : M i} → m ∼ m) where

      cpp′ : ∀ {i} {m m′ : M i} → m ∼ m′ → m ≡ m′
      cpp′ {i} p = cpp p · sym (cpp ∼-refl)

      cpp′-inv : ∀ {i} {m m′ : M i} → m ≡ m′ → m ∼ m′
      cpp′-inv refl = ∼-refl

      cpp′-id : ∀ {i} {m : M i} → cpp′ ∼-refl ≡ refl {x = m}
      cpp′-id = left-inverse $ cpp ∼-refl

      cpp′-retraction : ∀ {i} {m m′ : M i} (p : m ≡ m′) → cpp′ (cpp′-inv p) ≡ p
      cpp′-retraction refl = left-inverse $ cpp ∼-refl


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Truncation.Properties where

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.PathSplitEquiv
open isPathSplitEquiv
open import Cubical.Modalities.Everything
open Modality

open import Cubical.Data.Empty as ⊥ using (⊥)
open import Cubical.Data.Nat hiding (elim)
open import Cubical.Data.NatMinusOne as ℕ₋₁ hiding (1+_)
open import Cubical.Data.NatMinusTwo as ℕ₋₂ hiding (-1+_)
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.Nullification as Null hiding (rec; elim)

open import Cubical.HITs.Truncation.Base

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 ℓ

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

isSphereFilledTrunc : {n : ℕ} → isSphereFilled (-1+ n) (hLevelTrunc n A)
isSphereFilledTrunc {n = zero}  f = hub f , ⊥.elim
isSphereFilledTrunc {n = suc n} f = hub f , spoke f

isSphereFilled→isOfHLevelSuc : {n : ℕ} → isSphereFilled (ℕ→ℕ₋₁ n) A → isOfHLevel (suc n) A
isSphereFilled→isOfHLevelSuc {A = A} {zero} h x y = sym (snd (h f) north) ∙ snd (h f) south
  where
    f : Susp ⊥ → A
    f north = x
    f south = y
    f (merid () i)
isSphereFilled→isOfHLevelSuc {A = A} {suc n} h x y = isSphereFilled→isOfHLevelSuc (helper h x y)
  where
    helper : isSphereFilled (ℕ→ℕ₋₁ (suc n)) A → (x y : A) → isSphereFilled (ℕ→ℕ₋₁ n) (x ≡ y)
    helper h x y f = l , r
      where
        f' : Susp (S (ℕ→ℕ₋₁ n)) → A
        f' north = x
        f' south = y
        f' (merid u i) = f u i

        u : sphereFill (ℕ→ℕ₋₁ (suc n)) f'
        u = h f'

        z : A
        z = fst u

        p : z ≡ x
        p = snd u north

        q : z ≡ y
        q = snd u south

        l : x ≡ y
        l = sym p ∙ q

        r : (s : S (ℕ→ℕ₋₁ n)) → l ≡ f s
        r s i j = hcomp
                    (λ k →
                       λ { (i = i0) → compPath-filler (sym p) q k j
                         ; (i = i1) → snd u (merid s j) k
                         ; (j = i0) → p (k ∨ (~ i))
                         ; (j = i1) → q k
                         })
                  (p ((~ i) ∧ (~ j)))

isOfHLevel→isSphereFilled : {n : ℕ} → isOfHLevel n A → isSphereFilled (-1+ n) A
isOfHLevel→isSphereFilled {A = A} {zero} h f = fst h , λ _ → snd h _
isOfHLevel→isSphereFilled {A = A} {suc zero} h f = f north , λ _ → h _ _
isOfHLevel→isSphereFilled {A = A} {suc (suc n)} h = helper λ x y → isOfHLevel→isSphereFilled (h x y)
  where
    helper : {n : ℕ} → ((x y : A) → isSphereFilled (-1+ n) (x ≡ y)) → isSphereFilled (suc₋₁ (-1+ n)) A
    helper {n = n} h f = l , r
      where
      l : A
      l = f north

      f' : S (-1+ n) → f north ≡ f south
      f' x i = f (merid x i)

      h' : sphereFill (-1+ n) f'
      h' = h (f north) (f south) f'

      r : (x : S (suc₋₁ (-1+ n))) → l ≡ f x
      r north = refl
      r south = h' .fst
      r (merid x i) j = hcomp (λ k → λ { (i = i0) → f north
                                        ; (i = i1) → h' .snd x (~ k) j
                                        ; (j = i0) → f north
                                        ; (j = i1) → f (merid x i) }) (f (merid x (i ∧ j)))

-- isNull (S n) A ≃ (isSphereFilled n A) × (∀ (x y : A) → isSphereFilled n (x ≡ y))

isOfHLevel→isSnNull : {n : ℕ} → isOfHLevel n A → isNull (S (-1+ n)) A
fst (sec (isOfHLevel→isSnNull h)) f     = fst (isOfHLevel→isSphereFilled h f)
snd (sec (isOfHLevel→isSnNull h)) f i s = snd (isOfHLevel→isSphereFilled h f) s i
fst (secCong (isOfHLevel→isSnNull h) x y) p = fst (isOfHLevel→isSphereFilled (isOfHLevelPath _ h x y) (funExt⁻ p))
snd (secCong (isOfHLevel→isSnNull h) x y) p i j s = snd (isOfHLevel→isSphereFilled (isOfHLevelPath _ h x y) (funExt⁻ p)) s i j

isSnNull→isOfHLevel : {n : ℕ} → isNull (S (-1+ n)) A → isOfHLevel n A
isSnNull→isOfHLevel {n = zero}  nA = fst (sec nA) ⊥.rec , λ y → fst (secCong nA _ y) (funExt ⊥.elim)
isSnNull→isOfHLevel {n = suc n} nA = isSphereFilled→isOfHLevelSuc (λ f → fst (sec nA) f , λ s i → snd (sec nA) f i s)

isOfHLevelTrunc : (n : ℕ) → isOfHLevel n (hLevelTrunc n A)
isOfHLevelTrunc zero    = hub ⊥.rec , λ _ → ≡hub ⊥.rec
isOfHLevelTrunc (suc n) = isSphereFilled→isOfHLevelSuc isSphereFilledTrunc
-- isOfHLevelTrunc n = isSnNull→isOfHLevel isNull-Null

-- hLevelTrunc n is a modality

rec : {n : ℕ}
      {B : Type ℓ'} →
      (isOfHLevel n B) →
      (g : (a : A) → B) →
      (hLevelTrunc n A → B)
rec {B = B} h = Null.elim {B = λ _ → B} λ x → isOfHLevel→isSnNull h

elim : {n : ℕ}
  {B : hLevelTrunc n A → Type ℓ'}
  (hB : (x : hLevelTrunc n A) → isOfHLevel n (B x))
  (g : (a : A) → B (∣ a ∣))
  (x : hLevelTrunc n A) →
  B x
elim hB = Null.elim (λ x → isOfHLevel→isSnNull (hB x))

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

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

HLevelTruncModality : ∀ {ℓ} (n : ℕ) → Modality ℓ
isModal       (HLevelTruncModality n) = isOfHLevel n
isModalIsProp (HLevelTruncModality n) = isPropIsOfHLevel n
◯             (HLevelTruncModality n) = hLevelTrunc n
◯-isModal     (HLevelTruncModality n) = isOfHLevelTrunc n
η             (HLevelTruncModality n) = ∣_∣
◯-elim        (HLevelTruncModality n) = elim
◯-elim-β      (HLevelTruncModality n) = λ _ _ _ → refl
◯-=-isModal   (HLevelTruncModality n) = isOfHLevelPath n (isOfHLevelTrunc n)

idemTrunc : (n : ℕ) → isOfHLevel n A → A ≃ (hLevelTrunc n A)
idemTrunc n hA = ∣_∣ , isModalToIsEquiv (HLevelTruncModality n) hA

-- equivalences to prop/set/groupoid truncations

propTrunc≃Trunc-1 : ∥ A ∥₋₁ ≃ ∥ A ∥ -1
propTrunc≃Trunc-1 =
  isoToEquiv
    (iso
      (PropTrunc.elim (λ _ → isOfHLevelTrunc 1) ∣_∣)
      (elim (λ _ → squash₋₁) ∣_∣₋₁)
      (elim (λ _ → isOfHLevelPath 1 (isOfHLevelTrunc 1) _ _) (λ _ → refl))
      (PropTrunc.elim (λ _ → isOfHLevelPath 1 squash₋₁ _ _) (λ _ → refl)))

setTrunc≃Trunc0 : ∥ A ∥₀ ≃ ∥ A ∥ 0
setTrunc≃Trunc0 =
  isoToEquiv
    (iso
      (SetTrunc.elim (λ _ → isOfHLevelTrunc 2) ∣_∣)
      (elim (λ _ → squash₀) ∣_∣₀)
      (elim (λ _ → isOfHLevelPath 2 (isOfHLevelTrunc 2) _ _) (λ _ → refl))
      (SetTrunc.elim (λ _ → isOfHLevelPath 2 squash₀ _ _) (λ _ → refl)))

groupoidTrunc≃Trunc1 : ∥ A ∥₁ ≃ ∥ A ∥ 1
groupoidTrunc≃Trunc1 =
  isoToEquiv
    (iso
      (GpdTrunc.elim (λ _ → isOfHLevelTrunc 3) ∣_∣)
      (elim (λ _ → squash₁) ∣_∣₁)
      (elim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) (λ _ → refl))
      (GpdTrunc.elim (λ _ → isOfHLevelPath 3 squash₁ _ _) (λ _ → refl)))

2GroupoidTrunc≃Trunc2 : ∥ A ∥₂ ≃ ∥ A ∥ 2
2GroupoidTrunc≃Trunc2 =
  isoToEquiv
    (iso
      (2GpdTrunc.elim (λ _ → isOfHLevelTrunc 4) ∣_∣)
      (elim (λ _ → squash₂) ∣_∣₂)
      (elim (λ _ → isOfHLevelPath 4 (isOfHLevelTrunc 4) _ _) (λ _ → refl))
      (2GpdTrunc.elim (λ _ → isOfHLevelPath 4 squash₂ _ _) (λ _ → refl)))

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

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

private
  {- We define the fibration P to show a more general result  -}
  P :  ∀ {ℓ} {B : Type ℓ}{n : ℕ₋₂} → ∥ B ∥  (suc₋₂ n) → ∥ B ∥  (suc₋₂ n) → Type ℓ
  P x y = fst (P₁ x y)
    where
    P₁ : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂} → ∥ B ∥  (suc₋₂ n) → ∥ B ∥  (suc₋₂ n) → (HLevel  ℓ (2+ n))
    P₁ {ℓ} {n = n}  x y =
      elim2 (λ _ _  → isOfHLevelHLevel (2+ n)) (λ a b → ∥ a ≡ b ∥  n , isOfHLevelTrunc (2+ n)) x y

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

  {- decode function from P x y to x ≡ y -}
  decode-fun :  ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂} (x y : ∥ B ∥ (suc₋₂ n)) → P x y → x ≡ y
  decode-fun {B = B} {n = n} =
    elim2
      (λ u v → isOfHLevelPi
        (2+ suc₋₂ n)
        (λ _ → isOfHLevelSuc (2+ suc₋₂ n) (isOfHLevelTrunc (2+ suc₋₂ n)) u v))
      decode*
      where
      decode* :  ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂}(u v : B)
        → (P {n = n} ∣ u ∣ ∣ v ∣) → _≡_ {A = ∥ B ∥ (suc₋₂ n)} ∣ u ∣ ∣ v ∣
      decode* {B = B} {n = neg2} u v =
        rec
          ( isOfHLevelTrunc (suc zero) ∣ u ∣ ∣ v ∣
          , λ _ →
            isOfHLevelSuc (suc zero) (isOfHLevelTrunc (suc zero)) _ _ _ _
          )
          (λ p → cong (λ z → ∣ z ∣) p)
      decode* {n = ℕ₋₂.-1+ n} u v =
        rec (isOfHLevelTrunc (suc (suc n)) ∣ u ∣ ∣ v ∣) (λ p → cong (λ z → ∣ z ∣) p)

  {- auxilliary function r used to define encode -}
  r :  ∀ {ℓ} {B : Type ℓ} {m : ℕ₋₂} (u : ∥ B ∥ (suc₋₂ m)) → P u u
  r {m = m}  = elim (λ x → hLevelP x x) (λ a → ∣ refl ∣)

  {- encode function from x ≡ y to P x y -}
  encode-fun : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂} (x y : ∥ B ∥ (suc₋₂ n)) → x ≡ y → P x y
  encode-fun x y p = transport (λ i → P x (p i)) (r x)

  {- We need the following two lemmas on the functions behaviour for refl -}
  dec-refl : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂}
    (x : ∥ B ∥ (suc₋₂ n)) → decode-fun x x (r x) ≡ refl {x = x}
  dec-refl {B = B} {n = neg2} =
    elim
      (λ x →
        isOfHLevelSuc (suc zero)
          (isOfHLevelSuc (suc zero) (isOfHLevelTrunc (suc zero)) x x)
          _ _)
      (λ a → refl)
  dec-refl {n = ℕ₋₂.-1+ n} =
    elim
      (λ x →
        isOfHLevelSuc (suc n)
         (isOfHLevelSuc (suc n)
            (isOfHLevelTrunc (suc (suc n)) x x)
            (decode-fun x x (r x)) refl))
      (λ c → refl)

  enc-refl : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂}
    (x : ∥ B ∥ (suc₋₂ n)) → encode-fun x x refl ≡ r x
  enc-refl x j = transp (λ i → P x (refl {x = x} i)) j (r x)

  {- decode-fun is a right-inverse -}
  P-rinv : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂} (u v : ∥ B ∥  (suc₋₂ n)) →
    (x : _≡_ {A = ∥ B ∥ (suc₋₂ n)} u v) → decode-fun u v (encode-fun u v x) ≡ x
  P-rinv {ℓ = ℓ} {B = B} {n = n} u v =
    J (λ y p → decode-fun u y (encode-fun u y p) ≡ p)
      ((λ i → (decode-fun u u (enc-refl u i))) ∙ dec-refl u)

  {- decode-fun is a left-inverse -}
  P-linv : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂} (u v : ∥ B ∥ (suc₋₂ n )) →
    (x : P u v) → encode-fun u v (decode-fun u v x) ≡ x
  P-linv {n = n} =
    elim2
      (λ x y → isOfHLevelPi (2+ suc₋₂ n)
        (λ z → isOfHLevelSuc (2+ suc₋₂ n) (hLevelP x y) _ _))
      helper
    where
    helper : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂} (a b : B) (x : P {n = n} ∣ a ∣ ∣ b ∣)
      → encode-fun ∣ a ∣ ∣ b ∣ (decode-fun ∣ a ∣ ∣ b ∣ x) ≡ x
    helper {n = neg2} a b =
      elim
        (λ x →
          ( sym (isOfHLevelTrunc zero .snd (encode-fun ∣ a ∣ ∣ b ∣ (decode-fun ∣ a ∣ ∣ b ∣ x)))
            ∙ (isOfHLevelTrunc zero .snd x)
          , λ y →
            isOfHLevelSuc (suc zero)
              (isOfHLevelSuc zero (isOfHLevelTrunc {A = a ≡ b} zero))
              _ _ _ _
          ))
        (J
          (λ y p → encode-fun ∣ a ∣ ∣ y ∣ ((decode-fun ∣ a ∣ ∣ y ∣) ∣ p ∣) ≡ ∣ p ∣)
          (enc-refl ∣ a ∣))
    helper {n = ℕ₋₂.-1+ n} a b =
      elim
        (λ x → hLevelP {n = ℕ₋₂.-1+ n} ∣ a ∣ ∣ b ∣ _ _)
        (J (λ y p → encode-fun {n = ℕ₋₂.-1+ n} ∣ a ∣ ∣ y ∣ ((decode-fun ∣ a ∣ ∣ y ∣) ∣ p ∣) ≡ ∣ p ∣)
           (enc-refl ∣ a ∣))

  {- The final Iso established -}
  IsoFinal : ∀ {ℓ} {B : Type ℓ} {n : ℕ₋₂} (x y : ∥ B ∥ (suc₋₂ n)) → Iso (x ≡ y) (P x y)
  IsoFinal x y = iso (encode-fun x y ) (decode-fun x y) (P-linv x y) (P-rinv x y)

PathIdTrunc : {a b : A} (n : ℕ₋₂) → (_≡_ {A = ∥ A ∥ (suc₋₂ n)} ∣ a ∣ ∣ b ∣) ≡ (∥ a ≡ b ∥ n)
PathIdTrunc {a = a} {b = b} n = isoToPath (IsoFinal {n = n} ∣ a ∣ ∣ b ∣)

PathΩ : {a : A} (n : ℕ₋₂) → (_≡_ {A = ∥ A ∥ (suc₋₂ n)} ∣ a ∣ ∣ a ∣) ≡ (∥ a ≡ a ∥ n)
PathΩ {a = a} n = PathIdTrunc {a = a} {b = a} n