open import Nat
open import Prelude
open import dynamics-core
open import contexts
open import preservation

module complete-preservation where
  -- if you substitute a complete term into a complete term, the result is
  -- still complete.
  cp-subst : ∀ {x d1 d2} →
             d1 dcomplete →
             d2 dcomplete →
             ([ d2 / x ] d1) dcomplete
  cp-subst {x = y} (DCVar {x = x}) dc2 with natEQ x y
  cp-subst DCVar dc2 | Inl refl = dc2
  cp-subst DCVar dc2 | Inr x₂ = DCVar
  cp-subst DCNum dc2 = DCNum
  cp-subst (DCPlus dc1 dc2) dc3 = DCPlus (cp-subst dc1 dc3) (cp-subst dc2 dc3)
  cp-subst {x = x} (DCLam {x = y} dc1 x₂) dc2 with natEQ y x
  cp-subst (DCLam dc1 x₃) dc2 | Inl refl = DCLam dc1 x₃
  cp-subst (DCLam dc1 x₃) dc2 | Inr x₂ = DCLam (cp-subst dc1 dc2) x₃
  cp-subst (DCAp dc1 dc2) dc3 = DCAp (cp-subst dc1 dc3) (cp-subst dc2 dc3)
  cp-subst (DCCast dc1 x₁ x₂) dc2 = DCCast (cp-subst dc1 dc2) x₁ x₂
  cp-subst (DCInl x dc1) dc2 = DCInl x (cp-subst dc1 dc2)
  cp-subst (DCInr x dc1) dc2 = DCInr x (cp-subst dc1 dc2)
  cp-subst {x = x} (DCCase {x = y} {y = z} dc dc1 dc3) dc2
    with natEQ y x | natEQ z x
  ... | Inl refl | Inl refl = DCCase (cp-subst dc dc2) dc1 dc3
  ... | Inl refl | Inr z≠x  = DCCase (cp-subst dc dc2 ) dc1 (cp-subst dc3 dc2)
  ... | Inr y≠x  | Inl refl = DCCase (cp-subst dc dc2) (cp-subst dc1 dc2) dc3
  ... | Inr y≠x  | Inr z≠x  = DCCase (cp-subst dc dc2) (cp-subst dc1 dc2) (cp-subst dc3 dc2)
  cp-subst (DCPair dc1 dc3) dc2 = DCPair (cp-subst dc1 dc2) (cp-subst dc3 dc2)
  cp-subst (DCFst dc1) dc2 = DCFst (cp-subst dc1 dc2)
  cp-subst (DCSnd dc1) dc2 = DCSnd (cp-subst dc1 dc2)

  -- this just lets me pull the particular x out of a derivation; it's not
  -- bound in any of the constructors explicitly since it's only in the
  -- lambda case; so below i have no idea how else to get a name for it,
  -- instead of leaving it dotted in the context
  lem-proj : {x : Nat} {d : ihexp} { τ : htyp} →
             (·λ x ·[ τ ] d) dcomplete →
             Σ[ y ∈ Nat ] (y == x)
  lem-proj {x} (DCLam dc x₁) = x , refl

  -- a complete well typed term steps to a complete term.
  cp-rhs : ∀{d τ d' Δ} →
           d dcomplete →
           Δ , ∅ ⊢ d :: τ →
           d ↦ d' →
           d' dcomplete
  cp-rhs dc TANum (Step FHOuter () FHOuter)
  cp-rhs (DCPlus dc dc₁) (TAPlus wt wt₁) (Step FHOuter (ITPlus refl) FHOuter) = DCNum
  cp-rhs (DCPlus dc dc₁) (TAPlus wt wt₁) (Step (FHPlus1 x) x₁ (FHPlus1 x₂))
    with cp-rhs dc wt (Step x x₁ x₂)
  ... | q = DCPlus q dc₁
  cp-rhs (DCPlus dc dc₁) (TAPlus wt wt₁) (Step (FHPlus2 x) x₁ (FHPlus2 x₂))
    with cp-rhs dc₁ wt₁ (Step x x₁ x₂)
  ... | q = DCPlus dc q
  cp-rhs dc (TAVar x₁) stp = abort (somenotnone (! x₁))
  cp-rhs dc (TALam _ wt) (Step FHOuter () FHOuter)
  -- this case is a little more complicated than it feels like it ought to
  -- be, just from horsing around with agda implicit variables.
  cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) with lem-proj dc
  cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl with cp-subst {x = x} dc dc₁
  ... | qq with natEQ x x
  cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl | DCLam qq x₁ | Inl refl = cp-subst qq dc₁
  cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step FHOuter ITLam FHOuter) | x , refl | qq | Inr x₁ = abort (x₁ refl)
  cp-rhs (DCAp (DCCast dc (TCArr x x₁) (TCArr x₂ x₃)) dc₁) (TAAp (TACast wt x₄) wt₁) (Step FHOuter ITApCast FHOuter) = DCCast (DCAp dc (DCCast dc₁ x₂ x)) x₁ x₃
  cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step (FHAp1 x) x₁ (FHAp1 x₂)) = DCAp (cp-rhs dc wt (Step x x₁ x₂)) dc₁
  cp-rhs (DCAp dc dc₁) (TAAp wt wt₁) (Step (FHAp2 x) x₁ (FHAp2 x₂)) = DCAp dc (cp-rhs dc₁ wt₁ (Step x x₁ x₂))
  cp-rhs () (TAEHole x x₁) stp
  cp-rhs () (TANEHole x wt x₁) stp
  cp-rhs (DCCast dc x x₁) (TACast wt x₂) (Step FHOuter ITCastID FHOuter) = dc
  cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITCastSucceed x₃) FHOuter)
  cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITCastFail x₃ x₄ x₅) FHOuter)
  cp-rhs (DCCast dc x ()) (TACast wt x₂) (Step FHOuter (ITGround x₃) FHOuter)
  cp-rhs (DCCast dc () x₁) (TACast wt x₂) (Step FHOuter (ITExpand x₃) FHOuter)
  cp-rhs (DCCast dc x x₁) (TACast wt x₂) (Step (FHCast x₃) x₄ (FHCast x₅)) = DCCast (cp-rhs dc wt (Step x₃ x₄ x₅)) x x₁
  cp-rhs () (TAFailedCast wt x x₁ x₂) stp
  cp-rhs (DCInl x dc) (TAInl wt) (Step (FHInl x₁) x₂ (FHInl x₃)) = DCInl x (cp-rhs dc wt (Step x₁ x₂ x₃))
  cp-rhs (DCInr x dc) (TAInr wt) (Step (FHInr x₁) x₂ (FHInr x₃)) = DCInr x (cp-rhs dc wt (Step x₁ x₂ x₃))
  cp-rhs (DCCase (DCInl x₂ dc) dc₁ dc₂) (TACase wt x wt₁ x₁ wt₂) (Step FHOuter ITCaseInl FHOuter) = cp-subst dc₁ dc
  cp-rhs (DCCase (DCInr x₂ dc) dc₁ dc₂) (TACase wt x wt₁ x₁ wt₂) (Step FHOuter ITCaseInr FHOuter) = cp-subst dc₂ dc
  cp-rhs (DCCase (DCCast dc (TCSum x₂ x₄) (TCSum x₃ x₅)) dc₁ dc₂) (TACase wt x wt₁ x₁ wt₂) (Step FHOuter ITCaseCast FHOuter) =  DCCase dc (cp-subst dc₁ (DCCast DCVar x₂ x₃)) (cp-subst dc₂ (DCCast DCVar x₄ x₅))
  cp-rhs (DCCase dc dc₁ dc₂) (TACase wt x wt₁ x₁ wt₂) (Step (FHCase x₂) x₃ (FHCase x₄)) = DCCase (cp-rhs dc wt (Step x₂ x₃ x₄)) dc₁ dc₂
  cp-rhs (DCInl x dc) (TAInl dc₁) (Step FHOuter () FHOuter)
  cp-rhs (DCInr x dc) (TAInr dc₁) (Step FHOuter () FHOuter)
  cp-rhs (DCPair dc dc₁) (TAPair dc₂ dc₃) (Step (FHPair1 x₁) x₂ (FHPair1 x₃)) = DCPair (cp-rhs dc dc₂ (Step x₁ x₂ x₃)) dc₁
  cp-rhs (DCPair dc dc₁) (TAPair dc₂ dc₃) (Step (FHPair2 x₁) x₂ (FHPair2 x₃)) = DCPair dc (cp-rhs dc₁ dc₃ (Step x₁ x₂ x₃))
  cp-rhs (DCFst (DCPair dc dc₃)) (TAFst dc₁) (Step FHOuter ITFstPair FHOuter) = dc
  cp-rhs (DCFst (DCCast dc (TCProd x x₁) (TCProd x₃ x₄))) (TAFst dc₁) (Step FHOuter ITFstCast FHOuter) = DCCast (DCFst dc) x x₃
  cp-rhs (DCFst dc) (TAFst dc₁) (Step (FHFst x₁) x₂ (FHFst x₃)) = DCFst (cp-rhs dc dc₁ (Step x₁ x₂ x₃))
  cp-rhs (DCSnd (DCPair dc dc₂)) (TASnd dc₁) (Step FHOuter ITSndPair FHOuter) = dc₂
  cp-rhs (DCSnd (DCCast dc (TCProd x x₁) (TCProd x₂ x₃))) (TASnd dc₁) (Step FHOuter ITSndCast FHOuter) = DCCast (DCSnd dc) x₁ x₃
  cp-rhs (DCSnd dc) (TASnd dc₁) (Step (FHSnd x₁) x₂ (FHSnd x₃)) = DCSnd (cp-rhs dc dc₁ (Step x₁ x₂ x₃))

  -- this is the main result of this file.
  complete-preservation : ∀{d τ d' Δ} →
                          binders-unique d →
                          d dcomplete →
                          Δ , ∅ ⊢ d :: τ →
                          d ↦ d' →
                          (Δ , ∅ ⊢ d' :: τ) × (d' dcomplete)
  complete-preservation bd dc wt stp = preservation bd wt stp , cp-rhs dc wt stp


{-# OPTIONS --cubical #-}

module Data.Binary.PerformanceTests.Conversion where

open import Prelude
open import Data.Binary.Definition
open import Data.Binary.Conversion using (⟦_⇓⟧)
-- open import Data.Binary.Conversion.Strict
open import Data.Binary.Conversion.Fast

-- one-thousand : 𝔹
-- one-thousand = 2ᵇ 1ᵇ 1ᵇ 2ᵇ 1ᵇ 2ᵇ 2ᵇ 2ᵇ 2ᵇ 0ᵇ

-- f : 𝔹
-- f = one-thousand

n : ℕ
n = 5000000

-- The actual performance test (uncomment and time how long it takes to type-check)
-- _ : ⟦ ⟦ n ⇑⟧ ⇓⟧ ≡ n
-- _ = refl


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

-- We do not parameterize this module since we do not have access to _+_ or _*_
-- for the fields that we want (real numbers)
open import Level using (Level)

open import Relation.Binary.PropositionalEquality hiding (Extensionality)
open ≡-Reasoning

open import Data.Nat using (ℕ) renaming (_+_ to _+ᴺ_)
open import Data.Nat.Properties
open import Data.Vec using (Vec; []; _∷_; _++_; take; drop; map; replicate)
open import Data.Vec.Properties

open import Function using (id)

open import FLA.Algebra.Structures
open import FLA.Algebra.Properties.Field
open import FLA.Algebra.LinearAlgebra
open import FLA.Algebra.LinearAlgebra.Properties

module FLA.Algebra.LinearMap where

private
  variable
    ℓ : Level
    A : Set ℓ
    m n p q : ℕ

-- A linear map from one vector field to another
record _⊸_ {ℓ : Level} {A : Set ℓ} ⦃ F : Field A ⦄ (m n : ℕ) : Set ℓ where
  field
    f : (Vec A m → Vec A n)

    -- Additivity
    f[u+v]≡f[u]+f[v] : (u v : Vec A m) → f (u +ⱽ v) ≡ f u +ⱽ f v

    -- Homogeneity
    f[c*v]≡c*f[v] : (c : A) → (v : Vec A m) → f (c ∘ⱽ v) ≡ c ∘ⱽ (f v)

infixr 1 _⊸_

-- A convenient syntax if a particular set needs to be specified.
_—_⊸_ : {ℓ : Level} (m : ℕ) (A : Set ℓ) (n : ℕ) ⦃ F : Field A ⦄ → Set ℓ
m — A ⊸ n  = _⊸_ {A = A} m n
infixr 1 _—_⊸_

module _ ⦃ F : Field A ⦄ where
  open Field F
  open _⊸_

  _·ˡᵐ_ : m ⊸ n → Vec A m → Vec A n
  _·ˡᵐ_ LM = f LM

  private
    +ˡᵐ-linearity : (g h : m ⊸ n) → (u v x y : Vec A m)
                  → g ·ˡᵐ (u +ⱽ v) +ⱽ h ·ˡᵐ (x +ⱽ y) ≡
                     g ·ˡᵐ u +ⱽ h ·ˡᵐ x +ⱽ (g ·ˡᵐ v +ⱽ h ·ˡᵐ y)
    +ˡᵐ-linearity g h u v x y rewrite
        f[u+v]≡f[u]+f[v] g u v
      | f[u+v]≡f[u]+f[v] h x y
      | (+ⱽ-assoc (g ·ˡᵐ u) (g ·ˡᵐ v) (h ·ˡᵐ x +ⱽ h ·ˡᵐ y))
      | sym (+ⱽ-assoc (g ·ˡᵐ v) (h ·ˡᵐ x) (h ·ˡᵐ y))
      | +ⱽ-comm (g ·ˡᵐ v) (h ·ˡᵐ x)
      | (+ⱽ-assoc (h ·ˡᵐ x) (g ·ˡᵐ v) (h ·ˡᵐ y))
      | sym (+ⱽ-assoc (g ·ˡᵐ u) (h ·ˡᵐ x) (g ·ˡᵐ v +ⱽ h ·ˡᵐ y))
      = refl

    +-homogeneity : (g h : m ⊸ n) → (c : A) (u v : Vec A m)
                  → g ·ˡᵐ (c ∘ⱽ u) +ⱽ h ·ˡᵐ (c ∘ⱽ v) ≡
                     c ∘ⱽ (g ·ˡᵐ u +ⱽ h ·ˡᵐ v)
    +-homogeneity g h c u v rewrite
          f[c*v]≡c*f[v] g c u
        | f[c*v]≡c*f[v] h c v
        | sym (∘ⱽ-distr-+ⱽ c (g ·ˡᵐ u) (h ·ˡᵐ v))
        = refl

  _+ˡᵐ_ : m ⊸ n → m ⊸ n → m ⊸ n
  g +ˡᵐ h = record
    { f = λ v → g ·ˡᵐ v +ⱽ h ·ˡᵐ v
    ; f[u+v]≡f[u]+f[v] = λ u v → +ˡᵐ-linearity g h u v u v
    ; f[c*v]≡c*f[v] = λ c v → +-homogeneity g h c v v
    }

  _-ˡᵐ_ : m ⊸ n → m ⊸ n → m ⊸ n
  g -ˡᵐ h = record
    { f = λ v → g ·ˡᵐ v -ⱽ h ·ˡᵐ v
    ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]' g h
    ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]' g h
    }
    where
      f[u+v]≡f[u]+f[v]' : (g h : m ⊸ n) → (u v : Vec A m)
                        → g ·ˡᵐ (u +ⱽ v) -ⱽ h ·ˡᵐ (u +ⱽ v) ≡
                           g ·ˡᵐ u -ⱽ h ·ˡᵐ u +ⱽ (g ·ˡᵐ v -ⱽ h ·ˡᵐ v)
      f[u+v]≡f[u]+f[v]' g h u v = begin
          g ·ˡᵐ (u +ⱽ v) -ⱽ h ·ˡᵐ (u +ⱽ v)
        ≡⟨ cong (g ·ˡᵐ (u +ⱽ v) +ⱽ_) (-ⱽ≡-1ᶠ∘ⱽ (h ·ˡᵐ (u +ⱽ v))) ⟩
          g ·ˡᵐ (u +ⱽ v) +ⱽ (- 1ᶠ) ∘ⱽ (h ·ˡᵐ (u +ⱽ v))
        ≡⟨ cong (λ x → g ·ˡᵐ (u +ⱽ v) +ⱽ (- 1ᶠ) ∘ⱽ x) (f[u+v]≡f[u]+f[v] h u v) ⟩
          g ·ˡᵐ (u +ⱽ v) +ⱽ (- 1ᶠ) ∘ⱽ (h ·ˡᵐ u +ⱽ h ·ˡᵐ v)
        ≡⟨ cong (g ·ˡᵐ (u +ⱽ v) +ⱽ_) (∘ⱽ-distr-+ⱽ (- 1ᶠ) (h ·ˡᵐ u) (h ·ˡᵐ v)) ⟩
          g ·ˡᵐ (u +ⱽ v) +ⱽ ((- 1ᶠ) ∘ⱽ h ·ˡᵐ u +ⱽ (- 1ᶠ) ∘ⱽ h ·ˡᵐ v)
        ≡⟨ cong₂ (λ x y → g ·ˡᵐ (u +ⱽ v) +ⱽ (x +ⱽ y))
                 (sym (f[c*v]≡c*f[v] h (- 1ᶠ) u))
                 (sym (f[c*v]≡c*f[v] h (- 1ᶠ) v)) ⟩
          g ·ˡᵐ (u +ⱽ v) +ⱽ (h ·ˡᵐ ((- 1ᶠ) ∘ⱽ u) +ⱽ h ·ˡᵐ ((- 1ᶠ) ∘ⱽ v))
        ≡⟨ cong (g ·ˡᵐ (u +ⱽ v) +ⱽ_)
                (sym (f[u+v]≡f[u]+f[v] h ((- 1ᶠ) ∘ⱽ u) ((- 1ᶠ) ∘ⱽ v))) ⟩
          g ·ˡᵐ (u +ⱽ v) +ⱽ (h ·ˡᵐ ((- 1ᶠ) ∘ⱽ u +ⱽ (- 1ᶠ) ∘ⱽ v))
        ≡⟨ +ˡᵐ-linearity g h u v ((- 1ᶠ) ∘ⱽ u) ((- 1ᶠ) ∘ⱽ v) ⟩
          g ·ˡᵐ u +ⱽ h ·ˡᵐ ((- 1ᶠ) ∘ⱽ u) +ⱽ (g ·ˡᵐ v +ⱽ h ·ˡᵐ ((- 1ᶠ) ∘ⱽ v))
        ≡⟨ cong₂ (λ x y → g ·ˡᵐ u +ⱽ x +ⱽ (g ·ˡᵐ v +ⱽ y))
          (trans (f[c*v]≡c*f[v] h ((- 1ᶠ)) u) (sym (-ⱽ≡-1ᶠ∘ⱽ (h ·ˡᵐ u))))
          (trans (f[c*v]≡c*f[v] h ((- 1ᶠ)) v) (sym (-ⱽ≡-1ᶠ∘ⱽ (h ·ˡᵐ v)))) ⟩
          g ·ˡᵐ u -ⱽ h ·ˡᵐ u +ⱽ (g ·ˡᵐ v -ⱽ h ·ˡᵐ v)
        ∎

      f[c*v]≡c*f[v]' : (g h : m ⊸ n) → (c : A) (v : Vec A m)
                     → g ·ˡᵐ (c ∘ⱽ v) -ⱽ h ·ˡᵐ (c ∘ⱽ v) ≡
                        c ∘ⱽ (g ·ˡᵐ v -ⱽ h ·ˡᵐ v)
      f[c*v]≡c*f[v]' g h c v = begin
          g ·ˡᵐ (c ∘ⱽ v) -ⱽ h ·ˡᵐ (c ∘ⱽ v)
        ≡⟨ cong (g ·ˡᵐ (c ∘ⱽ v) +ⱽ_)
          (trans (-ⱽ≡-1ᶠ∘ⱽ (h ·ˡᵐ (c ∘ⱽ v)))
                 (sym (f[c*v]≡c*f[v] h (- 1ᶠ) (c ∘ⱽ v)))) ⟩
          g ·ˡᵐ (c ∘ⱽ v) +ⱽ h ·ˡᵐ ((- 1ᶠ) ∘ⱽ (c ∘ⱽ v))
        ≡⟨ cong (λ x → g ·ˡᵐ (c ∘ⱽ v) +ⱽ h ·ˡᵐ x) (∘ⱽ-comm (- 1ᶠ) c v) ⟩
          g ·ˡᵐ (c ∘ⱽ v) +ⱽ h ·ˡᵐ (c ∘ⱽ ((- 1ᶠ) ∘ⱽ v))
        ≡⟨ +-homogeneity g h c v ((- 1ᶠ) ∘ⱽ v) ⟩
          c ∘ⱽ (g ·ˡᵐ v +ⱽ h ·ˡᵐ ((- 1ᶠ) ∘ⱽ v))
        ≡⟨ cong (λ x → c ∘ⱽ (g ·ˡᵐ v +ⱽ x))
                (trans (f[c*v]≡c*f[v] h (- 1ᶠ) v) (sym (-ⱽ≡-1ᶠ∘ⱽ (h ·ˡᵐ v)))) ⟩
          c ∘ⱽ (g ·ˡᵐ v -ⱽ h ·ˡᵐ v)
        ∎

  _*ˡᵐ_ : n ⊸ p → m ⊸ n → m ⊸ p
  g *ˡᵐ h = record
    { f = λ v → g ·ˡᵐ (h ·ˡᵐ v)
    ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]' g h
    ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]' g h
    }
    where
      f[u+v]≡f[u]+f[v]' : (g : n ⊸ p) (h : m ⊸ n)
                        → (u v : Vec A m)
                        → g ·ˡᵐ (h ·ˡᵐ (u +ⱽ v)) ≡
                           g ·ˡᵐ (h ·ˡᵐ u) +ⱽ g ·ˡᵐ (h ·ˡᵐ v)
      f[u+v]≡f[u]+f[v]' g h u v rewrite
          f[u+v]≡f[u]+f[v] h u v
        | f[u+v]≡f[u]+f[v] g (f h u) (f h v)
        = refl

      f[c*v]≡c*f[v]' : (g : n ⊸ p) (h : m ⊸ n)
                     → (c : A) (v : Vec A m)
                     → g ·ˡᵐ (h ·ˡᵐ (c ∘ⱽ v)) ≡ c ∘ⱽ g ·ˡᵐ (h ·ˡᵐ v)
      f[c*v]≡c*f[v]' g h c v rewrite
          f[c*v]≡c*f[v] h c v
        | f[c*v]≡c*f[v] g c (h ·ˡᵐ v)
        = refl

  -- vertical stack forward operator
  _—ˡᵐ_ : p ⊸ m → p ⊸ n → p ⊸ (m +ᴺ n)
  T —ˡᵐ B =
    record
      { f = λ v →  T ·ˡᵐ v ++ B ·ˡᵐ v
      ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]' T B
      ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]' T B
      }
    where
      f[u+v]≡f[u]+f[v]' : (T : p ⊸ m) (B : p ⊸ n)
                        → (u v : Vec A p)
                        → T ·ˡᵐ (u +ⱽ v) ++ B ·ˡᵐ (u +ⱽ v) ≡
                          (T ·ˡᵐ u ++ B ·ˡᵐ u) +ⱽ (T ·ˡᵐ v ++ B ·ˡᵐ v)
      f[u+v]≡f[u]+f[v]' T B u v rewrite
          f[u+v]≡f[u]+f[v] T u v
        | f[u+v]≡f[u]+f[v] B u v
        | +ⱽ-flip-++ (T ·ˡᵐ u) (T ·ˡᵐ v) (B ·ˡᵐ u) (B ·ˡᵐ v)
        = refl

      f[c*v]≡c*f[v]' : (T : p ⊸ m) (B : p ⊸ n)
                     → (c : A) → (v : Vec A p)
                     → T ·ˡᵐ (c ∘ⱽ v) ++ B ·ˡᵐ (c ∘ⱽ v) ≡
                        c ∘ⱽ (T ·ˡᵐ v ++ B ·ˡᵐ v)
      f[c*v]≡c*f[v]' T B c v rewrite
          f[c*v]≡c*f[v] T c v
        | f[c*v]≡c*f[v] B c v
        | ∘ⱽ-distr-++ c (T ·ˡᵐ v) (B ·ˡᵐ v)
        = refl

  -- horizontal stack forward operator
  _|ˡᵐ_ : m ⊸ p → n ⊸ p → (m +ᴺ n) ⊸ p
  _|ˡᵐ_ {m} {n} {p} T B =
    record
      { f = λ v → T ·ˡᵐ (take m v) +ⱽ B ·ˡᵐ (drop m v)
      ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]' T B
      ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]' T B
      }
      where
        f[u+v]≡f[u]+f[v]' : {m n p : ℕ}
                          → (T : m ⊸ p) (B : n ⊸ p)
                          → (u v : Vec A (m +ᴺ n))
                          → T ·ˡᵐ take m (u +ⱽ v) +ⱽ B ·ˡᵐ drop m (u +ⱽ v) ≡
                             T ·ˡᵐ take m u +ⱽ B ·ˡᵐ drop m u +ⱽ
                             (T ·ˡᵐ take m v +ⱽ B ·ˡᵐ drop m v)
        f[u+v]≡f[u]+f[v]' {m} T B u v = begin
            T ·ˡᵐ (take m (u +ⱽ v)) +ⱽ B ·ˡᵐ (drop m (u +ⱽ v))
          ≡⟨ cong₂ (λ x y → T ·ˡᵐ x +ⱽ B ·ˡᵐ y)
                   (take-distr-zipWith _+_ u v) (drop-distr-zipWith _+_ u v)⟩
            T ·ˡᵐ (take m u +ⱽ take m v) +ⱽ B ·ˡᵐ (drop m u +ⱽ drop m v)
          ≡⟨ cong₂ _+ⱽ_ (f[u+v]≡f[u]+f[v] T (take m u) (take m v))
                        (f[u+v]≡f[u]+f[v] B (drop m u) (drop m v)) ⟩
            T ·ˡᵐ take m u +ⱽ T ·ˡᵐ take m v +ⱽ
            (B ·ˡᵐ drop m u +ⱽ B ·ˡᵐ drop m v)
          ≡⟨ sym (+ⱽ-assoc (T ·ˡᵐ take m u +ⱽ T ·ˡᵐ take m v)
                           (B ·ˡᵐ drop m u) (B ·ˡᵐ drop m v)) ⟩
            T ·ˡᵐ take m u +ⱽ T ·ˡᵐ take m v +ⱽ B ·ˡᵐ drop m u +ⱽ
            B ·ˡᵐ drop m v
          ≡⟨ cong (_+ⱽ B ·ˡᵐ drop m v) (+ⱽ-assoc (T ·ˡᵐ take m u)
                                                 (T ·ˡᵐ take m v)
                                                 (B ·ˡᵐ drop m u)) ⟩
            T ·ˡᵐ take m u +ⱽ (T ·ˡᵐ take m v +ⱽ B ·ˡᵐ drop m u) +ⱽ
            B ·ˡᵐ drop m v
          ≡⟨ cong (λ x → (T ·ˡᵐ take m u +ⱽ x) +ⱽ B ·ˡᵐ drop m v)
                  (+ⱽ-comm (T ·ˡᵐ take m v) (B ·ˡᵐ drop m u)) ⟩
            (T ·ˡᵐ take m u +ⱽ ((B ·ˡᵐ drop m u +ⱽ T ·ˡᵐ take m v))) +ⱽ
            B ·ˡᵐ drop m v
          ≡⟨ cong (_+ⱽ B ·ˡᵐ drop m v) (sym (+ⱽ-assoc (T ·ˡᵐ take m u)
                                                      (B ·ˡᵐ drop m u)
                                                      (T ·ˡᵐ take m v))) ⟩
            (T ·ˡᵐ take m u +ⱽ B ·ˡᵐ drop m u +ⱽ T ·ˡᵐ take m v) +ⱽ
            B ·ˡᵐ drop m v
          ≡⟨ +ⱽ-assoc (T ·ˡᵐ take m u +ⱽ B ·ˡᵐ drop m u)
                      (T ·ˡᵐ take m v) (B ·ˡᵐ drop m v) ⟩
            T ·ˡᵐ take m u +ⱽ B ·ˡᵐ drop m u +ⱽ
            (T ·ˡᵐ take m v +ⱽ B ·ˡᵐ drop m v)
          ∎

        f[c*v]≡c*f[v]' : {m n p : ℕ}
                       → (T : m ⊸ p) → (B : n ⊸ p)
                       → (c : A) (v : Vec A (m +ᴺ n))
                       → T ·ˡᵐ take m (c ∘ⱽ v) +ⱽ B ·ˡᵐ drop m (c ∘ⱽ v) ≡
                          c ∘ⱽ (T ·ˡᵐ take m v +ⱽ B ·ˡᵐ drop m v)
        f[c*v]≡c*f[v]' {m} T B c v = begin
            T ·ˡᵐ take m (c ∘ⱽ v) +ⱽ B ·ˡᵐ drop m (c ∘ⱽ v)
          ≡⟨ cong₂ (λ x y → T ·ˡᵐ x +ⱽ B ·ˡᵐ y) (take-distr-map (c *_) m v)
                                                 (drop-distr-map (c *_) m v) ⟩
            T ·ˡᵐ (c ∘ⱽ take m v) +ⱽ B ·ˡᵐ (c ∘ⱽ drop m v)
          ≡⟨ cong₂ _+ⱽ_ (f[c*v]≡c*f[v] T c (take m v))
                        (f[c*v]≡c*f[v] B c (drop m v)) ⟩
            c ∘ⱽ (T ·ˡᵐ take m v) +ⱽ c ∘ⱽ (B ·ˡᵐ drop m v)
          ≡⟨ sym (∘ⱽ-distr-+ⱽ c (T ·ˡᵐ take m v) (B ·ˡᵐ drop m v)) ⟩
            c ∘ⱽ (T ·ˡᵐ take m v +ⱽ B ·ˡᵐ drop m v)
          ∎

  -- block diagonal forward and adjoint operator
  _/ˡᵐ_ : m ⊸ n → p ⊸ q → (m +ᴺ p) ⊸ (n +ᴺ q)
  _/ˡᵐ_ {m} {n} {p} {q} T B =
    record
      { f = λ v → T ·ˡᵐ (take m v) ++ B ·ˡᵐ (drop m v)
      ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]' T B
      ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]' T B
      }
      where
        f[u+v]≡f[u]+f[v]' : {m n p q : ℕ}
                          → (T : m ⊸ n) (B : p ⊸ q)
                          → (u v : Vec A (m +ᴺ p))
                          → T ·ˡᵐ (take m (u +ⱽ v)) ++ B ·ˡᵐ (drop m (u +ⱽ v)) ≡
                             (T ·ˡᵐ (take m u) ++ B ·ˡᵐ (drop m u)) +ⱽ
                             (T ·ˡᵐ (take m v) ++ B ·ˡᵐ (drop m v))
        f[u+v]≡f[u]+f[v]' {m} T B u v =
          begin
              T ·ˡᵐ take m (u +ⱽ v) ++ B ·ˡᵐ drop m (u +ⱽ v)
            ≡⟨ cong₂ (λ x y → T ·ˡᵐ x ++ B ·ˡᵐ y)
                     (take-distr-zipWith _+_ u v) (drop-distr-zipWith _+_ u v)⟩
              T ·ˡᵐ (take m u +ⱽ take m v) ++ B ·ˡᵐ (drop m u +ⱽ drop m v)
            ≡⟨ cong₂ _++_ (f[u+v]≡f[u]+f[v] T (take m u) (take m v))
                          (f[u+v]≡f[u]+f[v] B (drop m u) (drop m v)) ⟩
              (T ·ˡᵐ take m u +ⱽ T ·ˡᵐ take m v) ++
              (B ·ˡᵐ drop m u +ⱽ B ·ˡᵐ drop m v)
            ≡⟨ sym (+ⱽ-flip-++ (T ·ˡᵐ take m u) (T ·ˡᵐ take m v)
                               (B ·ˡᵐ drop m u) (B ·ˡᵐ drop m v)) ⟩
              (T ·ˡᵐ take m u ++ B ·ˡᵐ drop m u) +ⱽ
              (T ·ˡᵐ take m v ++ B ·ˡᵐ drop m v)
          ∎

        f[c*v]≡c*f[v]' : {m n p q : ℕ}
                       → (T : m ⊸ n) (B : p ⊸ q)
                       → (c : A) (v : Vec A (m +ᴺ p))
                       → T ·ˡᵐ (take m (c ∘ⱽ v)) ++ B ·ˡᵐ (drop m (c ∘ⱽ v)) ≡
                          c ∘ⱽ (T ·ˡᵐ (take m v) ++ B ·ˡᵐ (drop m v))
        f[c*v]≡c*f[v]' {m} T B c v =
          begin
              T ·ˡᵐ take m (c ∘ⱽ v) ++ B ·ˡᵐ drop m (c ∘ⱽ v)
            ≡⟨ cong₂ (λ x y → T ·ˡᵐ x ++ B ·ˡᵐ y) (take-distr-map (c *_) m v)
                                                   (drop-distr-map (c *_) m v) ⟩
              T ·ˡᵐ (c ∘ⱽ take m v) ++ B ·ˡᵐ (c ∘ⱽ (drop m v))
            ≡⟨ cong₂ _++_ (f[c*v]≡c*f[v] T c (take m v))
                          (f[c*v]≡c*f[v] B c (drop m v)) ⟩
              c ∘ⱽ (T ·ˡᵐ take m v) ++ c ∘ⱽ (B ·ˡᵐ drop m v)
            ≡⟨ sym (∘ⱽ-distr-++ c (T ·ˡᵐ take m v) (B ·ˡᵐ drop m v)) ⟩
              c ∘ⱽ (T ·ˡᵐ take m v ++ B ·ˡᵐ drop m v)
          ∎

  -- Multiply by a constant
  _∘ˡᵐ_ : A → n ⊸ m → n ⊸ m
  c ∘ˡᵐ m =
    record
      { f = λ v → c ∘ⱽ m ·ˡᵐ v
      ; f[u+v]≡f[u]+f[v] = λ u v → trans (cong (c ∘ⱽ_) (f[u+v]≡f[u]+f[v] m u v))
                                         (∘ⱽ-distr-+ⱽ c (m ·ˡᵐ u) (m ·ˡᵐ v))
      ; f[c*v]≡c*f[v] = λ c₁ v → trans (cong (c ∘ⱽ_) (f[c*v]≡c*f[v] m c₁ v))
                                       (∘ⱽ-comm c c₁ (f m v))
      }

  -- Choose 20 since function application is assumed higher than almost anything
  infixr 20 _·ˡᵐ_

  infixl 2 _—ˡᵐ_
  infixl 3 _|ˡᵐ_
  infixl 4 _/ˡᵐ_
  infixl 6 _+ˡᵐ_
  infixl 6 _-ˡᵐ_
  infixl 7 _*ˡᵐ_
  infixl 10 _∘ˡᵐ_

-- Example LinearMap values ---------------------------------------------------

module _ ⦃ F : Field A ⦄ where
  open Field F

  idₗₘ : n ⊸ n
  idₗₘ = record
    { f = id
    ; f[u+v]≡f[u]+f[v] = λ u v → refl
    ; f[c*v]≡c*f[v] = λ c v → refl
    }

  diagₗₘ : Vec A n → n ⊸ n
  diagₗₘ d = record
    { f = d *ⱽ_
    ; f[u+v]≡f[u]+f[v] = *ⱽ-distr-+ⱽ d
    ; f[c*v]≡c*f[v] = λ c v → *ⱽ∘ⱽ≡∘ⱽ*ⱽ c d v
    }

  1ₗₘ : n ⊸ m
  1ₗₘ = record
    { f = λ v → replicate (sum v)
    ; f[u+v]≡f[u]+f[v] = f[u+v]≡f[u]+f[v]
    ; f[c*v]≡c*f[v] = f[c*v]≡c*f[v]
    }
    where
      f[u+v]≡f[u]+f[v] : (u v : Vec A n)
                       → replicate (sum (u +ⱽ v)) ≡
                          replicate (sum u) +ⱽ replicate (sum v)
      f[u+v]≡f[u]+f[v] u v = begin
        replicate (sum (u +ⱽ v))      ≡⟨ cong replicate (sum-distr-+ⱽ u v) ⟩
        replicate ((sum u) + (sum v)) ≡⟨ replicate-distr-+ (sum u) (sum v) ⟩
        replicate (sum u) +ⱽ replicate (sum v) ∎

      f[c*v]≡c*f[v] : (c : A) (v : Vec A n)
                    → replicate (sum (c ∘ⱽ v)) ≡ c ∘ⱽ replicate (sum v)
      f[c*v]≡c*f[v] c v = begin
        replicate (sum (c ∘ⱽ v)) ≡⟨ cong replicate (sum[c∘ⱽv]≡c*sum[v] c v) ⟩
        replicate (c * sum v)    ≡⟨ replicate[a*b]≡a∘ⱽreplicate[b] c (sum v) ⟩
        c ∘ⱽ replicate (sum v)   ∎

  -- This could be defined as 0ᶠ ∘ˡᵐ allonesₗₘ, but then that would make
  -- some later proofs more difficult, since they would then have more than
  -- just replicate 0ᶠ to replace zerosₗₘ with.
  0ₗₘ : n ⊸ m
  0ₗₘ =  record
    { f = λ v → replicate 0ᶠ
    ; f[u+v]≡f[u]+f[v] = λ u v → sym (trans (zipWith-replicate _+_ 0ᶠ 0ᶠ)
                                             (cong replicate 0ᶠ+0ᶠ≡0ᶠ))
    ; f[c*v]≡c*f[v] = λ c v → sym (c∘ⱽ0ᶠⱽ≡0ᶠⱽ c)
    }


{-# OPTIONS --cubical-compatible --rewriting --confluence-check #-}

open import Issue1719.Common
open import Issue1719.Spans
open import Issue1719.Pushouts

module _ {d : Span} {l} {P : Pushout d → Set l}
  (left* : (a : Span.A d) → P (left a))
  (right* : (b : Span.B d) → P (right b))
  (glue* : (c : Span.C d) → left* (Span.f d c) == right* (Span.g d c) [ P ↓ glue c ]) where

  test : (a : Span.A d) → Pushout-elim {P = P} left* right* glue* (left a) ↦ left* a
  test a = idr


module BBHeap.DropLast {A : Set}(_≤_ : A → A → Set) where

open import BBHeap _≤_
open import BBHeap.Compound _≤_
open import BBHeap.Properties _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.Empty
open import Data.Sum renaming (_⊎_ to _∨_)

mutual
  dropLast : {b : Bound} → BBHeap b → BBHeap b
  dropLast leaf = leaf
  dropLast (left b≤x l⋘r)
      with l⋘r | lemma-dropLast⋘ l⋘r
  ... | lf⋘ | _ = leaf
  ... | ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | inj₁ (≃nd .x≤y₁ .x≤y₂ .l₁⋘r₁ .l₂⋘r₂ l₁≃r₁ _ l₁≃l₂) =
               let l≃r = ≃nd x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂
               in right b≤x (lemma-dropLast≃ l≃r (cl x≤y₁ l₁⋘r₁))
  ... | lr⋘ _ _ _ _ _ _ | inj₁ ()
  ... | _ | inj₂ dl⋘r = left b≤x dl⋘r
  dropLast (right b≤x l⋙r)
      with lemma-dropLast⋙ l⋙r
  ... | inj₁ l⋗r = left b≤x (lemma-dropLast⋗ l⋗r)
  ... | inj₂ l⋙dr = right b≤x l⋙dr

  lemma-dropLast-⊥ : {b : Bound}{l r : BBHeap b} → l ≃ r → dropLast l ⋘ r → Compound l → ⊥
  lemma-dropLast-⊥ () _ (cr _ _)
  lemma-dropLast-⊥ (≃nd b≤x b≤x' l⋘r l'⋘r' l≃r l'≃r' l≃l') dxlr⋘x'l'r' (cl .b≤x .l⋘r)
      with l⋘r | l≃r | l≃l' | l'⋘r' | lemma-dropLast⋘ l⋘r | dxlr⋘x'l'r'
  ... | lf⋘ | ≃lf | _ | _ | _ |  ()
  ... | lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₁≃r₁ l₁⋗l₂ | () | _ | _ | _ | _
  ... | ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | _ | ≃nd .x≤y₁ x'≤y'₁ .l₁⋘r₁ l'₁⋘r'₁ _ l'₁≃r'₁ l₁≃r'₁ | ll⋘ .x'≤y'₁ x'≤y'₂ .l'₁⋘r'₁ l'₂⋘r'₂ l'₂≃r'₂ r'₁≃l'₂ | inj₁ (≃nd .x≤y₁ .x≤y₂ .l₁⋘r₁ .l₂⋘r₂ l₁≃r₁ _ l₁≃l₂) | _dxlr⋘x'l'r'
      with lemma-dropLast≃ (≃nd x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂) (cl x≤y₁ l₁⋘r₁) | _dxlr⋘x'l'r'
  ... | l⋙dr | lr⋘ .b≤x .b≤x' .l⋙dr .(ll⋘ x'≤y'₁ x'≤y'₂ l'₁⋘r'₁ l'₂⋘r'₂ l'₂≃r'₂ r'₁≃l'₂) _ l⋗l'
      with lemma-≃-⊥ (≃nd x≤y₁ x'≤y'₁ l₁⋘r₁ l'₁⋘r'₁ l₁≃r₁ l'₁≃r'₁ l₁≃r'₁) l⋗l'
  ... | ()
  lemma-dropLast-⊥ (≃nd b≤x b≤x' l⋘r l'⋘r' l≃r l'≃r' l≃l') dxlr⋘x'l'r' (cl .b≤x .l⋘r) | ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | ≃nd .x≤y₁ .x≤y₂ .l₁⋘r₁ .l₂⋘r₂ l₁≃r₁ _ l₁≃l₂ | _ | _ | inj₂ dl⋘r | _
      with lemma-dropLast-⊥ (≃nd x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂) dl⋘r (cl x≤y₁ l₁⋘r₁)
  ... | ()

  lemma-dropLast≃ : {b : Bound}{l r : BBHeap b} → l ≃ r → Compound l → l ⋙ dropLast r
  lemma-dropLast≃ () (cr _ _)
  lemma-dropLast≃ (≃nd b≤x b≤x' l⋘r l'⋘r' l≃r l'≃r' l≃l') (cl .b≤x .l⋘r)
      with l'≃r' | l≃l' | l≃r | l⋘r | l'⋘r' | lemma-dropLast⋘ l'⋘r'
  ... | ≃lf | ≃lf | ≃lf | lf⋘ | lf⋘ | _ = ⋙lf b≤x
  ... | ≃nd x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ _ _ _ | _ | _l≃r | _l⋘r | ll⋘ .x'≤y₁ .x'≤y₂ .l₁⋘r₁ .l₂⋘r₂ l₂≃r₂ _ | inj₁ (≃nd .x'≤y₁ .x'≤y₂ .l₁⋘r₁ .l₂⋘r₂ l₁≃r₁ _ l₁≃l₂) =
                 let l'≃r' = ≃nd x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ ;
                      l'⋙dr' = lemma-dropLast≃ l'≃r' (cl x'≤y₁ l₁⋘r₁)
                 in ⋙rr b≤x b≤x' _l⋘r _l≃r l'⋙dr' l≃l'
  ... | ≃nd x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ | _l≃l' | _l≃r | _l⋘r | ll⋘ .x'≤y₁ .x'≤y₂ .l₁⋘r₁ .l₂⋘r₂ _ _ | inj₂ dl'⋘r'
      with lemma-dropLast-⊥ (≃nd x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂) dl'⋘r' (cl x'≤y₁ l₁⋘r₁)
  ... | ()

  lemma-dropLast⋗ : {b : Bound}{l r : BBHeap b} → l ⋗ r → dropLast l ⋘ r
  lemma-dropLast⋗ (⋗lf b≤x) = lf⋘
  lemma-dropLast⋗ (⋗nd b≤x b≤x' l⋘r l'⋘r' l≃r l'≃r' l⋗l')
      with l⋘r | l≃r | l⋗l' | lemma-dropLast⋘ l⋘r
  ... | lf⋘ | _ | () | _
  ... | lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₁≃r₁ l₁⋗l₂ | _ | _ | inj₁ ()
  ... | lr⋘ x≤y₁ x≤y₂ l₁⋙r₁ l₂⋘r₂ l₁≃r₁ l₁⋗l₂ | () | _ | inj₂ _
  ... | ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | _ | _ | inj₁ (≃nd .x≤y₁ .x≤y₂ .l₁⋘r₁ .l₂⋘r₂ l₁≃r₁ _ l₁≃l₂) =
                let _l≃r = ≃nd x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ ;
                     l⋙dr = lemma-dropLast≃ _l≃r (cl x≤y₁ l₁⋘r₁)
                in lr⋘ b≤x b≤x' l⋙dr l'⋘r' l'≃r' l⋗l'
  ... | ll⋘ x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ _ r₁≃l₂ | ≃nd .x≤y₁ .x≤y₂ .l₁⋘r₁ .l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂ | _ | inj₂ dl⋘r
      with lemma-dropLast-⊥ (≃nd x≤y₁ x≤y₂ l₁⋘r₁ l₂⋘r₂ l₁≃r₁ l₂≃r₂ l₁≃l₂) dl⋘r (cl x≤y₁ l₁⋘r₁)
  ... | ()

  lemma-dropLast⋘ : {b : Bound}{l r : BBHeap b} → l ⋘ r → l ≃ r ∨ dropLast l ⋘ r
  lemma-dropLast⋘ lf⋘ = inj₁ ≃lf
  lemma-dropLast⋘ (ll⋘ b≤x b≤x' l⋘r l'⋘r' l'≃r' r≃l')
      with l⋘r | l'⋘r' | r≃l' | lemma-dropLast⋘ l⋘r
  ... | lf⋘ | lf⋘ | ≃lf | _ = inj₁ (≃nd b≤x b≤x' lf⋘ lf⋘ ≃lf ≃lf ≃lf)
  ... | ll⋘ x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | _l'⋘r' | _r≃l' | inj₁ l≃r =
               let l≃l' = trans≃ l≃r _r≃l' ;
                    _l⋘r = ll⋘ x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂
               in inj₁ (≃nd b≤x b≤x' _l⋘r _l'⋘r' l≃r l'≃r' l≃l')
  ... | ll⋘ x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | _l'⋘r' | _r≃l' | inj₂ dl⋘r = inj₂ (ll⋘ b≤x b≤x' dl⋘r _l'⋘r' l'≃r' _r≃l')
  ... | lr⋘ x'≤y₁ x'≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂ | _l'⋘r' | _r≃l' | inj₁ l≃r =
               let l≃l' = trans≃ l≃r _r≃l' ;
                    _l⋘r = lr⋘ x'≤y₁ x'≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂
               in inj₁ (≃nd b≤x b≤x' _l⋘r _l'⋘r' l≃r l'≃r' l≃l')
  ... | lr⋘ x'≤y₁ x'≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂ | _l'⋘r' | _r≃l' | inj₂ dl⋘r = inj₂ (ll⋘ b≤x b≤x' dl⋘r _l'⋘r' l'≃r' _r≃l')
  lemma-dropLast⋘ (lr⋘ b≤x b≤x' l⋙r l'⋘r' l'≃r' l⋗l')
      with lemma-dropLast⋙ l⋙r
  ... | inj₁ l⋗r =
               let dl⋘r = lemma-dropLast⋗ l⋗r ;
                    r≃l' = lemma⋗⋗' l⋗r l⋗l'
               in inj₂ (ll⋘ b≤x b≤x' dl⋘r l'⋘r' l'≃r' r≃l')
  ... | inj₂ l⋙dr = inj₂ (lr⋘ b≤x b≤x' l⋙dr l'⋘r' l'≃r' l⋗l')

  lemma-dropLast⋙ : {b : Bound}{l r : BBHeap b} → l ⋙ r → l ⋗ r ∨ l ⋙ dropLast r
  lemma-dropLast⋙ (⋙lf b≤x) = inj₁ (⋗lf b≤x)
  lemma-dropLast⋙ (⋙rl b≤x b≤x' l⋘r l≃r l'⋘r' l⋗r')
      with l'⋘r' | l≃r | l⋗r' | lemma-dropLast⋘ l'⋘r'
  ... | lf⋘ | ≃nd x≤y _ lf⋘ lf⋘ ≃lf ≃lf ≃lf | ⋗lf .x≤y | _ = inj₁ (⋗nd b≤x b≤x' l⋘r lf⋘ l≃r ≃lf (⋗lf x≤y))
  ... | ll⋘ x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | _l≃r | _l⋗r' | inj₁ l'≃r' =
             let l⋗l' = lemma⋗≃ _l⋗r' (sym≃ l'≃r') ;
                  _l'⋘r' = ll⋘ x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂
             in inj₁ (⋗nd b≤x b≤x' l⋘r _l'⋘r' _l≃r l'≃r' l⋗l')
  ... | ll⋘ x'≤y₁ x'≤y₂ l₁⋘r₁ l₂⋘r₂ l₂≃r₂ r₁≃l₂ | _l≃r | _l⋗r' | inj₂ dl'⋘r' = inj₂ (⋙rl b≤x b≤x' l⋘r _l≃r dl'⋘r' _l⋗r')
  ... | lr⋘ x'≤y₁ x'≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂ | _l≃r | _l⋗r' | inj₁ l'≃r' =
             let l⋗l' = lemma⋗≃ _l⋗r' (sym≃ l'≃r') ;
                  _l'⋘r' = lr⋘ x'≤y₁ x'≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂
             in inj₁ (⋗nd b≤x b≤x' l⋘r _l'⋘r' _l≃r l'≃r' l⋗l')
  ... | lr⋘ x'≤y₁ x'≤y₂ l₁⋙r₁ l₂⋘r₂ l₂≃r₂ l₁⋗l₂ | _l≃r | _l⋗r' | inj₂ dl'⋘r' = inj₂ (⋙rl b≤x b≤x' l⋘r _l≃r dl'⋘r' _l⋗r')
  lemma-dropLast⋙ (⋙rr b≤x b≤x' l⋘r l≃r l'⋙r' l≃l')
      with lemma-dropLast⋙ l'⋙r'
  ... | inj₁ l'⋗r' =
               let dl'⋘r' = lemma-dropLast⋗ l'⋗r' ;
                    l⋗r' = lemma≃⋗ l≃l' l'⋗r'
               in inj₂ (⋙rl b≤x b≤x' l⋘r l≃r dl'⋘r' l⋗r')
  ... | inj₂ l'⋙dr' = inj₂ (⋙rr b≤x b≤x' l⋘r l≃r l'⋙dr' l≃l')


{-# OPTIONS --universe-polymorphism #-}

module UniversePolymorphicIO where

open import Common.Level

postulate
  IO : ∀ {ℓ} → Set ℓ → Set ℓ

{-# IMPORT UniversePolymorphicIO #-}
{-# COMPILED_TYPE IO UniversePolymorphicIO.AgdaIO #-}
{-# BUILTIN IO IO #-}

postulate
  return : ∀ {a} {A : Set a} → A → IO A
  _>>=_  : ∀ {a b} {A : Set a} {B : Set b} → IO A → (A → IO B) → IO B

postulate
  String : Set

{-# BUILTIN STRING String #-}

{-# COMPILED return (\_ _ -> return :: a -> IO a) #-}
{-# COMPILED _>>=_  (\_ _ _ _ ->
                        (>>=) :: IO a -> (a -> IO b) -> IO b) #-}

{-# IMPORT Data.Text.IO #-}

postulate
  Unit : Set
  putStrLn : String →  IO Unit

{-# COMPILED_TYPE Unit () #-}

{-# COMPILED putStrLn Data.Text.IO.putStrLn #-}

data List A : Set where
  [] : List A
  _∷_ : A → List A → List A

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL [] #-}
{-# BUILTIN CONS _∷_ #-}

main = putStrLn "ok" >>= λ _ → return lzero


{-# OPTIONS --exact-split #-}
-- {-# OPTIONS -v tc.cover:10 #-}

postulate
  A : Set

record I : Set where
  constructor i
  field
    f : A

data Wrap : (j : I) → Set where
  con : (j : I) → Wrap j

postulate
  C : Set
  anything : C

test : (X : I) -> Wrap X -> C
test (i ._) (con x) = anything


-- Andreas, 2017-05-24, issue #2590
-- Making variables visible by case splitting in with-clauses

-- {-# OPTIONS -v interaction.case:20 #-}
-- {-# OPTIONS -v reify:100 #-}
-- {-# OPTIONS -v tc.display:100 #-}

open import Agda.Builtin.Nat

test1 : {x : Nat} → Nat
test1 with Set
... | q = {!.x!}  -- C-c C-c

-- Expected result:
-- test1 {x} | q = ?

data Any (x : Nat) : Set where
  any : Any x

postulate
  zonk : ∀{x} → Any x → Nat

test2 : {x y : Nat} → Any y → Nat
test2 p with zonk p
... | q = {!.y!} -- C-c C-c

-- Expected result:
-- test2 {y = y} p | q = ?


{-# OPTIONS --type-in-type #-}

module TypeInTypeAndUnivPoly where

open import UniversePolymorphism

-- The level metas should be solved with 0 when we have --type-in-type
fst′ : ∀ {A B} → Σ A B → A
fst′ x = fst x


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

module Data.Rational.SternBrocot where

open import Prelude
import Data.Nat as ℕ
import Data.Nat.Properties as ℕ
open import Data.Bits renaming (Bits to ℚ⁺; [] to 1ℚ; 0∷_ to lℚ; 1∷_ to rℚ)
open import Data.Bits.Equatable

-- ⟦_⇓⟧ : ℚ⁺ → (ℕ × ℕ)
-- ⟦ 1ℚ ⇓⟧ = 1 , 1
-- ⟦ lℚ x ⇓⟧ = let p , q = ⟦ x ⇓⟧ in p , p ℕ.+ q
-- ⟦ rℚ x ⇓⟧ = let p , q = ⟦ x ⇓⟧ in p ℕ.+ q , q

-- module TerminationProofs where
--   Tᴮ⇒≡ : {n m : ℕ} → n ≡ m → T (n ℕ.≡ᴮ m)
--   Tᴮ⇒≡ {n} {m} n≡m = subst (λ n′ → T (n ℕ.≡ᴮ n′)) n≡m (ℕ.complete-== n)

--   lift-suc-≡ : ∀ {n m} s → m ≡ n → T (n ℕ.≡ᴮ s) → T (m ℕ.≡ᴮ s)
--   lift-suc-≡ {n} {m} s  m≡n p = Tᴮ⇒≡ (m≡n ; ℕ.sound-== (n) s p)

--   lemma₁ : ∀ a m → a ℕ.+ m ℕ.+ zero ≡ m ℕ.+ a
--   lemma₁ a m = ℕ.+-idʳ (a ℕ.+ m) ; ℕ.+-comm a m

--   lemma₂ : ∀ n a m → n ℕ.+ m ℕ.+ suc a ≡ n ℕ.+ suc m ℕ.+ a
--   lemma₂ n a m = ℕ.+-assoc n m (suc a) ; cong (n ℕ.+_) (ℕ.+-suc m a) ; sym (ℕ.+-assoc n (suc m) a)

--   lemma₃ : ∀ n a → n ℕ.+ a ℕ.+ zero ≡ n ℕ.+ zero ℕ.+ a
--   lemma₃ n a = ℕ.+-idʳ (n ℕ.+ a) ; cong (ℕ._+ a) (sym (ℕ.+-idʳ n))

-- _+1/_+1 : ℕ → ℕ → ℚ⁺
-- n +1/ m +1 = go zero n m (n ℕ.+ m)
--   where
--   go : (a n m s : ℕ) → ℚ⁺
--   go a zero    (suc m) (suc s) = lℚ (go zero a m s)
--   go a (suc n) (suc m) (suc s) = go (suc a) n m s
--   go a (suc n) zero    (suc s) = rℚ (go zero n a s)
--   go _ _       _       _       = 1ℚ

euclidian : ℕ → ℕ → ℕ → ℚ⁺
euclidian n m zero    = 1ℚ
euclidian n m (suc s) =
  if n ℕ.≡ᴮ m
  then 1ℚ
  else if n ℕ.<ᴮ m
  then lℚ (euclidian n (m ℕ.∸ (1 ℕ.+ n)) s)
  else rℚ (euclidian (n ℕ.∸ (1 ℕ.+ m)) m s)

normalise-suc : ℕ → ℕ → ℚ⁺
normalise-suc n m = euclidian n m (n ℕ.+ m)

ℚ : Type
ℚ = ℚ⁺

import Data.Rational.Unnormalised as F
open import Data.Rational.Unnormalised using (_/suc_; _/_)
import Data.Integer as ℤ
open import Data.Integer using (ℤ; ⁺; ⁻suc; ⁻)
open import Data.Bits.Fold

zer : (ℕ × ℕ) → (ℕ × ℕ)
zer (p , q) = p , suc p ℕ.+ q

one : (ℕ × ℕ) → (ℕ × ℕ)
one (p , q) = suc p ℕ.+ q , q

fraction : ℚ → (ℕ × ℕ)
fraction = foldr-bits zer one (0 , 0)

⟦_⇓⟧ : ℚ → F.ℚ
⟦ 1ℚ ⇓⟧ = ⁺ 0 F./suc 0
⟦ lℚ xs ⇓⟧ = let n , d = fraction xs in ⁻suc n /suc d
⟦ rℚ xs ⇓⟧ = let n , d = fraction xs in ⁺ (suc n) /suc d

⟦_⇑⟧ : F.ℚ → ℚ
⟦ ⁺ zero /suc den-pred ⇑⟧ = 1ℚ
⟦ ⁺ (suc x) /suc den-pred ⇑⟧ = rℚ (normalise-suc x den-pred)
⟦ ⁻suc x /suc den-pred ⇑⟧ = lℚ (normalise-suc x den-pred)

-- open import Path.Reasoning

-- n≢sn+d : ∀ n d → (n ℕ.≡ᴮ suc (n ℕ.+ d)) ≡ false
-- n≢sn+d zero d = refl
-- n≢sn+d (suc n) d = n≢sn+d n d

-- n<sn+d : ∀ n d → (n ℕ.<ᴮ suc (n ℕ.+ d)) ≡ true
-- n<sn+d zero d = refl
-- n<sn+d (suc n) d = n<sn+d n d

-- n+d-n≡d : ∀ n d → n ℕ.+ d ℕ.∸ n ≡ d
-- n+d-n≡d zero d = refl
-- n+d-n≡d (suc n) d = n+d-n≡d n d

-- euclidian-term-helper : ∀ n d s₁ s₂ → (n ℕ.+ d ℕ.≤ s₁) → (n ℕ.+ d ℕ.≤ s₂) → euclidian n d s₁ ≡ euclidian n d s₂
-- euclidian-term-helper zero zero zero zero p₁ p₂ = refl
-- euclidian-term-helper zero zero zero (suc s₂) p₁ p₂ = refl
-- euclidian-term-helper zero zero (suc s₁) zero p₁ p₂ = refl
-- euclidian-term-helper zero zero (suc s₁) (suc s₂) p₁ p₂ = refl
-- euclidian-term-helper zero (suc d) (suc s₁) (suc s₂) p₁ p₂ = cong lℚ (euclidian-term-helper zero d s₁ s₂ (ℕ.p≤p d s₁ p₁) (ℕ.p≤p d s₂ p₂))
-- euclidian-term-helper (suc n) zero (suc s₁) (suc s₂) p₁ p₂ = cong rℚ (euclidian-term-helper n zero s₁ s₂ (ℕ.p≤p (n ℕ.+ zero) s₁ p₁) (ℕ.p≤p (n ℕ.+ zero) s₂ p₂))
-- euclidian-term-helper (suc n) (suc d) (suc s₁) (suc s₂) p₁ p₂ with n ℕ.≡ᴮ d | n ℕ.<ᴮ d
-- euclidian-term-helper (suc n) (suc d) (suc s₁) (suc s₂) p₁ p₂ | false | false = cong rℚ (euclidian-term-helper (n ℕ.∸ suc d) (suc d) s₁ s₂ {!!} {!!})
-- euclidian-term-helper (suc n) (suc d) (suc s₁) (suc s₂) p₁ p₂ | false | true  = cong lℚ (euclidian-term-helper (suc n) (d ℕ.∸ suc n) s₁ s₂ {!!} {!!})
-- euclidian-term-helper (suc n) (suc d) (suc s₁) (suc s₂) p₁ p₂ | true  | _ = refl

-- norm-l : ∀ n d → normalise-suc n (suc n ℕ.+ d) ≡ lℚ (normalise-suc n d)
-- norm-l n d =
--   normalise-suc n (suc n ℕ.+ d) ≡⟨⟩
--   euclidian n (suc n ℕ.+ d) (n ℕ.+ (suc n ℕ.+ d)) ≡⟨ cong (euclidian n (suc n ℕ.+ d)) (ℕ.+-suc n (n ℕ.+ d)) ⟩
--   euclidian n (suc n ℕ.+ d) (suc n ℕ.+ (n ℕ.+ d)) ≡⟨⟩
--   (if n ℕ.≡ᴮ suc (n ℕ.+ d) then 1ℚ else
--        if n ℕ.<ᴮ suc (n ℕ.+ d) then lℚ (euclidian n (n ℕ.+ d ℕ.∸ n) (n ℕ.+ (n ℕ.+ d))) else rℚ (euclidian (n ℕ.∸ suc (suc (n ℕ.+ d))) (suc (n ℕ.+ d)) (n ℕ.+ (n ℕ.+ d)))) ≡⟨ cong (if_then 1ℚ else if n ℕ.<ᴮ suc (n ℕ.+ d) then lℚ (euclidian n (n ℕ.+ d ℕ.∸ n) (n ℕ.+ (n ℕ.+ d))) else rℚ (euclidian (n ℕ.∸ suc (suc (n ℕ.+ d))) (suc (n ℕ.+ d)) (n ℕ.+ (n ℕ.+ d)))) (n≢sn+d n d) ⟩
--   (if n ℕ.<ᴮ suc (n ℕ.+ d) then
--        lℚ (euclidian n (n ℕ.+ d ℕ.∸ n) (n ℕ.+ (n ℕ.+ d))) else
--        rℚ (euclidian (n ℕ.∸ suc (suc (n ℕ.+ d))) (suc (n ℕ.+ d)) (n ℕ.+ (n ℕ.+ d)))) ≡⟨ cong (if_then lℚ ((euclidian n (n ℕ.+ d ℕ.∸ n) (n ℕ.+ (n ℕ.+ d)))) else rℚ ((euclidian (n ℕ.∸ suc (suc (n ℕ.+ d))) (suc (n ℕ.+ d)) (n ℕ.+ (n ℕ.+ d))))) (n<sn+d n d) ⟩
--   lℚ (euclidian n (n ℕ.+ d ℕ.∸ n) (n ℕ.+ (n ℕ.+ d))) ≡⟨ cong (λ ndn → lℚ (euclidian n ndn (n ℕ.+ (n ℕ.+ d)))) (n+d-n≡d n d) ⟩
--   lℚ (euclidian n d (n ℕ.+ (n ℕ.+ d))) ≡⟨ {!!} ⟩
--   lℚ (euclidian n d (n ℕ.+ d)) ≡⟨⟩
--   lℚ (normalise-suc n d) ∎

-- ℚ-retract′ : ∀ x → normalise-suc (fst (fraction x)) (snd (fraction x)) ≡ x
-- ℚ-retract′ 1ℚ = refl
-- ℚ-retract′ (rℚ x) = {!!}
-- ℚ-retract′ (lℚ x) = let n , d = fraction x in
--   normalise-suc n (suc (n ℕ.+ d)) ≡⟨ {!!} ⟩
--   lℚ x ∎

-- ℚ-retract : ∀ x → ⟦ ⟦ x ⇓⟧ ⇑⟧ ≡ x
-- ℚ-retract 1ℚ = refl
-- ℚ-retract (lℚ x) = cong lℚ (ℚ-retract′ x)
-- ℚ-retract (rℚ x) = cong rℚ (ℚ-retract′ x)


open import Prelude
open import Nat
open import dynamics-core
open import contexts
open import lemmas-disjointness

module lemmas-freshness where
  -- if x is fresh in an hexp, it's fresh in its expansion
  mutual
    fresh-elab-synth1 : ∀{x e τ d Γ Δ} →
                         x # Γ →
                         freshh x e →
                         Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                         fresh x d
    fresh-elab-synth1 apt FHNum ESNum = FNum
    fresh-elab-synth1 apt (FRHPlus x x₄) (ESPlus gapt x₁ x₂ x₃) =
                          FPlus (FCast (fresh-elab-ana1 apt x x₂))
                                (FCast (fresh-elab-ana1 apt x₄ x₃))
    fresh-elab-synth1 apt (FRHAsc frsh) (ESAsc x₁) = FCast (fresh-elab-ana1 apt frsh x₁)
    fresh-elab-synth1 _ (FRHVar x₂) (ESVar x₃) = FVar x₂
    fresh-elab-synth1 {Γ = Γ} apt (FRHLam2 x₂ frsh) (ESLam x₃ exp) = FLam x₂ (fresh-elab-synth1 (apart-extend1 Γ x₂ apt) frsh exp)
    fresh-elab-synth1 apt (FRHAp frsh frsh₁) (ESAp x₁ x₂ x₃ x₄ x₅ x₆) = FAp (FCast (fresh-elab-ana1 apt frsh x₅)) (FCast (fresh-elab-ana1 apt frsh₁ x₆))
    fresh-elab-synth1 apt (FRHPair frsh frsh₁) (ESPair x x₁ x₂ x₃) = FPair (fresh-elab-synth1 apt frsh x₂) (fresh-elab-synth1 apt frsh₁ x₃)
    fresh-elab-synth1 apt (FRHFst frsh) (ESFst x x₁ x₂) = FFst (FCast (fresh-elab-ana1 apt frsh x₂))
    fresh-elab-synth1 apt (FRHSnd frsh) (ESSnd x x₁ x₂) = FSnd (FCast (fresh-elab-ana1 apt frsh x₂))
    fresh-elab-synth1 apt FRHEHole ESEHole = FHole (EFId apt)
    fresh-elab-synth1 apt (FRHNEHole frsh) (ESNEHole x₁ exp) = FNEHole (EFId apt) (fresh-elab-synth1 apt frsh exp)

    fresh-elab-ana1 : ∀{x e τ d τ' Γ Δ} →
                      x # Γ →
                      freshh x e →
                      Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                      fresh x d
    fresh-elab-ana1 {Γ = Γ}  apt (FRHLam1 x₁ frsh) (EALam x₂ x₃ exp) = FLam x₁ (fresh-elab-ana1 (apart-extend1 Γ x₁ apt) frsh exp )
    fresh-elab-ana1 apt frsh (EASubsume x₁ x₂ x₃ x₄) = fresh-elab-synth1 apt frsh x₃
    fresh-elab-ana1 apt (FRHInl frsh) (EAInl x x₁) = FInl (fresh-elab-ana1 apt frsh x₁)
    fresh-elab-ana1 apt (FRHInr frsh) (EAInr x x₁) = FInr (fresh-elab-ana1 apt frsh x₁)
    fresh-elab-ana1 {Γ = Γ} apt (FRHCase frsh x₁ frsh₁ x₂ frsh₂) (EACase x x₃ x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃) = FCase (FCast (fresh-elab-synth1 apt frsh x₁₀)) x₁ (FCast (fresh-elab-ana1 (apart-extend1 Γ x₁ apt) frsh₁ x₁₂)) x₂ (FCast (fresh-elab-ana1 (apart-extend1 Γ x₂ apt) frsh₂ x₁₃))
    fresh-elab-ana1 apt FRHEHole EAEHole = FHole (EFId apt)
    fresh-elab-ana1 apt (FRHNEHole frsh) (EANEHole x₁ x₂) = FNEHole (EFId apt) (fresh-elab-synth1 apt frsh x₂)

  -- if x is fresh in the expansion of an hexp, it's fresh in that hexp
  mutual
    fresh-elab-synth2 : ∀{x e τ d Γ Δ} →
                         fresh x d →
                         Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                         freshh x e
    fresh-elab-synth2 FNum ESNum = FRHNum
    fresh-elab-synth2 (FPlus (FCast x) (FCast x₄)) (ESPlus apt x₁ x₂ x₃) =
      FRHPlus (fresh-elab-ana2 x x₂) (fresh-elab-ana2 x₄ x₃)
    fresh-elab-synth2 (FVar x₂) (ESVar x₃) = FRHVar x₂
    fresh-elab-synth2 (FLam x₂ frsh) (ESLam x₃ exp) = FRHLam2 x₂ (fresh-elab-synth2 frsh exp)
    fresh-elab-synth2 (FAp (FCast frsh) (FCast frsh₁)) (ESAp x₁ x₂ x₃ x₄ x₅ x₆) = FRHAp (fresh-elab-ana2 frsh x₅) (fresh-elab-ana2 frsh₁ x₆)
    fresh-elab-synth2 (FPair frsh frsh₁) (ESPair x x₁ x₂ x₃) = FRHPair (fresh-elab-synth2 frsh x₂) (fresh-elab-synth2 frsh₁ x₃)
    fresh-elab-synth2 (FFst (FCast frsh)) (ESFst x x₁ x₂) = FRHFst (fresh-elab-ana2 frsh x₂)
    fresh-elab-synth2 (FSnd (FCast frsh)) (ESSnd x x₁ x₂) = FRHSnd (fresh-elab-ana2 frsh x₂)
    fresh-elab-synth2 (FHole x₁) ESEHole = FRHEHole
    fresh-elab-synth2 (FNEHole x₁ frsh) (ESNEHole x₂ exp) = FRHNEHole (fresh-elab-synth2 frsh exp)
    fresh-elab-synth2 (FCast frsh) (ESAsc x₁) = FRHAsc (fresh-elab-ana2 frsh x₁)

    fresh-elab-ana2 : ∀{ x e τ d τ' Γ Δ} →
                      fresh x d →
                      Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                      freshh x e
    fresh-elab-ana2 (FLam x₁ frsh) (EALam x₂ x₃ exp) = FRHLam1 x₁ (fresh-elab-ana2 frsh exp)
    fresh-elab-ana2 frsh (EASubsume x₁ x₂ x₃ x₄) = fresh-elab-synth2 frsh x₃
    fresh-elab-ana2 (FHole x₁) EAEHole = FRHEHole
    fresh-elab-ana2 (FNEHole x₁ frsh) (EANEHole x₂ x₃) = FRHNEHole (fresh-elab-synth2 frsh x₃)
    fresh-elab-ana2 (FInl frsh) (EAInl x x₁) = FRHInl (fresh-elab-ana2 frsh x₁)
    fresh-elab-ana2 (FInr frsh) (EAInr x x₁) = FRHInr (fresh-elab-ana2 frsh x₁)
    fresh-elab-ana2 (FCase (FCast frsh) x (FCast frsh₁) x₁ (FCast frsh₂)) (EACase x₂ x₃ x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃) = FRHCase (fresh-elab-synth2 frsh x₁₀) x (fresh-elab-ana2 frsh₁ x₁₂) x₁ (fresh-elab-ana2 frsh₂ x₁₃)


{-# OPTIONS --warning=error --safe --without-K #-}

open import LogicalFormulae
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Naturals
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Numbers.Naturals.Order.WellFounded
open import KeyValue.KeyValue
open import Orders.Total.Definition
open import Orders.Partial.Definition
open import Vectors
open import Maybe
open import Semirings.Definition
open import Numbers.Naturals.EuclideanAlgorithm

module Numbers.Primes.PrimeNumbers where

open TotalOrder ℕTotalOrder
open Semiring ℕSemiring
open import Decidable.Lemmas ℕDecideEquality

dividesEqualityLemma'' : {a b : ℕ} → (quot1 quot2 : ℕ) → .(quot1 ≡ quot2) → (rem : ℕ) → .(pr1 : (quot1 +N a *N quot1) +N rem ≡ b) → .(pr2 : (quot2 +N a *N quot2) +N rem ≡ b) → (y : rem <N' succ a) → (x1 : zero <N' succ a) → _≡_ {A = divisionAlgResult' _ _} record { quot = quot1 ; rem = rem ; pr = pr1 ; remIsSmall = inl y ; quotSmall = inl x1 } record { quot = quot2 ; rem = rem ; pr = pr2 ; remIsSmall = inl y ; quotSmall = inl x1}
dividesEqualityLemma'' {a} {b} q1 q2 pr rem pr1 pr2 y x1 with squashN record { eq = pr }
... | refl = refl

dividesEqualityLemma' : {a b : ℕ} → (quot1 quot2 : ℕ) → (rem : ℕ) → .(pr1 : (quot1 +N a *N quot1) +N rem ≡ b) → .(pr2 : (quot2 +N a *N quot2) +N rem ≡ b) → (y : rem <N' succ a) → (y2 : rem <N' succ a) → (x1 : zero <N' succ a) → _≡_ {A = divisionAlgResult' _ _} record { quot = quot1 ; rem = rem ; pr = pr1 ; remIsSmall = inl y ; quotSmall = inl x1 } record { quot = quot2 ; rem = rem ; pr = pr2 ; remIsSmall = inl y2 ; quotSmall = inl x1}
dividesEqualityLemma' {a} {b} quot1 quot2 rem pr1 pr2 y y2 x1 with productCancelsLeft (succ a) quot2 quot1 (succIsPositive a) (canSubtractFromEqualityRight (transitivity (squashN record { eq = pr2 }) (equalityCommutative (squashN record { eq = pr1 }))))
... | refl with <N'Refl y y2
... | refl = refl

dividesEqualityLemma : {a b : ℕ} → (quot1 quot2 : ℕ) → (rem1 rem2 : ℕ) → .(pr1 : (quot1 +N a *N quot1) +N rem1 ≡ b) → .(pr2 : (quot2 +N a *N quot2) +N rem2 ≡ b) → .(rem1 ≡ rem2) → (y : rem1 <N' succ a) → (y2 : rem2 <N' succ a) → (x1 : zero <N' succ a) → _≡_ {A = divisionAlgResult' _ _} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = inl y ; quotSmall = inl x1 } record { quot = quot2 ; rem = rem2 ; pr = pr2 ; remIsSmall = inl y2 ; quotSmall = inl x1}
dividesEqualityLemma {a} {b} quot1 quot2 rem1 rem2 pr1 pr2 remEq y y2 x1 with squashN record { eq = remEq }
... | refl = dividesEqualityLemma' quot1 quot2 rem1 pr1 pr2 y y2 x1

dividesEqualityLemma1 : {a b : ℕ} → (quot1 quot2 : ℕ) → (rem1 rem2 : ℕ) → .(pr1 : (quot1 +N a *N quot1) +N rem1 ≡ b) → .(pr2 : (quot2 +N a *N quot2) +N rem2 ≡ b) → .(rem1 ≡ rem2) → (y : (rem1 <N' succ a) || (succ a =N' zero)) → (y2 : (rem2 <N' succ a) || (succ a =N' zero)) → (x1 : zero <N' succ a) → _≡_ {A = divisionAlgResult' _ _} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = y ; quotSmall = inl x1 } record { quot = quot2 ; rem = rem2 ; pr = pr2 ; remIsSmall = y2 ; quotSmall = inl x1}
dividesEqualityLemma1 {a} {b} quot1 quot2 rem1 rem2 pr1 pr2 remEq (inl x) (inl y) x1 = dividesEqualityLemma quot1 quot2 rem1 rem2 pr1 pr2 remEq x y x1

dividesEqualityLemma2 : {a b : ℕ} → (quot1 quot2 : ℕ) → (rem1 rem2 : ℕ) → .(pr1 : (quot1 +N a *N quot1) +N rem1 ≡ b) → .(pr2 : (quot2 +N a *N quot2) +N rem2 ≡ b) → .(rem1 ≡ rem2) → (y : (rem1 <N' succ a) || (succ a =N' zero)) → (y2 : (rem2 <N' succ a) || (succ a =N' zero)) → (x1 : zero <N' succ a) (x2 : zero <N' succ a) → _≡_ {A = divisionAlgResult' _ _} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = y ; quotSmall = inl x1 } record { quot = quot2 ; rem = rem2 ; pr = pr2 ; remIsSmall = y2 ; quotSmall = inl x2 }
dividesEqualityLemma2 {a} {b} quot1 quot2 rem1 rem2 pr1 pr2 remEq x y x1 x2 with <N'Refl x1 x2
... | refl = dividesEqualityLemma1 quot1 quot2 rem1 rem2 pr1 pr2 remEq x y x1

dividesEqualityLemma3 : {a b : ℕ} → (quot1 quot2 : ℕ) → (rem1 rem2 : ℕ) → .(pr1 : (succ a *N quot1) +N rem1 ≡ b) → .(pr2 : (succ a *N quot2) +N rem2 ≡ b) → .(rem1 ≡ rem2) → (y : (rem1 <N' succ a) || (succ a =N' zero)) → (y2 : (rem2 <N' succ a) || (succ a =N' zero)) → (x1 : (zero <N' succ a) || (zero =N' succ a) && (quot1 =N' zero)) (x2 : (zero <N' succ a) || (zero =N' succ a) && (quot2 =N' zero)) → _≡_ {A = divisionAlgResult' _ _} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = y ; quotSmall = x1 } record { quot = quot2 ; rem = rem2 ; pr = pr2 ; remIsSmall = y2 ; quotSmall = x2 }
dividesEqualityLemma3 {a} {b} quot1 quot2 rem1 rem2 pr1 pr2 remEq x y (inl x1) (inl x2) = dividesEqualityLemma2 quot1 quot2 rem1 rem2 pr1 pr2 remEq x y x1 x2

dividesEqualityPr' : {a b : ℕ} → (res1 res2 : divisionAlgResult' a b) → res1 ≡ res2
dividesEqualityPr' {zero} {zero} record { quot = quot₁ ; rem = rem₁ ; pr = pr1 ; remIsSmall = (inr f2) ; quotSmall = (inr (f4 ,, quot1=0)) } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr f1) ; quotSmall = (inr (f3 ,, quot=0)) } with squashN quot1=0
... | refl with squashN quot=0
... | refl with =N'Refl f1 f2
... | refl with =N'Refl f3 f4
... | refl with =N'Refl quot1=0 quot=0
... | refl with transitivity (squashN record { eq = pr }) (equalityCommutative (squashN record { eq = pr1 }))
... | refl = refl
dividesEqualityPr' {zero} {succ b} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = (inr rSm) ; quotSmall = (inr (f ,, quot1=0)) } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr rSm2) ; quotSmall = (inr (f2 ,, quot=0)) } with squashN quot=0
... | refl with squashN quot1=0
... | refl with =N'Refl rSm rSm2
... | refl with =N'Refl quot1=0 quot=0
... | refl with =N'Refl f f2
... | refl with transitivity (squashN record { eq = pr }) (equalityCommutative (squashN record { eq = pr1 }))
... | refl = refl
dividesEqualityPr' {succ a} {zero} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = (inl remSm) ; quotSmall = (inl qSm) } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl remSm2) ; quotSmall = (inl qSm2) } with sumZeroImpliesSummandsZero {quot +N a *N quot} {rem} (squashN record { eq = pr })
... | fst ,, refl with sumZeroImpliesSummandsZero {quot} {_} fst
... | refl ,, _ with sumZeroImpliesSummandsZero {_} {rem1} (squashN record { eq = pr1 })
... | fst2 ,, refl with sumZeroImpliesSummandsZero {quot1} {_} fst2
... | refl ,, _ with <N'Refl remSm remSm2
... | refl with <N'Refl qSm qSm2
... | refl = refl
dividesEqualityPr' {succ a} {succ b} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = inl remIsSmall1 ; quotSmall = inl (quotSmall1) } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = inl remIsSmall ; quotSmall = (inl quotSmall) } = dividesEqualityLemma3 quot1 quot rem1 rem pr1 pr t (inl remIsSmall1) (inl remIsSmall) (inl quotSmall1) (inl quotSmall)
  where
    t : rem1 ≡ rem
    t = modIsUnique record { quot = quot1 ; rem = rem1 ; pr = squash pr1 ; remIsSmall = inl (<N'To<N remIsSmall1) ; quotSmall = inl (<N'To<N quotSmall) } record { quot = quot ; rem = rem ; pr = squash pr ; remIsSmall = inl (<N'To<N remIsSmall) ; quotSmall = inl (<N'To<N quotSmall1) }

dividesEquality : {a b : ℕ} → (res1 res2 : a ∣' b) → res1 ≡ res2
dividesEquality (divides' res1 x1) (divides' res2 x2) with dividesEqualityPr' res1 res2
... | refl = refl

data notDiv : ℕ → ℕ → Set where
  doesNotDivide : {a b : ℕ} → (res : divisionAlgResult a b) → 0 <N divisionAlgResult.rem res → notDiv a b

twoDividesFour : succ (succ zero) ∣ succ (succ (succ (succ zero)))
twoDividesFour = divides {(succ (succ zero))} {succ (succ (succ (succ zero)))} (record { quot = succ (succ zero) ; rem = zero ; pr = refl ; remIsSmall = inl (succIsPositive 1) ; quotSmall = inl (succIsPositive 1) }) refl

record Prime (p : ℕ) : Set where
  field
    p>1 : 1 <N p
    pr : forall {i : ℕ} → i ∣ p → i <N p → zero <N i → i ≡ (succ zero)

record Composite (n : ℕ) : Set where
  field
    n>1 : 1 <N n
    divisor : ℕ
    dividesN : divisor ∣ n
    divisorLessN : divisor <N n
    divisorNot1 : 1 <N divisor
    divisorPrime : Prime divisor
    noSmallerDivisors : ∀ i → i <N divisor → 1 <N i → i ∣ n → False

notBothPrimeAndComposite : {n : ℕ} → Composite n → Prime n → False
notBothPrimeAndComposite {n} record { n>1 = n>1 ; divisor = divisor ; dividesN = dividesN ; divisorLessN = divisorLessN ; divisorNot1 = divisorNot1 } record { p>1 = p>1 ; pr = pr } = lessImpliesNotEqual divisorNot1 (equalityCommutative div=1)
  where
    div=1 : divisor ≡ 1
    div=1 = pr {divisor} dividesN divisorLessN (TotalOrder.<Transitive ℕTotalOrder (succIsPositive 0) divisorNot1)

zeroIsNotPrime : Prime 0 → False
zeroIsNotPrime record { p>1 = p>1 ; pr = pr } = zeroNeverGreater p>1

oneIsNotPrime : Prime 1 → False
oneIsNotPrime record { p>1 = (le x proof) ; pr = pr } = naughtE (equalityCommutative absurd')
  where
    absurd : x +N 1 ≡ 0
    absurd = succInjective proof
    absurd' : succ x ≡ 0
    absurd' rewrite Semiring.commutative ℕSemiring 1 x = absurd

twoIsPrime : Prime 2
Prime.p>1 twoIsPrime = succPreservesInequality (succIsPositive 0)
Prime.pr twoIsPrime {i} i|2 i<2 0<i with totality i (succ (succ zero))
Prime.pr twoIsPrime {zero} i|2 i<2 (le x ()) | order
Prime.pr twoIsPrime {succ zero} i|2 i<2 0<i | order = refl
Prime.pr twoIsPrime {succ (succ zero)} i|2 i<2 0<i | order = exFalso (lessImpliesNotEqual {2} i<2 refl)
Prime.pr twoIsPrime {succ (succ (succ i))} i|2 i<2 0<i | inl (inl x) = exFalso (TotalOrder.irreflexive ℕTotalOrder (TotalOrder.<Transitive ℕTotalOrder i<2 (succPreservesInequality (succPreservesInequality (succIsPositive i)))))
Prime.pr twoIsPrime {succ (succ (succ i))} i|2 i<2 0<i | inl (inr twoLessThree) = exFalso (TotalOrder.irreflexive ℕTotalOrder (TotalOrder.<Transitive ℕTotalOrder twoLessThree i<2))
Prime.pr twoIsPrime {succ (succ (succ i))} i|2 i<2 0<i | inr ()

threeIsPrime : Prime 3
Prime.p>1 threeIsPrime = le 1 refl
Prime.pr threeIsPrime {succ zero} i|3 i<3 _ = refl
Prime.pr threeIsPrime {succ (succ zero)} (divides record { quot = (succ (succ (succ zero))) ; rem = zero ; pr = () ; remIsSmall = remIsSmall ; quotSmall = quotSmall } x) i<3 _
Prime.pr threeIsPrime {succ (succ zero)} (divides record { quot = (succ (succ (succ (succ quot)))) ; rem = zero ; pr = () ; remIsSmall = remIsSmall ; quotSmall = quotSmall } x) i<3 _
Prime.pr threeIsPrime {succ (succ (succ i))} i|3 (le (succ (succ zero)) ()) _
Prime.pr threeIsPrime {succ (succ (succ i))} i|3 (le (succ (succ (succ x))) ()) _

compositeImpliesNotPrime : (m p : ℕ) → (succ zero <N m) → (m <N p) → (m ∣ p) → Prime p → False
compositeImpliesNotPrime zero p (le x ()) _ mDivP pPrime
compositeImpliesNotPrime (succ zero) p mLarge _ mDivP pPrime = lessImpliesNotEqual {succ zero} {succ zero} mLarge refl
compositeImpliesNotPrime (succ (succ m)) zero _ _ mDivP ()
compositeImpliesNotPrime (succ (succ m)) (succ zero) _ _ mDivP primeP = exFalso (oneIsNotPrime primeP)
compositeImpliesNotPrime (succ (succ m)) (succ (succ p)) _ mLessP mDivP pPrime = false
  where
    r = succ (succ m)
    q = succ (succ p)
    rEqOne : r ≡ succ zero
    rEqOne = (Prime.pr pPrime) {r} mDivP mLessP (succIsPositive (succ m))
    false : False
    false = succIsNonzero (succInjective rEqOne)

fourIsNotPrime : Prime 4 → False
fourIsNotPrime = compositeImpliesNotPrime (succ (succ zero)) (succ (succ (succ (succ zero)))) (le zero refl) (le (succ zero) refl) twoDividesFour

record Coprime (a : ℕ) (b : ℕ) : Set where
  field
    hcf : hcfData a b
    hcfNot1 : 1 <N hcfData.c hcf

record numberLessThan (n : ℕ) : Set where
  field
    a : ℕ
    a<n : a <N' n
  upper : ℕ
  upper = n

numberLessThanEquality : {n : ℕ} → (a b : numberLessThan n) → (numberLessThan.a a ≡ numberLessThan.a b) → a ≡ b
numberLessThanEquality record { a = a ; a<n = a<n } record { a = b ; a<n = b<n } pr rewrite pr | <N'Refl a<n b<n = refl

numberLessThanOrder : (n : ℕ) → TotalOrder (numberLessThan n)
PartialOrder._<_ (TotalOrder.order (numberLessThanOrder n)) = λ a b → (numberLessThan.a a) <N numberLessThan.a b
PartialOrder.irreflexive (TotalOrder.order (numberLessThanOrder n)) pr = TotalOrder.irreflexive ℕTotalOrder pr
PartialOrder.<Transitive (TotalOrder.order (numberLessThanOrder n)) pr1 pr2 = TotalOrder.<Transitive ℕTotalOrder pr1 pr2
TotalOrder.totality (numberLessThanOrder n) a b with totality (numberLessThan.a a) (numberLessThan.a b)
TotalOrder.totality (numberLessThanOrder n) a b | inl (inl x) = inl (inl x)
TotalOrder.totality (numberLessThanOrder n) a b | inl (inr x) = inl (inr x)
TotalOrder.totality (numberLessThanOrder n) a b | inr x rewrite x = inr (numberLessThanEquality a b x)

numberLessThanInject : {newMax : ℕ} → (max : ℕ) → (n : numberLessThan max) → (max <N newMax) → (numberLessThan newMax)
numberLessThanInject max record { a = n ; a<n = n<max } max<newMax = record { a = n ; a<n = <NTo<N' (PartialOrder.<Transitive (TotalOrder.order ℕTotalOrder) (<N'To<N n<max) max<newMax) }

numberLessThanInjectComp : {max : ℕ} (a b : ℕ) → (i : numberLessThan b) → (pr : b <N a) → (pr2 : a <N max) → numberLessThanInject {max} a (numberLessThanInject {a} b i pr) pr2 ≡ numberLessThanInject {max} b i (PartialOrder.<Transitive (TotalOrder.order ℕTotalOrder) pr pr2)
numberLessThanInjectComp {max} a b record { a = i ; a<n = i<max } b<a a<max = numberLessThanEquality _ _ refl

allNumbersLessThanDescending : (n : ℕ) → Vec (numberLessThan n) n
allNumbersLessThanDescending zero = []
allNumbersLessThanDescending (succ n) = record { a = n ; a<n = <NTo<N' (le zero refl) } ,- vecMap (λ i → numberLessThanInject {succ n} (numberLessThan.upper i) i (le zero refl)) (allNumbersLessThanDescending n)

allNumbersLessThan : (n : ℕ) → Vec (numberLessThan n) n
allNumbersLessThan n = vecRev (allNumbersLessThanDescending n)

maxDivides : (a b : ℕ) → ((TotalOrder.max ℕTotalOrder a b) ∣ a) → (TotalOrder.max ℕTotalOrder a b) ∣ b → (((a ≡ 0) && (0 <N b)) || ((b ≡ 0) && (0 <N a))) || (a ≡ b)
maxDivides a b max|a max|b with totality a b
maxDivides a b max|a max|b | inl (inl a<b) = inl (inl (record { fst = gg ; snd = identityOfIndiscernablesLeft _<N_ a<b gg}))
  where
    gg : a ≡ 0
    gg = biggerThanCantDivideLemma {a} {b} a<b max|a
maxDivides a b max|a max|b | inl (inr b<a) = inl (inr (record { fst = gg ; snd = identityOfIndiscernablesLeft _<N_ b<a gg }))
  where
    gg : b ≡ 0
    gg = biggerThanCantDivideLemma b<a max|b
maxDivides a .a a|max b|max | inr refl = inr refl

{-
hcfsEquivalent' : {a b : ℕ} → extensionalHCF a b → hcfData a b
hcfData.c (hcfsEquivalent' {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; hcfExtension = hcfExtension }) = c
hcfData.c|a (hcfsEquivalent' {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; hcfExtension = hcfExtension }) = c|a
hcfData.c|b (hcfsEquivalent' {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; hcfExtension = hcfExtension }) = c|b
hcfData.hcf (hcfsEquivalent' {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; hcfExtension = hcfExtension }) x x|a x|b with totality ℕTotalOrder x c
hcfData.hcf (hcfsEquivalent' {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; zeroCase = zeroCase ; hcfExtension = hcfExtension ; hcfExtensionIsRightLength = hIRL }) x x|a x|b | inl (inl x<c) = {!!}
  where
    xLess : numberLessThan c
    xLess = record { a = x ; a<n = x<c }
    pair : Set
    pair = Sg (numberLessThan c) (λ i → (notDiv (numberLessThan.a i) a || notDiv (numberLessThan.a i) b) || (numberLessThan.a i ∣ a) & numberLessThan.a i ∣ b & (numberLessThan.a i ∣ c))
    pr : Sg pair λ p → (lookup (MapWithDomain.map hcfExtension) xLess ≡ {!!})
    pr = MapWithDomain.lookup' hcfExtension xLess (hcfsContains {a} {b} {x} (record { c = c ; c|a = c|a ; c|b = c|b ; zeroCase = zeroCase ; hcfExtension = hcfExtension ; hcfExtensionIsRightLength = hIRL }) x<c)
hcfData.hcf (hcfsEquivalent' {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; zeroCase = _ ; hcfExtension = hcfExtension ; hcfExtensionIsRightLength = _ }) x x|a x|b | inl (inr c<x) = {!!}
hcfData.hcf (hcfsEquivalent' {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; zeroCase = _ ; hcfExtension = hcfExtension ; hcfExtensionIsRightLength = _ }) x x|a x|b | inr x=c rewrite x=c = aDivA c

extensionalHCFEquality : {a b : ℕ} → {h1 h2 : extensionalHCF a b} → (extensionalHCF.c h1 ≡ extensionalHCF.c h2) → h1 ≡ h2
extensionalHCFEquality {a} {b} {record { c = c1 ; c|a = c|a1 ; c|b = c|b1 ; hcfExtension = hcfExtension1 }} {record { c = c2 ; c|a = c|a2 ; c|b = c|b2 ; hcfExtension = hcfExtension2 }} pr rewrite pr = {!!}
-}

divisorIsSmaller : {a b : ℕ} → a ∣ succ b → succ b <N a → False
divisorIsSmaller {a} {b} (divides record { quot = zero ; rem = .0 ; pr = pr } refl) sb<a rewrite Semiring.sumZeroRight ℕSemiring (a *N zero) = go
  where
    go : False
    go rewrite Semiring.productZeroRight ℕSemiring a = naughtE pr
divisorIsSmaller {a} {b} (divides record { quot = (succ quot) ; rem = .0 ; pr = pr } refl) sb<a rewrite Semiring.sumZeroRight ℕSemiring (a *N succ quot) = go
  where
    go : False
    go rewrite equalityCommutative pr = go'
      where
        go' : False
        go' rewrite multiplicationNIsCommutative a (succ quot) = cannotAddAndEnlarge' sb<a

primeDivisorIs1OrP : {a p : ℕ} → (prime : Prime p) → (a ∣ p) → (a ≡ 1) || (a ≡ p)
primeDivisorIs1OrP {zero} {zero} prime a|p = inr refl
primeDivisorIs1OrP {zero} {succ p} prime a|p = exFalso (zeroDividesNothing p a|p)
primeDivisorIs1OrP {succ zero} {p} prime a|p = inl refl
primeDivisorIs1OrP {succ (succ a)} {p} prime a|p with totality (succ (succ a)) p
primeDivisorIs1OrP {succ (succ a)} {p} prime a|p | inl (inl ssa<p) = go p prime a|p ssa<p
  where
    go : (n : ℕ) → Prime n → succ (succ a) ∣ n → succ (succ a) <N n → (succ (succ a) ≡ 1) || (succ (succ a) ≡ p)
    go zero pr x|n n<n = exFalso (zeroIsNotPrime pr)
    go (succ zero) pr x|n n<n = exFalso (oneIsNotPrime pr)
    go (succ (succ n)) pr x|n n<n = inl ((Prime.pr pr) {succ (succ a)} x|n n<n (succIsPositive (succ a)))
primeDivisorIs1OrP {succ (succ a)} {zero} prime a|p | inl (inr x) = exFalso (zeroIsNotPrime prime)
primeDivisorIs1OrP {succ (succ a)} {succ p} prime a|p | inl (inr x) = exFalso (divisorIsSmaller {succ (succ a)} {p} a|p x)
primeDivisorIs1OrP {succ (succ a)} {p} prime a|p | inr x = inr x

hcfPrimeIsOne' : {p : ℕ} → {a : ℕ} → (Prime p) → (0 <N divisionAlgResult.rem (divisionAlg p a)) → (extendedHcf.c (euclid a p) ≡ 1) || (extendedHcf.c (euclid a p) ≡ p)
hcfPrimeIsOne' {p} {a} pPrime pCoprimeA with euclid a p
hcfPrimeIsOne' {p} {a} pPrime pCoprimeA | record { hcf = record { c = hcf ; c|a = hcf|a ; c|b = hcf|p ; hcf = hcfPr } } with divisionAlg p a
hcfPrimeIsOne' {p} {a} pPrime pCoprimeA | record { hcf = record { c = hcf ; c|a = hcf|a ; c|b = hcf|p ; hcf = hcfPr } } | record { quot = quot ; rem = rem ; pr = prPDivA } with primeDivisorIs1OrP pPrime hcf|p
hcfPrimeIsOne' {p} {a} pPrime pCoprimeA | record { hcf = record { c = hcf ; c|a = hcf|a ; c|b = hcf|p ; hcf = hcfPr } } | record { quot = quot ; rem = rem ; pr = prPDivA } | inl x = inl x
hcfPrimeIsOne' {p} {a} pPrime pCoprimeA | record { hcf = record { c = hcf ; c|a = hcf|a ; c|b = hcf|p ; hcf = hcfPr } } | record { quot = quot ; rem = rem ; pr = prPDivA } | inr x = inr x

divisionDecidable : (a b : ℕ) → (a ∣ b) || ((a ∣ b) → False)
divisionDecidable zero zero = inl (aDivA zero)
divisionDecidable zero (succ b) = inr f
  where
    f : zero ∣ succ b → False
    f (divides record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = remIsSmall } x) rewrite x = naughtE pr
divisionDecidable (succ a) b with divisionAlg (succ a) b
divisionDecidable (succ a) b | record { quot = quot ; rem = zero ; pr = pr ; remIsSmall = remSmall } = inl (divides (record { quot = quot ; rem = zero ; pr = pr ; remIsSmall = remSmall ; quotSmall = inl (succIsPositive a) }) refl)
divisionDecidable (succ a) b | record { quot = b/a ; rem = succ rem ; pr = prANotDivB ; remIsSmall = inr p } = exFalso (naughtE (equalityCommutative p))
divisionDecidable (succ a) b | record { quot = b/a ; rem = succ rem ; pr = prANotDivB ; remIsSmall = inl p } = inr f
  where
    f : (succ a) ∣ b → False
    f (divides record { quot = b/a' ; rem = .0 ; pr = pr } refl) rewrite Semiring.sumZeroRight ℕSemiring ((succ a) *N b/a') = naughtE (modUniqueLemma {zero} {succ rem} {succ a} b/a' b/a (succIsPositive a) p comp')
      where
        comp : (succ a) *N b/a' ≡ (succ a) *N b/a +N succ rem
        comp = transitivity pr (equalityCommutative prANotDivB)
        comp' : (succ a) *N b/a' +N zero ≡ (succ a) *N b/a +N succ rem
        comp' rewrite Semiring.sumZeroRight ℕSemiring (succ a *N b/a') = comp

doesNotDivideImpliesNonzeroRem : (a b : ℕ) → ((a ∣ b) → False) → 0 <N divisionAlgResult.rem (divisionAlg a b)
doesNotDivideImpliesNonzeroRem a b pr with divisionAlg a b
doesNotDivideImpliesNonzeroRem a b pr | record { quot = quot ; rem = rem ; pr = divAlgPr ; remIsSmall = remIsSmall } with zeroIsValidRem rem
doesNotDivideImpliesNonzeroRem a b pr | record { quot = quot ; rem = rem ; pr = divAlgPr ; remIsSmall = remIsSmall } | inl x = x
doesNotDivideImpliesNonzeroRem a b pr | record { quot = quot ; rem = rem ; pr = divAlgPr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } | inr x = exFalso (pr aDivB)
  where
    aDivB : a ∣ b
    aDivB = divides (record { quot = quot ; rem = rem ; pr = divAlgPr ; remIsSmall = remIsSmall ; quotSmall = quotSmall }) x

hcfPrimeIsOne : {p : ℕ} → {a : ℕ} → (Prime p) → ((p ∣ a) → False) → extendedHcf.c (euclid a p) ≡ 1
hcfPrimeIsOne {p} {a} pPrime pr with hcfPrimeIsOne' {p} {a} pPrime (doesNotDivideImpliesNonzeroRem p a pr)
hcfPrimeIsOne {p} {a} pPrime pr | inl x = x
hcfPrimeIsOne {p} {a} pPrime pr | inr x with euclid a p
hcfPrimeIsOne {p} {a} pPrime pr | inr x | record { hcf = record { c = c ; c|a = c|a ; c|b = c|b ; hcf = hcf } ; extended1 = extended1 ; extended2 = extended2 ; extendedProof = extendedProof } rewrite x = exFalso (pr c|a)

reduceEquationMod : {a b c : ℕ} → (d : ℕ) → (a ∣ b) → (a ∣ c) → b ≡ c +N d → a ∣ d
reduceEquationMod {a} {b} {c} 0 a|b a|c pr = aDivZero a
reduceEquationMod {a} {b} {c} (succ d) (divides record { quot = b/a ; rem = .0 ; pr = prb/a ; remIsSmall = r1 ; quotSmall = qSm1 } refl) (divides record { quot = c/a ; rem = .0 ; pr = prc/a ; remIsSmall = r2 ; quotSmall = qSm2 } refl) b=c+d = identityOfIndiscernablesRight _∣_ a|b-c ex
  where
    c<b : c <N b
    c<b rewrite succExtracts c d | Semiring.commutative ℕSemiring c d = le d (equalityCommutative b=c+d)
    a|b-c : a ∣ subtractionNResult.result (-N (inl c<b))
    a|b-c = dividesBothImpliesDividesDifference (divides record { quot = b/a ; rem = 0 ; pr = prb/a ; remIsSmall = r1 ; quotSmall = qSm1 } refl) (divides record { quot = c/a ; rem = 0 ; pr = prc/a ; remIsSmall = r2 ; quotSmall = qSm2 } refl) c<b
    ex : subtractionNResult.result (-N {c} {b} (inl c<b)) ≡ subtractionNResult.result (-N {0} {succ d} (inl (succIsPositive d)))
    ex = equivalentSubtraction c (succ d) b 0 (c<b) (succIsPositive d) (equalityCommutative (identityOfIndiscernablesLeft _≡_ b=c+d (equalityCommutative (Semiring.sumZeroRight ℕSemiring b))))

primesArePrime : {p : ℕ} → {a b : ℕ} → (Prime p) → p ∣ (a *N b) → (p ∣ a) || (p ∣ b)
primesArePrime {p} {a} {b} pPrime pr with divisionDecidable p a
primesArePrime {p} {a} {b} pPrime pr | inl p|a = inl p|a
primesArePrime {p} {a} {b} pPrime (divides record {quot = ab/p ; rem = .0 ; pr = p|ab ; remIsSmall = _ ; quotSmall = quotSmall } refl) | inr notp|a = inr (answer ex'')
  where
    euc : extendedHcf a p
    euc = euclid a p
    h : extendedHcf.c euc ≡ 1
    h = hcfPrimeIsOne {p} {a} pPrime notp|a
    x = extendedHcf.extended1 euc
    y = extendedHcf.extended2 euc
    extended : ((a *N x) ≡ p *N y +N extendedHcf.c euc) || (a *N x +N extendedHcf.c euc ≡ p *N y)
    extended = extendedHcf.extendedProof euc
    extended' : (a *N x ≡ p *N y +N 1) || (a *N x +N 1 ≡ p *N y)
    extended' rewrite equalityCommutative h = extended
    extended'' : ((a *N x ≡ p *N y +N 1) || (a *N x +N 1 ≡ p *N y)) → (b *N (a *N x) ≡ b *N (p *N y +N 1)) || (b *N (a *N x +N 1) ≡ b *N (p *N y))
    extended'' (inl z) = inl (applyEquality (λ t → b *N t) z)
    extended'' (inr z) = inr (applyEquality (λ t → b *N t) z)
    ex : (b *N (a *N x) ≡ b *N (p *N y +N 1)) || (b *N (a *N x +N 1) ≡ b *N (p *N y)) → ((b *N a) *N x ≡ (b *N (p *N y) +N b)) || (((b *N a) *N x +N b) ≡ b *N (p *N y))
    ex (inl z) rewrite Semiring.*Associative ℕSemiring b a x | Semiring.+DistributesOver* ℕSemiring b (p *N y) 1 | Semiring.productOneRight ℕSemiring b = inl z
    ex (inr z) rewrite Semiring.+DistributesOver* ℕSemiring b (a *N x) 1 | Semiring.*Associative ℕSemiring b a x | Semiring.productOneRight ℕSemiring b = inr z
    ex' : ((a *N b) *N x ≡ ((p *N y) *N b +N b)) || (((a *N b) *N x +N b) ≡ (p *N y) *N b)
    ex' rewrite multiplicationNIsCommutative a b | multiplicationNIsCommutative (p *N y) b = ex (extended'' extended')
    ex'' : ((a *N b) *N x ≡ (p *N (y *N b) +N b)) || (((a *N b) *N x +N b) ≡ p *N (y *N b))
    ex'' rewrite Semiring.*Associative ℕSemiring (p) y b = ex'
    inter1 : p ∣ (a *N b) *N x
    inter1 = divides (record {quot = ab/p *N x ; rem = 0 ; pr = g ; remIsSmall = zeroIsValidRem p ; quotSmall = qsm quotSmall}) refl
      where
        g' : p *N ab/p ≡ a *N b
        g' rewrite Semiring.sumZeroRight ℕSemiring (p *N ab/p) = p|ab
        g'' : p *N (ab/p *N x) ≡ (a *N b) *N x
        g'' rewrite Semiring.*Associative ℕSemiring (p) ab/p x = applyEquality (λ t → t *N x) g'
        g : p *N (ab/p *N x) +N 0 ≡ (a *N b) *N x
        g rewrite Semiring.sumZeroRight ℕSemiring (p *N (ab/p *N x)) = g''
        qsm : ((0 <N p) || ((0 ≡ p) && (ab/p ≡ 0))) → (0 <N p) || ((0 ≡ p) && (ab/p *N x ≡ 0))
        qsm (inl pr) = inl pr
        qsm (inr (pr1 ,, pr2)) = inr (pr1 ,, blah)
          where
            blah : ab/p *N x ≡ 0
            blah rewrite pr2 = refl
    inter2 : ((0 <N p) || ((0 ≡ p) && (ab/p ≡ 0))) → p ∣ (p *N (y *N b))
    inter2 (inl 0<p) = divides (record {quot = y *N b ; rem = 0 ; pr = Semiring.sumZeroRight ℕSemiring (p *N (y *N b)) ; remIsSmall = zeroIsValidRem p ; quotSmall = inl 0<p }) refl
    inter2 (inr (0=p ,, ab/p=0)) = divides (record {quot = y *N b ; rem = 0 ; pr = Semiring.sumZeroRight ℕSemiring (p *N (y *N b)) ; remIsSmall = zeroIsValidRem p ; quotSmall = inr (0=p ,, blah) }) refl
      where
        oneZero : (a ≡ 0) || (b ≡ 0)
        oneZero rewrite Semiring.commutative ℕSemiring (p *N ab/p) 0 | ab/p=0 | equalityCommutative 0=p = productZeroImpliesOperandZero (equalityCommutative p|ab)
        blah : y *N b ≡ 0
        blah with oneZero
        blah | inl x1 = exFalso (notp|a p|a)
          where
            p|a : p ∣ a
            p|a rewrite x1 = aDivZero p
        blah | inr x1 rewrite x1 = Semiring.productZeroRight ℕSemiring y
    answer : ((a *N b) *N x ≡ (p *N (y *N b) +N b)) || (((a *N b) *N x +N b) ≡ p *N (y *N b)) → (p ∣ b)
    answer (inl z) = reduceEquationMod {p} b inter1 (inter2 quotSmall) z
    answer (inr z) = reduceEquationMod {p} b (inter2 quotSmall) inter1 (equalityCommutative z)

primesAreBiggerThanOne : {p : ℕ} → Prime p → (1 <N p)
primesAreBiggerThanOne {zero} record { p>1 = (le x ()) ; pr = pr }
primesAreBiggerThanOne {succ zero} pr = exFalso (oneIsNotPrime pr)
primesAreBiggerThanOne {succ (succ p)} pr = succPreservesInequality (succIsPositive p)

primesAreBiggerThanZero : {p : ℕ} → Prime p → 0 <N p
primesAreBiggerThanZero {p} pr = TotalOrder.<Transitive ℕTotalOrder (succIsPositive 0) (primesAreBiggerThanOne pr)

record notDividedByLessThan (a : ℕ) (firstPossibleDivisor : ℕ) : Set where
  field
    previousDoNotDivide : ∀ x → 1 <N x → x <N firstPossibleDivisor → x ∣ a → False

alternativePrime : {a : ℕ} → 1 <N a → notDividedByLessThan a a → Prime a
alternativePrime {a} 1<a record { previousDoNotDivide = previousDoNotDivide } = record { pr = pr ; p>1 = 1<a}
  where
    pr : {x : ℕ} → (x|a : x ∣ a) (x<a : x <N a) (0<x : zero <N x) → x ≡ 1
    pr {zero} _ _ (le x ())
    pr {succ zero} _ _ _ = refl
    pr {succ (succ x)} x|a x<a 0<x = exFalso (previousDoNotDivide (succ (succ x)) (succPreservesInequality (succIsPositive x)) x<a x|a)

divisibilityTransitive : {a b c : ℕ} → a ∣ b → b ∣ c → a ∣ c
divisibilityTransitive {a} {b} {c} (divides record { quot = b/a ; rem = .0 ; pr = prDivAB ; remIsSmall = remIsSmallAB ; quotSmall = quotSmall } refl) (divides record { quot = c/b ; rem = .0 ; pr = prDivBC ; remIsSmall = remIsSmallBC } refl) = divides record { quot = b/a *N c/b ; rem = 0 ; pr = p ; remIsSmall = zeroIsValidRem a ; quotSmall = qsm quotSmall } refl
  where
    p : a *N (b/a *N c/b) +N 0 ≡ c
    p rewrite Semiring.sumZeroRight ℕSemiring (a *N (b/a *N c/b)) | Semiring.sumZeroRight ℕSemiring (b *N c/b) | Semiring.sumZeroRight ℕSemiring (a *N b/a) | Semiring.*Associative ℕSemiring a b/a c/b | prDivAB | prDivBC = refl
    qsm : ((0 <N a) || (0 ≡ a) && (b/a ≡ 0)) → ((0 <N a) || (0 ≡ a) && (b/a *N c/b ≡ 0))
    qsm (inl x) = inl x
    qsm (inr (p1 ,, p2)) = inr (p1 ,, blah)
      where
        blah : b/a *N c/b ≡ 0
        blah rewrite p2 = refl

compositeOrPrimeLemma : {a b : ℕ} → notDividedByLessThan b a → a ∣ b → {i : ℕ} → (i ∣ a) → (i <N a) → (0 <N i) → i ≡ 1
compositeOrPrimeLemma {a} {b} record { previousDoNotDivide = previousDoNotDivide } a|b {zero} i|a i<a 0<i = exFalso (lessIrreflexive 0<i)
compositeOrPrimeLemma {a} {b} record { previousDoNotDivide = previousDoNotDivide } a|b {succ zero} i|a i<a 0<i = refl
compositeOrPrimeLemma {a} {b} record { previousDoNotDivide = previousDoNotDivide } a|b {succ (succ i)} i|a i<a 0<i = exFalso (previousDoNotDivide (succ (succ i)) (succPreservesInequality (succIsPositive i)) i<a (divisibilityTransitive i|a a|b) )

compositeOrPrime : (a : ℕ) → (1 <N a) → (Composite a) || (Prime a)
compositeOrPrime a pr = go''' go''
  where
    base : notDividedByLessThan a 2
    base = record { previousDoNotDivide = λ x 1<x x<2 _ → noIntegersBetweenXAndSuccX 1 1<x x<2 }
    go : {firstPoss : ℕ} → notDividedByLessThan a firstPoss → ((notDividedByLessThan a (succ firstPoss)) || ((firstPoss ∣ a) && (firstPoss <N a))) || (firstPoss ≡ a)
    go' : (firstPoss : ℕ) → (((notDividedByLessThan a firstPoss) || (Composite a))) || (notDividedByLessThan a a)
    go'' : (notDividedByLessThan a a) || (Composite a)
    go'' with go' a
    ... | inr x = inl x
    ... | inl x = x
    go''' : ((notDividedByLessThan a a) || (Composite a)) → ((Composite a) || (Prime a))
    go''' (inl x) = inr (alternativePrime pr x)
    go''' (inr x) = inl x
    go' (zero) = inl (inl (record { previousDoNotDivide = λ x 1<x x<0 _ → zeroNeverGreater x<0 }))
    go' (succ 0) = inl (inl (record { previousDoNotDivide = λ x 1<x x<1 _ → TotalOrder.irreflexive ℕTotalOrder (TotalOrder.<Transitive ℕTotalOrder x<1 1<x) }))
    go' (succ (succ zero)) = inl (inl base)
    go' (succ (succ (succ firstPoss))) with go' (succ (succ firstPoss))
    go' (succ (succ (succ firstPoss))) | inl (inl x) with go {succ (succ firstPoss)} x
    go' (succ (succ (succ firstPoss))) | inl (inl x) | inl (inl x1) = inl (inl x1)
    go' (succ (succ (succ firstPoss))) | inl (inl x) | inl (inr x1) = inl (inr record { noSmallerDivisors = λ i i<ssFP 1<i i|a → notDividedByLessThan.previousDoNotDivide x i 1<i i<ssFP i|a ; n>1 = pr ; divisor = succ (succ firstPoss) ; dividesN = _&&_.fst x1 ; divisorLessN = _&&_.snd x1 ; divisorNot1 = succPreservesInequality (succIsPositive firstPoss) ; divisorPrime = record { p>1 = succPreservesInequality (succIsPositive firstPoss) ; pr = compositeOrPrimeLemma {succ (succ firstPoss)} {a} x (_&&_.fst x1) } })
    go' (succ (succ (succ firstPoss))) | inl (inl x) | inr y rewrite y = inr x
    go' (succ (succ (succ firstPoss))) | inl (inr x) = inl (inr x)
    go' (succ (succ (succ firstPoss))) | inr x = inr x

    go {zero} pr = inl (inl (record { previousDoNotDivide = λ x 1<x x<1 _ → irreflexive (<Transitive x<1 1<x)}))
    go {succ firstPoss} knownCoprime with totality (succ firstPoss) a
    go {succ firstPoss} knownCoprime | inr x = inr x
    go {succ firstPoss} knownCoprime | inl (inl sFP<a) with divisionAlg (succ firstPoss) a
    go {succ firstPoss} knownCoprime | inl (inl sFP<a) | record { quot = quot ; rem = zero ; pr = pr ; remIsSmall = remIsSmall } = inl (inr record { fst = (divides (record { quot = quot ; rem = zero ; remIsSmall = remIsSmall ; pr = pr ; quotSmall = inl (succIsPositive firstPoss) }) refl) ; snd = sFP<a })
    go {succ firstPoss} knownCoprime | inl (inl sFP<a) | record { quot = quot ; rem = succ rem ; pr = pr ; remIsSmall = remIsSmall } = inl next
      where
        previous : ∀ x → 1 <N x → x <N succ firstPoss → x ∣ a → False
        previous = notDividedByLessThan.previousDoNotDivide knownCoprime
        next : notDividedByLessThan a (succ (succ firstPoss)) || (((succ firstPoss) ∣ a) && (succ firstPoss <N a))
        next with divisionAlg (succ firstPoss) a
        next | record { quot = quot ; rem = zero ; pr = pr ; remIsSmall = remIsSmall } = inr (record { fst = divides record { quot = quot ; rem = zero ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = inl (succIsPositive firstPoss) } refl ; snd = sFP<a } )
        next | record { quot = quot ; rem = succ rem ; pr = pr ; remIsSmall = remIsSmall } = inl record { previousDoNotDivide = (next' record { quot = quot ; rem = succ rem ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = inl (succIsPositive firstPoss)  } (succIsPositive rem)) }
          where
            next' : (res : divisionAlgResult (succ firstPoss) a) → (pr : 0 <N divisionAlgResult.rem res) → (x : ℕ) → 1 <N x → x <N succ (succ firstPoss) → x ∣ a → False
            next' (res) (prDiv) x 1<x x<ssFirstposs x|a with totality x (succ firstPoss)
            next' (res) (prDiv) x 1<x x<ssFirstposs x|a | inl (inl x<sFirstPoss) = previous x 1<x x<sFirstPoss x|a
            next' (res) (prDiv) x 1<x x<ssFirstposs x|a | inl (inr sFirstPoss<x) = noIntegersBetweenXAndSuccX (succ firstPoss) sFirstPoss<x x<ssFirstposs
            next' res prDiv x 1<x x<ssFirstposs (divides res1 x1) | inr x=sFirstPoss rewrite equalityCommutative x=sFirstPoss = g
              where
                g : False
                g with modIsUnique res res1
                ... | r rewrite r = lessImpliesNotEqual prDiv (equalityCommutative x1)
    go {succ firstPoss} record { previousDoNotDivide = previousDoNotDivide } | inl (inr a<sFP) = exFalso (previousDoNotDivide a pr a<sFP (aDivA a))

primeDivPrimeImpliesEqual : {p1 p2 : ℕ} → Prime p1 → Prime p2 → p1 ∣ p2 → p1 ≡ p2
primeDivPrimeImpliesEqual {p1} {p2} pr1 pr2 p1|p2 with totality p1 p2
primeDivPrimeImpliesEqual {p1} {p2} pr1 record { p>1 = p>1 ; pr = pr } p1|p2 | inl (inl p1<p2) with pr p1|p2 p1<p2 (primesAreBiggerThanZero {p1} pr1)
... | p1=1 = exFalso (oneIsNotPrime contr)
  where
    contr : Prime 1
    contr rewrite p1=1 = pr1
primeDivPrimeImpliesEqual {p1} {zero} pr1 pr2 p1|p2 | inl (inr p1>p2) = exFalso (zeroIsNotPrime pr2)
primeDivPrimeImpliesEqual {p1} {succ p2} pr1 pr2 p1|p2 | inl (inr p1>p2) = exFalso (divisorIsSmaller p1|p2 p1>p2)
primeDivPrimeImpliesEqual {p1} {p2} pr1 pr2 p1|p2 | inr p1=p2 = p1=p2

mult1Lemma : {a b : ℕ} → a *N succ b ≡ 1 → (a ≡ 1) && (b ≡ 0)
mult1Lemma {a} {b} pr = record { fst = _&&_.fst p ; snd = q}
  where
    p : (a ≡ 1) && (succ b ≡ 1)
    p = productOneImpliesOperandsOne pr
    q : b ≡ zero
    q = succInjective (_&&_.snd p)

oneHasNoDivisors : {a : ℕ} → a ∣ 1 → a ≡ 1
oneHasNoDivisors {a} (divides record { quot = zero ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall } refl) rewrite Semiring.sumZeroRight ℕSemiring (a *N zero) | multiplicationNIsCommutative a zero | Semiring.sumZeroRight ℕSemiring a = exFalso (naughtE pr)
oneHasNoDivisors {a} (divides record { quot = (succ quot) ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall } refl) rewrite Semiring.sumZeroRight ℕSemiring (a *N succ quot) = _&&_.fst (mult1Lemma pr)

notSmallerMeansGE : {a b : ℕ} → (a <N b → False) → b ≤N a
notSmallerMeansGE {a} {b} notA<b with totality a b
notSmallerMeansGE {a} {b} notA<b | inl (inl x) = exFalso (notA<b x)
notSmallerMeansGE {a} {b} notA<b | inl (inr x) = inl x
notSmallerMeansGE {a} {b} notA<b | inr x = inr (equalityCommutative x)


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

-- In this module, we define the subtyping relation of D<: according to Lemma 2.
module Dsub where

open import Data.List as List
open import Data.List.All as All
open import Data.Nat as ℕ
open import Data.Maybe as Maybe
open import Data.Product as Σ
open import Data.Sum
open import Data.Empty renaming (⊥ to False)
open import Data.Vec as Vec renaming (_∷_ to _‼_ ; [] to nil) hiding (_++_)
open import Function

open import Data.Maybe.Properties as Maybeₚ
open import Data.Nat.Properties as ℕₚ
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import DsubDef
open import Utils

module Dsub where

  infix 4 _⊢_<:_

  data _⊢_<:_ : Env → Typ → Typ → Set where
    dtop   : ∀ {Γ T} →
      Γ ⊢ T <: ⊤
    dbot   : ∀ {Γ T} →
      Γ ⊢ ⊥ <: T
    drefl  : ∀ {Γ T} →
      Γ ⊢ T <: T
    dtrans : ∀ {Γ S U} T →
      (S<:T : Γ ⊢ S <: T) →
      (T<:U : Γ ⊢ T <: U) →
      Γ ⊢ S <: U
    dbnd   : ∀ {Γ S U S′ U′} →
      (S′<:S : Γ ⊢ S′ <: S) →
      (U<:U′ : Γ ⊢ U <: U′) →
      Γ ⊢ ⟨A: S ⋯ U ⟩ <: ⟨A: S′ ⋯ U′ ⟩
    dall   : ∀ {Γ S U S′ U′} →
      (S′<:S : Γ ⊢ S′ <: S) →
      (U<:U′ : (S′ ∷ Γ) ⊢ U <: U′) →
      Γ ⊢ Π S ∙ U <: Π S′ ∙ U′
    dsel₁  : ∀ {Γ n T S} →
      (T∈Γ : env-lookup Γ n ≡ just T) →
      (D : Γ ⊢ T <: ⟨A: S ⋯ ⊤ ⟩) →
      Γ ⊢ S <: n ∙A
    dsel₂  : ∀ {Γ n T U} →
      (T∈Γ : env-lookup Γ n ≡ just T) →
      (D : Γ ⊢ T <: ⟨A: ⊥ ⋯ U ⟩) →
      Γ ⊢ n ∙A <: U

  D-measure : ∀ {Γ S U} (D : Γ ⊢ S <: U) → ℕ
  D-measure dtop                 = 1
  D-measure dbot                 = 1
  D-measure drefl                = 1
  D-measure (dtrans _ S<:T T<:U) = 1 + D-measure S<:T + D-measure T<:U
  D-measure (dbnd D₁ D₂)         = 1 + D-measure D₁ + D-measure D₂
  D-measure (dall Dp Db)         = 1 + D-measure Dp + D-measure Db
  D-measure (dsel₁ T∈Γ D)        = 1 + D-measure D
  D-measure (dsel₂ T∈Γ D)        = 1 + D-measure D

  D-measure≥1 : ∀ {Γ S U} (D : Γ ⊢ S <: U) → D-measure D ≥ 1
  D-measure≥1 dtop           = s≤s z≤n
  D-measure≥1 dbot           = s≤s z≤n
  D-measure≥1 drefl          = s≤s z≤n
  D-measure≥1 (dtrans _ _ _) = s≤s z≤n
  D-measure≥1 (dbnd _ _)     = s≤s z≤n
  D-measure≥1 (dall _ _)     = s≤s z≤n
  D-measure≥1 (dsel₁ _ _)    = s≤s z≤n
  D-measure≥1 (dsel₂ _ _)    = s≤s z≤n

  D-deriv : Set
  D-deriv = Σ (Env × Typ × Typ) λ { (Γ , S , U) → Γ ⊢ S <: U }

  env : D-deriv → Env
  env ((Γ , _) , _) = Γ

  typ₁ : D-deriv → Typ
  typ₁ ((_ , S , U) , _) = S

  typ₂ : D-deriv → Typ
  typ₂ ((_ , S , U) , _) = U

  drefl-dec : ∀ (D : D-deriv) → Dec (D ≡ ((env D , typ₁ D , _) , drefl))
  drefl-dec (_ , dtop)         = no (λ ())
  drefl-dec (_ , dbot)         = no (λ ())
  drefl-dec (_ , drefl)        = yes refl
  drefl-dec (_ , dtrans _ _ _) = no (λ ())
  drefl-dec (_ , dbnd _ _)     = no (λ ())
  drefl-dec (_ , dall _ _)     = no (λ ())
  drefl-dec (_ , dsel₁ _ _)    = no (λ ())
  drefl-dec (_ , dsel₂ _ _)    = no (λ ())

  -- weakening
  infixl 7 _⇑
  _⇑ : Env → Env
  [] ⇑      = []
  (T ∷ Γ) ⇑ = T ↑ length Γ ∷ Γ ⇑

  ↦∈-weaken-≤ : ∀ {n T Γ} →
                  n ↦ T ∈ Γ →
                ∀ Γ₁ Γ₂ T′ →
                  Γ ≡ Γ₁ ‣ Γ₂ →
                  length Γ₂ ≤ n →
                  suc n ↦ T ↑ length Γ₂ ∈ Γ₁ ‣ T′ ! ‣ Γ₂ ⇑
  ↦∈-weaken-≤ hd .(_ ∷ _) [] T′ refl z≤n       = tl hd
  ↦∈-weaken-≤ hd Γ₁ (_ ∷ Γ₂) T′ eqΓ ()
  ↦∈-weaken-≤ (tl T∈Γ) .(_ ∷ _) [] T′ refl z≤n = tl (tl T∈Γ)
  ↦∈-weaken-≤ (tl {_} {T} T∈Γ) Γ₁ (_ ∷ Γ₂) T′ refl (s≤s l≤n)
    rewrite ↑-↑-comm T 0 (length Γ₂) z≤n       = tl (↦∈-weaken-≤ T∈Γ Γ₁ Γ₂ T′ refl l≤n)

  ↦∈-weaken-> : ∀ {n T Γ} →
                  n ↦ T ∈ Γ →
                ∀ Γ₁ Γ₂ T′ →
                  Γ ≡ Γ₁ ‣ Γ₂ →
                  length Γ₂ > n →
                  n ↦ T ↑ length Γ₂ ∈ Γ₁ ‣ T′ ! ‣ Γ₂ ⇑
  ↦∈-weaken-> T∈Γ Γ₁ [] T′ eqΓ ()
  ↦∈-weaken-> (hd {T}) Γ₁ (_ ∷ Γ₂) T′ refl (s≤s l>n)
    rewrite ↑-↑-comm T 0 (length Γ₂) l>n = hd
  ↦∈-weaken-> (tl {_} {T} T∈Γ) Γ₁ (_ ∷ Γ₂) T′ refl (s≤s l>n)
    rewrite ↑-↑-comm T 0 (length Γ₂) z≤n = tl (↦∈-weaken-> T∈Γ Γ₁ Γ₂ T′ refl l>n)

  ↦∈-weaken : ∀ {n T Γ} →
                n ↦ T ∈ Γ →
              ∀ Γ₁ Γ₂ T′ →
                Γ ≡ Γ₁ ‣ Γ₂ →
                ↑-idx n (length Γ₂) ↦ T ↑ length Γ₂ ∈ Γ₁ ‣ T′ ! ‣ Γ₂ ⇑
  ↦∈-weaken {n} T∈Γ _ Γ₂ _ eqΓ with length Γ₂ ≤? n
  ... | yes l≤n = ↦∈-weaken-≤ T∈Γ _ Γ₂ _ eqΓ l≤n
  ... | no l>n  = ↦∈-weaken-> T∈Γ _ Γ₂ _ eqΓ (≰⇒> l>n)

  ↦∈-weaken′ : ∀ {n T Γ} →
                 env-lookup Γ n ≡ just T →
               ∀ Γ₁ Γ₂ T′ →
                 Γ ≡ Γ₁ ‣ Γ₂ →
                 env-lookup (Γ₁ ‣ T′ ! ‣ Γ₂ ⇑) (↑-idx n (length Γ₂)) ≡ just (T ↑ length Γ₂)
  ↦∈-weaken′ T∈Γ Γ₁ Γ₂ T′ eqΓ = ↦∈⇒lookup (↦∈-weaken (lookup⇒↦∈ T∈Γ) Γ₁ Γ₂ T′ eqΓ)

  <:-weakening-gen : ∀ {Γ S U} →
                        Γ ⊢ S <: U →
                      ∀ Γ₁ Γ₂ T →
                        Γ ≡ Γ₁ ‣ Γ₂ →
                        Γ₁ ‣ T ! ‣ Γ₂ ⇑ ⊢ S ↑ length Γ₂ <: U ↑ length Γ₂
  <:-weakening-gen dtop Γ₁ Γ₂ T eqΓ                    = dtop
  <:-weakening-gen dbot Γ₁ Γ₂ T eqΓ                    = dbot
  <:-weakening-gen drefl Γ₁ Γ₂ T eqΓ                   = drefl
  <:-weakening-gen (dtrans T′ S<:T′ T′<:U) Γ₁ Γ₂ T eqΓ = dtrans _
                                                                (<:-weakening-gen S<:T′ Γ₁ Γ₂ T eqΓ)
                                                                (<:-weakening-gen T′<:U Γ₁ Γ₂ T eqΓ)
  <:-weakening-gen (dbnd S′<:S U<:U′) Γ₁ Γ₂ T eqΓ      = dbnd (<:-weakening-gen S′<:S Γ₁ Γ₂ T eqΓ)
                                                              (<:-weakening-gen U<:U′ Γ₁ Γ₂ T eqΓ)
  <:-weakening-gen (dall S′<:S U<:U′) Γ₁ Γ₂ T eqΓ      = dall (<:-weakening-gen S′<:S Γ₁ Γ₂ T eqΓ)
                                                              (<:-weakening-gen U<:U′ Γ₁ (_ ∷ Γ₂) T (cong (_ ∷_) eqΓ))
  <:-weakening-gen (dsel₁ {_} {n} T∈Γ T<:B) Γ₁ Γ₂ T eqΓ
    rewrite ↑-var n (length Γ₂)                        = dsel₁ (↦∈-weaken′ T∈Γ Γ₁ Γ₂ T eqΓ)
                                                               (<:-weakening-gen T<:B Γ₁ Γ₂ T eqΓ)
  <:-weakening-gen (dsel₂ {_} {n} T∈Γ T<:B) Γ₁ Γ₂ T eqΓ
    rewrite ↑-var n (length Γ₂)                        = dsel₂ (↦∈-weaken′ T∈Γ Γ₁ Γ₂ T eqΓ)
                                                               (<:-weakening-gen T<:B Γ₁ Γ₂ T eqΓ)

  <:-weakening : ∀ {Γ₁ Γ₂ S U} T →
                    Γ₁ ‣ Γ₂ ⊢ S <: U →
                    Γ₁ ‣ T ! ‣ Γ₂ ⇑ ⊢ S ↑ length Γ₂ <: U ↑ length Γ₂
  <:-weakening T S<:U = <:-weakening-gen S<:U _ _ T refl

  <:-weakening-hd : ∀ {Γ S U} T →
                       Γ ⊢ S <: U →
                       Γ ‣ T ! ⊢ S ↑ 0 <: U ↑ 0
  <:-weakening-hd T = <:-weakening {Γ₂ = []} T

  -- narrowing
  infix 4 _≺:[_]_
  data _≺:[_]_ : Env → ℕ → Env → Set where
    ≺[_,_] : ∀ {Γ U} S → Γ ⊢ S <: U → Γ ‣ S ! ≺:[ 0 ] Γ ‣ U !
    _∷_    : ∀ {Γ₁ n Γ₂} T → Γ₁ ≺:[ n ] Γ₂ → Γ₁ ‣ T ! ≺:[ suc n ] Γ₂ ‣ T !

  <:∈-find : ∀ {x T Γ Γ′ n} →
               x ↦ T ∈ Γ →
               Γ′ ≺:[ n ] Γ →
               x ≡ n × (∃ λ T′ → n ↦ T′ ∈ Γ′ × Γ′ ⊢ T′ <: T) ⊎ x ≢ n × x ↦ T ∈ Γ′
  <:∈-find hd ≺[ T′ , T′<:T ]           = inj₁ (refl , T′ ↑ 0 , hd , <:-weakening-hd T′ T′<:T)
  <:∈-find hd (T ∷ Γ′≺:Γ)               = inj₂ ((λ ()) , hd)
  <:∈-find (tl T∈Γ) ≺[ T′ , T′<:T ]     = inj₂ ((λ ()) , tl T∈Γ)
  <:∈-find (tl T∈Γ) (S ∷ Γ′≺:Γ) with <:∈-find T∈Γ Γ′≺:Γ
  ... | inj₁ (x≡n , T′ , T′∈Γ′ , T′<:T) = inj₁ (cong suc x≡n , T′ ↑ 0 , tl T′∈Γ′ , <:-weakening-hd S T′<:T)
  ... | inj₂ (x≢n , T∈Γ′)               = inj₂ (x≢n ∘ suc-injective , tl T∈Γ′)

  <:∈-find′ : ∀ {x T Γ Γ′ n} →
                env-lookup Γ x ≡ just T →
                Γ′ ≺:[ n ] Γ →
                x ≡ n × (∃ λ T′ → env-lookup Γ′ n ≡ just T′ × Γ′ ⊢ T′ <: T) ⊎ x ≢ n × env-lookup Γ′ x ≡ just T
  <:∈-find′ T∈Γ Γ′≺Γ with <:∈-find (lookup⇒↦∈ T∈Γ) Γ′≺Γ
  ... | inj₁ (x≡n , T′ , T′∈Γ′ , T′<:T) = inj₁ (x≡n , T′ , ↦∈⇒lookup T′∈Γ′ , T′<:T)
  ... | inj₂ (x≢n , T∈Γ′)               = inj₂ (x≢n , ↦∈⇒lookup T∈Γ′)

  <:-narrow : ∀ {Γ Γ′ n S U T} →
                Γ ⊢ S <: U →
                Γ′ ≺:[ n ] Γ →
                env-lookup Γ n ≡ just T →
                Γ′ ⊢ S <: U
  <:-narrow dtop Γ′≺Γ T∈Γ                         = dtop
  <:-narrow dbot Γ′≺Γ T∈Γ                         = dbot
  <:-narrow drefl Γ′≺Γ T∈Γ                        = drefl
  <:-narrow (dtrans T S<:T T<:U) Γ′≺Γ T∈Γ         = dtrans T (<:-narrow S<:T Γ′≺Γ T∈Γ) (<:-narrow T<:U Γ′≺Γ T∈Γ)
  <:-narrow (dbnd S′<:S U<:U′) Γ′≺Γ T∈Γ           = dbnd (<:-narrow S′<:S Γ′≺Γ T∈Γ) (<:-narrow U<:U′ Γ′≺Γ T∈Γ)
  <:-narrow  {Γ} {Γ′} {n} (dall {S′ = S′} S′<:S U<:U′) Γ′≺Γ T∈Γ
    = dall (<:-narrow S′<:S Γ′≺Γ T∈Γ)
           (<:-narrow U<:U′ (_ ∷ Γ′≺Γ) (↦∈⇒lookup (tl {n} {T′ = S′} {Γ} (lookup⇒↦∈ T∈Γ))))
  <:-narrow (dsel₁ T′∈Γ T′<:B) Γ′≺Γ T∈Γ
    with <:∈-find′ T′∈Γ Γ′≺Γ
  ...  | inj₁ (refl , T″ , T″∈Γ′ , T″<:T)
    rewrite just-injective (trans (sym T′∈Γ) T∈Γ) = dsel₁ T″∈Γ′ (dtrans _ T″<:T (<:-narrow T′<:B Γ′≺Γ T∈Γ))
  ... | inj₂ (x≢n , T′∈Γ′)                        = dsel₁ T′∈Γ′ (<:-narrow T′<:B Γ′≺Γ T∈Γ)
  <:-narrow (dsel₂ T′∈Γ T′<:B) Γ′≺Γ T∈Γ
    with <:∈-find′ T′∈Γ Γ′≺Γ
  ...  | inj₁ (refl , T″ , T″∈Γ′ , T″<:T)
    rewrite just-injective (trans (sym T′∈Γ) T∈Γ) = dsel₂ T″∈Γ′ (dtrans _ T″<:T (<:-narrow T′<:B Γ′≺Γ T∈Γ))
  ... | inj₂ (x≢n , T′∈Γ′)                        = dsel₂ T′∈Γ′ (<:-narrow T′<:B Γ′≺Γ T∈Γ)

open Dsub hiding (<:-weakening-gen; <:-weakening; <:-weakening-hd
                 ; _≺:[_]_; ≺[_,_]; _∷_; <:∈-find; <:∈-find′; <:-narrow) public

-- materialization of inversion properties in invertible contexts
module DsubInvProperties {P : Env → Set}
                         (invertible : InvertibleEnv P) where

  module ContraEnvProperties = InvertibleProperties invertible _⊢_<:_
  open ContraEnvProperties public

  mutual
    <:⇒<:ᵢ : ∀ {Γ S U} → Γ ⊢ S <: U → P Γ → Γ ⊢ᵢ S <: U
    <:⇒<:ᵢ dtop pΓ                 = ditop
    <:⇒<:ᵢ dbot pΓ                 = dibot
    <:⇒<:ᵢ drefl pΓ                = direfl
    <:⇒<:ᵢ (dtrans T S<:T T<:U) pΓ = ditrans T (<:⇒<:ᵢ S<:T pΓ) (<:⇒<:ᵢ T<:U pΓ)
    <:⇒<:ᵢ (dbnd S′<:S U<:U′) pΓ   = dibnd (<:⇒<:ᵢ S′<:S pΓ) (<:⇒<:ᵢ U<:U′ pΓ)
    <:⇒<:ᵢ (dall S′<:S U<:U′) pΓ   = diall (<:⇒<:ᵢ S′<:S pΓ) U<:U′
    <:⇒<:ᵢ (dsel₁ T∈Γ T<:B) pΓ with sel-case T∈Γ T<:B pΓ
    ... | refl , _                 = dibot
    <:⇒<:ᵢ (dsel₂ T∈Γ T<:B) pΓ with sel-case T∈Γ T<:B pΓ
    ... | refl , U′ , refl
        with ⟨A:⟩<:⟨A:⟩ (<:⇒<:ᵢ T<:B pΓ) pΓ
    ...    | _ , U′<:U             = ditrans U′ (disel T∈Γ) U′<:U

    sel-case : ∀ {T Γ n S U} →
                 env-lookup Γ n ≡ just T →
                 Γ ⊢ T <: ⟨A: S ⋯ U ⟩ →
                 P Γ →
                 S ≡ ⊥ × ∃ λ U′ → T ≡ ⟨A: ⊥ ⋯ U′ ⟩
    sel-case {⊤} T∈Γ T<:B pΓ = case ⊤<: (<:⇒<:ᵢ T<:B pΓ) of λ ()
    sel-case {⊥} T∈Γ T<:B pΓ = ⊥-elim (no-⊥ pΓ T∈Γ)
    sel-case {n ∙A} T∈Γ T<:B pΓ
      with <:⟨A:⟩ (<:⇒<:ᵢ T<:B pΓ) pΓ
    ...  | inj₁ ()
    ...  | inj₂ (_ , _ , ())
    sel-case {Π S ∙ U} T∈Γ T<:B pΓ
      with <:⟨A:⟩ (<:⇒<:ᵢ T<:B pΓ) pΓ
    ...  | inj₁ ()
    ...  | inj₂ (_ , _ , ())
    sel-case {⟨A: S ⋯ U ⟩} T∈Γ T<:B pΓ
      rewrite ⊥-lb pΓ T∈Γ with ⟨A:⟩<:⟨A:⟩ (<:⇒<:ᵢ T<:B pΓ) pΓ
    ... | S<:⊥ , _ with <:⊥ S<:⊥ pΓ
    ...               | refl = refl , U , refl

  <:ᵢ⇒<: : ∀ {Γ S U} → Γ ⊢ᵢ S <: U → Γ ⊢ S <: U
  <:ᵢ⇒<: ditop                 = dtop
  <:ᵢ⇒<: dibot                 = dbot
  <:ᵢ⇒<: direfl                = drefl
  <:ᵢ⇒<: (ditrans T S<:T T<:U) = dtrans T (<:ᵢ⇒<: S<:T) (<:ᵢ⇒<: T<:U)
  <:ᵢ⇒<: (dibnd S′<:S U<:U′)   = dbnd (<:ᵢ⇒<: S′<:S) (<:ᵢ⇒<: U<:U′)
  <:ᵢ⇒<: (diall S′<:S U<:U′)   = dall (<:ᵢ⇒<: S′<:S) U<:U′
  <:ᵢ⇒<: (disel T∈Γ)           = dsel₂ T∈Γ drefl

  ⊤<:′ : ∀ {Γ T} → Γ ⊢ ⊤ <: T → P Γ → T ≡ ⊤
  ⊤<:′ ⊤<:T = ⊤<: ∘ <:⇒<:ᵢ ⊤<:T

  <:⊥′ : ∀ {Γ T} → Γ ⊢ T <: ⊥ → P Γ → T ≡ ⊥
  <:⊥′ T<:⊥ pΓ = <:⊥ (<:⇒<:ᵢ T<:⊥ pΓ) pΓ

  ⟨A:⟩<:⟨A:⟩′ : ∀ {Γ S′ U U′} → Γ ⊢ ⟨A: ⊥ ⋯ U ⟩ <: ⟨A: S′ ⋯ U′ ⟩ → P Γ →
                        S′ ≡ ⊥
  ⟨A:⟩<:⟨A:⟩′ B<:B′ pΓ with ⟨A:⟩<:⟨A:⟩ (<:⇒<:ᵢ B<:B′ pΓ) pΓ
  ... | S<:⊥ , _ = <:⊥ S<:⊥ pΓ

  Π<:⟨A:⟩⇒⊥ : ∀ {Γ S U S′ U′} → Γ ⊢ᵢ Π S ∙ U <: ⟨A: S′ ⋯ U′ ⟩ → P Γ → False
  Π<:⟨A:⟩⇒⊥ Π<:⟨A:⟩ eΓ with <:⟨A:⟩ Π<:⟨A:⟩ eΓ
  ... | inj₁ ()
  ... | inj₂ (_ , _ , ())

  ∙A<:⟨A:⟩⇒⊥ : ∀ {Γ x S U} → Γ ⊢ᵢ x ∙A <: ⟨A: S ⋯ U ⟩ → P Γ → False
  ∙A<:⟨A:⟩⇒⊥ x∙A<:⟨A:⟩ eΓ with <:⟨A:⟩ x∙A<:⟨A:⟩ eΓ
  ... | inj₁ ()
  ... | inj₂ (_ , _ , ())

  Π<:Π : ∀ {Γ S U S′ U′} →
            Γ ⊢ Π S ∙ U <: Π S′ ∙ U′ →
            P Γ →
            Γ ⊢ S′ <: S × (S′ ∷ Γ) ⊢ U <: U′
  Π<:Π <: pΓ = Σ.map₁ <:ᵢ⇒<: $ helper (<:⇒<:ᵢ <: pΓ) pΓ
    where helper : ∀ {Γ S U S′ U′} →
                     Γ ⊢ᵢ Π S ∙ U <: Π S′ ∙ U′ →
                     P Γ →
                     Γ ⊢ᵢ S′ <: S × (S′ ∷ Γ) ⊢ U <: U′
          helper direfl pΓ                           = direfl , drefl
          helper (ditrans T <: <:′) pΓ with Π<: <:
          ... | inj₁ refl                            = case ⊤<: <:′ of λ ()
          ... | inj₂ (_ , _ , refl)
              with helper <: pΓ    | helper <:′ pΓ
          ...    | S″<:S′ , U′<:U″ | S‴<:S″ , U″<:U‴ = ditrans _ S‴<:S″ S″<:S′
                                                     , dtrans _ (Dsub.<:-narrow U′<:U″ Dsub.≺[ _ , <:ᵢ⇒<: S‴<:S″ ] refl) U″<:U‴
          helper (diall <: U<:U′) pΓ                 = <: , U<:U′


{-# OPTIONS --without-K --safe #-}
-- Various operations and proofs on morphisms between products

-- Perhaps a bit of overkill? There is so much here that it's impossible to remember
-- it all
open import Categories.Category

module Categories.Object.Product.Morphisms {o ℓ e} (𝒞 : Category o ℓ e) where

open import Function using (flip)
open import Level

open import Categories.Object.Product.Core 𝒞

open Category 𝒞
open HomReasoning

private
  variable
    A B C D E F : Obj
    f f′ g g′ h i : A ⇒ B

infix 10 [_]⟨_,_⟩ [_⇒_]_×_
infix 12 [[_]] [_]π₁ [_]π₂

[[_]] : Product A B → Obj
[[ p ]] = Product.A×B p

[_]⟨_,_⟩ : ∀ (p : Product B C) → A ⇒ B → A ⇒ C → A ⇒ [[ p ]]
[ p ]⟨ f , g ⟩ = Product.⟨_,_⟩ p f g

[_]π₁ : ∀ (p : Product A B) → [[ p ]] ⇒ A
[_]π₁ = Product.π₁

[_]π₂ : ∀ (p : Product A B) → [[ p ]] ⇒ B
[_]π₂ = Product.π₂

[_⇒_]_×_ : ∀ (p₁ : Product A C) (p₂ : Product B D) →
             (A ⇒ B) → (C ⇒ D) → ([[ p₁ ]] ⇒ [[ p₂ ]])
[ p₁ ⇒ p₂ ] f × g  = [ p₂ ]⟨ f ∘ p₁.π₁ , g ∘ p₁.π₂ ⟩
  where module p₁ = Product p₁
        module p₂ = Product p₂

id×id : ∀ (p : Product A B) → [ p ⇒ p ] id × id ≈ id
id×id p = begin
  ⟨ id ∘ π₁ , id ∘ π₂ ⟩ ≈⟨ ⟨⟩-cong₂ identityˡ identityˡ ⟩
  ⟨ π₁ , π₂ ⟩           ≈⟨ η ⟩
  id                    ∎
  where open Product p

repack≡id×id : ∀ (p₁ p₂ : Product A B) → repack p₁ p₂ ≈ [ p₁ ⇒ p₂ ] id × id
repack≡id×id p₁ p₂ = sym (Product.⟨⟩-cong₂ p₂ identityˡ identityˡ)

[_⇒_]π₁∘× : ∀ (p₁ : Product A C)(p₂ : Product B D) →
              Product.π₁ p₂ ∘ [ p₁ ⇒ p₂ ] f × g ≈ f ∘ Product.π₁ p₁
[_⇒_]π₁∘× _ p₂ = Product.project₁ p₂

[_⇒_]π₂∘× : ∀ (p₁ : Product A C) (p₂ : Product B D) →
              Product.π₂ p₂ ∘ [ p₁ ⇒ p₂ ] f × g ≈ g ∘ Product.π₂ p₁
[_⇒_]π₂∘× _ p₂ = Product.project₂ p₂

[_⇒_]×-cong₂ : ∀ (p₁ : Product A B) (p₂ : Product C D) →
                 f ≈ g → h ≈ i →
                 [ p₁ ⇒ p₂ ] f × h ≈ [ p₁ ⇒ p₂ ] g × i
[_⇒_]×-cong₂ p₁ p₂ f≈g h≈i =
    Product.⟨⟩-cong₂ p₂ (∘-resp-≈ f≈g refl) (∘-resp-≈ h≈i refl)

[_⇒_]×∘⟨⟩ : ∀ (p₁ : Product A B) (p₂ : Product C D) →
              ([ p₁ ⇒ p₂ ] f × g) ∘ [ p₁ ]⟨ f′ , g′ ⟩ ≈ [ p₂ ]⟨ f ∘ f′ , g ∘ g′ ⟩
[_⇒_]×∘⟨⟩ {f = f} {g = g} {f′ = f′} {g′ = g′} p₁ p₂ = begin
  [ p₂ ]⟨ f ∘ p₁.π₁ , g ∘ p₁.π₂ ⟩ ∘ [ p₁ ]⟨ f′ , g′ ⟩ ≈⟨ p₂.∘-distribʳ-⟨⟩ ⟩
  [ p₂ ]⟨ (f ∘ p₁.π₁) ∘ p₁.⟨_,_⟩ f′ g′
        , (g ∘ p₁.π₂) ∘ p₁.⟨_,_⟩ f′ g′ ⟩              ≈⟨ p₂.⟨⟩-cong₂ assoc assoc ⟩
  [ p₂ ]⟨ f ∘ p₁.π₁ ∘ p₁.⟨_,_⟩ f′ g′
        , g ∘ p₁.π₂ ∘ p₁.⟨_,_⟩ f′ g′ ⟩                ≈⟨ p₂.⟨⟩-cong₂ (∘-resp-≈ refl p₁.project₁) (∘-resp-≈ refl p₁.project₂) ⟩
  [ p₂ ]⟨ f ∘ f′ , g ∘ g′ ⟩                           ∎
  where module p₁ = Product p₁
        module p₂ = Product p₂

[_]⟨⟩∘ : ∀ (p : Product A B) → [ p ]⟨ f , g ⟩ ∘ h ≈ [ p ]⟨ f ∘ h , g ∘ h ⟩
[ p ]⟨⟩∘ = ⟺ (unique (⟺ assoc ○ ∘-resp-≈ˡ project₁) (⟺ assoc ○ ∘-resp-≈ˡ project₂))
  where open Product p

repack∘repack≈id : ∀ (p₁ p₂ : Product A B) → repack p₁ p₂ ∘ repack p₂ p₁ ≈ id
repack∘repack≈id p₁ p₂ = [ p₂ ]⟨⟩∘ ○ p₂.⟨⟩-cong₂ p₁.project₁ p₁.project₂ ○ p₂.η
  where module p₁ = Product p₁
        module p₂ = Product p₂

[_⇒_⇒_]×∘× : ∀ (p₁ : Product A B) (p₂ : Product C D) (p₃ : Product E F) →
               ([ p₂ ⇒ p₃ ] g × i) ∘ ([ p₁ ⇒ p₂ ] f × h) ≈ [ p₁ ⇒ p₃ ] (g ∘ f) × (i ∘ h)
[_⇒_⇒_]×∘× {g = g} {i = i} {f = f} {h = h} p₁ p₂ p₃ = begin
  [ p₃ ]⟨ g ∘ p₂.π₁ , i ∘ p₂.π₂ ⟩ ∘ [ p₂ ]⟨ f ∘ p₁.π₁ , h ∘ p₁.π₂ ⟩ ≈⟨ [ p₂ ⇒ p₃ ]×∘⟨⟩ ⟩
  [ p₃ ]⟨ g ∘ f ∘ p₁.π₁ , i ∘ h ∘ p₁.π₂ ⟩                          ≈˘⟨ p₃.⟨⟩-cong₂ assoc assoc ⟩
  [ p₃ ]⟨ (g ∘ f) ∘ p₁.π₁ , (i ∘ h) ∘ p₁.π₂ ⟩                       ∎
  where module p₁ = Product p₁
        module p₂ = Product p₂
        module p₃ = Product p₃

[_⇒_⇒_]repack∘× : ∀ (p₁ : Product A B) (p₂ : Product C D) (p₃ : Product C D) →
                    repack p₂ p₃ ∘ [ p₁ ⇒ p₂ ] f × g ≈ [ p₁ ⇒ p₃ ] f × g
[_⇒_⇒_]repack∘× {f = f} {g = g} p₁ p₂ p₃ = begin
  repack p₂ p₃ ∘ [ p₁ ⇒ p₂ ] f × g            ≈⟨ repack≡id×id p₂ p₃ ⟩∘⟨ refl ⟩
  ([ p₂ ⇒ p₃ ] id × id) ∘ ([ p₁ ⇒ p₂ ] f × g) ≈⟨ [ p₁ ⇒ p₂ ⇒ p₃ ]×∘× ⟩
  [ p₁ ⇒ p₃ ] (id ∘ f) × (id ∘ g)             ≈⟨ [ p₁ ⇒ p₃ ]×-cong₂ identityˡ identityˡ ⟩
  [ p₁ ⇒ p₃ ] f × g                           ∎

[_⇒_⇒_]repack∘repack : ∀ (p₁ p₂ p₃ : Product A B) → repack p₂ p₃ ∘ repack p₁ p₂ ≈ repack p₁ p₃
[_⇒_⇒_]repack∘repack = repack∘

[_⇒_]_×id : ∀ (p₁ : Product A C) (p₂ : Product B C) → A ⇒ B → [[ p₁ ]] ⇒ [[ p₂ ]]
[ p₁ ⇒ p₂ ] f ×id = [ p₁ ⇒ p₂ ] f × id

[_⇒_]id× : ∀ (p₁ : Product A B) (p₂ : Product A C) → B ⇒ C → [[ p₁ ]] ⇒ [[ p₂ ]]
[ p₁ ⇒ p₂ ]id× g = [ p₁ ⇒ p₂ ] id × g

first-id : ∀ (p : Product A B) → [ p ⇒ p ] id ×id ≈ id
first-id = id×id

second-id : ∀ (p : Product A B) → [ p ⇒ p ]id× id ≈ id
second-id = id×id

[_⇒_]×id∘⟨⟩ : ∀ (p₁ : Product B D) (p₂ : Product C D) →
                  [ p₁ ⇒ p₂ ] f ×id ∘ [ p₁ ]⟨ f′ , g′ ⟩ ≈ [ p₂ ]⟨ f ∘ f′ , g′ ⟩
[_⇒_]×id∘⟨⟩ {f = f} {f′ = f′} {g′ = g′} p₁ p₂ = begin
  [ p₁ ⇒ p₂ ] f ×id ∘ [ p₁ ]⟨ f′ , g′ ⟩ ≈⟨ [ p₁ ⇒ p₂ ]×∘⟨⟩ ⟩
  [ p₂ ]⟨ f ∘ f′ , id ∘ g′ ⟩            ≈⟨ p₂.⟨⟩-cong₂ refl identityˡ ⟩
  [ p₂ ]⟨ f ∘ f′ , g′ ⟩                 ∎
  where module p₂ = Product p₂

[_⇒_]id×∘⟨⟩ : ∀ (p₁ : Product B D) (p₂ : Product B E) →
                   [ p₁ ⇒ p₂ ]id× g ∘ [ p₁ ]⟨ f′ , g′ ⟩ ≈ [ p₂ ]⟨ f′ , g ∘ g′ ⟩
[_⇒_]id×∘⟨⟩ {g = g} {f′ = f′} {g′ = g′} p₁ p₂ = begin
  [ p₁ ⇒ p₂ ]id× g ∘ [ p₁ ]⟨ f′ , g′ ⟩ ≈⟨ [ p₁ ⇒ p₂ ]×∘⟨⟩ ⟩
  [ p₂ ]⟨ id ∘ f′ , g ∘ g′ ⟩              ≈⟨ p₂.⟨⟩-cong₂ identityˡ refl ⟩
  [ p₂ ]⟨ f′ , g ∘ g′ ⟩                   ∎
  where module p₂ = Product p₂

[_⇒_⇒_]×id∘×id : ∀ (p₁ : Product A D) (p₂ : Product B D) (p₃ : Product C D) →
                       [ p₂ ⇒ p₃ ] f ×id ∘ [ p₁ ⇒ p₂ ] g ×id ≈ [ p₁ ⇒ p₃ ] f ∘ g ×id
[_⇒_⇒_]×id∘×id {f = f} {g = g} p₁ p₂ p₃ = begin
  [ p₂ ⇒ p₃ ] f ×id ∘ [ p₁ ⇒ p₂ ] g ×id ≈⟨ [ p₁ ⇒ p₂ ⇒ p₃ ]×∘× ⟩
  [ p₁ ⇒ p₃ ] (f ∘ g) × (id ∘ id)       ≈⟨ [ p₁ ⇒ p₃ ]×-cong₂ refl identityˡ ⟩
  [ p₁ ⇒ p₃ ] f ∘ g ×id                 ∎

[_⇒_⇒_]id×∘id× : ∀ (p₁ : Product A B) (p₂ : Product A C) (p₃ : Product A D) →
                         [ p₂ ⇒ p₃ ]id× f ∘ [ p₁ ⇒ p₂ ]id× g ≈ [ p₁ ⇒ p₃ ]id×(f ∘ g)
[_⇒_⇒_]id×∘id× {f = f} {g = g} p₁ p₂ p₃ = begin
  [ p₂ ⇒ p₃ ]id× f ∘ [ p₁ ⇒ p₂ ]id× g ≈⟨ [ p₁ ⇒ p₂ ⇒ p₃ ]×∘× ⟩
  [ p₁ ⇒ p₃ ] (id ∘ id) × (f ∘ g)     ≈⟨ [ p₁ ⇒ p₃ ]×-cong₂ identityˡ refl ⟩
  [ p₁ ⇒ p₃ ]id× (f ∘ g)              ∎

[_⇒_,_⇒_]first↔second : ∀ (p₁ : Product A D) (p₂ : Product B D)
                          (p₃ : Product A C) (p₄ : Product B C) →
                          [ p₁ ⇒ p₂ ] f ×id ∘ [ p₃ ⇒ p₁ ]id× g ≈ [ p₄ ⇒ p₂ ]id× g ∘ [ p₃ ⇒ p₄ ] f ×id
[_⇒_,_⇒_]first↔second {f = f} {g = g} p₁ p₂ p₃ p₄ = begin
  [ p₁ ⇒ p₂ ] f ×id ∘ [ p₃ ⇒ p₁ ]id× g ≈⟨ [ p₃ ⇒ p₁ ⇒ p₂ ]×∘× ⟩
  [ p₃ ⇒ p₂ ] (f ∘ id) × (id ∘ g)      ≈⟨ [ p₃ ⇒ p₂ ]×-cong₂ identityʳ identityˡ ⟩
  [ p₃ ⇒ p₂ ] f × g                    ≈⟨ sym ([ p₃ ⇒ p₂ ]×-cong₂ identityˡ identityʳ) ⟩
  [ p₃ ⇒ p₂ ] (id ∘ f) × (g ∘ id)      ≈⟨ sym ([ p₃ ⇒ p₄ ⇒ p₂ ]×∘×) ⟩
  [ p₄ ⇒ p₂ ]id× g ∘ [ p₃ ⇒ p₄ ] f ×id ∎


open import Agda.Builtin.Equality

postulate
  Ty Cxt : Set
  Var Tm : Ty → Cxt → Set
  _≤_ : (Γ Δ : Cxt) → Set

variable
  Γ Δ Φ : Cxt
  A B C : Ty
  x : Var A Γ

Mon : (P : Cxt → Set) → Set
Mon P = ∀{Δ Γ} (ρ : Δ ≤ Γ) → P Γ → P Δ

postulate
  _•_ : Mon (_≤ Φ)
  monVar : Mon (Var A)
  monTm : Mon (Tm A)

postulate
  refl-ish : {A : Set} {x y : A} → x ≡ y

variable
  ρ ρ' : Δ ≤ Γ

monVar-comp : monVar ρ (monVar ρ' x) ≡ monVar (ρ • ρ') x
monVar-comp {ρ = ρ} {ρ' = ρ'} {x = x} = refl-ish

variable
  t : Tm A Γ

monTm-comp : monTm ρ (monTm ρ' t) ≡ monTm (ρ • ρ') t
monTm-comp {ρ = ρ} {ρ' = ρ'} {t = t} = refl-ish


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

data D : Set where
  c : D → D

variable
  x y : D

data P : D → D → Set where
  c : P (c x) (c y)

record Q (y : D) : Set where

G : .(Q y) → P x y → Set₁
G _ c = Set