-- Combinators for logical reasoning
{-# OPTIONS --without-K --safe --exact-split #-}

module Constructive.Combinators where

-- agda-stdlib
open import Data.Empty
open import Data.Sum as Sum
open import Data.Product as Prod
open import Function.Base
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
import Relation.Unary as U
open import Relation.Binary.PropositionalEquality

-- agda-misc
open import Constructive.Common

---------------------------------------------------------------------------
-- Combinators
---------------------------------------------------------------------------

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} where
  →-distrib-⊎-× : ((A ⊎ B) → C) → (A → C) × (B → C)
  →-distrib-⊎-× f = f ∘ inj₁ , f ∘ inj₂

  →-undistrib-⊎-× : (A → C) × (B → C) → (A ⊎ B) → C
  →-undistrib-⊎-× (f , g) (inj₁ x) = f x
  →-undistrib-⊎-× (f , g) (inj₂ y) = g y

  →-undistrib-⊎-×-flip : (A ⊎ B) → (A → C) × (B → C) → C
  →-undistrib-⊎-×-flip = flip →-undistrib-⊎-×

  →-undistrib-×-⊎ : (A → C) ⊎ (B → C) → (A × B) → C
  →-undistrib-×-⊎ (inj₁ f) (x , y) = f x
  →-undistrib-×-⊎ (inj₂ g) (x , y) = g y

  →-undistrib-×-⊎-flip : (A × B) → (A → C) ⊎ (B → C) → C
  →-undistrib-×-⊎-flip = flip →-undistrib-×-⊎

-- contradiction
contradiction : ∀ {a w} {A : Set a} {WhatEver : Set w} → A → ¬ A → WhatEver
contradiction x ¬x = ⊥-elim (¬x x)

-- sum and product
module _ {a b} {A : Set a} {B : Set b} where
  A⊎B→¬A→B : A ⊎ B → ¬ A → B
  A⊎B→¬A→B (inj₁ x) ¬A = contradiction x ¬A
  A⊎B→¬A→B (inj₂ y) ¬A = y

  A⊎B→¬B→A : A ⊎ B → ¬ B → A
  A⊎B→¬B→A (inj₁ x) ¬B = x
  A⊎B→¬B→A (inj₂ y) ¬B = contradiction y ¬B

  ¬A⊎B→A→B : ¬ A ⊎ B → A → B
  ¬A⊎B→A→B (inj₁ ¬A) x = contradiction x ¬A
  ¬A⊎B→A→B (inj₂ y)  _ = y

  [A→B]→¬[A×¬B] : (A → B) → ¬ (A × ¬ B)
  [A→B]→¬[A×¬B] f (x , y) = y (f x)

  A×B→¬[A→¬B] : A × B → ¬ (A → ¬ B)
  A×B→¬[A→¬B] (x , y) f = f x y

  -- De Morgan's laws
  ¬[A⊎B]→¬A×¬B : ¬ (A ⊎ B) → ¬ A × ¬ B
  ¬[A⊎B]→¬A×¬B = →-distrib-⊎-×

  ¬A×¬B→¬[A⊎B] : ¬ A × ¬ B → ¬ (A ⊎ B)
  ¬A×¬B→¬[A⊎B] = →-undistrib-⊎-×

  A⊎B→¬[¬A×¬B] : A ⊎ B → ¬ (¬ A × ¬ B)
  A⊎B→¬[¬A×¬B] = →-undistrib-⊎-×-flip

  ¬A⊎¬B→¬[A×B] : ¬ A ⊎ ¬ B → ¬ (A × B)
  ¬A⊎¬B→¬[A×B] = →-undistrib-×-⊎

  A×B→¬[¬A⊎¬B] : A × B → ¬ (¬ A ⊎ ¬ B)
  A×B→¬[¬A⊎¬B] = →-undistrib-×-⊎-flip

  -- Double negated DEM₃
  ¬[A×B]→¬¬[¬A⊎¬B] : ¬ (A × B) → ¬ ¬ (¬ A ⊎ ¬ B)
  ¬[A×B]→¬¬[¬A⊎¬B] ¬[A×B] ¬[¬A⊎¬B] =
    ¬[¬A⊎¬B] (inj₁ λ x → contradiction (inj₂ (λ y → ¬[A×B] (x , y))) ¬[¬A⊎¬B])

  dec⊎⇒¬[A×B]→¬A⊎¬B : Dec⊎ A → Dec⊎ B → ¬ (A × B) → ¬ A ⊎ ¬ B
  dec⊎⇒¬[A×B]→¬A⊎¬B (inj₁ x)  (inj₁ y)  ¬[A×B] = contradiction (x , y) ¬[A×B]
  dec⊎⇒¬[A×B]→¬A⊎¬B (inj₁ x)  (inj₂ ¬y) ¬[A×B] = inj₂ ¬y
  dec⊎⇒¬[A×B]→¬A⊎¬B (inj₂ ¬x) _         ¬[A×B] = inj₁ ¬x

  join : (A → A → B) → A → B
  join f x = f x x

-- properties of negation
module _ {a} {A : Set a} where
  [A→¬A]→¬A : (A → ¬ A) → ¬ A
  [A→¬A]→¬A = join

  [¬A→A]→¬¬A : (¬ A → A) → ¬ ¬ A
  [¬A→A]→¬¬A ¬A→A ¬A = ¬A (¬A→A ¬A)

  -- Law of noncontradiction (LNC)
  ¬[A×¬A] : ¬ (A × ¬ A)
  ¬[A×¬A] = uncurry (flip _$_)

module _ {a b} {A : Set a} {B : Set b} where
  ¬[A→B]→¬B : ¬ (A → B) → ¬ B
  ¬[A→B]→¬B ¬[A→B] y = ¬[A→B] (const y)

  ¬[A→B]→¬[A→¬¬B] : ¬ (A → B) → ¬ (A → ¬ ¬ B)
  ¬[A→B]→¬[A→¬¬B] ¬[A→B] A→¬¬B = ¬[A→B] λ x → ⊥-elim $ A→¬¬B x (¬[A→B]→¬B ¬[A→B])

  ¬[A→B]→B→A : ¬ (A → B) → B → A
  ¬[A→B]→B→A ¬[A→B] y = contradiction (λ _ → y) ¬[A→B]

  [[A→B]→A]→¬A→A : ((A → B) → A) → ¬ A → A
  [[A→B]→A]→¬A→A [A→B]→A ¬A = [A→B]→A (⊥-elim ∘′ ¬A)

  [[A→B]→A]→¬¬A : ((A → B) → A) → ¬ ¬ A
  [[A→B]→A]→¬¬A [A→B]→A ¬A = ¬A ([[A→B]→A]→¬A→A [A→B]→A ¬A)

  [[[A→B]→A]→A]→¬B→¬¬A→A : (((A → B) → A) → A) → ¬ B → ¬ ¬ A → A
  [[[A→B]→A]→A]→¬B→¬¬A→A [[A→B]→A]→A ¬B ¬¬A =
    [[A→B]→A]→A λ A→B → contradiction (flip _∘′_ A→B ¬B) ¬¬A

module _ {a b} {A : Set a} {B : Set b} where
  contraposition : (A → B) → ¬ B → ¬ A
  contraposition = flip _∘′_

  -- variant of contraposition
  [A→¬¬B]→¬B→¬A : (A → ¬ ¬ B) → ¬ B → ¬ A
  [A→¬¬B]→¬B→¬A f ¬B x = (f x) ¬B

  [¬A→¬B]→¬¬[B→A] : (¬ A → ¬ B) → ¬ ¬ (B → A)
  [¬A→¬B]→¬¬[B→A] ¬A→¬B ¬[B→A] = ¬[B→A] λ y → ⊥-elim $ ¬A→¬B (¬[A→B]→¬B ¬[B→A]) y

  [A→¬B]→¬¬A→¬B : (A → ¬ B) → ¬ ¬ A → ¬ B
  [A→¬B]→¬¬A→¬B A→¬B ¬¬A y = ¬¬A λ x → A→¬B x y

module _ {a} {A : Set a} where
  -- introduction for double negation
  DN-intro : A → ¬ ¬ A
  DN-intro = flip _$_

  -- triple negation to negation
  TN-to-N : ¬ ¬ ¬ A → ¬ A
  TN-to-N = contraposition DN-intro

  -- Double negation of excluded middle
  DN-Dec⊎ : ¬ ¬ Dec⊎ A
  DN-Dec⊎ = λ f → (f ∘ inj₂) (f ∘ inj₁)

-- eliminator for ⊥
⊥-stable : ¬ ¬ ⊥ → ⊥
⊥-stable f = f id

-- Double negation is monad
module _ {a} {A : Set a} where
  DN-join : ¬ ¬ ¬ ¬ A → ¬ ¬ A
  DN-join = TN-to-N

module _ {a b} {A : Set a} {B : Set b} where
  DN-map : (A → B) → ¬ ¬ A → ¬ ¬ B
  DN-map = contraposition ∘′ contraposition

module _ {a b} {A : Set a} {B : Set b} where
  DN-bind : (A → ¬ ¬ B) → ¬ ¬ A → ¬ ¬ B
  DN-bind f = DN-join ∘′ DN-map f

  DN-bind⁻¹ : (¬ ¬ A → ¬ ¬ B) → A → ¬ ¬ B
  DN-bind⁻¹ f = f ∘′ DN-intro

module _ {a b} {A : Set a} {B : Set b} where
  DN-ap : ¬ ¬ (A → B) → ¬ ¬ A → ¬ ¬ B
  DN-ap ff fx = DN-bind (λ f → DN-map f fx) ff

  DN-ap⁻¹ : (¬ ¬ A → ¬ ¬ B) → ¬ ¬ (A → B)
  DN-ap⁻¹ f ¬[A→B] = ¬[A→B]→¬[A→¬¬B] ¬[A→B] (DN-bind⁻¹ f)

-- distributive properties
  DN-distrib-× : ¬ ¬ (A × B) → ¬ ¬ A × ¬ ¬ B
  DN-distrib-× ¬¬A×B = DN-map proj₁ ¬¬A×B , DN-map proj₂ ¬¬A×B

  DN-undistrib-× : ¬ ¬ A × ¬ ¬ B → ¬ ¬ (A × B)
  DN-undistrib-× = [A→¬¬B]→¬B→¬A ¬[A×B]→¬¬[¬A⊎¬B] ∘′ ¬A×¬B→¬[A⊎B]

  DN-undistrib-⊎ : ¬ ¬ A ⊎ ¬ ¬ B → ¬ ¬ (A ⊎ B)
  DN-undistrib-⊎ = Sum.[ DN-map inj₁ , DN-map inj₂ ]

  stable-undistrib-× : Stable A × Stable B → Stable (A × B)
  stable-undistrib-× (A-stable , B-stable) ¬¬[A×B] =
    Prod.map A-stable B-stable $ DN-distrib-× ¬¬[A×B]

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} where
  ip-⊎-DN : (A → (B ⊎ C)) → ¬ ¬ ((A → B) ⊎ (A → C))
  ip-⊎-DN f =
    DN-map Sum.[ (Sum.map const const ∘ f) , (λ ¬A → inj₁ λ x → ⊥-elim (¬A x)) ]
          DN-Dec⊎

DN-ip : ∀ {p q r} {P : Set p} {Q : Set q} {R : Q → Set r} →
        Q → (P → Σ Q R) → ¬ ¬ (Σ Q λ x → (P → R x))
DN-ip q f =
  DN-map Sum.[ (λ x → Prod.map₂ const (f x)) ,
               (λ ¬P → q , λ P → ⊥-elim $ ¬P P) ] DN-Dec⊎

-- Properties of Dec⊎
module _ {a} {A : Set a} where
  dec⊎⇒dec : Dec⊎ A → Dec A
  dec⊎⇒dec (inj₁ x) = yes x
  dec⊎⇒dec (inj₂ y) = no y

  dec⇒dec⊎ : Dec A → Dec⊎ A
  dec⇒dec⊎ (yes p) = inj₁ p
  dec⇒dec⊎ (no ¬p) = inj₂ ¬p

  ¬-dec⊎ : Dec⊎ A → Dec⊎ (¬ A)
  ¬-dec⊎ (inj₁ x) = inj₂ (DN-intro x)
  ¬-dec⊎ (inj₂ y) = inj₁ y

module _ {a b} {A : Set a} {B : Set b} where
  dec⊎-map : (A → B) → (B → A) → Dec⊎ A → Dec⊎ B
  dec⊎-map f g dec⊎ = Sum.map f (contraposition g) dec⊎

  dec⊎-⊎ : Dec⊎ A → Dec⊎ B → Dec⊎ (A ⊎ B)
  dec⊎-⊎ (inj₁ x)  _         = inj₁ (inj₁ x)
  dec⊎-⊎ (inj₂ ¬x) (inj₁ y)  = inj₁ (inj₂ y)
  dec⊎-⊎ (inj₂ ¬x) (inj₂ ¬y) = inj₂ (¬A×¬B→¬[A⊎B] (¬x , ¬y))

  dec⊎-× : Dec⊎ A → Dec⊎ B → Dec⊎ (A × B)
  dec⊎-× (inj₁ x)  (inj₁ y)  = inj₁ (x , y)
  dec⊎-× (inj₁ x)  (inj₂ ¬y) = inj₂ (¬y ∘ proj₂)
  dec⊎-× (inj₂ ¬x) _         = inj₂ (¬x ∘ proj₁)

-- Properties of Stable
module _ {a} {A : Set a} where
  dec⇒stable : Dec A → Stable A
  dec⇒stable (yes p) ¬¬A = p
  dec⇒stable (no ¬p) ¬¬A = ⊥-elim (¬¬A ¬p)

  ¬-stable : Stable (¬ A)
  ¬-stable = TN-to-N

  dec⊎⇒stable : Dec⊎ A → Stable A
  dec⊎⇒stable dec⊎ = dec⇒stable (dec⊎⇒dec dec⊎)

module _ {a p} {A : Set a} {P : A → Set p} where
  DecU⇒stable : DecU P → ∀ x → Stable (P x)
  DecU⇒stable P? x = dec⊎⇒stable (P? x)

  -- Properties of DecU
  ¬-DecU : DecU P → DecU (λ x → ¬ (P x))
  ¬-DecU P? x = ¬-dec⊎ (P? x)

  DecU⇒decidable : DecU P → U.Decidable P
  DecU⇒decidable P? x = dec⊎⇒dec (P? x)

  decidable⇒DecU : U.Decidable P → DecU P
  decidable⇒DecU P? x = dec⇒dec⊎ (P? x)

DecU-map : ∀ {a b p} {A : Set a} {B : Set b} {P : A → Set p} →
  (f : B → A) → DecU P → DecU (λ x → P (f x))
DecU-map f P? x = dec⊎-map id id (P? (f x))

module _ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} where
  DecU-⊎ : DecU P → DecU Q → DecU (λ x → P x ⊎ Q x)
  DecU-⊎ P? Q? x = dec⊎-⊎ (P? x) (Q? x)

  DecU-× : DecU P → DecU Q → DecU (λ x → P x × Q x)
  DecU-× P? Q? x = dec⊎-× (P? x) (Q? x)

-- Quantifier
module _ {a p} {A : Set a} {P : A → Set p} where
  ∃P→¬∀¬P : ∃ P → ¬ (∀ x → ¬ (P x))
  ∃P→¬∀¬P = flip uncurry

  ∀P→¬∃¬P : (∀ x → P x) → ¬ ∃ λ x → ¬ (P x)
  ∀P→¬∃¬P f (x , ¬Px) = ¬Px (f x)

  ¬∃P→∀¬P : ¬ ∃ P → ∀ x → ¬ (P x)
  ¬∃P→∀¬P = curry

  ∀¬P→¬∃P : (∀ x → ¬ (P x)) → ¬ ∃ P
  ∀¬P→¬∃P = uncurry

  ∃¬P→¬∀P : ∃ (λ x → ¬ (P x)) → ¬ (∀ x → P x)
  ∃¬P→¬∀P (x , ¬Px) ∀P = ¬Px (∀P x)

  ¬∀¬P→¬¬∃P : ¬ (∀ x → ¬ P x) → ¬ ¬ ∃ P
  ¬∀¬P→¬¬∃P ¬∀¬P = contraposition ¬∃P→∀¬P ¬∀¬P

  ¬¬∃P→¬∀¬P : ¬ ¬ ∃ P → ¬ (∀ x → ¬ P x)
  ¬¬∃P→¬∀¬P ¬¬∃P = contraposition ∀¬P→¬∃P ¬¬∃P

  ¬¬∀P→¬∃¬P : ¬ ¬ (∀ x → P x) → ¬ ∃ λ x → ¬ (P x)
  ¬¬∀P→¬∃¬P ¬¬∀P = contraposition ∃¬P→¬∀P ¬¬∀P

  ¬¬∃P<=>¬∀¬P : ¬ ¬ ∃ P <=> ¬ (∀ x → ¬ P x)
  ¬¬∃P<=>¬∀¬P = mk<=> ¬¬∃P→¬∀¬P ¬∀¬P→¬¬∃P

  -- remove?
  ∀¬¬P→¬∃¬P : (∀ x → ¬ ¬ P x) → ¬ ∃ λ x → ¬ (P x)
  ∀¬¬P→¬∃¬P = uncurry

  -- converse of DNS
  ¬¬∀P→∀¬¬P : ¬ ¬ (∀ x → P x) → ∀ x → ¬ ¬ P x
  ¬¬∀P→∀¬¬P f x = DN-map (λ ∀P → ∀P x) f

  ∃¬¬P→¬¬∃P  : (∃ λ x → ¬ ¬ P x) → ¬ ¬ ∃ λ x → P x
  ∃¬¬P→¬¬∃P (x , ¬¬Px) = DN-map (λ Px → x , Px) ¬¬Px

  ¬¬∃¬P→¬∀P : ¬ ¬ ∃ (λ x → ¬ (P x)) → ¬ (∀ x → P x)
  ¬¬∃¬P→¬∀P = contraposition ∀P→¬∃¬P

  ¬∃¬P→∀¬¬P : ¬ ∃ (λ x → ¬ P x) → ∀ x → ¬ ¬ P x
  ¬∃¬P→∀¬¬P = curry

  ∀P→∀¬¬P : (∀ x → P x) → ∀ x → ¬ ¬ P x
  ∀P→∀¬¬P ∀P x = DN-intro (∀P x)

  ∃P→∃¬¬P : ∃ P → ∃ λ x → ¬ ¬ P x
  ∃P→∃¬¬P (x , Px) = x , DN-intro Px

module _ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} where
  [∀¬P→∀¬Q]→¬¬[∃Q→∃P] : ((∀ x → ¬ P x) → (∀ x → ¬ Q x)) → ¬ ¬ (∃ Q → ∃ P)
  [∀¬P→∀¬Q]→¬¬[∃Q→∃P] ∀¬P→∀¬Q =
    DN-ap⁻¹ (¬∀¬P→¬¬∃P ∘ contraposition ∀¬P→∀¬Q ∘ ¬¬∃P→¬∀¬P)

-- Quantifier rearrangement for stable predicate
module _ {a p} {A : Set a} {P : A → Set p} (P-stable : ∀ x → Stable (P x)) where
  P-stable⇒∃¬¬P→∃P : ∃ (λ x → ¬ ¬ P x) → ∃ P
  P-stable⇒∃¬¬P→∃P (x , ¬¬Px) = x , P-stable x ¬¬Px

  P-stable⇒∀¬¬P→∀P : (∀ x → ¬ ¬ P x) → ∀ x → P x
  P-stable⇒∀¬¬P→∀P ∀¬¬P x = P-stable x (∀¬¬P x)

  P-stable⇒¬¬∀P→∀P : ¬ ¬ (∀ x → P x) → ∀ x → P x
  P-stable⇒¬¬∀P→∀P = P-stable⇒∀¬¬P→∀P ∘′ ¬¬∀P→∀¬¬P

  P-stable⇒¬∃¬P→∀P : ¬ ∃ (λ x → ¬ P x) → ∀ x → P x
  P-stable⇒¬∃¬P→∀P ¬∃¬P = P-stable⇒∀¬¬P→∀P (¬∃¬P→∀¬¬P ¬∃¬P)

  P-stable⇒¬∀P→¬¬∃¬P : ¬ (∀ x → P x) → ¬ ¬ ∃ (λ x → ¬ (P x))
  P-stable⇒¬∀P→¬¬∃¬P ¬∀P = contraposition P-stable⇒¬∃¬P→∀P ¬∀P

module _ {a p} {A : Set a} {P : A → Set p} (P? : DecU P) where
  P?⇒∃¬¬P→∃P : ∃ (λ x → ¬ ¬ P x) → ∃ P
  P?⇒∃¬¬P→∃P = P-stable⇒∃¬¬P→∃P (DecU⇒stable P?)

  P?⇒∀¬¬P→∀P : (∀ x → ¬ ¬ P x) → ∀ x → P x
  P?⇒∀¬¬P→∀P = P-stable⇒∀¬¬P→∀P (DecU⇒stable P?)

  P?⇒¬¬∀P→∀P : ¬ ¬ (∀ x → P x) → ∀ x → P x
  P?⇒¬¬∀P→∀P = P-stable⇒¬¬∀P→∀P (DecU⇒stable P?)

  P?⇒¬∃¬P→∀P : ¬ ∃ (λ x → ¬ P x) → ∀ x → P x
  P?⇒¬∃¬P→∀P = P-stable⇒¬∃¬P→∀P (DecU⇒stable P?)

  P?⇒¬∀P→¬¬∃¬P : ¬ (∀ x → P x) → ¬ ¬ ∃ (λ x → ¬ P x)
  P?⇒¬∀P→¬¬∃¬P = P-stable⇒¬∀P→¬¬∃¬P (DecU⇒stable P?)

  -- call/cc
  P?⇒[¬∀P→∀P]→∀P : (¬ (∀ x → P x) → ∀ x → P x) → ∀ x → P x
  P?⇒[¬∀P→∀P]→∀P ¬∀P→∀P = P?⇒¬¬∀P→∀P λ ¬∀P → ¬∀P (¬∀P→∀P ¬∀P)

  P?⇒[∃¬P→∀P]→∀P : (∃ (λ x → ¬ P x) → ∀ x → P x) → ∀ x → P x
  P?⇒[∃¬P→∀P]→∀P ∃¬P→∀P =
    P?⇒¬¬∀P→∀P λ ¬∀P → P?⇒¬∀P→¬¬∃¬P ¬∀P λ ∃¬P → ¬∀P (∃¬P→∀P ∃¬P)

  -- [∀¬P→¬∀Q]→¬∃¬Q→¬¬∃P

module _ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} where
  P?⇒[∃¬P→∃¬Q]→∀Q→∀P : DecU P → (∃ (λ x → ¬ P x) → ∃ (λ x → ¬ Q x)) →
                       (∀ x → Q x) → ∀ x → P x
  P?⇒[∃¬P→∃¬Q]→∀Q→∀P P? ∃¬P→∃¬Q =
    P?⇒¬∃¬P→∀P P? ∘ contraposition ∃¬P→∃¬Q ∘ ∀P→¬∃¬P

  P?⇒[∃Q→∀P]→¬∀¬Q→∀P : DecU P → (∃ Q → ∀ x → P x) → ¬ (∀ x → ¬ Q x) → ∀ x → P x
  P?⇒[∃Q→∀P]→¬∀¬Q→∀P P? ∃Q→∀P ¬∀¬Q = P?⇒¬¬∀P→∀P P? (DN-map ∃Q→∀P (¬∀¬P→¬¬∃P ¬∀¬Q))

  ¬[¬∀P⊎¬∀Q]→∀P×∀Q : DecU P → DecU Q → ¬ (¬ (∀ x → P x) ⊎ ¬ (∀ x → Q x)) →
                     (∀ x → P x) × (∀ x → Q x)
  ¬[¬∀P⊎¬∀Q]→∀P×∀Q P? Q? ¬[¬∀P⊎¬∀Q] =
    Prod.map (P?⇒¬¬∀P→∀P P?) (P?⇒¬¬∀P→∀P Q?) (¬[A⊎B]→¬A×¬B ¬[¬∀P⊎¬∀Q])

module _ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} where
  ∃-undistrib-⊎ : ∃ P ⊎ ∃ Q → ∃ (λ x → P x ⊎ Q x)
  ∃-undistrib-⊎ (inj₁ (x , Px)) = x , inj₁ Px
  ∃-undistrib-⊎ (inj₂ (x , Qx)) = x , inj₂ Qx

  ∃-distrib-⊎ : ∃ (λ x → P x ⊎ Q x) → ∃ P ⊎ ∃ Q
  ∃-distrib-⊎ (x , inj₁ Px) = inj₁ (x , Px)
  ∃-distrib-⊎ (x , inj₂ Qx) = inj₂ (x , Qx)

  ∃-distrib-× : ∃ (λ x → P x × Q x) → ∃ P × ∃ Q
  ∃-distrib-× (x , Px , Qx) = (x , Px) , (x , Qx)

  ∀-undistrib-× : (∀ x → P x) × (∀ x → Q x) → ∀ x → P x × Q x
  ∀-undistrib-× (∀P , ∀Q) x = ∀P x , ∀Q x

  ∀-distrib-× : (∀ x → P x × Q x) → (∀ x → P x) × (∀ x → Q x)
  ∀-distrib-× ∀x→Px×Qx = proj₁ ∘ ∀x→Px×Qx , proj₂ ∘ ∀x→Px×Qx

  ∀-undistrib-⊎ : (∀ x → P x) ⊎ (∀ x → Q x) → ∀ x → P x ⊎ Q x
  ∀-undistrib-⊎ (inj₁ ∀P) x = inj₁ (∀P x)
  ∀-undistrib-⊎ (inj₂ ∀Q) x = inj₂ (∀Q x)

  ¬[¬∃P×¬∃Q]→¬¬∃x→Px⊎Qx : ¬ (¬ ∃ P × ¬ ∃ Q) → ¬ ¬ ∃ λ x → P x ⊎ Q x
  ¬[¬∃P×¬∃Q]→¬¬∃x→Px⊎Qx = DN-map ∃-undistrib-⊎ ∘′ contraposition ¬[A⊎B]→¬A×¬B

  [¬¬∃x→Px⊎Qx]→¬[¬∃P×¬∃Q] : (¬ ¬ ∃ λ x → P x ⊎ Q x) → ¬ (¬ ∃ P × ¬ ∃ Q)
  [¬¬∃x→Px⊎Qx]→¬[¬∃P×¬∃Q] = contraposition ¬A×¬B→¬[A⊎B] ∘′ DN-map ∃-distrib-⊎

  ¬∀¬P×¬∀¬Q→¬¬[∃P×∃Q] : ¬ (∀ x → ¬ P x) × ¬ (∀ x → ¬ Q x) → ¬ ¬ (∃ P × ∃ Q)
  ¬∀¬P×¬∀¬Q→¬¬[∃P×∃Q] = DN-undistrib-× ∘′ Prod.map ¬∀¬P→¬¬∃P ¬∀¬P→¬¬∃P

  ¬¬[∃P×∃Q]→¬∀¬P×¬∀¬Q : ¬ ¬ (∃ P × ∃ Q) → ¬ (∀ x → ¬ P x) × ¬ (∀ x → ¬ Q x)
  ¬¬[∃P×∃Q]→¬∀¬P×¬∀¬Q = Prod.map ¬¬∃P→¬∀¬P ¬¬∃P→¬∀¬P ∘′ DN-distrib-×

  [∀x→Px→Qx]→∀P→∀Q : (∀ x → P x → Q x) → (∀ x → P x) → ∀ x → Q x
  [∀x→Px→Qx]→∀P→∀Q f g x = f x (g x)


-- Andreas, 2012-03-15, example by Nisse
-- {-# OPTIONS --show-implicit -v tc.meta:20 #-}
module Issue585-17 where

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

data ″ℕ″ : Set where
  suc : ″ℕ″ → ″ℕ″

replicate : {A : Set} → ″ℕ″ → A → List A
replicate (suc n) x = x ∷ replicate n x

data P (A B : Set) : List B → Set where
  p : (x : B) → P A B (x ∷ [])

data Q {A B xs} : List B → P A B xs → Set where
  q : ∀ {x xs p} → Q xs p → Q (x ∷ xs) p

foo : {A B : Set} (x : B) (n : ″ℕ″) → Q (replicate n x) (p {A = A} x)
foo x n = bar x n
  where
  bar : {B : Set} (x : B) (n : ″ℕ″) → Q (replicate n x) (p x)
  bar x (suc n) = q (bar x n)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Convenient syntax for "equational reasoning" using a partial order
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.PartialOrderReasoning
         {p₁ p₂ p₃} (P : Poset p₁ p₂ p₃) where

open Poset P
import Relation.Binary.PreorderReasoning as PreR
open PreR preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)


{-# OPTIONS --without-K #-}
module hott.truncation.elim where

open import sum
open import equality
open import function
open import hott.equivalence
open import hott.level
open import hott.loop
open import hott.truncation.core
open import hott.truncation.equality
open import hott.univalence
open import sets.nat
open import sets.unit

is-null : ∀ {i j}{X : Set i}{Y : Set j} → Y → (X → Y) → Set _
is-null y f = ∀ x → y ≡ f x

is-null-level : ∀ {i j}{X : Set i}{Y : Set j} → h 2 Y
              → (y : Y)(f : X → Y) → h 1 (is-null y f)
is-null-level hY y f = Π-level λ x → hY y (f x)

compose-is-null : ∀ {i j k}{X : Set i}{Y : Set j}{Z : Set k}
                → (y : Y)(f : X → Y)(g : Y → Z)
                → is-null y f
                → is-null (g y) (g ∘ f)
compose-is-null y f g c y' = ap g (c y')

Null : ∀ {i j} → ℕ → Set i → Set j → Set _
Null n X Y = Σ (X → Y) λ f → (x : X) → is-null (refl' n (f x)) (mapΩ n f)

-- connected components

Conn : ∀ {i}{X : Set i}(n : ℕ) → Trunc n X → Set _
Conn {X = X} n c = Σ X λ x → [ x ] ≡ c

map-conn : ∀ {i j}{X : Set i}{Y : Set j}(n : ℕ)
         → (c : Trunc n X)
         → (X → Y)
         → (Conn n c → Y)
map-conn n c f (x , p) = f x

conn-decomp : ∀ {i}{X : Set i}(n : ℕ)
            → Σ (Trunc n X) (Conn n) ≅ X
conn-decomp {X = X} n = total-iso [_]

conn-connected : ∀ {i}{X : Set i}(n : ℕ)(c : Trunc n X)
               → contr (Trunc n (Conn n c))
conn-connected {X = X} n c = φ c , lem c
  where
    φ' : (x : X) → Trunc n (Conn n [ x ])
    φ'  x = [ x , refl ]

    φ : (c : Trunc n X) → Trunc n (Conn n c)
    φ = Trunc-dep-elim n (λ c → Trunc n (Conn n c)) (λ _ → Trunc-level n) φ'

    lem' : (c : Trunc n X)(a : Conn n c) → φ c ≡ [ a ]
    lem' .([ x ]) (x , refl) = Trunc-dep-elim-β n
      (λ c → Trunc n (Conn n c))
      (λ _ → Trunc-level n) φ' x

    lem : (c : Trunc n X)(a : Trunc n (Conn n c)) → φ c ≡ a
    lem c = Trunc-dep-elim n (λ a → φ c ≡ a) (λ a → h↑ (Trunc-level n) (φ c) a) (lem' c)

-- main result

module CM {i j} n (X : Set i)(Y : Set j)
          (hY : h (n + 2) Y) where
  cm' : Y → Null n X Y
  cm' y = (λ _ → y) , (λ x p → sym (mapΩ-const n y x p))

  cm : (Trunc (suc n) X → Y) → Null n X Y
  cm f = (λ x → f [ x ]) , λ x
       → subst₂ (is-null) (mapΩ-refl n f) (eq x)
               (compose-is-null (refl' n [ x ]) (mapΩ n [_]) (mapΩ n f)
                 (λ p → h1⇒prop (Ω-level n hT) _ _))
     where
       f' : X → Y
       f' x = f [ x ]

       eq' : (x : X)(p : Ω n x) → mapΩ n f (mapΩ n [_] p) ≡ mapΩ n f' p
       eq' x p = mapΩ-hom n [_] f p

       eq : (x : X) → mapΩ n f ∘ mapΩ n [_] ≡ mapΩ n f'
       eq x = funext (eq' x)

       hT : h (n + 1) (Trunc (suc n) X)
       hT = subst (λ m → h m (Trunc (suc n) X)) (+-commutativity 1 n) (Trunc-level (suc n))

Trunc-elim' : ∀ {i j} n (X : Set i)(Y : Set j) → h (n + 2) Y
            → (Trunc (suc n) X → Y) ≅ Null n X Y

null-connected : ∀ {i j} n {X : Set i}{Y : Set j}
               → contr (Trunc (suc n) X)
               → h (n + 2) Y
               → (f : X → Y)
               → ((x : X) → is-null (refl' n (f x)) (mapΩ n f {x}))
               → (x : X) → is-null (f x) f
null-connected zero hX hY f c x₀ x₁ = c x₀ x₁
null-connected (suc n) {X} hX hY f c x₀ x₁
  = φ (trunc-equality (suc n) (h1⇒prop (h↑ hX) _ _))
  where
    ap-null : (x y : X)(p : x ≡ y) → is-null (refl' n (ap f p)) (mapΩ n (ap f) {p})
    ap-null x .x refl = c x

    φ : Trunc (suc n) (x₀ ≡ x₁) → f x₀ ≡ f x₁
    φ = invert (Trunc-elim' n (x₀ ≡ x₁) (f x₀ ≡ f x₁) (hY _ _))
        ( ap f , ap-null x₀ x₁ )

Trunc-elim-connected : ∀ {i j} n (X : Set i)(Y : Set j)
                     → contr (Trunc (suc n) X)
                     → h (n + 2) Y
                     → Y ≅ Null n X Y
Trunc-elim-connected n X Y hX hY = ≈⇒≅ (cm' , cm-equiv' (proj₁ hX))
  where
    open CM n X Y hY

    module _ (x₀ : X) where
      g : Null n X Y → Y
      g (f , c) = f x₀

      α : (y : Y) → g (cm' y) ≡ y
      α y = refl

      β : (x : Null n X Y) → cm' (g x) ≡ x
      β (f , c) = unapΣ ( (funext λ x → null-connected n hX hY f c _ _)
                        , h1⇒prop (Π-level λ x → is-null-level (Ω-level n hY) _ _) _ _)

      f-iso : Y ≅ Null n X Y
      f-iso = iso cm' g α β

    cm-equiv : X → weak-equiv cm'
    cm-equiv x₀ = proj₂ (≅⇒≈ (f-iso x₀))

    cm-equiv' : Trunc (suc n) X → weak-equiv cm'
    cm-equiv' = invert (Trunc-elim-iso (suc n) X (weak-equiv cm') (h! (weak-equiv-h1 cm'))) cm-equiv

abstract
  Trunc-elim'₀ : ∀ {i j} n (X : Set i)(Y : Set j) → h (n + 2) Y
              → (Trunc (suc n) X → Y) ≅ Null n X Y
  Trunc-elim'₀ n X Y hY = begin
      (Trunc (suc n) X → Y)
    ≅⟨ ( Π-ap-iso refl≅ λ c
       → Trunc-elim-connected n _ _ (conn-connected (suc n) c) hY) ⟩
      ((c : Trunc (suc n) X) → Null n (Conn (suc n) c) Y)
    ≅⟨ ΠΣ-swap-iso ⟩
      ( Σ ((c : Trunc (suc n) X) → Conn (suc n) c → Y) λ f
      → ((c : Trunc (suc n) X) → (x : Conn (suc n) c) → is-null _ (mapΩ n (f c))) )
    ≅⟨ sym≅ ( Σ-ap-iso (curry-iso (λ _ _ → Y)) λ f
            → curry-iso λ c x → is-null _ (mapΩ n (λ x' → f (c , x')))  ) ⟩
      ( Σ ((Σ (Trunc (suc n) X) λ c → Conn (suc n) c) → Y) λ f
      → (((x' : (Σ (Trunc (suc n) X) λ c → Conn (suc n) c))
           → is-null _ (mapΩ n (λ x → f (proj₁ x' , x))))) )
    ≅⟨ ( Σ-ap-iso' (→-ap-iso (conn-decomp (suc n)) refl≅) λ f
       → Π-ap-iso (conn-decomp (suc n)) λ x → refl≅ ) ⟩
      ( Σ (X → Y) λ f
      → (((x : X) → is-null _ (mapΩ n (λ x → f (proj₁ x)) {x , refl}))) )
    ≅⟨ ( Σ-ap-iso refl≅ λ f → Π-ap-iso refl≅ λ x → lem f x ) ⟩
      Null n X Y
    ∎
    where
      open ≅-Reasoning

      lem : (f : X → Y) (x : X)
          → is-null (refl' n (f x)) (mapΩ n (map-conn (suc n) [ x ] f) {x , refl})
          ≅ is-null (refl' n (f x)) (mapΩ n f {x})
      lem f x = ≡⇒≅ (ap (is-null (refl' n (f x))) (funext hom)) ·≅ sym≅ is-const-equiv
        where
          π : Conn (suc n) [ x ] → X
          π = proj₁

          hom : (p : Ω n (x , refl))
              → mapΩ n (map-conn (suc n) [ x ] f) p
              ≡ mapΩ n f (mapΩ n proj₁ p)
          hom p = sym (mapΩ-hom n proj₁ f p)

          φ : Ω n {Conn (suc n) [ x ]} (x , refl) ≅ Ω n x
          φ = loop-sum n λ a → Trunc-level (suc n) _ _

          is-const-equiv : is-null {X = Ω n x} (refl' n (f x)) (mapΩ n f {x})
                         ≅ is-null {X = Ω n {Conn (suc n) [ x ]} (x , refl)}
                                   (refl' n (f x))
                                   (mapΩ n f ∘ mapΩ n proj₁)
          is-const-equiv = Π-ap-iso (sym≅ φ) λ p
                         → refl≅

  Trunc-elim'-β₀ : ∀ {i j n}{X : Set i}{Y : Set j} (hY : h (n + 2) Y)
                → (f : Trunc (suc n) X → Y)
                → proj₁ (apply (Trunc-elim'₀ n X Y hY) f) ≡ (λ x → f [ x ])
  Trunc-elim'-β₀ hY f = refl

  Trunc-elim'-β : ∀ {i j n}{X : Set i}{Y : Set j} (hY : h (n + 2) Y)
                → (f : Trunc (suc n) X → Y)
                → apply (Trunc-elim'₀ n X Y hY) f ≡ CM.cm n X Y hY f
  Trunc-elim'-β {n = n} hY f = unapΣ
    ( Trunc-elim'-β₀ hY f
    , h1⇒prop (Π-level λ x → is-null-level (Ω-level n hY) _ _) _ _ )

Trunc-elim' n X Y hY = ≈⇒≅ (cm , cm-we)
  where
    open CM n X Y hY

    cm-eq : apply (Trunc-elim'₀ n X Y hY) ≡ cm
    cm-eq = funext (Trunc-elim'-β hY)

    cm-we : weak-equiv cm
    cm-we = subst weak-equiv cm-eq (proj₂ (≅⇒≈ (Trunc-elim'₀ n X Y hY)))

-- example

Repr : ∀ {i} → Set i → Set _
Repr {i} A = Σ (Trunc 2 A → Set i) λ hom
       → (a : A) → hom [ a ] ≅ (a ≡ a)

Braiding : ∀ {i} → Set i → Set _
Braiding A = {a : A}(p q : a ≡ a) → p · q ≡ q · p

braiding-repr : ∀ {i}{A : Set i} → h 3 A → Braiding A → Repr A
braiding-repr {i}{A} hA γ = (λ c → proj₁ (hom c)) , λ a
                          → ≡⇒≅ (ap proj₁ (hom-β a))
  where
    eq : A → Set _
    eq a = (a ≡ a)

    hom' : A → Type _ 2
    hom' a = eq a , hA a a

    type-eq-iso : ∀ {n}{X Y : Type i n}
                → (X ≡ Y) ≅ (proj₁ X ≈ proj₁ Y)
    type-eq-iso {n}{X}{Y} = begin
        (X ≡ Y)
      ≅⟨ sym≅ Σ-split-iso ⟩
        (Σ (proj₁ X ≡ proj₁ Y) λ p → subst (h n) p (proj₂ X) ≡ proj₂ Y)
      ≅⟨ (Σ-ap-iso refl≅ λ p → contr-⊤-iso (hn-h1 n _ _ _)) ⟩
        ((proj₁ X ≡ proj₁ Y) × ⊤)
      ≅⟨ ×-right-unit ⟩
        (proj₁ X ≡ proj₁ Y)
      ≅⟨ uni-iso ⟩
        (proj₁ X ≈ proj₁ Y)
      ∎
      where open ≅-Reasoning

    type-eq : ∀ {n}{X : Type i n}{p : X ≡ X}
            → ((x : proj₁ X) → coerce (ap proj₁ p) x ≡ x)
            → p ≡ refl
    type-eq f = invert≅ (iso≡ type-eq-iso) (unapΣ
              ( funext f , h1⇒prop (weak-equiv-h1 _) _ _))

    ap-eq : {a b : A}(p : a ≡ b)(q : a ≡ a) → coerce (ap proj₁ (ap hom' p)) q ≡ sym p · q · p
    ap-eq refl q = sym (left-unit q)

    hom-null : (a : A) → is-null refl (mapΩ 1 hom' {a})
    hom-null a p = sym (type-eq λ q → ap-eq p q
                                    · ap (λ z → z · p) (γ (sym p) q)
                                    · associativity q (sym p) p
                                    · ap (λ z → q · z) (right-inverse p)
                                    · left-unit q)

    hom-iso : (Trunc 2 A → Type i 2) ≅ Null 1 A (Type i 2)
    hom-iso = Trunc-elim' 1 A (Type i 2) type-level

    hom : Trunc 2 A → Type _ 2
    hom = invert hom-iso (hom' , hom-null)

    hom-β : (a : A) → hom [ a ] ≡ hom' a
    hom-β a = funext-inv (ap proj₁ (_≅_.iso₂ hom-iso (hom' , hom-null))) a


module Data.Num.Sandbox.WF where

open import Data.Nat
-- open import Relation.Binary
--
-- open DecTotalOrder decTotalOrder
--   using (trans)
--
-- data Acc (n : ℕ) : Set where
--     acc : (∀ m → m < n → Acc m) → Acc n
--
-- go0 : (m : ℕ) → m < 0 → Acc m
-- go0 m ()
--
-- <-wf : ∀ n → Acc n
-- <-wf n = acc (go n)
--     where   go : (n m : ℕ) → m < n → Acc m
--             go zero m ()
--             go (suc n₁) zero m<n = acc (λ _ → λ ())
--             go (suc n₁) (suc m) (s≤s m<n₁) = acc (λ m₁ m₁<m+1 → go n₁ m₁ (trans m₁<m+1 m<n₁))

pp : ℕ → ℕ
pp zero = zero
pp (suc zero) = zero
pp (suc (suc n)) = n
--
-- f : ℕ → ℕ
-- f n = go n (<-wf n)
--     where
--         go : ∀ n → Acc n → ℕ
--         go zero    _ = zero
--         go (suc n) (acc a) = go (pp (suc n)) (a (pp (suc n)) {!   !})

open import Induction.Nat

half : ℕ → ℕ
half = <-rec _ go
    where   go : (x : ℕ) → ((y : ℕ) → suc y ≤′ x → ℕ) → ℕ
            go zero acc = zero
            go (suc zero) acc = zero
            go (suc (suc n)) acc = suc (acc n (≤′-step ≤′-refl))


module ConstructorHeadedDivergenceIn2-2-10 where

data ⊤ : Set where
  tt : ⊤

data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

{- Brandon Moore reports (July 2011)
In 2.2.10 the following code seems to cause typechecking
to diverge.
-}

f : ℕ → Set
f zero = ⊤
f (suc n) = ℕ × f n

enum : (n : ℕ) → f n
enum zero = tt
enum (suc n) = n , enum n

n : ℕ
n = _

test : f n
test = enum (suc n)
{-
This typechecks quickly if the definition
of test is changed to

test = enum n

I think the problem is that the body has type ℕ × f n,
and unifying it with the expected type f n invokes the
constructor-headed function specialization to resolve
n to suc n', and the process repeats.

Brandon
-}

-- Andreas, 2011-07-28 This bug is not reproducible in the darcs
-- version.
--
-- This file should fail with unresolved metas.


{-# OPTIONS --safe #-}
module Cubical.Data.Int.MoreInts.DiffInt.Properties where

open import Cubical.Foundations.HLevels

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence

open import Cubical.Data.Int.MoreInts.DiffInt.Base
open import Cubical.Data.Nat as ℕ renaming (_+_ to _+ℕ_ ; _·_ to _*ℕ_)
open import Cubical.Data.Sigma
open import Cubical.Data.Bool

open import Cubical.Relation.Binary.Base
open import Cubical.Relation.Nullary

open import Cubical.HITs.SetQuotients as SetQuotients
open import Cubical.HITs.PropositionalTruncation as PropositionalTruncation
open import Cubical.Foundations.Isomorphism

open BinaryRelation

relIsEquiv : isEquivRel rel
relIsEquiv = equivRel {A = ℕ × ℕ} relIsRefl relIsSym relIsTrans
  where
    relIsRefl : isRefl rel
    relIsRefl (a0 , a1) = refl

    relIsSym : isSym rel
    relIsSym (a0 , a1) (b0 , b1) p = sym p

    relIsTrans : isTrans rel
    relIsTrans (a0 , a1) (b0 , b1) (c0 , c1) p0 p1 =
      inj-m+ {m = (b0 +ℕ b1)} ((b0 +ℕ b1) +ℕ (a0 +ℕ c1) ≡⟨ ℕ.+-assoc (b0 +ℕ b1) a0 c1  ⟩
            ((b0 +ℕ b1) +ℕ a0) +ℕ c1 ≡[ i ]⟨ ℕ.+-comm b0 b1 i +ℕ a0   +ℕ c1 ⟩
            ((b1 +ℕ b0) +ℕ a0) +ℕ c1 ≡[ i ]⟨ ℕ.+-comm (b1 +ℕ b0) a0 i +ℕ c1 ⟩
            (a0 +ℕ (b1 +ℕ b0)) +ℕ c1 ≡[ i ]⟨ ℕ.+-assoc a0 b1 b0 i    +ℕ c1 ⟩
            (a0 +ℕ b1) +ℕ b0 +ℕ c1 ≡⟨ sym (ℕ.+-assoc (a0 +ℕ b1) b0 c1) ⟩
            (a0 +ℕ b1) +ℕ (b0 +ℕ c1) ≡⟨ cong (λ p → p . fst +ℕ p .snd) (transport ΣPath≡PathΣ (p0 , p1))⟩
            (b0 +ℕ a1) +ℕ (c0 +ℕ b1) ≡⟨ sym (ℕ.+-assoc b0 a1 (c0 +ℕ b1))⟩
            b0 +ℕ (a1 +ℕ (c0 +ℕ b1)) ≡[ i ]⟨ b0 +ℕ (a1 +ℕ ℕ.+-comm c0 b1 i) ⟩
            b0 +ℕ (a1 +ℕ (b1 +ℕ c0)) ≡[ i ]⟨ b0 +ℕ ℕ.+-comm a1 (b1 +ℕ c0) i ⟩
            b0 +ℕ ((b1 +ℕ c0) +ℕ a1) ≡[ i ]⟨ b0 +ℕ ℕ.+-assoc b1 c0 a1 (~ i) ⟩
            b0 +ℕ (b1 +ℕ (c0 +ℕ a1)) ≡⟨ ℕ.+-assoc b0 b1 (c0 +ℕ a1)⟩
            (b0 +ℕ b1) +ℕ (c0 +ℕ a1) ∎ )

relIsProp : BinaryRelation.isPropValued rel
relIsProp a b x y = isSetℕ _ _ _ _

discreteℤ : Discrete ℤ
discreteℤ = discreteSetQuotients (discreteΣ discreteℕ λ _ → discreteℕ) relIsProp relIsEquiv (λ _ _ → discreteℕ _ _)

private
  _ : Dec→Bool (discreteℤ [ (3 , 5) ] [ (4 , 6) ]) ≡ true
  _ = refl

  _ : Dec→Bool (discreteℤ [ (3 , 5) ] [ (4 , 7) ]) ≡ false
  _ = refl

  _+ℕ'_ : (ℕ × ℕ) → (ℕ × ℕ) → (ℕ × ℕ)
  (n₁ , n₂) +ℕ' (m₁ , m₂) = (n₁ +ℕ m₁ , n₂ +ℕ m₂)

  [_-ℕ'_] : ℕ → ℕ → ℤ
  [ x -ℕ' y ] = [ x , y ]

  ℤ-cancelˡ : ∀ {a b} (c : ℕ) → [ (c ℕ.+ a) -ℕ' (c +ℕ b) ] ≡ [ a -ℕ' b ]
  ℤ-cancelˡ {a} {b} c = eq/ _ _ (tmp a b c)
    where tmp : ∀ a b c → rel (c +ℕ a , c +ℕ b) (a , b)
          tmp a b c =
            c +ℕ a +ℕ b
              ≡⟨ cong (λ x → x +ℕ b) (ℕ.+-comm c a) ⟩
            a +ℕ c +ℕ b
              ≡⟨ sym(ℕ.+-assoc a c b) ⟩
            a +ℕ (c +ℕ b) ∎

  ℤ-cancelʳ : ∀ {a b} (c : ℕ) → [ a +ℕ c -ℕ' b +ℕ c ] ≡ [ a -ℕ' b ]
  ℤ-cancelʳ {a} {b} c = eq/ _ _ (tmp a b c)
    where tmp : ∀ a b c → rel (a +ℕ c , b +ℕ c) (a , b)
          tmp a b c =
            a +ℕ c +ℕ b
              ≡⟨ sym(ℕ.+-assoc a c b) ⟩
            a +ℕ (c +ℕ b)
              ≡⟨ cong (λ x → a +ℕ x) (ℕ.+-comm c b) ⟩
            a +ℕ (b +ℕ c) ∎

  -- right congruence
  +-right-congruence : ∀ x y z → rel y z → rel (x +ℕ' y) (x +ℕ' z)
  +-right-congruence x y z  p =
    (fst x +ℕ fst y) +ℕ (snd x +ℕ snd z)
      ≡⟨ cong (λ x' → (fst x +ℕ fst y) +ℕ x') (ℕ.+-comm (snd x) (snd z)) ⟩
    (fst x +ℕ fst y) +ℕ (snd z +ℕ snd x)
      ≡⟨ ℕ.+-assoc (fst x +ℕ fst y) (snd z) (snd x) ⟩
    fst x +ℕ fst y +ℕ snd z +ℕ snd x
      ≡⟨ cong (λ x' → x' +ℕ snd x) (sym (ℕ.+-assoc (fst x) (fst y) (snd z))) ⟩
    fst x +ℕ (fst y +ℕ snd z) +ℕ snd x
      ≡⟨ cong (λ x' → fst x +ℕ x' +ℕ snd x) p ⟩
    fst x +ℕ (fst z +ℕ snd y) +ℕ snd x
      ≡⟨ cong (λ x' → x' +ℕ snd x) (ℕ.+-assoc (fst x) (fst z) (snd y)) ⟩
    fst x +ℕ fst z +ℕ snd y +ℕ snd x
      ≡⟨ sym (ℕ.+-assoc (fst x +ℕ fst z) (snd y) (snd x)) ⟩
    fst x +ℕ fst z +ℕ (snd y +ℕ snd x)
      ≡⟨ cong (λ x' → fst x +ℕ fst z +ℕ x') (ℕ.+-comm (snd y) (snd x)) ⟩
    fst x +ℕ fst z +ℕ (snd x +ℕ snd y) ∎

  +-left-congruence : ∀ x y z → rel x y → rel (x +ℕ' z) (y +ℕ' z)
  +-left-congruence x y z p =
    (fst x +ℕ fst z) +ℕ (snd y +ℕ snd z)
      ≡⟨ cong (λ x' → x' +ℕ (snd y +ℕ snd z)) (ℕ.+-comm (fst x) (fst z)) ⟩
    (fst z +ℕ fst x) +ℕ (snd y +ℕ snd z)
      ≡⟨ ℕ.+-assoc (fst z +ℕ fst x) (snd y) (snd z) ⟩
    fst z +ℕ fst x +ℕ snd y +ℕ snd z
      ≡⟨ cong (λ x' → x' +ℕ snd z) (sym (ℕ.+-assoc (fst z) (fst x) (snd y))) ⟩
    fst z +ℕ (fst x +ℕ snd y) +ℕ snd z
      ≡⟨ cong (λ x' → fst z +ℕ x' +ℕ snd z) p ⟩
    fst z +ℕ (fst y +ℕ snd x) +ℕ snd z
      ≡⟨ cong (λ x' → x' +ℕ snd z) (ℕ.+-assoc (fst z) (fst y) (snd x)) ⟩
    fst z +ℕ fst y +ℕ snd x +ℕ snd z
      ≡⟨ sym (ℕ.+-assoc (fst z +ℕ fst y) (snd x) (snd z)) ⟩
    fst z +ℕ fst y +ℕ (snd x +ℕ snd z)
      ≡⟨ cong (λ x' → x' +ℕ (snd x +ℕ snd z)) (ℕ.+-comm (fst z) (fst y)) ⟩
    fst y +ℕ fst z +ℕ (snd x +ℕ snd z) ∎

ℤ-isSet : isSet ℤ
ℤ-isSet m n p q = squash/ m n p q

_+_ : ℤ → ℤ → ℤ
_+_ = SetQuotients.rec2 ℤ-isSet (λ x y → [ x +ℕ' y ]) feql feqr
    where
      feql : (a b c : ℕ × ℕ) (r : rel a b) → [ a +ℕ' c ] ≡ [ b +ℕ' c ]
      feql a b c r = eq/ (a +ℕ' c) (b +ℕ' c) (+-left-congruence a b c r)
      feqr : (a b c : ℕ × ℕ) (r : rel b c) → [ a +ℕ' b ] ≡ [ a +ℕ' c ]
      feqr a b c r = eq/ (a +ℕ' b) (a +ℕ' c) (+-right-congruence a b c r)

private
  zero-identityˡ-lem : (a : ℕ)(b : ℤ) → (Σ (ℕ × ℕ) ( λ (c , d) → [ (c , d) ]  ≡ b )) → [ a , a ] + b ≡ b
  zero-identityˡ-lem a b ( (c , d) , p ) =
    [ a , a ] + b           ≡⟨ cong (λ x → [ a , a ] + x) (sym p) ⟩
    [ a , a ] + [ c , d ]   ≡⟨ ℤ-cancelˡ a ⟩
    [ c , d ]               ≡⟨ p ⟩
    b ∎

  zero-identityʳ-lem : (a : ℕ)(b : ℤ) → (Σ (ℕ × ℕ) ( λ (c , d) → [ (c , d) ]  ≡ b )) → b + [ a , a ] ≡ b
  zero-identityʳ-lem a b ( (c , d) , p ) =
    b + [ a , a ]           ≡⟨ cong (λ x → x + [ a , a ]) (sym(p)) ⟩
    [ c , d ] + [ a , a ]   ≡⟨ ℤ-cancelʳ a ⟩
    [ c , d ]               ≡⟨ p ⟩
    b ∎

zero-identityˡ : (a : ℕ) (b : ℤ) → [ a , a ] + b ≡ b
zero-identityˡ a b = PropositionalTruncation.rec (lem2 a b) (zero-identityˡ-lem a b) ([]surjective b)
                     where
                       lem2 : (a : ℕ) (b : ℤ) → isProp ([ a , a ] + b ≡ b)
                       lem2 a b = ℤ-isSet ([ a , a ] + b) b

zero-identityʳ : (a : ℕ)(b : ℤ) → b + [ a , a ] ≡ b
zero-identityʳ a b = PropositionalTruncation.rec (lem2 a b) (zero-identityʳ-lem a b) ([]surjective b)
                     where
                       lem2 : (a : ℕ) (b : ℤ) → isProp (b + [ a , a ] ≡ b)
                       lem2 a b = ℤ-isSet (b + [ a , a ]) b

-ℤ_  : ℤ → ℤ
-ℤ [ a ] = [ snd a , fst a ]
-ℤ eq/ a b r i = eq/ (snd a , fst a) (snd b , fst b) (tmp a b r) i
                  where
                    tmp : ∀ a b → fst a +ℕ snd b ≡ fst b +ℕ snd a → snd a +ℕ fst b ≡ snd b +ℕ fst a
                    tmp a b r =
                      snd a +ℕ fst b ≡⟨ ℕ.+-comm (snd a) (fst b) ⟩
                      fst b +ℕ snd a ≡⟨ sym r ⟩
                      fst a +ℕ snd b ≡⟨ ℕ.+-comm (fst a) (snd b) ⟩
                      snd b +ℕ fst a ∎
-ℤ squash/ a a₁ p q i i₁ = squash/ (-ℤ a) (-ℤ a₁) (cong (λ x → -ℤ x) p) (cong (λ x → -ℤ x) q) i i₁

private
  -ℤ-invʳ-lem : (b : ℤ) → (Σ (ℕ × ℕ) ( λ (c , d) → [ (c , d) ]  ≡ b )) → b + (-ℤ b) ≡ [ 0 , 0 ]
  -ℤ-invʳ-lem b ( (c , d) , p ) =
    b + (-ℤ b)
      ≡⟨ cong (λ x → x + (-ℤ b)) (sym p) ⟩
    [ c , d ] + (-ℤ b)
      ≡⟨ cong (λ x → [ c , d ] + (-ℤ x)) (sym p) ⟩
    [ c +ℕ d , d +ℕ c ]
      ≡⟨ cong (λ x → [ c +ℕ d , x ]) (ℕ.+-comm d c) ⟩
    [ c +ℕ d , c +ℕ d ]
      ≡⟨ ℤ-cancelˡ c ⟩
    [ d -ℕ' d ]
      ≡⟨ sym(ℤ-cancelʳ 0) ⟩
    [ d +ℕ 0 -ℕ' d +ℕ 0 ]
      ≡⟨ ℤ-cancelˡ d ⟩
    [ 0 , 0 ] ∎

  -ℤ-invˡ-lem : (b : ℤ) → (Σ (ℕ × ℕ) ( λ (c , d) → [ (c , d) ]  ≡ b )) → (-ℤ b) + b ≡ [ 0 , 0 ]
  -ℤ-invˡ-lem b ( (c , d) , p ) =
    (-ℤ b) + b
      ≡⟨ cong (λ x → (-ℤ b) + x) (sym p) ⟩
    (-ℤ b) + [ c , d ]
      ≡⟨ cong (λ x → (-ℤ x) + [ c , d ]) (sym p) ⟩
    [ d +ℕ c , c +ℕ d ]
      ≡⟨ cong (λ x → [ x , c +ℕ d ]) (ℕ.+-comm d c) ⟩
    [ c +ℕ d , c +ℕ d ]
      ≡⟨ ℤ-cancelˡ c ⟩
    [ d -ℕ' d ]
      ≡⟨ sym(ℤ-cancelʳ 0) ⟩
    [ d +ℕ 0 -ℕ' d +ℕ 0 ]
      ≡⟨ ℤ-cancelˡ d ⟩
    [ 0 , 0 ] ∎

_-_ : ℤ → ℤ → ℤ
a - b = a + (-ℤ b)

-ℤ-invʳ : (b : ℤ) → b + (-ℤ b) ≡ [ 0 , 0 ]
-ℤ-invʳ b = PropositionalTruncation.rec (lem2 b) (-ℤ-invʳ-lem b) ([]surjective b)
             where
               lem2 : (b : ℤ) → isProp (b + (-ℤ b) ≡ [ 0 , 0 ])
               lem2 b = ℤ-isSet (b + (-ℤ b)) [ 0 , 0 ]

-ℤ-invˡ : (b : ℤ) → (-ℤ b) + b ≡ [ 0 , 0 ]
-ℤ-invˡ b = PropositionalTruncation.rec (lem2 b) (-ℤ-invˡ-lem b) ([]surjective b)
             where
               lem2 : (b : ℤ) → isProp ((-ℤ b) + b ≡ [ 0 , 0 ])
               lem2 b = ℤ-isSet ((-ℤ b) + b) [ 0 , 0 ]

+ℤ-assoc : ∀ x y z → x + (y + z) ≡ (x + y) + z
+ℤ-assoc = elimProp3 (λ _ _ _ → ℤ-isSet _ _)
    (λ { (a , b) (c , d) (e , f) i → [ ℕ.+-assoc a c e i -ℕ' ℕ.+-assoc b d f i ] })

+ℤ-comm : ∀ x y → x + y ≡ y + x
+ℤ-comm = elimProp2 (λ _ _ → ℤ-isSet _ _)
         λ ( a , b ) ( c , d ) i → [ ℕ.+-comm a c i -ℕ'  ℕ.+-comm b d i ]


{-# OPTIONS --termination-depth=2 #-}

module TerminationWithMerge where

data List (a : Set) : Set where
  []  : List a
  _∷_ : a -> List a -> List a

-- infix

postulate
  a : Set
  Bool : Set
  _≤?_ : a -> a -> Bool

merge : List a -> List a -> List a
merge xs           []           = xs
merge []           ys           = ys
merge (x ∷ xs) (y ∷ ys) with x ≤? y
... | true  = x ∷ merge xs  (y ∷ ys)
... | false = y ∷ merge (x ∷ xs) ys

{- still cannot pass the termination checker, since

   size(x :: xs) <= 1 + max(size(x),size(xs))

but the termination checker does not have maximum, and no
type information that tells it to ignore x in this caculation.

Solution: sized types!
-}


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

open import Categories.Category

module Categories.Diagram.Pullback.Properties {o ℓ e} (C : Category o ℓ e) where

open import Function using (_$_)

open import Categories.Category.BinaryProducts C
open import Categories.Category.Cartesian C
open import Categories.Diagram.Pullback C
open import Categories.Diagram.Equalizer C hiding (up-to-iso)
open import Categories.Object.Product C hiding (up-to-iso)
open import Categories.Object.Terminal C hiding (up-to-iso)
open import Categories.Morphism C
open import Categories.Morphism.Reasoning C
open import Categories.Category.Complete.Finitely using (FinitelyComplete)
open import Data.Product using (∃; _,_)

private
  open Category C
  variable
    X Y Z : Obj
    f g h i : X ⇒ Y
open HomReasoning
open Equiv

-- pullbacks of a monomorphism along itself give us the identity arrow.
pullback-self-mono : Mono f → IsPullback id id f f
pullback-self-mono mono = record
  { commute = refl
  ; universal = λ {X} {h₁} {h₂} eq → h₁
  ; unique = λ id∘i≈h₁ _ → ⟺ identityˡ ○ id∘i≈h₁
  ; p₁∘universal≈h₁ = identityˡ
  ; p₂∘universal≈h₂ = λ {X} {h₁} {h₂} {eq} → identityˡ ○ mono h₁ h₂ eq
  }

-- pullback from a terminal object is the same as a product
module _ (t : Terminal) where
  open Terminal t

  pullback-⊤⇒product : Pullback (! {X}) (! {Y}) → Product X Y
  pullback-⊤⇒product p = record
    { A×B      = P
    ; π₁       = p₁
    ; π₂       = p₂
    ; ⟨_,_⟩    = λ f g → universal (!-unique₂ {f = ! ∘ f} {g = ! ∘ g})
    ; project₁ = p₁∘universal≈h₁
    ; project₂ = p₂∘universal≈h₂
    ; unique   = λ eq eq′ → ⟺ (unique eq eq′)
    }
    where open Pullback p

  product⇒pullback-⊤ : Product X Y → Pullback (! {X}) (! {Y})
  product⇒pullback-⊤ p = record
    { p₁              = π₁
    ; p₂              = π₂
    ; isPullback = record
      { commute         = !-unique₂
      ; universal       = λ {_ f g} _ → ⟨ f , g ⟩
      ; unique          = λ eq eq′ → ⟺ (unique eq eq′)
      ; p₁∘universal≈h₁ = project₁
      ; p₂∘universal≈h₂ = project₂
      }
    }
    where open Product p

-- pullbacks respect _≈_
module _ (p : Pullback f g) where
  open Pullback p

  pullback-resp-≈ : f ≈ h → g ≈ i → Pullback h i
  pullback-resp-≈ eq eq′ = record
    { p₁              = p₁
    ; p₂              = p₂
    ; isPullback = record
      { commute         = ∘-resp-≈ˡ (⟺ eq) ○ commute ○ ∘-resp-≈ˡ eq′
      ; universal       = λ eq″ → universal (∘-resp-≈ˡ eq ○ eq″ ○ ∘-resp-≈ˡ (⟺ eq′))
      ; unique          = unique
      ; p₁∘universal≈h₁ = p₁∘universal≈h₁
      ; p₂∘universal≈h₂ = p₂∘universal≈h₂
      }
    }

-- Some facts about pulling back along identity
module _ (p : Pullback id f) where
  open Pullback p

  -- This is a more subtle way of saying that 'p₂ ≈ id', without involving heterogenous equality.
  pullback-identity : universal id-comm-sym ∘ p₂ ≈ id
  pullback-identity = begin
    universal Basic.id-comm-sym ∘ p₂ ≈⟨ unique ( pullˡ p₁∘universal≈h₁ ) (pullˡ p₂∘universal≈h₂)  ⟩
    universal eq                     ≈⟨ universal-resp-≈ (⟺ commute ○ identityˡ) identityˡ ⟩
    universal commute                ≈˘⟨ Pullback.id-unique p ⟩
    id ∎
    where
      eq : id ∘ f ∘ p₂ ≈ f ∘ id ∘ p₂
      eq = begin
        (id ∘ f ∘ p₂) ≈⟨ elimˡ Equiv.refl ⟩
        (f ∘ p₂)      ≈˘⟨ refl⟩∘⟨ identityˡ ⟩
        (f ∘ id ∘ p₂) ∎

-- pullbacks in Cartesian categories create equalizers
module _ (pullbacks : ∀ {X Y Z} (f : X ⇒ Z) (g : Y ⇒ Z) → Pullback f g)
         (cartesian : Cartesian) where
  open Cartesian cartesian
  open BinaryProducts products using (⟨_,_⟩; π₁; π₂; ⟨⟩-cong₂; ⟨⟩∘; project₁; project₂)

  pullback×cartesian⇒equalizer : Equalizer f g
  pullback×cartesian⇒equalizer {f = f} {g = g} = record
    { arr       = p.p₁
    ; isEqualizer = record
      { equality  = equality
      ; equalize  = λ {_ h} eq → p.universal $ begin
        ⟨ f , g ⟩ ∘ h               ≈⟨ ⟨⟩∘ ⟩
        ⟨ f ∘ h , g ∘ h ⟩           ≈˘⟨ ⟨⟩-cong₂ identityˡ (identityˡ ○ eq) ⟩
        ⟨ id ∘ f ∘ h , id ∘ f ∘ h ⟩ ≈˘⟨ ⟨⟩∘ ⟩
        ⟨ id , id ⟩ ∘ f ∘ h         ∎
      ; universal = ⟺ p.p₁∘universal≈h₁
      ; unique    = λ eq → p.unique (⟺ eq)
                                    (⟺ (pullˡ eq′) ○ ⟺ (∘-resp-≈ʳ eq))
      }
    }
    where p : Pullback ⟨ f , g ⟩ ⟨ id , id ⟩
          p = pullbacks _ _
          module p = Pullback p
          eq : ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩ ≈ ⟨ p.p₂ , p.p₂ ⟩
          eq = begin
            ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩      ≈˘⟨ ⟨⟩∘ ⟩
            ⟨ f , g ⟩ ∘ p.p₁             ≈⟨ p.commute ⟩
            ⟨ id , id ⟩ ∘ p.p₂           ≈⟨ ⟨⟩∘ ⟩
            ⟨ id ∘ p.p₂ , id ∘ p.p₂ ⟩    ≈⟨ ⟨⟩-cong₂ identityˡ identityˡ ⟩
            ⟨ p.p₂ , p.p₂ ⟩              ∎
          eq′ : f ∘ p.p₁ ≈  p.p₂
          eq′ = begin
            f ∘ p.p₁                     ≈˘⟨ project₁ ⟩
            π₁ ∘ ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩ ≈⟨ refl⟩∘⟨ eq ⟩
            π₁ ∘ ⟨ p.p₂ , p.p₂ ⟩         ≈⟨ project₁ ⟩
            p.p₂                         ∎
          equality : f ∘ p.p₁ ≈ g ∘ p.p₁
          equality = begin
            f ∘ p.p₁                     ≈⟨ eq′ ⟩
            p.p₂                         ≈˘⟨ project₂ ⟩
            π₂ ∘ ⟨ p.p₂ , p.p₂ ⟩         ≈˘⟨ refl⟩∘⟨ eq ⟩
            π₂ ∘ ⟨ f ∘ p.p₁ , g ∘ p.p₁ ⟩ ≈⟨ project₂ ⟩
            g ∘ p.p₁                     ∎

-- all pullbacks and a terminal object make a category finitely complete
pullback-⊤⇒FinitelyComplete : (∀ {X Y Z} (f : X ⇒ Z) (g : Y ⇒ Z) → Pullback f g) → Terminal → FinitelyComplete C
pullback-⊤⇒FinitelyComplete pullbacks ⊤ = record
  { cartesian = cartesian
  ; equalizer = λ _ _ → pullback×cartesian⇒equalizer pullbacks cartesian
  }
    where
      open Category hiding (Obj)
      open Pullback
      open Terminal ⊤ hiding (⊤)

      _×_ : (A B : Obj) → Pullback (IsTerminal.! ⊤-is-terminal) (IsTerminal.! ⊤-is-terminal)
      A × B = pullbacks (IsTerminal.! ⊤-is-terminal) (IsTerminal.! ⊤-is-terminal)

      cartesian = record
        { terminal = ⊤
        ; products = record
            { product = λ {A B} → record
                { A×B = P {A}{_}{B} (A × B)
                ; π₁ = p₁ (A × B)
                ; π₂ = p₂ (A × B)
                ; ⟨_,_⟩ =  λ _ _ → universal (A × B) (!-unique₂)
                ; project₁ = p₁∘universal≈h₁ (A × B)
                ; project₂ = p₂∘universal≈h₂ (A × B)
                ; unique = λ eq₁ eq₂ → Equiv.sym C (unique (A × B) eq₁ eq₂)
                }
            }
        }

-- extra properties of "up-to-iso"
module IsoPb {X Y Z} {f : X ⇒ Z} {g : Y ⇒ Z} (pull₀ pull₁ : Pullback f g) where
  open Pullback using (P; p₁; p₂; p₁∘universal≈h₁; p₂∘universal≈h₂; commute; universal)

  P₀≅P₁ : P pull₀ ≅ P pull₁
  P₀≅P₁ = up-to-iso pull₀ pull₁

  P₀⇒P₁ : P pull₀ ⇒ P pull₁
  P₀⇒P₁ = _≅_.from P₀≅P₁

  p₁-≈ : p₁ pull₁ ∘ P₀⇒P₁ ≈ p₁ pull₀
  p₁-≈ = p₁∘universal≈h₁ pull₁ {eq = commute pull₀}

  p₂-≈ : p₂ pull₁ ∘ P₀⇒P₁ ≈ p₂ pull₀
  p₂-≈ = p₂∘universal≈h₂ pull₁ {eq = commute pull₀}


-- Some tests for the Agda Abstract Machine.

open import Agda.Builtin.Nat
open import Agda.Builtin.Equality
open import Agda.Builtin.Sigma

_×_ : Set → Set → Set
A × B = Σ A λ _ → B

id : Nat → Nat
id x = x

-- Applying id should not break sharing
double : Nat → Nat
double n = id n + id n

pow : Nat → Nat
pow zero    = 1
pow (suc n) = double (pow n)

test-pow : pow 64 ≡ 18446744073709551616
test-pow = refl

-- Projections should not break sharing
addPair : Nat × Nat → Nat
addPair p = fst p + snd p

dup : Nat → Nat × Nat
dup x .fst = x
dup x .snd = x

smush : Nat × Nat → Nat × Nat
smush p = dup (addPair p)

iter : {A : Set} → (A → A) → Nat → A → A
iter f zero    x = x
iter f (suc n) x = f (iter f n x)

pow' : Nat → Nat
pow' n = addPair (iter smush n (0 , 1))

test-pow' : pow' 64 ≡ pow 64
test-pow' = refl

-- Should not be linear (not quadratic) for neutral n.
builtin : Nat → Nat → Nat
builtin k n = k + n - k

test-builtin : ∀ n → builtin 50000 n ≡ n
test-builtin n = refl


------------------------------------------------------------------------
-- Preimages
------------------------------------------------------------------------

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

-- Partly based on Voevodsky's work on so-called univalent
-- foundations.

open import Equality

module Preimage
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Bijection eq as Bijection hiding (id; _∘_)
open Derived-definitions-and-properties eq
open import H-level eq as H-level
open import Injection eq hiding (id; _∘_)
open import Logical-equivalence using (module _⇔_)
open import Prelude
open import Surjection eq hiding (id; _∘_)

-- The preimage of y under f is denoted by f ⁻¹ y.

infix 5 _⁻¹_

_⁻¹_ : ∀ {a b} {A : Type a} {B : Type b} → (A → B) → B → Type (a ⊔ b)
f ⁻¹ y = ∃ λ x → f x ≡ y

-- Preimages under the identity function are contractible. (Note that
-- Singleton x is equal to id ⁻¹ x.)

id⁻¹-contractible : ∀ {a} {A : Type a} (y : A) →
                    Contractible (id ⁻¹ y)
id⁻¹-contractible = singleton-contractible

-- _⁻¹_ respects extensional equality of functions.

respects-extensional-equality :
  ∀ {a b} {A : Type a} {B : Type b} {f g : A → B} {y} →
  (∀ x → f x ≡ g x) → (f ⁻¹ y) ↔ (g ⁻¹ y)
respects-extensional-equality {f = f} {g} {y} f≡g = record
  { surjection = record
    { logical-equivalence = record
      { to   = to′
      ; from = from′
      }
    ; right-inverse-of = right-inverse-of
    }
  ; left-inverse-of = left-inverse-of
  }
  where
  to′ : f ⁻¹ y → g ⁻¹ y
  to′ (x , fx≡y) = x , (
    g x  ≡⟨ sym $ f≡g x ⟩
    f x  ≡⟨ fx≡y ⟩∎
    y    ∎)

  from′ : g ⁻¹ y → f ⁻¹ y
  from′ (x , gx≡y) = x , (
    f x  ≡⟨ f≡g x ⟩
    g x  ≡⟨ gx≡y ⟩∎
    y    ∎)

  abstract
    right-inverse-of : ∀ p → to′ (from′ p) ≡ p
    right-inverse-of = λ g⁻¹y → cong (_,_ (proj₁ g⁻¹y)) (
      let p = f≡g (proj₁ g⁻¹y); q = proj₂ g⁻¹y in
      trans (sym p) (trans p q)  ≡⟨ sym $ trans-assoc _ _ _ ⟩
      trans (trans (sym p) p) q  ≡⟨ cong (λ p → trans p q) (trans-symˡ _) ⟩
      trans (refl _) q           ≡⟨ trans-reflˡ _ ⟩∎
      q                          ∎)

    left-inverse-of : ∀ p → from′ (to′ p) ≡ p
    left-inverse-of = λ f⁻¹y → cong (_,_ (proj₁ f⁻¹y))
      let p = f≡g (proj₁ f⁻¹y); q = proj₂ f⁻¹y in
      trans p (trans (sym p) q)  ≡⟨ sym $ trans-assoc _ _ _ ⟩
      trans (trans p (sym p)) q  ≡⟨ cong (λ p → trans p q) (trans-symʳ _) ⟩
      trans (refl _) q           ≡⟨ trans-reflˡ _ ⟩∎
      q                          ∎

-- Split surjections can be lifted to preimages.

lift-surjection :
  ∀ {a b} {A : Type a} {B : Type b} (A↠B : A ↠ B) → let open _↠_ A↠B in
  ∀ {y} → (from ∘ to ⁻¹ y) ↠ (from ⁻¹ y)
lift-surjection {A = A} {B} A↠B {y} = record
  { logical-equivalence = record
    { to   = drop-∘
    ; from = add-∘
    }
  ; right-inverse-of = right-inv
  }
  where
  open _↠_ A↠B

  -- Given a preimage under (f ∘ g) a preimage under f can be
  -- constructed.

  drop-∘ : (from ∘ to) ⁻¹ y → from ⁻¹ y
  drop-∘ = Σ-map to id

  -- If f is a left inverse of g then the other direction also
  -- holds.

  abstract
    add-∘-lemma : ∀ {x} → from x ≡ y → from (to (from x)) ≡ y
    add-∘-lemma {x} from-x≡y =
      from (to (from x))  ≡⟨ cong from (right-inverse-of x) ⟩
      from x              ≡⟨ from-x≡y ⟩∎
      y                   ∎

  add-∘ : from ⁻¹ y → (from ∘ to) ⁻¹ y
  add-∘ (x , from-x≡y) = (from x , add-∘-lemma from-x≡y)

  abstract

    -- add-∘ is a right inverse of drop-∘.

    right-inv : (from⁻¹y : from ⁻¹ y) → drop-∘ (add-∘ from⁻¹y) ≡ from⁻¹y
    right-inv (x , from-x≡y) =
        (to (from x) , trans (cong from (right-inverse-of x)) from-x≡y)  ≡⟨ sym $ lemma (right-inverse-of x) from-x≡y ⟩∎
        (x           , from-x≡y)                                         ∎
      where
      lemma : ∀ {x y z} {f : B → A}
              (y≡x : y ≡ x) (p : f x ≡ z) →
              _≡_ {A = f ⁻¹ z} (x , p) (y , trans (cong f y≡x) p)
      lemma {z = z} {f} = elim
        (λ {y x} y≡x → (p : f x ≡ z) →
           _≡_ {A = f ⁻¹ z} (x , p) (y , trans (cong f y≡x) p))
        (λ x p → cong (_,_ x) (
           p                          ≡⟨ sym $ trans-reflˡ _ ⟩
           trans (refl (f x)) p       ≡⟨ cong (λ q → trans q p) (sym (cong-refl f)) ⟩∎
           trans (cong f (refl x)) p  ∎))

-- A consequence of the lemmas above is that preimages under a
-- bijection are contractible.

bijection⁻¹-contractible :
  ∀ {a b} {A : Type a} {B : Type b} (A↔B : A ↔ B) → let open _↔_ A↔B in
  ∀ y → Contractible (to ⁻¹ y)
bijection⁻¹-contractible A↔B =
  H-level.respects-surjection surj 0 ∘ id⁻¹-contractible
  where
  open _↔_ (Bijection.inverse A↔B)

  surj : ∀ {y} → id ⁻¹ y ↠ from ⁻¹ y
  surj {y} =
    id ⁻¹ y         ↠⟨ _↔_.surjection $
                         respects-extensional-equality (sym ∘ left-inverse-of) ⟩
    from ∘ to ⁻¹ y  ↠⟨ lift-surjection surjection ⟩□
    from ⁻¹ y       □

abstract

  -- Preimages under an injection into a set are propositional.

  injection⁻¹-propositional :
    ∀ {a b} {A : Type a} {B : Type b} (A↣B : A ↣ B) →
    let open _↣_ A↣B in
    Is-set B →
    ∀ y → Is-proposition (to ⁻¹ y)
  injection⁻¹-propositional A↣B B-set y (x₁ , tox₁≡y) (x₂ , tox₂≡y) =
    Σ-≡,≡→≡ (injective (to x₁  ≡⟨ tox₁≡y ⟩
                        y      ≡⟨ sym tox₂≡y ⟩∎
                        to x₂  ∎))
            (subst (λ x → to x ≡ y)
                   (injective (trans tox₁≡y (sym tox₂≡y)))
                   tox₁≡y                                   ≡⟨ B-set _ _ ⟩∎
             tox₂≡y                                         ∎)
    where
    open _↣_ A↣B


record _×_ (A B : Set) : Set where
  no-eta-equality
  constructor _,_
  field
    fst : A
    snd : B

open _×_

swap : ∀ {A B} → A × B → B × A
swap (x , y) = y , x

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

-- This should fail since we don't have eta for _×_.
fails : ∀ {A B} (p : A × B) → swap p ≡ (snd p , fst p)
fails p = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Divisibility
------------------------------------------------------------------------

module Data.Nat.Divisibility where

open import Data.Nat as Nat
open import Data.Nat.DivMod
import Data.Nat.Properties as NatProp
open import Data.Fin as Fin using (Fin; zero; suc)
import Data.Fin.Properties as FP
open NatProp.SemiringSolver
open import Algebra
private
  module CS = CommutativeSemiring NatProp.commutativeSemiring
open import Data.Product
open import Relation.Nullary
open import Relation.Binary
import Relation.Binary.PartialOrderReasoning as PartialOrderReasoning
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; sym; cong; subst)
open import Function

-- m ∣ n is inhabited iff m divides n. Some sources, like Hardy and
-- Wright's "An Introduction to the Theory of Numbers", require m to
-- be non-zero. However, some things become a bit nicer if m is
-- allowed to be zero. For instance, _∣_ becomes a partial order, and
-- the gcd of 0 and 0 becomes defined.

infix 4 _∣_

data _∣_ : ℕ → ℕ → Set where
  divides : {m n : ℕ} (q : ℕ) (eq : n ≡ q * m) → m ∣ n

-- Extracts the quotient.

quotient : ∀ {m n} → m ∣ n → ℕ
quotient (divides q _) = q

-- If m divides n, and n is positive, then m ≤ n.

∣⇒≤ : ∀ {m n} → m ∣ suc n → m ≤ suc n
∣⇒≤         (divides zero    ())
∣⇒≤ {m} {n} (divides (suc q) eq) = begin
  m          ≤⟨ NatProp.m≤m+n m (q * m) ⟩
  suc q * m  ≡⟨ sym eq ⟩
  suc n      ∎
  where open ≤-Reasoning

-- _∣_ is a partial order.

poset : Poset _ _ _
poset = record
  { Carrier        = ℕ
  ; _≈_            = _≡_
  ; _≤_            = _∣_
  ; isPartialOrder = record
    { isPreorder = record
      { isEquivalence = PropEq.isEquivalence
      ; reflexive     = reflexive
      ; trans         = trans
      }
    ; antisym = antisym
    }
  }
  where
  module DTO = DecTotalOrder Nat.decTotalOrder
  open PropEq.≡-Reasoning

  reflexive : _≡_ ⇒ _∣_
  reflexive {n} refl = divides 1 (sym $ proj₁ CS.*-identity n)

  antisym : Antisymmetric _≡_ _∣_
  antisym (divides {n = zero} q₁ eq₁) (divides {n = n₂} q₂ eq₂) = begin
    n₂      ≡⟨ eq₂ ⟩
    q₂ * 0  ≡⟨ CS.*-comm q₂ 0 ⟩
    0       ∎
  antisym (divides {n = n₁} q₁ eq₁) (divides {n = zero} q₂ eq₂) = begin
    0       ≡⟨ CS.*-comm 0 q₁ ⟩
    q₁ * 0  ≡⟨ sym eq₁ ⟩
    n₁      ∎
  antisym (divides {n = suc n₁} q₁ eq₁) (divides {n = suc n₂} q₂ eq₂) =
    DTO.antisym (∣⇒≤ (divides q₁ eq₁)) (∣⇒≤ (divides q₂ eq₂))

  trans : Transitive _∣_
  trans (divides q₁ refl) (divides q₂ refl) =
    divides (q₂ * q₁) (sym (CS.*-assoc q₂ q₁ _))

module ∣-Reasoning = PartialOrderReasoning poset
  renaming (_≤⟨_⟩_ to _∣⟨_⟩_; _≈⟨_⟩_ to _≡⟨_⟩_)

private module P = Poset poset

-- 1 divides everything.

1∣_ : ∀ n → 1 ∣ n
1∣ n = divides n (sym $ proj₂ CS.*-identity n)

-- Everything divides 0.

_∣0 : ∀ n → n ∣ 0
n ∣0 = divides 0 refl

-- 0 only divides 0.

0∣⇒≡0 : ∀ {n} → 0 ∣ n → n ≡ 0
0∣⇒≡0 {n} 0∣n = P.antisym (n ∣0) 0∣n

-- Only 1 divides 1.

∣1⇒≡1 : ∀ {n} → n ∣ 1 → n ≡ 1
∣1⇒≡1 {n} n∣1 = P.antisym n∣1 (1∣ n)

-- If i divides m and n, then i divides their sum.

∣-+ : ∀ {i m n} → i ∣ m → i ∣ n → i ∣ m + n
∣-+ (divides {m = i} q refl) (divides q' refl) =
  divides (q + q') (sym $ proj₂ CS.distrib i q q')

-- If i divides m and n, then i divides their difference.

∣-∸ : ∀ {i m n} → i ∣ m + n → i ∣ m → i ∣ n
∣-∸ (divides {m = i} q' eq) (divides q refl) =
  divides (q' ∸ q)
          (sym $ NatProp.im≡jm+n⇒[i∸j]m≡n q' q i _ $ sym eq)

-- A simple lemma: n divides kn.

∣-* : ∀ k {n} → n ∣ k * n
∣-* k = divides k refl

-- If i divides j, then ki divides kj.

*-cong : ∀ {i j} k → i ∣ j → k * i ∣ k * j
*-cong {i} {j} k (divides q eq) = divides q lemma
  where
  open PropEq.≡-Reasoning
  lemma = begin
    k * j        ≡⟨ cong (_*_ k) eq ⟩
    k * (q * i)  ≡⟨ solve 3 (λ k q i → k :* (q :* i)
                                   :=  q :* (k :* i))
                            refl k q i ⟩
    q * (k * i)  ∎

-- If ki divides kj, and k is positive, then i divides j.

/-cong : ∀ {i j} k → suc k * i ∣ suc k * j → i ∣ j
/-cong {i} {j} k (divides q eq) = divides q lemma
  where
  open PropEq.≡-Reasoning
  k′    = suc k
  lemma = NatProp.cancel-*-right j (q * i) (begin
    j * k′        ≡⟨ CS.*-comm j k′ ⟩
    k′ * j        ≡⟨ eq ⟩
    q * (k′ * i)  ≡⟨ solve 3 (λ q k i → q :* (k :* i)
                                    :=  q :* i :* k)
                             refl q k′ i ⟩
    q * i * k′    ∎)

-- If the remainder after division is non-zero, then the divisor does
-- not divide the dividend.

nonZeroDivisor-lemma
  : ∀ m q (r : Fin (1 + m)) → Fin.toℕ r ≢ 0 →
    ¬ (1 + m) ∣ (Fin.toℕ r + q * (1 + m))
nonZeroDivisor-lemma m zero r r≢zero (divides zero eq) = r≢zero $ begin
  Fin.toℕ r
    ≡⟨ sym $ proj₁ CS.*-identity (Fin.toℕ r) ⟩
  1 * Fin.toℕ r
    ≡⟨ eq ⟩
  0
    ∎
  where open PropEq.≡-Reasoning
nonZeroDivisor-lemma m zero r r≢zero (divides (suc q) eq) =
  NatProp.¬i+1+j≤i m $ begin
    m + suc (q * suc m)
      ≡⟨ solve 2 (λ m q → m :+ (con 1 :+ q)  :=  con 1 :+ m :+ q)
                 refl m (q * suc m) ⟩
    suc (m + q * suc m)
      ≡⟨ sym eq ⟩
    1 * Fin.toℕ r
      ≡⟨ proj₁ CS.*-identity (Fin.toℕ r) ⟩
    Fin.toℕ r
      ≤⟨ ≤-pred $ FP.bounded r ⟩
    m
      ∎
  where open ≤-Reasoning
nonZeroDivisor-lemma m (suc q) r r≢zero d =
  nonZeroDivisor-lemma m q r r≢zero (∣-∸ d' P.refl)
  where
  lem = solve 3 (λ m r q → r :+ (m :+ q)  :=  m :+ (r :+ q))
                refl (suc m) (Fin.toℕ r) (q * suc m)
  d' = subst (λ x → (1 + m) ∣ x) lem d

-- Divisibility is decidable.

_∣?_ : Decidable _∣_
zero  ∣? zero                         = yes (0 ∣0)
zero  ∣? suc n                        = no ((λ ()) ∘′ 0∣⇒≡0)
suc m ∣? n                            with n divMod suc m
suc m ∣? .(q * suc m)                 | result q zero    refl =
  yes $ divides q refl
suc m ∣? .(1 + Fin.toℕ r + q * suc m) | result q (suc r) refl =
  no $ nonZeroDivisor-lemma m q (suc r) (λ())


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

open import HoTT
open import homotopy.JoinComm
open import homotopy.JoinAssocCubical

module homotopy.JoinSusp where

module _ {i} {A : Type i} where

  private

      module Into = PushoutRec {d = *-span (Lift {j = i} Bool) A}
        {D = Suspension A}
        (λ {(lift true) → north _;
            (lift false) → south _})
        (λ _ → south _)
        (λ {(lift true , a) → merid _ a;
            (lift false , a) → idp})

      into = Into.f

      module Out = SuspensionRec A {C = Lift {j = i} Bool * A}
        (left (lift true))
        (left (lift false))
        (λ a → glue (lift true , a) ∙ ! (glue (lift false , a)))

      out = Out.f

      into-out : ∀ σ → into (out σ) == σ
      into-out = Suspension-elim _
        idp
        idp
        (↓-∘=idf-from-square into out ∘ λ a → vert-degen-square $
           ap (ap into) (Out.glue-β a)
           ∙ ap-∙ into (glue (lift true , a)) (! (glue (lift false , a)))
           ∙ (Into.glue-β (lift true , a)
              ∙2 (ap-! into (glue (lift false , a))
                  ∙ ap ! (Into.glue-β (lift false , a))))
           ∙ ∙-unit-r _)

      out-into : ∀ j → out (into j) == j
      out-into = Pushout-elim
        (λ {(lift true) → idp;
            (lift false) → idp})
        (λ a → glue (lift false , a))
        (↓-∘=idf-from-square out into ∘
          λ {(lift true , a) →
                (ap (ap out) (Into.glue-β (lift true , a)) ∙ Out.glue-β a)
                ∙v⊡ (vid-square {p = glue (lift true , a)}
                      ⊡h rt-square (glue (lift false , a)))
                ⊡v∙ ∙-unit-r _;
             (lift false , a) →
               ap (ap out) (Into.glue-β (lift false , a)) ∙v⊡ connection})

  join-S⁰-equiv : Lift {j = i} Bool * A ≃ Suspension A
  join-S⁰-equiv = equiv into out into-out out-into

  join-S⁰-path = ua join-S⁰-equiv

module _ {i} (X : Ptd i) where

  join-S⁰-⊙path : ⊙Sphere {i} 0 ⊙* X == ⊙Susp X
  join-S⁰-⊙path = ⊙ua join-S⁰-equiv idp

module _ {i} {A B : Type i} where

  join-susp-shift : Suspension A * B == Suspension (A * B)
  join-susp-shift =
    ap (λ C → C * B) (! join-S⁰-path)
    ∙ join-rearrange-path
    ∙ ua swap-equiv
    ∙ join-S⁰-path
    ∙ ap Suspension (ua swap-equiv)

module _ {i} (X Y : Ptd i) where

  ⊙join-susp-shift : ⊙Susp X ⊙* Y == ⊙Susp (X ⊙* Y)
  ⊙join-susp-shift =
    ap (λ Z → Z ⊙* Y) (! (join-S⁰-⊙path X))
    ∙ join-rearrange-⊙path (⊙Sphere 0) X Y
    ∙ ⊙ua swap-equiv (! (glue _))
    ∙ join-S⁰-⊙path (Y ⊙* X)
    ∙ ap (λ A → (Suspension A , north _)) (ua swap-equiv)

module _ {i} (X : Ptd i) where

  ⊙join-sphere : (m : ℕ) → ⊙Sphere {i} m ⊙* X == ⊙Susp^ (S m) X
  ⊙join-sphere O = join-S⁰-⊙path X
  ⊙join-sphere (S m) = ⊙join-susp-shift (⊙Sphere m) X
                          ∙ ap ⊙Susp (⊙join-sphere m)


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

module Categories.Functor.Profunctor where

open import Level

open import Data.Product
open import Relation.Binary.Bundles
open import Categories.Category
open import Categories.Category.Instance.Setoids
open import Categories.Functor hiding (id)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Hom
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.Equivalence
open import Function.Equality using (Π; _⟨$⟩_; cong)

Profunctor : ∀ {o ℓ e} {o′ ℓ′ e′} → Category o ℓ e → Category o′ ℓ′ e′ → Set _
Profunctor {ℓ = ℓ} {e} {ℓ′ = ℓ′} {e′} C D = Bifunctor (Category.op D) C (Setoids (ℓ ⊔ ℓ′) (e ⊔ e′))

-- Calling the profunctor identity "id" is a bad idea
proid : ∀ {o ℓ e} → {C : Category o ℓ e} → Profunctor C C
proid {C = C} = Hom[ C ][-,-]

module Profunctor {o ℓ e} {o′} (C : Category o ℓ e) (D : Category o′ ℓ e) where
  module C = Category C
  open module D = Category D hiding (id)
  open D.HomReasoning
  open import Categories.Morphism.Reasoning D using (assoc²''; elimˡ; elimʳ)

  -- representable profunctors
  -- hom(f,1)
  repˡ : ∀ (F : Functor C D) → Profunctor D C
  repˡ F = record
    { F₀ = λ (c , d) → record
      { Carrier = D [ F₀ c , d ]
      ; _≈_ = D._≈_
      ; isEquivalence = D.equiv
      }
    ; F₁ = λ (f , g) → record
      { _⟨$⟩_ = λ x → g ∘ x ∘ F₁ f
      ; cong  = λ x → begin _ ≈⟨ refl⟩∘⟨ x ⟩∘⟨refl ⟩ _ ∎
      }
    ; identity = λ {x} {y} {y'} y≈y' → begin
        D.id ∘ y ∘ F₁ C.id ≈⟨ D.identityˡ ⟩
        y ∘ F₁ C.id        ≈⟨ elimʳ identity ⟩
        y                  ≈⟨ y≈y' ⟩
        y'                 ∎
    ; homomorphism = λ { {f = f0 , f1} {g = g0 , g1} {x} {y} x≈y → begin
        (g1 ∘ f1) ∘ x ∘ F₁ (f0 C.∘ g0)  ≈⟨ refl⟩∘⟨ x≈y ⟩∘⟨ F.homomorphism ⟩
        (g1 ∘ f1) ∘ y ∘ F₁ f0 ∘ F₁ g0   ≈⟨ refl⟩∘⟨ D.sym-assoc ⟩
        (g1 ∘ f1) ∘ (y ∘ F₁ f0) ∘ F₁ g0 ≈⟨ Equiv.sym assoc²'' ⟩
        g1 ∘ (f1 ∘ y ∘ F₁ f0) ∘ F₁ g0   ∎
      }
    ; F-resp-≈ = λ { {f = f0 , f1} {g = g0 , g1} (f0≈g0 , f1≈g1) {x} {y} x≈y → begin
        f1 ∘ x ∘ F₁ f0 ≈⟨ f1≈g1 ⟩∘⟨ x≈y ⟩∘⟨ F-resp-≈ f0≈g0 ⟩
        g1 ∘ y ∘ F₁ g0 ∎
      }
    }
    where
      open module F = Functor F

  -- hom(1,f)
  repʳ : (F : Functor C D) → Profunctor C D
  repʳ F = record
    { F₀ = λ (c , d) → record
      { Carrier = D [ c , F₀ d ]
      ; _≈_ = D._≈_
      ; isEquivalence = D.equiv
      }
    ; F₁ = λ (f , g) → record
      { _⟨$⟩_ = λ x → F₁ g ∘ x ∘ f
      ; cong  = λ x → begin _ ≈⟨ refl⟩∘⟨ x ⟩∘⟨refl ⟩ _ ∎
      }
    ; identity = λ {x} {y} {y'} y≈y' → begin
        F₁ C.id ∘ y ∘ D.id ≈⟨ elimˡ identity ⟩
        y ∘ D.id           ≈⟨ D.identityʳ ⟩
        y                  ≈⟨ y≈y' ⟩
        y'                 ∎
    ; homomorphism = λ { {f = f0 , f1} {g = g0 , g1} {x} {y} x≈y → begin
        F₁ (g1 C.∘ f1) ∘ x ∘ f0 ∘ g0    ≈⟨ F.homomorphism ⟩∘⟨ x≈y ⟩∘⟨refl ⟩
        (F₁ g1 ∘ F₁ f1) ∘ y ∘ f0 ∘ g0   ≈⟨ refl⟩∘⟨ D.sym-assoc ⟩
        (F₁ g1 ∘ F₁ f1) ∘ (y ∘ f0) ∘ g0 ≈⟨ Equiv.sym assoc²'' ⟩
        F₁ g1 ∘ (F₁ f1 ∘ y ∘ f0) ∘ g0   ∎
      }
    ; F-resp-≈ = λ { {f = f0 , f1} {g = g0 , g1} (f0≈g0 , f1≈g1) {x} {y} x≈y → begin
        F₁ f1 ∘ x ∘ f0 ≈⟨ F-resp-≈ f1≈g1 ⟩∘⟨ x≈y ⟩∘⟨ f0≈g0 ⟩
        F₁ g1 ∘ y ∘ g0 ∎
      }
    }
    where
      open module F = Functor F

-- each Prof(C,D) is a category
homProf : {o o′ ℓ e : Level} → (C : Category o ℓ e) → (D : Category o′ ℓ e) → Category _ _ _
homProf C D = record
  { Obj = Profunctor C D
  ; _⇒_ = NaturalTransformation
  ; _≈_ = _≃_
  ; id = id
  ; _∘_ = _∘ᵥ_
  ; assoc     = λ { {f = f} {g} {h} → assoc-lemma {f = f} {g} {h}}
  ; sym-assoc = λ { {f = f} {g} {h} → sym-assoc-lemma {f = f} {g} {h}}
  ; identityˡ = λ { {f = f} → id-lemmaˡ {f = f} }
  ; identityʳ = λ { {f = f} → id-lemmaʳ {f = f} }
  ; identity² = λ z → z
  ; equiv = ≃-isEquivalence
  ; ∘-resp-≈ = λ { {f = f} {h} {g} {i} eq eq' → ∘ᵥ-resp-≃ {f = f} {h} {g} {i} eq eq' }
  }
  where
    id-lemmaˡ : ∀ {o o′ ℓ ℓ′ e e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {P K : Functor C D}
            {f : NaturalTransformation P K} → id ∘ᵥ f ≃ f
    id-lemmaˡ {D = D} = Category.identityˡ D

    id-lemmaʳ : ∀ {o o′ ℓ ℓ′ e e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {P K : Functor C D}
            {f : NaturalTransformation P K} → f ∘ᵥ id ≃ f
    id-lemmaʳ {D = D} = Category.identityʳ D

    assoc-lemma : ∀ {o o′ ℓ ℓ′ e e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {E F G H : Functor C D}
              {f : NaturalTransformation E F}
              {g : NaturalTransformation F G}
              {h : NaturalTransformation G H}
               → (h ∘ᵥ g) ∘ᵥ f ≃ h ∘ᵥ g ∘ᵥ f
    assoc-lemma {D = D} = Category.assoc D

    sym-assoc-lemma : ∀ {o o′ ℓ ℓ′ e e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {E F G H : Functor C D}
              {f : NaturalTransformation E F}
              {g : NaturalTransformation F G}
              {h : NaturalTransformation G H}
               → h ∘ᵥ g ∘ᵥ f ≃ (h ∘ᵥ g) ∘ᵥ f
    sym-assoc-lemma {D = D} = Category.sym-assoc D

    ∘ᵥ-resp-≃ : ∀ {o o′ ℓ ℓ′ e e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {R P K : Functor C D}
        {f h : NaturalTransformation P K}
        {g i : NaturalTransformation R P} → f ≃ h → g ≃ i → f ∘ᵥ g ≃ h ∘ᵥ i
    ∘ᵥ-resp-≃ {D = D} fh gi = Category.∘-resp-≈ D fh gi


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

open import Agda.Primitive as Prim public
  using    (Level; _⊔_; Setω)
  renaming (lzero to zero; lsuc to suc)

open import Agda.Builtin.Sigma public
  renaming (fst to proj₁; snd to proj₂)
  hiding (module Σ)

infixr 2 _×_

variable
  a b c p q r : Level
  A B C : Set a

_×_ : ∀ (A : Set a) (B : Set b) → Set (a ⊔ b)
A × B = Σ A λ _ → B

<_,_> : ∀ {A : Set a} {B : A → Set b} {C : ∀ {x} → B x → Set c}
        (f : (x : A) → B x) → ((x : A) → C (f x)) →
        ((x : A) → Σ (B x) C)
< f , g > x = (f x , g x)

map : ∀ {P : A → Set p} {Q : B → Set q} →
      (f : A → B) → (∀ {x} → P x → Q (f x)) →
      Σ A P → Σ B Q
map f g (x , y) = (f x , g y)

zip : ∀ {P : A → Set p} {Q : B → Set q} {R : C → Set r} →
      (_∙_ : A → B → C) →
      (∀ {x y} → P x → Q y → R (x ∙ y)) →
      Σ A P → Σ B Q → Σ C R
zip _∙_ _∘_ (a , p) (b , q) = ((a ∙ b) , (p ∘ q))

curry′ : (A × B → C) → (A → B → C)
curry′ k a b = k (a , b)

swap : A × B → B × A
swap (x , y) = (y , x)

record Category (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  eta-equality
  infix  4 _≈_ _⇒_
  infixr 9 _∘_

  field
    Obj : Set o
    _⇒_ : Obj → Obj → Set ℓ
    _≈_ : ∀ {A B} → (A ⇒ B) → (A ⇒ B) → Set e

    _∘_ : ∀ {A B C} → (B ⇒ C) → (A ⇒ B) → (A ⇒ C)

  CommutativeSquare : ∀ {A B C D} → (f : A ⇒ B) (g : A ⇒ C) (h : B ⇒ D) (i : C ⇒ D) → Set _
  CommutativeSquare f g h i = h ∘ f ≈ i ∘ g

infix 10  _[_,_]

_[_,_] : ∀ {o ℓ e} → (C : Category o ℓ e) → (X : Category.Obj C) → (Y : Category.Obj C) → Set ℓ
_[_,_] = Category._⇒_

module Inner {x₁ x₂ x₃} (CC : Category x₁ x₂ x₃) where

  private
    variable
      o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ : Level

  zipWith : ∀ {a b c p q r s} {A : Set a} {B : Set b} {C : Set c} {P : A → Set p} {Q : B → Set q} {R : C → Set r} {S : (x : C) → R x → Set s} (_∙_ : A → B → C) → (_∘_ : ∀ {x y} → P x → Q y → R (x ∙ y)) → (_*_ : (x : C) → (y : R x) → S x y) → (x : Σ A P) → (y : Σ B Q) → S (proj₁ x ∙ proj₁ y) (proj₂ x ∘ proj₂ y)
  zipWith _∙_ _∘_ _*_ (a , p) (b , q) = (a ∙ b) * (p ∘ q)
  syntax zipWith f g h = f -< h >- g

  record Functor (C : Category o ℓ e) (D : Category o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    eta-equality
    private module C = Category C
    private module D = Category D

    field
      F₀ : C.Obj → D.Obj
      F₁ : ∀ {A B} (f : C [ A , B ]) → D [ F₀ A , F₀ B ]

  Product : (C : Category o ℓ e) (D : Category o′ ℓ′ e′) → Category (o ⊔ o′) (ℓ ⊔ ℓ′) (e ⊔ e′)
  Product C D = record
    { Obj       = C.Obj × D.Obj
    ; _⇒_       = C._⇒_ -< _×_ >- D._⇒_
    ; _≈_       = C._≈_ -< _×_ >- D._≈_
    ; _∘_       = zip C._∘_ D._∘_
    }
    where module C = Category C
          module D = Category D

  Bifunctor : Category o ℓ e → Category o′ ℓ′ e′ → Category o″ ℓ″ e″ → Set _
  Bifunctor C D E = Functor (Product C D) E

  private
    module CC = Category CC

  open CC

  infix 4 _≅_
  record _≅_ (A B : Obj) : Set (x₂) where
    field
      from : A ⇒ B
      to   : B ⇒ A

  private
    variable
      X Y Z W : Obj
      f g h : X ⇒ Y

  record Monoidal : Set (x₁ ⊔ x₂ ⊔ x₃) where
    infixr 10 _⊗₀_ _⊗₁_

    field
      ⊗  : Bifunctor CC CC CC

    module ⊗ = Functor ⊗

    open Functor ⊗

    _⊗₀_ : Obj → Obj → Obj
    _⊗₀_ = curry′ F₀

    -- this is also 'curry', but a very-dependent version
    _⊗₁_ : X ⇒ Y → Z ⇒ W → X ⊗₀ Z ⇒ Y ⊗₀ W
    f ⊗₁ g = F₁ (f , g)

    field
      associator : (X ⊗₀ Y) ⊗₀ Z ≅ X ⊗₀ (Y ⊗₀ Z)

    module associator {X} {Y} {Z} = _≅_ (associator {X} {Y} {Z})

    -- for exporting, it makes sense to use the above long names, but for
    -- internal consumption, the traditional (short!) categorical names are more
    -- convenient. However, they are not symmetric, even though the concepts are, so
    -- we'll use ⇒ and ⇐ arrows to indicate that
    private
      α⇒ = associator.from
      α⇐ = λ {X} {Y} {Z} → associator.to {X} {Y} {Z}

    field
      assoc-commute-from   : CommutativeSquare ((f ⊗₁ g) ⊗₁ h) α⇒ α⇒ (f ⊗₁ (g ⊗₁ h))
      assoc-commute-to     : CommutativeSquare (f ⊗₁ (g ⊗₁ h)) α⇐ α⇐ ((f ⊗₁ g) ⊗₁ h)


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

module Fragment.Equational.Structures where

import Fragment.Equational.Theory.Laws as L
open import Fragment.Equational.Theory
open import Fragment.Equational.Theory.Bundles
open import Fragment.Equational.Model

open import Fragment.Algebra.Algebra

open import Level using (Level)
open import Data.Fin using (Fin; #_; suc; zero)
open import Data.Vec using ([]; _∷_)
open import Data.Vec.Relation.Binary.Pointwise.Inductive using ([]; _∷_)
open import Relation.Binary using (Setoid; Rel)

open import Algebra.Core

private
  variable
    a ℓ : Level

module _ {A : Set a} {_≈_ : Rel A ℓ} where

  open import Algebra.Definitions _≈_
  open import Algebra.Structures _≈_

  module _ {_•_ : Op₂ A} where

    module _ (isMagma : IsMagma _•_) where

      open IsMagma isMagma

      magma→setoid : Setoid a ℓ
      magma→setoid = record { Carrier       = A
                            ; _≈_           = _≈_
                            ; isEquivalence = isEquivalence
                            }

      private

        magma→⟦⟧ : Interpretation Σ-magma magma→setoid
        magma→⟦⟧ MagmaOp.• (x ∷ y ∷ []) = _•_ x y

        magma→⟦⟧-cong : Congruent₂ _•_ → Congruence Σ-magma magma→setoid magma→⟦⟧
        magma→⟦⟧-cong c MagmaOp.• (x₁≈x₂ ∷ y₁≈y₂ ∷ []) = c x₁≈x₂ y₁≈y₂

      magma→isAlgebra : IsAlgebra Σ-magma magma→setoid
      magma→isAlgebra = record { ⟦_⟧     = magma→⟦⟧
                               ; ⟦⟧-cong = magma→⟦⟧-cong ∙-cong
                               }

      magma→algebra : Algebra Σ-magma
      magma→algebra = record { ∥_∥/≈           = magma→setoid
                             ; ∥_∥/≈-isAlgebra = magma→isAlgebra
                             }

      private

        magma→models : Models Θ-magma magma→algebra
        magma→models ()

        magma→isModel : IsModel Θ-magma magma→setoid
        magma→isModel = record { isAlgebra = magma→isAlgebra
                               ; models    = magma→models
                               }

      magma→model : Model Θ-magma
      magma→model = record { ∥_∥/≈   = magma→setoid
                           ; isModel = magma→isModel
                           }

    module _ (isSemigroup : IsSemigroup _•_) where

      private

        open IsSemigroup isSemigroup renaming (assoc to •-assoc)

        semigroup→models : Models Θ-semigroup (magma→algebra isMagma)
        semigroup→models assoc θ = •-assoc (θ (# 0)) (θ (# 1)) (θ (# 2))

        semigroup→isModel : IsModel Θ-semigroup (magma→setoid isMagma)
        semigroup→isModel = record { isAlgebra = magma→isAlgebra isMagma
                                   ; models    = semigroup→models
                                   }

      semigroup→model : Model Θ-semigroup
      semigroup→model = record { ∥_∥/≈   = magma→setoid isMagma
                               ; isModel = semigroup→isModel
                               }

    module _ (isCSemigroup : IsCommutativeSemigroup _•_) where

      private

        open IsCommutativeSemigroup isCSemigroup
          renaming (comm to •-comm; assoc to •-assoc)

        csemigroup→models : Models Θ-csemigroup (magma→algebra isMagma)
        csemigroup→models comm θ = •-comm (θ (# 0)) (θ (# 1))
        csemigroup→models assoc θ = •-assoc (θ (# 0)) (θ (# 1)) (θ (# 2))

        csemigroup→isModel : IsModel Θ-csemigroup (magma→setoid isMagma)
        csemigroup→isModel = record { isAlgebra = magma→isAlgebra isMagma
                                    ; models    = csemigroup→models
                                    }

      csemigroup→model : Model Θ-csemigroup
      csemigroup→model = record { ∥_∥/≈   = magma→setoid isMagma
                                ; isModel = csemigroup→isModel
                                }


module STLC where

open import Data.Nat
open import Data.Empty
open import Relation.Binary.PropositionalEquality

-- infix  4 _⊢_
-- infix  4 _∋_∶_
-- infixl 5 _,_

infixr 7 _⟶_

infix  5 ƛ_
infixl 7 _∙_
-- infix  9 `_
infixl 10 _∶_

-- infix  5 μ_
-- infix  8 `suc_
-- infix  9 S_
-- infix  9 #_

data Type : Set where
  _⟶_ : Type → Type → Type
  ⊤    : Type

data Context : Set
data Term : Set

infix 4 _∋_∶_
data _∋_∶_ : Context → Term → Type → Set

infixl 10 _,_∶_
data Context where
  ∅   : Context
  _,_∶_ : Context → Term → Type → Context

data Term where
  ‵_ : ∀ {Γ x A} → Γ ∋ x ∶ A → Term

  ƛ_ : Term → Term

  _∙_ : Term → Term → Term

  _∶_ : Term → Type → Term

  tt : Term

data _∋_∶_ where
  Z : ∀ {Γ x A}
      ---------
    → Γ , x ∶ A ∋ x ∶ A

  S_ : ∀ {Γ x A y B}
    → Γ ∋ x ∶ A
      ---------
    → Γ , y ∶ B ∋ x ∶ A

-- lookup : Context → ℕ → Type
-- lookup (Γ , A) zero     =  A
-- lookup (Γ , _) (suc n)  =  lookup Γ n
-- lookup ∅       _        =  ⊥-elim impossible
--   where postulate impossible : ⊥

-- count : ∀ {Γ} → (n : ℕ) → Γ ∋ lookup Γ n
-- count {Γ , _} zero     =  Z
-- count {Γ , _} (suc n)  =  S (count n)
-- count {∅}     _        =  ⊥-elim impossible
--   where postulate impossible : ⊥

-- -- #_ : ∀ {Γ} → (n : ℕ) → Γ ⊢ lookup Γ n
-- -- # n  =  ` count n

-- a = {!   !}

infix 4 _⊢_⇐_
infix 4 _⊢_⇒_

data _⊢_⇐_ : Context → Term → Type → Set
data _⊢_⇒_ : Context → Term → Type → Set

variable
  Γ : Context
  x e f : Term
  A B : Type

data _⊢_⇒_ where

  Var :
      Γ ∋ x ∶ A
    ----------------------------
    → Γ ⊢ x ⇒ A

  Anno :
      Γ ⊢ e ⇐ A
    ----------------------------
    → Γ ⊢ (e ∶ A) ⇒ A

  ⟶E :
      Γ ⊢ f ⇒ (A ⟶ B)
    → Γ ⊢ e ⇐ A
    ----------------------------
    → Γ ⊢ f ∙ e ⇒ B

data _⊢_⇐_ where

  Sub :
      Γ ∋ e ∶ A
    → A ≡ B
    ----------------------------
    → Γ ⊢ e ⇐ B

  ⊤I : ∀ {Γ}
    ----------------------------
    → Γ ⊢ tt ⇐ ⊤

  ⟶I :
      (Γ , x ∶ A) ⊢ e ⇐ B
    ----------------------------
    → Γ ⊢ ƛ e ⇐ A ⟶ B

4-4-Synth : ∅ , x ∶ A ⊢ x ⇒ A
4-4-Synth = Var Z

4-4-Check : ∅ , x ∶ A ⊢ x ⇐ A
4-4-Check = Sub Z refl

4-4-Sym→Elim : ∅ , f ∶ (A ⟶ B) , x ∶ A ⊢ (f ∙ x) ⇒ B
4-4-Sym→Elim = ⟶E (Var (S Z)) (Sub Z refl)


{-# OPTIONS --sized-types --without-K #-}
module DepM where

open import Level using (Level)
open import Data.Product
open import Data.Nat
open import Data.Fin
open import Data.Unit
open import Data.Empty
open import Data.Vec hiding (_∈_; [_])
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Sum
open import Size

Fam : Set → Set₁
Fam I = I → Set

Fam₂ : {I : Set} → (I → Set) → Set₁
Fam₂ {I} J = (i : I) → J i → Set

-- | Morphisms between families
MorFam : {I : Set} (P₁ P₂ : Fam I) → Set
MorFam {I} P₁ P₂ = (x : I) → P₁ x → P₂ x

_⇒_ = MorFam

compMorFam : {I : Set} {P₁ P₂ P₃ : Fam I} →
             MorFam P₁ P₂ → MorFam P₂ P₃ → MorFam P₁ P₃
compMorFam f₁ f₂ a = f₂ a ∘ f₁ a

_⊚_ = compMorFam

-- | Reindexing of families
_* : {I J : Set} → (I → J) → Fam J → Fam I
(u *) P = P ∘ u

-- | Reindexing on morphisms of families
_*₁ : {I J : Set} → (u : I → J) →
      {P₁ P₂ : Fam J} → (P₁ ⇒ P₂) → (u *) P₁ ⇒ (u *) P₂
(u *₁) f i = f (u i)

-- | This notation for Π-types is more useful for our purposes here.
Π : (A : Set) (P : Fam A) → Set
Π A P = (x : A) → P x

-- | Fully general Σ-type, which we need to interpret the interpretation
-- of families of containers as functors for inductive types.
data Σ' {A B : Set} (f : A → B) (P : Fam A) : B → Set where
  ins : (a : A) → P a → Σ' f P (f a)

p₁' : {A B : Set} {u : A → B} {P : Fam A} {b : B} →
      Σ' u P b → A
p₁' (ins a _) = a

p₂' : {A B : Set} {u : A → B} {P : Fam A} {b : B} →
      (x : Σ' u P b) → P (p₁' x)
p₂' (ins _ x) = x

p₌' : {A B : Set} {u : A → B} {P : Fam A} {b : B} →
      (x : Σ' u P b) → u (p₁' x) ≡ b
p₌' (ins _ _) = refl

ins' : {A B : Set} {u : A → B} {P : Fam A} →
       (a : A) → (b : B) → u a ≡ b → P a → Σ' u P b
ins' a ._ refl x = ins a x

Σ'-eq : {A B : Set} {f : A → B} {P : Fam A} →
        (a a' : A) (x : P a) (x' : P a')
        (a≡a' : a ≡ a') (x≡x' : subst P a≡a' x ≡ x') →
        subst (Σ' f P) (cong f a≡a') (ins a x) ≡ ins a' x'
Σ'-eq a .a x .x refl refl = refl

Σ-eq : {a b : Level} {A : Set a} {B : A → Set b} →
       (a a' : A) (x : B a) (x' : B a')
       (a≡a' : a ≡ a') (x≡x' : subst B a≡a' x ≡ x') →
       (a , x) ≡ (a' , x')
Σ-eq a .a x .x refl refl = refl

×-eq : {ℓ : Level} {A : Set ℓ} {B : Set ℓ} →
       (a a' : A) (b b' : B) →
       a ≡ a' → b ≡ b' → (a , b) ≡ (a' , b')
×-eq a .a b .b refl refl = refl

×-eqˡ : {A B : Set} {a a' : A} {b b' : B} → (a , b) ≡ (a' , b') → a ≡ a'
×-eqˡ refl = refl

×-eqʳ : {A B : Set} {a a' : A} {b b' : B} → (a , b) ≡ (a' , b') → b ≡ b'
×-eqʳ refl = refl

-- | Comprehension
⟪_⟫ : {I : Set} → Fam I → Set
⟪_⟫ {I} B = Σ I B

⟪_⟫² : {I J : Set} → (J → Fam I) → Fam J
⟪_⟫² {I} B j = Σ I (B j)

π : {I : Set} → (B : Fam I) → ⟪ B ⟫ → I
π B = proj₁

_⊢₁_ : {I : Set} {A : Fam I} → (i : I) → A i → ⟪ A ⟫
i ⊢₁ a = (i , a)

_,_⊢₂_ : {I : Set} {A : Fam I} {B : Fam ⟪ A ⟫} →
         (i : I) → (a : A i) → B (i , a) → ⟪ B ⟫
i , a ⊢₂ b = ((i , a) , b)

-- Not directly definable...
-- record Π' {A B : Set} (u : A → B) (P : A → Set) : B → Set where
--  field
--    app : (a : A) → Π' u P (u a) → P a

-- | ... but this does the job.
Π' : {I J : Set} (u : I → J) (P : Fam I) → Fam J
Π' {I} u P j = Π (∃ λ i → u i ≡ j) (λ { (i , _) → P i})

Π'' : {I J : Set} (u : I → J) (j : J) (P : Fam (∃ λ i → u i ≡ j)) → Set
Π'' {I} u j P = Π (∃ λ i → u i ≡ j) P

-- | Application for fully general Π-types.
app : {I J : Set} {u : I → J} {P : Fam I} →
      (u *) (Π' u P) ⇒ P
app i f = f (i , refl)

-- | Abstraction for fully general Π-types.
abs : {I J : Set} {u : I → J} {P : Fam I} →
      ((i : I) → P i) → ((j : J) → Π' u P j)
abs {u = u} f .(u i) (i , refl) = f i

-- | Abstraction for fully general Π-types.
abs' : {I J : Set} {u : I → J} {P : Fam I} {X : Fam J} →
      ((u *) X ⇒ P) → (X ⇒ Π' u P)
abs' {u = u} f .(u i) x (i , refl) = f i x

-- | Abstraction for fully general Π-types.
abs'' : {I J : Set} {u : I → J} {P : Fam I} →
        (j : J) → ((i : I) → u i ≡ j → P i) → Π' u P j
abs'' j f (i , p) = f i p

abs₃ : {I J : Set} {u : I → J} (j : J) {P : Fam (Σ I (λ i → u i ≡ j))} →
       ((i : I) → (p : u i ≡ j) → P (i , p)) → Π'' u j P
abs₃ j f (i , p) = f i p

-- | Functorial action of Π'
Π'₁ : {I J : Set} {u : I → J} {P Q : Fam I} →
        (f : P ⇒ Q) → (Π' u P ⇒ Π' u Q)
Π'₁ {u = u} f .(u i) g (i , refl) = f i (app i g)

-- | Dependent polynomials
record DPoly
  {I : Set} -- ^ Outer index
  {J : Set} -- ^ Inner index
  : Set₁ where
  constructor dpoly
  field
    -- J ←t- E -p→ A -s→ I
    A : Set  -- ^ Labels
    s : A → I
    E : Set
    p : E → A
    t : E → J

-- | Interpretation of polynomial as functor
⟦_⟧ : {I : Set} {J : Set} →
    DPoly {I} {J} →
    (X : Fam J) →  -- ^ Parameter
    (Fam I)
⟦_⟧ {I} {N} (dpoly A s E p t) X =
  Σ' s (λ a →
  Π' p (λ e →
    X (t e)
  ) a )

-- | Functorial action of T
⟦_⟧₁ : {I : Set} {J : Set} →
     (P : DPoly {I} {J}) →
     {X Y : J → Set} →
     (f : (j : J) → X j → Y j)
     (i : I) → ⟦ P ⟧ X i → ⟦ P ⟧ Y i
⟦_⟧₁ {I} {J} (dpoly A s E p t) {X} {Y} f .(s a) (ins a v) =
  ins a (Π'₁ ((t *₁) f) a v)

-- | Final coalgebras for dependent polynomials
record M {a : Size} {I} (P : DPoly {I} {I}) (i : I) : Set where
  coinductive
  field
    ξ : ∀ {b : Size< a} → ⟦ P ⟧ (M {b} P) i
open M

ξ'  : ∀ {I P} → {i : I} → M P i → ⟦ P ⟧ (M P) i
ξ' x = ξ x

Rel₂ : {I : Set} → (X Y : I → Set) → Set₁
Rel₂ {I} X Y = (i : I) → X i → Y i → Set

-- | Lifting to relations
⟦_⟧'' : ∀ {I} (P : DPoly {I} {I}) {X Y} → Rel₂ X Y → Rel₂ (⟦ P ⟧ X) (⟦ P ⟧ Y)
⟦ dpoly A s E p t ⟧'' {X} {Y} R i x y =
  ∃ λ a → ∃ λ α → ∃ λ β → Σ[ q ∈ (i ≡ s a) ]
    (subst (⟦ dpoly A s E p t ⟧ X) q x ≡ ins a α
    × (subst (⟦ dpoly A s E p t ⟧ Y) q y) ≡ ins a β
    × ∀ u → R (t (proj₁ u)) (α u) (β u))

[_]_≡₂_ : ∀{I} {X : I → Set} → Rel₂ X X
[ i ] x ≡₂ y = x ≡ y

eq-preserving : ∀ {I P X} (i : I) (x y : ⟦ P ⟧ X i) →
                x ≡ y → ⟦ P ⟧'' (λ i → _≡_) i x y
eq-preserving i x y x≡y = {!!}

mutual
  -- | Equality for M types is given by bisimilarity
  record Bisim {I} {P : DPoly {I} {I}} (i : I) (x y : M P i) : Set where
    coinductive
    field
      ~pr : ⟦ P ⟧'' Bisim i (ξ' x) (ξ' y)
open Bisim public


{-

Basic properties about Σ-types

- Characterization of equality in Σ-types using transport ([pathSigma≡sigmaPath])

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Sigma.Properties where

open import Cubical.Data.Sigma.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.CartesianKanOps
open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidableEq

open import Cubical.Data.Nat.Base

private
  variable
    ℓ : Level
    A : Type ℓ
    B : (a : A) → Type ℓ

ΣPathP : ∀ {x y}
  → Σ (fst x ≡ fst y) (λ a≡ → PathP (λ i → B (a≡ i)) (snd x) (snd y))
  → x ≡ y
ΣPathP eq = λ i → (fst eq i) , (snd eq i)

Σ≡ : {x y : Σ A B}  →
     Σ (fst x ≡ fst y) (λ a≡ → PathP (λ i → B (a≡ i)) (snd x) (snd y)) ≃
     (x ≡ y)
Σ≡ {A = A} {B = B} {x} {y} = isoToEquiv (iso intro elim intro-elim elim-intro)
  where
    intro = ΣPathP

    elim : x ≡ y → Σ (fst x ≡ fst y) (λ a≡ → PathP (λ i → B (a≡ i)) (snd x) (snd y ))
    elim eq = (λ i → fst (eq i)) , λ i → snd (eq i)

    intro-elim : ∀ eq → intro (elim eq) ≡ eq
    intro-elim eq = refl

    elim-intro : ∀ eq → elim (intro eq) ≡ eq
    elim-intro eq = refl

-- Alternative version for path in Σ-types, as in the HoTT book

sigmaPathTransport : (a b : Σ A B) → Type _
sigmaPathTransport {B = B} a b =
  Σ (fst a ≡ fst b) (λ p → transport (λ i → B (p i)) (snd a) ≡ snd b)

_Σ≡T_ : (a b : Σ A B) → Type _
a Σ≡T b = sigmaPathTransport a b

-- now we prove that the alternative path space a Σ≡ b is equal to the usual path space a ≡ b

-- forward direction

private
  pathSigma-π1 : {a b : Σ A B} → a ≡ b → fst a ≡ fst b
  pathSigma-π1 p i = fst (p i)

  filler-π2 : {a b : Σ A B} → (p : a ≡ b) → I → (i : I) → B (fst (p i))
  filler-π2 {B = B} {a = a} p i =
    fill (λ i → B (fst (p i)))
         (λ t → λ { (i = i0) → coe0→i (λ j → B (fst (p j))) t (snd a)
                  ; (i = i1) → snd (p t) })
         (inS (snd a))

  pathSigma-π2 : {a b : Σ A B} → (p : a ≡ b) →
    subst B (pathSigma-π1 p) (snd a) ≡ snd b
  pathSigma-π2 p i = filler-π2 p i i1

pathSigma→sigmaPath : (a b : Σ A B) → a ≡ b → a Σ≡T b
pathSigma→sigmaPath _ _ p = (pathSigma-π1 p , pathSigma-π2 p)

-- backward direction

private
  filler-comp : (a b : Σ A B) → a Σ≡T b → I → I → Σ A B
  filler-comp {B = B} a b (p , q) i =
    hfill (λ t → λ { (i = i0) → a
                   ; (i = i1) → (p i1 , q t) })
          (inS (p i , coe0→i (λ j → B (p j)) i (snd a)))

sigmaPath→pathSigma : (a b : Σ A B) → a Σ≡T b → (a ≡ b)
sigmaPath→pathSigma a b x i = filler-comp a b x i i1

-- first homotopy

private
  homotopy-π1 : (a b : Σ A B) →
    ∀ (x : a Σ≡T b) → pathSigma-π1 (sigmaPath→pathSigma a b x) ≡ fst x
  homotopy-π1 a b x i j = fst (filler-comp a b x j (~ i))

  homotopy-π2 : (a b : Σ A B) → (p : a Σ≡T b) → (i : I) →
             (transport (λ j → B (fst (filler-comp a b p j i))) (snd a) ≡ snd b)
  homotopy-π2 {B = B} a b p i j =
    comp (λ t → B (fst (filler-comp a b p t (i ∨ j))))
         (λ t → λ { (j = i0) → coe0→i (λ t → B (fst (filler-comp a b p t i)))
                                      t (snd a)
                  ; (j = i1) → snd (sigmaPath→pathSigma a b p t)
                  ; (i = i0) → snd (filler-comp a b p t j)
                  ; (i = i1) → filler-π2 (sigmaPath→pathSigma a b p) j t })
         (snd a)

pathSigma→sigmaPath→pathSigma : {a b : Σ A B} →
  ∀ (x : a Σ≡T b) → pathSigma→sigmaPath _ _ (sigmaPath→pathSigma a b x) ≡ x
pathSigma→sigmaPath→pathSigma {a = a} p i =
  (homotopy-π1 a _ p i , homotopy-π2 a _ p (~ i))

-- second homotopy

sigmaPath→pathSigma→sigmaPath : {a b : Σ A B} →
  ∀ (x : a ≡ b) → sigmaPath→pathSigma a b (pathSigma→sigmaPath _ _ x) ≡ x
sigmaPath→pathSigma→sigmaPath {B = B} {a = a} {b = b} p i j =
  hcomp (λ t → λ { (i = i1) → (fst (p j) , filler-π2 p t j)
                 ; (i = i0) → filler-comp a b (pathSigma→sigmaPath _ _ p) j t
                 ; (j = i0) → (fst a , snd a)
                 ; (j = i1) → (fst b , filler-π2 p t i1) })
        (fst (p j) , coe0→i (λ k → B (fst (p k))) j (snd a))

pathSigma≡sigmaPath : (a b : Σ A B) → (a ≡ b) ≡ (a Σ≡T b)
pathSigma≡sigmaPath a b =
  isoToPath (iso (pathSigma→sigmaPath a b)
                 (sigmaPath→pathSigma a b)
                 (pathSigma→sigmaPath→pathSigma {a = a})
                 sigmaPath→pathSigma→sigmaPath)

discreteΣ : Discrete A → ((a : A) → Discrete (B a)) → Discrete (Σ A B)
discreteΣ {B = B} Adis Bdis (a0 , b0) (a1 , b1) = discreteΣ' (Adis a0 a1)
  where
    discreteΣ' : Dec (a0 ≡ a1) → Dec ((a0 , b0) ≡ (a1 , b1))
    discreteΣ' (yes p) = J (λ a1 p → ∀ b1 → Dec ((a0 , b0) ≡ (a1 , b1))) (discreteΣ'') p b1
      where
        discreteΣ'' : (b1 : B a0) → Dec ((a0 , b0) ≡ (a0 , b1))
        discreteΣ'' b1 with Bdis a0 b0 b1
        ... | (yes q) = yes (transport (ua Σ≡) (refl , q))
        ... | (no ¬q) = no (λ r → ¬q (subst (λ X → PathP (λ i → B (X i)) b0 b1) (Discrete→isSet Adis a0 a0 (cong fst r) refl) (cong snd r)))
    discreteΣ' (no ¬p) = no (λ r → ¬p (cong fst r))


-- Andreas, 2016-09-28, Level meta below neutral level
-- Agda previously simplified X <= a to X = a.
-- This loses the solution X = lzero.

-- {-# OPTIONS -v tc.constr.add:40 #-}

open import Common.Level

module _ (a : Level) where

module WorksWithSwappedDeclarations where

  mutual
    X : Level
    X = _

    data E : Set₁ where
      c : Set X → E  -- constraint lsuc X <= 1 solves X = lzero

    data D : Set (lsuc a) where
      c : Set X → D  -- fine since lzero <= a

module WorksWithGivenSolution where

  mutual
    X : Level
    X = lzero

    data D : Set (lsuc a) where
      c : Set X → D

    data E : Set₁ where
      c : Set X → E

module Test where

  mutual
    X : Level
    X = _

    data D : Set (lsuc a) where
      c : Set X → D  -- solved X (prematurely) since X <= a implies X = a ?? (Wrong!)

    data E : Set₁ where
      c : Set X → E  -- constraint X <= 0 became contradictory constraint a <= 0

-- ERROR WAS:
-- The type of the constructor does not fit in the sort of the
-- datatype, since Set (lsuc a) is not less or equal than Set₁
-- when checking the constructor c in the declaration of E

-- should succeed


module STLC.Properties.Determinism where

open import STLC.Term
open import STLC.Term.Reduction

open import Data.Nat using (ℕ; _+_)

open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using (contradiction)

open import Data.Product using (Σ; _,_; ∃; Σ-syntax; ∃-syntax)

open import Relation.Binary.PropositionalEquality as Eq
  using (refl; _≡_; cong₂)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)

infix 4 _¬—→

_¬—→ : ∀ { n : ℕ } -> Term n -> Set
t₁ ¬—→ = ¬ (∃[ t₂ ] (t₁ —→ t₂))

¬—→-value : ∀ { n : ℕ } { t : Term n }
  -> Value t
  -- --------
  -> t ¬—→
¬—→-value {_} {ƛ _} v = λ ()

—→-¬value : ∀ { n : ℕ } { t₁ t₂ : Term n }
  -> t₁ —→ t₂
  -- ---------
  -> ¬ Value t₁
—→-¬value { _ } { _ } { t₂ } s v = ¬—→-value v (t₂ , s)

determinism : ∀ { n : ℕ } { t₁ t₂ t₃ : Term n }
  -> t₁ —→ t₂
  -> t₁ —→ t₃
  -- --------
  -> t₂ ≡ t₃

determinism (β-·₁ s₁) (β-·₁ s₂) = cong₂ (_·_) (determinism s₁ s₂) refl
determinism (β-·₂ _ s₁) (β-·₂ _ s₂) =  cong₂ (_·_) refl (determinism s₁ s₂)
determinism (β-ƛ _) (β-ƛ _) = refl
determinism (β-·₁ s) (β-·₂ v _) = contradiction v (—→-¬value s)
determinism (β-·₂ v _) (β-·₁ s) = contradiction v (—→-¬value s)
determinism (β-·₂ _ s) (β-ƛ v) = contradiction v (—→-¬value s)
determinism (β-ƛ v) (β-·₂ _ s) = contradiction v (—→-¬value s)


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

open import HoTT
open import homotopy.JoinComm
open import homotopy.JoinAssocCubical

module homotopy.JoinSusp where

module _ {i} (A : Type i) where

  private

      module Into = JoinRec {A = Bool} {B = A}
        {C = Susp A}
        (Bool-rec north south)
        (λ _ → south)
        (λ {true a → merid a;
            false a → idp})

      into = Into.f

      module Out = SuspRec {C = Bool * A}
        (left true)
        (left false)
        (λ a → jglue true a ∙ ! (jglue false a))

      out = Out.f

      into-out : ∀ σ → into (out σ) == σ
      into-out = Susp-elim
        idp
        idp
        (λ a → ↓-∘=idf-from-square into out $ vert-degen-square $
           ap (ap into) (Out.merid-β a)
           ∙ ap-∙ into (jglue true a) (! (jglue false a))
           ∙ (Into.glue-β true a
              ∙2 (ap-! into (jglue false a)
                  ∙ ap ! (Into.glue-β false a)))
           ∙ ∙-unit-r _)

      out-into : ∀ j → out (into j) == j
      out-into = Join-elim
        (Bool-elim idp idp)
        (λ a → jglue false a)
        (λ{true a → ↓-∘=idf-from-square out into $
              (ap (ap out) (Into.glue-β true a) ∙ Out.merid-β a)
              ∙v⊡ (vid-square {p = jglue true a}
                    ⊡h rt-square (jglue false a))
              ⊡v∙ ∙-unit-r _;
           false a → ↓-∘=idf-from-square out into $
             ap (ap out) (Into.glue-β false a) ∙v⊡ connection})

  *-Bool-l : Bool * A ≃ Susp A
  *-Bool-l = equiv into out into-out out-into

module _ {i} (X : Ptd i) where

  ⊙*-Bool-l : ⊙Bool ⊙* X ⊙≃ ⊙Susp X
  ⊙*-Bool-l = ≃-to-⊙≃ (*-Bool-l (de⊙ X)) idp

module _ {i j} (A : Type i) (B : Type j) where

  *-Susp-l : Susp A * B ≃ Susp (A * B)
  *-Susp-l = *-Bool-l (A * B) ∘e *-assoc Bool A B ∘e *-emap (*-Bool-l A) (ide B) ⁻¹

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  ⊙*-Susp-l : ⊙Susp X ⊙* Y ⊙≃ ⊙Susp (X ⊙* Y)
  ⊙*-Susp-l = ≃-to-⊙≃ (*-Susp-l (de⊙ X) (de⊙ Y)) idp

module _ {i} where

  ⊙*-Sphere-l : (m : ℕ) (X : Ptd i) → ⊙Sphere m ⊙* X ⊙≃ ⊙Susp^ (S m) X
  ⊙*-Sphere-l O X = ⊙*-Bool-l X
  ⊙*-Sphere-l (S m) X = ⊙Susp-emap (⊙*-Sphere-l m X) ⊙∘e ⊙*-Susp-l (⊙Sphere m) X


-- Andreas, 2016-02-21 issue 1862 reported by nad
-- {-# OPTIONS -v tc.decl:10 -v tc.def.where:10 -v tc.meta:10 -v tc.size.solve:100 #-}

open import Common.Size

data Nat (i : Size) : Set where
  zero : Nat i
  suc  : (j : Size< i) (n : Nat j) → Nat i

id : ∀ i → Nat i → Nat i
id _ zero      = zero
id _ (suc j n) = s
  where
    mutual
      s = suc _ r  -- should not be instantiated to ∞x
      r = id _ n


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

open import Cubical.ZCohomology.Base
open import Cubical.HITs.Sn
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Data.NatMinusTwo.Base
open import Cubical.Data.Empty
open import Cubical.Data.Sigma
open import Cubical.Data.Prod.Base
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation
open import Cubical.HITs.Nullification
open import Cubical.Data.Int
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation

open import Cubical.HITs.Pushout
open import Cubical.Data.Sum.Base
open import Cubical.Data.HomotopyGroup
open import Cubical.Data.Bool
private
  variable
    ℓ ℓ' : Level
    A : Type ℓ
    B : Type ℓ'

{- Equivalence between cohomology of A and reduced cohomology of (A + 1) -}
coHomRed+1Equiv : (n : ℕ) →
                 (A : Set ℓ) →
                 (coHom n A) ≡ (coHomRed n ((A ⊎ Unit , inr (tt))))
coHomRed+1Equiv zero A i = ∥ helpLemma {C = (Int , pos 0)} i ∥₀
  module coHomRed+1 where
  helpLemma : {C : Pointed ℓ} → ( (A → (typ C)) ≡  ((((A ⊎ Unit) , inr (tt)) →* C)))
  helpLemma {C = C} = isoToPath (iso map1
                                     map2
                                     (λ b → linvPf b)
                                     (λ _  → refl))
    where
    map1 : (A → typ C) → ((((A ⊎ Unit) , inr (tt)) →* C))
    map1 f = map1' , refl module helpmap where
      map1' : A ⊎ Unit → fst C
      map1' (inl x) = f x
      map1' (inr x) = pt C

    map2 : ((((A ⊎ Unit) , inr (tt)) →* C)) → (A → typ C)
    map2 (g , pf) x = g (inl x)

    linvPf : (b :((((A ⊎ Unit) , inr (tt)) →* C))) →  map1 (map2 b) ≡ b
    linvPf (f , snd) i = (λ x → helper x i)  , λ j → snd ((~ i) ∨ j)
      where
      helper : (x : A ⊎ Unit) → ((helpmap.map1') (map2 (f , snd)) x) ≡ f x
      helper (inl x) = refl
      helper (inr tt) = sym snd

coHomRed+1Equiv (suc n) A i = ∥ coHomRed+1.helpLemma A i {C = ((coHomK (suc n)) , ∣ north ∣)} i ∥₀


{-

Product of structures S and T: X ↦ S X × T X

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Product where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path
open import Cubical.Foundations.SIP
open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ₁ ℓ₁' ℓ₂ ℓ₂' : Level

ProductStructure : (S₁ : Type ℓ → Type ℓ₁) (S₂ : Type ℓ → Type ℓ₂)
               → Type ℓ → Type (ℓ-max ℓ₁ ℓ₂)
ProductStructure S₁ S₂ X = S₁ X × S₂ X

ProductEquivStr : {S₁ : Type ℓ → Type ℓ₁} (ι₁ : StrEquiv S₁ ℓ₁')
           {S₂ : Type ℓ → Type ℓ₂} (ι₂ : StrEquiv S₂ ℓ₂')
         → StrEquiv (ProductStructure S₁ S₂) (ℓ-max ℓ₁' ℓ₂')
ProductEquivStr ι₁ ι₂ (X , s₁ , s₂) (Y , t₁ , t₂) f = (ι₁ (X , s₁) (Y , t₁) f) × (ι₂ (X , s₂) (Y , t₂) f)

ProductUnivalentStr : {S₁ : Type ℓ → Type ℓ₁} (ι₁ : StrEquiv S₁ ℓ₁') (θ₁ : UnivalentStr S₁ ι₁)
           {S₂ : Type ℓ → Type ℓ₂} (ι₂ : StrEquiv S₂ ℓ₂') (θ₂ : UnivalentStr S₂ ι₂)
         → UnivalentStr (ProductStructure S₁ S₂) (ProductEquivStr ι₁ ι₂)
ProductUnivalentStr {S₁ = S₁} ι₁ θ₁ {S₂} ι₂ θ₂ {X , s₁ , s₂} {Y , t₁ , t₂} e =
  isoToEquiv (iso φ ψ η ε)
    where
    φ : ProductEquivStr ι₁ ι₂ (X , s₁ , s₂) (Y , t₁ , t₂) e
      → PathP (λ i → ProductStructure S₁ S₂ (ua e i)) (s₁ , s₂) (t₁ , t₂)
    φ (p , q) i = (θ₁ e .fst p i) , (θ₂ e .fst q i)

    ψ : PathP (λ i → ProductStructure S₁ S₂ (ua e i)) (s₁ , s₂) (t₁ , t₂)
      → ProductEquivStr ι₁ ι₂ (X , s₁ , s₂) (Y , t₁ , t₂) e
    ψ p = invEq (θ₁ e) (λ i → p i .fst) , invEq (θ₂ e) (λ i → p i .snd)

    η : section φ ψ
    η p i j = retEq (θ₁ e) (λ k → p k .fst) i j , retEq (θ₂ e) (λ k → p k .snd) i j

    ε : retract φ ψ
    ε (p , q) i = secEq (θ₁ e) p i , secEq (θ₂ e) q i


postulate A : Set
variable  a : A

postulate B : A → Set
variable  b : B a

postulate C : B a → Set
variable  c : C b

postulate
  _==_  : {b b' : B a} → C b → C b' → Set
  _=='_ : {b : B a} → C b → C b → Set

postulate
  f : (b : B a) (b' : B {!a!}) → Set
  g : (c : C b) (c' : C {!b!}) → c == c' → Set

module _ (X : Set) where
  postulate
    h : (b' : B a) (c : C b) (c' : C b') → {!c'!} ==' c' → Set