open import Relation.Binary.PropositionalEquality using (sym)
open import Data.Fin using (zero; suc)
open import Data.Nat using (suc)

open import Substitution using (rename-subst-commute; subst-commute)
open import DeBruijn
open import Beta

infix 3 _—↠ˢ_

_—↠ˢ_ : ∀ {n m} → Subst n m → Subst n m → Set
σ —↠ˢ σ′ = ∀ {x} → σ x —↠ σ′ x

beta-rename : ∀ {n m} {ρ : Rename n m} {M M′ : Term n}
  → M —→ M′
    -------------------------
  → rename ρ M —→ rename ρ M′
beta-rename (—→-ƛ  M—→M′)  = —→-ƛ (beta-rename M—→M′)
beta-rename (—→-ξₗ M—→M′) = —→-ξₗ (beta-rename M—→M′)
beta-rename (—→-ξᵣ N—→N′) = —→-ξᵣ (beta-rename N—→N′)
beta-rename {ρ = ρ} (—→-β {M = M}{N = N})
  rewrite sym (rename-subst-commute {N = M}{M = N}{ρ = ρ}) = —→-β

betas-rename : ∀ {n m} {ρ : Rename n m} {M M′ : Term n}
  → M —↠ M′
    -------------------------
  → rename ρ M —↠ rename ρ M′
betas-rename {ρ = ρ} (M ∎)                = rename ρ M ∎
betas-rename {ρ = ρ} (M —→⟨ M—→L ⟩ L—↠M′) = rename ρ M —→⟨ beta-rename M—→L ⟩ betas-rename L—↠M′

betas-subst-exts : ∀ {n m} {σ σ′ : Subst n m}
  → σ —↠ˢ σ′
    ------------------
  → exts σ —↠ˢ exts σ′
betas-subst-exts σ—↠σ′ {zero}  = # zero ∎
betas-subst-exts σ—↠σ′ {suc x} = betas-rename σ—↠σ′

subst-betas-sub : ∀ {n m} {M : Term n} {σ σ′ : Subst n m}
  → σ —↠ˢ σ′
    -----------------------
  → subst σ M —↠ subst σ′ M
subst-betas-sub {M = # x}   σ—↠σ′ = σ—↠σ′
subst-betas-sub {M = M · N} σ—↠σ′ = —↠-cong (subst-betas-sub {M = M} σ—↠σ′)
                                            (subst-betas-sub {M = N} σ—↠σ′)
subst-betas-sub {M = ƛ M}   σ—↠σ′ =
  —↠-cong-ƛ (subst-betas-sub {M = M} (λ {x} → betas-subst-exts σ—↠σ′ {x = x}))

subst-beta-term : ∀ {n m} {M M′ : Term n} {σ : Subst n m}
  → M —→ M′
    -----------------------
  → subst σ M —→ subst σ M′
subst-beta-term (—→-ƛ  M—→M′) = —→-ƛ  (subst-beta-term M—→M′)
subst-beta-term (—→-ξₗ M—→M′) = —→-ξₗ (subst-beta-term M—→M′)
subst-beta-term (—→-ξᵣ N—→N′) = —→-ξᵣ (subst-beta-term N—→N′)
subst-beta-term {σ = σ} (—→-β {M = M}{N = N})
  rewrite sym (subst-commute {N = M}{M = N}{σ = σ}) = —→-β

subst-betas : ∀ {n m} {σ σ′ : Subst n m} {M M′ : Term n}
  → σ —↠ˢ σ′
  → M —↠ M′
    ------------------------
  → subst σ M —↠ subst σ′ M′
subst-betas σ—↠σ′ (M ∎) = subst-betas-sub {M = M} σ—↠σ′
subst-betas {σ = σ} σ—↠σ′ (M —→⟨ M—→L ⟩ L—↠M′) =
  subst σ M —→⟨ subst-beta-term M—→L ⟩ subst-betas σ—↠σ′ L—↠M′

betas-subst-zero : ∀ {n} {M M′ : Term n}
  → M —↠ M′
    ------------------------------
  → subst-zero M —↠ˢ subst-zero M′
betas-subst-zero M—↠M′ {zero}  = M—↠M′
betas-subst-zero M—↠M′ {suc x} = # x ∎

sub-betas : ∀ {n} {M M′ : Term (suc n)} {N N′ : Term n}
  → M —↠ M′
  → N —↠ N′
    --------------------
  → M [ N ] —↠ M′ [ N′ ]
sub-betas M—↠M′ N—↠N′ = subst-betas (betas-subst-zero N—↠N′) M—↠M′


{-# OPTIONS --safe #-}

module Cubical.Categories.Additive.Instances.Terminal where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Categories.Category
open import Cubical.Categories.Additive.Base
open import Cubical.Categories.Instances.Discrete

open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.AbGroup.Instances.Unit

open import Cubical.Data.Unit

private
  variable
    ℓ ℓ' : Level

open PreaddCategory
open PreaddCategoryStr
open AdditiveCategory
open AdditiveCategoryStr

private
  terminalCategory : Category ℓ ℓ
  terminalCategory = DiscreteCategory (Unit* , isOfHLevelUnit* 3)

  terminalAbGroupStr : AbGroupStr {ℓ = ℓ} Unit*
  terminalAbGroupStr = snd UnitAbGroup

  homProp : (x y : Category.ob {ℓ = ℓ} terminalCategory) → isProp (terminalCategory [ x , y ])
  homProp x y = isOfHLevelUnit* 2 x y

  homContr : (x y : Category.ob {ℓ = ℓ} terminalCategory) → isContr (terminalCategory [ x , y ])
  homContr x y = isProp→isContrPath (isOfHLevelUnit* 1) x y

  terminalPreAdd : PreaddCategory ℓ ℓ
  cat terminalPreAdd = terminalCategory
  homAbStr (preadd terminalPreAdd) =
    λ x y →
      subst
        AbGroupStr
        (sym (isContr→≡Unit* (homContr x y)))
        terminalAbGroupStr
  ⋆distl+ (preadd terminalPreAdd) = λ _ _ _ _ → refl
  ⋆distr+ (preadd terminalPreAdd) = λ _ _ _ → refl

terminalAdditiveCategory : AdditiveCategory ℓ ℓ
preaddcat terminalAdditiveCategory = terminalPreAdd
ZeroObject.z (zero (addit terminalAdditiveCategory)) = tt*
ZeroObject.zInit (zero (addit terminalAdditiveCategory)) y = homContr _ _
ZeroObject.zTerm (zero (addit terminalAdditiveCategory)) y = homContr _ _
biprod (addit terminalAdditiveCategory) x y = trivProd
  where trivProd : Biproduct terminalPreAdd x y
        Biproduct.x⊕y trivProd = tt*
        Biproduct.i₁ trivProd = refl
        Biproduct.i₂ trivProd = refl
        Biproduct.π₁ trivProd = refl
        Biproduct.π₂ trivProd = refl
        IsBiproduct.i₁⋆π₁ (Biproduct.isBipr trivProd) = homProp _ _ _ _
        IsBiproduct.i₁⋆π₂ (Biproduct.isBipr trivProd) = homProp _ _ _ _
        IsBiproduct.i₂⋆π₁ (Biproduct.isBipr trivProd) = homProp _ _ _ _
        IsBiproduct.i₂⋆π₂ (Biproduct.isBipr trivProd) = homProp _ _ _ _
        IsBiproduct.∑π⋆i (Biproduct.isBipr trivProd) = homProp _ _ _ _


module Mask where

open import Basics
open import Ix
open import All
open import Cutting
open import Splitting
open import Perm
open import Interior
open import Recutter

module MASK {I}(C : I |> I) where

  open _|>_
  open INTERIOR C
  open RECUTTER C

  module CHOP {P}(pc : CutKit P)(rec : Recutter) where

    glue : (is : List I) -> (d : Subs is) ->
              All (Interior P) (subCollect is d) -> All (Interior P) is
    glue [] <> <> = <>
    glue (i ,- is) (inl <> , ds) (p , ps) = p , glue is ds ps
    glue (i ,- is) (inr c , ds) ps with isRiffle (slrs (inners C c) (subCollect is ds)) ps
    glue (i ,- is) (inr c , ds) .(riffle (slrs (inners C c) (subCollect is ds)) lp rp)
      | mkRiffle lp rp = < c 8>< lp > , glue is ds rp

    chop : (i : I)(c c' : Cuts C i) ->
           All (Interior P) (inners C c) -> All (Interior P) (inners C c')
    chops : (is : List I) -> All (Interior P) is -> (d : Subs is) ->
              All (Interior P) (subCollect is d)
    chop i c c' ps with rec i c c'
    ... | d , d' , m with chops (inners C c) ps d
    ... | qs = glue (inners C c') d' (permute m qs)
    chops [] <> <> = <>
    chops (i ,- is) (p , ps) (inl <> , ds) = p , chops is ps ds
    chops (i ,- is) (tile p , ps) (inr c' , ds) =
      cat (inners C c') (subCollect is ds) (all (\ _ -> tile) _ (pc i c' p)) (chops is ps ds)
    chops (i ,- is) (< c 8>< ps' > , ps) (inr c' , ds) =
      cat (inners C c') (subCollect is ds) (chop i c c' ps') (chops is ps ds)

    mask : forall {O Q} -> [ O -:> Interior P -:> Interior Q ]
                        -> [ Interior O -:> Interior P -:> Interior Q ]
    mask {O}{Q} f = ifold f help where
      help :  [ Cutting C (Interior P -:> Interior Q) -:> Interior P -:> Interior Q ]
      help i (c' 8>< fs) (tile p) with pc i c' p
      ... | ps = < c' 8>< allAp (inners C c') fs (all (\ _ -> tile) _ ps) >
      help i (c' 8>< fs) < c 8>< ps > = < c' 8>< allAp (inners C c') fs (chop i c c' ps) >


{- Example by Andreas (2015-09-18) -}

{-# OPTIONS --rewriting --local-confluence-check #-}

open import Common.Prelude
open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

module _ (A : Set) where

  postulate
    plus0p :  ∀{x} → (x + zero) ≡ x

  {-# REWRITE plus0p #-}


{-# OPTIONS --rewriting #-}

--
-- Prelude.agda - Some base definitions
--

module Prelude where

  open import Agda.Primitive public

  record ⊤ : Set where
    constructor tt

  {-# BUILTIN UNIT ⊤ #-}

  record Σ {i j} (A : Set i) (B : A → Set j) : Set (i ⊔ j) where
    constructor _,_
    field
      fst : A
      snd : B fst

  open Σ public

  data ℕ : Set where
    O : ℕ
    S : ℕ → ℕ

  {-# BUILTIN NATURAL ℕ #-}

  uncurry : ∀ {i j k} {A : Set i} {B : A → Set j} {C : Set k} →
            (φ : (a : A) → (b : B a) → C) →
            Σ A B → C
  uncurry φ (a , b) = φ a b

  curry : ∀ {i j k} {A : Set i} {B : A → Set j} {C : Set k} →
          (ψ : Σ A B → C) →
          (a : A) → (b : B a) → C
  curry ψ a b = ψ (a , b)

  infix 30 _==_

  data _==_ {i} {A : Set i} (a : A) : A → Set i where
    idp : a == a

  {-# BUILTIN EQUALITY _==_ #-}
  {-# BUILTIN REFL idp #-}

  transport : ∀{i j} {A : Set i} (P : A → Set j) {a₀ a₁ : A} (p : a₀ == a₁) → P a₀ → P a₁
  transport P idp x = x

  sym : ∀ {i} {A : Set i} {a₀ a₁ : A} (p : a₀ == a₁) → a₁ == a₀
  sym idp = idp

  etrans : ∀ {i} {A : Set i} {a₀ a₁ a₂ : A} → a₀ == a₁ → a₁ == a₂ → a₀ == a₂
  etrans idp idp = idp

  proof-irrelevance : ∀ {a} {A : Set a} {x y : A} (p q : x == y) → p == q
  proof-irrelevance idp idp = idp

  elimtransport : ∀{i j} {A : Set i} (P : A → Set j) {a₀ a₁ : A} (p : a₀ == a₁) (q : a₀ == a₁) (r : p == q)  (x : P a₀) → transport P p x == transport P q x
  elimtransport P p .p idp x = idp

  tr! : ∀{i j} {A : Set i} (P : A → Set j) {a₀ a₁ : A} (p : a₀ == a₁) (q : a₀ == a₁) (x : P a₀) → transport P p x == transport P q x
  tr! P p q x = elimtransport P p q (proof-irrelevance p q) x

  tr² : ∀{i j} {A : Set i} (P : A → Set j) {a₀ a₁ a₂ : A} (p : a₀ == a₁) (q : a₁ == a₂) (x : P a₀) → transport P q (transport P p x) == transport P (etrans p q) x
  tr² P idp idp x = idp

  tr³ : ∀{i j} {A : Set i} (P : A → Set j) {a₀ a₁ a₂ a₃ : A} (p₀ : a₀ == a₁) (p₁ : a₁ == a₂) (p₂ : a₂ == a₃) (x : P a₀) → transport P p₂ (transport P p₁ (transport P p₀ x)) == transport P (etrans p₀ (etrans p₁ p₂)) x
  tr³ P idp idp idp x = idp

  tr⁴ : ∀{i j} {A : Set i} (P : A → Set j) {a₀ a₁ a₂ a₃ a₄ : A} (p₀ : a₀ == a₁) (p₁ : a₁ == a₂) (p₂ : a₂ == a₃) (p₃ : a₃ == a₄) (x : P a₀) → transport P p₃ (transport P p₂ (transport P p₁ (transport P p₀ x))) == transport P (etrans p₀ (etrans p₁ (etrans p₂ p₃))) x
  tr⁴ P idp idp idp idp x = idp

  hfiber : ∀ {i} {A B : Set i} (f : A → B) (b : B) → Set i
  hfiber {A = A} f b = Σ A (λ a → f a == b)

  PathOver : ∀ {i j} {A : Set i} (B : A → Set j) {a₀ a₁ : A} (p : a₀ == a₁) (b₉ : B a₀) (b₁ : B a₁) → Set j
  PathOver B idp b₀ b₁ = b₀ == b₁

  infix 30 PathOver
  syntax PathOver B p u v =
    u == v [ B ↓ p ]

  Σ-r : ∀ {i j k} {A : Set i} {B : A → Set j} (C : Σ A B → Set k) → A → Set (j ⊔ k)
  Σ-r {A = A} {B = B} C a = Σ (B a) (λ b → C (a , b))

  Σ-in : ∀ {i j k} {A : Set i} {B : A → Set j} (C : (a : A) → B a → Set k) → A → Set (j ⊔ k)
  Σ-in {A = A} {B = B} C a = Σ (B a) (λ b → C a b)

  infix 30 _↦_

  postulate
    _↦_ : ∀ {i} {A : Set i} → A → A → Set i

  {-# BUILTIN REWRITE _↦_ #-}

  data bool : Set where
    true  : bool
    false : bool

  data ⊥ : Set where

  if_then_else : ∀ {a} {A : Set a} →  bool → A → A → A
  if true then A else B = A
  if false then A else B = B

  _≤_ : ℕ → ℕ → bool
  O ≤ n₁ = true
  S n₀ ≤ O = false
  S n₀ ≤ S n₁ = n₀ ≤ n₁

  min : ℕ → ℕ → ℕ
  min n₀ n₁ with n₀ ≤ n₁
  min n₀ n₁ | true = n₀
  min n₀ n₁ | false = n₁

  ≤S : ∀ (n₀ n₁ : ℕ) → (n₀ ≤ n₁) == true → (n₀ ≤ S n₁) == true
  ≤S O n₁ x = idp
  ≤S (S n₀) O ()
  ≤S (S n₀) (S n₁) x = ≤S n₀ n₁ x

  S≤S : ∀ (n₀ n₁ : ℕ) → (n₀ ≤ n₁) == true → (S n₀ ≤ S n₁) == true
  S≤S n₀ n₁ x = x


module Relation.Unary.Monotone.Prefix {ℓ}{T : Set ℓ} where

open import Data.List.Prefix
open import Data.List as List
open import Data.List.Membership.Propositional
open import Data.List.All as All

open import Relation.Unary.Monotone (⊑-preorder {A = T})

instance
  open Monotone

  any-monotone : ∀ {x : T} → Monotone (λ xs → x ∈ xs)
  wk any-monotone ext l = ∈-⊒ l ext


{-# OPTIONS --without-K --exact-split #-}

module categories where

import 21-image
open 21-image public

{- We introduce precategories and categories. -}

Precat :
  (l1 l2 : Level) → UU (lsuc l1 ⊔ lsuc l2)
Precat l1 l2 =
  Σ (UU l1) (λ Obj → Σ (Obj → Obj → hSet l2) (λ Hom →
    Σ ({X : Obj} → type-Set (Hom X X)) (λ i →
      Σ ( {X Y Z : Obj} →
          type-Set (Hom Y Z) → type-Set (Hom X Y) → type-Set (Hom X Z))
          ( λ comp →
            ( {X Y Z W : Obj} (f : type-Set (Hom X Y)) (g : type-Set (Hom Y Z))
              (h : type-Set (Hom Z W)) →
              Id (comp (comp h g) f) (comp h (comp g f))) ×
            ( ( {X Y : Obj} (f : type-Set (Hom X Y)) → Id (comp i f) f) ×
              ( {X Y : Obj} (f : type-Set (Hom X Y)) → Id (comp f i) f))))))

obj-Precat :
  {l1 l2 : Level} (C : Precat l1 l2) → UU l1
obj-Precat C = pr1 C

hom-Precat :
  {l1 l2 : Level} (C : Precat l1 l2) → obj-Precat C → obj-Precat C → hSet l2
hom-Precat C = pr1 (pr2 C)

id-Precat :
  {l1 l2 : Level} (C : Precat l1 l2)
  {X : obj-Precat C} → type-Set (hom-Precat C X X)
id-Precat C = pr1 (pr2 (pr2 C))

comp-Precat :
  {l1 l2 : Level} (C : Precat l1 l2)
  {X Y Z : obj-Precat C} → type-Set (hom-Precat C Y Z) →
  type-Set (hom-Precat C X Y) → type-Set (hom-Precat C X Z)
comp-Precat C = pr1 (pr2 (pr2 (pr2 C)))

assoc-Precat :
  {l1 l2 : Level} (C : Precat l1 l2)
  {X Y Z W : obj-Precat C} (f : type-Set (hom-Precat C X Y)) →
  ( g : type-Set (hom-Precat C Y Z)) ( h : type-Set (hom-Precat C Z W)) →
  Id (comp-Precat C (comp-Precat C h g) f) (comp-Precat C h (comp-Precat C g f))
assoc-Precat C = pr1 (pr2 (pr2 (pr2 (pr2 C))))

left-unit-Precat :
  {l1 l2 : Level} (C : Precat l1 l2)
  {X Y : obj-Precat C} (f : type-Set (hom-Precat C X Y)) →
  Id (comp-Precat C (id-Precat C) f) f
left-unit-Precat C = pr1 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))

right-unit-Precat :
  {l1 l2 : Level} (C : Precat l1 l2)
  {X Y : obj-Precat C} (f : type-Set (hom-Precat C X Y)) →
  Id (comp-Precat C f (id-Precat C)) f
right-unit-Precat C = pr2 (pr2 (pr2 (pr2 (pr2 (pr2 C)))))

{- We define the notion of isomorphism in a precategory. -}

is-iso-Precat :
  {l1 l2 : Level} (C : Precat l1 l2) {X Y : obj-Precat C} →
  (type-Set (hom-Precat C X Y)) → UU l2
is-iso-Precat C {X} {Y} f =
  Σ ( type-Set (hom-Precat C Y X)) (λ g →
    Id (comp-Precat C f g) (id-Precat C) ×
    Id (comp-Precat C g f) (id-Precat C))

iso-Precat :
  {l1 l2 : Level} (C : Precat l1 l2) →
  obj-Precat C → obj-Precat C → hSet l2
iso-Precat C X Y =
  {!!}


module PLRTree.Compound {A : Set}  where

open import PLRTree {A}

data Compound : PLRTree → Set where
  compound : {t : Tag}{x : A}{l r : PLRTree} → Compound (node t x l r)


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Free.Base (Σ : Signature) where

open import Fragment.Algebra.Algebra Σ
open import Fragment.Algebra.Free.Atoms public

open import Level using (Level; _⊔_)
open import Function using (_∘_)

open import Data.Empty using (⊥)
open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Vec.Relation.Binary.Pointwise.Inductive
  using (Pointwise; []; _∷_)

open import Relation.Binary using (Setoid; IsEquivalence)
open import Relation.Binary.PropositionalEquality as PE using (_≡_)

private
  variable
    a ℓ : Level

module _ (A : Set a) where

  data Term : Set a where
    atom : A → Term
    term : ∀ {arity} → (f : ops Σ arity) → Vec Term arity → Term

module _ (S : Setoid a ℓ) where

  open Setoid S renaming (Carrier to A)

  data _~_ : Term A → Term A → Set (a ⊔ ℓ) where
      atom : ∀ {x y} → x ≈ y → atom x ~ atom y
      term : ∀ {arity xs ys} {f : ops Σ arity}
             → Pointwise _~_ xs ys
             → term f xs ~ term f ys

  private

    mutual
      map-~-refl : ∀ {n} {xs : Vec _ n} → Pointwise _~_ xs xs
      map-~-refl {xs = []}     = []
      map-~-refl {xs = x ∷ xs} = ~-refl ∷ map-~-refl

      ~-refl : ∀ {x} → x ~ x
      ~-refl {atom _}   = atom refl
      ~-refl {term _ _} = term map-~-refl

    mutual
      map-~-sym : ∀ {n} {xs ys : Vec _ n}
                   → Pointwise _~_ xs ys
                   → Pointwise _~_ ys xs
      map-~-sym [] = []
      map-~-sym (x≈y ∷ xs≈ys) =
        ~-sym x≈y ∷ map-~-sym xs≈ys

      ~-sym : ∀ {x y} → x ~ y → y ~ x
      ~-sym (atom x≈y)   = atom (sym x≈y)
      ~-sym (term xs≈ys) = term (map-~-sym xs≈ys)

    mutual
      map-~-trans : ∀ {n} {xs ys zs : Vec _ n}
                    → Pointwise _~_ xs ys
                    → Pointwise _~_ ys zs
                    → Pointwise _~_ xs zs
      map-~-trans [] [] = []
      map-~-trans (x≈y ∷ xs≈ys) (y≈z ∷ ys≈zs) =
        ~-trans x≈y y≈z ∷ map-~-trans xs≈ys ys≈zs

      ~-trans : ∀ {x y z} → x ~ y → y ~ z → x ~ z
      ~-trans (atom x≈y) (atom y≈z)     =
        atom (trans x≈y y≈z)
      ~-trans (term xs≈ys) (term ys≈zs) =
        term (map-~-trans xs≈ys ys≈zs)

    ~-isEquivalence : IsEquivalence _~_
    ~-isEquivalence = record { refl  = ~-refl
                             ; sym   = ~-sym
                             ; trans = ~-trans
                             }

  Herbrand : Setoid _ _
  Herbrand = record { Carrier       = Term A
                    ; _≈_           = _~_
                    ; isEquivalence = ~-isEquivalence
                    }

  Free : Algebra
  Free = record { ∥_∥/≈           = Herbrand
                ; ∥_∥/≈-isAlgebra = Free-isAlgebra
                }
    where term-cong : Congruence Herbrand term
          term-cong f p = term p

          Free-isAlgebra : IsAlgebra Herbrand
          Free-isAlgebra = record { ⟦_⟧     = term
                                  ; ⟦⟧-cong = term-cong
                                  }

F : ℕ → Algebra
F = Free ∘ Atoms (PE.setoid ⊥)


-- | The core type system.
module Ethambda.System where

open import Ethambda.Common using () -- ((<.>), (<.))

data Tp : Type -> Type where
  Var : a -> Tp a
  Fun : Tp a -> Tp a -> Tp a

Show a => Show (Tp a) where
  show t = case t of
    -- Var a => ?foo
    Var a => show a
    Fun a0 b0 => mbrackets a0 <+> "→" <+> show b0
  -- where
  --   brackets : String -> String
  --   brackets s = "(" <+> s <+> ")"
  --   mbrackets : Show a => Tp a -> String
  --   mbrackets a = case a of
  --     Var _   => neutral
  --     Fun _ _ => brackets (show a)


{-

This files contains:
- Facts about constructions on finite sets, especially when they preserve finiteness.

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

module Cubical.Data.FinSet.Constructors where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv renaming (_∙ₑ_ to _⋆_)
open import Cubical.Foundations.Univalence

open import Cubical.HITs.PropositionalTruncation as Prop

open import Cubical.Data.Nat
open import Cubical.Data.Unit
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Sum
open import Cubical.Data.Sigma

open import Cubical.Data.Fin.LehmerCode as LehmerCode
open import Cubical.Data.SumFin
open import Cubical.Data.FinSet.Base
open import Cubical.Data.FinSet.Properties
open import Cubical.Data.FinSet.FiniteChoice

open import Cubical.Relation.Nullary

open import Cubical.Functions.Fibration
open import Cubical.Functions.Embedding
open import Cubical.Functions.Surjection

private
  variable
    ℓ ℓ' ℓ'' ℓ''' : Level

module _
  (X : Type ℓ)(p : isFinOrd X) where

  isFinOrd∥∥ : isFinOrd ∥ X ∥
  isFinOrd∥∥ = _ , propTrunc≃ (p .snd) ⋆ SumFin∥∥≃ _

  isFinOrd≃ : isFinOrd (X ≃ X)
  isFinOrd≃ = _ , equivComp (p .snd) (p .snd) ⋆ SumFin≃≃ _

module _
  (X : Type ℓ )(p : isFinOrd X)
  (Y : Type ℓ')(q : isFinOrd Y) where

  isFinOrd⊎ : isFinOrd (X ⊎ Y)
  isFinOrd⊎ = _ , ⊎-equiv (p .snd) (q .snd) ⋆ SumFin⊎≃ _ _

  isFinOrd× : isFinOrd (X × Y)
  isFinOrd× = _ , Σ-cong-equiv (p .snd) (λ _ → q .snd) ⋆ SumFin×≃ _ _

module _
  (X : Type ℓ )(p : isFinOrd X)
  (Y : X → Type ℓ')(q : (x : X) → isFinOrd (Y x)) where

  private
    e = p .snd

    f : (x : X) → ℕ
    f x = q x .fst

  isFinOrdΣ : isFinOrd (Σ X Y)
  isFinOrdΣ = _ ,
      Σ-cong-equiv {B' = λ x → Y (invEq e x)} e (transpFamily p)
    ⋆ Σ-cong-equiv-snd (λ x → q (invEq e x) .snd)
    ⋆ SumFinΣ≃ _ _

  isFinOrdΠ : isFinOrd ((x : X) → Y x)
  isFinOrdΠ = _ ,
      equivΠ {B' = λ x → Y (invEq e x)} e (transpFamily p)
    ⋆ equivΠCod (λ x → q (invEq e x) .snd)
    ⋆ SumFinΠ≃ _ _

-- closedness under several type constructors

module _
  (X : FinSet ℓ)
  (Y : X .fst → FinSet ℓ') where

  isFinSetΣ : isFinSet (Σ (X .fst) (λ x → Y x .fst))
  isFinSetΣ = rec2 isPropIsFinSet
    (λ p q → isFinOrd→isFinSet (isFinOrdΣ (X .fst) (_ , p) (λ x → Y x .fst) q))
    (X .snd .snd) (choice X (λ x → isFinOrd (Y x .fst)) (λ x → isFinSet→isFinSet' (Y x .snd)))

  isFinSetΠ : isFinSet ((x : X .fst) → Y x .fst)
  isFinSetΠ = rec2 isPropIsFinSet
    (λ p q → isFinOrd→isFinSet (isFinOrdΠ (X .fst) (_ , p) (λ x → Y x .fst) q))
    (X .snd .snd) (choice X (λ x → isFinOrd (Y x .fst)) (λ x → isFinSet→isFinSet' (Y x .snd)))

module _
  (X : FinSet ℓ)
  (Y : X .fst → FinSet ℓ')
  (Z : (x : X .fst) → Y x .fst → FinSet ℓ'') where

  isFinSetΠ2 : isFinSet ((x : X .fst) → (y : Y x .fst) → Z x y .fst)
  isFinSetΠ2 = isFinSetΠ X (λ x → _ , isFinSetΠ (Y x) (Z x))

module _
  (X : FinSet ℓ)
  (Y : X .fst → FinSet ℓ')
  (Z : (x : X .fst) → Y x .fst → FinSet ℓ'')
  (W : (x : X .fst) → (y : Y x .fst) → Z x y .fst → FinSet ℓ''') where

  isFinSetΠ3 : isFinSet ((x : X .fst) → (y : Y x .fst) → (z : Z x y .fst) → W x y z .fst)
  isFinSetΠ3 = isFinSetΠ X (λ x → _ , isFinSetΠ2 (Y x) (Z x) (W x))

module _
  (X : FinSet ℓ) where

  isFinSet≡ : (a b : X .fst) → isFinSet (a ≡ b)
  isFinSet≡ a b = isDecProp→isFinSet (isFinSet→isSet (X .snd) a b) (isFinSet→Discrete (X .snd) a b)

  isFinSet∥∥ : isFinSet ∥ X .fst ∥
  isFinSet∥∥ = Prop.rec isPropIsFinSet (λ p → isFinOrd→isFinSet (isFinOrd∥∥ (X .fst) (_ , p))) (X .snd .snd)

  isFinSetIsContr : isFinSet (isContr (X .fst))
  isFinSetIsContr = isFinSetΣ X (λ x → _ , (isFinSetΠ X (λ y → _ , isFinSet≡ x y)))

  isFinSetIsProp : isFinSet (isProp (X .fst))
  isFinSetIsProp = isFinSetΠ2 X (λ _ → X) (λ x x' → _ , isFinSet≡ x x')

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ')
  (f : X .fst → Y .fst) where

  isFinSetFiber : (y : Y .fst) → isFinSet (fiber f y)
  isFinSetFiber y = isFinSetΣ X (λ x → _ , isFinSet≡ Y (f x) y)

  isFinSetIsEquiv : isFinSet (isEquiv f)
  isFinSetIsEquiv =
    EquivPresIsFinSet
      (invEquiv (isEquiv≃isEquiv' f))
      (isFinSetΠ Y (λ y → _ , isFinSetIsContr (_ , isFinSetFiber y)))

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ') where

  isFinSet⊎ : isFinSet (X .fst ⊎ Y .fst)
  isFinSet⊎ = card X + card Y ,
    map2 (λ p q → isFinOrd⊎ (X .fst) (_ , p) (Y .fst) (_ , q) .snd) (X .snd .snd) (Y .snd .snd)

  isFinSet× : isFinSet (X .fst × Y .fst)
  isFinSet× = card X · card Y ,
    map2 (λ p q → isFinOrd× (X .fst) (_ , p) (Y .fst) (_ , q) .snd) (X .snd .snd) (Y .snd .snd)

  isFinSet→ : isFinSet (X .fst → Y .fst)
  isFinSet→ = isFinSetΠ X (λ _ → Y)

  isFinSet≃ : isFinSet (X .fst ≃ Y .fst)
  isFinSet≃ = isFinSetΣ (_ , isFinSet→) (λ f → _ , isFinSetIsEquiv X Y f)

module _
  (X Y : FinSet ℓ ) where

  isFinSetType≡ : isFinSet (X .fst ≡ Y .fst)
  isFinSetType≡ = EquivPresIsFinSet (invEquiv univalence) (isFinSet≃ X Y)

module _
  (X : FinSet ℓ) where

  isFinSetAut : isFinSet (X .fst ≃ X .fst)
  isFinSetAut = LehmerCode.factorial (card X) ,
    Prop.map (λ p → isFinOrd≃ (X .fst) (card X , p) .snd) (X .snd .snd)

  isFinSetTypeAut : isFinSet (X .fst ≡ X .fst)
  isFinSetTypeAut = EquivPresIsFinSet (invEquiv univalence) isFinSetAut

module _
  (X : FinSet ℓ) where

  isFinSet¬ : isFinSet (¬ (X .fst))
  isFinSet¬ = isFinSet→ X (Fin 0 , isFinSetFin)

module _
  (X : FinSet ℓ) where

  isFinSetNonEmpty : isFinSet (NonEmpty (X .fst))
  isFinSetNonEmpty = isFinSet¬ (_ , isFinSet¬ X)

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ')
  (f : X .fst → Y .fst) where

  isFinSetIsEmbedding : isFinSet (isEmbedding f)
  isFinSetIsEmbedding =
    isFinSetΠ2 X (λ _ → X)
      (λ a b → _ , isFinSetIsEquiv (_ , isFinSet≡ X a b) (_ , isFinSet≡ Y (f a) (f b)) (cong f))

  isFinSetIsSurjection : isFinSet (isSurjection f)
  isFinSetIsSurjection =
    isFinSetΠ Y (λ y → _ , isFinSet∥∥ (_ , isFinSetFiber X Y f y))

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ') where

  isFinSet↪ : isFinSet (X .fst ↪ Y .fst)
  isFinSet↪ = isFinSetΣ (_ , isFinSet→ X Y) (λ f → _ , isFinSetIsEmbedding X Y f)

  isFinSet↠ : isFinSet (X .fst ↠ Y .fst)
  isFinSet↠ = isFinSetΣ (_ , isFinSet→ X Y) (λ f → _ , isFinSetIsSurjection X Y f)

-- a criterion of being finite set

module _
  (X : Type ℓ)(Y : FinSet ℓ')
  (f : X → Y .fst)
  (h : (y : Y .fst) → isFinSet (fiber f y)) where

  isFinSetTotal : isFinSet X
  isFinSetTotal = EquivPresIsFinSet (invEquiv (totalEquiv f)) (isFinSetΣ Y (λ y → _ , h y))

-- a criterion of fibers being finite sets, more general than the previous result

module _
  (X : FinSet ℓ)
  (Y : Type ℓ')(h : Discrete Y)
  (f : X. fst → Y) where

  isFinSetFiberDisc : (y : Y) → isFinSet (fiber f y)
  isFinSetFiberDisc y = isFinSetΣ X (λ x → _ , isDecProp→isFinSet (Discrete→isSet h _ _) (h (f x) y))


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

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Naturals
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Numbers.Naturals.Order.WellFounded
open import Orders.WellFounded.Induction
open import Orders.Total.Definition
open import Semirings.Definition

module Numbers.Naturals.EuclideanAlgorithm where

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

record divisionAlgResult (a : ℕ) (b : ℕ) : Set where
  field
    quot : ℕ
    rem : ℕ
    pr : a *N quot +N rem ≡ b
    remIsSmall : (rem <N a) || (a ≡ 0)
    quotSmall : (0 <N a) || ((0 ≡ a) && (quot ≡ 0))

record divisionAlgResult' (a : ℕ) (b : ℕ) : Set where
  field
    quot : ℕ
    rem : ℕ
    .pr : a *N quot +N rem ≡ b
    remIsSmall : (rem <N' a) || (a =N' 0)
    quotSmall : (0 <N' a) || ((0 =N' a) && (quot =N' 0))

collapseDivAlgResult : {a b : ℕ} → (divisionAlgResult a b) → divisionAlgResult' a b
collapseDivAlgResult record { quot = q ; rem = r ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inl y) } = record { quot = q ; rem = r ; pr = pr ; remIsSmall = inl (<NTo<N' x) ; quotSmall = inl (<NTo<N' y) }
collapseDivAlgResult record { quot = q ; rem = r ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inr y) } = record { quot = q ; rem = r ; pr = pr ; remIsSmall = inl (<NTo<N' x) ; quotSmall = inr (collapseN (_&&_.fst y) ,, collapseN (_&&_.snd y)) }
collapseDivAlgResult record { quot = q ; rem = r ; pr = pr ; remIsSmall = (inr x) ; quotSmall = inl y } = record { quot = q ; rem = r ; pr = pr ; remIsSmall = inr (collapseN x) ; quotSmall = inl (<NTo<N' y) }
collapseDivAlgResult record { quot = q ; rem = r ; pr = pr ; remIsSmall = (inr x) ; quotSmall = inr y } = record { quot = q ; rem = r ; pr = pr ; remIsSmall = inr (collapseN x) ; quotSmall = inr (collapseN (_&&_.fst y) ,, collapseN (_&&_.snd y)) }

squashDivAlgResult : {a b : ℕ} → divisionAlgResult' a b → divisionAlgResult a b
squashDivAlgResult record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inl y) } = record { quot = quot ; rem = rem ; pr = squash pr ; remIsSmall = inl (<N'To<N x) ; quotSmall = inl (<N'To<N y) }
squashDivAlgResult record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inr y) } = record { quot = quot ; rem = rem ; pr = squash pr ; remIsSmall = inl (<N'To<N x) ; quotSmall = inr (squashN (_&&_.fst y) ,, squashN (_&&_.snd y)) }
squashDivAlgResult record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inl y) } = record { quot = quot ; rem = rem ; pr = squash pr ; remIsSmall = inr (squashN x) ; quotSmall = inl (<N'To<N y) }
squashDivAlgResult record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inr y) } = record { quot = quot ; rem = rem ; pr = squash pr ; remIsSmall = inr (squashN x) ; quotSmall = inr (squashN (_&&_.fst y) ,, squashN (_&&_.snd y)) }

squashPreservesRem : {a b : ℕ} → (p : divisionAlgResult' a b) → divisionAlgResult.rem (squashDivAlgResult p) ≡ divisionAlgResult'.rem p
squashPreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inl x₁) } = refl
squashPreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inr x₁) } = refl
squashPreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inl x₁) } = refl
squashPreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inr x₁) } = refl

squashPreservesQuot : {a b : ℕ} → (p : divisionAlgResult' a b) → divisionAlgResult.quot (squashDivAlgResult p) ≡ divisionAlgResult'.quot p
squashPreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inl x₁) } = refl
squashPreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inr x₁) } = refl
squashPreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inl x₁) } = refl
squashPreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inr x₁) } = refl

collapsePreservesRem : {a b : ℕ} → (p : divisionAlgResult a b) → divisionAlgResult'.rem (collapseDivAlgResult p) ≡ divisionAlgResult.rem p
collapsePreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inl x₁) } = refl
collapsePreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inr x₁) } = refl
collapsePreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inl x₁) } = refl
collapsePreservesRem record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inr x₁) } = refl

collapsePreservesQuot : {a b : ℕ} → (p : divisionAlgResult a b) → divisionAlgResult'.quot (collapseDivAlgResult p) ≡ divisionAlgResult.quot p
collapsePreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inl x₁) } = refl
collapsePreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) ; quotSmall = (inr x₁) } = refl
collapsePreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inl x₁) } = refl
collapsePreservesQuot record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr x) ; quotSmall = (inr x₁) } = refl

divAlgLessLemma : (a b : ℕ) → (0 <N a) → (r : divisionAlgResult a b) → (divisionAlgResult.quot r ≡ 0) || (divisionAlgResult.rem r <N b)
divAlgLessLemma zero b pr _ = exFalso (TotalOrder.irreflexive ℕTotalOrder pr)
divAlgLessLemma (succ a) b _ record { quot = zero ; rem = a%b ; pr = pr ; remIsSmall = remIsSmall } = inl refl
divAlgLessLemma (succ a) b _ record { quot = (succ a/b) ; rem = a%b ; pr = pr ; remIsSmall = remIsSmall } = inr record { x = a/b +N a *N succ (a/b) ; proof = pr }

modUniqueLemma : {rem1 rem2 a : ℕ} → (quot1 quot2 : ℕ) → rem1 <N a → rem2 <N a → a *N quot1 +N rem1 ≡ a *N quot2 +N rem2 → rem1 ≡ rem2
modUniqueLemma {rem1} {rem2} {a} zero zero rem1<a rem2<a pr rewrite Semiring.productZeroRight ℕSemiring a = pr
modUniqueLemma {rem1} {rem2} {a} zero (succ quot2) rem1<a rem2<a pr rewrite Semiring.productZeroRight ℕSemiring a | pr | multiplicationNIsCommutative a (succ quot2) | equalityCommutative (Semiring.+Associative ℕSemiring a (quot2 *N a) rem2) = exFalso (cannotAddAndEnlarge' {a} {quot2 *N a +N rem2} rem1<a)
modUniqueLemma {rem1} {rem2} {a} (succ quot1) zero rem1<a rem2<a pr rewrite Semiring.productZeroRight ℕSemiring a | equalityCommutative pr | multiplicationNIsCommutative a (succ quot1) | equalityCommutative (Semiring.+Associative ℕSemiring a (quot1 *N a) rem1) = exFalso (cannotAddAndEnlarge' {a} {quot1 *N a +N rem1} rem2<a)
modUniqueLemma {rem1} {rem2} {a} (succ quot1) (succ quot2) rem1<a rem2<a pr rewrite multiplicationNIsCommutative a (succ quot1) | multiplicationNIsCommutative a (succ quot2) | equalityCommutative (Semiring.+Associative ℕSemiring a (quot1 *N a) rem1) | equalityCommutative (Semiring.+Associative ℕSemiring a (quot2 *N a) rem2) = modUniqueLemma {rem1} {rem2} {a} quot1 quot2 rem1<a rem2<a (go {a}{quot1}{rem1}{quot2}{rem2} pr)
  where
    go : {a quot1 rem1 quot2 rem2 : ℕ} → (a +N (quot1 *N a +N rem1) ≡ a +N (quot2 *N a +N rem2)) → a *N quot1 +N rem1 ≡ a *N quot2 +N rem2
    go {a} {quot1} {rem1} {quot2} {rem2} pr rewrite multiplicationNIsCommutative quot1 a | multiplicationNIsCommutative quot2 a = canSubtractFromEqualityLeft {a} pr

modIsUnique : {a b : ℕ} → (div1 div2 : divisionAlgResult a b) → divisionAlgResult.rem div1 ≡ divisionAlgResult.rem div2
modIsUnique {zero} {b} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = remIsSmall1 } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = remIsSmall } = transitivity pr1 (equalityCommutative pr)
modIsUnique {succ a} {b} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = (inl y) } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) } = modUniqueLemma {rem1} {rem} {succ a} quot1 quot y x (transitivity pr1 (equalityCommutative pr))
modIsUnique {succ a} {b} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = (inr ()) } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inl x) }
modIsUnique {succ a} {b} record { quot = quot1 ; rem = rem1 ; pr = pr1 ; remIsSmall = remIsSmall1 } record { quot = quot ; rem = rem ; pr = pr ; remIsSmall = (inr ()) }

transferAddition : (a b c : ℕ) → (a +N b) +N c ≡ (a +N c) +N b
transferAddition a b c rewrite equalityCommutative (Semiring.+Associative ℕSemiring a b c) = p a b c
  where
    p : (a b c : ℕ) → a +N (b +N c) ≡ (a +N c) +N b
    p a b c = transitivity (applyEquality (a +N_) (Semiring.commutative ℕSemiring b c)) (Semiring.+Associative ℕSemiring a c b)

divisionAlgLemma : (x b : ℕ) → x *N zero +N b ≡ b
divisionAlgLemma x b rewrite (Semiring.productZeroRight ℕSemiring x) = refl

divisionAlgLemma2 : (x b : ℕ) → (x ≡ b) → x *N succ zero +N zero ≡ b
divisionAlgLemma2 x b pr rewrite (Semiring.productOneRight ℕSemiring x) = equalityCommutative (transitivity (equalityCommutative pr) (equalityCommutative (Semiring.sumZeroRight ℕSemiring x)))

divisionAlgLemma3 : {a x : ℕ} → (p : succ a <N succ x) → (subtractionNResult.result (-N (inl p))) <N (succ x)
divisionAlgLemma3 {a} {x} p = -NIsDecreasing {a} {succ x} p

divisionAlgLemma4 : (p a q : ℕ) → ((p +N a *N p) +N q) +N succ a ≡ succ ((p +N a *N succ p) +N q)
divisionAlgLemma4 p a q = ans
  where
    r   : ((p +N a *N p) +N q) +N succ a ≡ succ (((p +N a *N p) +N q) +N a)
    ans : ((p +N a *N p) +N q) +N succ a ≡ succ ((p +N a *N succ p) +N q)
    s : ((p +N a *N p) +N q) +N a ≡ (p +N a *N succ p) +N q
    t : (p +N a *N p) +N a ≡ p +N a *N succ p
    s = transitivity (transferAddition (p +N a *N p) q a) (applyEquality (λ i → i +N q) t)
    ans = identityOfIndiscernablesRight _≡_ r (applyEquality succ s)
    r = succExtracts ((p +N a *N p) +N q) a
    t = transitivity (equalityCommutative (Semiring.+Associative ℕSemiring p (a *N p) a)) (applyEquality (λ n → p +N n) (equalityCommutative (transitivity (multiplicationNIsCommutative a (succ p)) (transitivity (Semiring.commutative ℕSemiring a _) (applyEquality (_+N a) (multiplicationNIsCommutative p _))))))

divisionAlg : (a : ℕ) → (b : ℕ) → divisionAlgResult a b
divisionAlg zero = λ b → record { quot = zero ; rem = b ; pr = refl ; remIsSmall = inr refl ; quotSmall = inr (record { fst = refl ; snd = refl }) }
divisionAlg (succ a) = rec <NWellfounded (λ n → divisionAlgResult (succ a) n) go
  where
    go : (x : ℕ) (indHyp : (y : ℕ) (y<x : y <N x) → divisionAlgResult (succ a) y) →
            divisionAlgResult (succ a) x
    go zero prop = record { quot = zero ; rem = zero ; pr = divisionAlgLemma (succ a) zero ; remIsSmall = inl (succIsPositive a) ; quotSmall = inl (succIsPositive a) }
    go (succ x) indHyp with totality (succ a) (succ x)
    go (succ x) indHyp | inl (inl sa<sx) with indHyp (subtractionNResult.result (-N (inl sa<sx))) (divisionAlgLemma3 sa<sx)
    ... | record { quot = prevQuot ; rem = prevRem ; pr = prevPr ; remIsSmall = smallRem } = p
      where
        p : divisionAlgResult (succ a) (succ x)
        addedA : (succ a *N prevQuot +N prevRem) +N (succ a) ≡ subtractionNResult.result (-N (inl sa<sx)) +N (succ a)
        addedA' : (succ a *N prevQuot +N prevRem) +N succ a ≡ succ x
        addedA'' : (succ a *N succ prevQuot) +N prevRem ≡ succ x
        addedA''' : succ ((prevQuot +N a *N succ prevQuot) +N prevRem) ≡ succ x
        addedA''' = identityOfIndiscernablesLeft _≡_ addedA'' refl
        p = record { quot = succ prevQuot ; rem = prevRem ; pr = addedA''' ; remIsSmall = smallRem ; quotSmall = inl (succIsPositive a) }
        addedA = applyEquality (λ n → n +N succ a) prevPr
        addedA' = identityOfIndiscernablesRight _≡_ addedA (addMinus {succ a} {succ x} (inl sa<sx))
        addedA'' = identityOfIndiscernablesLeft _≡_ addedA' (divisionAlgLemma4 prevQuot a prevRem)
    go (succ x) indHyp | inr (sa=sx) = record { quot = succ zero ; rem = zero ; pr = divisionAlgLemma2 (succ a) (succ x) sa=sx ; remIsSmall = inl (succIsPositive a) ; quotSmall = inl (succIsPositive a) }
    go (succ x) indHyp | inl (inr (sx<sa)) = record { quot = zero ; rem = succ x ; pr = divisionAlgLemma (succ a) (succ x) ; remIsSmall = inl sx<sa ; quotSmall = inl (succIsPositive a) }

data _∣_ : ℕ → ℕ → Set where
  divides : {a b : ℕ} → (res : divisionAlgResult a b) → divisionAlgResult.rem res ≡ zero → a ∣ b

data _∣'_ : ℕ → ℕ → Set where
  divides' : {a b : ℕ} → (res : divisionAlgResult' a b) → .(divisionAlgResult'.rem res ≡ zero) → a ∣' b

divToDiv' : {a b : ℕ} → a ∣ b → a ∣' b
divToDiv' (divides res x) = divides' (collapseDivAlgResult res) (transitivity (collapsePreservesRem res) x)

div'ToDiv : {a b : ℕ} → a ∣' b → a ∣ b
div'ToDiv (divides' res x) = divides (squashDivAlgResult res) (transitivity (squashPreservesRem res) (squashN record { eq = x }))

zeroDividesNothing : (a : ℕ) → zero ∣ succ a → False
zeroDividesNothing a (divides record { quot = quot ; rem = rem ; pr = pr } x) = naughtE p
  where
    p : zero ≡ succ a
    p = transitivity (equalityCommutative x) pr

record hcfData (a b : ℕ) : Set where
  field
    c : ℕ
    c|a : c ∣ a
    c|b : c ∣ b
    hcf : ∀ x → x ∣ a → x ∣ b → x ∣ c

positiveTimes : {a b : ℕ} → (succ a *N succ b <N succ a) → False
positiveTimes {a} {b} pr = zeroNeverGreater f'
  where
    g : succ a *N succ b <N succ a *N succ 0
    g rewrite multiplicationNIsCommutative a 1 | Semiring.commutative ℕSemiring a 0 = pr
    f : succ b <N succ 0
    f = cancelInequalityLeft {succ a} {succ b} g
    f' : b <N 0
    f' = canRemoveSuccFrom<N f

biggerThanCantDivideLemma : {a b : ℕ} → (a <N b) → (b ∣ a) → a ≡ 0
biggerThanCantDivideLemma {zero} {b} a<b b|a = refl
biggerThanCantDivideLemma {succ a} {zero} a<b (divides record { quot = quot ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = (inl (le x ())) } refl)
biggerThanCantDivideLemma {succ a} {zero} a<b (divides record { quot = quot ; rem = .0 ; pr = () ; remIsSmall = remIsSmall ; quotSmall = (inr x) } refl)
biggerThanCantDivideLemma {succ a} {succ b} a<b (divides record { quot = zero ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } refl) rewrite Semiring.commutative ℕSemiring (b *N zero) 0 | multiplicationNIsCommutative b 0 = exFalso (naughtE pr)
biggerThanCantDivideLemma {succ a} {succ b} a<b (divides record { quot = (succ quot) ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } refl) rewrite Semiring.commutative ℕSemiring (quot +N b *N succ quot) 0 | equalityCommutative pr = exFalso (positiveTimes {b} {quot} a<b)

biggerThanCantDivide : {a b : ℕ} → (x : ℕ) → (TotalOrder.max ℕTotalOrder a b) <N x → (x ∣ a) → (x ∣ b) → (a ≡ 0) && (b ≡ 0)
biggerThanCantDivide {a} {b} x pr x|a x|b with totality a b
biggerThanCantDivide {a} {b} x pr x|a x|b | inl (inl a<b) = exFalso (zeroNeverGreater f')
  where
    f : b ≡ 0
    f = biggerThanCantDivideLemma pr x|b
    f' : a <N 0
    f' rewrite equalityCommutative f = a<b
biggerThanCantDivide {a} {b} x pr x|a x|b | inl (inr b<a) = exFalso (zeroNeverGreater f')
  where
    f : a ≡ 0
    f = biggerThanCantDivideLemma pr x|a
    f' : b <N 0
    f' rewrite equalityCommutative f = b<a
biggerThanCantDivide {a} {b} x pr x|a x|b | inr a=b = (transitivity a=b f ,, f)
  where
    f : b ≡ 0
    f = biggerThanCantDivideLemma pr x|b

aDivA : (a : ℕ) → a ∣ a
aDivA zero = divides (record { quot = 0 ; rem = 0 ; pr = equalityCommutative (oneTimesPlusZero zero) ; remIsSmall = inr refl ; quotSmall = inr (refl ,, refl) }) refl
aDivA (succ a) = divides (record { quot = 1 ; rem = 0 ; pr = equalityCommutative (oneTimesPlusZero (succ a)) ; remIsSmall = inl (succIsPositive a) ; quotSmall = inl (succIsPositive a) }) refl

aDivZero : (a : ℕ) → a ∣ zero
aDivZero zero = aDivA zero
aDivZero (succ a) = divides (record { quot = zero ; rem = zero ; pr = lemma (succ a) ; remIsSmall = inl (succIsPositive a) ; quotSmall = inl (succIsPositive a) }) refl
  where
    lemma : (b : ℕ) → b *N zero +N zero ≡ zero
    lemma b rewrite (Semiring.sumZeroRight ℕSemiring (b *N zero)) = Semiring.productZeroRight ℕSemiring b

record extendedHcf (a b : ℕ) : Set where
  field
    hcf : hcfData a b
  c : ℕ
  c = hcfData.c hcf
  field
    extended1 : ℕ
    extended2 : ℕ
    extendedProof : (a *N extended1 ≡ b *N extended2 +N c) || (a *N extended1 +N c ≡ b *N extended2)

divEqualityLemma1 : {a b c : ℕ} → b ≡ zero → b *N c +N 0 ≡ a → a ≡ b
divEqualityLemma1 {a} {.0} {c} refl pr = equalityCommutative pr

divEquality : {a b : ℕ} → a ∣ b → b ∣ a → a ≡ b
divEquality {a} {b} (divides record { quot = quotAB ; rem = .0 ; pr = prAB ; remIsSmall = _ ; quotSmall = quotSmallAB } refl) (divides record { quot = quot ; rem = .0 ; pr = pr ; remIsSmall = _ ; quotSmall = (inl x) } refl) rewrite Semiring.commutative ℕSemiring (b *N quot) 0 | Semiring.commutative ℕSemiring (a *N quotAB) 0 | equalityCommutative pr | equalityCommutative (Semiring.*Associative ℕSemiring b quot quotAB) = res
  where
    lem : {b r : ℕ} → b *N r ≡ b → (0 <N b) → r ≡ 1
    lem {zero} {r} pr ()
    lem {succ b} {zero} pr _ rewrite multiplicationNIsCommutative b 0 = exFalso (naughtE pr)
    lem {succ b} {succ zero} pr _ = refl
    lem {succ b} {succ (succ r)} pr _ rewrite multiplicationNIsCommutative b (succ (succ r)) | Semiring.commutative ℕSemiring (succ r) (b +N (b +N r *N b)) | equalityCommutative (Semiring.+Associative ℕSemiring b (b +N r *N b) (succ r)) | Semiring.commutative ℕSemiring (b +N r *N b) (succ r) = exFalso (cannotAddAndEnlarge'' {succ b} pr)
    p : quot *N quotAB ≡ 1
    p = lem prAB x
    q : quot ≡ 1
    q = _&&_.fst (productOneImpliesOperandsOne p)
    res : b *N quot ≡ b
    res rewrite q | multiplicationNIsCommutative b 1 | Semiring.commutative ℕSemiring b 0 = refl
divEquality {.0} {.0} (divides record { quot = quotAB ; rem = .0 ; pr = prAB ; remIsSmall = _ ; quotSmall = quotSmallAB } refl) (divides record { quot = quot ; rem = .0 ; pr = refl ; remIsSmall = _ ; quotSmall = (inr (refl ,, snd)) } refl) = refl

hcfWelldefined : {a b : ℕ} → (ab : hcfData a b) → (ab' : hcfData a b) → (hcfData.c ab ≡ hcfData.c ab')
hcfWelldefined {a} {b} record { c = c ; c|a = c|a ; c|b = c|b ; hcf = hcf } record { c = c' ; c|a = c|a' ; c|b = c|b' ; hcf = hcf' } with hcf c' c|a' c|b'
... | c'DivC with hcf' c c|a c|b
... | cDivC' = divEquality cDivC' c'DivC

reverseHCF : {a b : ℕ} → (ab : extendedHcf a b) → extendedHcf b a
reverseHCF {a} {b} record { hcf = record { c = c ; c|a = c|a ; c|b = c|b ; hcf = hcf } ; extended1 = extended1 ; extended2 = extended2 ; extendedProof = (inl x) } = record { hcf = record { c = c ; c|a = c|b ; c|b = c|a ; hcf = λ x z z₁ → hcf x z₁ z } ; extended1 = extended2 ; extended2 = extended1 ; extendedProof = inr (equalityCommutative x) }
reverseHCF {a} {b} record { hcf = record { c = c ; c|a = c|a ; c|b = c|b ; hcf = hcf } ; extended1 = extended1 ; extended2 = extended2 ; extendedProof = (inr x) } = record { hcf = record { c = c ; c|a = c|b ; c|b = c|a ; hcf = λ x z z₁ → hcf x z₁ z } ; extended1 = extended2 ; extended2 = extended1 ; extendedProof = inl (equalityCommutative x) }

oneDivN : (a : ℕ) → 1 ∣ a
oneDivN a = divides (record { quot = a ; rem = zero ; pr = pr ; remIsSmall = inl (succIsPositive zero) ; quotSmall = inl (le zero refl) }) refl
  where
    pr : (a +N zero) +N zero ≡ a
    pr rewrite Semiring.sumZeroRight ℕSemiring (a +N zero) = Semiring.sumZeroRight ℕSemiring a

hcfZero : (a : ℕ) → extendedHcf zero a
hcfZero a = record { hcf = record { c = a ; c|a = aDivZero a ; c|b = aDivA a ; hcf = λ _ _ p → p } ; extended1 = 0 ; extended2 = 1 ; extendedProof = inr (equalityCommutative (Semiring.productOneRight ℕSemiring a))}

hcfOne : (a : ℕ) → extendedHcf 1 a
hcfOne a = record { hcf = record { c = 1 ; c|a = aDivA 1 ; c|b = oneDivN a ; hcf = λ _ z _ → z } ; extended1 = 1 ; extended2 = 0 ; extendedProof = inl g }
  where
    g : 1 ≡ a *N 0 +N 1
    g rewrite multiplicationNIsCommutative a 0 = refl

zeroIsValidRem : (a : ℕ) → (0 <N a) || (a ≡ 0)
zeroIsValidRem zero = inr refl
zeroIsValidRem (succ a) = inl (succIsPositive a)

dividesBothImpliesDividesSum : {a x y : ℕ} → a ∣ x → a ∣ y → a ∣ (x +N y)
dividesBothImpliesDividesSum {a} {x} {y} (divides record { quot = xDivA ; rem = .0 ; pr = prA ; quotSmall = qsm1 } refl) (divides record { quot = quot ; rem = .0 ; pr = pr ; quotSmall = qsm2 } refl) = divides (record { quot = xDivA +N quot ; rem = 0 ; pr = go {a} {x} {y} {xDivA} {quot} pr prA ; remIsSmall = zeroIsValidRem a ; quotSmall = (quotSmall qsm1 qsm2) }) refl
  where
    go : {a x y quot quot2 : ℕ} → (a *N quot2 +N zero ≡ y) → (a *N quot +N zero ≡ x) → a *N (quot +N quot2) +N zero ≡ x +N y
    go {a} {x} {y} {quot} {quot2} pr1 pr2 rewrite Semiring.sumZeroRight ℕSemiring (a *N quot) = identityOfIndiscernablesLeft _≡_ t (equalityCommutative (Semiring.sumZeroRight ℕSemiring (a *N (quot +N quot2))))
      where
        t : a *N (quot +N quot2) ≡ x +N y
        t rewrite Semiring.sumZeroRight ℕSemiring (a *N quot2) = transitivity (Semiring.+DistributesOver* ℕSemiring a quot quot2) p
          where
            s : a *N quot +N a *N quot2 ≡ x +N a *N quot2
            s = applyEquality (λ n → n +N a *N quot2) pr2
            r : x +N a *N quot2 ≡ x +N y
            r = applyEquality (λ n → x +N n) pr1
            p : a *N quot +N a *N quot2 ≡ x +N y
            p = transitivity s r
    quotSmall : ((0 <N a) || ((0 ≡ a) && (xDivA ≡ 0))) → ((0 <N a) || ((0 ≡ a) && (quot ≡ 0))) → (0 <N a) || ((0 ≡ a) && (xDivA +N quot ≡ 0))
    quotSmall (inl x1) (inl x2) = inl x1
    quotSmall (inl x1) (inr x2) = inl x1
    quotSmall (inr x1) (inl x2) = inl x2
    quotSmall (inr (a=0 ,, bl)) (inr (_ ,, bl2)) = inr (a=0 ,, ans)
      where
        ans : xDivA +N quot ≡ 0
        ans rewrite bl | bl2 = refl

dividesBothImpliesDividesDifference : {a b c : ℕ} → a ∣ b → a ∣ c → (c<b : c <N b) → a ∣ (subtractionNResult.result (-N (inl c<b)))
dividesBothImpliesDividesDifference {zero} {b} {.0} prab (divides record { quot = quot ; rem = .0 ; pr = refl } refl) c<b = prab
dividesBothImpliesDividesDifference {succ a} {b} {c} (divides record { quot = bDivSA ; rem = .0 ; pr = pr } refl) (divides record { quot = cDivSA ; rem = .0 ; pr = pr2 } refl) c<b rewrite (Semiring.sumZeroRight ℕSemiring (succ a *N cDivSA)) | (Semiring.sumZeroRight ℕSemiring (succ a *N bDivSA)) = divides (record { quot = subtractionNResult.result bDivSA-cDivSA ; rem = 0 ; pr = identityOfIndiscernablesLeft _≡_ (identityOfIndiscernablesLeft _≡_ s (equalityCommutative q)) (equalityCommutative (Semiring.sumZeroRight ℕSemiring _)) ; remIsSmall = inl (succIsPositive a) ; quotSmall = inl (succIsPositive a) }) refl
  where
    p : cDivSA <N bDivSA
    p rewrite (equalityCommutative pr2) | (equalityCommutative pr) = cancelInequalityLeft {succ a} {cDivSA} {bDivSA} c<b
    bDivSA-cDivSA : subtractionNResult cDivSA bDivSA (inl p)
    bDivSA-cDivSA = -N {cDivSA} {bDivSA} (inl p)
    la-ka = subtractionNResult.result (-N {succ a *N cDivSA} {succ a *N bDivSA} (inl (lessRespectsMultiplicationLeft cDivSA bDivSA (succ a) p (succIsPositive a))))
    q : (succ a *N (subtractionNResult.result bDivSA-cDivSA)) ≡ la-ka
    q = subtractProduct {succ a} {cDivSA} {bDivSA} (succIsPositive a) p
    s : la-ka ≡ subtractionNResult.result (-N {c} {b} (inl c<b))
    s = equivalentSubtraction (succ a *N cDivSA) b (succ a *N bDivSA) c (lessRespectsMultiplicationLeft cDivSA bDivSA (succ a) p (succIsPositive a)) c<b g
      where
        g : (succ a *N cDivSA) +N b ≡ (succ a *N bDivSA) +N c
        g rewrite equalityCommutative pr2 | equalityCommutative pr = Semiring.commutative ℕSemiring (cDivSA +N a *N cDivSA) (bDivSA +N a *N bDivSA)

euclidLemma1 : {a b : ℕ} → (a<b : a <N b) → (t : ℕ) → a +N b <N t → a +N (subtractionNResult.result (-N (inl a<b))) <N t
euclidLemma1 {zero} {b} zero<b t b<t = b<t
euclidLemma1 {succ a} {b} sa<b t sa+b<t = identityOfIndiscernablesLeft _<N_ q (Semiring.commutative ℕSemiring (subtractionNResult.result (-N (inl sa<b))) (succ a))
  where
    p : b <N t
    p = TotalOrder.<Transitive ℕTotalOrder (le a refl) sa+b<t
    q : (subtractionNResult.result (-N (inl sa<b))) +N succ a <N t
    q = identityOfIndiscernablesLeft _<N_ p (equalityCommutative (addMinus (inl sa<b)))

euclidLemma2 : {a b max : ℕ} → (succ (a +N b) <N max) → b <N max
euclidLemma2 {a} {b} {max} pr = lessTransitive {b} {succ (a +N b)} {max} (lemma a b) pr
  where
    lemma : (a b : ℕ) → b <N succ (a +N b)
    lemma a b rewrite Semiring.commutative ℕSemiring (succ a) b = addingIncreases b a

euclidLemma3 : {a b max : ℕ} → (succ (succ (a +N b)) <N max) → succ b <N max
euclidLemma3 {a} {b} {max} pr = euclidLemma2 {a} {succ b} {max} (identityOfIndiscernablesLeft _<N_ pr (applyEquality succ (equalityCommutative (succExtracts a b))))

euclidLemma4 : (a b c d h : ℕ) → (sa<b : (succ a) <N b) → (pr : subtractionNResult.result (-N (inl sa<b)) *N c ≡ (succ a) *N d +N h) → b *N c ≡ (succ a) *N (d +N c) +N h
euclidLemma4 a b zero d h sa<b pr rewrite Semiring.sumZeroRight ℕSemiring d | Semiring.productZeroRight ℕSemiring b | Semiring.productZeroRight ℕSemiring (subtractionNResult.result (-N (inl sa<b))) = pr
euclidLemma4 a b (succ c) d h sa<b pr rewrite subtractProduct' (succIsPositive c) sa<b = transitivity q' r'
  where
    q : (succ c) *N b ≡ succ (a +N c *N succ a) +N ((succ a) *N d +N h)
    q = moveOneSubtraction {succ (a +N c *N succ a)} {b +N c *N b} {(succ a) *N d +N h} {inl _} pr
    q' : b *N succ c ≡ succ (a +N c *N succ a) +N ((succ a) *N d +N h)
    q' rewrite multiplicationNIsCommutative b (succ c) = q
    r' : ((succ c) *N succ a) +N (((succ a) *N d) +N h) ≡ ((succ a) *N (d +N succ c)) +N h
    r' rewrite Semiring.+Associative ℕSemiring ((succ c) *N succ a) ((succ a) *N d) h = applyEquality (λ t → t +N h) {((succ c) *N succ a) +N ((succ a) *N d)} {(succ a) *N (d +N succ c)} (go (succ c) (succ a) d)
      where
        go' : (a b c : ℕ) → b *N a +N b *N c ≡ b *N (c +N a)
        go : (a b c : ℕ) → a *N b +N b *N c ≡ b *N (c +N a)
        go a b c rewrite multiplicationNIsCommutative a b = go' a b c
        go' a b c rewrite Semiring.commutative ℕSemiring (b *N a) (b *N c) = equalityCommutative (Semiring.+DistributesOver* ℕSemiring b c a)

euclidLemma5 : (a b c d h : ℕ) → (sa<b : (succ a) <N b) → (pr : subtractionNResult.result (-N (inl sa<b)) *N c +N h ≡ (succ a) *N d) → (succ a) *N (d +N c) ≡ b *N c +N h
euclidLemma5 a b c d h sa<b pr with (-N (inl sa<b))
euclidLemma5 a b zero d h sa<b pr | record { result = result ; pr = sub } rewrite Semiring.sumZeroRight ℕSemiring d | Semiring.productZeroRight ℕSemiring b | Semiring.productZeroRight ℕSemiring result = equalityCommutative pr
euclidLemma5 a b (succ c) d h sa<b pr | record { result = result ; pr = sub } rewrite subtractProduct' (succIsPositive c) sa<b | equalityCommutative sub = pv''
  where
    p : succ a *N d ≡ result *N succ c +N h
    p = equalityCommutative pr
    p' : a *N succ c +N succ a *N d ≡ (a *N succ c) +N ((result *N succ c) +N h)
    p' = applyEquality (λ t → a *N succ c +N t) p
    p'' : a *N succ c +N succ a *N d ≡ (a *N succ c +N result *N succ c) +N h
    p'' rewrite equalityCommutative (Semiring.+Associative ℕSemiring (a *N succ c) (result *N succ c) h) = p'
    p''' : a *N succ c +N succ a *N d ≡ (a +N result) *N succ c +N h
    p''' rewrite multiplicationNIsCommutative (a +N result) (succ c) | Semiring.+DistributesOver* ℕSemiring (succ c) a result | multiplicationNIsCommutative (succ c) a | multiplicationNIsCommutative (succ c) result = p''
    pv : c +N (a *N succ c +N succ a *N d) ≡ (c +N (a +N result) *N succ c) +N h
    pv rewrite equalityCommutative (Semiring.+Associative ℕSemiring c ((a +N result) *N succ c) h) = applyEquality (λ t → c +N t) p'''
    pv' : (succ c) +N (a *N succ c +N succ a *N d) ≡ succ ((c +N (a +N result) *N succ c) +N h)
    pv' = applyEquality succ pv
    pv'' : (succ a) *N (d +N succ c) ≡ succ ((c +N (a +N result) *N succ c) +N h)
    pv'' = identityOfIndiscernablesLeft _≡_ pv' (go a c d)
      where
        go : (a c d : ℕ) → (succ c) +N (a *N succ c +N ((succ a) *N d)) ≡ (succ a) *N (d +N succ c)
        go a c d rewrite Semiring.+Associative ℕSemiring (succ c) (a *N succ c) ((succ a) *N d) = go'
          where
            go' : (succ a) *N (succ c) +N (succ a) *N d ≡ (succ a) *N (d +N succ c)
            go' rewrite Semiring.commutative ℕSemiring d (succ c) = equalityCommutative (Semiring.+DistributesOver* ℕSemiring (succ a) (succ c) d)

euclid : (a b : ℕ) → extendedHcf a b
euclid a b = inducted (succ a +N b) a b (a<SuccA (a +N b))
  where
    P : ℕ → Set
    P sum = ∀ (a b : ℕ) → a +N b <N sum → extendedHcf a b
    go'' : {a b : ℕ} → (maxsum : ℕ) → (a <N b) → (a +N b <N maxsum) → (∀ y → y <N maxsum → P y) → extendedHcf a b
    go'' {zero} {b} maxSum zero<b b<maxsum indHyp = hcfZero b
    go'' {1} {b} maxSum 1<b b<maxsum indHyp = hcfOne b
    go'' {succ (succ a)} {b} maxSum ssa<b ssa+b<maxsum indHyp with (indHyp (succ b) (euclidLemma3 {a} {b} {maxSum} ssa+b<maxsum)) (subtractionNResult.result (-N (inl ssa<b))) (succ (succ a)) (identityOfIndiscernablesLeft _<N_ (a<SuccA b) (equalityCommutative (addMinus (inl ssa<b))))
    go'' {succ (succ a)} {b} maxSum ssa<b ssa+b<maxsum indHyp | record { hcf = record { c = c ; c|a = c|a ; c|b = c|b ; hcf = hcf } ; extended1 = extended1 ; extended2 = extended2 ; extendedProof = inl extendedProof } = record { hcf = record { c = c ; c|a = c|b ; c|b = hcfDivB'' ; hcf = λ div prDivSSA prDivB → hcf div (dividesBothImpliesDividesDifference prDivB prDivSSA ssa<b) prDivSSA } ; extended2 = extended1; extended1 = extended2 +N extended1 ; extendedProof = inr (equalityCommutative (euclidLemma4 (succ a) b extended1 extended2 c ssa<b extendedProof)) }
      where
        hcfDivB : c ∣ ((succ (succ a)) +N (subtractionNResult.result (-N (inl ssa<b))))
        hcfDivB = dividesBothImpliesDividesSum {c} {succ (succ a)} { subtractionNResult.result (-N (inl ssa<b))} c|b c|a
        hcfDivB' : c ∣ ((subtractionNResult.result (-N (inl ssa<b))) +N (succ (succ a)))
        hcfDivB' = identityOfIndiscernablesRight _∣_ hcfDivB (Semiring.commutative ℕSemiring (succ (succ a)) ( subtractionNResult.result (-N (inl ssa<b))))
        hcfDivB'' : c ∣ b
        hcfDivB'' = identityOfIndiscernablesRight _∣_ hcfDivB' (addMinus (inl ssa<b))
    go'' {succ (succ a)} {b} maxSum ssa<b ssa+b<maxsum indHyp | record { hcf = record { c = c ; c|a = c|a ; c|b = c|b ; hcf = hcf } ; extended1 = extended1 ; extended2 = extended2 ; extendedProof = inr extendedProof } = record { hcf = record { c = c ; c|a = c|b ; c|b = hcfDivB'' ; hcf = λ div prDivSSA prDivB → hcf div (dividesBothImpliesDividesDifference prDivB prDivSSA ssa<b) prDivSSA } ; extended2 = extended1; extended1 = extended2 +N extended1 ; extendedProof = inl (euclidLemma5 (succ a) b extended1 extended2 c ssa<b extendedProof) }
      where
        hcfDivB : c ∣ ((succ (succ a)) +N (subtractionNResult.result (-N (inl ssa<b))))
        hcfDivB = dividesBothImpliesDividesSum {c} {succ (succ a)} { subtractionNResult.result (-N (inl ssa<b))} c|b c|a
        hcfDivB' : c ∣ ((subtractionNResult.result (-N (inl ssa<b))) +N (succ (succ a)))
        hcfDivB' = identityOfIndiscernablesRight _∣_ hcfDivB (Semiring.commutative ℕSemiring (succ (succ a)) (subtractionNResult.result (-N (inl ssa<b))))
        hcfDivB'' : c ∣ b
        hcfDivB'' = identityOfIndiscernablesRight _∣_ hcfDivB' (addMinus (inl ssa<b))
    go' : (maxSum a b : ℕ) → (a +N b <N maxSum) → (∀ y → y <N maxSum → P y) → extendedHcf a b
    go' maxSum a b a+b<maxsum indHyp with totality a b
    go' maxSum a b a+b<maxsum indHyp | inl (inl a<b) = go'' maxSum a<b a+b<maxsum indHyp
    go' maxSum a b a+b<maxsum indHyp | inl (inr b<a) = reverseHCF (go'' maxSum b<a (identityOfIndiscernablesLeft _<N_ a+b<maxsum (Semiring.commutative ℕSemiring a b)) indHyp)
    go' maxSum a .a _ indHyp | inr refl = record { hcf = record { c = a ; c|a = aDivA a ; c|b = aDivA a ; hcf = λ _ _ z → z } ; extended1 = 0 ; extended2 = 1 ; extendedProof = inr s}
      where
        s : a *N zero +N a ≡ a *N 1
        s rewrite multiplicationNIsCommutative a zero | Semiring.productOneRight ℕSemiring a = refl
    go : ∀ x → (∀ y → y <N x → P y) → P x
    go maxSum indHyp = λ a b a+b<maxSum → go' maxSum a b a+b<maxSum indHyp
    inducted : ∀ x → P x
    inducted = rec <NWellfounded P go

divOneImpliesOne : {a : ℕ} → a ∣ 1 → a ≡ 1
divOneImpliesOne {zero} a|1 = exFalso (zeroDividesNothing _ a|1)
divOneImpliesOne {succ zero} a|1 = refl
divOneImpliesOne {succ (succ a)} (divides record { quot = zero ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } refl) rewrite Semiring.sumZeroRight ℕSemiring (a *N zero) | multiplicationNIsCommutative a 0 = exFalso (naughtE pr)
divOneImpliesOne {succ (succ a)} (divides record { quot = (succ quot) ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } refl) rewrite Semiring.commutative ℕSemiring quot (succ (quot +N a *N succ quot)) = exFalso (naughtE (equalityCommutative (succInjective pr)))


module Structure.Relator.Properties where

open import Functional
import      Lvl
open import Lang.Instance
open import Logic
import      Structure.Relator.Names as Names
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Lvl.Level
private variable T A B C D E : Type{ℓ}

-- Definition of a reflexive binary relation
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record Reflexivity : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Reflexivity(_▫_)
  reflexivity = inst-fn Reflexivity.proof

-- Definition of a transitive binary relation
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record Transitivity : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Transitivity(_▫_)
  transitivity = inst-fn Transitivity.proof

-- Definition of a antisymmetric binary relation
module _ {T : Type{ℓ₁}} (_▫₁_ : T → T → Stmt{ℓ₂}) (_▫₂_ : T → T → Stmt{ℓ₃}) where
  record Antisymmetry : Stmt{ℓ₁ Lvl.⊔ ℓ₂ Lvl.⊔ ℓ₃} where
    constructor intro
    field proof : Names.Antisymmetry(_▫₁_)(_▫₂_)
  antisymmetry = inst-fn Antisymmetry.proof

-- Definition of a irreflexive binary relation
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record Irreflexivity : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Irreflexivity(_▫_)
  irreflexivity = inst-fn Irreflexivity.proof

-- Definition of a total binary relation.
-- Total in the sense that it, or its converse, holds.
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record ConverseTotal : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.ConverseTotal(_▫_)
  converseTotal = inst-fn ConverseTotal.proof

-- Definition of a converse dichotomy.
-- It or its converse always holds, but never both at the same time.
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record ConverseDichotomy : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.ConverseDichotomy(_▫_)
  dichotomy = inst-fn ConverseDichotomy.proof

module _ {T : Type{ℓ₁}} (_▫₁_ : T → T → Stmt{ℓ₂}) (_▫₂_ : T → T → Stmt{ℓ₃}) where
  record ConverseTrichotomy : Stmt{ℓ₁ Lvl.⊔ ℓ₂ Lvl.⊔ ℓ₃} where
    constructor intro
    field proof : Names.ConverseTrichotomy(_▫₁_)(_▫₂_)
  trichotomy = inst-fn ConverseTrichotomy.proof

-- Definition of a converse binary operation for a binary operation
-- record Converse {T₁ T₂ : Type} (_▫₁_ : T₁ → T₂ → Stmt) (_▫₂_ : T₂ → T₁ → Stmt) : Stmt where
--   constructor intro
--
--   field
--     converseₗ : Names.ConversePattern (_▫₂_) (_▫₁_)
--     converseᵣ : Names.ConversePattern (_▫₁_) (_▫₂_)
-- open Converse ⦃ ... ⦄ public
-- {x : T₁}{y : T₂} → (x ▫₁ y) ↔ (y ▫₂ x)

-- Definition of a symmetric binary operation
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record Symmetry : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Symmetry(_▫_)
  symmetry = inst-fn Symmetry.proof
-- {x y : T} → (x ▫ y) → (y ▫ x)

-- Definition of an asymmetric binary operation
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record Asymmetry : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Asymmetry(_▫_)
  asymmetry = inst-fn Asymmetry.proof
-- {x y : T} → (x ▫ y) → ¬(y ▫ x)

module _ (_▫₁_ : A → B → Stmt{ℓ₁}) (_▫₂_ : A → B → Stmt{ℓ₂}) where
  record _⊆₂_ : Stmt{Lvl.of(A) Lvl.⊔ Lvl.of(B) Lvl.⊔ ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Subrelation(_▫₁_)(_▫₂_)
  sub₂ = inst-fn _⊆₂_.proof

module _ (_▫₁_ : A → B → Stmt{ℓ₁}) (_▫₂_ : A → B → Stmt{ℓ₂}) where
  _⊇₂_ = (_▫₂_) ⊆₂ (_▫₁_)
  module _⊇₂_ inst = _⊆₂_ {_▫₁_ = _▫₂_}{_▫₂_ = _▫₁_} inst
  super₂ = inst-fn _⊇₂_.proof

module _ (_▫₁_ : A → B → Stmt{ℓ₁}) (_▫₂_ : A → A → Stmt{ℓ₂}) where
  record Subtransitivityₗ : Stmt{Lvl.of(A) Lvl.⊔ Lvl.of(B) Lvl.⊔ ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Subtransitivityₗ(_▫₁_)(_▫₂_)
  subtransitivityₗ = inst-fn Subtransitivityₗ.proof

module _ (_▫₁_ : A → B → Stmt{ℓ₁}) (_▫₂_ : B → B → Stmt{ℓ₂}) where
  record Subtransitivityᵣ : Stmt{Lvl.of(A) Lvl.⊔ Lvl.of(B) Lvl.⊔ ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.Subtransitivityᵣ(_▫₁_)(_▫₂_)
  subtransitivityᵣ = inst-fn Subtransitivityᵣ.proof

-- Definition of a cotransitive binary relation
module _ {T : Type{ℓ₁}} (_▫_ : T → T → Stmt{ℓ₂}) where
  record CoTransitivity : Stmt{ℓ₁ Lvl.⊔ ℓ₂} where
    constructor intro
    field proof : Names.CoTransitivity(_▫_)
  cotransitivity = inst-fn CoTransitivity.proof


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

module _ where

postulate
  _≡_ : {A : Set} → A → A → Set

{-# BUILTIN REWRITE _≡_ #-}

record ⊤ : Set where
  constructor []
open ⊤

postulate
  ID : (Δ : Set) (δ₀ δ₁ : Δ) → Set
  ID⊤ : (δ₀ δ₁ : ⊤) → ID ⊤ δ₀ δ₁ ≡ ⊤
  Id : {Δ : Set} (A : Δ → Set) {δ₀ δ₁ : Δ} (δ₂ : ID Δ δ₀ δ₁) (a₀ : A δ₀) (a₁ : A δ₁) → Set
  ap : {Δ : Set} {A : Δ → Set} (f : (δ : Δ) → A δ) {δ₀ δ₁ : Δ} (δ₂ : ID Δ δ₀ δ₁) → Id A δ₂ (f δ₀) (f δ₁)
  AP : {Θ Δ : Set} (f : Θ → Δ) {t₀ t₁ : Θ} (t₂ : ID Θ t₀ t₁) → ID Δ (f t₀) (f t₁)
  Id-AP : {Θ Δ : Set} (f : Θ → Δ) {t₀ t₁ : Θ} (t₂ : ID Θ t₀ t₁) (A : Δ → Set) (a₀ : A (f t₀)) (a₁ : A (f t₁)) →
    Id A (AP f t₂) a₀ a₁ ≡ Id (λ w → A (f w)) t₂ a₀ a₁
  Copy : Set → Set
  uncopy : {A : Set} → Copy A → A

{-# REWRITE ID⊤ #-}
{-# REWRITE Id-AP #-}

postulate
  utr→ : {Δ : Set} (A : Δ → Set) {δ₀ δ₁ : Δ} (δ₂ : ID Δ δ₀ δ₁) (a₁ a₁' : A δ₁) → Id {⊤} (λ _ → A δ₁) [] a₁ a₁'
  IdU : {Δ : Set} {δ₀ δ₁ : Δ} (δ₂ : ID Δ δ₀ δ₁) (A B : Set) →
    Id {Δ} (λ _ → Set) δ₂ A B ≡ Copy ((b₀ : B) (b₁ : B) → Id {⊤} (λ _ → B) [] b₀ b₁)

{-# REWRITE IdU #-}

postulate
  apU : {Δ : Set} (A : Δ → Set) {δ₀ δ₁ : Δ} (δ₂ : ID Δ δ₀ δ₁) → uncopy (ap A δ₂) ≡ utr→ A δ₂

{-# REWRITE apU #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Instantiates the ring solver, using the natural numbers as the
-- coefficient "ring"
------------------------------------------------------------------------

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

open import Algebra
import Algebra.Operations.Semiring as SemiringOps
open import Data.Maybe.Base using (Maybe; just; nothing; map)

module Algebra.Solver.Ring.NaturalCoefficients
         {r₁ r₂}
         (R : CommutativeSemiring r₁ r₂)
         (dec : let open CommutativeSemiring R
                    open SemiringOps semiring in
                ∀ m n → Maybe (m × 1# ≈ n × 1#)) where

import Algebra.Solver.Ring
open import Algebra.Solver.Ring.AlmostCommutativeRing
open import Data.Nat.Base as ℕ
open import Data.Product using (module Σ)
open import Function

open CommutativeSemiring R
open SemiringOps semiring
open import Relation.Binary.Reasoning.Setoid setoid

private

  -- The coefficient "ring".

  ℕ-ring : RawRing _
  ℕ-ring = record
    { Carrier = ℕ
    ; _+_     = ℕ._+_
    ; _*_     = ℕ._*_
    ; -_      = id
    ; 0#      = 0
    ; 1#      = 1
    }

  -- There is a homomorphism from ℕ to R.
  --
  -- Note that _×′_ is used rather than _×_. If _×_ were used, then
  -- Function.Related.TypeIsomorphisms.test would fail to type-check.

  homomorphism :
    ℕ-ring -Raw-AlmostCommutative⟶ fromCommutativeSemiring R
  homomorphism = record
    { ⟦_⟧    = λ n → n ×′ 1#
    ; +-homo = ×′-homo-+ 1#
    ; *-homo = ×′1-homo-*
    ; -‿homo = λ _ → refl
    ; 0-homo = refl
    ; 1-homo = refl
    }

  -- Equality of certain expressions can be decided.

  dec′ : ∀ m n → Maybe (m ×′ 1# ≈ n ×′ 1#)
  dec′ m n = map to (dec m n)
    where
    to : m × 1# ≈ n × 1# → m ×′ 1# ≈ n ×′ 1#
    to m≈n = begin
      m ×′ 1#  ≈⟨ sym $ ×≈×′ m 1# ⟩
      m ×  1#  ≈⟨ m≈n ⟩
      n ×  1#  ≈⟨ ×≈×′ n 1# ⟩
      n ×′ 1#  ∎

-- The instantiation.

open Algebra.Solver.Ring _ _ homomorphism dec′ public


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

module SymmetricMonoidalCategory where

open import Level

open import Categories.Category using (Category)
open import Categories.Monoidal using (Monoidal)
open import Categories.Monoidal.Braided using (Braided; module Braided)
open import Categories.NaturalIsomorphism using (module NaturalIsomorphism)
open import Categories.NaturalTransformation using (id; _∘₁_; _≡_)

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

record SymmetricMonoidalCategory {o ℓ e} {ℂ  : Category o ℓ e} {Mℂ : Monoidal ℂ}
  (BMℂ : Braided Mℂ) : Set (suc (o ⊔ ℓ ⊔ e)) where
  open Braided BMℂ using (braid)
  open NaturalIsomorphism braid using () renaming (F⇒G to x⊗y⇒y⊗x; F⇐G to y⊗x⇒x⊗y)
  field
    symmetry : y⊗x⇒x⊗y ∘₁ x⊗y⇒y⊗x ≡ id

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


module Monad where

open import Level

open import Category
import Functor
import Nat
import Adjoint

open Category.Category
open Functor.Functor
open Nat.Export
open Nat.Nat
open Adjoint.Export

record Monad {c₀ c₁ ℓ} (C : Category c₀ c₁ ℓ) : Set (suc (c₀ ⊔ c₁ ⊔ ℓ)) where
  field
    MFunctor : Functor.Functor C C
    Mjoin : Nat.Nat (Functor.exp MFunctor 2) MFunctor
    Munit : Nat.Nat (Functor.identity C) MFunctor

  field
    join_join : {A : Obj C} → C [ C [ component Mjoin A ∘ component Mjoin (fobj MFunctor A) ] ≈ C [ component Mjoin A ∘ fmap MFunctor (component Mjoin A) ] ]
    unit_MFunctor : {A : Obj C} → C [ C [ component Mjoin A ∘ component Munit (fobj MFunctor A) ] ≈ id C ]
    MFunctor_unit : {A : Obj C} → C [ C [ component Mjoin A ∘ fmap MFunctor (component Munit A) ] ≈ id C ]

Adjoint-Monad : ∀ {C₀ C₁ ℓ} {C D : Category C₀ C₁ ℓ} {F : Functor.Functor C D} {G : Functor.Functor D C} → F ⊣ G → Monad C
Adjoint-Monad {C = C} {D} {F} {G} F⊣G = record {
  MFunctor = T;
  Mjoin = record {
    component = λ X → component (G F∘N ε N∘F F) X ;
    naturality = λ {a} {b} {f} → begin⟨ C ⟩
      C [ component (G F∘N ε N∘F F) b ∘ fmap G (fmap (Functor.compose F T) f) ] ≈⟨ sym-hom C (preserveComp G) ⟩
      fmap G (D [ component ε (fobj F b) ∘ fmap (Functor.compose F G) (fmap F f) ]) ≈⟨ Functor.preserveEq G (naturality ε) ⟩
      fmap G (D [ fmap F f ∘ component ε (fobj F a) ]) ≈⟨ preserveComp G ⟩
      C [ fmap T f ∘ component (G F∘N ε N∘F F) a ]
      ∎ };
  Munit = Adjoint.unit F⊣G;
  join_join = λ {A} → begin⟨ C ⟩
    C [ component (G F∘N ε N∘F F) A ∘ component (G F∘N ε N∘F F) (fobj T A) ] ≈⟨ sym-hom C (preserveComp G) ⟩
    fmap G (D [ component ε (fobj F A) ∘ component ε (fobj (Functor.compose F G) (fobj F A)) ]) ≈⟨ Functor.preserveEq G (sym-hom D (naturality ε)) ⟩
    fmap G (D [ component ε (fobj F A) ∘ fmap (Functor.compose F G) (component ε (fobj F A)) ]) ≈⟨ preserveComp G ⟩
    C [ component (G F∘N ε N∘F F) A ∘ fmap T (component (G F∘N ε N∘F F) A) ]
    ∎ ;
  unit_MFunctor = λ {A} → begin⟨ C ⟩
    C [ component (G F∘N ε N∘F F) A ∘ component η (fobj T A) ] ≈⟨ refl-hom C ⟩
    C [ component (G F∘N ε) (fobj F A) ∘ component (η N∘F G) (fobj F A) ] ≈⟨ sym-hom C (≈-composite C (leftId C) (trans-hom C (leftId C) (rightId C))) ⟩
    C [ C [ id C ∘ component (G F∘N ε) (fobj F A) ] ∘ C [ id C ∘ C [ component (η N∘F G) (fobj F A) ∘ id C ] ] ] ≈⟨ refl-hom C ⟩
    component (Nat.compose (Nat.compose {H = G} Nat.rightIdNat→ (G F∘N ε)) (Nat.compose (Nat.assocNat→ {F = G} {F} {G}) (Nat.compose (η N∘F G) Nat.leftIdNat←))) (fobj F A) ≈⟨ Adjoint.triangularR F⊣G {fobj F A} ⟩
    component (id [ D , C ] {G}) (fobj F A) ≈⟨ refl-hom C ⟩
    id C
    ∎ ;
  MFunctor_unit = λ {A} → begin⟨ C ⟩
    C [ component (G F∘N ε N∘F F) A ∘ fmap T (component η A) ] ≈⟨ refl-hom C ⟩
    C [ fmap G (component ε (fobj F A)) ∘ fmap G (fmap F (component η A)) ] ≈⟨ sym-hom C (preserveComp G) ⟩
    fmap G (D [ component ε (fobj F A) ∘ fmap F (component η A) ]) ≈⟨ Functor.preserveEq G (≈-composite D (sym-hom D (leftId D)) (sym-hom D (trans-hom D (leftId D) (rightId D)))) ⟩
    fmap G (D [ D [ id D ∘ component ε (fobj F A) ] ∘ D [ id D ∘ D [ fmap F (component η A) ∘ id D ] ] ]) ≈⟨ Functor.preserveEq G (refl-hom D) ⟩
    fmap G (component (Nat.compose (Nat.compose Nat.leftIdNat→ (Adjoint.counit F⊣G N∘F F)) (Nat.compose {F = F} (Nat.assocNat← {F = F} {G} {F}) (Nat.compose {F = F} (F F∘N Adjoint.unit F⊣G) Nat.rightIdNat←))) A ) ≈⟨ Functor.preserveEq G (Adjoint.triangularL F⊣G {A}) ⟩
    fmap G (component (id [ C , D ] {F}) A) ≈⟨ preserveId G ⟩
    id C
    ∎ }
  where
    T = Functor.compose G F
    η = Adjoint.unit F⊣G
    ε = Adjoint.counit F⊣G


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of Any predicate transformer for fresh lists
------------------------------------------------------------------------

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

module Data.List.Fresh.Relation.Unary.Any.Properties where

open import Level using (Level; _⊔_; Lift)
open import Data.Bool.Base using (true; false)
open import Data.Empty
open import Data.Nat.Base using (ℕ; zero; suc)
open import Data.Product using (_,_)
open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂)
open import Function using (_∘′_)
open import Relation.Nullary.Reflects using (invert)
open import Relation.Nullary
open import Relation.Unary  as U using (Pred)
open import Relation.Binary as B using (Rel)
open import Relation.Nary
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong)

open import Data.List.Fresh
open import Data.List.Fresh.Relation.Unary.All
open import Data.List.Fresh.Relation.Unary.Any

private
  variable
    a b p q r s : Level
    A : Set a
    B : Set b

------------------------------------------------------------------------
-- NonEmpty

module _ {R : Rel A r} {P : Pred A p} where

  Any⇒NonEmpty : {xs : List# A R} → Any P xs → NonEmpty xs
  Any⇒NonEmpty {xs = cons x xs pr} p  = cons x xs pr

------------------------------------------------------------------------
-- Correspondence between Any and All

module _ {R : Rel A r} {P : Pred A p} {Q : Pred A q} (P⇒¬Q : ∀[ P ⇒ ∁ Q ]) where

  Any⇒¬All : {xs : List# A R} → Any P xs → ¬ (All Q xs)
  Any⇒¬All (here p)   (q ∷ _)  = P⇒¬Q p q
  Any⇒¬All (there ps) (_ ∷ qs) = Any⇒¬All ps qs

  All⇒¬Any : {xs : List# A R} → All P xs → ¬ (Any Q xs)
  All⇒¬Any (p ∷ _)  (here q)   = P⇒¬Q p q
  All⇒¬Any (_ ∷ ps) (there qs) = All⇒¬Any ps qs

module _ {R : Rel A r} {P : Pred A p} {Q : Pred A q} (P? : Decidable P) where

  ¬All⇒Any : {xs : List# A R} → ¬ (All P xs) → Any (∁ P) xs
  ¬All⇒Any {xs = []}      ¬ps = ⊥-elim (¬ps [])
  ¬All⇒Any {xs = x ∷# xs} ¬ps with P? x
  ... |  true because  [p] = there (¬All⇒Any (¬ps ∘′ (invert [p] ∷_)))
  ... | false because [¬p] = here (invert [¬p])

  ¬Any⇒All : {xs : List# A R} → ¬ (Any P xs) → All (∁ P) xs
  ¬Any⇒All {xs = []}      ¬ps = []
  ¬Any⇒All {xs = x ∷# xs} ¬ps with P? x
  ... |  true because  [p] = ⊥-elim (¬ps (here (invert [p])))
  ... | false because [¬p] = invert [¬p] ∷ ¬Any⇒All (¬ps ∘′ there)

------------------------------------------------------------------------
-- remove

module _ {R : Rel A r} {P : Pred A p} where

  length-remove : {xs : List# A R} (k : Any P xs) →
    length xs ≡ suc (length (xs ─ k))
  length-remove (here _)  = refl
  length-remove (there p) = cong suc (length-remove p)

------------------------------------------------------------------------
-- append

module _ {R : Rel A r} {P : Pred A p} where

  append⁺ˡ : {xs ys : List# A R} {ps : All (_# ys) xs} →
             Any P xs → Any P (append xs ys ps)
  append⁺ˡ (here px) = here px
  append⁺ˡ (there p) = there (append⁺ˡ p)

  append⁺ʳ : {xs ys : List# A R} {ps : All (_# ys) xs} →
             Any P ys → Any P (append xs ys ps)
  append⁺ʳ {xs = []}      p = p
  append⁺ʳ {xs = x ∷# xs} p = there (append⁺ʳ p)

  append⁻ : ∀ xs {ys : List# A R} {ps : All (_# ys) xs} →
            Any P (append xs ys ps) → Any P xs ⊎ Any P ys
  append⁻ []        p         = inj₂ p
  append⁻ (x ∷# xs) (here px) = inj₁ (here px)
  append⁻ (x ∷# xs) (there p) = Sum.map₁ there (append⁻ xs p)


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

-- The basic CBPV metalanguage, extended with parallelism.

open import Calf.CostMonoid

module Calf.ParMetalanguage (parCostMonoid : ParCostMonoid) where

open ParCostMonoid parCostMonoid

open import Calf.Prelude
open import Calf.Metalanguage
open import Calf.Step costMonoid

open import Calf.Types.Eq
open import Calf.Types.Bounded costMonoid

open import Data.Product
open import Relation.Binary.PropositionalEquality

postulate
  _&_ : {A₁ A₂ : tp pos} → cmp (F A₁) → cmp (F A₂) → cmp (F (Σ++ A₁ (λ _ → A₂)))

  &/join : ∀ {A₁ A₂} {v₁ v₂ p₁ p₂} →
    step (F A₁) p₁ (ret v₁) & step (F A₂) p₂ (ret v₂) ≡ step (F (Σ++ A₁ λ _ → A₂)) (p₁ ⊗ p₂) (ret (v₁ , v₂))
  {-# REWRITE &/join #-}

&/join/𝟘 : ∀ {A₁ A₂} {v₁ v₂} →
  ret v₁ & ret v₂ ≡ step (F (Σ++ A₁ λ _ → A₂)) (𝟘 ⊗ 𝟘) (ret (v₁ , v₂))
&/join/𝟘 = &/join {p₁ = 𝟘} {p₂ = 𝟘}
{-# REWRITE &/join/𝟘 #-}

bind/& : ∀ {A₁ A₂} {X} {v₁ v₂ f} (p₁ p₂ : ℂ) →
  bind {Σ++ A₁ λ _ → A₂} X (step (F A₁) p₁ (ret v₁) & step (F A₂) p₂ (ret v₂)) f ≡ step X (p₁ ⊗ p₂) (f (v₁ , v₂))
bind/& _ _ = refl

bound/par : {A₁ A₂ : tp pos} {e₁ : cmp (F A₁)} {e₂ : cmp (F A₂)} {c₁ c₂ : ℂ} →
  IsBounded A₁ e₁ c₁ →
  IsBounded A₂ e₂ c₂ →
  IsBounded (Σ++ A₁ λ _ → A₂) (e₁ & e₂) (c₁ ⊗ c₂)
bound/par (⇓ a₁ withCost p₁' [ h-bounded₁ , h-≡₁ ]) (⇓ a₂ withCost p₂' [ h-bounded₂ , h-≡₂ ]) with eq/ref h-≡₁ | eq/ref h-≡₂
... | refl | refl = ⇓ (a₁ , a₂) withCost (p₁' ⊗ p₂') [ (λ u → ⊗-mono-≤ (h-bounded₁ u) (h-bounded₂ u)) , (ret (eq/intro refl)) ]


module Categories.Congruence where

open import Level
open import Relation.Binary hiding (_⇒_; Setoid)

open import Categories.Support.PropositionalEquality
open import Categories.Support.Equivalence
open import Categories.Support.EqReasoning

open import Categories.Category hiding (module Heterogeneous; _[_∼_])

record Congruence {o ℓ e} (C : Category o ℓ e) q : Set (o ⊔ ℓ ⊔ e ⊔ suc q) where
  open Category C
  field
    _≡₀_ : Rel Obj q
    equiv₀ : IsEquivalence _≡₀_

  module Equiv₀ = IsEquivalence equiv₀

  field
    coerce : ∀ {X₁ X₂ Y₁ Y₂} → X₁ ≡₀ X₂ → Y₁ ≡₀ Y₂ → X₁ ⇒ Y₁ → X₂ ⇒ Y₂

    .coerce-resp-≡ : ∀ {X₁ X₂ Y₁ Y₂} (xpf : X₁ ≡₀ X₂) (ypf : Y₁ ≡₀ Y₂)
                   → {f₁ f₂ : X₁ ⇒ Y₁} → f₁ ≡ f₂
                   → coerce xpf ypf f₁ ≡ coerce xpf ypf f₂
    .coerce-refl : ∀ {X Y} (f : X ⇒ Y) → coerce Equiv₀.refl Equiv₀.refl f ≡ f
    .coerce-invariant : ∀ {X₁ X₂ Y₁ Y₂} (xpf₁ xpf₂ : X₁ ≡₀ X₂)
                                        (ypf₁ ypf₂ : Y₁ ≡₀ Y₂)
                      → (f : X₁ ⇒ Y₁)
                      → coerce xpf₁ ypf₁ f ≡ coerce xpf₂ ypf₂ f
    .coerce-trans : ∀ {X₁ X₂ X₃ Y₁ Y₂ Y₃} (xpf₁ : X₁ ≡₀ X₂) (xpf₂ : X₂ ≡₀ X₃)
                                          (ypf₁ : Y₁ ≡₀ Y₂) (ypf₂ : Y₂ ≡₀ Y₃)
                  → (f : X₁ ⇒ Y₁)
                  →   coerce (Equiv₀.trans xpf₁ xpf₂) (Equiv₀.trans ypf₁ ypf₂) f
                    ≡ coerce xpf₂ ypf₂ (coerce xpf₁ ypf₁ f)
    .coerce-∘ : ∀ {X₁ X₂ Y₁ Y₂ Z₁ Z₂}
              →   (pfX : X₁ ≡₀ X₂) (pfY : Y₁ ≡₀ Y₂) (pfZ : Z₁ ≡₀ Z₂)
              →   (g : Y₁ ⇒ Z₁) (f : X₁ ⇒ Y₁)
              → coerce pfX pfZ (g ∘ f) ≡ coerce pfY pfZ g ∘ coerce pfX pfY f

  .coerce-local : ∀ {X Y} (xpf : X ≡₀ X) (ypf : Y ≡₀ Y) {f : X ⇒ Y} → coerce xpf ypf f ≡ f
  coerce-local xpf ypf {f} =
    begin
      coerce xpf ypf f
    ↓⟨ coerce-invariant xpf Equiv₀.refl ypf Equiv₀.refl f ⟩
      coerce Equiv₀.refl Equiv₀.refl f
    ↓⟨ coerce-refl f ⟩
      f
    ∎
    where open HomReasoning

  .coerce-zigzag : ∀ {X₁ X₂ Y₁ Y₂} (pfX : X₁ ≡₀ X₂) (rfX : X₂ ≡₀ X₁)
                                   (pfY : Y₁ ≡₀ Y₂) (rfY : Y₂ ≡₀ Y₁)
                   → {f : X₁ ⇒ Y₁}
                   → coerce rfX rfY (coerce pfX pfY f) ≡ f
  coerce-zigzag pfX rfX pfY rfY {f} =
    begin
      coerce rfX rfY (coerce pfX pfY f)
    ↑⟨ coerce-trans _ _ _ _ _ ⟩
      coerce (trans pfX rfX) (trans pfY rfY) f
    ↓⟨ coerce-local _ _ ⟩
      f
    ∎
    where
    open HomReasoning
    open Equiv₀

  .coerce-uncong : ∀ {X₁ X₂ Y₁ Y₂} (pfX : X₁ ≡₀ X₂) (pfY : Y₁ ≡₀ Y₂) (f g : X₁ ⇒ Y₁) → coerce pfX pfY f ≡ coerce pfX pfY g → f ≡ g
  coerce-uncong xpf ypf f g fg-pf =
    begin
      f
    ↑⟨ coerce-zigzag _ _ _ _ ⟩
      coerce (sym xpf) (sym ypf) (coerce xpf ypf f)
    ↓⟨ coerce-resp-≡ _ _ fg-pf ⟩
      coerce (sym xpf) (sym ypf) (coerce xpf ypf g)
    ↓⟨ coerce-zigzag _ _ _ _ ⟩
      g
    ∎
    where
    open HomReasoning
    open Equiv₀

  .coerce-slide⇒ : ∀ {X₁ X₂ Y₁ Y₂} (pfX : X₁ ≡₀ X₂) (rfX : X₂ ≡₀ X₁)
                                   (pfY : Y₁ ≡₀ Y₂) (rfY : Y₂ ≡₀ Y₁)
                   → (f : X₁ ⇒ Y₁) (g : X₂ ⇒ Y₂)
                   → coerce pfX pfY f ≡ g → f ≡ coerce rfX rfY g
  coerce-slide⇒ pfX rfX pfY rfY f g eq =
    begin
      f
    ↑⟨ coerce-zigzag _ _ _ _ ⟩
      coerce rfX rfY (coerce pfX pfY f)
    ↓⟨ coerce-resp-≡ _ _ eq ⟩
      coerce rfX rfY g
    ∎
    where open HomReasoning

  .coerce-slide⇐ : ∀ {X₁ X₂ Y₁ Y₂} (pfX : X₁ ≡₀ X₂) (rfX : X₂ ≡₀ X₁)
                                   (pfY : Y₁ ≡₀ Y₂) (rfY : Y₂ ≡₀ Y₁)
                   → (f : X₁ ⇒ Y₁) (g : X₂ ⇒ Y₂)
                   → f ≡ coerce rfX rfY g → coerce pfX pfY f ≡ g
  coerce-slide⇐ pfX rfX pfY rfY f g eq =
    begin
      coerce pfX pfY f
    ↓⟨ coerce-resp-≡ _ _ eq ⟩
      coerce pfX pfY (coerce rfX rfY g)
    ↓⟨ coerce-zigzag _ _ _ _ ⟩
      g
    ∎
    where open HomReasoning

  .coerce-id : ∀ {X Y} (pf₁ pf₂ : X ≡₀ Y) → coerce pf₁ pf₂ id ≡ id
  coerce-id pf₁ pf₂ =
    begin
      coerce pf₁ pf₂ id
    ↑⟨ identityˡ ⟩
      id ∘ coerce pf₁ pf₂ id
    ↑⟨ ∘-resp-≡ˡ (coerce-local _ _) ⟩
      coerce (trans (sym pf₂) pf₂) (trans (sym pf₂) pf₂) id ∘ coerce pf₁ pf₂ id
    ↓⟨ ∘-resp-≡ˡ (coerce-trans _ _ _ _ _) ⟩
      coerce pf₂ pf₂ (coerce (sym pf₂) (sym pf₂) id) ∘ coerce pf₁ pf₂ id
    ↑⟨ coerce-∘ _ _ _ _ _ ⟩
      coerce pf₁ pf₂ (coerce (sym pf₂) (sym pf₂) id ∘ id)
    ↓⟨ coerce-resp-≡ _ _ identityʳ ⟩
      coerce pf₁ pf₂ (coerce (sym pf₂) (sym pf₂) id)
    ↑⟨ coerce-trans _ _ _ _ _ ⟩
      coerce (trans (sym pf₂) pf₁) (trans (sym pf₂) pf₂) id
    ↓⟨ coerce-local _ _ ⟩
      id
    ∎
    where
    open HomReasoning
    open Equiv₀

module Heterogeneous {o ℓ e} {C : Category o ℓ e} {q} (Q : Congruence C q) where
  open Category C
  open Congruence Q
  open Equiv renaming (refl to refl′; sym to sym′; trans to trans′; reflexive to reflexive′)
  open Equiv₀ renaming (refl to refl₀; sym to sym₀; trans to trans₀; reflexive to reflexive₀)

  infix 4 _∼_

  data _∼_ {A B} (f : A ⇒ B) {X Y} (g : X ⇒ Y) : Set (o ⊔ ℓ ⊔ e ⊔ q) where
    ≡⇒∼ : (ax : A ≡₀ X) (by : B ≡₀ Y) → .(coerce ax by f ≡ g) → f ∼ g

  refl : ∀ {A B} {f : A ⇒ B} → f ∼ f
  refl = ≡⇒∼ refl₀ refl₀ (coerce-refl _)

  sym : ∀ {A B} {f : A ⇒ B} {D E} {g : D ⇒ E} → f ∼ g → g ∼ f
  sym (≡⇒∼ A≡D B≡E f≡g) = ≡⇒∼ (sym₀ A≡D) (sym₀ B≡E) (coerce-slide⇐ _ _ _ _ _ _ (sym′ f≡g))

  trans : ∀ {A B} {f : A ⇒ B}
             {D E} {g : D ⇒ E}
             {F G} {h : F ⇒ G}
          → f ∼ g → g ∼ h → f ∼ h
  trans (≡⇒∼ A≡D B≡E f≡g) (≡⇒∼ D≡F E≡G g≡h) = ≡⇒∼
    (trans₀ A≡D D≡F)
    (trans₀ B≡E E≡G)
    (trans′ (trans′ (coerce-trans _ _ _ _ _) (coerce-resp-≡ _ _ f≡g)) g≡h)

  reflexive : ∀ {A B} {f g : A ⇒ B} → f ≣ g → f ∼ g
  reflexive f≣g = ≡⇒∼ refl₀ refl₀ (trans′ (coerce-refl _) (reflexive′ f≣g))

  ∘-resp-∼ : ∀ {A B C A′ B′ C′} {f : B ⇒ C} {h : B′ ⇒ C′} {g : A ⇒ B} {i : A′ ⇒ B′} → f ∼ h → g ∼ i → (f ∘ g) ∼ (h ∘ i)
  ∘-resp-∼ {f = f} {h} {g} {i} (≡⇒∼ B≡B′₁ C≡C′ f≡h) (≡⇒∼ A≡A′ B≡B′₂ g≡i) = ≡⇒∼
    A≡A′
    C≡C′
    (begin
      coerce A≡A′ C≡C′ (f ∘ g)
    ↓⟨ coerce-∘ _ _ _ _ _ ⟩
      coerce B≡B′₁ C≡C′ f ∘ coerce A≡A′ B≡B′₁ g
    ↓⟨ ∘-resp-≡ʳ (coerce-invariant _ _ _ _ _) ⟩
      coerce B≡B′₁ C≡C′ f ∘ coerce A≡A′ B≡B′₂ g
    ↓⟨ ∘-resp-≡ f≡h g≡i ⟩
      h ∘ i
    ∎)
    where open HomReasoning

  ∘-resp-∼ˡ : ∀ {A B C C′} {f : B ⇒ C} {h : B ⇒ C′} {g : A ⇒ B} → f ∼ h → (f ∘ g) ∼ (h ∘ g)
  ∘-resp-∼ˡ {f = f} {h} {g} (≡⇒∼ B≡B C≡C′ f≡h) = ≡⇒∼ refl₀ C≡C′
    (begin
      coerce refl₀ C≡C′ (f ∘ g)
    ↓⟨ coerce-∘ _ _ _ _ _ ⟩
      coerce B≡B C≡C′ f ∘ coerce refl₀ B≡B g
    ↓⟨ ∘-resp-≡ʳ (coerce-local _ _) ⟩
      coerce B≡B C≡C′ f ∘ g
    ↓⟨ ∘-resp-≡ˡ f≡h ⟩
      h ∘ g
    ∎)
    where open HomReasoning

  ∘-resp-∼ʳ : ∀ {A A′ B C} {f : A ⇒ B} {h : A′ ⇒ B} {g : B ⇒ C} → f ∼ h → (g ∘ f) ∼ (g ∘ h)
  ∘-resp-∼ʳ {f = f} {h} {g} (≡⇒∼ A≡A′ B≡B f≡h) = ≡⇒∼ A≡A′ refl₀
    (begin
      coerce A≡A′ refl₀ (g ∘ f)
    ↓⟨ coerce-∘ _ _ _ _ _ ⟩
      coerce B≡B refl₀ g ∘ coerce A≡A′ B≡B f
    ↓⟨ ∘-resp-≡ˡ (coerce-local _ _) ⟩
      g ∘ coerce A≡A′ B≡B f
    ↓⟨ ∘-resp-≡ʳ f≡h ⟩
      g ∘ h
    ∎)
    where open HomReasoning

  .∼⇒≡ : ∀ {A B} {f g : A ⇒ B} → f ∼ g → f ≡ g
  ∼⇒≡ (≡⇒∼ A≡A B≡B f≡g) = trans′ (sym′ (coerce-local A≡A B≡B)) (irr f≡g)

  domain-≣ : ∀ {A A′ B B′} {f : A ⇒ B} {f′ : A′ ⇒ B′} → f ∼ f′ → A ≡₀ A′
  domain-≣ (≡⇒∼ eq _ _) = eq

  codomain-≣ : ∀ {A A′ B B′} {f : A ⇒ B} {f′ : A′ ⇒ B′} → f ∼ f′ → B ≡₀ B′
  codomain-≣ (≡⇒∼ _ eq _) = eq

  ∼-cong : ∀ {t : Level} {T : Set t} {dom cod : T → Obj} (f : (x : T) → dom x ⇒ cod x) → ∀ {i j} (eq : i ≣ j) → f i ∼ f j
  ∼-cong f ≣-refl = refl

  -- henry ford versions
  .∼⇒≡₂ : ∀ {A A′ B B′} {f : A ⇒ B} {f′ : A′ ⇒ B′} → f ∼ f′ → (A≡A′ : A ≡₀ A′) (B≡B′ : B ≡₀ B′) → coerce A≡A′ B≡B′ f ≡ f′
  ∼⇒≡₂ (≡⇒∼ pfA pfB pff) A≡A′ B≡B′ = trans′ (coerce-invariant _ _ _ _ _) (irr pff)

  -- .∼⇒≡ˡ : ∀ {A B B′} {f : A ⇒ B} {f′ : A ⇒ B′} → f ∼ f′ → (B≣B′ : B ≣ B′) → floatˡ B≣B′ f ≡ f′
  -- ∼⇒≡ˡ pf ≣-refl = ∼⇒≡ pf

  -- .∼⇒≡ʳ : ∀ {A A′ B} {f : A ⇒ B} {f′ : A′ ⇒ B} → f ∼ f′ → (A≣A′ : A ≣ A′) → floatʳ A≣A′ f ≡ f′
  -- ∼⇒≡ʳ pf ≣-refl = ∼⇒≡ pf

  -- ≡⇒∼ʳ : ∀ {A A′ B} {f : A ⇒ B} {f′ : A′ ⇒ B} → (A≣A′ : A ≣ A′) → .(floatʳ A≣A′ f ≡ f′) → f ∼ f′
  -- ≡⇒∼ʳ ≣-refl pf = ≡⇒∼ pf

  coerce-resp-∼ : ∀ {A A′ B B′} (A≡A′ : A ≡₀ A′) (B≡B′ : B ≡₀ B′) {f : C [ A , B ]} → f ∼ coerce A≡A′ B≡B′ f
  coerce-resp-∼ A≡A′ B≡B′ = ≡⇒∼ A≡A′ B≡B′ refl′

  -- floatˡ-resp-∼ : ∀ {A B B′} (B≣B′ : B ≣ B′) {f : C [ A , B ]} → f ∼ floatˡ B≣B′ f
  -- floatˡ-resp-∼ ≣-refl = refl

  -- floatʳ-resp-∼ : ∀ {A A′ B} (A≣A′ : A ≣ A′) {f : C [ A , B ]} → f ∼ floatʳ A≣A′ f
  -- floatʳ-resp-∼ ≣-refl = refl

  infixr 4 ▹_

  record -⇒- : Set (o ⊔ ℓ) where
    constructor ▹_
    field
      {Dom} : Obj
      {Cod} : Obj
      morphism : Dom ⇒ Cod

  ∼-setoid : Setoid _ _
  ∼-setoid = record {
               Carrier = -⇒-;
               _≈_ = λ x y → -⇒-.morphism x ∼ -⇒-.morphism y;
               isEquivalence = record { refl = refl; sym = sym; trans = trans } }

  module HetReasoning where
    open SetoidReasoning ∼-setoid public

_[_∼_] : ∀ {o ℓ e} {C : Category o ℓ e} {q} (Q : Congruence C q) {A B} (f : C [ A , B ]) {X Y} (g : C [ X , Y ]) → Set (q ⊔ o ⊔ ℓ ⊔ e)
Q [ f ∼ g ] = Heterogeneous._∼_ Q f g

TrivialCongruence : ∀ {o ℓ e} (C : Category o ℓ e) → Congruence C _
TrivialCongruence C = record
  { _≡₀_ = _≣_
  ; equiv₀ = ≣-isEquivalence
  ; coerce = ≣-subst₂ (_⇒_)
  ; coerce-resp-≡ = resp-≡
  ; coerce-refl = λ f → refl
  ; coerce-invariant = invariant
  ; coerce-trans = tranz
  ; coerce-∘ = compose
  }
  where
  open Category C
  open Equiv
  -- XXX must this depend on proof irrelevance?

  .resp-≡ : ∀ {X₁ X₂ Y₁ Y₂} (xpf : X₁ ≣ X₂) (ypf : Y₁ ≣ Y₂) {f₁ f₂ : X₁ ⇒ Y₁}
            → f₁ ≡ f₂ → ≣-subst₂ _⇒_ xpf ypf f₁ ≡ ≣-subst₂ _⇒_ xpf ypf f₂
  resp-≡ ≣-refl ≣-refl eq = eq

  .invariant : ∀ {X₁ X₂ Y₁ Y₂} (xpf₁ xpf₂ : X₁ ≣ X₂) (ypf₁ ypf₂ : Y₁ ≣ Y₂)
               → (f : X₁ ⇒ Y₁)
               → ≣-subst₂ _⇒_ xpf₁ ypf₁ f ≡ ≣-subst₂ _⇒_ xpf₂ ypf₂ f
  invariant ≣-refl ≣-refl ≣-refl ≣-refl f = refl

  .tranz : ∀ {X₁ X₂ X₃ Y₁ Y₂ Y₃} (xpf₁ : X₁ ≣ X₂) (xpf₂ : X₂ ≣ X₃)
                                 (ypf₁ : Y₁ ≣ Y₂) (ypf₂ : Y₂ ≣ Y₃)
           → (f : X₁ ⇒ Y₁)
           →   ≣-subst₂ _⇒_ (≣-trans xpf₁ xpf₂) (≣-trans ypf₁ ypf₂) f
             ≡ ≣-subst₂ _⇒_ xpf₂ ypf₂ (≣-subst₂ _⇒_ xpf₁ ypf₁ f)
  tranz ≣-refl xpf₂ ≣-refl ypf₂ f = refl

  .compose : ∀ {X₁ X₂ Y₁ Y₂ Z₁ Z₂} (pfX : X₁ ≣ X₂)(pfY : Y₁ ≣ Y₂)(pfZ : Z₁ ≣ Z₂)
             → (g : Y₁ ⇒ Z₁) (f : X₁ ⇒ Y₁)
             →   ≣-subst₂ _⇒_ pfX pfZ (g ∘ f)
               ≡ ≣-subst₂ _⇒_ pfY pfZ g ∘ ≣-subst₂ _⇒_ pfX pfY f
  compose ≣-refl ≣-refl ≣-refl g f = refl


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

module Issue442 where

postulate
  A : Set
  f : (P : A → A → Set) → (∀ {x} → P x x) →
      (∀ {x y z} → P y z → P x y → A) → A
  P : A → A → Set
  reflP : ∀ {x} → P x x
  g : ∀ {x y z} → P y z → P x y → A

a : A
a = f _ reflP g


module Convertibility where

open import Syntax public

-- β-η-equivalence.

infix 4 _≡ᵝᵑ_
data _≡ᵝᵑ_ : ∀ {A Γ} → Γ ⊢ A → Γ ⊢ A → Set where
  refl≡ᵝᵑ  : ∀ {A Γ} {d : Γ ⊢ A} → d ≡ᵝᵑ d

  trans≡ᵝᵑ : ∀ {A Γ} {d d′ d″ : Γ ⊢ A} → d ≡ᵝᵑ d′ → d′ ≡ᵝᵑ d″ → d ≡ᵝᵑ d″

  sym≡ᵝᵑ   : ∀ {A Γ} {d d′ : Γ ⊢ A} → d ≡ᵝᵑ d′ → d′ ≡ᵝᵑ d

  -- Congruences.

  cong≡ᵝᵑlam  : ∀ {A B Γ} {d d′ : Γ , A ⊢ B} →
                d ≡ᵝᵑ d′ → lam d ≡ᵝᵑ lam d′

  cong≡ᵝᵑapp  : ∀ {A B Γ} {d d′ : Γ ⊢ A ⇒ B} {e e′ : Γ ⊢ A} →
                d ≡ᵝᵑ d′ → e ≡ᵝᵑ e′ → app d e ≡ᵝᵑ app d′ e′

  cong≡ᵝᵑpair : ∀ {A B Γ} {d d′ : Γ ⊢ A} {e e′ : Γ ⊢ B} →
                d ≡ᵝᵑ d′ → e ≡ᵝᵑ e′ → pair d e ≡ᵝᵑ pair d′ e′

  cong≡ᵝᵑfst  : ∀ {A B Γ} {d d′ : Γ ⊢ A ⩕ B} →
                d ≡ᵝᵑ d′ → fst d ≡ᵝᵑ fst d′

  cong≡ᵝᵑsnd  : ∀ {A B Γ} {d d′ : Γ ⊢ A ⩕ B} →
                d ≡ᵝᵑ d′ → snd d ≡ᵝᵑ snd d′

  -- Reductions, or β-conversions.

  reduce⇒ : ∀ {A B Γ} → (d : Γ , A ⊢ B) (e : Γ ⊢ A) →
             app (lam d) e ≡ᵝᵑ [ top ≔ e ] d

  reduce⩕₁ : ∀ {A B Γ} → (d : Γ ⊢ A) (e : Γ ⊢ B) →
             fst (pair d e) ≡ᵝᵑ d

  reduce⩕₂ : ∀ {A B Γ} → (d : Γ ⊢ A) (e : Γ ⊢ B) →
             snd (pair d e) ≡ᵝᵑ e

  -- Expansions, or η-conversions.

  expand⇒ : ∀ {A B Γ} → (d : Γ ⊢ A ⇒ B) →
             d ≡ᵝᵑ lam (app (mono⊢ weak⊆ d) v₀)

  expand⩕  : ∀ {A B Γ} → (d : Γ ⊢ A ⩕ B) →
             d ≡ᵝᵑ pair (fst d) (snd d)

  expand⫪ : ∀ {Γ} → (d : Γ ⊢ ⫪) →
             d ≡ᵝᵑ unit

≡→≡ᵝᵑ : ∀ {A Γ} {d d′ : Γ ⊢ A} → d ≡ d′ → d ≡ᵝᵑ d′
≡→≡ᵝᵑ refl = refl≡ᵝᵑ

-- Syntax for equational reasoning with β-η-equivalence.

module ≡ᵝᵑ-Reasoning where
  infix 1 begin≡ᵝᵑ_
  begin≡ᵝᵑ_ : ∀ {A Γ} {d d′ : Γ ⊢ A} → d ≡ᵝᵑ d′ → d ≡ᵝᵑ d′
  begin≡ᵝᵑ_ p = p

  infixr 2 _≡→≡ᵝᵑ⟨⟩_
  _≡→≡ᵝᵑ⟨⟩_ : ∀ {A Γ} (d {d′} : Γ ⊢ A) → d ≡ d′ → d ≡ᵝᵑ d′
  d ≡→≡ᵝᵑ⟨⟩ p = ≡→≡ᵝᵑ p

  infixr 2 _≡ᵝᵑ⟨⟩_
  _≡ᵝᵑ⟨⟩_ : ∀ {A Γ} (d {d′} : Γ ⊢ A) → d ≡ᵝᵑ d′ → d ≡ᵝᵑ d′
  d ≡ᵝᵑ⟨⟩ p = p

  infixr 2 _≡ᵝᵑ⟨_⟩_
  _≡ᵝᵑ⟨_⟩_ : ∀ {A Γ} (d {d′ d″} : Γ ⊢ A) → d ≡ᵝᵑ d′ → d′ ≡ᵝᵑ d″ → d ≡ᵝᵑ d″
  d ≡ᵝᵑ⟨ p ⟩ q = trans≡ᵝᵑ p q

  infix 3 _∎≡ᵝᵑ
  _∎≡ᵝᵑ : ∀ {A Γ} (d : Γ ⊢ A) → d ≡ᵝᵑ d
  _∎≡ᵝᵑ _ = refl≡ᵝᵑ

open ≡ᵝᵑ-Reasoning public


{-# OPTIONS --sized-types #-}
-- {-# OPTIONS -v tc.size.solve:100 -v tc.meta.new:50 #-}
module CheckSizeMetaBounds where

open import Common.Size

postulate
  Size< : (_ : Size) → Set
{-# BUILTIN SIZELT Size< #-}

data Nat {i : Size} : Set where
  zero : Nat
  suc  : {j : Size< i} → Nat {j} → Nat

one : Nat
one = suc {i = ∞} zero

data ⊥ : Set where
record ⊤ : Set where

NonZero : Nat → Set
NonZero zero    = ⊥
NonZero (suc n) = ⊤

-- magic conversion must of course fail
magic : {i : Size} → Nat {∞} → Nat {i}
magic zero = zero
magic (suc n) = suc (magic n)

lem : (n : Nat) → NonZero n → NonZero (magic n)
lem (zero)  ()
lem (suc n) _ = _

-- otherwise, we exploit it for an infinite loop
loop : {i : Size} → (x : Nat {i}) → NonZero x → ⊥
loop zero ()
loop (suc {j} n) p = loop {j} (magic one) (lem one _)

bot : ⊥
bot = loop one _


{-# OPTIONS --rewriting -v rewriting:80 #-}

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

postulate
  A : Set
  f : A → A
  h : .A → A → A
  rew : ∀ {x} → h x x ≡ x

{-# REWRITE rew #-}

test2 : (x y : A) → h x y ≡ y
test2 x y = refl

postulate
  r : .A → A
  s : .A → A
  rewr : ∀ x → r x ≡ s x
{-# REWRITE rewr #-}