module Golden.RedBlack where

open import Prelude hiding (insert)

-- Version of comparison that lets us use instance search for the proof objects.
data Comparison! {a} {A : Set a} (_<_ : A → A → Set a) (x y : A) : Set a where
  less    : {{_ : x < y}} → Comparison! _<_ x y
  equal   : {{_ : x ≡ y}} → Comparison! _<_ x y
  greater : {{_ : y < x}} → Comparison! _<_ x y

compare! : ∀ {a} {A : Set a} {{_ : Ord A}} (x y : A) → Comparison! _<_ x y
compare! x y =
  case compare x y of λ where
    (less    lt) → less    {{lt}}
    (equal   eq) → equal   {{eq}}
    (greater gt) → greater {{gt}}

record Prf (A : Set) : Set where
  constructor !
  field
    {{prf}} : A

data Bound (A : Set) : Set where
  -∞ ∞ : Bound A
  # : A → Bound A

module _ {A : Set} {{_ : Ord A}} where
  LessBound : Bound A → Bound A → Set
  LessBound ∞ _ = ⊥
  LessBound _ ∞ = ⊤
  LessBound _ -∞ = ⊥
  LessBound -∞ _ = ⊤
  LessBound (# x) (# y) = x < y

  instance
    OrdBound : Ord (Bound A)
    OrdBound = defaultOrd compareBound
      where
        compareBound : (a b : Bound A) → Comparison LessBound a b
        compareBound -∞ -∞ = equal refl
        compareBound -∞ ∞ = less _
        compareBound -∞ (# x) = less _
        compareBound ∞ -∞ = greater tt
        compareBound ∞ ∞ = equal refl
        compareBound ∞ (# x) = greater tt
        compareBound (# x) -∞ = greater tt
        compareBound (# x) ∞ = less tt
        compareBound (# x) (# y) with compare x y
        ... | less lt = less lt
        ... | greater gt = greater gt
        compareBound (# x) (# .x) | equal refl = equal refl

Bounds : Set → Set
Bounds A = Bound A × Bound A

Rel : Set → Set₁
Rel A = Bounds A → Set

module _ {A : Set} where
  PrfR : Rel A → Rel A
  PrfR R b = Prf (R b)

  data _∧_ (S T : Rel A) : Rel A where
    pivot : ∀ {l u} p → S (l , # p) → T (# p , u) → (S ∧ T) (l , u)

  pattern -⟨_⟩- p = pivot p ! !
  pattern _⟨_⟩_ l p r = pivot p l r

module _ {A : Set} {{_ : Ord A}} where
  Less : Rel A
  Less = PrfR (uncurry _<_)

  Bounded : Rel A
  Bounded = Less ∧ Less

data Color : Set where
  red black : Color

module _ (A : Set) {{_ : Ord A}} where

  data Tree′ (b : Bounds A) : Nat → Color → Set

  Tree : Nat → Color → Rel A
  Tree n c b = Tree′ b n c

  data Tree′ b where
    leaf′  : Less b → Tree 0 black b
    red   : ∀ {n} → (Tree n black ∧ Tree n black) b → Tree n red b
    black : ∀ {c₁ c₂ n} → (Tree n c₁ ∧ Tree n c₂) b → Tree (suc n) black b

  pattern leaf = leaf′ !

  data PreTree′ (b : Bounds A) (n : Nat) : Color → Set

  PreTree : Nat → Color → Bounds A → Set
  PreTree n c b = PreTree′ b n c

  data PreTree′ b n where
    red         : ∀ {c₁ c₂} → (Tree n c₁ ∧ Tree n c₂) b → PreTree n red b
    maybe-black : ∀ {c} → Tree n c b → PreTree n black b

  pattern _b⟨_⟩_   l x r = black (l ⟨ x ⟩ r)
  pattern _r⟨_⟩_   l x r = red (l ⟨ x ⟩ r)
  pattern _pb⟨_⟩_  l x r = maybe-black (black (l ⟨ x ⟩ r))
  pattern _pbr⟨_⟩_ l x r = maybe-black (red   (l ⟨ x ⟩ r))
  pattern _rbb⟨_⟩_ l x r = red {c₁ = black} {c₂ = black} (l ⟨ x ⟩ r)

module _ {A : Set} {{_ : Ord A}} where

  balance-l : ∀ {b c₁ c₂ n} →
              (PreTree A n c₁ ∧ Tree A n c₂) b →
              PreTree A (suc n) black b
  balance-l (((l₁ r⟨ z ⟩ l₂) r⟨ x ⟩ l₃) ⟨ y ⟩ r) =
    (l₁ b⟨ z ⟩ l₂) pbr⟨ x ⟩ (l₃ b⟨ y ⟩ r)
  balance-l ((l₁ r⟨ z ⟩ (l₂ r⟨ x ⟩ l₃)) ⟨ y ⟩ r) =
    (l₁ b⟨ z ⟩ l₂) pbr⟨ x ⟩ (l₃ b⟨ y ⟩ r)
  balance-l ((l₁ rbb⟨ x ⟩ l₂) ⟨ y ⟩ r) =
    (l₁ r⟨ x ⟩ l₂) pb⟨ y ⟩ r
  balance-l (maybe-black l ⟨ y ⟩ r) = l pb⟨ y ⟩ r

  balance-r : ∀ {b c₁ c₂ n} →
              (Tree A n c₁ ∧ PreTree A n c₂) b →
              PreTree A (suc n) black b
  balance-r (l ⟨ y ⟩ ((r₁ r⟨ z ⟩ r₂) r⟨ x ⟩ r₃)) =
    (l b⟨ y ⟩ r₁) pbr⟨ z ⟩ (r₂ b⟨ x ⟩ r₃)
  balance-r (l ⟨ y ⟩ (r₁ r⟨ x ⟩ (r₂ r⟨ z ⟩ r₃))) =
    (l b⟨ y ⟩ r₁) pbr⟨ x ⟩ (r₂ b⟨ z ⟩ r₃)
  balance-r (l ⟨ y ⟩ (r₁ rbb⟨ x ⟩ r₂)) =
    l pb⟨ y ⟩ (r₁ r⟨ x ⟩ r₂)
  balance-r (l ⟨ y ⟩ maybe-black r) = l pb⟨ y ⟩ r

  ins : ∀ {b c n} → Bounded b → Tree A n c b → PreTree A n c b
  ins -⟨ x ⟩- leaf = leaf pbr⟨ x ⟩ leaf
  ins -⟨ x ⟩- (red (l ⟨ y ⟩ r)) =
    case compare! x y of λ where
      less    → case ins -⟨ x ⟩- l of λ { (maybe-black l′) → l′ r⟨ y ⟩ r }
      greater → case ins -⟨ x ⟩- r of λ { (maybe-black r′) → l r⟨ y ⟩ r′ }
      equal   → l r⟨ y ⟩ r
  ins -⟨ x ⟩- (black (l ⟨ y ⟩ r)) =
    case compare! x y of λ where
      less    → balance-l (ins -⟨ x ⟩- l ⟨ y ⟩ r)
      greater → balance-r (l ⟨ y ⟩ ins -⟨ x ⟩- r)
      equal   → l pb⟨ y ⟩ r

data RedBlackTree (A : Set) {{_ : Ord A}} : Set where
  mkT : ∀ {n} → Tree A n black (-∞ , ∞) → RedBlackTree A

module _ {A : Set} {{_ : Ord A}} where

  insert : A → RedBlackTree A → RedBlackTree A
  insert x (mkT t) with ins -⟨ x ⟩- t
  ... | l pbr⟨ y ⟩ r      = mkT $ l b⟨ y ⟩ r
  ... | l  pb⟨ y ⟩ r      = mkT $ l b⟨ y ⟩ r
  ... | maybe-black leaf = mkT leaf

  fromList : List A → RedBlackTree A
  fromList = foldr insert (mkT leaf)

  toList′ : ∀ {b n c} → Tree′ A b n c → List A → List A
  toList′ (leaf′ _)   xs = xs
  toList′ (l r⟨ x ⟩ r) xs = toList′ l (x ∷ toList′ r xs)
  toList′ (l b⟨ x ⟩ r) xs = toList′ l (x ∷ toList′ r xs)

  toList : RedBlackTree A → List A
  toList (mkT t) = toList′ t []

  treeSort : List A → List A
  treeSort = toList ∘ fromList

-- Example

test : List Nat
test = treeSort $ 5 ∷ 1 ∷ 2 ∷ 10 ∷ 13 ∷ 0 ∷ 141 ∷ 7 ∷ []

hest : String
hest = show test

main : IO Unit
main = putStrLn hest


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

open import HoTT

open import stash.modalities.gbm.GbmUtil
open import stash.modalities.GbmCodes

module stash.modalities.Gbm {ℓ} (M : Modality ℓ)
  {A : Type ℓ} {B : Type ℓ}
  (Q : A → B → Type ℓ)
  (H : BM-Relation M Q) where

  open Modality M

  import stash.modalities.gbm.Pushout
  open import stash.modalities.gbm.PushoutMono
  open import stash.modalities.gbm.PullbackSplit
  open import homotopy.PushoutSplit

  private

    A' : Type ℓ
    A' = Σ A (λ a → Trunc (S ⟨-2⟩) (Σ B (λ b → Q a b)))

    Q' : A' → B → Type ℓ
    Q' (a , _) b = Q a b

    Q'-pth-ovr-lemma : {a₀ a₁ : A'} {b : B} (q₀ : Q' a₀ b) (q₁ : Q' a₁ b) (p : a₀ == a₁)
                 → (q₀ == q₁ [ (λ a → Q' a b) ↓ p ]) ≃ (q₀ == q₁ [ (λ a → Q a b) ↓ fst= p ])
    Q'-pth-ovr-lemma q₀ q₁ idp = ide (q₀ == q₁)

    Q'-is-BM-Relation : BM-Relation M Q'
    Q'-is-BM-Relation {a₀} {b₀} q₀ {a₁} q₁ {b₁} q₂ =
      equiv-preserves-◯-conn (*-emap eqv (ide _))
        (H {fst a₀} {b₀} q₀ {fst a₁} q₁ {b₁} q₂)

      where eqv = =Σ-econv (a₀ , q₀) (a₁ , q₁)
                    ∘e (Σ-emap-r (Q'-pth-ovr-lemma q₀ q₁)) ⁻¹
                    ∘e (Σ-emap-l (λ p → q₀ == q₁ [ (λ a → Q a b₀) ↓ p ])
                         (Subtype=-econv ((λ a → Trunc -1 (Σ B λ b → Q a b)), λ a → Trunc-level) a₀ a₁ ⁻¹)) ⁻¹
                    ∘e (=Σ-econv (fst a₀ , q₀) (fst a₁ , q₁)) ⁻¹

    module W = stash.modalities.gbm.Pushout Q
    module W' = stash.modalities.gbm.Pushout Q'
    W  = W.BMPushout
    W' = W'.BMPushout

    Z = (Σ A λ a → Σ B λ b → Q a b)
    Z' = (Σ A' λ a → Σ B λ b → Q (fst a) b)

    Z-to-Z' : Z → Z'
    Z-to-Z' (a , b , q) = (a , [ b , q ]) , b , q

    Z'-to-Z : Z' → Z
    Z'-to-Z ((a , e) , b , q) = a , b , q

    Z≃Z' : is-equiv Z-to-Z'
    Z≃Z' = is-eq Z-to-Z' Z'-to-Z to-from from-to

      where to-from : (z : Z') → Z-to-Z' (Z'-to-Z z) == z
            to-from ((a , e) , b , q) = pair= (pair= idp (prop-has-all-paths Trunc-level _ e))
              (↓-cst2-in idp (prop-has-all-paths Trunc-level _ e) idp)

            from-to : (z : Z) → Z'-to-Z (Z-to-Z' z) == z
            from-to (a , b , q) = idp

    W-span = span A B Z fst (fst ∘ snd)
    W''-span = span A B Z' (fst ∘ fst) (fst ∘ snd)

    W'' = Pushout W''-span

    W≃W'' : W ≃ W''
    W≃W'' = Pushout-emap span-eqv

      where span-eqv : SpanEquiv W-span W''-span
            span-eqv = (span-map (idf A) (idf B) Z-to-Z'
                         (comm-sqr (λ a → idp))
                         (comm-sqr (λ b → idp))) ,
                         ( idf-is-equiv A
                         , idf-is-equiv B
                         , Z≃Z')

    --
    --  But the PushoutSplit lemma, we find that
    --
    --    Z' ---------> B
    --    |             |
    --    |             |
    --    v             v
    --    A' ---------> W'
    --    |             |
    --    |             |
    --    v             v
    --    A ----------> W'' ≃ X
    --

    X = Pushout (span A W' A' fst left)

    W''≃X : W'' ≃ X
    W''≃X = PS.split-equiv

      where module PS = PushoutLSplit {A = A'} {B = A} {C = B} {D = Z'} fst fst (fst ∘ snd)

    --
    --  Now we switch gears and take pullbacks.  We
    --  have the following diagram:
    --
    -- U'' ≃  U' ≃ U ---------> B
    --             |            |
    --             |            |
    --             v            v
    --        A' ≃ V ---------> W'  outer = cospan₀
    --             |            |
    --             |  cospan₂   |
    --             v            v
    --             A ---------> X ≃ W''

    V = Pullback (cospan A W' X left right)

    U = Pullback (cospan A B X left (right ∘ W'.bmright))
    U' = Pullback (cospan A B W'' left right)
    U'' = Pullback (cospan V B W' Pullback.b right)

    U≃U'' : U ≃ U''
    U≃U'' = PBSplit.split-equiv

      where module PBSplit = PullbackLSplit {A = W'} {B = B} {C = A} {D = X} right right left

    --
    --  The map A' --> A is a mono.  Hence by
    --  the PushoutMono lemma we get that it
    --  is also a pullback and consequently
    --  equivalent to V
    --

    V≃A' : V ≃ A'
    V≃A' = (ML.pushout-mono-is-pullback) ⁻¹ ∘e (pullback-decomp-equiv (cospan A W' X left right))

      where module ML = MonoLemma
              (span A W' A' fst left)
              (λ b → equiv-preserves-level ((hfiber-fst b) ⁻¹) Trunc-level)

    -- We need this for commutivity below
    V≃A'-coh : (v : V) → Pullback.b v == left (fst V≃A' v)
    V≃A'-coh (pullback a b h) = ! (ML.witness-for-coh₀ h)

      where module ML = MonoLemma
              (span A W' A' fst left)
              (λ b → equiv-preserves-level ((hfiber-fst b) ⁻¹) Trunc-level)

    --
    --  Now on to the main theorem
    --

    A×WB = Pullback (cospan A B W left right)
    A'×W'B = Pullback (cospan A' B W' left right)

    U''≃A'×W'B : U'' ≃ A'×W'B
    U''≃A'×W'B = Pullback-emap cospan-eqv

      where cospan-eqv : CospanEquiv (cospan V B W' Pullback.b right)
                                     (cospan A' B W' left right)
            cospan-eqv = (cospan-map (fst (V≃A')) (idf B) (idf W')
                                     (comm-sqr V≃A'-coh)
                                     (comm-sqr (λ b → idp))) ,
                                     snd (V≃A') ,
                                     idf-is-equiv B ,
                                     idf-is-equiv W'

    A×WB≃U : A×WB ≃ U
    A×WB≃U = Pullback-emap cospan-eqv

      where cospan-eqv : CospanEquiv (cospan A B W left right) (cospan A B X left (right ∘ W'.bmright))
            cospan-eqv = (cospan-map (idf A) (idf B) (fst (W''≃X ∘e W≃W''))
                                     (comm-sqr (λ a → idp))
                                     (comm-sqr (λ b → idp))) ,
                                     idf-is-equiv A ,
                                     (idf-is-equiv B) ,
                                     (snd (W''≃X ∘e W≃W''))

    Pb = Σ A (λ a → Σ B (λ b →  W.bmleft a == W.bmright b))
    Pb' = Σ A' (λ a → Σ B (λ b →  W'.bmleft a == W'.bmright b))

    Pb≃Pb' = Pb ≃⟨ Σ-assoc ⁻¹  ⟩
             Σ (A × B) (λ ab → W.bmleft (fst ab) == W.bmright (snd ab)) ≃⟨ (pullback-decomp-equiv (cospan A B W left right)) ⁻¹  ⟩
             A×WB ≃⟨ A×WB≃U ⟩
             U ≃⟨ U≃U'' ⟩
             U'' ≃⟨ U''≃A'×W'B ⟩
             A'×W'B ≃⟨ pullback-decomp-equiv (cospan A' B W' left right) ⟩
             Σ (A' × B) (λ ab → W'.bmleft (fst ab) == W'.bmright (snd ab)) ≃⟨ Σ-assoc ⟩
             Pb' ≃∎

    bm-map : Z → Pb
    bm-map (a , b , q) = a , b , W.bmglue q

    bm-map' : Z' → Pb'
    bm-map' (a' , b , q) = a' , b , W'.bmglue q

    bm-map'-is-◯-equiv : is-◯-equiv bm-map'
    bm-map'-is-◯-equiv =
      total-◯-equiv
        (λ a' → λ { (b , q) → b , W'.bmglue q})
        (λ a' → total-◯-equiv (λ b q → W'.bmglue q)
          (λ b r → Trunc-rec (prop-has-level-S is-◯-connected-is-prop)
            (λ{(_ , q₀₀) → code-contr M Q' Q'-is-BM-Relation q₀₀ r}) (snd a')))

  --
  --  We have a commutative diagram with top and bottom
  --  maps equivalences.  This induces an equivalence on
  --  homotopy fibers, from which the theorem follows
  --          ~
  --    Z --------> Z'
  --    |           |
  --  s |           | t
  --    |           |
  --    v           v
  --    Pb -------> Pb'
  --          ~
  --

  sq-coh : (z : Z) → (fst Pb≃Pb' (bm-map z)) == bm-map' (Z-to-Z' z)
  sq-coh (a , b , q) = {!!}

    where test = fst Pb≃Pb' (a , b , W.bmglue q) =⟨ idp ⟩
                 (–> Σ-assoc) (–> (pullback-decomp-equiv (cospan A' B W' left right)) {!–> U''≃A'×W'B ?!} )  =⟨ idp ⟩
                 fst Pb≃Pb' (a , b , W.bmglue q) ∎

    -- Pb≃Pb' = Pb ≃⟨ Σ-assoc ⁻¹  ⟩
    --          Σ (A × B) (λ ab → W.bmleft (fst ab) == W.bmright (snd ab)) ≃⟨ (pullback-decomp-equiv (cospan A B W left right)) ⁻¹  ⟩
    --          A×WB ≃⟨ A×WB≃U ⟩
    --          U ≃⟨ U≃U'' ⟩
    --          U'' ≃⟨ U''≃A'×W'B ⟩
    --          A'×W'B ≃⟨ pullback-decomp-equiv (cospan A' B W' left right) ⟩
    --          Σ (A' × B) (λ ab → W'.bmleft (fst ab) == W'.bmright (snd ab)) ≃⟨ Σ-assoc ⟩
    --          Pb' ≃∎

    -- fst Pb≃Pb' (a , b , W.bmglue q) =⟨ {!!} ⟩
    -- (a , [ b , q ]) , (b , W'.bmglue q) ∎

  generalized-blakers-massey : is-◯-equiv bm-map
  generalized-blakers-massey pb = equiv-preserves-◯-conn (lemma ⁻¹) (bm-map'-is-◯-equiv (fst Pb≃Pb' pb))

    where

          lemma : hfiber bm-map pb ≃ hfiber bm-map' (fst Pb≃Pb' pb)
          lemma = hfiber-sq-eqv bm-map bm-map' Z-to-Z' (fst Pb≃Pb')
            (comm-sqr sq-coh) Z≃Z' (snd Pb≃Pb') pb


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

open import Agda.Primitive using (Setω)

-- No panic should be triggered

data A : Setω where

record B' : Set where
  field
    theA : A

data B : Set where
  b : A → B

data C : Set where
  c : Setω → C

data C' : Setω where
  c : Setω → C'

record C'' : Setω where
  field
    theSet : Setω
    thefield : theSet


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

module Number.Operations.Details where

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Data.Unit.Base -- Unit
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`
open import Function.Base using (_$_)

open import Cubical.Data.Nat.Properties
open import Cubical.Data.Nat.Order renaming (zero-≤ to z≤n; suc-≤-suc to s≤s)

open import MoreNatProperties renaming (0≤x to 0≤xⁿ)

open import Number.Postulates
open import Number.Structures
open import Number.Bundles
open import Number.Inclusions
open import Number.Base
open import Number.Coercions

open ℕⁿ
open ℤᶻ
open ℚᶠ
open ℝʳ
open ℂᶜ

infix  9 _⁻¹
infix  8 -_

open import Number.Operations.Specification

open PatternsProp

_⁻¹ : ∀{l p} → (x : Number (l , p)) → ⁻¹-Types x

_⁻¹ {isNat    } {⁇x⁇} (x ,, q) {{h}} = let r = Isℕ↪ℚ.preserves-#0 ℕ↪ℚinc _ h in _⁻¹ᶠ (ℕ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-#0 _ r
_⁻¹ {isNat    } {x#0} (x ,, q) {{h}} = let r = Isℕ↪ℚ.preserves-#0 ℕ↪ℚinc _ q in _⁻¹ᶠ (ℕ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-#0 _ r
_⁻¹ {isNat    } {0≤x} (x ,, q) {{h}} = let p = Isℕ↪ℚ.preserves-0< ℕ↪ℚinc _ (ℕ.≤-#-implies-< _ _ q (ℕ.#-sym _ _ h))
                                           r = Isℕ↪ℚ.preserves-#0 ℕ↪ℚinc _ h
                                       in  _⁻¹ᶠ (ℕ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-0< _ p r
_⁻¹ {isNat    } {0<x} (x ,, q) {{h}} = let p = Isℕ↪ℚ.preserves-0< ℕ↪ℚinc _ q
                                           r = Isℕ↪ℚ.preserves-#0 ℕ↪ℚinc _ (ℕ.#-sym _ _ (ℕ.<-implies-# _ _ q))
                                       in  _⁻¹ᶠ (ℕ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-0< _ p r
_⁻¹ {isNat    } {x≤0} (x ,, q) {{h}} = let p = Isℕ↪ℚ.preserves-<0 ℕ↪ℚinc _ (ℕ.≤-#-implies-< _ _ q h)
                                           r = Isℕ↪ℚ.preserves-#0 ℕ↪ℚinc _ h
                                       in  _⁻¹ᶠ (ℕ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-<0 _ p r

_⁻¹ {isInt    } {⁇x⁇} (x ,, q) {{h}} = let r = Isℤ↪ℚ.preserves-#0 ℤ↪ℚinc _ h in _⁻¹ᶠ (ℤ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-#0 _ r
_⁻¹ {isInt    } {x#0} (x ,, q) {{h}} = let r = Isℤ↪ℚ.preserves-#0 ℤ↪ℚinc _ q in _⁻¹ᶠ (ℤ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-#0 _ r
_⁻¹ {isInt    } {0≤x} (x ,, q) {{h}} = let p = Isℤ↪ℚ.preserves-0< ℤ↪ℚinc _ (ℤ.≤-#-implies-< _ _ q (ℤ.#-sym _ _ h))
                                           r = Isℤ↪ℚ.preserves-#0 ℤ↪ℚinc _ h
                                       in  _⁻¹ᶠ (ℤ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-0< _ p r
_⁻¹ {isInt    } {0<x} (x ,, q) {{h}} = let p = Isℤ↪ℚ.preserves-0< ℤ↪ℚinc _ q
                                           r = Isℤ↪ℚ.preserves-#0 ℤ↪ℚinc _ (ℤ.#-sym _ _ (ℤ.<-implies-# _ _ q))
                                       in  _⁻¹ᶠ (ℤ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-0< _ p r
_⁻¹ {isInt    } {x<0} (x ,, q) {{h}} = let p = Isℤ↪ℚ.preserves-<0 ℤ↪ℚinc _ q
                                           r = Isℤ↪ℚ.preserves-#0 ℤ↪ℚinc _ (ℤ.<-implies-# _ _ q)
                                       in  _⁻¹ᶠ (ℤ↪ℚ x) {{r}} ,,  ℚ.⁻¹-preserves-<0 _ p r
_⁻¹ {isInt    } {x≤0} (x ,, q) {{h}} = let p = Isℤ↪ℚ.preserves-<0 ℤ↪ℚinc _ (ℤ.≤-#-implies-< _ _ q h)
                                           r = Isℤ↪ℚ.preserves-#0 ℤ↪ℚinc _ h
                                       in  _⁻¹ᶠ (ℤ↪ℚ x) {{r}} ,, ℚ.⁻¹-preserves-<0 _ p r

_⁻¹ {isRat    } {⁇x⁇} (x ,, q) {{h}} =  _⁻¹ᶠ x  {{h}} ,, ℚ.⁻¹-preserves-#0 x h
_⁻¹ {isRat    } {x#0} (x ,, q) {{h}} =  _⁻¹ᶠ x  {{q}} ,, ℚ.⁻¹-preserves-#0 x q
_⁻¹ {isRat    } {0≤x} (x ,, q) {{h}} =  _⁻¹ᶠ x  {{h}} ,, ℚ.⁻¹-preserves-0< x (ℚ.≤-#-implies-< _ _ q (ℚ.#-sym _ _ h)) h
_⁻¹ {isRat    } {0<x} (x ,, q) {{h}} = let r = ℚ.#-sym _ _ (ℚ.<-implies-# _ _ q) in _⁻¹ᶠ x  {{r}} ,,  ℚ.⁻¹-preserves-0< _ q r
_⁻¹ {isRat    } {x<0} (x ,, q) {{h}} = let r = ℚ.<-implies-# _ _ q in _⁻¹ᶠ x  {{r}} ,, ℚ.⁻¹-preserves-<0 _ q r
_⁻¹ {isRat    } {x≤0} (x ,, q) {{h}} =  _⁻¹ᶠ x  {{h}} ,,  ℚ.⁻¹-preserves-<0 x (ℚ.≤-#-implies-< _ _ q h) h

_⁻¹ {isReal   } {⁇x⁇} (x ,, q) {{h}} =  _⁻¹ʳ x  {{h}} ,, ℝ.⁻¹-preserves-#0 x h
_⁻¹ {isReal   } {x#0} (x ,, q) {{h}} =  _⁻¹ʳ x  {{q}} ,, ℝ.⁻¹-preserves-#0 x q
_⁻¹ {isReal   } {0≤x} (x ,, q) {{h}} =  _⁻¹ʳ x  {{h}} ,, ℝ.⁻¹-preserves-0< x (ℝ.≤-#-implies-< _ _ q (ℝ.#-sym _ _ h)) h
_⁻¹ {isReal   } {0<x} (x ,, q) {{h}} = let r = ℝ.#-sym _ _ (ℝ.<-implies-# _ _ q) in _⁻¹ʳ x {{r}} ,,  ℝ.⁻¹-preserves-0< _ q r
_⁻¹ {isReal   } {x<0} (x ,, q) {{h}} = let r = ℝ.<-implies-# _ _ q in _⁻¹ʳ x  {{r}} ,, ℝ.⁻¹-preserves-<0 _ q r
_⁻¹ {isReal   } {x≤0} (x ,, q) {{h}} =  _⁻¹ʳ      x  {{h}} ,, ℝ.⁻¹-preserves-<0 x (ℝ.≤-#-implies-< _ _ q h) h

_⁻¹ {isComplex} {⁇x⁇} (x ,, q) {{h}} =  _⁻¹ᶜ      x  {{h}} ,, ℂ.⁻¹-preserves-#0 x h
_⁻¹ {isComplex} {x#0} (x ,, q) {{h}} =  _⁻¹ᶜ      x  {{q}} ,, ℂ.⁻¹-preserves-#0 x q

-_ : ∀{l p} → (x : Number (l , p)) → -Types x
-_ {isNat    } {⁇x⁇} (x ,, p) = (-ᶻ (ℕ↪ℤ x)) ,, (ℤ.-flips-0≤ _ $ Isℕ↪ℤ.preserves-0≤ ℕ↪ℤinc _ (0≤xⁿ x))
-_ {isNat    } {x#0} (x ,, p) = (-ᶻ (ℕ↪ℤ x)) ,, (ℤ.-preserves-#0 _ $ Isℕ↪ℤ.preserves-#0 ℕ↪ℤinc _ p)
-_ {isNat    } {0≤x} (x ,, p) = (-ᶻ (ℕ↪ℤ x)) ,, (ℤ.-flips-0≤ _ $ Isℕ↪ℤ.preserves-0≤ ℕ↪ℤinc _ p)
-_ {isNat    } {0<x} (x ,, p) = (-ᶻ (ℕ↪ℤ x)) ,, (ℤ.-flips-0< _ $ Isℕ↪ℤ.preserves-0< ℕ↪ℤinc _ p)
-_ {isNat    } {x≤0} (x ,, p) = (-ᶻ (ℕ↪ℤ x)) ,, (ℤ.-flips-≤0 _ $ Isℕ↪ℤ.preserves-≤0 ℕ↪ℤinc _ p)
-_ {isInt    } {⁇x⁇} (x ,, p) = (-ᶻ      x ) ,, lift tt
-_ {isInt    } {x#0} (x ,, p) = (-ᶻ      x ) ,, ℤ.-preserves-#0 _ p
-_ {isInt    } {0≤x} (x ,, p) = (-ᶻ      x ) ,, ℤ.-flips-0≤ _ p
-_ {isInt    } {0<x} (x ,, p) = (-ᶻ      x ) ,, ℤ.-flips-0< _ p
-_ {isInt    } {x<0} (x ,, p) = (-ᶻ      x ) ,, ℤ.-flips-<0 _ p
-_ {isInt    } {x≤0} (x ,, p) = (-ᶻ      x ) ,, ℤ.-flips-≤0 _ p
-_ {isRat    } {⁇x⁇} (x ,, p) = (-ᶠ      x ) ,, lift tt
-_ {isRat    } {x#0} (x ,, p) = (-ᶠ      x ) ,, ℚ.-preserves-#0 _ p
-_ {isRat    } {0≤x} (x ,, p) = (-ᶠ      x ) ,, ℚ.-flips-0≤ _ p
-_ {isRat    } {0<x} (x ,, p) = (-ᶠ      x ) ,, ℚ.-flips-0< _ p
-_ {isRat    } {x<0} (x ,, p) = (-ᶠ      x ) ,, ℚ.-flips-<0 _ p
-_ {isRat    } {x≤0} (x ,, p) = (-ᶠ      x ) ,, ℚ.-flips-≤0 _ p
-_ {isReal   } {⁇x⁇} (x ,, p) = (-ʳ      x ) ,, lift tt
-_ {isReal   } {x#0} (x ,, p) = (-ʳ      x ) ,, ℝ.-preserves-#0 _ p
-_ {isReal   } {0≤x} (x ,, p) = (-ʳ      x ) ,, ℝ.-flips-0≤ _ p
-_ {isReal   } {0<x} (x ,, p) = (-ʳ      x ) ,, ℝ.-flips-0< _ p
-_ {isReal   } {x<0} (x ,, p) = (-ʳ      x ) ,, ℝ.-flips-<0 _ p
-_ {isReal   } {x≤0} (x ,, p) = (-ʳ      x ) ,, ℝ.-flips-≤0 _ p
-_ {isComplex} {⁇x⁇} (x ,, p) = (-ᶜ      x ) ,, lift tt
-_ {isComplex} {x#0} (x ,, p) = (-ᶜ      x ) ,, ℂ.-preserves-#0 _ p

_+ʰⁿ_ : ∀{p q} → (x : Number (isNat , p)) → (y : Number (isNat , q)) → PositivityKindInterpretation isNat (+-Positivityʰ isNat p q) (num x +ⁿ num y)
_+ʰⁿ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℕ.+-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ a + b
_+ʰⁿ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℕ.+-0≤-0<-implies-0< a b pa pb -- 0 ≤ a → 0 < b → 0 < a + b
_+ʰⁿ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℕ.+-0<-0≤-implies-0< a b pa pb -- 0 < a → 0 ≤ b → 0 < a + b
_+ʰⁿ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℕ.+-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < a + b
_+ʰⁿ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = tt
_+ʰⁿ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℕ.+-≤0-≤0-implies-≤0 a b pa pb -- a ≤ 0 → b ≤ 0 → (a + b) ≤ 0

_+ʰᶻ_ : ∀{p q} → (x : Number (isInt , p)) → (y : Number (isInt , q)) → PositivityKindInterpretation isInt (+-Positivityʰ isInt p q) (num x +ᶻ num y)
_+ʰᶻ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {⁇x⁇} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x#0} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℤ.+-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ a + b
_+ʰᶻ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℤ.+-0≤-0<-implies-0< a b pa pb -- 0 ≤ a → 0 < b → 0 < a + b
_+ʰᶻ_ {0≤x} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℤ.+-0<-0≤-implies-0< a b pa pb -- 0 < a → 0 ≤ b → 0 < a + b
_+ʰᶻ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℤ.+-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < a + b
_+ʰᶻ_ {0<x} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x<0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x<0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x<0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x<0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x<0} {x<0} (a ,, pa) (b ,, pb) = ℤ.+-<0-<0-implies-<0 a b pa pb -- a < 0 → b < 0 → (a + b) < 0
_+ʰᶻ_ {x<0} {x≤0} (a ,, pa) (b ,, pb) = ℤ.+-<0-≤0-implies-<0 a b pa pb -- a < 0 → b ≤ 0 → (a + b) < 0
_+ʰᶻ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶻ_ {x≤0} {x<0} (a ,, pa) (b ,, pb) = ℤ.+-≤0-<0-implies-<0 a b pa pb -- a ≤ 0 → b < 0 → (a + b) < 0
_+ʰᶻ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℤ.+-≤0-≤0-implies-≤0 a b pa pb -- a ≤ 0 → b ≤ 0 → (a + b) ≤ 0

_+ʰᶠ_ : ∀{p q} → (x : Number (isRat , p)) → (y : Number (isRat , q)) → PositivityKindInterpretation isRat (+-Positivityʰ isRat p q) (num x +ᶠ num y)
_+ʰᶠ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {⁇x⁇} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x#0} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℚ.+-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ a + b
_+ʰᶠ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℚ.+-0≤-0<-implies-0< a b pa pb -- 0 ≤ a → 0 < b → 0 < a + b
_+ʰᶠ_ {0≤x} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℚ.+-0<-0≤-implies-0< a b pa pb -- 0 < a → 0 ≤ b → 0 < a + b
_+ʰᶠ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℚ.+-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < a + b
_+ʰᶠ_ {0<x} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x<0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x<0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x<0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x<0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x<0} {x<0} (a ,, pa) (b ,, pb) = ℚ.+-<0-<0-implies-<0 a b pa pb -- a < 0 → b < 0 → (a + b) < 0
_+ʰᶠ_ {x<0} {x≤0} (a ,, pa) (b ,, pb) = ℚ.+-<0-≤0-implies-<0 a b pa pb -- a < 0 → b ≤ 0 → (a + b) < 0
_+ʰᶠ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰᶠ_ {x≤0} {x<0} (a ,, pa) (b ,, pb) = ℚ.+-≤0-<0-implies-<0 a b pa pb -- a ≤ 0 → b < 0 → (a + b) < 0
_+ʰᶠ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℚ.+-≤0-≤0-implies-≤0 a b pa pb -- a ≤ 0 → b ≤ 0 → (a + b) ≤ 0

_+ʰʳ_ : ∀{p q} → (x : Number (isReal , p)) → (y : Number (isReal , q)) → PositivityKindInterpretation isReal (+-Positivityʰ isReal p q) (num x +ʳ num y)
_+ʰʳ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {⁇x⁇} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x#0} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℝ.+-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ a + b
_+ʰʳ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℝ.+-0≤-0<-implies-0< a b pa pb -- 0 ≤ a → 0 < b → 0 < a + b
_+ʰʳ_ {0≤x} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℝ.+-0<-0≤-implies-0< a b pa pb -- 0 < a → 0 ≤ b → 0 < a + b
_+ʰʳ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℝ.+-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < a + b
_+ʰʳ_ {0<x} {x<0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x<0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x<0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x<0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x<0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x<0} {x<0} (a ,, pa) (b ,, pb) = ℝ.+-<0-<0-implies-<0 a b pa pb -- a < 0 → b < 0 → (a + b) < 0
_+ʰʳ_ {x<0} {x≤0} (a ,, pa) (b ,, pb) = ℝ.+-<0-≤0-implies-<0 a b pa pb -- a < 0 → b ≤ 0 → (a + b) < 0
_+ʰʳ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = lift tt
_+ʰʳ_ {x≤0} {x<0} (a ,, pa) (b ,, pb) = ℝ.+-≤0-<0-implies-<0 a b pa pb -- a ≤ 0 → b < 0 → (a + b) < 0
_+ʰʳ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℝ.+-≤0-≤0-implies-≤0 a b pa pb -- a ≤ 0 → b ≤ 0 → (a + b) ≤ 0

_+ʰᶜ_ : ∀{p q} → (x : Number (isComplex , p)) → (y : Number (isComplex , q)) → PositivityKindInterpretation isComplex (+-Positivityʰ isComplex p q) (num x +ᶜ num y)
_+ʰᶜ_ x y = lift tt

_·ʰⁿ_ : ∀{p q} → (x : Number (isNat , p)) → (y : Number (isNat , q)) → PositivityKindInterpretation isNat (·-Positivityʰ isNat p q) (num x ·ⁿ num y)
_·ʰⁿ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = ℕ.·-#0-#0-implies-#0 a b pa pb -- a # 0 → b # 0 → (a · b) # 0
_·ʰⁿ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = ℕ.·-#0-0<-implies-#0 a b pa pb -- a # 0 → 0 < b → (a · b) # 0
_·ʰⁿ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℕ.·-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ (a · b)
_·ʰⁿ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℕ.·-0≤-0<-implies-0≤ a b pa pb -- 0 ≤ a → 0 < b → 0 ≤ (a · b)
_·ʰⁿ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = ℕ.·-0≤-≤0-implies-≤0 a b pa pb -- 0 ≤ a → b ≤ 0 → (a · b) ≤ 0
_·ʰⁿ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = ℕ.·-0<-#0-implies-#0 a b pa pb -- 0 < a → b # 0 → (a · b) # 0
_·ʰⁿ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℕ.·-0<-0≤-implies-0≤ a b pa pb -- 0 < a → 0 ≤ b → 0 ≤ (a · b)
_·ʰⁿ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℕ.·-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < (a · b)
_·ʰⁿ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = ℕ.·-0<-≤0-implies-≤0 a b pa pb -- 0 < a → b ≤ 0 → (a · b) ≤ 0
_·ʰⁿ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = tt
_·ʰⁿ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = ℕ.·-≤0-0≤-implies-≤0 a b pa pb -- a ≤ 0 → 0 ≤ b → (a · b) ≤ 0
_·ʰⁿ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = ℕ.·-≤0-0<-implies-≤0 a b pa pb -- a ≤ 0 → 0 < b → (a · b) ≤ 0
_·ʰⁿ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℕ.·-≤0-≤0-implies-0≤ a b pa pb -- a ≤ 0 → b ≤ 0 → 0 ≤ (a · b)

_·ʰᶻ_ : ∀{p q} → (x : Number (isInt , p)) → (y : Number (isInt , q)) → PositivityKindInterpretation isInt (·-Positivityʰ isInt p q) (num x ·ᶻ num y)
_·ʰᶻ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {⁇x⁇} {x<0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = ℤ.·-#0-#0-implies-#0 a b pa pb -- a # 0 → b # 0 → (a · b) # 0
_·ʰᶻ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = ℤ.·-#0-0<-implies-#0 a b pa pb -- a # 0 → 0 < b → (a · b) # 0
_·ʰᶻ_ {x#0} {x<0} (a ,, pa) (b ,, pb) = ℤ.·-#0-<0-implies-#0 a b pa pb -- a # 0 → b < 0 → (a · b) # 0
_·ʰᶻ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℤ.·-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ (a · b)
_·ʰᶻ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℤ.·-0≤-0<-implies-0≤ a b pa pb -- 0 ≤ a → 0 < b → 0 ≤ (a · b)
_·ʰᶻ_ {0≤x} {x<0} (a ,, pa) (b ,, pb) = ℤ.·-0≤-<0-implies-≤0 a b pa pb -- 0 ≤ a → b < 0 → (a · b) ≤ 0
_·ʰᶻ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = ℤ.·-0≤-≤0-implies-≤0 a b pa pb -- 0 ≤ a → b ≤ 0 → (a · b) ≤ 0
_·ʰᶻ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = ℤ.·-0<-#0-implies-#0 a b pa pb -- 0 < a → b # 0 → (a · b) # 0
_·ʰᶻ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℤ.·-0<-0≤-implies-0≤ a b pa pb -- 0 < a → 0 ≤ b → 0 ≤ (a · b)
_·ʰᶻ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℤ.·-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < (a · b)
_·ʰᶻ_ {0<x} {x<0} (a ,, pa) (b ,, pb) = ℤ.·-0<-<0-implies-<0 a b pa pb -- 0 < a → b < 0 → (a · b) < 0
_·ʰᶻ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = ℤ.·-0<-≤0-implies-≤0 a b pa pb -- 0 < a → b ≤ 0 → (a · b) ≤ 0
_·ʰᶻ_ {x<0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {x<0} {x#0} (a ,, pa) (b ,, pb) = ℤ.·-<0-#0-implies-#0 a b pa pb -- a < 0 → b # 0 → (a · b) # 0
_·ʰᶻ_ {x<0} {0≤x} (a ,, pa) (b ,, pb) = ℤ.·-<0-0≤-implies-≤0 a b pa pb -- a < 0 → 0 ≤ b → (a · b) ≤ 0
_·ʰᶻ_ {x<0} {0<x} (a ,, pa) (b ,, pb) = ℤ.·-<0-0<-implies-<0 a b pa pb -- a < 0 → 0 < b → (a · b) < 0
_·ʰᶻ_ {x<0} {x<0} (a ,, pa) (b ,, pb) = ℤ.·-<0-<0-implies-0< a b pa pb -- a < 0 → b < 0 → 0 < (a · b)
_·ʰᶻ_ {x<0} {x≤0} (a ,, pa) (b ,, pb) = ℤ.·-<0-≤0-implies-0≤ a b pa pb -- a < 0 → b ≤ 0 → 0 ≤ (a · b)
_·ʰᶻ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶻ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = ℤ.·-≤0-0≤-implies-≤0 a b pa pb -- a ≤ 0 → 0 ≤ b → (a · b) ≤ 0
_·ʰᶻ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = ℤ.·-≤0-0<-implies-≤0 a b pa pb -- a ≤ 0 → 0 < b → (a · b) ≤ 0
_·ʰᶻ_ {x≤0} {x<0} (a ,, pa) (b ,, pb) = ℤ.·-≤0-<0-implies-0≤ a b pa pb -- a ≤ 0 → b < 0 → 0 ≤ (a · b)
_·ʰᶻ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℤ.·-≤0-≤0-implies-0≤ a b pa pb -- a ≤ 0 → b ≤ 0 → 0 ≤ (a · b)

_·ʰᶠ_ : ∀{p q} → (x : Number (isRat , p)) → (y : Number (isRat , q)) → PositivityKindInterpretation isRat (·-Positivityʰ isRat p q) (num x ·ᶠ num y)
_·ʰᶠ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {⁇x⁇} {x<0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = ℚ.·-#0-#0-implies-#0 a b pa pb -- a # 0 → b # 0 → (a · b) # 0
_·ʰᶠ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = ℚ.·-#0-0<-implies-#0 a b pa pb -- a # 0 → 0 < b → (a · b) # 0
_·ʰᶠ_ {x#0} {x<0} (a ,, pa) (b ,, pb) = ℚ.·-#0-<0-implies-#0 a b pa pb -- a # 0 → b < 0 → (a · b) # 0
_·ʰᶠ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℚ.·-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ (a · b)
_·ʰᶠ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℚ.·-0≤-0<-implies-0≤ a b pa pb -- 0 ≤ a → 0 < b → 0 ≤ (a · b)
_·ʰᶠ_ {0≤x} {x<0} (a ,, pa) (b ,, pb) = ℚ.·-0≤-<0-implies-≤0 a b pa pb -- 0 ≤ a → b < 0 → (a · b) ≤ 0
_·ʰᶠ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = ℚ.·-0≤-≤0-implies-≤0 a b pa pb -- 0 ≤ a → b ≤ 0 → (a · b) ≤ 0
_·ʰᶠ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = ℚ.·-0<-#0-implies-#0 a b pa pb -- 0 < a → b # 0 → (a · b) # 0
_·ʰᶠ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℚ.·-0<-0≤-implies-0≤ a b pa pb -- 0 < a → 0 ≤ b → 0 ≤ (a · b)
_·ʰᶠ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℚ.·-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < (a · b)
_·ʰᶠ_ {0<x} {x<0} (a ,, pa) (b ,, pb) = ℚ.·-0<-<0-implies-<0 a b pa pb -- 0 < a → b < 0 → (a · b) < 0
_·ʰᶠ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = ℚ.·-0<-≤0-implies-≤0 a b pa pb -- 0 < a → b ≤ 0 → (a · b) ≤ 0
_·ʰᶠ_ {x<0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {x<0} {x#0} (a ,, pa) (b ,, pb) = ℚ.·-<0-#0-implies-#0 a b pa pb -- a < 0 → b # 0 → (a · b) # 0
_·ʰᶠ_ {x<0} {0≤x} (a ,, pa) (b ,, pb) = ℚ.·-<0-0≤-implies-≤0 a b pa pb -- a < 0 → 0 ≤ b → (a · b) ≤ 0
_·ʰᶠ_ {x<0} {0<x} (a ,, pa) (b ,, pb) = ℚ.·-<0-0<-implies-<0 a b pa pb -- a < 0 → 0 < b → (a · b) < 0
_·ʰᶠ_ {x<0} {x<0} (a ,, pa) (b ,, pb) = ℚ.·-<0-<0-implies-0< a b pa pb -- a < 0 → b < 0 → 0 < (a · b)
_·ʰᶠ_ {x<0} {x≤0} (a ,, pa) (b ,, pb) = ℚ.·-<0-≤0-implies-0≤ a b pa pb -- a < 0 → b ≤ 0 → 0 ≤ (a · b)
_·ʰᶠ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶠ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = ℚ.·-≤0-0≤-implies-≤0 a b pa pb -- a ≤ 0 → 0 ≤ b → (a · b) ≤ 0
_·ʰᶠ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = ℚ.·-≤0-0<-implies-≤0 a b pa pb -- a ≤ 0 → 0 < b → (a · b) ≤ 0
_·ʰᶠ_ {x≤0} {x<0} (a ,, pa) (b ,, pb) = ℚ.·-≤0-<0-implies-0≤ a b pa pb -- a ≤ 0 → b < 0 → 0 ≤ (a · b)
_·ʰᶠ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℚ.·-≤0-≤0-implies-0≤ a b pa pb -- a ≤ 0 → b ≤ 0 → 0 ≤ (a · b)

_·ʰʳ_ : ∀{p q} → (x : Number (isReal , p)) → (y : Number (isReal , q)) → PositivityKindInterpretation isReal (·-Positivityʰ isReal p q) (num x ·ʳ num y)
_·ʰʳ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {⁇x⁇} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {⁇x⁇} {0<x} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {⁇x⁇} {x<0} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {⁇x⁇} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = ℝ.·-#0-#0-implies-#0 a b pa pb -- a # 0 → b # 0 → (a · b) # 0
_·ʰʳ_ {x#0} {0≤x} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {x#0} {0<x} (a ,, pa) (b ,, pb) = ℝ.·-#0-0<-implies-#0 a b pa pb -- a # 0 → 0 < b → (a · b) # 0
_·ʰʳ_ {x#0} {x<0} (a ,, pa) (b ,, pb) = ℝ.·-#0-<0-implies-#0 a b pa pb -- a # 0 → b < 0 → (a · b) # 0
_·ʰʳ_ {x#0} {x≤0} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {0≤x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {0≤x} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {0≤x} {0≤x} (a ,, pa) (b ,, pb) = ℝ.·-0≤-0≤-implies-0≤ a b pa pb -- 0 ≤ a → 0 ≤ b → 0 ≤ (a · b)
_·ʰʳ_ {0≤x} {0<x} (a ,, pa) (b ,, pb) = ℝ.·-0≤-0<-implies-0≤ a b pa pb -- 0 ≤ a → 0 < b → 0 ≤ (a · b)
_·ʰʳ_ {0≤x} {x<0} (a ,, pa) (b ,, pb) = ℝ.·-0≤-<0-implies-≤0 a b pa pb -- 0 ≤ a → b < 0 → (a · b) ≤ 0
_·ʰʳ_ {0≤x} {x≤0} (a ,, pa) (b ,, pb) = ℝ.·-0≤-≤0-implies-≤0 a b pa pb -- 0 ≤ a → b ≤ 0 → (a · b) ≤ 0
_·ʰʳ_ {0<x} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {0<x} {x#0} (a ,, pa) (b ,, pb) = ℝ.·-0<-#0-implies-#0 a b pa pb -- 0 < a → b # 0 → (a · b) # 0
_·ʰʳ_ {0<x} {0≤x} (a ,, pa) (b ,, pb) = ℝ.·-0<-0≤-implies-0≤ a b pa pb -- 0 < a → 0 ≤ b → 0 ≤ (a · b)
_·ʰʳ_ {0<x} {0<x} (a ,, pa) (b ,, pb) = ℝ.·-0<-0<-implies-0< a b pa pb -- 0 < a → 0 < b → 0 < (a · b)
_·ʰʳ_ {0<x} {x<0} (a ,, pa) (b ,, pb) = ℝ.·-0<-<0-implies-<0 a b pa pb -- 0 < a → b < 0 → (a · b) < 0
_·ʰʳ_ {0<x} {x≤0} (a ,, pa) (b ,, pb) = ℝ.·-0<-≤0-implies-≤0 a b pa pb -- 0 < a → b ≤ 0 → (a · b) ≤ 0
_·ʰʳ_ {x<0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {x<0} {x#0} (a ,, pa) (b ,, pb) = ℝ.·-<0-#0-implies-#0 a b pa pb -- a < 0 → b # 0 → (a · b) # 0
_·ʰʳ_ {x<0} {0≤x} (a ,, pa) (b ,, pb) = ℝ.·-<0-0≤-implies-≤0 a b pa pb -- a < 0 → 0 ≤ b → (a · b) ≤ 0
_·ʰʳ_ {x<0} {0<x} (a ,, pa) (b ,, pb) = ℝ.·-<0-0<-implies-<0 a b pa pb -- a < 0 → 0 < b → (a · b) < 0
_·ʰʳ_ {x<0} {x<0} (a ,, pa) (b ,, pb) = ℝ.·-<0-<0-implies-0< a b pa pb -- a < 0 → b < 0 → 0 < (a · b)
_·ʰʳ_ {x<0} {x≤0} (a ,, pa) (b ,, pb) = ℝ.·-<0-≤0-implies-0≤ a b pa pb -- a < 0 → b ≤ 0 → 0 ≤ (a · b)
_·ʰʳ_ {x≤0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {x≤0} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰʳ_ {x≤0} {0≤x} (a ,, pa) (b ,, pb) = ℝ.·-≤0-0≤-implies-≤0 a b pa pb -- a ≤ 0 → 0 ≤ b → (a · b) ≤ 0
_·ʰʳ_ {x≤0} {0<x} (a ,, pa) (b ,, pb) = ℝ.·-≤0-0<-implies-≤0 a b pa pb -- a ≤ 0 → 0 < b → (a · b) ≤ 0
_·ʰʳ_ {x≤0} {x<0} (a ,, pa) (b ,, pb) = ℝ.·-≤0-<0-implies-0≤ a b pa pb -- a ≤ 0 → b < 0 → 0 ≤ (a · b)
_·ʰʳ_ {x≤0} {x≤0} (a ,, pa) (b ,, pb) = ℝ.·-≤0-≤0-implies-0≤ a b pa pb -- a ≤ 0 → b ≤ 0 → 0 ≤ (a · b)

_·ʰᶜ_ : ∀{p q} → (x : Number (isComplex , p)) → (y : Number (isComplex , q)) → PositivityKindInterpretation isComplex (·-Positivityʰ isComplex p q) (num x ·ᶜ num y)
_·ʰᶜ_ {⁇x⁇} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶜ_ {⁇x⁇} {x#0} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶜ_ {x#0} {⁇x⁇} (a ,, pa) (b ,, pb) = lift tt
_·ʰᶜ_ {x#0} {x#0} (a ,, pa) (b ,, pb) = ℂ.·-#0-#0-implies-#0 a b pa pb -- a # 0 → b # 0 → (a · b) # 0

open PatternsType

-- abs x = max x (- x)

abs : ∀{l p} → (x : Number (l , p)) → abs-Types x
abs {isNat    } {X  } (x ,, p) = (absⁿ x ,, 0≤xⁿ x)
abs {isNat    } {X⁺⁻} (x ,, p) = (absⁿ x ,, ℕ.0≤-#0-implies-0< x (0≤xⁿ x) p)
abs {isNat    } {X₀⁺} (x ,, p) = (absⁿ x ,, p)
abs {isNat    } {X⁺ } (x ,, p) = (absⁿ x ,, p)
abs {isNat    } {X₀⁻} (x ,, p) = (absⁿ x ,, (0ⁿ , (sym $ ≤0→≡0 p)))
abs {isInt    } {X  } (x ,, p) = (absᶻ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isInt    } {X⁺⁻} (x ,, p) = (absᶻ x ,, {!!}) -- ∀ x → x # 0 → 0 < abs x
abs {isInt    } {X₀⁺} (x ,, p) = (absᶻ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isInt    } {X⁺ } (x ,, p) = (absᶻ x ,, {!!}) -- ∀ x → 0 < x → 0 < abs x
abs {isInt    } {X⁻ } (x ,, p) = (absᶻ x ,, {!!}) -- ∀ x → x < 0 → 0 < abs x
abs {isInt    } {X₀⁻} (x ,, p) = (absᶻ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isRat    } {X  } (x ,, p) = (absᶠ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isRat    } {X⁺⁻} (x ,, p) = (absᶠ x ,, {!!}) -- ∀ x → x # 0 → 0 < abs x
abs {isRat    } {X₀⁺} (x ,, p) = (absᶠ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isRat    } {X⁺ } (x ,, p) = (absᶠ x ,, {!!}) -- ∀ x → 0 < x → 0 < abs x
abs {isRat    } {X⁻ } (x ,, p) = (absᶠ x ,, {!!}) -- ∀ x → x < 0 → 0 < abs x
abs {isRat    } {X₀⁻} (x ,, p) = (absᶠ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isReal   } {X  } (x ,, p) = (absʳ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isReal   } {X⁺⁻} (x ,, p) = (absʳ x ,, {!!}) -- ∀ x → x # 0 → 0 < abs x
abs {isReal   } {X₀⁺} (x ,, p) = (absʳ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isReal   } {X⁺ } (x ,, p) = (absʳ x ,, {!!}) -- ∀ x → 0 < x → 0 < abs x
abs {isReal   } {X⁻ } (x ,, p) = (absʳ x ,, {!!}) -- ∀ x → x < 0 → 0 < abs x
abs {isReal   } {X₀⁻} (x ,, p) = (absʳ x ,, {!!}) -- ∀ x → 0 ≤ abs x
abs {isComplex} {X  } (x ,, p) = (absᶜ x ,, 0≤abs x)
abs {isComplex} {X⁺⁻} (x ,, p) = (absᶜ x ,, γ) where
  pʳ = ℂ.0≤abs x
  γ : 0ʳ <ʳ absᶜ x
  γ =  ℝ.0≤-#0-implies-0< (absᶜ x) pʳ (ℂ.abs-preserves-#0 x p)

-- a < b → ¬(b ≤ a) = ¬¬(a < b)

-- 0≤abs       : ∀ x → 0ʳ ≤ʳ abs x
-- abs-preserves-0 : ∀ x → x ≡ 0f → abs x ≡ 0ʳ
-- abs-reflects-0  : ∀ x → abs x ≡ 0ʳ → x ≡ 0f
-- abs-preserves-· : ∀ x y → abs (x · y) ≡ (abs x) ·ʳ (abs y)
-- #-tight : ∀ x y → ¬(x # y) → x ≡ y
-- a ≤ b = ¬(b < a)


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

open import LogicalFormulae
open import Groups.Definition
open import Setoids.Setoids
open import Rings.Definition
open import Sets.EquivalenceRelations
open import Rings.Ideals.Definition
open import Rings.IntegralDomains.Definition
open import Rings.Ideals.Prime.Definition
open import Rings.Cosets

module Rings.Ideals.Prime.Lemmas {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} {R : Ring S _+_ _*_} {c : _} {pred : A → Set c} (i : Ideal R pred) where

open Ring R
open Group additiveGroup
open Setoid S
open Equivalence eq
open import Rings.Ideals.Lemmas R

idealPrimeImpliesQuotientIntDom : PrimeIdeal i → IntegralDomain (cosetRing R i)
IntegralDomain.intDom (idealPrimeImpliesQuotientIntDom isPrime) {a} {b} ab=0 a!=0 = ans
  where
    ab=0' : pred (a * b)
    ab=0' = translate' i ab=0
    a!=0' : (pred a) → False
    a!=0' prA = a!=0 (translate i prA)
    ans' : pred b
    ans' = PrimeIdeal.isPrime isPrime ab=0' a!=0'
    ans : pred (inverse (Ring.0R (cosetRing R i)) + b)
    ans = translate i ans'
IntegralDomain.nontrivial (idealPrimeImpliesQuotientIntDom isPrime) 1=0 = PrimeIdeal.notContainedIsNotContained isPrime u
  where
    t : pred (Ring.1R (cosetRing R i))
    t = translate' i 1=0
    u : pred (PrimeIdeal.notContained isPrime)
    u = Ideal.isSubset i identIsIdent (Ideal.accumulatesTimes i {y = PrimeIdeal.notContained isPrime} t)

quotientIntDomImpliesIdealPrime : IntegralDomain (cosetRing R i) → PrimeIdeal i
quotientIntDomImpliesIdealPrime intDom = record { isPrime = isPrime ; notContained = Ring.1R R ; notContainedIsNotContained = notCon }
  where
    abstract
      notCon : pred 1R → False
      notCon 1=0 = IntegralDomain.nontrivial intDom (translate i 1=0)
      isPrime : {a b : A} → pred (a * b) → (pred a → False) → pred b
      isPrime {a} {b} predAB !predA = translate' i (IntegralDomain.intDom intDom (translate i predAB) λ t → !predA (translate' i t))

private
  dividesZero : {a : A} → generatedIdealPred R 0R a → a ∼ 0R
  dividesZero (c , pr) = symmetric (transitive (symmetric (transitive *Commutative timesZero)) pr)

zeroIdealPrimeImpliesIntDom : PrimeIdeal (generatedIdeal R 0R) → IntegralDomain R
IntegralDomain.intDom (zeroIdealPrimeImpliesIntDom record { isPrime = isPrime ; notContained = notContained ; notContainedIsNotContained = notContainedIsNotContained }) {a} {b} ab=0 a!=0 with isPrime {a} {b} (1R , transitive (transitive *Commutative timesZero) (symmetric ab=0)) (λ 0|a → a!=0 (dividesZero 0|a))
... | c , 0c=b = transitive (symmetric 0c=b) (transitive *Commutative timesZero)
IntegralDomain.nontrivial (zeroIdealPrimeImpliesIntDom record { isPrime = isPrime ; notContained = notContained ; notContainedIsNotContained = notContainedIsNotContained }) 1=0 = notContainedIsNotContained (notContained , transitive (*WellDefined (symmetric 1=0) reflexive) identIsIdent)

intDomImpliesZeroIdealPrime : IntegralDomain R → PrimeIdeal (generatedIdeal R 0R)
PrimeIdeal.isPrime (intDomImpliesZeroIdealPrime intDom) (c , 0=ab) 0not|a with IntegralDomain.intDom intDom (transitive (symmetric 0=ab) (transitive *Commutative timesZero)) (λ a=0 → 0not|a (0R , transitive timesZero (symmetric a=0)))
... | b=0 = 0R , transitive timesZero (symmetric b=0)
PrimeIdeal.notContained (intDomImpliesZeroIdealPrime intDom) = 1R
PrimeIdeal.notContainedIsNotContained (intDomImpliesZeroIdealPrime intDom) (c , 0c=1) = IntegralDomain.nontrivial intDom (symmetric (transitive (symmetric (transitive *Commutative timesZero)) 0c=1))

primeIdealWellDefined : {c : _} {pred2 : A → Set c} (ideal2 : Ideal R pred2) → ({x : A} → pred x → pred2 x) → ({x : A} → pred2 x → pred x) → PrimeIdeal i → PrimeIdeal ideal2
PrimeIdeal.isPrime (primeIdealWellDefined ideal2 predToPred2 pred2ToPred record { isPrime = isPrime ; notContained = notContained ; notContainedIsNotContained = notContainedIsNotContained }) p2ab notP2a = predToPred2 (isPrime (pred2ToPred p2ab) λ p → notP2a (predToPred2 p))
PrimeIdeal.notContained (primeIdealWellDefined ideal2 predToPred2 pred2ToPred record { isPrime = isPrime ; notContained = notContained ; notContainedIsNotContained = notContainedIsNotContained }) = notContained
PrimeIdeal.notContainedIsNotContained (primeIdealWellDefined ideal2 predToPred2 pred2ToPred record { isPrime = isPrime ; notContained = notContained ; notContainedIsNotContained = notContainedIsNotContained }) pred2Not = notContainedIsNotContained (pred2ToPred pred2Not)


{-# OPTIONS -v tc.conv.fun:20 #-}

-- Andreas, 2019-11-06, issue #4175, reported and test case by nad.
-- Check quantity for function type subtyping.

postulate
  F : Set → Set
  G : (@0 Set → Set) → Set

-- If an erased function is expected, we cannot pass one
-- that might actually use its arguments.

ShouldFail : Set
ShouldFail = G F

-- Note the eta-expanded version already failed:
-- Fails = G λ x → F x


{-
  A morphism of UARels is a function between the structures with an action on the relations that
  commutes with the equivalence to PathP.

  We can reindex a DUARel or SubstRel along one of these.
-}
{-# OPTIONS --safe #-}
module Cubical.Displayed.Morphism where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport

open import Cubical.Displayed.Base
open import Cubical.Displayed.Subst

private
  variable
    ℓ ℓA ℓA' ℓ≅A ℓB ℓB' ℓ≅B ℓC ℓ≅C : Level

record UARelHom {A : Type ℓA} {B : Type ℓB} (𝒮-A : UARel A ℓ≅A) (𝒮-B : UARel B ℓ≅B)
  : Type (ℓ-max (ℓ-max ℓA ℓ≅A) (ℓ-max ℓB ℓ≅B)) where
  no-eta-equality
  constructor uarelhom
  field
    fun : A → B
    rel : ∀ {a a'} → UARel._≅_ 𝒮-A a a' → UARel._≅_ 𝒮-B (fun a) (fun a')
    ua : ∀ {a a'} (p : UARel._≅_ 𝒮-A a a')
      → cong fun (UARel.≅→≡ 𝒮-A p) ≡ UARel.≅→≡ 𝒮-B (rel p)

open UARelHom

𝒮-id : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → UARelHom 𝒮-A 𝒮-A
𝒮-id 𝒮-A .fun = idfun _
𝒮-id 𝒮-A .rel = idfun _
𝒮-id 𝒮-A .ua _ = refl

𝒮-∘ : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B}
  {C : Type ℓC} {𝒮-C : UARel C ℓ≅C}
  → UARelHom 𝒮-B 𝒮-C
  → UARelHom 𝒮-A 𝒮-B
  → UARelHom 𝒮-A 𝒮-C
𝒮-∘ g f .fun = g .fun ∘ f .fun
𝒮-∘ g f .rel = g .rel ∘ f .rel
𝒮-∘ {𝒮-A = 𝒮-A} {𝒮-B = 𝒮-B} {𝒮-C = 𝒮-C} g f .ua p =
  cong (cong (g .fun)) (f .ua p) ∙ g .ua (f .rel p)

𝒮ᴰ-reindex : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} {C : B → Type ℓC}
  (f : UARelHom 𝒮-A 𝒮-B)
  → DUARel 𝒮-B C ℓ≅C
  → DUARel 𝒮-A (C ∘ fun f) ℓ≅C
𝒮ᴰ-reindex f 𝒮ᴰ-C .DUARel._≅ᴰ⟨_⟩_ c p c' = 𝒮ᴰ-C .DUARel._≅ᴰ⟨_⟩_ c (f .rel p) c'
𝒮ᴰ-reindex {C = C} f 𝒮ᴰ-C .DUARel.uaᴰ c p c' =
  compEquiv
    (𝒮ᴰ-C .DUARel.uaᴰ c (f .rel p) c')
    (substEquiv (λ q → PathP (λ i → C (q i)) c c') (sym (f .ua p)))

𝒮ˢ-reindex : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A} {B : Type ℓB} {𝒮-B : UARel B ℓ≅B} {C : B → Type ℓC}
  (f : UARelHom 𝒮-A 𝒮-B)
  → SubstRel 𝒮-B C
  → SubstRel 𝒮-A (C ∘ fun f)
𝒮ˢ-reindex f 𝒮ˢ-C .SubstRel.act p = 𝒮ˢ-C .SubstRel.act (f .rel p)
𝒮ˢ-reindex {C = C} f 𝒮ˢ-C .SubstRel.uaˢ p c =
  cong (λ q → subst C q c) (f .ua p)
  ∙ 𝒮ˢ-C .SubstRel.uaˢ (f .rel p) c


------------------------------------------------------------------------
-- The Agda standard library
--
-- The lifting of a non-strict order to incorporate new extrema
------------------------------------------------------------------------

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

-- This module is designed to be used with
-- Relation.Nullary.Construct.Add.Extrema

open import Relation.Binary

module Relation.Binary.Construct.Add.Extrema.NonStrict
  {a ℓ} {A : Set a} (_≤_ : Rel A ℓ) where

open import Function
open import Relation.Nullary.Construct.Add.Extrema
import Relation.Nullary.Construct.Add.Infimum as I
import Relation.Binary.Construct.Add.Infimum.NonStrict as AddInfimum
import Relation.Binary.Construct.Add.Supremum.NonStrict as AddSupremum
import Relation.Binary.Construct.Add.Extrema.Equality as Equality

-------------------------------------------------------------------------
-- Definition

private
  module Inf = AddInfimum _≤_
  module Sup = AddSupremum Inf._≤₋_

open Sup using () renaming (_≤⁺_ to _≤±_) public

-------------------------------------------------------------------------
-- Useful pattern synonyms

pattern ⊥±≤⊥±    = Sup.[ Inf.⊥₋≤ I.⊥₋ ]
pattern ⊥±≤[_] l = Sup.[ Inf.⊥₋≤ I.[ l ] ]
pattern [_] p    = Sup.[ Inf.[ p ] ]
pattern ⊥±≤⊤±    = ⊥±    Sup.≤⊤⁺
pattern [_]≤⊤± k = [ k ] Sup.≤⊤⁺
pattern ⊤±≤⊤±    = ⊤±    Sup.≤⊤⁺

⊥±≤_ : ∀ k → ⊥± ≤± k
⊥±≤ ⊥±    = ⊥±≤⊥±
⊥±≤ [ k ] = ⊥±≤[ k ]
⊥±≤ ⊤±    = ⊥±≤⊤±

_≤⊤± : ∀ k → k ≤± ⊤±
⊥±    ≤⊤± = ⊥±≤⊤±
[ k ] ≤⊤± = [ k ]≤⊤±
⊤±    ≤⊤± = ⊤±≤⊤±

-------------------------------------------------------------------------
-- Relational properties

[≤]-injective : ∀ {k l} → [ k ] ≤± [ l ] → k ≤ l
[≤]-injective = Inf.[≤]-injective ∘′ Sup.[≤]-injective

module _ {e} {_≈_ : Rel A e} where

  open Equality _≈_

  ≤±-reflexive : (_≈_ ⇒ _≤_) → (_≈±_ ⇒ _≤±_)
  ≤±-reflexive = Sup.≤⁺-reflexive ∘′ Inf.≤₋-reflexive

  ≤±-antisym : Antisymmetric _≈_ _≤_ → Antisymmetric _≈±_ _≤±_
  ≤±-antisym = Sup.≤⁺-antisym ∘′ Inf.≤₋-antisym

≤±-trans : Transitive _≤_ → Transitive _≤±_
≤±-trans = Sup.≤⁺-trans ∘′ Inf.≤₋-trans

≤±-minimum : Minimum _≤±_ ⊥±
≤±-minimum = ⊥±≤_

≤±-maximum : Maximum _≤±_ ⊤±
≤±-maximum = _≤⊤±

≤±-dec : Decidable _≤_ → Decidable _≤±_
≤±-dec = Sup.≤⁺-dec ∘′ Inf.≤₋-dec

≤±-total : Total _≤_ → Total _≤±_
≤±-total = Sup.≤⁺-total ∘′ Inf.≤₋-total

≤±-irrelevant : Irrelevant _≤_ → Irrelevant _≤±_
≤±-irrelevant = Sup.≤⁺-irrelevant ∘′ Inf.≤₋-irrelevant

-------------------------------------------------------------------------
-- Structures

module _ {e} {_≈_ : Rel A e} where

  open Equality _≈_

  ≤±-isPreorder : IsPreorder _≈_ _≤_ → IsPreorder _≈±_ _≤±_
  ≤±-isPreorder = Sup.≤⁺-isPreorder ∘′ Inf.≤₋-isPreorder

  ≤±-isPartialOrder : IsPartialOrder _≈_ _≤_ → IsPartialOrder _≈±_ _≤±_
  ≤±-isPartialOrder = Sup.≤⁺-isPartialOrder ∘′ Inf.≤₋-isPartialOrder

  ≤±-isDecPartialOrder : IsDecPartialOrder _≈_ _≤_ → IsDecPartialOrder _≈±_ _≤±_
  ≤±-isDecPartialOrder = Sup.≤⁺-isDecPartialOrder ∘′ Inf.≤₋-isDecPartialOrder

  ≤±-isTotalOrder : IsTotalOrder _≈_ _≤_ → IsTotalOrder _≈±_ _≤±_
  ≤±-isTotalOrder = Sup.≤⁺-isTotalOrder ∘′ Inf.≤₋-isTotalOrder

  ≤±-isDecTotalOrder : IsDecTotalOrder _≈_ _≤_ → IsDecTotalOrder _≈±_ _≤±_
  ≤±-isDecTotalOrder = Sup.≤⁺-isDecTotalOrder ∘′ Inf.≤₋-isDecTotalOrder


module Categories.Functor.Coalgebra where


{-# OPTIONS -v tc.unquote.clause:30 #-}

open import Common.Reflection
open import Common.Prelude

data Box : Set → Set₁ where
  box : (A : Set) → Box A

unquoteDecl test = define (vArg test) (funDef
 (pi
   (vArg (sort (lit 0)))
   (abs "A" (pi
    (vArg (def (quote Box) (vArg (var 0 []) ∷ [])))
    (abs "x" (sort (lit 0))))))
 (clause
   (vArg dot ∷
    vArg (con (quote box) (vArg (var "dot") ∷ [])) ∷ [])
   (var 1 [])
 ∷ []))


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

module Fragment.Prelude where

open import Fragment.Tactic.Fragment using (fragment) public

open import Fragment.Equational.Theory.Bundles public
open import Fragment.Equational.Structures public

open import Fragment.Extensions.Semigroup using (SemigroupFrex) public
open import Fragment.Extensions.CSemigroup using (CSemigroupFrex) public


open import HoTT

module cohomology.Exactness where

module _ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (F : fst (X ⊙→ Y)) (G : fst (Y ⊙→ Z)) where

  private
    f = fst F
    g = fst G

  {- in image of F ⇒ in kernel of G -}
  is-exact-itok : Type (lmax k (lmax j i))
  is-exact-itok = (y : fst Y) → Trunc ⟨-1⟩ (Σ (fst X) (λ x → f x == y))
    → g y == snd Z

  {- in kernel of G ⇒ in image of F -}
  is-exact-ktoi : Type (lmax k (lmax j i))
  is-exact-ktoi = (y : fst Y) → g y == snd Z
    → Trunc ⟨-1⟩ (Σ (fst X) (λ x → f x == y))

  record is-exact : Type (lmax k (lmax j i)) where
    field
      itok : is-exact-itok
      ktoi : is-exact-ktoi

  open is-exact public

  {- an equivalent version of is-exact-ktoi if Z is a set -}
  itok-alt-in : has-level ⟨0⟩ (fst Z)
    → ((x : fst X) → g (f x) == snd Z) → is-exact-itok
  itok-alt-in pZ h y = Trunc-rec (pZ _ _)
    (λ {(x , p) → ap g (! p) ∙ h x})

  itok-alt-out : is-exact-itok → ((x : fst X) → g (f x) == snd Z)
  itok-alt-out h x = h (f x) [ x , idp ]

{- Convenient notation for exact sequences. At the moment this is only set
   up for exact sequences of groups. Do we care about the general case?    -}

infix 2 _⊣|
infixr 2 _⟨_⟩→_

data ExactDiag {i} : Group i → Group i → Type (lsucc i) where
  _⊣| : (G : Group i) → ExactDiag G G
  _⟨_⟩→_ : (G : Group i) {H K : Group i} (φ : G →ᴳ H)
             → ExactDiag H K → ExactDiag G K

data ExactSeq {i} : {G H : Group i} → ExactDiag G H → Type (lsucc i) where
  exact-seq-zero : {G : Group i} → ExactSeq (G ⊣|)
  exact-seq-one : {G H : Group i} {φ : G →ᴳ H} → ExactSeq (G ⟨ φ ⟩→ H ⊣|)
  exact-seq-two : {G H K J : Group i} {φ : G →ᴳ H} {ψ : H →ᴳ K}
    {diag : ExactDiag K J} → is-exact (GroupHom.⊙f φ) (GroupHom.⊙f ψ)
    → ExactSeq (H ⟨ ψ ⟩→ diag) → ExactSeq (G ⟨ φ ⟩→ H ⟨ ψ ⟩→ diag)

private
  exact-get-type : ∀ {i} {G H : Group i} → ExactDiag G H → ℕ → Type i
  exact-get-type (G ⊣|) _ = Lift Unit
  exact-get-type (G ⟨ φ ⟩→ H ⊣|) _ = Lift Unit
  exact-get-type (G ⟨ φ ⟩→ (H ⟨ ψ ⟩→ s)) O =
    is-exact (GroupHom.⊙f φ) (GroupHom.⊙f ψ)
  exact-get-type (_ ⟨ _ ⟩→ s) (S n) = exact-get-type s n

exact-get : ∀ {i} {G H : Group i} {diag : ExactDiag G H}
  → ExactSeq diag → (n : ℕ) → exact-get-type diag n
exact-get exact-seq-zero _ = lift unit
exact-get exact-seq-one _ = lift unit
exact-get (exact-seq-two ex s) O = ex
exact-get (exact-seq-two ex s) (S n) = exact-get s n

private
  exact-build-arg-type : ∀ {i} {G H : Group i} → ExactDiag G H → List (Type i)
  exact-build-arg-type (G ⊣|) = nil
  exact-build-arg-type (G ⟨ φ ⟩→ H ⊣|) = nil
  exact-build-arg-type (G ⟨ φ ⟩→ H ⟨ ψ ⟩→ s) =
    is-exact (GroupHom.⊙f φ) (GroupHom.⊙f ψ)
    :: exact-build-arg-type (H ⟨ ψ ⟩→ s)

  exact-build-helper : ∀ {i} {G H : Group i} (diag : ExactDiag G H)
    → HList (exact-build-arg-type diag) → ExactSeq diag
  exact-build-helper (G ⊣|) nil = exact-seq-zero
  exact-build-helper (G ⟨ φ ⟩→ H ⊣|) nil = exact-seq-one
  exact-build-helper (G ⟨ φ ⟩→ H ⟨ ψ ⟩→ s) (ie :: ies) =
    exact-seq-two ie (exact-build-helper (H ⟨ ψ ⟩→ s) ies)

exact-build : ∀ {i} {G H : Group i} (diag : ExactDiag G H)
  → hlist-curry-type (exact-build-arg-type diag) (λ _ → ExactSeq diag)
exact-build diag = hlist-curry (exact-build-helper diag)

private
  exact-snoc-diag : ∀ {i} {G H K : Group i}
    → ExactDiag G H → (H →ᴳ K) → ExactDiag G K
  exact-snoc-diag (G ⊣|) ψ = G ⟨ ψ ⟩→ _ ⊣|
  exact-snoc-diag (G ⟨ φ ⟩→ s) ψ = G ⟨ φ ⟩→ exact-snoc-diag s ψ

  exact-concat-diag : ∀ {i} {G H K : Group i}
    → ExactDiag G H → ExactDiag H K → ExactDiag G K
  exact-concat-diag (G ⊣|) s₂ = s₂
  exact-concat-diag (G ⟨ φ ⟩→ s₁) s₂ = G ⟨ φ ⟩→ (exact-concat-diag s₁ s₂)

abstract
  exact-concat : ∀ {i} {G H K L : Group i}
    {diag₁ : ExactDiag G H} {φ : H →ᴳ K} {diag₂ : ExactDiag K L}
    → ExactSeq (exact-snoc-diag diag₁ φ) → ExactSeq (H ⟨ φ ⟩→ diag₂)
    → ExactSeq (exact-concat-diag diag₁ (H ⟨ φ ⟩→ diag₂))
  exact-concat {diag₁ = G ⊣|} exact-seq-one es₂ = es₂
  exact-concat {diag₁ = G ⟨ ψ ⟩→ H ⊣|} (exact-seq-two ex _) es₂ =
    exact-seq-two ex es₂
  exact-concat {diag₁ = G ⟨ ψ ⟩→ H ⟨ χ ⟩→ s} (exact-seq-two ex es₁) es₂ =
    exact-seq-two ex (exact-concat {diag₁ = H ⟨ χ ⟩→ s} es₁ es₂)


module par-swap where

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Context
open import sn-calculus

data _∥R_ : Term -> Term -> Set where
  ∥Rstep : ∀ {C p q d} ->
          (d≐C⟦p∥q⟧c : d ≐ C ⟦ (p ∥ q) ⟧c) ->
          d ∥R (C ⟦ (q ∥ p) ⟧c)

data _∥R*_ : Term -> Term -> Set where
  ∥R0 : ∀ {p} -> p ∥R* p
  ∥Rn : ∀ {p q r} ->
        (p∥Rq : p ∥R q) ->
        (q∥R*r : q ∥R* r) ->
        p ∥R* r

∥R*-concat : ∀ {p q r} -> p ∥R* q -> q ∥R* r -> p ∥R* r
∥R*-concat ∥R0 q∥R*r = q∥R*r
∥R*-concat (∥Rn p∥Rq p∥R*q) q∥R*r = ∥Rn p∥Rq (∥R*-concat p∥R*q q∥R*r)

data _∥R*∪sn⟶*_ : Term -> Term -> Set where
  ∪∥R* : ∀ {p q r} ->
         (p∥R*q : p ∥R* q) ->
         (q∥R∪sn⟶*r : q ∥R*∪sn⟶* r) ->
         p ∥R*∪sn⟶* r
  ∪sn⟶* : ∀ {p q r} ->
         (psn⟶*q : p sn⟶* q) ->
         (q∥R∪sn⟶*r : q ∥R*∪sn⟶* r) ->
         p ∥R*∪sn⟶* r
  ∪refl : ∀ {p} -> p ∥R*∪sn⟶* p

∥R*∪sn⟶*-concat : ∀ {p q r} -> p ∥R*∪sn⟶* q -> q ∥R*∪sn⟶* r -> p ∥R*∪sn⟶* r
∥R*∪sn⟶*-concat (∪∥R* p∥R*q a) b = ∪∥R* p∥R*q (∥R*∪sn⟶*-concat a b)
∥R*∪sn⟶*-concat (∪sn⟶* psn⟶*q a) b = ∪sn⟶* psn⟶*q (∥R*∪sn⟶*-concat a b)
∥R*∪sn⟶*-concat ∪refl b = b

data _∥R∪sn≡ₑ_ : Term → Term → Set where
  ∪stpsn : ∀{p q} → (psn⟶q : p sn⟶ q) → p ∥R∪sn≡ₑ q
  ∪stp∥ : ∀{p q} → (p∥Rq : p ∥R q) → p ∥R∪sn≡ₑ q
  ∪sym : ∀{p q BV FV} → (psn∪∥R≡ₑq : p ∥R∪sn≡ₑ q) → (CBp : CorrectBinding p BV FV) → q ∥R∪sn≡ₑ p
  ∪ref : ∀{p} → p ∥R∪sn≡ₑ p
  ∪trn : ∀{p r q} → (p∥R∪sn≡ₑr : p ∥R∪sn≡ₑ r) → (r∥R∪sn≡ₑq : r ∥R∪sn≡ₑ q) → p ∥R∪sn≡ₑ q


module Basic.Compiler.Machine where

open import Basic.AST
open import Basic.BigStep
open import Basic.Compiler.Code

open import Utils.Decidable
open import Data.Product
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Data.List hiding (unfold)
open import Data.Bool
open import Data.Nat
open import Data.Maybe

{-

This is a simple interpreter for the abstract machine code.

There's no corresponding part in the book.

A nice thing about the abstract machine is that each transition is decidable,
so we can tell at each point whether our program is stuck or may continue.

Of course, this doesn't mean that *computation sequences* are decidable! (it's pretty much
just the halting problem).

What we can do is specify how many steps we'd like to compute, and then compute that far.

The "steps" function below only computes the ending configuration, while "trace"
returns a list of all intermediate configurations.

"unfold" returns a computation sequence if the program terminates or gets stuck in
the given number of steps.

-}

step : ∀ {n} (c : Code n) e s → Dec (∃₂ λ c' e' -> ∃ λ s' → ⟨ c , e , s ⟩▷⟨ c' , e' , s' ⟩)
step [] e s = no (λ {(c' , e' , s' , ())})
step (PUSH x ∷ c) e s = yes (c , nat x ∷ e , s , PUSH x)
step (FETCH x ∷ c) e s = yes (c , nat _ ∷ e , s , FETCH x)
step (STORE x ∷ c) [] s = no (λ {(c' , e' , s' , ())})
step (STORE x ∷ c) (nat x₁ ∷ e) s = yes (c , e , _ , STORE x)
step (STORE x ∷ c) (bool x₁ ∷ e) s = no (λ {(c' , e' , s' , ())})
step (ADD ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (ADD ∷ c) (nat x ∷ []) s = no (λ { (c' , e' , s' , ()) })
step (ADD ∷ c) (nat x ∷ nat x₁ ∷ e) s = yes (c , nat _ ∷ e , s , ADD x x₁)
step (ADD ∷ c) (nat x ∷ bool x₁ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (ADD ∷ c) (bool x ∷ e) s = no (λ { (c' , e' , s' , ()) })

step (MUL ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (MUL ∷ c) (nat x ∷ []) s = no (λ { (c' , e' , s' , ()) })
step (MUL ∷ c) (nat x ∷ nat x₁ ∷ e) s = yes (c , nat _ ∷ e , s , MUL x x₁)
step (MUL ∷ c) (nat x ∷ bool x₁ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (MUL ∷ c) (bool x ∷ e) s = no (λ { (c' , e' , s' , ()) })

step (SUB ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (SUB ∷ c) (nat x ∷ []) s = no (λ { (c' , e' , s' , ()) })
step (SUB ∷ c) (nat x ∷ nat x₁ ∷ e) s = yes (c , nat _ ∷ e , s , SUB x x₁)
step (SUB ∷ c) (nat x ∷ bool x₁ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (SUB ∷ c) (bool x ∷ e) s = no (λ { (c' , e' , s' , ()) })

step (TRUE ∷ c) e s = yes (c  , bool true ∷ e , s , TRUE)
step (FALSE ∷ c) e s = yes (c , bool false ∷ e , s , FALSE)

step (EQ ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (EQ ∷ c) (nat x ∷ []) s = no (λ { (c' , e' , s' , ()) })
step (EQ ∷ c) (nat x ∷ nat x₁ ∷ e) s = yes (c , bool ⌊ x ≡⁇ x₁ ⌋ ∷ e , s , EQ x x₁)
step (EQ ∷ c) (nat x ∷ bool x₁ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (EQ ∷ c) (bool x ∷ e) s = no (λ { (c' , e' , s' , ()) })

step (LTE ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (LTE ∷ c) (nat x ∷ []) s = no (λ { (c' , e' , s' , ()) })
step (LTE ∷ c) (nat x ∷ nat x₁ ∷ e) s = yes (c , bool ⌊ x ≤⁇ x₁ ⌋ ∷ e , s , LTE x x₁)
step (LTE ∷ c) (nat x ∷ bool x₁ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (LTE ∷ c) (bool x ∷ e) s = no (λ { (c' , e' , s' , ()) })

step (LT ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (LT ∷ c) (nat x ∷ []) s = no (λ { (c' , e' , s' , ()) })
step (LT ∷ c) (nat x ∷ nat x₁ ∷ e) s = yes (c , bool ⌊ x <⁇ x₁ ⌋ ∷ e , s , LT x x₁)
step (LT ∷ c) (nat x ∷ bool x₁ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (LT ∷ c) (bool x ∷ e) s = no (λ { (c' , e' , s' , ()) })

step (AND ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (AND ∷ c) (nat x ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (AND ∷ c) (bool x ∷ []) s = no (λ { (c' , e' , s' , ()) })
step (AND ∷ c) (bool x ∷ nat x₁ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (AND ∷ c) (bool x ∷ bool x₁ ∷ e) s = yes (c , bool (x ∧ x₁) ∷ e , s , AND x x₁)

step (NOT ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (NOT ∷ c) (nat x ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (NOT ∷ c) (bool x ∷ e) s = yes (c , bool _ ∷ e , s , NOT x)
step (NOOP ∷ c) e s = yes (c , e , s , NOOP)

step (BRANCH x x₁ ∷ c) [] s = no (λ { (c' , e' , s' , ()) })
step (BRANCH x x₁ ∷ c) (nat x₂ ∷ e) s = no (λ { (c' , e' , s' , ()) })
step (BRANCH x x₁ ∷ c) (bool true ∷ e) s = yes (x ++ c , e , s , BRANCH)
step (BRANCH x x₁ ∷ c) (bool false ∷ e) s = yes (x₁ ++ c , e , s , BRANCH)

step (LOOP x x₁ ∷ c) e s = yes (x ++ BRANCH (x₁ ++ LOOP x x₁ ∷ []) (NOOP ∷ []) ∷ c , e , s , LOOP)

steps : ∀ {n} → Code n → Stack → State n → ℕ → (Code n × Stack × State n)
steps c e s zero = c , e , s
steps c e s (suc n) with step c e s
... | yes (c' , e' , s' , p) = steps c' e' s' n
... | no _ = c , e , s

trace : ∀ {n} → Code n → Stack → State n → ℕ → List (Code n × Stack × State n)
trace c e s zero = []
trace c e s (suc n) with step c e s
... | yes  (c' , e' , s' , p) = (c , e , s) ∷ trace c' e' s' n
... | no _ = (c , e , s) ∷ []

unfold :
  ∀ {n} c e (s : State n) → ℕ → Maybe (∃₂ λ c' e' → ∃ λ s' → ⟨ c , e , s ⟩▷*⟨ c' , e' , s' ⟩)
unfold [] e s n₁ = just ([] , e , s , done)
unfold (x ∷ c) e s zero = nothing
unfold (x ∷ c) e s (suc n) with step (x ∷ c) e s
... | no ¬p = just (x ∷ c , e , s , stuck (λ c' e' s' z → ¬p (c' , e' , s' , z)))
... | yes (c' , e' , s' , p) with unfold c' e' s' n
... | nothing = nothing
... | just (c'' , e'' , s'' , seq) = just (c'' , e'' , s'' , p ∷ seq)


{-# OPTIONS --rewriting #-}
{-# OPTIONS --no-fast-reduce #-}

open import Agda.Builtin.Equality
{-# BUILTIN REWRITE _≡_ #-}

data A : Set where
  a b : A

postulate rew : a ≡ b
{-# REWRITE rew #-}

test : a ≡ b
test = refl


module SingleSorted.Context where

-- An attempt to define more structured context
-- that directly support the cartesian structure

data Context : Set where
  ctx-empty : Context
  ctx-slot : Context
  ctx-concat : Context → Context → Context

-- the variables in a context
data var : Context → Set where
  var-var  : var ctx-slot
  var-inl  : ∀ {Γ Δ} → var Γ → var (ctx-concat Γ Δ)
  var-inr  : ∀ {Γ Δ} → var Δ → var (ctx-concat Γ Δ)

-- It is absurd to have a variable in the empty context
ctx-empty-absurd : ∀ {ℓ} {A : Set ℓ} → var ctx-empty → A
ctx-empty-absurd ()


module Golden.Constructor where

open import Agda.Builtin.Nat

f : (Nat -> Nat) -> Nat
f g = g zero

fsuc = suc
fzero = zero

one = f suc
a = fsuc fzero


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

module Categories.CategorySolver where

open import Level
open import Categories.Category
open import Categories.Functor hiding (equiv) renaming (id to idF; _≡_ to _≡F_; _∘_ to _∘F_; ∘-resp-≡ to ∘F-resp-≡F)
open import Categories.NaturalTransformation hiding (equiv) renaming (id to idT; _≡_ to _≡T_)

{- We need a way to force the universe levels of two categories to be
   the same, to hack together a reified morphism type.  These lift
   operations let us do this in reification. -}

liftCategory : ∀ {o ℓ e o′ ℓ′ e′} (C : Category o ℓ e) → Category (o ⊔ o′) (ℓ ⊔ ℓ′) (e ⊔ e′)
liftCategory {o} {ℓ} {e} {o′} {ℓ′} {e′} C = record {
                                              Obj = Lift {ℓ = o′} (Category.Obj C);
                                              _⇒_ = λ s d → Lift {ℓ = ℓ′} ((lower s) ⇒ (lower d));
                                              _≡_ = λ m₀ m₁ → Lift {ℓ = e′} (lower m₀ ≡ lower m₁);
                                              id = lift id;
                                              _∘_ = λ m₀ m₁ → lift (lower m₀ ∘ lower m₁);
                                              assoc = λ {A} {B} {C₁} {D} {f} {g} {h} → lift C.assoc;
                                              identityˡ = λ {A} {B} {f} → lift C.identityˡ;
                                              identityʳ = λ {A} {B} {f} → lift C.identityʳ;
                                              equiv = record { refl = λ {x} → lift Equiv.refl
                                                             ; sym = λ x → lift (Equiv.sym (lower x))
                                                             ; trans = λ x y → lift (Equiv.trans (lower x) (lower y)) };
                                              ∘-resp-≡ = λ x y → lift (∘-resp-≡ (lower x) (lower y)) }
             where
               module C = Category C
               open C

liftFunctor : ∀ {o₀ ℓ₀ e₀ o′₀ ℓ′₀ e′₀ o₁ ℓ₁ e₁ o′₁ ℓ′₁ e′₁} {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁}
              → Functor C D → Functor (liftCategory {o′ = o′₀} {ℓ′₀} {e′₀} C) (liftCategory {o′ = o′₁} {ℓ′₁} {e′₁} D)
liftFunctor {o₀} {ℓ₀} {e₀} {o′₀} {ℓ′₀} {e′₀} {o₁} {ℓ₁} {e₁} {o′₁} {ℓ′₁} {e′₁} {C} {D} F =
  record {
    F₀ = λ x → lift (F.F₀ (lower x));
    F₁ = λ m → lift (F.F₁ (lower m));
    identity = lift F.identity;
    homomorphism = lift F.homomorphism;
    F-resp-≡ = λ H → lift (F.F-resp-≡ (lower H)) }
  where
    module C = Category C
    module D = Category D
    module ↑C = Category (liftCategory {o′ = o′₀} {ℓ′₀} {e′₀} C)
    module ↑D = Category (liftCategory {o′ = o′₁} {ℓ′₁} {e′₁} D)
    module F = Functor F

mutual
  data ReifiedMorphismHelper {o ℓ e} {C : Category o ℓ e} : Category.Obj C → Category.Obj C → Set (suc (o ⊔ ℓ ⊔ e)) where
    ∥_₁∥₀_ : ∀ {D : Category o ℓ e} → (F : Functor D C) → {s d : Category.Obj D} → (m : ReifiedMorphism {C = D} s d) → ReifiedMorphismHelper (Functor.F₀ F s) (Functor.F₀ F d)

  data ReifiedMorphism {o ℓ e} {C : Category o ℓ e} : Category.Obj C → Category.Obj C → Set (suc (o ⊔ ℓ ⊔ e)) where
    _∥∘∥_ : ∀ {s d d′ : Category.Obj C} → (m2 : ReifiedMorphism {C = C} d d′) → (m1 : ReifiedMorphism {C = C} s d) → ReifiedMorphism s d′
    ∥id∥ : ∀ {x : Category.Obj C} → ReifiedMorphism x x
    ∥_₁∥₁ : ∀ {s d : Category.Obj C} (m : ReifiedMorphismHelper {C = C} s d) → ReifiedMorphism s d
    ∥_∥ : ∀ {s d : Category.Obj C} → (m : Category._⇒_ C s d) → ReifiedMorphism s d

pattern ∥F₁∥m D F s d F₀s F₀d m = ∥_₁∥₁ {F₀s} {F₀d} (∥_₁∥₀_ {D} F {s} {d} m)
pattern ∥_₁∥_ F m = ∥ (∥ F ₁∥₀ m) ₁∥₁

⟱ : ∀ {o ℓ e} → {C : Category o ℓ e} → {s d : Category.Obj C} → ReifiedMorphism {C = C} s d → Category._⇒_ C s d
⟱ {C = C} (∥m₂∥ ∥∘∥ ∥m₁∥) = ⟱ ∥m₂∥ ∘ ⟱ ∥m₁∥
  where open Category C
⟱ {C = C} ∥id∥ = Category.id C
⟱ (∥ F ₁∥ ∥m∥) = Functor.F₁ F (⟱ ∥m∥)
⟱ ∥ m ∥ = m

record ReifiedMorphismOf {o ℓ e} {C : Category o ℓ e} {s d : Category.Obj C} (m : Category._⇒_ C s d) : Set (suc o ⊔ suc ℓ ⊔ suc e) where
  constructor reify
  field
    reified : ReifiedMorphism {C = C} s d
    .reified≡ : Category._≡_ C (⟱ {C = C} reified) m

ReifiedMorphismSimplify : ∀ {o ℓ e} → {C : Category o ℓ e} → {s d : Category.Obj C}
                            → (m : ReifiedMorphism {C = C} s d) → ReifiedMorphismOf {C = C} (⟱ m)
ReifiedMorphismSimplify {C = C} ∥ m ∥ = reify ∥ m ∥ (Category.Equiv.refl C)
ReifiedMorphismSimplify {C = C} ∥id∥  = reify ∥id∥ (Category.Equiv.refl C)
ReifiedMorphismSimplify {C = C} (∥m₀∥ ∥∘∥ ∥m₁∥) = ReifiedMorphismSimplify∥∘∥ {∥m₀∥ = ∥m₀∥} {∥m₁∥} (ReifiedMorphismSimplify ∥m₀∥) (ReifiedMorphismSimplify ∥m₁∥)
  where
    module C = Category C
    open C.HomReasoning

    ReifiedMorphismSimplify∥∘∥ : ∀ {s d d′ : C.Obj} → {∥m₀∥ : ReifiedMorphism {C = C} d d′} → {∥m₁∥ : ReifiedMorphism {C = C} s d}
                                 → ReifiedMorphismOf {C = C} (⟱ ∥m₀∥)
                                 → ReifiedMorphismOf {C = C} (⟱ ∥m₁∥)
                                 → ReifiedMorphismOf {C = C} (⟱ (∥m₀∥ ∥∘∥ ∥m₁∥))
    ReifiedMorphismSimplify∥∘∥ {∥m₀∥ = ∥m₀∥} {∥m₁∥} (reify ∥id∥ id≡m₀) (reify ∥m₁∥′ m₁′≡m₁) =
      reify ∥m₁∥′ (begin
                   ⟱ ∥m₁∥′
                 ↑⟨ C.identityˡ ⟩
                   C.id C.∘ ⟱ ∥m₁∥′
                 ↓⟨ C.∘-resp-≡ id≡m₀ m₁′≡m₁ ⟩
                   ⟱ (∥m₀∥ ∥∘∥ ∥m₁∥)
                 ∎)
    ReifiedMorphismSimplify∥∘∥ {∥m₀∥ = ∥m₀∥} {∥m₁∥} (reify ∥m₀∥′ m₀′≡m₀) (reify ∥id∥ id≡m₁) =
      reify ∥m₀∥′ (begin
                   ⟱ ∥m₀∥′
                 ↑⟨ C.identityʳ ⟩
                   ⟱ ∥m₀∥′ C.∘ C.id
                 ↓⟨ C.∘-resp-≡ m₀′≡m₀ id≡m₁ ⟩
                   ⟱ (∥m₀∥ ∥∘∥ ∥m₁∥)
                 ∎)
    ReifiedMorphismSimplify∥∘∥ {∥m₀∥ = ∥m₀∥} {∥m₁∥} (reify (∥m₀₀∥ ∥∘∥ ∥m₀₁∥) m₀₀∘m₀₁≡m₀) (reify ∥m₁∥′ m₁′≡m₁) =
      reify (∥m₀₀∥ ∥∘∥ (∥m₀₁∥ ∥∘∥ ∥m₁∥′)) (begin
                                     ⟱ (∥m₀₀∥ ∥∘∥ (∥m₀₁∥ ∥∘∥ ∥m₁∥′))
                                   ↑⟨ C.assoc ⟩
                                     (⟱ ∥m₀₀∥ C.∘ ⟱ ∥m₀₁∥) C.∘ ⟱ ∥m₁∥′
                                   ↓⟨ C.∘-resp-≡ m₀₀∘m₀₁≡m₀ m₁′≡m₁ ⟩
                                     ⟱ (∥m₀∥ ∥∘∥ ∥m₁∥)
                                   ∎)
    ReifiedMorphismSimplify∥∘∥ (reify ∥m₀∥′ m₀′≡m₀) (reify ∥m₁∥′ m₁′≡m₁) = reify (∥m₀∥′ ∥∘∥ ∥m₁∥′) (C.∘-resp-≡ m₀′≡m₀ m₁′≡m₁)
ReifiedMorphismSimplify {C = C} (∥F₁∥m D F s d ._ ._ ∥m∥) = ReifiedMorphismSimplifyF₀m {s = s} {d} {∥m∥}
                                                              (ReifiedMorphismSimplify ∥m∥)
  where
    module C = Category C
    module D = Category D
    module F = Functor F
    open C.HomReasoning

    ReifiedMorphismSimplifyF₀m : ∀ {s d : D.Obj} → {∥m∥ : ReifiedMorphism {C = D} s d}
                                   → ReifiedMorphismOf {C = D} (⟱ ∥m∥)
                                   → ReifiedMorphismOf {C = C} (F.F₁ (⟱ ∥m∥))
    ReifiedMorphismSimplifyF₀m {∥m∥ = ∥m∥} (reify ∥id∥ id≡m) =
      reify ∥id∥ (begin
                   C.id
                 ↑⟨ F.identity ⟩
                   F.F₁ D.id
                 ↓⟨ F.F-resp-≡ id≡m ⟩
                   F.F₁ (⟱ ∥m∥)
                 ∎)
    ReifiedMorphismSimplifyF₀m {∥m∥ = ∥m∥} (reify (∥m₀∥ ∥∘∥ ∥m₁∥) m₀∘m₁≡m) =
      reify (∥ F ₁∥ ∥m₀∥ ∥∘∥ ∥ F ₁∥ ∥m₁∥) (begin
                                       F.F₁ (⟱ ∥m₀∥) C.∘ F.F₁ (⟱ ∥m₁∥)
                                     ↑⟨ F.homomorphism ⟩
                                       F.F₁ (⟱ ∥m₀∥ D.∘ ⟱ ∥m₁∥)
                                     ↓⟨ F.F-resp-≡ m₀∘m₁≡m ⟩
                                       F.F₁ (⟱ ∥m∥)
                                     ∎)
    ReifiedMorphismSimplifyF₀m {∥m∥ = ∥m∥} (reify ∥m∥′ m′≡m) = reify (∥ F ₁∥ ∥m∥′) (F.F-resp-≡ m′≡m)

.removeIdentities : ∀ {o ℓ e} {C : Category o ℓ e} {s d : Category.Obj C} {m : Category._⇒_ C s d}
                    → (∥m∥ : ReifiedMorphismOf {C = C} m)
                     → Category._≡_ C (⟱ (ReifiedMorphismOf.reified (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m∥)))) m
removeIdentities {C = C} {m = m} ∥m∥ = begin
                                       ⟱
                                         (ReifiedMorphismOf.reified
                                          (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m∥)))
                                      ↓⟨ ReifiedMorphismOf.reified≡ (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m∥)) ⟩
                                        ⟱ (ReifiedMorphismOf.reified ∥m∥)
                                      ↓⟨ ReifiedMorphismOf.reified≡ ∥m∥ ⟩
                                        m
                                      ∎
  where
    module C = Category C
    open C.HomReasoning

.removeIdentities≡ : ∀ {o ℓ e} {C : Category o ℓ e} {s d : Category.Obj C} {m₀ m₁ : Category._⇒_ C s d}
                     → (∥m₀∥ : ReifiedMorphismOf {C = C} m₀)
                     → (∥m₁∥ : ReifiedMorphismOf {C = C} m₁)
                     → Category._≡_ C (⟱ (ReifiedMorphismOf.reified (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m₀∥))))
                                      (⟱ (ReifiedMorphismOf.reified (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m₁∥))))
                     → Category._≡_ C m₀ m₁
removeIdentities≡ {C = C} {m₀ = m₀} {m₁} ∥m₀∥ ∥m₁∥ m₀≡m₁ =
  begin
    m₀
  ↑⟨ ReifiedMorphismOf.reified≡ ∥m₀∥ ⟩
    ⟱ (ReifiedMorphismOf.reified ∥m₀∥)
  ↑⟨ ReifiedMorphismOf.reified≡
       (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m₀∥)) ⟩
    ⟱
      (ReifiedMorphismOf.reified
       (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m₀∥)))
  ↓⟨ m₀≡m₁ ⟩
    ⟱
      (ReifiedMorphismOf.reified
       (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m₁∥)))
  ↓⟨ ReifiedMorphismOf.reified≡
       (ReifiedMorphismSimplify (ReifiedMorphismOf.reified ∥m₁∥)) ⟩
    ⟱ (ReifiedMorphismOf.reified ∥m₁∥)
  ↓⟨ ReifiedMorphismOf.reified≡ ∥m₁∥ ⟩
    m₁
  ∎
  where
    module C = Category C
    open C.HomReasoning


module OTT.Prelude where

open import Level
  renaming (Level to MetaLevel; zero to lzeroₘ; suc to lsucₘ; _⊔_ to _⊔ₘ_) using () public
open import Function public
open import Relation.Binary.PropositionalEquality as P using (_≡_)
  renaming (refl to prefl; trans to ptrans; subst to psubst; cong to pcong; cong₂ to pcong₂) public
open import Data.Empty public
open import Data.Nat.Base hiding (_⊔_; _≟_; erase) public
open import Data.Maybe.Base using (Maybe; nothing; just) public
open import Data.Product hiding (,_) renaming (map to pmap) public

open import OTT.Lib.Heteroindexed public
open import OTT.Lib.Decidable public

open import Relation.Nullary
open import Relation.Binary

infix 4  ,_

pattern ,_ y = _ , y

record ⊤ {α} : Set α where
  constructor tt

⊤₀ : Set
⊤₀ = ⊤

instance
  iprefl : ∀ {α} {A : Set α} {x : A} -> x ≡ x
  iprefl = prefl

  ,-inst : ∀ {α β} {A : Set α} {B : A -> Set β} {{x : A}} {{y : B x}} -> Σ A B
  ,-inst {{x}} {{y}} = x , y

pright : ∀ {α} {A : Set α} {x y z : A} -> x ≡ y -> x ≡ z -> y ≡ z
pright prefl prefl = prefl

hpcong₂ : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : Set γ} {x₁ x₂} {y₁ : B x₁} {y₂ : B x₂}
        -> (f : ∀ x -> B x -> C) -> (q : x₁ ≡ x₂) -> psubst B q y₁ ≡ y₂ -> f x₁ y₁ ≡ f x₂ y₂
hpcong₂ f prefl prefl = prefl

record Apply {α β} {A : Set α} (B : A -> Set β) x : Set β where
  constructor tag
  field detag : B x
open Apply public

tag-inj : ∀ {α β} {A : Set α} {B : A -> Set β} {x} {y₁ y₂ : B x}
        -> tag {B = B} y₁ ≡ tag y₂ -> y₁ ≡ y₂
tag-inj prefl = prefl

data Match {ι α} {I : Set ι} {i} (A : I -> Set α) (x : A i) : Set (ι ⊔ₘ α) where
  matched : ∀ {j} -> (x′ : A j) -> [ A ] x ≅ x′ -> Match A x

match : ∀ {ι α} {I : Set ι} {i} -> (A : I -> Set α) -> (x : A i) -> Match A x
match A x = matched x irefl

data IMatch {ι α β} {I : Set ι} {i} (A : I -> Set α) {x : A i}
            (B : ∀ {i} -> A i -> Set β) (y : B x) : Set (ι ⊔ₘ α ⊔ₘ β) where
  imatched : ∀ {i} {x : A i} -> (y′ : B x) -> [ A ][ B ] y ≅ y′ -> IMatch A B y

imatch : ∀ {ι α β} {I : Set ι} {i}
       -> (A : I -> Set α) {x : A i} -> (B : ∀ {i} -> A i -> Set β) -> (y : B x) -> IMatch A B y
imatch A B y = imatched y iirefl

module _ {α} {A : Set α} where
  open import Relation.Nullary.Decidable
  open import Data.Maybe

  toPropEq : {a b : Maybe A} -> a ≡ b -> Eq _≡_ a b
  toPropEq {a = nothing} prefl = nothing
  toPropEq {a = just _ } prefl = just prefl

  fromPropEq : {a b : Maybe A} -> Eq _≡_ a b -> a ≡ b
  fromPropEq (just q) = pcong just q
  fromPropEq  nothing = prefl

  fromDecPropEq : {a b : Maybe A} -> Dec (Eq _≡_ a b) -> Dec (a ≡ b)
  fromDecPropEq = map′ fromPropEq toPropEq where

  decideMaybe : Decidable (_≡_ {A = A}) -> Decidable (_≡_ {A = Maybe A})
  decideMaybe D a b = fromDecPropEq (a ≟ b) where
    open DecSetoid (decSetoid (P.decSetoid D))

Enum : ℕ -> Set
Enum  0      = ⊥
Enum  1      = ⊤
Enum (suc n) = Maybe (Enum n)

decEnum : ∀ n -> Decidable (_≡_ {A = Enum n})
decEnum  0            () ()
decEnum  1            tt tt = yes prefl
decEnum (suc (suc n)) e₁ e₂ = decideMaybe (decEnum (suc n)) e₁ e₂


-- Andreas, 2016-05-13 Issue 1973 reported by Nisse
-- Problems with parameters to overloaded projections

-- {-# OPTIONS -v tc.proj.amb:100 #-}
-- {-# OPTIONS -v tc.deftype:100 #-}

record R₁ : Set₁ where
  field
    f : Set

open R₁ public

postulate
  F : ∀ {a} → Set a → Set a

module M (_ : Set₁) where

  record R₂ a (G : Set a → Set a) (A : Set a) : Set a where
    field
      f : G A

  open R₂ public

open module N = M Set using (f)

works : ∀ a (A : Set a) → N.R₂ a F A → F A
works a A x = N.R₂.f x

-- WAS:
-- a F !=< F A of type Set
-- when checking that the expression f x has type F A

ill-formed-term-in-error-message : ∀ a (A : Set a) → N.R₂ a F A → F A
ill-formed-term-in-error-message a A x = f x

-- What Agda did here is to copy parameters from the reduced record type
--   M.R₂ Set a F A
-- to the unreduced projection
--   N.R₂.f
-- The number of projections (3) was queried from N.R₂.f, but the projections
-- were taken from  M.R₂ Set a F A.
-- Now, take the original version of the projection,
--   M.R₂.f
-- which accepts 4 parameters, and these are the ones provided by  M.R₂ Set a F A.

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

internal-error : (A : Set) → N.R₂ _ F A → F A
internal-error A x = f x

-- should work now.


module Issue261 where

postulate
  List : Set → Set
  nil : ∀ A → List A
  Nat : Set

works-now : List Nat
works-now with nil _
... | xs = xs


module Integer.Signed where

open import Data.Empty as ⊥
open import Data.Product as Σ
open import Data.Product.Relation.Pointwise.NonDependent
open import Data.Sum as ⊎
open import Data.Unit as ⊤
open import Equality
open import Function
open import Natural as ℕ
open import Quotient as /
open import Relation.Binary
open import Syntax

open Equality.FunctionProperties

⟦ℤ⟧ = ℕ ⊎ ℕ
⟦ℤ²⟧ = ⟦ℤ⟧ × ⟦ℤ⟧

infix 10 +1*_ -1*_
pattern +1*_ x = inj₁ x
pattern -1*_ x = inj₂ x

infix 1 _≈_
_≈_ : ⟦ℤ⟧ → ⟦ℤ⟧ → Set
+1* x ≈ +1* y = x ≡ y
+1* x ≈ -1* y = x ≡ 0 × y ≡ 0
-1* x ≈ +1* y = x ≡ 0 × y ≡ 0
-1* x ≈ -1* y = x ≡ y

≈-refl : ∀ {x} → x ≈ x
≈-refl {+1* x} = refl
≈-refl { -1* x} = refl

≈-sym : ∀ {x y} → x ≈ y → y ≈ x
≈-sym {+1* x} {+1* y} = sym
≈-sym {+1* x} { -1* y} = Σ.swap
≈-sym { -1* x} {+1* y} = Σ.swap
≈-sym { -1* x} { -1* y} = sym

≈-trans : ∀ {x y z} → x ≈ y → y ≈ z → x ≈ z
≈-trans {+1* x} {+1* y} {+1* z} p q = compPath p q
≈-trans {+1* x} {+1* y} { -1* z} p (q , r) = p ≫ q , r
≈-trans {+1* x} { -1* y} {+1* z} (p , q) (r , s) = p ≫ sym s
≈-trans {+1* x} { -1* y} { -1* z} (p , q) r = p , sym r ≫ q
≈-trans { -1* x} {+1* y} {+1* z} (p , q) r = p , sym r ≫ q
≈-trans { -1* x} {+1* y} { -1* z} (p , q) (r , s) = p ≫ sym s
≈-trans { -1* x} { -1* y} {+1* z} p (q , r) = p ≫ q , r
≈-trans { -1* x} { -1* y} { -1* z} p q = compPath p q

ℤ = ⟦ℤ⟧ / _≈_
ℤ² = ⟦ℤ²⟧ / Pointwise _≈_ _≈_

instance
  ⟦ℤ⟧-Number : Number ⟦ℤ⟧
  ⟦ℤ⟧-Number = record { Constraint = λ _ → ⊤ ; fromNat = λ n → +1* n }

  ℤ-Number : Number ℤ
  ℤ-Number = record { Constraint = λ _ → ⊤ ; fromNat = λ n → ⟦ fromNat n ⟧ }

  ⟦ℤ⟧-Negative : Negative ⟦ℤ⟧
  ⟦ℤ⟧-Negative = record { Constraint = λ _ → ⊤ ; fromNeg = λ n → -1* n }

  ℤ-Negative : Negative ℤ
  ℤ-Negative = record { Constraint = λ _ → ⊤ ; fromNeg = λ n → ⟦ fromNeg n ⟧ }

⟦negate⟧ : ⟦ℤ⟧ → ⟦ℤ⟧
⟦negate⟧ (+1* n) = -1* n
⟦negate⟧ (-1* n) = +1* n

negate : ℤ → ℤ
negate =
  ⟦negate⟧ // λ where
    (+1* x) (+1* y) → id
    (+1* x) (-1* y) → id
    (-1* x) (+1* y) → id
    (-1* x) (-1* y) → id

ℕ-minus : ℕ → ℕ → ⟦ℤ⟧
ℕ-minus zero n = -1* n
ℕ-minus m zero = +1* m
ℕ-minus (suc m) (suc n) = ℕ-minus m n

instance
  ℕ-minus-syntax : minus-syntax-simple ℕ ℕ ⟦ℤ⟧
  ℕ-minus-syntax = λ where ._-_ → ℕ-minus

ℕ-minus-identityˡ : ∀ a → ℕ-minus 0 a ≈ -1* a
ℕ-minus-identityˡ a = refl

ℕ-minus-identityʳ : ∀ a → ℕ-minus a 0 ≈ +1* a
ℕ-minus-identityʳ zero = refl , refl
ℕ-minus-identityʳ (suc a) = refl

⟦plus⟧ : ⟦ℤ²⟧ → ⟦ℤ⟧
⟦plus⟧ (+1* a , +1* b) = +1* (a + b)
⟦plus⟧ (+1* a , -1* b) = a - b
⟦plus⟧ (-1* a , +1* b) = b - a
⟦plus⟧ (-1* a , -1* b) = -1* (a + b)

plus : ℤ² → ℤ
plus =
  ⟦plus⟧ // λ where
    (+1* a , +1* b) (+1* c , +1* d) (p , q) → cong₂ _+_ p q
    (+1* a , +1* b) (+1* c , -1* d) (p , (q , r)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          ≈-trans
            (⟨ ℕ.+-identityʳ a ⟩)
            (≈-sym (ℕ-minus-identityʳ a))
    (+1* a , +1* b) (-1* c , +1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          ≈-sym (ℕ-minus-identityʳ b)
    (+1* a , +1* b) (-1* c , -1* d) ((p , q) , (r , s)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ ,′ ⟪ s ⟫ of λ where
        (♥ , ♥ , ♥ , ♥) →
          refl , refl
    (+1* a , -1* b) (+1* c , +1* d) (p , (q , r)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          ≈-trans {ℕ-minus a 0} {+1* a} {+1* (a + 0)}
            (ℕ-minus-identityʳ a)
            (sym ⟨ ℕ.+-identityʳ a ⟩)
    (+1* a , -1* b) (+1* c , -1* d) (p , q) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) →
          ≈-refl
    (+1* a , -1* b) (-1* c , +1* d) ((p , q) , (r , s)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ ,′ ⟪ s ⟫ of λ where
        (♥ , ♥ , ♥ , ♥) →
          refl
    (+1* a , -1* b) (-1* c , -1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          refl
    (-1* a , +1* b) (+1* c , +1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          ℕ-minus-identityʳ b
    (-1* a , +1* b) (+1* c , -1* d) ((p , q) , (r , s)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ ,′ ⟪ s ⟫ of λ where
        (♥ , ♥ , ♥ , ♥) →
          refl
    (-1* a , +1* b) (-1* c , +1* d) (p , q) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) →
          ≈-refl
    (-1* a , +1* b) (-1* c , -1* d) (p , (q , r)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          sym ⟨ ℕ.+-identityʳ a ⟩
    (-1* a , -1* b) (+1* c , +1* d) ((p , q) , (r , s)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ ,′ ⟪ s ⟫ of λ where
        (♥ , ♥ , ♥ , ♥) →
          refl , refl
    (-1* a , -1* b) (+1* c , -1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          refl
    (-1* a , -1* b) (-1* c , +1* d) (p , (q , r)) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥ , ♥) →
          ⟨ ℕ.+-identityʳ a ⟩
    (-1* a , -1* b) (-1* c , -1* d) (p , q) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) →
          refl

⟦times⟧ : ⟦ℤ²⟧ → ⟦ℤ⟧
⟦times⟧ (+1* a , +1* b) = +1* (a * b)
⟦times⟧ (+1* a , -1* b) = -1* (a * b)
⟦times⟧ (-1* a , +1* b) = -1* (a * b)
⟦times⟧ (-1* a , -1* b) = +1* (a * b)

times : ℤ² → ℤ
times =
  ⟦times⟧ // λ where
    (+1* a , +1* b) (+1* c , +1* d) (p , q) → cong₂ _*_ p q
    (+1* a , -1* b) (+1* c , -1* d) (p , q) → cong₂ _*_ p q
    (-1* a , +1* b) (-1* c , +1* d) (p , q) → cong₂ _*_ p q
    (-1* a , -1* b) (-1* c , -1* d) (p , q) → cong₂ _*_ p q
    (+1* a , +1* b) (+1* c , -1* d) (p , q , r) →
      case ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥) → ⟨ *-zeroʳ a ⟩ , ⟨ *-zeroʳ c ⟩
    (+1* a , -1* b) (+1* c , +1* d) (p , (q , r)) →
      case ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥) → ⟨ *-zeroʳ a ⟩ , ⟨ *-zeroʳ c ⟩
    (-1* a , +1* b) (-1* c , -1* d) (p , (q , r)) →
      case ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥) → ⟨ *-zeroʳ a ⟩ , ⟨ *-zeroʳ c ⟩
    (-1* a , -1* b) (-1* c , +1* d) (p , (q , r)) →
      case ⟪ q ⟫ ,′ ⟪ r ⟫ of λ where
        (♥ , ♥) → ⟨ *-zeroʳ a ⟩ , ⟨ *-zeroʳ c ⟩
    (+1* a , +1* b) (-1* c , +1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl , refl
    (+1* a , -1* b) (-1* c , -1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl , refl
    (-1* a , +1* b) (+1* c , +1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl , refl
    (-1* a , -1* b) (+1* c , -1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl , refl
    (+1* a , +1* b) (-1* c , -1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl
    (+1* a , -1* b) (-1* c , +1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl
    (-1* a , +1* b) (+1* c , -1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl
    (-1* a , -1* b) (+1* c , +1* d) ((p , q) , r) →
      case ⟪ p ⟫ ,′ ⟪ q ⟫ of λ where
        (♥ , ♥) → refl

instance
  ℤ-plus-syntax : plus-syntax-simple ℤ ℤ ℤ
  ℤ-plus-syntax = λ where ._+_ → /.uncurry ≈-refl ≈-refl plus

  ℤ-minus-syntax : minus-syntax-simple ℤ ℤ ℤ
  ℤ-minus-syntax = λ where ._-_ x y → x + negate y

  ℤ-times-syntax : times-syntax-simple ℤ ℤ ℤ
  ℤ-times-syntax = λ where ._*_ → /.uncurry ≈-refl ≈-refl times


module Tactic.Nat.Auto.Lemmas where

open import Prelude
open import Tactic.Nat.NF
open import Tactic.Nat.Exp
open import Container.Bag
open import Prelude.Nat.Properties

map++ : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) (xs ys : List A) →
          map f (xs ++ ys) ≡ map f xs ++ map f ys
map++ f [] ys = refl
map++ f (x ∷ xs) ys rewrite map++ f xs ys = refl

prod++ : (xs ys : List Nat) → productR (xs ++ ys) ≡ productR xs * productR ys
prod++ [] ys = sym (add-zero-r (productR ys))
prod++ (x ∷ xs) ys rewrite prod++ xs ys = mul-assoc x _ _

private
  shuffle₁ : ∀ a b c d → a + ((b + c) + d) ≡ b + c + (a + d)
  shuffle₁ a b c d rewrite add-assoc a (b + c) d
                         | add-commute a (b + c)
                         | add-assoc (b + c) a d
                         = refl

  shuffle₂ : ∀ a b c d → a + b + (c + d) ≡ a + c + (b + d)
  shuffle₂ a b c d rewrite add-assoc (a + b) c d
                         | sym (add-assoc a b c)
                         | add-commute b c
                         | add-assoc a c b
                         | add-assoc (a + c) b d
                         = refl

  shuffle₃ : ∀ a b c d → (a * b) * (c * d) ≡ (a * c) * (b * d)
  shuffle₃ a b c d rewrite mul-assoc (a * b) c d
                         | sym (mul-assoc a b c)
                         | mul-commute b c
                         | mul-assoc a c b
                         | mul-assoc (a * c) b d = refl

  shuffle₄ : ∀ a b c d → a * (b * c * d) ≡ b * c * (a * d)
  shuffle₄ a b c d rewrite mul-assoc a (b * c) d
                         | mul-commute a (b * c)
                         | mul-assoc (b * c) a d
                         = refl

module _ {Atom : Set} {{_ : Ord Atom}} where
  ⟨+⟩-sound : ∀ v₁ v₂ (ρ : Env Atom) → ⟦ v₁ +nf v₂ ⟧n ρ ≡ ⟦ v₁ ⟧n ρ + ⟦ v₂ ⟧n ρ
  ⟨+⟩-sound [] []               ρ = refl
  ⟨+⟩-sound [] (_ ∷ _)          ρ = refl
  ⟨+⟩-sound (t ∷ v₁)  []        ρ = sym (add-zero-r _)
  ⟨+⟩-sound ((i , t₁) ∷ v₁) ((j , t₂) ∷ v₂) ρ with compare t₁ t₂
  ... | less _ rewrite ⟨+⟩-sound v₁ ((j , t₂) ∷ v₂) ρ
                     = add-assoc (i * productR (map ρ t₁)) _ _
  ... | equal eq rewrite eq | ⟨+⟩-sound v₁ v₂ ρ
                       | mul-distr-r i j (productR (map ρ t₂))
                       = shuffle₂ (⟦ i , t₂ ⟧t ρ) (⟦ j , t₂ ⟧t ρ) _ _
  ... | greater _ rewrite ⟨+⟩-sound ((i , t₁) ∷ v₁) v₂ ρ
                        = shuffle₁ (⟦ j , t₂ ⟧t ρ) (⟦ i , t₁ ⟧t ρ) _ _

  map-merge : ∀ x y (ρ : Env Atom) → productR (map ρ (merge x y)) ≡ productR (map ρ x) * productR (map ρ y)
  map-merge [] [] ρ = refl
  map-merge [] (x ∷ xs) ρ = sym (add-zero-r (productR (ρ x ∷ map ρ xs)))
  map-merge (x ∷ xs) [] ρ = sym (mul-one-r _)
  map-merge (x ∷ xs) (y ∷ ys) ρ with x <? y
  ... | true  rewrite map-merge xs (y ∷ ys) ρ = mul-assoc (ρ x) _ _
  ... | false rewrite map-merge (x ∷ xs) ys ρ = shuffle₄ (ρ y) (ρ x) _ _

  mulTm-sound : ∀ t t′ (ρ : Env Atom) →
                  ⟦ mulTm t t′ ⟧t ρ ≡ ⟦ t ⟧t ρ * ⟦ t′ ⟧t ρ
  mulTm-sound (a , x) (b , y) ρ rewrite map-merge x y ρ
                                        = shuffle₃ a b _ _

  mulTmDistr : ∀ t v (ρ : Env Atom) → ⟦ map (mulTm t) v ⟧n ρ ≡ ⟦ t ⟧t ρ * ⟦ v ⟧n ρ
  mulTmDistr t [] ρ = sym (mul-zero-r (⟦ t ⟧t ρ))
  mulTmDistr t (t′ ∷ v) ρ =
    ⟦ mulTm t t′ ⟧t ρ + ⟦ map (mulTm t) v ⟧n ρ
      ≡⟨ cong₂ _+_ (mulTm-sound t t′ ρ) (mulTmDistr t v ρ) ⟩
    ⟦ t ⟧t ρ * ⟦ t′ ⟧t ρ + ⟦ t ⟧t ρ * ⟦ v ⟧n ρ
      ≡⟨ mul-distr-l (⟦ t ⟧t ρ) _ _ ⟩ʳ
    ⟦ t ⟧t ρ * ⟦ t′ ∷ v ⟧n ρ ∎

  sort-sound : ∀ xs ρ → ⟦ nf-sort xs ⟧n ρ ≡ ⟦ xs ⟧n ρ
  sort-sound [] ρ = refl
  sort-sound (x ∷ xs) ρ rewrite ⟨+⟩-sound [ x ] (nf-sort xs) ρ
                              | sort-sound xs ρ
                              | add-zero-r (⟦ x ⟧t ρ) = refl

  ⟨*⟩-sound : ∀ v₁ v₂ (ρ : Env Atom) → ⟦ v₁ *nf v₂ ⟧n ρ ≡ ⟦ v₁ ⟧n ρ * ⟦ v₂ ⟧n ρ
  ⟨*⟩-sound [] v₂ ρ = refl
  ⟨*⟩-sound (t ∷ v₁) v₂ ρ =
    ⟦ nf-sort (map (mulTm t) v₂) +nf (v₁ *nf v₂) ⟧n ρ
      ≡⟨ ⟨+⟩-sound (nf-sort (map (mulTm t) v₂)) (v₁ *nf v₂) ρ ⟩
    ⟦ nf-sort (map (mulTm t) v₂) ⟧n ρ + ⟦ v₁ *nf v₂ ⟧n ρ
      ≡⟨ cong (flip _+_ (⟦ v₁ *nf v₂ ⟧n ρ)) (sort-sound (map (mulTm t) v₂) ρ) ⟩
    ⟦ map (mulTm t) v₂ ⟧n ρ + ⟦ v₁ *nf v₂ ⟧n ρ
      ≡⟨ cong (_+_ (⟦ map (mulTm t) v₂ ⟧n ρ)) (⟨*⟩-sound v₁ v₂ ρ) ⟩
    ⟦ map (mulTm t) v₂ ⟧n ρ + ⟦ v₁ ⟧n ρ * ⟦ v₂ ⟧n ρ
      ≡⟨ cong (flip _+_ (⟦ v₁ ⟧n ρ * ⟦ v₂ ⟧n ρ)) (mulTmDistr t v₂ ρ) ⟩
    ⟦ t ⟧t ρ * ⟦ v₂ ⟧n ρ + ⟦ v₁ ⟧n ρ * ⟦ v₂ ⟧n ρ
      ≡⟨ mul-distr-r (⟦ t ⟧t ρ) _ _ ⟩ʳ
    ⟦ t ∷ v₁ ⟧n ρ * ⟦ v₂ ⟧n ρ ∎

  sound : ∀ e (ρ : Env Atom) → ⟦ e ⟧e ρ ≡ ⟦ norm e ⟧n ρ
  sound (var x) ρ = mul-one-r (ρ x) ʳ⟨≡⟩ add-zero-r _ ʳ⟨≡⟩ʳ add-zero-r _
  sound (lit 0) ρ = refl
  sound (lit (suc n)) ρ rewrite mul-one-r n
                              | add-commute n 1
                              = sym (add-zero-r _)
  sound (e ⟨+⟩ e₁) ρ =
    ⟦ e ⟧e ρ + ⟦ e₁ ⟧e ρ
      ≡⟨ cong₂ _+_ (sound e ρ) (sound e₁ ρ) ⟩
    ⟦ norm e ⟧n ρ + ⟦ norm e₁ ⟧n ρ
      ≡⟨ ⟨+⟩-sound (norm e) (norm e₁) ρ ⟩ʳ
    ⟦ norm e +nf norm e₁ ⟧n ρ ∎
  sound (e ⟨*⟩ e₁) ρ =
    ⟦ e ⟧e ρ * ⟦ e₁ ⟧e ρ
      ≡⟨ cong₂ _*_ (sound e ρ) (sound e₁ ρ) ⟩
    ⟦ norm e ⟧n ρ * ⟦ norm e₁ ⟧n ρ
      ≡⟨ ⟨*⟩-sound (norm e) (norm e₁) ρ ⟩ʳ
    ⟦ norm e *nf norm e₁ ⟧n ρ ∎

  module _ (ρ₁ ρ₂ : Env Atom) (eq : ∀ x → ρ₁ x ≡ ρ₂ x) where
    private
      lem-eval-env-a : ∀ a → productR (map ρ₁ a) ≡ productR (map ρ₂ a)
      lem-eval-env-a []       = refl
      lem-eval-env-a (x ∷ xs) = _*_ $≡ eq x *≡ lem-eval-env-a xs

      lem-eval-env-t : ∀ t → ⟦ t ⟧t ρ₁ ≡ ⟦ t ⟧t ρ₂
      lem-eval-env-t (k , a) = _*_ k $≡ lem-eval-env-a a

    lem-eval-env : ∀ n → ⟦ n ⟧n ρ₁ ≡ ⟦ n ⟧n ρ₂
    lem-eval-env [] = refl
    lem-eval-env (x ∷ n) = _+_ $≡ lem-eval-env-t x *≡ lem-eval-env n


module LFRef.Readme where

open import LFRef.Syntax
open import LFRef.Welltyped
open import LFRef.Eval
open import LFRef.Properties.Soundness
open import LFRef.Properties.Confluence


open import Data.Product using ( proj₁ ; proj₂ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; sym ; cong )
open import Relation.Unary using ( _⊆_ )
open import Web.Semantic.DL.ABox using ( ABox ; ⟨ABox⟩ ; Assertions )
open import Web.Semantic.DL.ABox.Interp using ( ⌊_⌋ ; ind )
open import Web.Semantic.DL.ABox.Model using ( _⊨a_ ; bnodes ; _,_ )
open import Web.Semantic.DL.Category.Object using ( Object ; IN ; fin ; iface )
open import Web.Semantic.DL.Category.Morphism using ( impl ; _≣_ ; _⊑_ ; _,_ )
open import Web.Semantic.DL.Category.Composition using ( _∙_ )
open import Web.Semantic.DL.Category.Properties.Composition.Lemmas using
  ( compose-left ; compose-right ; compose-resp-⊨a )
open import Web.Semantic.DL.Category.Wiring using
  ( wiring ; wires-≈ ; wires-≈⁻¹ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox )
open import Web.Semantic.DL.TBox.Interp using
  ( Δ ; _⊨_≈_ ; ≈-refl ; ≈-refl′ ; ≈-trans )
open import Web.Semantic.Util using
  ( _∘_ ; False ; elim ; _⊕_⊕_ ; inode ; bnode ; enode )

module Web.Semantic.DL.Category.Properties.Composition.RespectsWiring
  {Σ : Signature} {S T : TBox Σ} where

compose-resp-wiring : ∀ (A B C : Object S T) →
  (f : IN B → IN A) →
  (f✓ : Assertions (⟨ABox⟩ f (iface B)) ⊆ Assertions (iface A)) →
  (g : IN C → IN B) →
  (g✓ : Assertions (⟨ABox⟩ g (iface C)) ⊆ Assertions (iface B)) →
  (h : IN C → IN A) →
  (h✓ : Assertions (⟨ABox⟩ h (iface C)) ⊆ Assertions (iface A)) →
    (∀ x → f (g x) ≡ h x) →
      (wiring A B f f✓ ∙ wiring B C g g✓ ≣ wiring A C h h✓)
compose-resp-wiring A B C f f✓ g g✓ h h✓ fg≡h =
  (LHS⊑RHS , RHS⊑LHS) where

  LHS⊑RHS : wiring A B f f✓ ∙ wiring B C g g✓ ⊑ wiring A C h h✓
  LHS⊑RHS I I⊨STA I⊨F = (elim , I⊨RHS) where

    lemma : ∀ x → ⌊ I ⌋ ⊨ ind I (inode (h x)) ≈ ind I (enode x)
    lemma x = ≈-trans ⌊ I ⌋
      (≈-refl′ ⌊ I ⌋ (cong (ind I ∘ inode) (sym (fg≡h x))))
      (≈-trans ⌊ I ⌋
        (wires-≈ f (proj₂ (fin B) (g x))
          (compose-left (wiring A B f f✓) (wiring B C g g✓) I I⊨F))
        (wires-≈ g (proj₂ (fin C) x)
          (compose-right (wiring A B f f✓) (wiring B C g g✓) I I⊨F)))

    I⊨RHS : bnodes I elim ⊨a impl (wiring A C h h✓)
    I⊨RHS = wires-≈⁻¹ h lemma (proj₁ (fin C))

  RHS⊑LHS : wiring A C h h✓ ⊑ wiring A B f f✓ ∙ wiring B C g g✓
  RHS⊑LHS I I⊨STA I⊨F = (i , I⊨LHS) where

    i : (False ⊕ IN B ⊕ False) → Δ ⌊ I ⌋
    i (inode ())
    i (bnode y) = ind I (inode (f y))
    i (enode ())

    lemma : ∀ x → ⌊ I ⌋ ⊨ ind I (inode (f (g x))) ≈ ind I (enode x)
    lemma x = ≈-trans ⌊ I ⌋
      (≈-refl′ ⌊ I ⌋ (cong (ind I ∘ inode) (fg≡h x)))
      (wires-≈ h (proj₂ (fin C) x) I⊨F)

    I⊨LHS : bnodes I i ⊨a impl (wiring A B f f✓ ∙ wiring B C g g✓)
    I⊨LHS = compose-resp-⊨a (wiring A B f f✓) (wiring B C g g✓) (bnodes I i)
      (wires-≈⁻¹ f (λ x → ≈-refl ⌊ I ⌋) (proj₁ (fin B)))
      (wires-≈⁻¹ g lemma (proj₁ (fin C)))


module Issue224 where

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just    : A → Maybe A

data D (A : Set) : Maybe A → Set where
  d₁ : (x : A) → D A (just x)
  d₂ : ∀ {x} → D A x → D A x

data S : ∀ {A x} → D A x → Set₁ where
  s : ∀ {A x} {d : D A x} → S d → S (d₂ d)

foo : {A : Set} → S (d₂ (d₁ (nothing {A}))) → Set₁
foo (s _) = Set

-- Bug.agda:19,6-9
-- Panic: Pattern match failure in do expression at
-- src/full/Agda/TypeChecking/Rules/LHS/Unify.hs:331:2-5
-- when checking that the pattern s _ has type S (d₂ (d₁ nothing))