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

module Number.Consequences 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 (inr to inrᵖ; inl to inlᵖ)
open import Function.Base using (it; _∋_; _$_)

open import Utils
open import MoreLogic.Definitions
open import MoreLogic.Properties
open import MorePropAlgebra.Definitions
open import MorePropAlgebra.Consequences
open import MorePropAlgebra.Structures
open import MorePropAlgebra.Bundles
open import Number.Definitions

-- import Cubical.HITs.Rationals.SigmaQ as ℚ*
-- import Cubical.Data.Nat.Coprime as Coprime
open import Cubical.HITs.Rationals.QuoQ renaming
  ( [_] to [_]ᶠ
  ; [_/_] to [_/_]ᶠ
  ; _+_ to _+ᶠ_
  ; -_  to -ᶠ_
  ; _*_ to _*ᶠ_
  ; +-assoc to +-assocᶠ
  ; +-comm  to +-commᶠ
  ; *-assoc to *-assocᶠ
  ; *-comm  to *-commᶠ
  )
-- open import Cubical.Data.Nat.Literals public
--
-- instance
--   fromNatℚ : HasFromNat ℚ
--   fromNatℚ = record { Constraint = λ _ → Unit ; fromNat = λ n → [ pos n / 1 ] }
--
-- instance
--   fromNegℚ : HasFromNeg ℚ
--   fromNegℚ = record { Constraint = λ _ → Unit ; fromNeg = λ n → [ neg n / 1 ] }

open import Cubical.HITs.SetQuotients renaming ([_] to [_]ˢ)

-- Define the integers as a HIT by identifying +0 and -0
import Cubical.HITs.Ints.QuoInt
import Cubical.Data.NatPlusOne

open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥) -- `⊥` and `elim`
open import Cubical.HITs.PropositionalTruncation.Base -- ∣_∣
import Cubical.HITs.PropositionalTruncation.Properties as PTrunc

-- -- Set quotients as a higher inductive type:
-- data _/_ {ℓ ℓ'} (A : Type ℓ) (R : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
--   [_] : (a : A) → A / R
--   eq/ : (a b : A) → (r : R a b) → [ a ] ≡ [ b ]
--   squash/ : (x y : A / R) → (p q : x ≡ y) → p ≡ q

-- {-# DISPLAY [_]' (Cubical.HITs.Ints.QuoInt.signed Agda.Builtin.Bool.Bool.false 1 / Cubical.Data.NatPlusOne.1+ 0 )= 1ᶠ #-}

{-

we have most properties in `Cubical.HITs.Rationals.QuoQ.Properties`

but we can use `Quoℚ≡Sigmaℚ : Quo.ℚ ≡ Sigma.ℚ` from `Cubical.HITs.Rationals.SigmaQ.Properties`

-}

open import Cubical.Data.NatPlusOne
open import Cubical.Data.Sigma
open import Cubical.HITs.Ints.QuoInt hiding (+-identityʳ; *-identityʳ; *-identityˡ; *-distribˡ;*-distribʳ) -- using (ℤ)
  renaming (_*_ to _*ᶻ_)
-- there is `elimProp` in `Cubical.HITs.SetQuotients` to define properties

-- elimProp {A = ℤ × ℕ₊₁} {R = _∼_} {B = λ(x : ℚ) → ?} ?

-- e.g. we have
-- _∼_ : ℤ × ℕ₊₁ → ℤ × ℕ₊₁ → Type₀
-- (a , b) ∼ (c , d) = a * ℕ₊₁→ℤ d ≡ c * ℕ₊₁→ℤ b

open import Cubical.Data.Nat as ℕ using (discreteℕ; ℕ; suc; zero) renaming (_+_ to _+ⁿ_; _*_ to _*ⁿ_)
open import Cubical.Data.Nat.Order using () renaming (_<_ to _<ⁿ_; _≤_ to _≤ⁿ_; ≤-suc to ≤ⁿ-suc)
open import Cubical.Data.Nat.Properties using (isSetℕ) renaming (snotz to snotzⁿ; +-suc to +-sucⁿ; inj-+m to inj-+mⁿ; inj-m+ to inj-m+ⁿ; +-zero to +-zeroⁿ; +-comm to +-commⁿ; +-assoc to +-assocⁿ)

_<ⁿᵖ_ : (x y : ℕ) → hProp ℓ-zero
(x <ⁿᵖ y) .fst = x <ⁿ y
(x <ⁿᵖ y) .snd (k₁ , k₁+sx≡y) (k₂ , k₂+sx≡y) = φ where
  abstract φ = Σ≡Prop (λ k → isSetℕ _ _) (inj-+mⁿ (k₁+sx≡y ∙ sym k₂+sx≡y))

isProp⊤ : isProp [ ⊤ ]
isProp⊤ tt tt = refl

private
  abstract
    lemma10 : ∀ n → (n <ⁿ 0) ≡ [ ⊥ ]
    lemma10 n = isoToPath (iso (λ{ (k , p) → snotzⁿ (sym (+-sucⁿ k n) ∙ p) }) ⊥-elim (λ b → isProp⊥ _ _) (λ a → isProp[] (n <ⁿᵖ 0) _ _))

    -- NOTE: we cannot prove `isProp lemma10` because it seems not even provable that `isProp ([ ⊥ ] ≡ [ ⊥ ])`
    -- but we can use propositional truncation
    lemma10' : ∀ n → ∥ (n <ⁿ 0) ≡ [ ⊥ ] ∥
    lemma10' n = ∣ isoToPath (iso (λ{ (k , p) → snotzⁿ (sym (+-sucⁿ k n) ∙ p) }) ⊥-elim (λ b → isProp⊥ _ _) (λ a → isProp[] (n <ⁿᵖ 0) _ _)) ∣

    lemma10'' : ∀ n → (n <ⁿᵖ 0) ≡ ⊥
    lemma10'' n = ⇔toPath (transport (lemma10 n)) (transport (sym (lemma10 n)))

  abstract
    lemma12 : ∀ n → (0 <ⁿ suc n) ≡ [ ⊤ ]
    lemma12 n = isoToPath (iso (λ _ →  tt) (λ _ → n , +-sucⁿ n 0 ∙ (λ i → suc (+-zeroⁿ n i))) (λ b → isProp⊤ _ _) (λ a → isProp[] (0 <ⁿᵖ suc n) _ _))

    lemma12'' : ∀ n → (0 <ⁿᵖ suc n) ≡ ⊤
    lemma12'' n = ⇔toPath (transport (lemma12 n)) (transport (sym (lemma12 n)))

  abstract
    helper : ∀ n → isProp (n <ⁿ 0) ≡ isProp [ ⊥ ]
    helper n = λ i → isProp (lemma10 n i)

    -- -- the following states that all propositions are equal (which is obviously not the case)
    -- isPropΣProp : ∀ {ℓ} → isProp (Σ[ X ∈ Type ℓ ] isProp X)
    -- isPropΣProp (A , isPropA) (B , isPropB) = Σ≡Prop (λ X → isPropIsProp) {! Goal: A ≡ B   !}

    -- isProp' : ∀{ℓ} {A : Type ℓ} → isProp A → A ≡ (A ≡ A)
    -- isProp' isPropA = pathToIso (iso ? ? ? ?)

    -- https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/
    -- no-unicorns :

    -- isProp-≡ : ∀{ℓ} {A : Type ℓ} → isProp A → isProp (A ≡ A)

    --
    -- isProp-≡ : ∀{ℓ} {A : Type ℓ} → isProp A → isProp (A ≡ A)
    -- -- ———— Boundary ——————————————————————————————————————————————
    -- -- i = i0 ⊢ p j
    -- -- i = i1 ⊢ q j
    -- -- j = i0 ⊢ A
    -- -- j = i1 ⊢ A
    -- --
    -- -- i j |    |
    -- -- 0 0 | pj | A
    -- -- 0 1 | pj | A
    -- -- 1 0 | qj | A
    -- -- 1 1 | qj | A
    -- -- Σ≡Prop {A = Type ℓ} {B = λ X → isProp X} (λ X → isPropIsProp) {u = (A , isPropA)} {v = (A , isPropA)}
    -- -- isProp→isSet (isPropIsProp {A = A})
    -- isProp-≡ {ℓ} {A} isPropA p q = isProp→isSet {! Goal : isProp (Type ℓ)  !} A A p q

    -- isProp-⊥≡⊥ : isProp ([ ⊥ ] ≡ [ ⊥ ])
    -- isProp-⊥≡⊥ x y = {!   !}

  -- abstract

    -- -- isProp[] (n <ⁿᵖ 0)
    -- isProp-lemma10 : ∀ n → isProp ((n <ⁿ 0) ≡ [ ⊥ ])
    -- -- ———— Boundary ——————————————————————————————————————————————
    -- -- i = i0 ⊢ p j
    -- -- i = i1 ⊢ q j
    -- -- j = i0 ⊢ n <ⁿ 0
    -- -- j = i1 ⊢ [ ⊥ ]
    -- -- (isProp[] (n <ⁿᵖ 0))
    -- isProp-lemma10 n p q =
    --   let γ : isProp ((n <ⁿ 0) ≡ (n <ⁿ 0))
    --       γ x y = {! isProp[] (n <ⁿᵖ 0) ?   !}
    --   -- transport (helper n) (isProp[] (n <ⁿᵖ 0))
    --   in {!    !}

_<ᶻ'_ : ℤ → ℤ → Type ℓ-zero
pos      n₀  <ᶻ' pos      n₁  = [ n₀ <ⁿᵖ n₁ ]
pos      n₀  <ᶻ' neg      n₁  = [ ⊥ ]
neg  zero    <ᶻ' pos  zero    = [ ⊥ ]
neg  zero    <ᶻ' pos (suc n₁) = [ ⊤ ]
neg (suc n₀) <ᶻ' pos  zero    = [ ⊤ ]
neg (suc n₀) <ᶻ' pos (suc n₁) = [ ⊤ ]
neg      n₀  <ᶻ' neg      n₁  = [ n₁ <ⁿᵖ n₀ ]
-- 1D pathes
pos      n₀  <ᶻ' posneg   j   = lemma10 n₀    j
neg  zero    <ᶻ' posneg   j   = lemma10 0  (~ j) -- [F1]
neg (suc n₀) <ᶻ' posneg   j   = lemma12 n₀ (~ j) -- [G1]
posneg   i   <ᶻ' pos  zero    = lemma10 0     i  -- [F2]
posneg   i   <ᶻ' pos (suc n₁) = lemma12 n₁    i  -- [G2]
posneg   i   <ᶻ' neg      n₁  = lemma10 n₁ (~ i)
-- 2D path
-- note, how `lemma12` does not appear in the final, 2D-case
-- this is, because we explitictly split out [F1] from [G1] and [F2] from [G2]
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ lemma10 0 j       [a]
-- i = i1 ⊢ lemma10 0 (~ j)   [b]
-- j = i0 ⊢ lemma10 0 i       [c]
-- j = i1 ⊢ lemma10 0 (~ i)   [d]
--
-- i j | a  b c  d | a b c d |
-- ----|-----------|---------|---
-- 0 0 | j    i    | 0   0   | 0
-- 0 1 | j      ~i | 1     1 | 1     ⇒ "i xor j" ≡ (i ∨ j) ∧ ~(i ∧ j)
-- 1 0 |   ~j i    |   1 1   | 1
-- 1 1 |   ~j   ~i |   0   0 | 0
posneg i <ᶻ' posneg j = lemma10 0 ((i ∨ j) ∧ ~(i ∧ j))

_<ᶻ''_ : ℤ → ℤ → hProp ℓ-zero
pos      n₀  <ᶻ'' pos      n₁  = n₀ <ⁿᵖ n₁  -- point 1: 1a    3a
pos      n₀  <ᶻ'' neg      n₁  = ⊥          -- point 2: 1b       4a
neg  zero    <ᶻ'' pos  zero    = ⊥          -- point 3:    2a 3b
neg  zero    <ᶻ'' pos (suc n₁) = ⊤          --
neg (suc n₀) <ᶻ'' pos  zero    = ⊤          --
neg (suc n₀) <ᶻ'' pos (suc n₁) = ⊤          --
neg      n₀  <ᶻ'' neg      n₁  = n₁ <ⁿᵖ n₀  -- point 4:    2b    4b
-- 1D pathes
pos      n₀  <ᶻ'' posneg   j   = lemma10'' n₀ j             -- face 1: point 1 to 2
neg  zero    <ᶻ'' posneg   j   = lemma10'' 0  (~ j) -- [F1] -- face 2: point 3 to 4
neg (suc n₀) <ᶻ'' posneg   j   = lemma12'' n₀ (~ j) -- [G1]
posneg   i   <ᶻ'' pos  zero    = lemma10'' 0     i  -- [F2] -- face 3: point 1 to 3
posneg   i   <ᶻ'' pos (suc n₁) = lemma12'' n₁    i  -- [G2]
posneg   i   <ᶻ'' neg      n₁  = lemma10'' n₁ (~ i)         -- face 4: point 2 to 4
-- 2D path
-- note, how `lemma12` does not appear in the final, 2D-case
-- this is, because we explitictly split out [F1] from [G1] and [F2] from [G2]
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ lemma10 0 j       [a]
-- i = i1 ⊢ lemma10 0 (~ j)   [b]
-- j = i0 ⊢ lemma10 0 i       [c]
-- j = i1 ⊢ lemma10 0 (~ i)   [d]
--
-- i j | a  b c  d | a b c d |
-- ----|-----------|---------|---
-- 0 0 | j    i    | 0   0   | 0
-- 0 1 | j      ~i | 1     1 | 1     ⇒ "i xor j" ≡ (i ∨ j) ∧ ~(i ∧ j)
-- 1 0 |   ~j i    |   1 1   | 1
-- 1 1 |   ~j   ~i |   0   0 | 0
posneg i <ᶻ'' posneg j = lemma10'' 0 ((i ∨ j) ∧ ~(i ∧ j)) -- square 1: face 1 to 2 to 3 to 4

_<ᶻᵖ_ : hPropRel ℤ ℤ ℓ-zero
(x <ᶻᵖ y) .fst = x <ᶻ' y
(x <ᶻᵖ y) .snd = {!   !}

_<ᶠ''_ : (ℤ × ℕ₊₁) → (ℤ × ℕ₊₁) → Type₀
(aᶻ , aⁿ⁺¹) <ᶠ'' (bᶻ , bⁿ⁺¹) = {! a * ℕ₊₁→ℤ d <ᶻ' c * ℕ₊₁→ℤ b  !}

_<ᶠ'_ : ℚ → ℚ → _
x <ᶠ' y = elimProp2 {A = ℤ × ℕ₊₁} {R = _∼_} {C = C} γ κ x y
  where
  φ : ℚ → ℚ → hProp ℓ-zero
  φ x y = {! ? , ?  !}
  C : ℚ → ℚ → Type
  C x y = [ φ x y ]
  γ : (x y : ℚ) → isProp (C x y)
  γ x y = {!   !}
  κ : (a b : ℤ × ℕ₊₁) → C [ a ]ᶠ [ b ]ᶠ
  κ a b = {!   !}

_<ᶠ_ : hPropRel ℚ ℚ ℓ-zero
x <ᶠ y = {! elimProp2 {A = ℤ × ℕ₊₁} {R = _∼_} {C = C} γ κ x y   !}
  where
  φ : ℚ → ℚ → hProp ℓ-zero
  φ x y = {!   !}
  C : ℚ → ℚ → Type
  C x y = [ φ x y ]
  γ : (x y : ℚ) → isProp (C x y)
  γ x y = {!   !}
  κ : (a b : ℤ × ℕ₊₁) → C [ a ]ᶠ [ b ]ᶠ
  κ a b = {!   !}

-- and there is `onCommonDenom` in `Cubical.HITs.Rationals.QuoQ.Properties` to define operations

-- open import Cubical.HITs.Ints.QuoInt.Base renaming

sucⁿ-creates-<ⁿᵖ : ∀ a b → [ a <ⁿᵖ b ⇔ suc a <ⁿᵖ suc b ]
sucⁿ-creates-<ⁿᵖ a b .fst (k , p) = k , (+-sucⁿ k (suc a)) ∙ (λ i → suc (p i))
sucⁿ-creates-<ⁿᵖ a b .snd (k , p) = k , inj-m+ⁿ {1} (sym (+-sucⁿ k (suc a)) ∙ p)

<ⁿᵖ-irrefl       : (a       : ℕ) → [ ¬ (a <ⁿᵖ a) ]
<ⁿᵖ-trans        : (a b x   : ℕ) → [ a <ⁿᵖ b ] → [ b <ⁿᵖ x ] → [ a <ⁿᵖ x ]
<ⁿᵖ-cotrans      : (a b     : ℕ) → [ a <ⁿᵖ b ] → (x : ℕ) → [ (a <ⁿᵖ x) ⊔ (x <ⁿᵖ b) ]
·ⁿ-preserves-<ⁿᵖ : (x y z   : ℕ) → [ 0 <ⁿᵖ z ] → [ x <ⁿᵖ y ] → [ (x *ⁿ z) <ⁿᵖ (y *ⁿ z) ]

-- abstract
-- <ⁿᵖ-irrefl zero (k , p) = ψ where abstract ψ = snotzⁿ (sym (+-sucⁿ k 0) ∙ p)

-- NOTE: `<-irreflᶻ'' (posneg i) p` forced this ?9 to be constrained to
--   ?9 (k = (fst x)) (p = (snd x)) = transp (λ i → [ lemma10'' 0 (((i1 ∨ i1) ∧ ~ i1 ∨ ~ i1) ∨ i) ]) i0 x : ⊥⊥
-- which demands an implementation in terms of lemma10''
-- <ⁿᵖ-irrefl zero q@(k , p) = transp (λ i → [ lemma10'' 0 (((i1 ∨ i1) ∧ ~ i1 ∨ ~ i1) ∨ i) ]) i0 q
-- <ⁿᵖ-irrefl zero q@(k , p) = transp (λ i → [ lemma10'' 0 ((i1 ∧ ~ i1) ∨ i) ]) i0 q
<ⁿᵖ-irrefl zero q@(k , p) = transp (λ i → [ lemma10'' 0 i ]) i0 q
<ⁿᵖ-irrefl (suc a) (k , p) = φ where
  abstract φ = snotzⁿ (inj-m+ⁿ {a} (+-sucⁿ a k ∙ (λ i → suc (+-commⁿ a k i)) ∙ sym (+-sucⁿ k a) ∙ inj-m+ⁿ {1} (sym (+-sucⁿ k (suc a)) ∙ p) ∙ sym (+-zeroⁿ a)))

<ⁿᵖ-trans a b c = Cubical.Data.Nat.Order.<-trans

-- <ⁿᵖ-trans  zero    zero    zero   q₁@(k₁ , p₁) q₂@(k₂ , p₂) = q₁
-- <ⁿᵖ-trans  zero    zero   (suc c) q₁@(k₁ , p₁) q₂@(k₂ , p₂) = q₂
-- <ⁿᵖ-trans  zero   (suc b)  zero   q₁@(k₁ , p₁) q₂@(k₂ , p₂) = ⊥-elim {A = λ _ → [ zero <ⁿᵖ zero ]} $ snotzⁿ (sym (+-sucⁿ k₂ (suc b)) ∙ p₂)
-- <ⁿᵖ-trans  zero   (suc b) (suc c) q₁@(k₁ , p₁) q₂@(k₂ , p₂) = k₂ +ⁿ (k₁ +ⁿ 1) , sym (+-assocⁿ k₂ _ 1) ∙ (λ i → k₂ +ⁿ +-sucⁿ (k₁ +ⁿ 1) 0 i) ∙ (λ i → k₂ +ⁿ suc (+-zeroⁿ (k₁ +ⁿ 1) i)) ∙ (λ i → k₂ +ⁿ suc (p₁ i)) ∙ p₂
-- <ⁿᵖ-trans (suc a)  zero    zero   q₁@(k₁ , p₁) q₂@(k₂ , p₂) = ⊥-elim {A = λ _ → [ suc a <ⁿᵖ zero ]} $ <ⁿᵖ-irrefl zero q₂
-- <ⁿᵖ-trans (suc a)  zero   (suc c) q₁@(k₁ , p₁) q₂@(k₂ , p₂) = ⊥-elim {A = λ _ → [ suc a <ⁿᵖ suc c ]} $ snotzⁿ (sym (+-sucⁿ k₁ (suc a)) ∙ p₁)
-- <ⁿᵖ-trans (suc a) (suc b)  zero   q₁@(k₁ , p₁) q₂@(k₂ , p₂) = ⊥-elim {A = λ _ → [ suc a <ⁿᵖ zero ]} $ snotzⁿ (sym (+-sucⁿ k₂ (suc b)) ∙ p₂)
-- <ⁿᵖ-trans (suc a) (suc b) (suc c) q₁@(k₁ , p₁) q₂@(k₂ , p₂) = k₂ +ⁿ  (k₁ +ⁿ 1) , (
--   (k₂ +ⁿ  (k₁ +ⁿ 1)) +ⁿ suc (suc a)  ≡⟨ {!   !} ⟩
--    k₂ +ⁿ ((k₁ +ⁿ 1)  +ⁿ suc (suc a)) ≡⟨ {!   !} ⟩
--    k₂ +ⁿ suc ((k₁ +ⁿ  1) +ⁿ  suc a ) ≡⟨ {!   !} ⟩
--    k₂ +ⁿ suc ( k₁ +ⁿ (1  +ⁿ  suc a)) ≡⟨ {!   !} ⟩
--    k₂ +ⁿ suc ( k₁ +ⁿ suc    (suc a)) ≡⟨ (λ i → k₂ +ⁿ suc (p₁ i)) ⟩
--    k₂ +ⁿ suc (suc b)                 ≡⟨ p₂ ⟩
--    suc c                             ∎)

<ⁿᵖ-cotrans  zero    zero        q      c  = ⊥-elim {A = λ _ → [ (zero <ⁿᵖ c) ⊔ (c <ⁿᵖ zero) ]}  (<ⁿᵖ-irrefl _ q)
<ⁿᵖ-cotrans  zero   (suc b)      q  zero   = inrᵖ q
<ⁿᵖ-cotrans  zero   (suc b)      q (suc c) = inlᵖ (c , +-commⁿ c 1)
<ⁿᵖ-cotrans (suc a)  zero   (k , p)     c  = ⊥-elim {A = λ _ → [ (suc a <ⁿᵖ c) ⊔ (c <ⁿᵖ zero) ]} (snotzⁿ (sym (+-sucⁿ k (suc a)) ∙ p))
<ⁿᵖ-cotrans (suc a) (suc b)      q  zero   = inrᵖ (b , +-commⁿ b 1)
<ⁿᵖ-cotrans (suc a) (suc b)      q (suc c) = transport (λ i → [ r i ⊔ s i ]) (<ⁿᵖ-cotrans a b (sucⁿ-creates-<ⁿᵖ a b .snd q) c)
  where abstract r : (a <ⁿᵖ c) ≡ (suc a <ⁿᵖ suc c)
                 s : (c <ⁿᵖ b) ≡ (suc c <ⁿᵖ suc b)
                 r = ⇔toPath (sucⁿ-creates-<ⁿᵖ a c .fst) (sucⁿ-creates-<ⁿᵖ a c .snd)
                 s = ⇔toPath (sucⁿ-creates-<ⁿᵖ c b .fst) (sucⁿ-creates-<ⁿᵖ c b .snd)

·ⁿ-preserves-<ⁿᵖ = {!   !}

<-irreflᶻ''       : (a       : ℤ) → [ ¬ (a <ᶻ'' a) ]
<-transᶻ''        : (a b x   : ℤ) → [ a <ᶻ'' b ] → [ b <ᶻ'' x ] → [ a <ᶻ'' x ]
<-cotransᶻ''      : (a b     : ℤ) → [ a <ᶻ'' b ] → (x : ℤ) → [ (a <ᶻ'' x) ⊔ (x <ᶻ'' b) ]
-- ·ᶻ-preserves-<ᶻ'' : (x y z   : ℤ) → [ 0 <ᶻ'' z ] → [ x <ᶻ'' y ] → [ (x *ᶻ z) <ᶻ'' (y *ᶻ z) ]

-- lemma10'' : ∀ n → (n <ⁿᵖ 0) ≡ ⊥

-- (i ∨ i) ∧ (~ i ∨ ~ i))
-- i0
-- lemma10'' 0 (~ i) = (⊥ ≡ (n <ⁿᵖ 0)) i

-- lemma14 :

<-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  = transport (λ j → [ lemma10'' 0 (((i ∨ i) ∧ (~ i ∨ ~ i)) ∨ j) ]) p
<-irreflᶻ'' (posneg i) p  = transport (λ j → [ lemma10'' 0 ((i ∧ ~ i) ∨ j) ]) p
-- <-irreflᶻ'' (posneg i) p  =
-- <-irreflᶻ'' (posneg i) p  = {! transport (λ j → [ lemma10'' 0 (((i ∨ i) ∧ (~ i ∨ ~ i)) ∨ j) ])     !} where
--   κ : [ lemma10'' 0 i1 ] ≡ {! <ⁿᵖ-irrefl 0    !}
--   κ = {!   !}
-- <-irreflᶻ'' (posneg i) p = transport (λ j → [ lemma10'' 0 ((i ∧ ~ i) ∨ j) ]) p
-- <-irreflᶻ'' (posneg i) p = transport (λ j → [ lemma10'' 0 (i₀ ∨ j) ]) p

-- The problem is that when we write ̀with f x | pr`, `with` decides to call `y`
-- the result `f x` and to replace *all* of the occurences of `f x` in the type
-- of `pr` with `y`. That is to say that if we were to write:
-- ...
-- then `with` would abstract `m + n` as `p` on *both* sides of the equality
-- proven by `refl` thus giving us the following goal with an extra, useless,
-- assumption:
-- ...
-- Given that `inspect` has the type `∀ f n → Reveal f · n is (f n)`, when we
-- write `with f n | inspect f n`, the only `f n` that can be abstracted in the
-- type of `inspect f n` is the third argument to `Reveal_·_is_`.
-- That is to say that the auxiliary definition generated looks like this:
--
-- plus-eq-reveal : ∀ m n → Plus-eq m n (m + n)
-- plus-eq-reveal m n = aux m n (m + n) (my-inspect (m +_) n) where
--
--   aux : ∀ m n p → MyReveal (m +_) · n is p → Plus-eq m n p
--   aux m n zero    [ m+n≡0   ] = m+n≡0⇒m≡0 m m+n≡0 , m+n≡0⇒n≡0 m m+n≡0
--   aux m n (suc p) [ m+n≡1+p ] = m+n≡1+p
--
-- At the cost of having to unwrap the constructor `[_]` around the equality
-- we care about, we can keep relying on `with` and avoid having to roll out
-- handwritten auxiliary definitions.

record Reveal_·_is_ {a b} {A : Type a} {B : A → Type b}
                    (f : (x : A) → B x) (x : A) (y : B x) :
                    Type (ℓ-max a b) where
  eta-equality
  constructor [_]ⁱ
  field eq : f x ≡ y -- lhs stays fix, rhs gets splitted

inspect : ∀{a b} {A : Type a} {B : A → Type b}
          (f : (x : A) → B x) (x : A) → Reveal f · x is f x
inspect f x = [ refl ]ⁱ

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)

_<ᶻ'''_ : ∀(x y : ℤ) → hProp ℓ-zero
x <ᶻ''' y with reprℤ x | reprℤ y | inspect-reprℤ x | inspect-reprℤ y
... | spos , x' | spos , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = x' <ⁿᵖ y'
... | spos , x' | sneg , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = ⊥
... | sneg , x' | spos , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = ⊤
... | sneg , x' | sneg , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = y' <ⁿᵖ x'

<ᶻ''≡<ᶻ''' : ∀ 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)

-- Goal lemma10'' 0 ((i ∨ j) ∧ ~ i ∨ ~ j) ≡ (posneg i <ᶻ''' posneg j)
-- Have (0 <ⁿᵖ 0) ≡ ⊥
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ λ k → lemma10'' 0 (~ k ∧ j)
-- i = i1 ⊢ λ k → lemma10'' 0 (~ k ∧ ~ j)
-- j = i0 ⊢ λ k → lemma10'' 0 (~ k ∧ i)
-- j = i1 ⊢ λ k → lemma10'' 0 (~ k ∧ ~ i)
<ᶻ''≡<ᶻ''' (posneg i) (posneg   j ) = λ k → lemma10'' 0 (((i ∨ j) ∧ ~ i ∨ ~ j) ∧ ~ k)

_<ᶻ'''ʳ_ : ∀(x y : Sign × ℕ) → hProp ℓ-zero
-- NOTE: when using this definition, we get `<ᶻ'''≡<ᶻ'''ʳ` proven definitionally
--       but we do not get term normalization as we need it
-- x <ᶻ'''ʳ y = reprℤ⁻¹ x <ᶻ''' reprℤ⁻¹  y
--       and when using this other definition, we get `<ᶻ'''≡'<ᶻ'''ʳ` proven definitionally
(spos , x) <ᶻ'''ʳ (spos , y) = x <ⁿᵖ y -- (pos x) <ᶻ''' (pos y)
(spos , x) <ᶻ'''ʳ (sneg , y) = ⊥       -- (pos x) <ᶻ''' (neg y)
(sneg , x) <ᶻ'''ʳ (spos , y) = ⊤       -- (neg x) <ᶻ''' (pos y)
(sneg , x) <ᶻ'''ʳ (sneg , y) = y <ⁿᵖ x -- (neg x) <ᶻ''' (neg y)

signʳ-≡ : ∀ z → sign z ≡ reprℤ z .fst
signʳ-≡ (signed s zero) = refl
signʳ-≡ (signed s (suc n)) = refl
signʳ-≡ (posneg i) = refl

<ᶻ'''≡<ᶻ'''ʳ : ∀ x y → reprℤ⁻¹ x <ᶻ''' reprℤ⁻¹ y ≡ x <ᶻ'''ʳ y
<ᶻ'''≡<ᶻ'''ʳ x@(sx , nx) y@(sy , ny) with sx | sy | signʳ-≡ (reprℤ⁻¹ x) | signʳ-≡ (reprℤ⁻¹ y)
... | sx' | sy' | px | py = {!   !}
-- <ᶻ'''≡<ᶻ'''ʳ (spos , x) (spos , y) = {! refl   !}
-- <ᶻ'''≡<ᶻ'''ʳ (spos , x) (sneg , y) = {! refl   !}
-- <ᶻ'''≡<ᶻ'''ʳ (sneg , x) (spos , y) = {! refl   !}
-- <ᶻ'''≡<ᶻ'''ʳ (sneg , x) (sneg , y) = {! refl   !}

<ᶻ'''≡'<ᶻ'''ʳ : ∀ x y → x <ᶻ''' y ≡ reprℤ x <ᶻ'''ʳ reprℤ y
<ᶻ'''≡'<ᶻ'''ʳ x y with reprℤ x | reprℤ y {- | inspect-reprℤ x | inspect-reprℤ y -}
... | spos , x' | spos , y' {- | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' -} = refl
... | spos , x' | sneg , y' {- | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' -} = refl
... | sneg , x' | spos , y' {- | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' -} = refl
... | sneg , x' | sneg , y' {- | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' -} = refl

<ᶻ'''≡''<ᶻ'''ʳ : ∀ x y → reprℤ⁻¹ x <ᶻ''' reprℤ⁻¹ y ≡ x <ᶻ'''ʳ y
<ᶻ'''≡''<ᶻ'''ʳ x@(xs , xn) y@(ys , yn) with reprℤ (reprℤ⁻¹ x) | reprℤ (reprℤ⁻¹ y) | inspect-reprℤ (reprℤ⁻¹ x) | inspect-reprℤ (reprℤ⁻¹ y)
... | spos , x' | spos , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = {! refl    !}
... | spos , x' | sneg , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = {! refl    !}
... | sneg , x' | spos , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = {! refl    !}
... | sneg , x' | sneg , y' | [ x≡ ]ⁱ' | [ y≡ ]ⁱ' = {! refl    !}

-- [ reprℤ⁻¹ (spos , a') <ᶻ''' reprℤ⁻¹ (spos , c') ]
-- [ reprℤ a <ᶻ'''ʳ reprℤ c ]
-- [ a <ᶻ''' c ]
-- [ a <ᶻ'' c ]

<ᶻ'''≡'''<ᶻ'''ʳ : ∀ x y → reprℤ⁻¹ x <ᶻ''' reprℤ⁻¹ y ≡ x <ᶻ'''ʳ y
<ᶻ'''≡'''<ᶻ'''ʳ x@(xs , xn) y@(ys , yn) with reprℤ (reprℤ⁻¹ x) | reprℤ (reprℤ⁻¹ y)
... | spos , x' | spos , y' = {!   !}
... | spos , x' | sneg , y' = {!   !}
... | sneg , x' | spos , y' = {!   !}
... | sneg , x' | sneg , y' = {!   !}

-- NOTE: making use of trichotomy might be in-line with the definition of QuoInt
--       because this is what we are likely to use at the end

-- -- {! pathTo⇐ (<ᶻ''≡<ᶻ''' a c ∙ (λ i → a≡ i <ᶻ''' c≡ i)) γ   !}
-- where γ : [ reprℤ⁻¹ (spos , a') <ᶻ''' reprℤ⁻¹ (spos , c') ]
--       γ = pathTo⇐ (<ᶻ'''≡<ᶻ'''ʳ (spos , a') (spos , c')) {!   !}
--       κ : [ reprℤ⁻¹ (spos , a') <ᶻ''' reprℤ⁻¹ (spos , c') ]
--       κ = {! <ᶻ'''≡'<ᶻ'''ʳ a c   !}

-- possible cases
-- NOTE: the "trick" is to with-abstract over `reprℤ a` and `reprℤ c`
--       which turns the type of `pathTo⇐ (<ᶻ''≡<ᶻ''' a c ∙ <ᶻ'''≡'<ᶻ'''ʳ a c)`
--       from `[ (reprℤ a <ᶻ'''ʳ reprℤ c) ⇒ (a <ᶻ'' c) ]`
--       into `a' <ⁿ c' → fst (a <ᶻ'' c)`
<-transᶻ'' a b c a<b b<c
  with reprℤ a | reprℤ b | reprℤ c
     | pathTo⇒ (<ᶻ''≡<ᶻ''' a b ∙ <ᶻ'''≡'<ᶻ'''ʳ a b) a<b
     | pathTo⇒ (<ᶻ''≡<ᶻ''' b c ∙ <ᶻ'''≡'<ᶻ'''ʳ b c) b<c
     | pathTo⇐ (<ᶻ''≡<ᶻ''' a c ∙ <ᶻ'''≡'<ᶻ'''ʳ a c)
... | spos , a' | spos , b' | spos , c' | a<b' | b<c' | p = p (<ⁿᵖ-trans _ _ _ a<b' b<c')
... | spos , a' | spos , b' | sneg , c' | a<b' | b<c' | p = p b<c'
... | spos , a' | sneg , b' | spos , c' | a<b' | b<c' | p = p (⊥-elim a<b')
... | spos , a' | sneg , b' | sneg , c' | a<b' | b<c' | p = p a<b'
... | sneg , a' | spos , b' | spos , c' | a<b' | b<c' | p = p a<b'
... | sneg , a' | spos , b' | sneg , c' | a<b' | b<c' | p = p (⊥-elim b<c')
... | sneg , a' | sneg , b' | spos , c' | a<b' | b<c' | p = p b<c'
... | sneg , a' | sneg , b' | sneg , c' | a<b' | b<c' | p = p (<ⁿᵖ-trans _ _ _ b<c' a<b')

<-cotransᶻ'' a b a<b c
  with reprℤ a | reprℤ b | reprℤ c
     | pathTo⇒ (<ᶻ''≡<ᶻ''' a b ∙ <ᶻ'''≡'<ᶻ'''ʳ a b) a<b
     | pathTo⇐ (λ i → (<ᶻ''≡<ᶻ''' a c ∙ <ᶻ'''≡'<ᶻ'''ʳ a c) i ⊔ (<ᶻ''≡<ᶻ''' c b ∙ <ᶻ'''≡'<ᶻ'''ʳ 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'))

-- [_/_] : ℤ → ℕ₊₁ → ℚ
-- [ a / b ] = [ a , b ]

lemma15 : ∀(a@(an , ad) b@(bn , bd) : ℤ × ℕ₊₁) → a ∼ b → ((sign an , abs an) , ad) ≡ ((sign bn , abs bn) , bd)
lemma15 a@(an , ad) b@(bn , bd) a~b = {!   !}

reprℚ : ℚ → (Sign × ℕ) × ℕ₊₁
reprℚ [ n , d ]ᶠ = (sign n , abs n) , d
reprℚ (eq/ a@(an , ad) b@(bn , bd) r i) = lemma15 a b r i
reprℚ (squash/ a b p q i j) = {!   !}

reprℚ⁻¹ : (Sign × ℕ) × ℕ₊₁ → ℚ
reprℚ⁻¹ ((s , n) , d) = [ signed s n , d ]ᶠ

lemma15' : ∀(a@(an , ad) b@(bn , bd) : ℤ × ℕ₊₁) → a ∼ b → (an , ad) ≡ (bn , bd)
lemma15' a@(an , ad) b@(bn , bd) a~b = {!   !}

import Cubical.HITs.SetQuotients.Properties as SetQuotients

reprℚ' : ℚ → ℤ × ℕ₊₁
reprℚ' [ n , d ]ᶠ = n , d
reprℚ' (eq/ a@(an , ad) b@(bn , bd) r i) = lemma15' a b r i
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ reprℚ' (p j)
-- i = i1 ⊢ reprℚ' (q j)
-- j = i0 ⊢ reprℚ' a
-- j = i1 ⊢ reprℚ' b
-- i : p j ≡ q j
-- j : a   ≡ b
--
-- j
-- ∧
-- | p1 = b      q1 = b
-- |
-- | p0 = a      q0 = a
-- +--------------------> i
--
-- i : p ≡ q
-- reprℚ' (squash/ a b p q i j) = reprℚ' (isSetℚ a b p q i j) -- termination checker complains
-- reprℚ' (squash/ a b p q i j) = {!   !} (isSetℚ a b p q i j)
reprℚ' (squash/ a b p q i j) = {! SetQuotients.rec2    !}
-- reprℚ' (squash/ a b p q i j) = {! SetQuotients.elimProp {A = ℤ × ℕ₊₁} {R = _∼_} {B = λ _ → ℤ × ℕ₊₁}   !}

-- NOTE: `onCommonDenom` uses `SetQuotient.rec2 isSetℚ`

reprℚ'' : ℚ → ℤ × ℕ₊₁
reprℚ'' q = SetQuotients.elim {A = ℤ × ℕ₊₁} {R = _∼_} {B = λ _ → ℤ × ℕ₊₁} γ (λ x → x) κ q where
  γ : (x : (ℤ × ℕ₊₁) // _∼_) → isSet (ℤ × ℕ₊₁)
  γ x = {!   !} -- this should work out
  κ : (a b : ℤ × ℕ₊₁) (r : a ∼ b) → a ≡ b
  κ a b a∼b = {!   !} -- this is an issue

reprℚ''' : ℚ → ℤ × ℕ₊₁
reprℚ''' q = SetQuotients.rec {A = ℤ × ℕ₊₁} {R = _∼_} {B = ℤ × ℕ₊₁} γ (λ x → x) κ q where
  γ : isSet (ℤ × ℕ₊₁)
  γ = {!   !} -- this should work out
  κ : (a b : ℤ × ℕ₊₁) (r : a ∼ b) → a ≡ b
  κ (an , ad) (bn , bd) a∼b = {!   !} -- this is an issue

-- is seems that `∀ a b → a ∼ b → a ≡ b` is a necessity to perform this representation operation
-- there is no nominator or denominator being "the" nominator or denominator in QuoQ
--   therefore, we won't get a `reprℚ : ℚ → ℤ × ℕ₊₁` for QuoQ (only for SigmaQ where this is just `fst`)
-- but for two (or more) rationals, we can create a common denominator for them
-- we might be able to get `ℚ ≃ Sign × ℚ⁺` with an identification of +0 and -0 similar to QuoInt
-- with onCommonDenom3 we could treat three rational numbers as integers for an implementation of <-transᶠ
-- I guess that we need to show then, something like
--   κ : ∀ a₁ b₁ c₁ a₂ b₂ c₂
--     → a₁ ∼ a₂ → b₁ ∼ b₂ → c₁ ∼ c₂
--     → (a₁<b₁ : a₁ < b₁) → (b₁<c₁ : b₁ < c₁)
--     → (a₂<b₂ : a₂ < b₂) → (b₂<c₂ : b₂ < c₂)
--     → <-trans a₁ b₁ c₁ a₁<b₁ b₁<c₁ ≡ <-trans a₂ b₂ c₂ a₂<b₂ b₂<c₂
-- i.e. that transitivity respects the equivalence
-- this might be shown with "multiplication preserves transitivity" on ℕ
--   κ : ∀ a b c
--     → (n : ℕ₊₁)
--     → (a<b : a < b) → (b<c : b < c)
--     → (an<bn : a · n < b · n) → (bn<cn : b · n < c · n)
--     → <-trans a b c a<b b<c ≡ <-trans (a · n) (b · n) (c · n) an<bn bn<cn

-- in `Cubical.HITs.Rationals.SigmaQ.Base` (which uses `ℤ` for `QuoInt.ℤ`) we have
--
--   ℚ : Type₀
--   ℚ = Σ[ (a , b) ∈ ℤ × ℕ₊₁ ] areCoprime (abs a , ℕ₊₁→ℕ b)
--
-- in `Cubical.HITs.Ints.QuoInt.Base` we have
--
--   data ℤ : Type₀ where
--     signed : (s : Sign) (n : ℕ) → ℤ
--     posneg : signed spos 0 ≡ signed sneg 0
--
-- in `Cubical.Data.NatPlusOne.Base` we have
--
--   record ℕ₊₁ : Type₀ where
--     constructor 1+_
--     field
--       n : ℕ
--
-- and in `Data.Rational.Base` (which uses `ℤ` for `Builtin.Int`) we have
--
--   record ℚ : Set where
--     constructor mkℚ
--     field
--       numerator     : ℤ
--       denominator-1 : ℕ
--       .isCoprime    : Coprime ∣ numerator ∣ (suc denominator-1)
--
-- in `Agda.Builtin.Int` we have
--
--   data Int : Set where
--     pos    : (n : Nat) → Int
--     negsuc : (n : Nat) → Int
--
-- in `Agda.Builtin.Nat` we have
--
--   data Nat : Set where
--     zero : Nat
--     suc  : (n : Nat) → Nat
--
-- so the difference between the cubical "SigmaQ"-rationals and the non-cubical "Rational"-rationals is that
--   SigmaQ uses QuoInt and NatPlusOne where Rational uses Builtin.Int and Builtin.Nat

reprℚ⁻¹' : ℤ × ℕ₊₁ → ℚ
reprℚ⁻¹' (n , d) = [ n , d ]ᶠ

-- 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)

-- _<ᶠ_ : hPropRel ℚ ℚ ℓ-zero
-- x <ᶠ y = {! elimProp2 {A = ℤ × ℕ₊₁} {R = _∼_} {C = C} γ κ x y   !}
--   where
--   φ : ℚ → ℚ → hProp ℓ-zero
--   φ x y = {!   !}
--   C : ℚ → ℚ → Type
--   C x y = [ φ x y ]
--   γ : (x y : ℚ) → isProp (C x y)
--   γ x y = {!   !}
--   κ : (a b : ℤ × ℕ₊₁) → C [ a ]ᶠ [ b ]ᶠ
--   κ a b = {!   !}

-- ... | spos , snd₁ | fst₂ , snd₂ | fst₃ , snd₃ | [ eq ]ⁱ | [ eq₁ ]ⁱ | [ eq₂ ]ⁱ = {!   !}
-- ... | sneg , snd₁ | fst₂ , snd₂ | fst₃ , snd₃ | [ eq ]ⁱ | [ eq₁ ]ⁱ | [ eq₂ ]ⁱ = {!   !}

-- <-transᶻ'' (pos zero) (pos zero) (pos zero) a<b b<c = {!   !}
-- <-transᶻ'' (pos zero) (pos zero) (pos (suc n₂)) a<b b<c = {!   !}
-- <-transᶻ'' (pos zero) (pos (suc n₁)) (pos zero) a<b b<c = {!   !}
-- <-transᶻ'' (pos zero) (pos (suc n₁)) (pos (suc n₂)) a<b b<c = {!   !}
--
-- <-transᶻ'' (pos (suc n₀)) (pos zero) (pos zero) a<b b<c = {!   !}
-- <-transᶻ'' (pos (suc n₀)) (pos zero) (pos (suc n₂)) a<b b<c = {!   !}
-- <-transᶻ'' (pos (suc n₀)) (pos (suc n₁)) (pos zero) a<b b<c = {!   !}
-- <-transᶻ'' (pos (suc n₀)) (pos (suc n₁)) (pos (suc n₂)) a<b b<c = {!   !}
--
-- <-transᶻ'' (neg n₀) (pos n₁) (pos n₂) a<b b<c = {!   !}
-- <-transᶻ'' (neg n₀) (neg n₁) (pos n₂) a<b b<c = {!   !}
-- <-transᶻ'' (neg n₀) (neg n₁) (neg n₂) a<b b<c = {!   !}
--
-- <-transᶻ'' (signed s₀ n₀) (signed s₁ n₁) (posneg i) a<b b<c = {!   !}
--
-- <-transᶻ'' (signed s₀ n₀) (posneg i) (signed s₁ n₁) a<b b<c = {!   !}
--
-- <-transᶻ'' (signed s₀ n₀) (posneg i) (posneg i₁) a<b b<c = {!   !}
--
-- <-transᶻ'' (posneg i) (signed s₁ n₁) (signed s₂ n₂) a<b b<c = {!   !}
--
-- <-transᶻ'' (posneg i) (signed s₁ n₁) (posneg i₁) a<b b<c = {!   !}
--
-- <-transᶻ'' (posneg i) (posneg i₁) (signed s₂ n₂) a<b b<c = {!   !}
--
-- <-transᶻ'' (posneg i) (posneg i₁) (posneg i₂) a<b b<c = {!   !}

{-

-- -- 8 points
-- <-transᶻ'' (pos n₀) (pos n₁) (pos zero) a<b b<c = {! <ⁿᵖ-trans   !} -- point 1
-- <-transᶻ'' (pos n₀) (pos n₁) (pos (suc n₂)) a<b b<c = {!   !}
-- <-transᶻ'' (neg n₀) (pos n₁) (pos zero) a<b b<c = {!   !} -- point 2
-- <-transᶻ'' (neg n₀) (pos n₁) (pos (suc n₂)) a<b b<c = {!   !}
-- <-transᶻ'' (neg n₀) (neg n₁) (neg zero) a<b b<c = {!   !} -- point 3
-- <-transᶻ'' (neg n₀) (neg n₁) (neg (suc n₂)) a<b b<c = {!   !}
-- <-transᶻ'' (neg n₀) (neg n₁) (pos zero) a<b b<c = {!   !} -- point 4
-- <-transᶻ'' (neg n₀) (neg n₁) (pos (suc n₂)) a<b b<c = {!   !}
--
-- -- 12 edges
-- <-transᶻ'' (neg n₀) (pos n₁) (posneg k) a<b b<c = {!   !} -- 21 -- point 2
-- <-transᶻ'' (pos n₀) (pos n₁) (posneg k) a<b b<c = {!   !} -- 22 -- point 1
-- <-transᶻ'' (neg n₀) (neg n₁) (posneg k) a<b b<c = {!   !} -- 23 -- point 3 to 4
-- -- <-transᶻ'' (pos n₀) (neg n₁) (posneg k) a<b b<c = {!   !}
-- <-transᶻ'' (pos n₀) (posneg j) (pos n₂) a<b b<c = {!   !} -- 24
-- <-transᶻ'' (pos n₀) (posneg j) (neg n₂) a<b b<c = {!   !} -- 25
-- <-transᶻ'' (neg n₀) (posneg j) (pos n₂) a<b b<c = {!   !} -- 26
-- <-transᶻ'' (neg n₀) (posneg j) (neg n₂) a<b b<c = {!   !} -- 27
-- <-transᶻ'' (posneg i) (pos n₁) (pos n₂) a<b b<c = {!   !} -- 28
-- <-transᶻ'' (posneg i) (neg n₁) (pos n₂) a<b b<c = {!   !} -- 29
-- <-transᶻ'' (posneg i) (neg n₁) (neg n₂) a<b b<c = {!   !} -- 30
-- -- <-transᶻ'' (posneg i) (pos n₁) (neg n₂) a<b b<c = {!   !}
--
-- --  6 faces
-- <-transᶻ'' (pos n₀) (posneg j) (posneg k) a<b b<c = {!   !} -- 22 24 25
-- <-transᶻ'' (neg n₀) (posneg j) (posneg k) a<b b<c = {!   !} -- 21 23 26
-- <-transᶻ'' (posneg i) (pos n₁) (posneg k) a<b b<c = {!   !} -- 22 21 28
-- <-transᶻ'' (posneg i) (neg n₁) (posneg k) a<b b<c = {!   !} -- 23 29 30
-- <-transᶻ'' (posneg i) (posneg j) (pos n₂) a<b b<c = {!   !} -- 24 26 28 29
-- <-transᶻ'' (posneg i) (posneg j) (neg n₂) a<b b<c = {!   !} -- 25 27 30

-- (i ∨ k) ∧ ~ i ∨ ~ k
-- (i ∨ k) ∧ (~ i ∨ ~ k)
-- (i ∨ k) ∧ ~(i ∧ k)
-- i k | i ∨ k | i ∧ k | ~(i ∧ k) | (i ∨ k) ∧ ~(i ∧ k)
-- 0 0 |   0   |   0   |     1    |         0
-- 0 1 |   1   |   0   |     1    |         1
-- 1 0 |   1   |   0   |     1    |         1
-- 1 1 |   1   |   1   |     0    |         0
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ ?21 (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 k)
-- i = i1 ⊢ ?22 (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 (~ k))
-- j = i0 ⊢ ?23 (i = i) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- j = i1 ⊢ ?24 (i = i) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- k = i0 ⊢ ?25 (i = i) (j = j) (n₂ = 0) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 i)
-- k = i1 ⊢ ?26 (i = i) (j = j) (n₂ = 0) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 (~ i))
-- ———— Constraints ———————————————————————————————————————————
-- ?21 (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) = ?27 (i = i0) : fst (lemma10'' 0 k)
-- ?22 (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) = ?27 (i = i1) : fst (lemma10'' 0 (~ k))
-- ?23 (i = i) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) = ?27 (j = i0) : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- ?24 (i = i) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) = ?27 (j = i1) : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- ?25 (i = i) (j = j) (n₂ = 0) (a<b = a<b) (b<c = b<c) = ?27 (k = i0) : fst (lemma10'' 0 i)
-- ?26 (i = i) (j = j) (n₂ = 0) (a<b = a<b) (b<c = b<c) = ?27 (k = i1) : fst (lemma10'' 0 (~ i))

-- Goal [ lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k) ]
-- ———— Boundary ——————————————————————————————————————————————
-- i = i0 ⊢ ?20 (s₀ = spos) (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 k)
-- i = i1 ⊢ ?20 (s₀ = sneg) (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 (~ k))
-- j = i0 ⊢ ?22 (i = i) (s₁ = spos) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- j = i1 ⊢ ?22 (i = i) (s₁ = sneg) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- k = i0 ⊢ ?23 (i = i) (j = j) (s₂ = spos) (n₂ = 0) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 i)
-- k = i1 ⊢ ?23 (i = i) (j = j) (s₂ = sneg) (n₂ = 0) (a<b = a<b) (b<c = b<c) -- : fst (lemma10'' 0 (~ i))
-- ———— Constraints ———————————————————————————————————————————
-- ?20 (s₀ = spos) (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) = ?24 (i = i0) : fst (lemma10'' 0 k)
-- ?20 (s₀ = sneg) (n₀ = 0) (j = j) (k = k) (a<b = a<b) (b<c = b<c) = ?24 (i = i1) : fst (lemma10'' 0 (~ k))
-- ?22 (i = i) (s₁ = spos) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) = ?24 (j = i0) : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- ?22 (i = i) (s₁ = sneg) (n₁ = 0) (k = k) (a<b = a<b) (b<c = b<c) = ?24 (j = i1) : fst (lemma10'' 0 ((i ∨ k) ∧ ~ i ∨ ~ k))
-- ?23 (i = i) (j = j) (s₂ = spos) (n₂ = 0) (a<b = a<b) (b<c = b<c) = ?24 (k = i0) : fst (lemma10'' 0 i)
-- ?23 (i = i) (j = j) (s₂ = sneg) (n₂ = 0) (a<b = a<b) (b<c = b<c) = ?24 (k = i1) : fst (lemma10'' 0 (~ i))

-- 1 cube
<-transᶻ'' (posneg    i ) (posneg    j ) (posneg    k ) a<b b<c = {!    !} -- ?24

·ᶻ-preserves-<ᶻ'' = {!   !}

-- _*ᶻ_ = Cubical.HITs.Ints.QuoInt._*_
-- signᶻ = Cubical.HITs.Ints.QuoInt.sign

open import Data.Nat.Base using () renaming
  ( _⊔_ to maxⁿ
  ; _⊓_ to minⁿ
  )

-- NOTE: in `Cubical.HITs.Ints.QuoInt.Base` there is
--         Int→ℤ : Int → ℤ
--         ℤ→Int : ℤ → Int
--         Int≡ℤ : Int ≡ ℤ

open import Cubical.Data.Int using () renaming (pos to ℕ→Int)

ℕ→ℤ : ℕ → ℤ
ℕ→ℤ x = Int→ℤ (ℕ→Int x)

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)) -- instead of `- ℕ→ℤ (maxⁿ ...)`

-- maxⁿ' : ℕ → ℕ → ℕ
-- maxⁿ' (zero ) (n    ) = n
-- maxⁿ' (suc m) (zero ) = suc m
-- maxⁿ' (suc m) (suc n) = suc (maxⁿ' m n)
--
-- minⁿ' : ℕ → ℕ → ℕ
-- minⁿ' (zero ) (n    ) = zero
-- minⁿ' (suc m) (zero ) = zero
-- minⁿ' (suc m) (suc n) = suc (minⁿ' m n)

maxⁿ≡0-right : ∀ n  → maxⁿ n 0 ≡ n
maxⁿ≡0-right zero    = refl
maxⁿ≡0-right (suc n) = refl

minⁿ≡0-right : ∀ n  → minⁿ n 0 ≡ 0
minⁿ≡0-right zero    = refl
minⁿ≡0-right (suc n) = refl

lemma : ∀ n → pos 0 ≡ neg (minⁿ n 0)
lemma n = posneg ∙ (λ j → neg (minⁿ≡0-right n (~ j)))
-- lemma n = posneg ∙ (λ j → neg (minⁿ≡0-right n (~ j)))

-- i = i0 ⊢ pos 0
-- i = i1 ⊢ lemma 0 j
-- j = i0 ⊢ pos 0
-- j = i1 ⊢ posneg i
--
-- ———— Constraints ———————————————————————————————————————————
-- posneg i = ?11 (j = i1) : ℤ
-- pos 0 = ?11 (j = i0) : ℤ
-- hcomp (doubleComp-faces (λ _ → pos 0) (λ j₁ → neg zero) j) (posneg j) = ?11 (i = i1) : ℤ
-- pos 0 = ?11 (i = i0) : ℤ

maxᶻ : ℤ → ℤ → ℤ
maxᶻ (pos n₀) (pos n₁) = pos (maxⁿ n₀ n₁)
maxᶻ (pos n₀) (neg n₁) = pos n₀
maxᶻ (neg n₀) (pos n₁) = pos n₁
maxᶻ (neg n₀) (neg n₁) = neg (minⁿ n₀ n₁)
-- pathes
maxᶻ (pos    n) (posneg i) = pos (maxⁿ≡0-right n i)
maxᶻ (neg zero) (posneg i) = posneg i -- `lemma zero i` does not work here
-- NOTE: better not use `lemma (suc n) i` because it creates an unnormalizable term:
--   `hcomp (doubleComp-faces (λ _ → pos 0) (λ j₁ → neg 0) j) (posneg j)`
maxᶻ (neg (suc n)) (posneg i) = posneg i -- lemma (suc n) i -- can also use `posneg i` here
maxᶻ (posneg i) (pos    n) = pos n
maxᶻ (posneg i) (neg    n) = posneg i
maxᶻ (posneg i) (posneg j) = posneg (i ∧ j) -- posneg (i ∧ j)

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))

_ = maxᶻ -1 -1 ≡ -1 ∋ refl
_ = maxᶻ -1  0 ≡  0 ∋ refl
_ = maxᶻ -1  1 ≡  1 ∋ refl
_ = maxᶻ  0 -1 ≡  0 ∋ refl
_ = maxᶻ  0  0 ≡  0 ∋ refl
_ = maxᶻ  0  1 ≡  1 ∋ refl
_ = maxᶻ  1 -1 ≡  1 ∋ refl
_ = maxᶻ  1  0 ≡  1 ∋ refl
_ = maxᶻ  1  1 ≡  1 ∋ refl

_ = maxᶻ' -1 -1 ≡ -1 ∋ refl
_ = maxᶻ' -1  0 ≡  0 ∋ refl
_ = maxᶻ' -1  1 ≡  1 ∋ refl
_ = maxᶻ'  0 -1 ≡  0 ∋ refl
_ = maxᶻ'  0  0 ≡  0 ∋ refl
_ = maxᶻ'  0  1 ≡  1 ∋ refl
_ = maxᶻ'  1 -1 ≡  1 ∋ refl
_ = maxᶻ'  1  0 ≡  1 ∋ refl
_ = maxᶻ'  1  1 ≡  1 ∋ refl

-- sign' : ℤ → Sign
-- sign' (signed _ zero) = spos
-- sign' (signed s (suc _)) = s
-- sign' (posneg i) = spos

lemma2 : ∀ x y → maxᶻ x y ≡ maxᶻ' x y
lemma2 (pos  zero   ) (pos  zero   ) = refl
lemma2 (pos  zero   ) (pos (suc n₁)) = refl
lemma2 (pos (suc n₀)) (pos  zero   ) = refl
lemma2 (pos (suc n₀)) (pos (suc n₁)) = refl
lemma2 (pos  zero   ) (neg  zero   ) = refl
lemma2 (pos  zero   ) (neg (suc n₁)) = refl
lemma2 (pos (suc n₀)) (neg  zero   ) = refl
lemma2 (pos (suc n₀)) (neg (suc n₁)) = refl
lemma2 (neg  zero   ) (pos  zero   ) = refl
lemma2 (neg  zero   ) (pos (suc n₁)) = refl
lemma2 (neg (suc n₀)) (pos  zero   ) = refl
lemma2 (neg (suc n₀)) (pos (suc n₁)) = refl
lemma2 (neg  zero   ) (neg  zero   ) = sym posneg
lemma2 (neg  zero   ) (neg (suc n₁)) = refl
lemma2 (neg (suc n₀)) (neg  zero   ) = refl
lemma2 (neg (suc n₀)) (neg (suc n₁)) = refl
lemma2 (pos  zero   ) (posneg   j  ) = refl
lemma2 (pos (suc n₀)) (posneg   j  ) = refl
lemma2 (neg  zero   ) (posneg   j  ) = λ i → posneg (j ∧ (~ i))
lemma2 (neg (suc n₀)) (posneg   j  ) = refl
lemma2 (posneg   i  ) (pos  zero   ) = refl
lemma2 (posneg   i  ) (pos (suc n₁)) = refl
lemma2 (posneg   i  ) (neg  zero   ) = λ j → posneg (i ∧ (~ j))
lemma2 (posneg   i  ) (neg (suc n₁)) = refl
lemma2 (posneg   i  ) (posneg   j  ) = λ k → posneg (i ∧ j ∧ (~ k))

lemma3 : maxᶻ ≡ maxᶻ'
lemma3 = funExt₂ᶜ lemma2

-- maxᶻ (signed s₀ n₀) (signed s₁ n₁) = {!   !}
-- maxᶻ (signed s₀ n₀) (posneg j) = {!   !}
-- maxᶻ (posneg i) (signed s₁ n₁) = {!   !}
-- maxᶻ (posneg i) (posneg j) = {!   !}

minᶠ : ℚ → ℚ → ℚ
minᶠ x y = onCommonDenom f g h x y where
  f : ℤ × ℕ₊₁ → ℤ × ℕ₊₁ → ℤ
  f a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) = minᶻ (aᶻ *ᶻ (ℕ₊₁→ℤ bⁿ)) (bᶻ *ᶻ (ℕ₊₁→ℤ aⁿ))
  g : (a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) c@(cᶻ , cⁿ) : ℤ × ℕ₊₁)
    → aᶻ *ᶻ (ℕ₊₁→ℤ bⁿ) ≡ bᶻ *ᶻ (ℕ₊₁→ℤ aⁿ)
    → (ℕ₊₁→ℤ bⁿ) *ᶻ (f a c) ≡ (ℕ₊₁→ℤ aⁿ) *ᶻ (f b c)
  g a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) c@(cᶻ , cⁿ) aᶻ*bⁿ≡bᶻ*aⁿ = {!    !}
  h : (a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) c@(cᶻ , cⁿ) : ℤ × ℕ₊₁)
    → bᶻ *ᶻ (ℕ₊₁→ℤ cⁿ) ≡ cᶻ *ᶻ (ℕ₊₁→ℤ bⁿ)
    → (f a b) *ᶻ (ℕ₊₁→ℤ cⁿ) ≡ (f a c) *ᶻ (ℕ₊₁→ℤ bⁿ)
  h a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) c@(cᶻ , cⁿ) bᶻ*cⁿ≡cᶻ*bⁿ = {!   !}

maxᶠ : ℚ → ℚ → ℚ
maxᶠ x y = {!   !}

0ᶠ 1ᶠ : ℚ
0ᶠ = 0
1ᶠ = 1

<-irreflᶠ       : (a       : ℚ) → [ ¬ (a <ᶠ a) ]
<-transᶠ        : (a b x   : ℚ) → [ a <ᶠ b ] → [ b <ᶠ x ] → [ a <ᶠ x ]
<-cotransᶠ      : (a b     : ℚ) → [ a <ᶠ b ] → (x : ℚ) → [ (a <ᶠ x) ⊔ (x <ᶠ b) ]
·ᶠ-inv''        : (x       : ℚ) → (∥ Σ[ y ∈ ℚ ] x *ᶠ y ≡ 1ᶠ ∥ → [ x <ᶠ 0ᶠ ] ⊎ [ 0ᶠ <ᶠ x ]) × ([ x <ᶠ 0ᶠ ] ⊎ [ 0ᶠ <ᶠ x ] → ∥ Σ[ y ∈ ℚ ] x *ᶠ y ≡ 1ᶠ ∥)
≤-reflᶠ         : (a       : ℚ) → [ ¬ (a <ᶠ a) ]
≤-antisymᶠ      : (a b     : ℚ) → [ ¬ (b <ᶠ a) ] → [ ¬ (a <ᶠ b) ] → [ a ≡ₚ b ]
≤-transᶠ        : (a b x   : ℚ) → [ ¬ (b <ᶠ a) ] → [ ¬ (x <ᶠ b) ] → [ ¬ (x <ᶠ a) ]
is-minᶠ         : (x y z   : ℚ) → [ ¬ (minᶠ x y <ᶠ z) ⇔ ¬ (x <ᶠ z) ⊓ ¬ (y <ᶠ z) ]
is-maxᶠ         : (x y z   : ℚ) → [ ¬ (z <ᶠ maxᶠ x y) ⇔ ¬ (z <ᶠ x) ⊓ ¬ (z <ᶠ y) ]
+ᶠ-<ᶠ-ext       : (w x y z : ℚ) → [ (w +ᶠ x) <ᶠ (y +ᶠ z) ] → [ (w <ᶠ y) ⊔ (x <ᶠ z) ]
·ᶠ-preserves-<ᶠ : (x y z   : ℚ) → [ 0ᶠ <ᶠ z ] → [ x <ᶠ y ] → [ (x *ᶠ z) <ᶠ (y *ᶠ z) ]

<-irreflᶠ       = {!   !}
<-transᶠ        = {!   !}
<-cotransᶠ      = {!   !}
·ᶠ-inv''        = {!   !}
≤-reflᶠ         = {!   !}
≤-antisymᶠ      = {!   !}
≤-transᶠ        = {!   !}
is-minᶠ         = {!   !}
is-maxᶠ         = {!   !}
+ᶠ-<ᶠ-ext       = {!   !}
·ᶠ-preserves-<ᶠ = {!   !}

open PartiallyOrderedField

ℚF : PartiallyOrderedField {ℓ-zero} {ℓ-zero}
ℚF .PartiallyOrderedField.Carrier                  = ℚ
ℚF .PartiallyOrderedField.0f                       = 0 -- [ signed spos 0 , (1+ 0) ]'
ℚF .PartiallyOrderedField.1f                       = 1
ℚF .PartiallyOrderedField._+_                      = _+ᶠ_
ℚF .PartiallyOrderedField.-_                       = -ᶠ_
ℚF .PartiallyOrderedField._·_                      = _*ᶠ_
ℚF .PartiallyOrderedField.min                      = minᶠ
ℚF .PartiallyOrderedField.max                      = maxᶠ
ℚF .PartiallyOrderedField._<_                      = _<ᶠ_
ℚF .PartiallyOrderedField.is-PartiallyOrderedField = record
  { is-AlmostPartiallyOrderedField  = record
    { is-set               = isSetℚ
    ; is-CommRing          = record
      { is-set  = isSetℚ
      ; is-Ring = record
        { is-set    = isSetℚ
        ; +-AbGroup = record
          { is-set   = isSetℚ
          ; is-Group = record
            { is-set     = isSetℚ
            ; is-Monoid  = record
              { is-set       = isSetℚ
              ; is-Semigroup = record
                { is-set   = isSetℚ
                ; is-assoc = +-assocᶠ
                }
              ; is-identity  = λ x → +-identityʳ x , +-identityˡ x
              }
            ; is-inverse = λ x → (+-inverseʳ x) , (+-inverseˡ x)
            }
          ; is-comm  = +-commᶠ
          }
        ; ·-Monoid  = record
          { is-set       = isSetℚ
          ; is-Semigroup = record
            { is-set   = isSetℚ
            ; is-assoc = *-assocᶠ
            }
          ; is-identity  = λ x → *-identityʳ x , *-identityˡ x
          }
        ; is-dist   = λ x y z → sym (*-distribˡ x y z) , sym (*-distribʳ x y z)
        }
      ; ·-comm  = *-commᶠ
      }
    ; <-StrictPartialOrder = record
      { is-irrefl  = <-irreflᶠ
      ; is-trans   = <-transᶠ
      ; is-cotrans = <-cotransᶠ
      }
    ; ·-inv''              = ·ᶠ-inv''
    ; ≤-isLattice          = record
      { ≤-PartialOrder = record
        { is-refl    = ≤-reflᶠ
        ; is-antisym = ≤-antisymᶠ
        ; is-trans   = ≤-transᶠ
        }
      ; is-min         = is-minᶠ
      ; is-max         = is-maxᶠ
      }
    }
  ; +-<-ext                         = +ᶠ-<ᶠ-ext
  ; ·-preserves-<                   = ·ᶠ-preserves-<ᶠ
  }
  where open PartiallyOrderedField ℚF renaming (Carrier to ℚ')

-- 4.3 Archimedean property
--
-- We now define the notion of Archimedean ordered fields. We phrase this in terms of a certain
-- interpolation property, that can be defined from the fact that there is a unique morphism of
-- ordered fields from the rationals to every ordered field.

-- Lemma 4.3.3. For every ordered field (F, 0 F , 1 F , + F , · F , min F , max F , < F ), there is a unique morphism
-- i of ordered fields from the rationals to F . Additionally, i preserves < in the sense that for every q, r : Q
--   q < r ⇒ i (q) < F i (r ).

-- ∃! : ∀ {ℓ ℓ'} (A : Type ℓ) (B : A → Type ℓ') → Type (ℓ-max ℓ ℓ')
-- ∃! A B = isContr (Σ A B)

-- isContr' A = Σ[ x ∈ A ] (∀ y → x ≡ y)

-- ℚ-IsInitialObject : ∀(OF : OrderedField {ℓ} {ℓ'}) → isContr (OrderedFieldMor ℚOF OF)
-- ℚ-IsInitialObject OF = {!!} , {!!}

-- Definition 4.3.5. Let (F, 0 F , 1 F , + F , · F , min F , max F , < F ) be an ordered field, so that we get a
-- canonical morphism i : Q → F of ordered fields, as in Lemma 4.3.3. We say the ordered field
-- (F, 0 F , 1 F , + F , · F , min F , max F , < F ) is Archimedean if
--   (∀x, y : F )(∃q : Q)x < i (q) < y.

-- IsArchimedian : OrderedField {ℓ} {ℓ'} → Type (ℓ-max ℓ ℓ')
-- IsArchimedian OF = let (orderedfieldmor i _) = fst (ℚ-IsInitialObject OF)
--                        open OrderedField OF
--                        ℚ = OrderedField.Carrier ℚOF
--                    in ∀ x y → ∃[ q ∈ ℚ ] (x < i q) × (i q < y)

-- If the ordered field is clear from the context, we will identify rationals q : Q with their in-
-- clusion i (q) in the ordered field, so that we may also say that (F, 0 F , 1 F , + F , · F , min F , max F , < F )
-- is Archimedean if
-- (∀x, y : F )(∃q : Q)x < q < y.

-- Example 4.3.6. In an Archimedean ordered field, all numbers are bounded by rationals. That
-- is, for a given x : F , there exist q, r : Q with q < x < r .

-- Example-4-3-6 : (OF : OrderedField {ℓ} {ℓ'})
--               → IsArchimedian OF
--               → let open OrderedField OF renaming (Carrier to F)
--                     (orderedfieldmor i _) = fst (ℚ-IsInitialObject OF)
--                     ℚ = OrderedField.Carrier ℚOF
--                 in ∀(x : F) → (∃[ q ∈ ℚ ] i q < x) × (∃[ r ∈ ℚ ] x < i r)
-- -- This follows from applying the Archimedean property to x − 1 < x and x < x + 1.
-- Example-4-3-6 OF isArchimedian = {!!}

-- 4.4 Cauchy completeness of real numbers
--
-- We focus on Cauchy completeness, rather than Dedekind or Dedekind-MacNeille completeness,
-- as we will focus on the computation of digit expansions, for which Cauchy completeness suffices.

-- In order to state that an ordered field is Cauchy complete, we need to define when sequences
-- are Cauchy, and when a sequence has a limit. We also take the opportunity to define
-- the set of Cauchy reals in Definition 4.4.9. Surprisingly, this ordered field cannot be shown to
-- be Cauchy complete.

-- Fix an ordered field (F, 0 F , 1 F , + F , · F , min F , max F , < F ).
module _ {ℓ ℓ'} (OF : PartiallyOrderedField {ℓ} {ℓ'}) where
  open PartiallyOrderedField OF renaming (Carrier to F)
  -- module ℚ = PartiallyOrderedField ℚ
  {-
  open PartiallyOrderedField ℚOF using () renaming (_<_ to _<ᵣ_; 0f to 0ᵣ)
  ℚ = PartiallyOrderedField.Carrier ℚOF
  iᵣ = PartiallyOrderedFieldMor.fun (fst (ℚ-IsInitialObject OF))
  open import Data.Nat.Base using (ℕ) renaming (_≤_ to _≤ₙ_)

  -- We get a notion of distance, given by the absolute value as
  --   |x − y| := max F (x − y, −(x − y)).

  distance : ∀(x y : F) → F
  distance x y = max (x - y) (- (x - y))

  -- Consider a sequence x : N → F of elements of F . Classically, we may state that x is Cauchy as
  -- (∀ε : Q + )(∃N : N)(∀m, n : N)m, n ≥ N ⇒ |x m − x n | < ε,
  IsCauchy : (x : ℕ → F) → Type (ℓ-max ℓ' ℚℓ)
  IsCauchy x = ∀(ε : ℚ) → 0ᵣ <ᵣ ε → ∃[ N ∈ ℕ ] ∀(m n : ℕ) → N ≤ₙ m → N ≤ₙ n → distance (x m) (x n) < iᵣ ε

  -- We can interpret the quantifiers as in Definition 2.4.5.
  -- NOTE: this is the case, since `∃ A B = ∥ Σ A B ∥`

  -- Following a propositions-as-types interpretation, we may also state that x is Cauchy as the
  -- structure
  -- (Πε : Q + )(ΣN : N)(Πm, n : N)m, n ≥ N → |x m − x n | < ε.

  -- The dependent sum represents a choice of index N for every error ε, and so we have arrived at the following definition.

  -- Definition 4.4.1.
  -- For a sequence of reals x : N → F , a a modulus of Cauchy convergence is a map M : Q + → N such that
  -- (∀ε : Q + )(∀m, n : N)m, n ≥ M (ε) ⇒ |x m − x n | < ε.

  -- NOTE: do we already call these x "reals" ?
  -- NOTE: we are using the Modulus-type `((y : ℚ) → {{0ᵣ <ᵣ y}} → ℕ)` a few times and might abbreviate it

  IsModulusOfCauchyConvergence : (x : ℕ → F) → (M : ((y : ℚ) → {{0ᵣ <ᵣ y}} → ℕ)) → Type (ℓ-max ℓ' ℚℓ)
  IsModulusOfCauchyConvergence x M = ∀(ε : ℚ) → (p : 0ᵣ <ᵣ ε) → ∀(m n : ℕ)
                                   → let instance _ = p
                                     in M ε ≤ₙ m → M ε ≤ₙ n → distance (x m) (x n) < iᵣ ε

  -- In constructive mathematics, we typically use such sequences with modulus, for example,
  -- because they can sometimes be used to compute limits of Cauchy sequences, avoiding choice axioms.

  -- Definition 4.4.2.
  -- A number l : F is the limit of a sequence x : N → F if the sequence
  -- converges to l in the usual sense:
  --   (∀ε : Q + )(∃N : N)(∀n : N)n ≥ N ⇒ |x n − l | < ε.

  IsLimit : (x : ℕ → F) → (l : F) → Type (ℓ-max ℓ' ℚℓ)
  IsLimit x l = ∀(ε : ℚ) → (0ᵣ <ᵣ ε) → ∃[ N ∈ ℕ ] ∀(n : ℕ) → N ≤ₙ n → distance (x n) l < iᵣ ε

  -- Remark 4.4.3. We do not consider the statement of convergence in propositions-as-types
  --
  --   (Πε : Q + )(ΣN : N)(Πn : N)n ≥ N → |x n − l | < ε,
  --
  -- because if the sequence has a modulus of Cauchy convergence M, then λε.M (ε/2) is a
  -- modulus of convergence to the limit l, so that we get an element of the above type.

  -- Definition 4.4.4.
  -- The ordered field (F, 0 F , 1 F , + F , · F , min F , max F , < F ) is said to be Cauchy complete
  -- if for every sequence x with modulus of Cauchy convergence M, we have a limit of x.
  -- In other words, an ordered field is Cauchy complete iff from a sequence–modulus pair (x, M), we can compute a limit of x.

  IsCauchyComplete : Type (ℓ-max (ℓ-max ℓ ℓ') ℚℓ)
  IsCauchyComplete = (x : ℕ → F)
                   → (M : ((y : ℚ) → {{0ᵣ <ᵣ y}} → ℕ))
                   → IsModulusOfCauchyConvergence x M
                   → Σ[ l ∈ F ] IsLimit x l

  -- For the remainder of this section, additionally assume that F is Archimedean.
  module _ (isArchimedian : IsArchimedian OF) where

    -- Lemma 4.4.5.
    -- The type of limits of a fixed sequence x : N → F is a proposition.
    Lemma-4-4-5 : ∀(x : ℕ → F) → isProp (Σ[ l ∈ F ] IsLimit x l)
    -- Proof. This can be shown using the usual proof that limits are unique in Archimedean ordered fields, followed by an application of Lemma 2.6.20.
    Lemma-4-4-5 x = {!!}

    -- Corollary 4.4.6.
    -- Fix a given sequence x : N → F . Suppose that we know that there exists a
    -- limit of the sequence. Then we can compute a limit of the sequence.
    Corollary-4-4-6 : ∀(x : ℕ → F) → (∃[ l ∈ F ] IsLimit x l) → Σ[ l ∈ F ] IsLimit x l
    -- Proof. By applying the induction principle of propositional truncations of Definition 2.4.3.
    Corollary-4-4-6 x p = {!!} , {!!}

    -- Corollary 4.4.7.
    -- Fix a given sequence x : N → F . Suppose that, from a modulus of Cauchy
    -- convergence, we can compute a limit of the sequence. Then from the existence of the modulus of
    -- Cauchy convergence we can compute a limit of the sequence.
    Corollary-4-4-7 : (x : ℕ → F)
                    → ( (M : ((y : ℚ) → {{0ᵣ <ᵣ y}} → ℕ))
                      → (isMCC : IsModulusOfCauchyConvergence x M)
                      → Σ[ l ∈ F ] IsLimit x l
                      )
                    -----------------------------------------------------------------------
                    → ∃[ M ∈ ((y : ℚ) → {{0ᵣ <ᵣ y}} → ℕ) ] IsModulusOfCauchyConvergence x M
                    → Σ[ l ∈ F ] IsLimit x l
    -- Proof. By applying the induction principle of propositional truncations of Definition 2.4.3.
    Corollary-4-4-7 x f p = {!!}

    -- We can thus compute the limit of x : N → F as the number lim(x, p), where p is a proof
    -- that the limit of x exists. We will rather use the more traditional notation lim n→∞ x n for this
    -- number.

    -- Example 4.4.8 (Exponential function).
    -- In a Cauchy complete Archimedean ordered field, we can define an exponential function exp : F → F by
    --
    --    exp(x) = Σ_{k=0}^{∞} (xᵏ) / (k!)
    --
    -- For a given input x, we obtain the existence of a modulus of Cauchy convergence for the output from boundedness of
    -- x, that is, from the fact that (∃q, r : Q) q < x < r .

    exp : F → F
    exp x = {!!}

    Example-4-4-8 : ∀(x : F) → ∃[ M ∈ ((y : ℚ) → {{0ᵣ <ᵣ y}} → ℕ) ] IsModulusOfCauchyConvergence {!!} M
    Example-4-4-8 x with Example-4-3-6 OF isArchimedian x
    ... | q' , r' = let q : ∃[ q ∈ ℚ ] iᵣ q < x
                        q = q'
                        r : ∃[ r ∈ ℚ ] x < iᵣ r
                        r = r'
                    in {!!}

    -- The point of this work is that, because we have a single language for properties and struc-
    -- ture, we can see more precisely what is needed for certain computations. In the above example,
    -- we explicitly do not require that inputs come equipped with a modulus of Cauchy convergence,
    -- but rather that there exists such a modulus. On the one hand, we do need a modulus to obtain
    -- the limit, but as the limit value is independent of the chosen modulus, existence of such a
    -- modulus suffices.
  -}

-}


------------------------------------------------------------------------
-- Properties relating Any to various list functions
------------------------------------------------------------------------

module Data.List.Any.Properties where

open import Category.Monad
open import Data.Bool
open import Data.Bool.Properties
open import Data.Function
open import Data.List as List
open RawMonad List.monad
open import Data.List.Any as Any using (Any; here; there)
import Data.List.Equality as ListEq
open import Data.Product as Prod hiding (map)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂; [_,_]′)
open import Relation.Unary using (Pred; _⟨×⟩_; _⟨→⟩_)
open import Relation.Binary
import Relation.Binary.EqReasoning as EqReasoning
open import Relation.Binary.FunctionSetoid
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl; inspect; _with-≡_)

------------------------------------------------------------------------
-- Lemmas related to Any

-- Introduction (⁺) and elimination (⁻) rules for map.

map⁺ : ∀ {A B} {P : Pred B} {f : A → B} {xs} →
       Any (P ∘₀ f) xs → Any P (map f xs)
map⁺ (here p)  = here p
map⁺ (there p) = there $ map⁺ p

map⁻ : ∀ {A B} {P : Pred B} {f : A → B} {xs} →
       Any P (map f xs) → Any (P ∘₀ f) xs
map⁻ {xs = []}     ()
map⁻ {xs = x ∷ xs} (here p)  = here p
map⁻ {xs = x ∷ xs} (there p) = there $ map⁻ p

-- Introduction and elimination rules for _++_.

++⁺ˡ : ∀ {A} {P : Pred A} {xs ys} →
       Any P xs → Any P (xs ++ ys)
++⁺ˡ (here p)  = here p
++⁺ˡ (there p) = there (++⁺ˡ p)

++⁺ʳ : ∀ {A} {P : Pred A} xs {ys} →
       Any P ys → Any P (xs ++ ys)
++⁺ʳ []       p = p
++⁺ʳ (x ∷ xs) p = there (++⁺ʳ xs p)

++⁻ : ∀ {A} {P : Pred A} xs {ys} →
      Any P (xs ++ ys) → Any P xs ⊎ Any P ys
++⁻ []       p         = inj₂ p
++⁻ (x ∷ xs) (here p)  = inj₁ (here p)
++⁻ (x ∷ xs) (there p) = Sum.map there id (++⁻ xs p)

-- Introduction and elimination rules for return.

return⁺ : ∀ {A} {P : Pred A} {x} →
          P x → Any P (return x)
return⁺ = here

return⁻ : ∀ {A} {P : Pred A} {x} →
          Any P (return x) → P x
return⁻ (here p)   = p
return⁻ (there ())

-- Introduction and elimination rules for concat.

concat⁺ : ∀ {A} {P : Pred A} {xss} →
          Any (Any P) xss → Any P (concat xss)
concat⁺ (here p)           = ++⁺ˡ p
concat⁺ (there {x = xs} p) = ++⁺ʳ xs (concat⁺ p)

concat⁻ : ∀ {A} {P : Pred A} xss →
          Any P (concat xss) → Any (Any P) xss
concat⁻ []               ()
concat⁻ ([]       ∷ xss) p         = there $ concat⁻ xss p
concat⁻ ((x ∷ xs) ∷ xss) (here p)  = here (here p)
concat⁻ ((x ∷ xs) ∷ xss) (there p)
  with concat⁻ (xs ∷ xss) p
... | here  p′ = here (there p′)
... | there p′ = there p′

-- Introduction and elimination rules for _>>=_.

>>=⁺ : ∀ {A B P xs} {f : A → List B} →
       Any (Any P ∘₀ f) xs → Any P (xs >>= f)
>>=⁺ = concat⁺ ∘ map⁺

>>=⁻ : ∀ {A B P} xs {f : A → List B} →
       Any P (xs >>= f) → Any (Any P ∘₀ f) xs
>>=⁻ _ = map⁻ ∘ concat⁻ _

-- Introduction and elimination rules for _⊛_.

⊛⁺ : ∀ {A B P} {fs : List (A → B)} {xs} →
     Any (λ f → Any (P ∘₀ f) xs) fs → Any P (fs ⊛ xs)
⊛⁺ = >>=⁺ ∘ Any.map (>>=⁺ ∘ Any.map return⁺)

⊛⁺′ : ∀ {A B P Q} {fs : List (A → B)} {xs} →
      Any (P ⟨→⟩ Q) fs → Any P xs → Any Q (fs ⊛ xs)
⊛⁺′ pq p = ⊛⁺ (Any.map (λ pq → Any.map (λ {x} → pq {x}) p) pq)

⊛⁻ : ∀ {A B P} (fs : List (A → B)) xs →
     Any P (fs ⊛ xs) → Any (λ f → Any (P ∘₀ f) xs) fs
⊛⁻ fs xs = Any.map (Any.map return⁻ ∘ >>=⁻ xs) ∘ >>=⁻ fs

-- Introduction and elimination rules for _⊗_.

⊗⁺ : ∀ {A B P} {xs : List A} {ys : List B} →
     Any (λ x → Any (λ y → P (x , y)) ys) xs → Any P (xs ⊗ ys)
⊗⁺ = ⊛⁺ ∘′ ⊛⁺ ∘′ return⁺

⊗⁺′ : ∀ {A B} {P : Pred A} {Q : Pred B} {xs ys} →
      Any P xs → Any Q ys → Any (P ⟨×⟩ Q) (xs ⊗ ys)
⊗⁺′ p q = ⊗⁺ (Any.map (λ p → Any.map (λ q → (p , q)) q) p)

⊗⁻ : ∀ {A B P} (xs : List A) (ys : List B) →
     Any P (xs ⊗ ys) → Any (λ x → Any (λ y → P (x , y)) ys) xs
⊗⁻ _ _ = return⁻ ∘ ⊛⁻ _ _ ∘ ⊛⁻ _ _

⊗⁻′ : ∀ {A B} {P : Pred A} {Q : Pred B} xs ys →
      Any (P ⟨×⟩ Q) (xs ⊗ ys) → Any P xs × Any Q ys
⊗⁻′ _ _ pq =
  (Any.map (proj₁ ∘ proj₂ ∘ Any.satisfied) lem ,
   (Any.map proj₂ $ proj₂ (Any.satisfied lem)))
  where lem = ⊗⁻ _ _ pq

-- Any and any are related via T.

any⁺ : ∀ {A} (p : A → Bool) {xs} →
       Any (T ∘₀ p) xs → T (any p xs)
any⁺ p (here  px)          = proj₂ T-∨ (inj₁ px)
any⁺ p (there {x = x} pxs) with p x
... | true  = _
... | false = any⁺ p pxs

any⁻ : ∀ {A} (p : A → Bool) xs →
       T (any p xs) → Any (T ∘₀ p) xs
any⁻ p []       ()
any⁻ p (x ∷ xs) px∷xs with inspect (p x)
any⁻ p (x ∷ xs) px∷xs | true  with-≡ eq = here (proj₂ T-≡ $
                                                  PropEq.sym eq)
any⁻ p (x ∷ xs) px∷xs | false with-≡ eq with p x
any⁻ p (x ∷ xs) pxs   | false with-≡ refl | .false =
  there (any⁻ p xs pxs)

------------------------------------------------------------------------
-- Lemmas related to _∈_, parameterised on underlying equalities

module Membership₁ (S : Setoid) where

  open Any.Membership S
  private
    open module S = Setoid S using (_≈_)
    open module [M] = Any.Membership (ListEq.Equality.setoid S)
      using () renaming (_∈_ to _[∈]_; _⊆_ to _[⊆]_)
    open module M≡ = Any.Membership-≡
      using () renaming (_∈_ to _∈≡_; _⊆_ to _⊆≡_)

  -- Any is monotone.

  mono : ∀ {P xs ys} →
         P Respects _≈_ → xs ⊆ ys → Any P xs → Any P ys
  mono resp xs⊆ys pxs with find pxs
  ... | (x , x∈xs , px) = lose resp (xs⊆ys x∈xs) px

  -- _++_ is monotone.

  _++-mono_ : ∀ {xs₁ xs₂ ys₁ ys₂} →
              xs₁ ⊆ ys₁ → xs₂ ⊆ ys₂ → xs₁ ++ xs₂ ⊆ ys₁ ++ ys₂
  _++-mono_ {ys₁ = ys₁} xs₁⊆ys₁ xs₂⊆ys₂ =
    [ ++⁺ˡ ∘ xs₁⊆ys₁ , ++⁺ʳ ys₁ ∘ xs₂⊆ys₂ ]′ ∘ ++⁻ _

  -- _++_ is idempotent.

  ++-idempotent : ∀ {xs} → xs ++ xs ⊆ xs
  ++-idempotent = [ id , id ]′ ∘ ++⁻ _

  -- Introduction and elimination rules for concat.

  concat-∈⁺ : ∀ {x xs xss} →
              x ∈ xs → xs [∈] xss → x ∈ concat xss
  concat-∈⁺ x∈xs xs∈xss =
    concat⁺ (Any.map (λ xs≈ys → P.reflexive xs≈ys x∈xs) xs∈xss)
    where module P = Preorder ⊆-preorder

  concat-∈⁻ : ∀ {x} xss → x ∈ concat xss →
              ∃ λ xs → x ∈ xs × xs [∈] xss
  concat-∈⁻ xss x∈ = Prod.map id swap $ [M].find (concat⁻ xss x∈)

  -- concat is monotone.

  concat-mono : ∀ {xss yss} →
                xss [⊆] yss → concat xss ⊆ concat yss
  concat-mono {xss = xss} xss⊆yss x∈ with concat-∈⁻ xss x∈
  ... | (xs , x∈xs , xs∈xss) = concat-∈⁺ x∈xs (xss⊆yss xs∈xss)

  -- any is monotone.

  any-mono : ∀ p → (T ∘₀ p) Respects _≈_ →
             ∀ {xs ys} → xs ⊆ ys → T (any p xs) → T (any p ys)
  any-mono p resp xs⊆ys = any⁺ p ∘ mono resp xs⊆ys ∘ any⁻ p _

  -- Introduction and elimination rules for map-with-∈.

  map-with-∈-∈⁺ : ∀ {A} {xs : List A}
                  (f : ∀ {x} → x ∈≡ xs → S.carrier) {x} →
                  (x∈xs : x ∈≡ xs) → f x∈xs ∈ M≡.map-with-∈ xs f
  map-with-∈-∈⁺ f (here refl)  = here S.refl
  map-with-∈-∈⁺ f (there x∈xs) = there $ map-with-∈-∈⁺ (f ∘ there) x∈xs

  map-with-∈-∈⁻ : ∀ {A} {xs : List A}
                  (f : ∀ {x} → x ∈≡ xs → S.carrier) {fx∈xs} →
                  fx∈xs ∈ M≡.map-with-∈ xs f →
                  ∃ λ x → Σ (x ∈≡ xs) λ x∈xs → fx∈xs ≈ f x∈xs
  map-with-∈-∈⁻ {xs = []}     f ()
  map-with-∈-∈⁻ {xs = y ∷ xs} f (here fx≈)   = (y , here refl , fx≈)
  map-with-∈-∈⁻ {xs = y ∷ xs} f (there x∈xs) =
    Prod.map id (Prod.map there id) $ map-with-∈-∈⁻ (f ∘ there) x∈xs

  -- map-with-∈ is monotone.

  map-with-∈-mono :
    ∀ {A} {xs : List A} {f : ∀ {x} → x ∈≡ xs → S.carrier}
          {ys : List A} {g : ∀ {x} → x ∈≡ ys → S.carrier} →
    (xs⊆ys : xs ⊆≡ ys) →
    (∀ {x} (x∈xs : x ∈≡ xs) → f x∈xs ≈ g (xs⊆ys x∈xs)) →
    M≡.map-with-∈ xs f ⊆ M≡.map-with-∈ ys g
  map-with-∈-mono {f = f} {g = g} xs⊆ys f≈g {fx∈xs} fx∈xs∈
    with map-with-∈-∈⁻ f fx∈xs∈
  ... | (x , x∈xs , fx∈xs≈) =
    Any.map (λ {y} g[xs⊆ys-x∈xs]≈y → begin
               fx∈xs           ≈⟨ fx∈xs≈ ⟩
               f x∈xs          ≈⟨ f≈g x∈xs ⟩
               g (xs⊆ys x∈xs)  ≈⟨ g[xs⊆ys-x∈xs]≈y ⟩
               y               ∎) $
            map-with-∈-∈⁺ g (xs⊆ys x∈xs)
    where open EqReasoning S

module Membership₂ (S₁ S₂ : Setoid) where

  private
    open module S₁ = Setoid S₁ using () renaming (_≈_ to _≈₁_)
    open module S₂ = Setoid S₂ using () renaming (_≈_ to _≈₂_)
    module L₂      = ListEq.Equality S₂
    open module M₁ = Any.Membership S₁
      using () renaming (_∈_ to _∈₁_; _⊆_ to _⊆₁_)
    open module M₂ = Any.Membership S₂
      using () renaming (_∈_ to _∈₂_; _⊆_ to _⊆₂_)
    open module M₁₂ = Any.Membership (S₁ ⇨ S₂)
      using () renaming (_∈_ to _∈₁₂_; _⊆_ to _⊆₁₂_)
    open Any.Membership (S₁ ×-setoid S₂)
      using () renaming (_⊆_ to _⊆₁,₂_)

  -- Introduction and elimination rules for map.

  map-∈⁺ : ∀ (f : S₁ ⟶ S₂) {x xs} →
          x ∈₁ xs → f ⟨$⟩ x ∈₂ map (_⟨$⟩_ f) xs
  map-∈⁺ f = map⁺ ∘ Any.map (pres f)

  map-∈⁻ : ∀ {f fx} xs →
           fx ∈₂ map f xs → ∃ λ x → x ∈₁ xs × fx ≈₂ f x
  map-∈⁻ _ fx∈ = M₁.find (map⁻ fx∈)

  -- map is monotone.

  map-mono : ∀ (f : S₁ ⟶ S₂) {xs ys} →
             xs ⊆₁ ys → map (_⟨$⟩_ f) xs ⊆₂ map (_⟨$⟩_ f) ys
  map-mono f xs⊆ys fx∈ with map-∈⁻ _ fx∈
  ... | (x , x∈ , eq) = Any.map (S₂.trans eq) (map-∈⁺ f (xs⊆ys x∈))

  -- Introduction and elimination rules for _>>=_.

  >>=-∈⁺ : ∀ (f : S₁ ⟶ L₂.setoid) {x y xs} →
           x ∈₁ xs → y ∈₂ f ⟨$⟩ x → y ∈₂ (xs >>= _⟨$⟩_ f)
  >>=-∈⁺ f x∈xs y∈fx =
    >>=⁺ (Any.map (flip M₂.∈-resp-list-≈ y∈fx ∘ pres f) x∈xs)

  >>=-∈⁻ : ∀ (f : S₁ ⟶ L₂.setoid) {y} xs →
           y ∈₂ (xs >>= _⟨$⟩_ f) → ∃ λ x → x ∈₁ xs × y ∈₂ f ⟨$⟩ x
  >>=-∈⁻ f xs y∈ = M₁.find (>>=⁻ xs y∈)

  -- _>>=_ is monotone.

  >>=-mono : ∀ (f g : S₁ ⟶ L₂.setoid) {xs ys} →
             xs ⊆₁ ys → (∀ {x} → f ⟨$⟩ x ⊆₂ g ⟨$⟩ x) →
             (xs >>= _⟨$⟩_ f) ⊆₂ (ys >>= _⟨$⟩_ g)
  >>=-mono f g {xs} xs⊆ys f⊆g z∈ with >>=-∈⁻ f xs z∈
  ... | (x , x∈xs , z∈fx) = >>=-∈⁺ g (xs⊆ys x∈xs) (f⊆g z∈fx)

  -- Introduction and elimination rules for _⊛_.

  private

    infixl 4 _⟨⊛⟩_

    _⟨⊛⟩_ : List (S₁ ⟶ S₂) → List S₁.carrier → List S₂.carrier
    fs ⟨⊛⟩ xs = map _⟨$⟩_ fs ⊛ xs

  ⊛-∈⁺ : ∀ f {fs x xs} →
         f ∈₁₂ fs → x ∈₁ xs → f ⟨$⟩ x ∈₂ fs ⟨⊛⟩ xs
  ⊛-∈⁺ _ f∈fs x∈xs =
    ⊛⁺′ (map⁺ (Any.map (λ f≈g x≈y → f≈g x≈y) f∈fs)) x∈xs

  ⊛-∈⁻ : ∀ fs xs {fx} → fx ∈₂ fs ⟨⊛⟩ xs →
         ∃₂ λ f x → f ∈₁₂ fs × x ∈₁ xs × fx ≈₂ f ⟨$⟩ x
  ⊛-∈⁻ fs xs fx∈ with M₁₂.find $ map⁻ (⊛⁻ (map _⟨$⟩_ fs) xs fx∈)
  ... | (f , f∈fs , x∈) with M₁.find x∈
  ...   | (x , x∈xs , fx≈fx) = (f , x , f∈fs , x∈xs , fx≈fx)

  -- _⊛_ is monotone.

  _⊛-mono_ : ∀ {fs gs xs ys} →
             fs ⊆₁₂ gs → xs ⊆₁ ys → fs ⟨⊛⟩ xs ⊆₂ gs ⟨⊛⟩ ys
  _⊛-mono_ {fs = fs} {xs = xs} fs⊆gs xs⊆ys fx∈ with ⊛-∈⁻ fs xs fx∈
  ... | (f , x , f∈fs , x∈xs , fx≈fx) =
    Any.map (S₂.trans fx≈fx) $ ⊛-∈⁺ f (fs⊆gs {f} f∈fs) (xs⊆ys x∈xs)

  -- _⊗_ is monotone.

  _⊗-mono_ : ∀ {xs₁ xs₂ ys₁ ys₂} →
             xs₁ ⊆₁ ys₁ → xs₂ ⊆₂ ys₂ → (xs₁ ⊗ xs₂) ⊆₁,₂ (ys₁ ⊗ ys₂)
  _⊗-mono_ {xs₁ = xs₁} {xs₂} xs₁⊆ys₁ xs₂⊆ys₂ {x , y} x,y∈
    with ⊗⁻′ {P = _≈₁_ x} {Q = _≈₂_ y} xs₁ xs₂ x,y∈
  ... | (x∈ , y∈) = ⊗⁺′ (xs₁⊆ys₁ x∈) (xs₂⊆ys₂ y∈)

------------------------------------------------------------------------
-- Lemmas related to the variant of _∈_ which is defined using
-- propositional equality

module Membership-≡ where

  open Any.Membership-≡
  private
    module P {A} = ListEq.PropositionalEquality {A}
    open module M₁ {A} = Membership₁ (PropEq.setoid A) public
      using (_++-mono_; ++-idempotent;
             map-with-∈-∈⁺; map-with-∈-∈⁻; map-with-∈-mono)
    open module M₂ {A} {B} =
      Membership₂ (PropEq.setoid A) (PropEq.setoid B) public
      using (map-∈⁻)

  -- Any is monotone.

  mono : ∀ {A xs ys} {P : Pred A} → xs ⊆ ys → Any P xs → Any P ys
  mono {P = P} = M₁.mono (PropEq.subst P)

  -- Introduction and elimination rules for concat.

  concat-∈⁺ : ∀ {A} {x : A} {xs xss} →
              x ∈ xs → xs ∈ xss → x ∈ concat xss
  concat-∈⁺ x∈xs = M₁.concat-∈⁺ x∈xs ∘ Any.map P.reflexive

  concat-∈⁻ : ∀ {A} {x : A} xss →
              x ∈ concat xss → ∃ λ xs → x ∈ xs × xs ∈ xss
  concat-∈⁻ xss x∈ =
    Prod.map id (Prod.map id (Any.map P.≈⇒≡)) $ M₁.concat-∈⁻ xss x∈

  -- concat is monotone.

  concat-mono : ∀ {A} {xss yss : List (List A)} →
                xss ⊆ yss → concat xss ⊆ concat yss
  concat-mono xss⊆yss =
    M₁.concat-mono (Any.map P.reflexive ∘ xss⊆yss ∘ Any.map P.≈⇒≡)

  -- any is monotone.

  any-mono : ∀ {A} (p : A → Bool) {xs ys} →
             xs ⊆ ys → T (any p xs) → T (any p ys)
  any-mono p = M₁.any-mono p (PropEq.subst (T ∘₀ p))

  -- Introduction rule for map.

  map-∈⁺ : ∀ {A B} {f : A → B} {x xs} →
           x ∈ xs → f x ∈ map f xs
  map-∈⁺ {f = f} = M₂.map-∈⁺ (PropEq.→-to-⟶ f)

  -- map is monotone.

  map-mono : ∀ {A B} {f : A → B} {xs ys} →
             xs ⊆ ys → map f xs ⊆ map f ys
  map-mono {f = f} = M₂.map-mono (PropEq.→-to-⟶ f)

  -- Introduction and elimination rules for _>>=_.

  private

    [→-to-⟶] : ∀ {A B} → (A → List B) →
               PropEq.setoid A ⟶
               ListEq.Equality.setoid (PropEq.setoid B)
    [→-to-⟶] f =
      record { _⟨$⟩_ = f; pres = P.reflexive ∘ PropEq.cong f }

  >>=-∈⁺ : ∀ {A B} (f : A → List B) {x y xs} →
           x ∈ xs → y ∈ f x → y ∈ (xs >>= f)
  >>=-∈⁺ f = M₂.>>=-∈⁺ ([→-to-⟶] f)

  >>=-∈⁻ : ∀ {A B} (f : A → List B) {y} xs →
           y ∈ (xs >>= f) → ∃ λ x → x ∈ xs × y ∈ f x
  >>=-∈⁻ f = M₂.>>=-∈⁻ ([→-to-⟶] f)

  -- _>>=_ is monotone.

  _>>=-mono_ : ∀ {A B} {f g : A → List B} {xs ys} →
               xs ⊆ ys → (∀ {x} → f x ⊆ g x) →
               (xs >>= f) ⊆ (ys >>= g)
  _>>=-mono_ {f = f} {g} = M₂.>>=-mono ([→-to-⟶] f) ([→-to-⟶] g)

  -- Introduction and elimination rules for _⊛_.

  ⊛-∈⁺ : ∀ {A B} {fs : List (A → B)} {xs f x} →
         f ∈ fs → x ∈ xs → f x ∈ fs ⊛ xs
  ⊛-∈⁺ f∈fs x∈xs =
    ⊛⁺′ (Any.map (λ f≡g x≡y → PropEq.cong₂ _$_ f≡g x≡y) f∈fs) x∈xs

  ⊛-∈⁻ : ∀ {A B} (fs : List (A → B)) xs {fx} →
         fx ∈ fs ⊛ xs → ∃₂ λ f x → f ∈ fs × x ∈ xs × fx ≡ f x
  ⊛-∈⁻ fs xs fx∈ with find $ ⊛⁻ fs xs fx∈
  ... | (f , f∈fs , x∈) with find x∈
  ...   | (x , x∈xs , fx≡fx) = (f , x , f∈fs , x∈xs , fx≡fx)

  -- _⊛_ is monotone.

  _⊛-mono_ : ∀ {A B} {fs gs : List (A → B)} {xs ys} →
             fs ⊆ gs → xs ⊆ ys → fs ⊛ xs ⊆ gs ⊛ ys
  _⊛-mono_ {fs = fs} {xs = xs} fs⊆gs xs⊆ys fx∈ with ⊛-∈⁻ fs xs fx∈
  ... | (f , x , f∈fs , x∈xs , refl) =
    ⊛-∈⁺ (fs⊆gs f∈fs) (xs⊆ys x∈xs)

  -- Introduction and elimination rules for _⊗_.

  private

    lemma₁ : ∀ {A B} {p q : A × B} →
             (p ⟨ _≡_ on₁ proj₁ ⟩₁ q) × (p ⟨ _≡_ on₁ proj₂ ⟩₁ q) → p ≡ q
    lemma₁ {p = (x , y)} {q = (.x , .y)} (refl , refl) = refl

    lemma₂ : ∀ {A B} {p q : A × B} →
             p ≡ q → (p ⟨ _≡_ on₁ proj₁ ⟩₁ q) × (p ⟨ _≡_ on₁ proj₂ ⟩₁ q)
    lemma₂ = < PropEq.cong proj₁ , PropEq.cong proj₂ >

  ⊗-∈⁺ : ∀ {A B} {xs : List A} {ys : List B} {x y} →
         x ∈ xs → y ∈ ys → (x , y) ∈ (xs ⊗ ys)
  ⊗-∈⁺ x∈xs y∈ys = Any.map lemma₁ (⊗⁺′ x∈xs y∈ys)

  ⊗-∈⁻ : ∀ {A B} (xs : List A) (ys : List B) {p} →
         p ∈ (xs ⊗ ys) → proj₁ p ∈ xs × proj₂ p ∈ ys
  ⊗-∈⁻ xs ys = ⊗⁻′ xs ys ∘ Any.map lemma₂

  -- _⊗_ is monotone.

  _⊗-mono_ : ∀ {A B} {xs₁ ys₁ : List A} {xs₂ ys₂ : List B} →
             xs₁ ⊆ ys₁ → xs₂ ⊆ ys₂ → (xs₁ ⊗ xs₂) ⊆ (ys₁ ⊗ ys₂)
  _⊗-mono_ xs₁⊆ys₁ xs₂⊆ys₂ {p} =
    Any.map lemma₁ ∘ M₂._⊗-mono_ xs₁⊆ys₁ xs₂⊆ys₂ {p} ∘ Any.map lemma₂


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality

postulate _↦_ : ∀ {a} {A : Set a} → A → A → Set
{-# BUILTIN REWRITE _↦_ #-}

postulate
  T  : (Set → Set → Set) → Set
  T₀ : Set

module _ (F : Set → Set) where

  postulate rew : T (λ X Y → F X) ↦ T₀

  {-# REWRITE rew #-}

  test : T (λ X Y → F X) ≡ T₀
  test = refl


{- # --without-K # -}

open import Data.Unit
open import Data.Empty
open import Data.Nat
open import Data.Sum as Sum
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality
open import Relation.Unary
open import Relation.Binary
open import Relation.Binary using (module IsEquivalence; Setoid; module Setoid)
open ≡-Reasoning
import Relation.Binary.HeterogeneousEquality as HE
open import Relation.Binary.HeterogeneousEquality using (_≅_; refl)

-- | Polynomials
data Poly : Set₁ where
  _▹_ : (A : Set) (B : A → Set) → Poly

-- | Interpretation of polynomials as functor, object part.
⟦_⟧ : Poly → Set → Set
⟦ A ▹ B ⟧ X = Σ[ a ∈ A ] (B a → X)

-- | Interpretation of polynomials as functor, morphism part.
⟦_⟧₁ : (P : Poly) → ∀{X Y} → (X → Y) → (⟦ P ⟧ X → ⟦ P ⟧ Y)
⟦ A ▹ B ⟧₁ f (a , α) = (a , (λ x → f (α x)))

-- | Finite trees over the signature determined by P with one free variable.
data _* (P : Poly) : Set where
  sup : ⟦ P ⟧ (P *) ⊎ ⊤ → P *

-- | Inverse of sup.
sup⁻¹ : ∀{P} → P * → ⟦ P ⟧ (P *) ⊎ ⊤
sup⁻¹ (sup x) = x

_extends_ : ∀{P} → P * → P * → Set
_extends_ {A ▹ B} (sup (inj₁ (a' , β))) (sup (inj₁ (a , α)))
  = Σ[ e ∈ a' ≡ a ] (∀ (b : B a') → (β b) extends α (subst B e b))
sup (inj₂ _) extends sup (inj₁ _) = ⊥
sup (inj₁ x) extends sup (inj₂ _) = ⊤
sup (inj₂ _) extends sup (inj₂ _) = ⊥

PreApprox : Poly → Set
PreApprox P = ℕ → P *

converges : ∀{P} → PreApprox P → Set
converges u = ∀ n → u (1 + n) extends u n

non-empty : ∀{P} → P * → Set
non-empty (sup (inj₁ x)) = ⊤
non-empty (sup (inj₂ _)) = ⊥

root : ∀{A B} → (t : (A ▹ B) *) → non-empty t → A
root (sup (inj₁ x)) p = proj₁ x
root (sup (inj₂ y)) ()

branch : ∀{A B} → (t : (A ▹ B) *) → (p : non-empty t) → B (root t p) → (A ▹ B) *
branch (sup (inj₁ x)) p  b = proj₂ x b
branch (sup (inj₂ y)) () b

_∞ : Poly → Set
P ∞ = Σ[ u ∈ PreApprox P ] (non-empty (u 0) × converges u)

-- | If u₀ is non-empty and u converges, then uₙ is non-empty for every n.
ne₀→all-ne : ∀{P} →
  (u : PreApprox P) → non-empty (u 0) → converges u →
  ∀ n → non-empty (u n)
ne₀→all-ne u ne₀ conv zero = ne₀
ne₀→all-ne {A ▹ B} u ne₀ conv (suc n)
  with u (suc n)   | u n          | conv n
... | sup (inj₁ x) | y            | z       = tt
... | sup (inj₂ x) | sup (inj₁ y) | ()
... | sup (inj₂ x) | sup (inj₂ y) | ()

-- | If t₂ extends t₁ and they are both non-empty, then they have the same
-- root labels.
ext→root≡ : ∀{A B} →
            (t₁ t₂ : (A ▹ B) *)
            (ne₁ : non-empty t₁)
            (ne₂ : non-empty t₂)
            (e : t₂ extends t₁) →
            root t₁ ne₁ ≡ root t₂ ne₂
ext→root≡ (sup (inj₁ (a , α))) (sup (inj₁ (b , β))) ne₁ ne₂ e = sym (proj₁ e)
ext→root≡ (sup (inj₁ x))       (sup (inj₂ tt))      ne₁ ()  e
ext→root≡ (sup (inj₂ tt))      (sup (inj₁ y))       ()  ne₂ e
ext→root≡ (sup (inj₂ tt))      (sup (inj₂ tt))      ne₁ ne₂ ()

-- | The roots of the first two trees in a converging sequence have the same
-- label. This is used as base case in conv→suc-roots≡.
conv→roots-0-1≡ : ∀{A B} →
  (u : PreApprox (A ▹ B))
  (ne : non-empty (u 0))
  (c : converges u) →
  root (u 0) ne ≡ root (u 1) (ne₀→all-ne u ne c 1)
conv→roots-0-1≡ {A} {B} u ne c
  = ext→root≡ (u 0) (u 1) ne (ne₀→all-ne u ne c 1) (c 0)

-- | The roots of two successive trees in a converging sequence have the same
-- label. We use this in the induction step in conv→roots≡.
conv→suc-roots≡ : ∀{A B} →
  (u : PreApprox (A ▹ B))
  (ne : non-empty (u 0))
  (c : converges u) →
  ∀ n → root (u n) (ne₀→all-ne u ne c n)
        ≡ root (u (1 + n)) (ne₀→all-ne u ne c (1 + n))
conv→suc-roots≡ u ne c zero = conv→roots-0-1≡ u ne c
conv→suc-roots≡ u ne c (suc n)
  = ext→root≡ (u (1 + n))
              (u (2 + n))
              (ne₀→all-ne u ne c (1 + n))
              (ne₀→all-ne u ne c (2 + n))
              (c (suc n))

-- | The root of any tree in a converging sequence has the same label as
-- the root of the first tree.
conv→roots≡ : ∀{A B} →
  (u : PreApprox (A ▹ B))
  (ne : non-empty (u 0))
  (c : converges u) →
  ∀ n → root (u 0) ne ≡ root (u n) (ne₀→all-ne u ne c n)
conv→roots≡ u ne c zero = refl
conv→roots≡ u ne c (suc n)
  = trans (conv→roots≡ u ne c n) (conv→suc-roots≡ u ne c n)

-- | All trees in a converging sequence have the same root label.
conv→all-roots≡ : ∀{A B} →
  (u : PreApprox (A ▹ B))
  (ne : non-empty (u 0))
  (c : converges u) →
  ∀ n m → root (u n) (ne₀→all-ne u ne c n) ≡ root (u m) (ne₀→all-ne u ne c m)
conv→all-roots≡ u ne c n m =
  begin
    root (u n) (ne₀→all-ne u ne c n)
  ≡⟨ sym (conv→roots≡ u ne c n) ⟩
    root (u 0) ne
  ≡⟨ conv→roots≡ u ne c m ⟩
    root (u m) (ne₀→all-ne u ne c m)
  ∎

-- | If t₁ is non-empty and t₂ extends t₁, then all branches of t₂ are
-- non-empty. This shows that _extends_ defines a strict order.
conv+ne₀→ne-branch : ∀{A B} →
  (t₁ t₂ : (A ▹ B)*)
  (ne₁ : non-empty t₁)
  (ne₂ : non-empty t₂)
  (e : t₂ extends t₁) →
  ∀ b → non-empty (branch t₂ ne₂ b)
conv+ne₀→ne-branch (sup (inj₁ (a , α))) (sup (inj₁ (.a , β))) ne₁ ne₂ (refl , q) b
  with α b          | β b           | q b
... | sup (inj₁ x)  | sup (inj₁ y)  | z  = tt
... | sup (inj₁ x)  | sup (inj₂ tt) | ()
... | sup (inj₂ tt) | sup (inj₁ y)  | z  = tt
... | sup (inj₂ tt) | sup (inj₂ tt) | ()
conv+ne₀→ne-branch (sup (inj₁ x)) (sup (inj₂ tt)) ne₁ () e b
conv+ne₀→ne-branch (sup (inj₂ tt)) t₂             () ne₂ e b

-- | If t₂ extends t₂, then all branches of t₂ extend the corresponding one
-- of t₁.
conv→branch-conv : ∀{A B} →
  (t₁ t₂ : (A ▹ B)*)
  (ne₁ : non-empty t₁)
  (ne₂ : non-empty t₂)
  (e : t₂ extends t₁) →
  ∀ b b' → b ≅ b' →
  (branch t₂ ne₂ b) extends
  (branch t₁ ne₁ b')
conv→branch-conv (sup (inj₁ (a'' , α)))
                 (sup (inj₁ (.a'' , β))) ne₁ ne₂ (refl , t) b .b refl = t b
conv→branch-conv (sup (inj₁ x)) (sup (inj₂ tt)) ne₁ () e b b' p
conv→branch-conv (sup (inj₂ tt)) (sup y) () ne₂ e b b' p

-- | Technical lemma:
-- The equality proofs for substitution by root equality are the same.
root-conv≡ : ∀ {A B} →
  (u : PreApprox (A ▹ B))
  (ne : non-empty (u 0))
  (c : converges u) →
  ∀ b n → (subst B (conv→roots≡ u ne c (1 + n)) b)
          ≅ (subst B (conv→roots≡ u ne c n) b)
root-conv≡ {A} {B} u ne c b n =
  HE.trans (HE.≡-subst-removable B (conv→roots≡ u ne c (1 + n)) b)
           (HE.sym (HE.≡-subst-removable B (conv→roots≡ u ne c n) b))

-- | Coalgebra structure on P∞.
out : ∀{P} → P ∞ → ⟦ P ⟧ (P ∞)
out {A ▹ B} (u , ne , conv) = (a , α)
  where
    a : A
    a = root (u 0) ne

    u' : B a → PreApprox (A ▹ B)
    u' b n = branch (u (1 + n))
                    (ne₀→all-ne u ne conv (1 + n))
                    (subst B (conv→roots≡ u ne conv (1 + n)) b)

    ne' : (b : B a) → non-empty (u' b 0)
    ne' b =
      conv+ne₀→ne-branch (u 0) (u 1) ne
                            (ne₀→all-ne u ne conv 1)
                            (conv 0)
                            (subst B (conv→roots≡ u ne conv 1) b)

    conv' : (b : B a) → converges (u' b)
    conv' b n = conv→branch-conv (u (1 + n)) (u (2 + n))
                                  (ne₀→all-ne u ne conv (1 + n))
                                  (ne₀→all-ne u ne conv (2 + n))
                                  (conv (1 + n))
                                  (subst B (conv→roots≡ u ne conv (2 + n)) b)
                                  (subst B (conv→roots≡ u ne conv (1 + n)) b)
                                  (root-conv≡ u ne conv b (suc n))

    α : B a → (A ▹ B) ∞
    α b = (u' b , ne' b , conv' b)

-- | Get root label.
root∞ : ∀{A B} → (A ▹ B) ∞ → A
root∞ t = proj₁ (out t)

-- | Get branches below root.
branch∞ : ∀{A B} → (t : (A ▹ B) ∞) → B (root∞ t) → (A ▹ B) ∞
branch∞ t = proj₂ (out t)

-- | Corecursion principle for P∞.
corec : ∀{P} {C : Set} → (C → ⟦ P ⟧ C) → (C → P ∞)
corec {A ▹ B} {C} f c = (u , ne , conv)
  where
    u-aux : C → PreApprox (A ▹ B)
    u-aux c zero =
      let (a , α) = f c
      in sup (inj₁ (a , (λ x → sup (inj₂ tt))))
    u-aux c (suc n) =
      let (a , α) = f c
      in sup (inj₁ (a , (λ b → u-aux (α b) n)))

    u : PreApprox (A ▹ B)
    u = u-aux c

    ne : non-empty (u 0)
    ne = tt

    conv-aux : (c : C) → converges (u-aux c)
    conv-aux c zero    = (refl , (λ b → tt))
    conv-aux c (suc n) = (refl , (λ b → conv-aux (proj₂ (f c) b) n))

    conv : converges u
    conv = conv-aux c


record R : Set₁ where
  field
    A : Set

  B : Set
  B = A

  field
    C : Set

  D : Set
  D = A → B → C