module Structure.Container.SetLike.Proofs where

{-
open import Data.Boolean
open import Data.Boolean.Stmt
open import Functional
open import Lang.Instance
import      Lvl
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Container.SetLike
open import Structure.Function.Domain
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Relator hiding (module Names)
open import Structure.Setoid renaming (_≡_ to _≡ₛ_ ; _≢_ to _≢ₛ_)
open import Type.Properties.Inhabited
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ ℓ₆ ℓ₇ ℓ₈ ℓ₉ ℓ₁₀ ℓₗ ℓₗ₁ ℓₗ₂ ℓₗ₃ : Lvl.Level
private variable A B C C₁ C₂ Cₒ Cᵢ E E₁ E₂ : Type{ℓ}
private variable _∈_ _∈ₒ_ _∈ᵢ_ : E → C

import      Data
import      Data.Either as Either
import      Data.Tuple as Tuple
open import Logic.Predicate.Theorems
open import Logic.Propositional.Theorems
open import Structure.Relator.Ordering
open import Structure.Relator.Proofs
open import Syntax.Transitivity

module _ ⦃ setLike : SetLike{ℓ₁}{ℓ₁}{ℓ₂}{C}{C} (_∈_) {ℓ₄}{ℓ₅} ⦄ where
  open SetLike(setLike)

  module _ ⦃ _ : Equiv{ℓₗ}(C) ⦄ where
    private
      instance
        big-intersection-filter-unary-relator : ⦃ _ : Equiv{ℓₗ}(E) ⦄ ⦃ _ : BinaryRelator{B = C}(_∈_) ⦄ → ∀{As} → UnaryRelator(\a → ∀{A} → (A ∈ As) → (a ∈ A))
        big-intersection-filter-unary-relator ⦃ [∈]-binaryRelator ⦄ = [∀]-unaryRelator ⦃ rel-P = \{A} → [→]-unaryRelator ⦃ rel-P = const-unaryRelator ⦄ ⦃ rel-Q = BinaryRelator.left (binaryRelator(_∈_)) {A} ⦄ ⦄

    filter-big-union-to-big-intersection : ⦃ _ : BinaryRelator(_∈_) ⦄ ⦃ _ : FilterFunction(_∈_){ℓ = ℓ₁ Lvl.⊔ ℓ₂} ⦄ ⦃ _ : BigUnionOperator(_∈_)(_∈_) ⦄ → BigIntersectionOperator(_∈_)(_∈_)
    BigIntersectionOperator.⋂ filter-big-union-to-big-intersection As = filter(\a → ∀{A} → (A ∈ As) → (a ∈ A))(⋃ As)
    Tuple.left (BigIntersectionOperator.membership filter-big-union-to-big-intersection {As} eAs {a}) p = [↔]-to-[←] Filter.membership ([∧]-intro ([↔]-to-[←] BigUnion.membership ([∃]-map-proof (aAs ↦ [∧]-intro aAs (p aAs)) eAs)) (\{x} → p{x}))
    Tuple.right (BigIntersectionOperator.membership filter-big-union-to-big-intersection {As} eAs {a}) xfilter {A} AAs = [∧]-elimᵣ([↔]-to-[→] Filter.membership xfilter) AAs

  module _
    ⦃ _ : Equiv{ℓₗ}(C) ⦄
    ⦃ _ : BinaryRelator(_∈_) ⦄
    where

    -- Also called: Russell's paradox.
    filter-universal-contradiction : ⦃ _ : FilterFunction(_∈_){ℓ = ℓ₂} ⦄ ⦃ _ : UniversalSet(_∈_) ⦄ → ⊥
    filter-universal-contradiction = proof-not-in proof-in where
      instance
        filter-unary-relator : UnaryRelator(x ↦ (x ∉ x))
        filter-unary-relator = [¬]-unaryRelator ⦃ rel-P = binary-unaryRelator ⦄

      notInSelf : C
      notInSelf = filter (x ↦ (x ∉ x))(𝐔)

      proof-not-in : (notInSelf ∉ notInSelf)
      proof-not-in pin = [∧]-elimᵣ([↔]-to-[→] Filter.membership pin) pin

      proof-in : (notInSelf ∈ notInSelf)
      proof-in = [↔]-to-[←] Filter.membership ([∧]-intro Universal.membership proof-not-in)

module _ ⦃ setLike : SetLike{ℓ₁}{ℓ₂}{ℓ₃}{C}{E} (_∈_) {ℓ₄}{ℓ₅} ⦄ where
  open SetLike(setLike)

  private variable a b c : C
  private variable x y z : E

  [⊇]-membership : ∀{a b} → (a ⊇ b) ↔ (∀{x} → (x ∈ a) ← (x ∈ b))
  [⊇]-membership = [⊆]-membership

  module _ ⦃ _ : Equiv{ℓₗ}(E) ⦄ where
    pair-to-singleton : ⦃ _ : PairSet(_∈_) ⦄ → SingletonSet(_∈_)
    SingletonSet.singleton  pair-to-singleton e = pair e e
    SingletonSet.membership pair-to-singleton = [↔]-transitivity Pair.membership ([↔]-intro [∨]-introₗ ([∨]-elim id id))

    filter-to-empty : let _ = c in ⦃ _ : FilterFunction(_∈_){ℓ = Lvl.𝟎} ⦄ → EmptySet(_∈_)
    EmptySet.∅ (filter-to-empty {c = c}) = filter (const ⊥) c
    EmptySet.membership filter-to-empty p = [∧]-elimᵣ ([↔]-to-[→] Filter.membership p)

    module _
      ⦃ _ : Equiv{ℓₗ}(C) ⦄
      ⦃ _ : BinaryRelator(_∈_) ⦄
      where

      filter-to-intersection : ⦃ _ : FilterFunction(_∈_){ℓ = ℓ₃} ⦄ → IntersectionOperator(_∈_)
      IntersectionOperator._∩_ filter-to-intersection a b = filter (_∈ b) ⦃ unaryRelator = BinaryRelator.left infer ⦄ a
      IntersectionOperator.membership filter-to-intersection = Filter.membership ⦃ unaryRelator = BinaryRelator.left infer ⦄

  module _ ⦃ equivalence : Equivalence(_≡_) ⦄ where
    private
      instance
        [≡]-equiv : Equiv{ℓ₅}(C)
        Equiv._≡_ [≡]-equiv = _≡_
        Equiv.equivalence [≡]-equiv = equivalence

    [∈]-unaryOperatorᵣ : UnaryRelator(x ∈_)
    UnaryRelator.substitution [∈]-unaryOperatorᵣ xy = [↔]-to-[→] ([↔]-to-[→] [≡]-membership xy)

    module _
      ⦃ _ : Equiv{ℓₗ₂}(E) ⦄
      ⦃ _ : Weak.PartialOrder(_⊆_)(_≡_) ⦄
      ⦃ _ : BinaryRelator(_∈_) ⦄
      ⦃ _ : (_≡_) ⊆₂ (_⊆_) ⦄
      ⦃ _ : (_≡_) ⊆₂ (_⊇_) ⦄
      where

      [⊆]-binaryRelator : BinaryRelator(_⊆_)
      BinaryRelator.substitution [⊆]-binaryRelator p1 p2 ps = sub₂(_≡_)(_⊇_) p1 🝖 ps 🝖 sub₂(_≡_)(_⊆_) p2

      [⊇]-binaryRelator : BinaryRelator(_⊇_)
      BinaryRelator.substitution [⊇]-binaryRelator = swap(substitute₂(_⊆_) ⦃ [⊆]-binaryRelator ⦄)

  [≡]-to-[⊆] : (_≡_) ⊆₂ (_⊆_)
  _⊆₂_.proof [≡]-to-[⊆] =
    [↔]-to-[←] [⊆]-membership
    ∘ [∀][→]-distributivity [↔]-to-[→]
    ∘ [↔]-to-[→] [≡]-membership

  [≡]-to-[⊇] : (_≡_) ⊆₂ (_⊇_)
  _⊆₂_.proof [≡]-to-[⊇] =
    [↔]-to-[←] [⊆]-membership
    ∘ [∀][→]-distributivity [↔]-to-[←]
    ∘ [↔]-to-[→] [≡]-membership

  [⊆]-reflexivity : Reflexivity(_⊆_)
  Reflexivity.proof [⊆]-reflexivity = [↔]-to-[←] [⊆]-membership [→]-reflexivity

  [⊆]-antisymmetry : Antisymmetry(_⊆_)(_≡_)
  Antisymmetry.proof [⊆]-antisymmetry ab ba =
    [↔]-to-[←] [≡]-membership ([↔]-intro ([↔]-to-[→] [⊇]-membership ba) ([↔]-to-[→] [⊆]-membership ab))

  [⊆]-transitivity : Transitivity(_⊆_)
  Transitivity.proof [⊆]-transitivity xy yz =
    [↔]-to-[←] [⊆]-membership ([→]-transitivity ([↔]-to-[→] [⊆]-membership xy) ([↔]-to-[→] [⊆]-membership yz))

  [⊆]-partialOrder : Weak.PartialOrder(_⊆_)(_≡_)
  [⊆]-partialOrder = Weak.intro ⦃ [⊆]-antisymmetry ⦄ ⦃ [⊆]-transitivity ⦄ ⦃ [⊆]-reflexivity ⦄

  [≡]-reflexivity : Reflexivity(_≡_)
  Reflexivity.proof [≡]-reflexivity = [↔]-to-[←] [≡]-membership [↔]-reflexivity

  [≡]-symmetry : Symmetry(_≡_)
  Symmetry.proof [≡]-symmetry =
    [↔]-to-[←] [≡]-membership
    ∘ [∀][→]-distributivity [↔]-symmetry
    ∘ [↔]-to-[→] [≡]-membership

  [≡]-transitivity : Transitivity(_≡_)
  Transitivity.proof [≡]-transitivity xy yz = [↔]-to-[←] [≡]-membership ([↔]-transitivity ([↔]-to-[→] [≡]-membership xy) ([↔]-to-[→] [≡]-membership yz))

  [≡]-equivalence : Equivalence(_≡_)
  [≡]-equivalence = intro ⦃ [≡]-reflexivity ⦄ ⦃ [≡]-symmetry ⦄ ⦃ [≡]-transitivity ⦄

  -- TODO: These are unneccessary if one uses Structure.Operator.SetAlgebra or lattices
  module _ ⦃ _ : EmptySet(_∈_) ⦄ ⦃ _ : UniversalSet(_∈_) ⦄ ⦃ _ : ComplementOperator(_∈_) ⦄ where
    ∁-of-∅ : (∁(∅) ≡ 𝐔)
    ∁-of-∅ = [↔]-to-[←] [≡]-membership ([↔]-intro ([↔]-to-[←] Complement.membership ∘ const Empty.membership) (const Universal.membership))

    ∁-of-𝐔 : (∁(𝐔) ≡ ∅)
    ∁-of-𝐔 = [↔]-to-[←] [≡]-membership ([↔]-intro ([⊥]-elim ∘ Empty.membership) ([⊥]-elim ∘ apply Universal.membership ∘ [↔]-to-[→] Complement.membership))

module _ ⦃ setLike : SetLike{ℓ₁}{ℓ₂}{ℓ₃}{C}{E} (_∈_) {ℓ₄}{ℓ₅} ⦄ where
  open SetLike(setLike)

  open import Logic.Classical
  open import Structure.Operator.Lattice
  open import Structure.Operator.Properties

  module _ where
    private
      instance
        equiv-C : Equiv{ℓ₅}(C)
        equiv-C = intro(_≡_) ⦃ [≡]-equivalence ⦄

    module _ ⦃ _ : ComplementOperator(_∈_) ⦄ where
      instance
        [∁]-function : Function(∁)
        Function.congruence [∁]-function xy =
          [↔]-to-[←] [≡]-membership (
            Complement.membership                            ⦗ [↔]-transitivity ⦘ᵣ
            [¬]-unaryOperator ([↔]-to-[→] [≡]-membership xy) ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Complement.membership
          )

      instance
        [∁]-involution : ⦃ _ : ∀{x y} → Classical(x ∈ y) ⦄ → Involution(∁)
        Involution.proof [∁]-involution =
          [↔]-to-[←] [≡]-membership (
            Complement.membership                   ⦗ [↔]-transitivity ⦘ᵣ
            [¬]-unaryOperator Complement.membership ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro [¬¬]-intro [¬¬]-elim
          )

    module _ ⦃ _ : UnionOperator(_∈_) ⦄ where
      instance
        [∪]-binaryOperator : BinaryOperator(_∪_)
        BinaryOperator.congruence [∪]-binaryOperator xy₁ xy₂ =
          [↔]-to-[←] [≡]-membership (
            Union.membership ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Either.map ([↔]-to-[←] ([↔]-to-[→] [≡]-membership xy₁)) ([↔]-to-[←] ([↔]-to-[→] [≡]-membership xy₂))) (Either.map ([↔]-to-[→] ([↔]-to-[→] [≡]-membership xy₁)) ([↔]-to-[→] ([↔]-to-[→] [≡]-membership xy₂))) ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Union.membership
          )

      instance
        [∪]-commutativity : Commutativity(_∪_)
        Commutativity.proof [∪]-commutativity {x} {y} =
          [↔]-to-[←] [≡]-membership (
            Union.membership                    ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro [∨]-symmetry [∨]-symmetry ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Union.membership
          )

      instance
        [∪]-associativity : Associativity(_∪_)
        Associativity.proof [∪]-associativity {x} {y} =
          [↔]-to-[←] [≡]-membership (
            Union.membership ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Either.mapLeft ([↔]-to-[←] Union.membership)) (Either.mapLeft ([↔]-to-[→] Union.membership)) ⦗ [↔]-transitivity ⦘ᵣ
            [∨]-associativity ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry([↔]-intro (Either.mapRight ([↔]-to-[←] Union.membership)) (Either.mapRight ([↔]-to-[→] Union.membership))) ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Union.membership
          )

      module _ ⦃ _ : EmptySet(_∈_) ⦄ where
        instance
          [∪]-identityₗ : Identityₗ(_∪_)(∅)
          Identityₗ.proof [∪]-identityₗ {x} =
            [↔]-to-[←] [≡]-membership (
              Union.membership ⦗ [↔]-transitivity ⦘ᵣ
              [↔]-intro (Either.mapLeft [⊥]-elim) (Either.mapLeft Empty.membership) ⦗ [↔]-transitivity ⦘ᵣ
              [↔]-intro [∨]-introᵣ [∨]-identityₗ
            )

    module _ ⦃ _ : IntersectionOperator(_∈_) ⦄ where
      instance
        [∩]-binaryOperator : BinaryOperator(_∩_)
        BinaryOperator.congruence [∩]-binaryOperator xy₁ xy₂ =
          [↔]-to-[←] [≡]-membership (
            Intersection.membership ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Tuple.map ([↔]-to-[←] ([↔]-to-[→] [≡]-membership xy₁)) ([↔]-to-[←] ([↔]-to-[→] [≡]-membership xy₂))) (Tuple.map ([↔]-to-[→] ([↔]-to-[→] [≡]-membership xy₁)) ([↔]-to-[→] ([↔]-to-[→] [≡]-membership xy₂))) ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Intersection.membership
          )

      instance
        [∩]-commutativity : Commutativity(_∩_)
        Commutativity.proof [∩]-commutativity {x} {y} =
          [↔]-to-[←] [≡]-membership (
            Intersection.membership             ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro [∧]-symmetry [∧]-symmetry ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Intersection.membership
          )

      instance
        [∩]-associativity : Associativity(_∩_)
        Associativity.proof [∩]-associativity {x} {y} =
          [↔]-to-[←] [≡]-membership (
            Intersection.membership ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Tuple.mapLeft ([↔]-to-[←] Intersection.membership)) (Tuple.mapLeft ([↔]-to-[→] Intersection.membership)) ⦗ [↔]-transitivity ⦘ᵣ
            [∧]-associativity ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry([↔]-intro (Tuple.mapRight ([↔]-to-[←] Intersection.membership)) (Tuple.mapRight ([↔]-to-[→] Intersection.membership))) ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Intersection.membership
          )

      module _ ⦃ _ : UniversalSet(_∈_) ⦄ where
        instance
          [∩]-identityₗ : Identityₗ(_∩_)(𝐔)
          Identityₗ.proof [∩]-identityₗ {x} =
            [↔]-to-[←] [≡]-membership (
              Intersection.membership ⦗ [↔]-transitivity ⦘ᵣ
              [↔]-intro (Tuple.mapLeft {ℓ₁} (const Universal.membership)) (Tuple.mapLeft (const [⊤]-intro)) ⦗ [↔]-transitivity ⦘ᵣ
              [↔]-intro ([∧]-intro [⊤]-intro) [∧]-elimᵣ
            )

    module _ ⦃ _ : UnionOperator(_∈_) ⦄ ⦃ _ : IntersectionOperator(_∈_) ⦄ where
      instance
        [∩][∪]-distributivityₗ : Distributivityₗ(_∩_)(_∪_)
        Distributivityₗ.proof [∩][∪]-distributivityₗ {x} {y} {z} =
          [↔]-to-[←] [≡]-membership (
            Intersection.membership ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Tuple.mapRight ([↔]-to-[←] Union.membership)) (Tuple.mapRight ([↔]-to-[→] Union.membership)) ⦗ [↔]-transitivity ⦘ᵣ
            [∧][∨]-distributivityₗ ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Either.map ([↔]-to-[→] Intersection.membership) ([↔]-to-[→] Intersection.membership)) (Either.map ([↔]-to-[←] Intersection.membership) ([↔]-to-[←] Intersection.membership)) ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Union.membership
          )

      instance
        [∪][∩]-distributivityₗ : Distributivityₗ(_∪_)(_∩_)
        Distributivityₗ.proof [∪][∩]-distributivityₗ {x} {y} {z} =
          [↔]-to-[←] [≡]-membership (
            Union.membership ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Either.mapRight ([↔]-to-[←] Intersection.membership)) (Either.mapRight ([↔]-to-[→] Intersection.membership)) ⦗ [↔]-transitivity ⦘ᵣ
            [∨][∧]-distributivityₗ ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-intro (Tuple.map ([↔]-to-[→] Union.membership) ([↔]-to-[→] Union.membership)) (Tuple.map ([↔]-to-[←] Union.membership) ([↔]-to-[←] Union.membership)) ⦗ [↔]-transitivity ⦘ᵣ
            [↔]-symmetry Intersection.membership
          )

      instance
        [∩][∪]-absorptionₗ : Absorptionₗ(_∩_)(_∪_)
        Absorptionₗ.proof [∩][∪]-absorptionₗ {x} {y} =
          [↔]-to-[←] [≡]-membership (
            Intersection.membership ⦗ [↔]-transitivity ⦘
            [↔]-intro (ax ↦ [∧]-intro ax ([↔]-to-[←] Union.membership ([∨]-introₗ ax))) [∧]-elimₗ
          )

      instance
        [∪][∩]-absorptionₗ : Absorptionₗ(_∪_)(_∩_)
        Absorptionₗ.proof [∪][∩]-absorptionₗ {x} {y} =
          [↔]-to-[←] [≡]-membership (
            Union.membership ⦗ [↔]-transitivity ⦘
            [↔]-intro [∨]-introₗ ([∨]-elim id ([∧]-elimₗ ∘ [↔]-to-[→] Intersection.membership))
          )

      instance
        [∪][∩]-lattice : Lattice(C) (_∪_)(_∩_)
        Lattice.[∨]-operator       [∪][∩]-lattice = [∪]-binaryOperator
        Lattice.[∧]-operator       [∪][∩]-lattice = [∩]-binaryOperator
        Lattice.[∨]-commutativity  [∪][∩]-lattice = [∪]-commutativity
        Lattice.[∧]-commutativity  [∪][∩]-lattice = [∩]-commutativity
        Lattice.[∨]-associativity  [∪][∩]-lattice = [∪]-associativity
        Lattice.[∧]-associativity  [∪][∩]-lattice = [∩]-associativity
        Lattice.[∨][∧]-absorptionₗ [∪][∩]-lattice = [∪][∩]-absorptionₗ
        Lattice.[∧][∨]-absorptionₗ [∪][∩]-lattice = [∩][∪]-absorptionₗ

      instance
        [∪][∩]-distributiveLattice : Lattice.Distributive([∪][∩]-lattice)
        [∪][∩]-distributiveLattice = intro

      module _ ⦃ _ : EmptySet(_∈_) ⦄ ⦃ _ : UniversalSet(_∈_) ⦄ where
        instance
          [∪][∩]-boundedLattice : Lattice.Bounded([∪][∩]-lattice)(∅)(𝐔)
          Lattice.Bounded.[∨]-identityₗ [∪][∩]-boundedLattice = [∪]-identityₗ
          Lattice.Bounded.[∧]-identityₗ [∪][∩]-boundedLattice = [∩]-identityₗ

      module _ ⦃ _ : ComplementOperator(_∈_) ⦄ where
-}


------------------------------------------------------------------------
-- Various properties
------------------------------------------------------------------------

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

module Delay-monad.Alternative.Properties where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (↑)

open import Bijection equality-with-J as Bijection using (_↔_)
open import Embedding equality-with-J as Embedding using (Embedding)
open import Equality.Decision-procedures equality-with-J
import Equality.Groupoid equality-with-J as EG
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J hiding (id; _∘_)
open import Groupoid equality-with-J
open import H-level equality-with-J as H-level
open import H-level.Closure equality-with-J
open import Injection equality-with-J using (Injective)
import Nat equality-with-J as N

open import Delay-monad.Alternative

------------------------------------------------------------------------
-- Lemmas related to h-levels

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

  -- _↑ is a family of propositions.

  ↑-propositional : (x : Maybe A) → Is-proposition (x ↑)
  ↑-propositional nothing =
                                        $⟨ mono (N.zero≤ 2) ⊤-contractible ⟩
    Is-proposition (tt ≡ tt)            ↝⟨ H-level.respects-surjection (_↔_.surjection Bijection.≡↔inj₁≡inj₁) 1 ⟩□
    Is-proposition (nothing ≡ nothing)  □

  ↑-propositional (just x) = [inhabited⇒+]⇒+ 0 (

    just x ≡ nothing           ↝⟨ ⊎.inj₁≢inj₂ ∘ sym ⟩
    ⊥₀                         ↝⟨ ⊥-elim ⟩□
    Is-proposition (just x ↑)  □)

  -- LE nothing is a family of contractible types.

  LE-nothing-contractible :
    {x : Maybe A} → Contractible (LE nothing x)
  LE-nothing-contractible {x = x} =
    propositional⇒inhabited⇒contractible
      (λ where
         (inj₁ x↑)        (inj₂ (_ , ¬x↑)) → ⊥-elim (¬x↑ (sym x↑))
         (inj₂ (_ , ¬x↑)) (inj₁ x↑)        → ⊥-elim (¬x↑ (sym x↑))

         (inj₁ p)         (inj₁ q)         →
                                 $⟨ ↑-propositional _ ⟩
           Is-proposition (x ↑)  ↝⟨ (λ hyp → hyp _ _) ⦂ (_ → _) ⟩
           sym p ≡ sym q         ↔⟨ Eq.≃-≡ $ from-bijection $ Groupoid.⁻¹-bijection (EG.groupoid _) ⟩
           p ≡ q                 ↔⟨ Bijection.≡↔inj₁≡inj₁ ⟩□
           inj₁ p ≡ inj₁ q       □

         (inj₂ p) (inj₂ q) →
                                               $⟨ ×-closure 1 (↑-propositional _) (¬-propositional ext) ⟩
           Is-proposition (nothing ↑ × ¬ x ↑)  ↝⟨ (λ hyp → hyp _ _) ⦂ (_ → _) ⟩
           p ≡ q                               ↔⟨ Bijection.≡↔inj₂≡inj₂ ⟩□
           inj₂ p ≡ inj₂ q                     □)
      (case x return LE nothing of λ where
         nothing  → inj₁ refl
         (just x) → inj₂ (refl , ⊎.inj₁≢inj₂ ∘ sym))

  -- If A is a set, then LE is a family of propositions.

  LE-propositional :
    Is-set A → {x y : Maybe A} → Is-proposition (LE x y)
  LE-propositional A-set = irr _ _
    where
    irr : ∀ x y → Is-proposition (LE x y)
    irr nothing _ = mono₁ 0 LE-nothing-contractible

    irr (just x) (just y) (inj₁ p) (inj₁ q) =
      cong inj₁ $ Maybe-closure 0 A-set p q

    irr (just _) (just _) (inj₂ (() , _))
    irr (just _) (just _) _ (inj₂ (() , _))
    irr (just _) nothing  (inj₁ ())
    irr (just _) nothing  (inj₂ (() , _))

  -- If A is a set, then Increasing is a family of propositions.

  Increasing-propositional :
    Is-set A → {f : ℕ → Maybe A} → Is-proposition (Increasing f)
  Increasing-propositional A-set =
    Π-closure ext 1 λ _ →
    LE-propositional A-set

  -- An equality characterisation lemma which applies when A is a set.

  equality-characterisation :
    Is-set A →
    {x y : Delay A} → proj₁ x ≡ proj₁ y ↔ x ≡ y
  equality-characterisation A-set =
    ignore-propositional-component (Increasing-propositional A-set)

  -- If A has h-level 2 + n, then LE {A = A} x y has h-level 2 + n.

  LE-closure :
    ∀ {x y} n → H-level (2 + n) A → H-level (2 + n) (LE x y)
  LE-closure n h =
    ⊎-closure n
      (mono₁ (1 + n) (Maybe-closure n h))
      (mono (N.suc≤suc (N.zero≤ (1 + n)))
         (×-closure 1 (↑-propositional _)
                      (¬-propositional ext)))

  -- If A has h-level 2 + n, then Increasing {A = A} f has h-level
  -- 2 + n.

  Increasing-closure :
    ∀ {f} n → H-level (2 + n) A → H-level (2 + n) (Increasing f)
  Increasing-closure n h =
    Π-closure ext (2 + n) λ _ →
    LE-closure n h

  -- If A has h-level 2 + n, then Delay A has h-level 2 + n.

  Delay-closure :
    ∀ n → H-level (2 + n) A → H-level (2 + n) (Delay A)
  Delay-closure n h =
    Σ-closure (2 + n)
      (Π-closure ext (2 + n) λ _ →
       Maybe-closure n h)
      (λ _ → Increasing-closure n h)

------------------------------------------------------------------------
-- Various properties relating _↓_, _↑ and the usual ordering of the
-- natural numbers

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

  -- If f is increasing and f n has a value, then f (suc n) has the
  -- same value.

  ↓-step : ∀ {f} {x : A} {n} →
           Increasing f → f n ↓ x → f (suc n) ↓ x
  ↓-step {f = f} {x} {n} inc fn↓x = step (inc n)
    module ↓ where
    step : LE (f n) (f (suc n)) → f (suc n) ↓ x
    step (inj₁ fn≡f1+n) =

      f (suc n)  ≡⟨ sym fn≡f1+n ⟩
      f n        ≡⟨ fn↓x ⟩∎
      just x     ∎

    step (inj₂ (fn↑ , _)) =

      ⊥-elim $ ⊎.inj₁≢inj₂ (
        nothing  ≡⟨ sym fn↑ ⟩
        f n      ≡⟨ fn↓x ⟩∎
        just x   ∎)

  -- If f is increasing and f (suc n) does not have a value, then
  -- f n does not have a value.

  ↑-step : ∀ {f : ℕ → Maybe A} {n} →
           Increasing f → f (suc n) ↑ → f n ↑
  ↑-step {f} {n} inc f1+n↑ with inc n
  ... | inj₁ fn≡f1+n   = f n        ≡⟨ fn≡f1+n ⟩
                         f (suc n)  ≡⟨ f1+n↑ ⟩∎
                         nothing    ∎
  ... | inj₂ (fn↑ , _) = fn↑

  -- If f is increasing and f 0 has a value, then f n has the same
  -- value.

  ↓-upwards-closed₀ : ∀ {f} {x : A} →
                      Increasing f → f 0 ↓ x → ∀ n → f n ↓ x
  ↓-upwards-closed₀ _   f0↓ zero    = f0↓
  ↓-upwards-closed₀ inc f0↓ (suc n) =
    ↓-upwards-closed₀ (inc ∘ suc) (↓-step inc f0↓) n

  -- If f is increasing, then (λ n → f n ↓ x) is upwards closed.

  ↓-upwards-closed :
    ∀ {f : ℕ → Maybe A} {m n x} →
    Increasing f → m N.≤ n → f m ↓ x → f n ↓ x
  ↓-upwards-closed _   (N.≤-refl′ refl)     = id
  ↓-upwards-closed inc (N.≤-step′ m≤n refl) =
    ↓-step inc ∘ ↓-upwards-closed inc m≤n

  -- If f is increasing, then (λ n → f n ↑) is downwards closed.

  ↑-downwards-closed : ∀ {f : ℕ → Maybe A} {m n} →
                       Increasing f → m N.≤ n → f n ↑ → f m ↑
  ↑-downwards-closed inc (N.≤-refl′ refl)     = id
  ↑-downwards-closed inc (N.≤-step′ m≤n refl) =
    ↑-downwards-closed inc m≤n ∘ ↑-step inc

  -- If f is increasing and f m does not have a value, but f n does
  -- have a value, then m < n.

  ↑<↓ : ∀ {f : ℕ → Maybe A} {x m n} →
        Increasing f → f m ↑ → f n ↓ x → m N.< n
  ↑<↓ {f} {x} {m} {n} inc fm↑ fn↓x with n N.≤⊎> m
  ... | inj₂ m<n = m<n
  ... | inj₁ n≤m =
    ⊥-elim $ ⊎.inj₁≢inj₂
      (nothing  ≡⟨ sym $ ↑-downwards-closed inc n≤m fm↑ ⟩
       f n      ≡⟨ fn↓x ⟩∎
       just x   ∎)

------------------------------------------------------------------------
-- An unused lemma

private

  -- If the embedding g maps nothing to nothing and just to just, then
  -- there is an isomorphism between Increasing f and
  -- Increasing (g ∘ f).

  Increasing-∘ :
    ∀ {a b} {A : Type a} {B : Type b} {f : ℕ → Maybe A} →
    (g : Embedding (Maybe A) (Maybe B)) →
    Embedding.to g nothing ≡ nothing →
    (∀ {x} → Embedding.to g (just x) ≢ nothing) →
    Increasing f ↔ Increasing (Embedding.to g ∘ f)
  Increasing-∘ {A = A} {B} {f} g g↑ g↓ = record
    { surjection = record
      { logical-equivalence = record
        { to   = to   ∘_
        ; from = from ∘_
        }
      ; right-inverse-of = ⟨ext⟩ ∘ (to∘from ∘_)
      }
    ; left-inverse-of = ⟨ext⟩ ∘ (from∘to ∘_)
    }
    where
    g′ : Maybe A → Maybe B
    g′ = Embedding.to g

    g-injective : Injective g′
    g-injective = Embedding.injective (Embedding.is-embedding g)

    lemma₁ : ∀ {x} → x ↑ → g′ x ↑
    lemma₁ refl = g↑

    lemma₂ : ∀ x → ¬ x ↑ → ¬ g′ x ↑
    lemma₂ nothing  x↓ _ = x↓ refl
    lemma₂ (just _) _    = g↓

    lemma₃ : ∀ x → g′ x ↑ → x ↑
    lemma₃ nothing  _   = refl
    lemma₃ (just _) g↓↑ = ⊥-elim (lemma₂ _ (λ ()) g↓↑)

    lemma₄ : ∀ x → g′ x ≢ nothing → x ≢ nothing
    lemma₄ nothing  g↑↓ _  = g↑↓ g↑
    lemma₄ (just _) _   ()

    to : ∀ {n} → Increasing-at n f → Increasing-at n (g′ ∘ f)
    to = ⊎-map (cong g′) (Σ-map lemma₁ (lemma₂ _))

    from : ∀ {n} → Increasing-at n (g′ ∘ f) → Increasing-at n f
    from = ⊎-map g-injective (Σ-map (lemma₃ _) (lemma₄ _))

    to∘from : ∀ {n} (x : Increasing-at n (g′ ∘ f)) → to (from x) ≡ x
    to∘from (inj₁ p) = cong inj₁ (
      cong g′ (g-injective p)  ≡⟨ _≃_.right-inverse-of (Embedding.equivalence g) _ ⟩∎
      p                        ∎)
    to∘from (inj₂ _) = cong inj₂ $
      ×-closure 1 (↑-propositional _) (¬-propositional ext) _ _

    from∘to : ∀ {n} (x : Increasing-at n f) → from (to x) ≡ x
    from∘to (inj₁ p) = cong inj₁ (
      g-injective (cong g′ p)  ≡⟨ _≃_.left-inverse-of (Embedding.equivalence g) _ ⟩∎
      p                        ∎)
    from∘to (inj₂ _) = cong inj₂ $
      ×-closure 1 (↑-propositional _) (¬-propositional ext) _ _


module LC.Subst where

open import LC.Base
open import LC.Subst.Var
open import LC.Subst.Term
open import LC.Subst.Term public using (lift)

open import Data.Nat
open import Data.Nat.Properties
open import Relation.Nullary

--------------------------------------------------------------------------------
-- substitution

infixl 10 _[_/_]
_[_/_] : Term → Term → ℕ → Term
(var x) [ N / i ] = subst-var (match x i) N
(ƛ M)   [ N / i ] = ƛ (M [ N / suc i ])
(L ∙ M) [ N / i ] = L [ N / i ] ∙ M [ N / i ]

-- substitute the 0th var in M for N
infixl 10 _[_]
_[_] : Term → Term → Term
M [ N ] = M [ N / 0 ]

--------------------------------------------------------------------------------
-- properties regarding substitution

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary.Negation using (contradiction)
open ≡-Reasoning

subst-< : ∀ x i N → x < i → (var x) [ N / i ] ≡ var x
subst-< x i N x<i with match x i
... | Under x<i' = refl
... | Exact x≡i  = contradiction x≡i (<⇒≢ x<i)
... | Above v x≥i = contradiction (≤-step (≤-pred x≥i)) (<⇒≱ x<i)

subst-≡ : ∀ x i N → x ≡ i → (var x) [ N / i ] ≡ lift 0 i N
subst-≡ x i N x≡i with match x i
... | Under x<i  = contradiction x≡i (<⇒≢ x<i)
... | Exact x≡i' = refl
... | Above v x≥i = contradiction (sym x≡i) (<⇒≢ x≥i)

subst-> : ∀ x i N → suc x > i → (var suc x) [ N / i ] ≡ var x
subst-> x i N x≥i with match (suc x) i
... | Under x<i = contradiction (≤-pred (≤-step x<i)) (<⇒≱ x≥i)
... | Exact x≡i  = contradiction (sym x≡i) (<⇒≢ x≥i)
... | Above v x≥i' = refl

subst-[]-var : ∀ m n i x N
  → subst-var (match (lift-var n m x) (n + m + i)) N
  ≡ lift n m (subst-var (match x (n + i)) N)
subst-[]-var m n i x N with inspectBinding n x
subst-[]-var m n i x N | Free n≤x with match x (n + i)
subst-[]-var m n i x N | Free n≤x | Under x<n+i =
    begin
        subst-var (match (m + x) (n + m + i)) N
    ≡⟨ subst-var-match-< {m + x} {n + m + i} N (LC.Subst.Var.INEQ.l+m+n>m+x n m i x x<n+i) ⟩
        var (m + x)
    ≡⟨ cong var_ (sym (LC.Subst.Var.lift-var-≤ n≤x)) ⟩
        var lift-var n m x
    ∎
subst-[]-var m n i x N | Free n≤x | Exact x≡n+i =
    begin
        subst-var (match (m + x) (n + m + i)) N
    ≡⟨ subst-var-match-≡ {m + x} {n + m + i} N (sym (LC.Subst.Var.EQ.l+m+n≡m+x n m i x (sym x≡n+i))) ⟩
        lift 0 (n + m + i) N
    ≡⟨ lift-lemma 0 m n i N ⟩
        lift n m (lift 0 (n + i) N)
    ∎
subst-[]-var m n i .(suc v) N | Free n≤x | Above v x≥n+i =
    begin
        subst-var (match (m + suc v) (n + m + i)) N
    ≡⟨ cong (λ w → subst-var (match w (n + m + i)) N) (+-suc m v) ⟩
        subst-var (match (suc m + v) (n + m + i)) N
    ≡⟨ subst-var-match-> {m + v} {n + m + i} N (s≤s (LC.Subst.Var.INEQ.l+m+n≤m+x n m i v (≤-pred x≥n+i))) ⟩
        var (m + v)
    ≡⟨ cong var_ (sym (LC.Subst.Var.lift-var-≤ {n} {m} {v} (≤-trans (m≤m+n n i) (≤-pred x≥n+i)))) ⟩
        var lift-var n m v
    ∎
subst-[]-var m n i x N | Bound n>x =
    begin
        subst-var (match x (n + m + i)) N
    ≡⟨ subst-var-match-< N (≤-trans n>x (≤-trans (m≤m+n n m) (m≤m+n (n + m) i))) ⟩
        var x
    ≡⟨ cong var_ (sym (LC.Subst.Var.lift-var-> n>x)) ⟩
        var lift-var n m x
    ≡⟨⟩
        lift n m (var x)
    ≡⟨ cong (lift n m) (sym (subst-var-match-< N (≤-trans n>x (m≤m+n n i)))) ⟩
        lift n m (subst-var (match x (n + i)) N)
    ∎

lemma : ∀ {m n i} M N
  → lift (suc ((m + n))) i M [ lift n i N / m ]
  ≡ lift (m + n)         i (M [ N / m ])
lemma {m} {n} {i} (var x) N = LC.Subst.Term.subst-var-lift _ _ _ x N
lemma (ƛ M)   N = cong  ƛ_   (lemma M N)
lemma (K ∙ M) N = cong₂ _∙_  (lemma K N) (lemma M N)

lift-[] : ∀ n m i M N → lift n m (M [ N / n + i ]) ≡ lift n m M [ N / n + m + i ]
lift-[] n m i (var x) N = sym (subst-[]-var m n i x N)
lift-[] n m i (ƛ M) N = cong ƛ_ (lift-[] (suc n) m i M N)
lift-[] n m i (M ∙ M') N = cong₂ _∙_ (lift-[] n m i M N) (lift-[] n m i M' N)

lift-subst-var : ∀ l m n i x N → n ≥ i → i ≥ m → lift (l + m) (suc n) (var x) [ N / l + i ] ≡ lift (l + m) n (var x)
lift-subst-var l m n i x N n≥i i≥m with inspectBinding (l + m) x
... | Free l+m≤x =
  begin
      subst-var (match (suc (n + x)) (l + i)) N
  ≡⟨ subst-var-match-> {n + x} {l + i} N (s≤s prop) ⟩
      var (n + x)
  ∎
  where
    prop : l + i ≤ n + x
    prop = ≤-trans (≤-reflexive (+-comm l i)) (+-mono-≤ n≥i (≤-trans (m≤m+n l m) l+m≤x))

... | Bound l+m>x =
    begin
        subst-var (match x (l + i)) N
    ≡⟨ subst-var-match-< {x} {l + i} N prop ⟩
        var x
    ∎
    where
      prop : x < l + i
      prop = ≤-trans l+m>x (+-monoʳ-≤ l i≥m)

lift-subst : ∀ l m n i M N → n ≥ i → i ≥ m → lift (l + m) (suc n) M [ N / l + i ] ≡ lift (l + m) n M
lift-subst l m n i (var x) N n≥i i≥m = lift-subst-var l m n i x N n≥i i≥m
lift-subst l m n i (ƛ M)   N n≥i i≥m = cong ƛ_ (lift-subst (suc l) m n i M N n≥i i≥m)
lift-subst l m n i (L ∙ M) N n≥i i≥m = cong₂ _∙_ (lift-subst l m n i L N n≥i i≥m) (lift-subst l m n i M N n≥i i≥m)

subst-var-match-[] : ∀ {m i} x M N
    → subst-var (match x (suc (m + i))) N [ M [ N / i ] / m     ]
    ≡ subst-var (match x       m      ) M [ N           / m + i ]
subst-var-match-[] {m} {i} x M N with match x m
... | Under x<m =
    begin
        subst-var (match x (suc (m + i))) N [ M [ N / i ] / m ]
    ≡⟨ (cong (_[ M [ N / i ] / m ])) (LC.Subst.Term.subst-var-match-< N (≤-trans x<m (≤-step (m≤m+n m i)))) ⟩
        (var x) [ M [ N / i ] / m ]
    ≡⟨ subst-< x m (M [ N / i ]) x<m ⟩
        var x
    ≡⟨ sym (LC.Subst.Term.subst-var-match-< N (≤-trans x<m (m≤m+n m i))) ⟩
        subst-var (match x (m + i)) N
    ∎
... | Exact x≡m =
    begin
        subst-var (match x (suc (m + i))) N [ M [ N / i ] / m ]
    ≡⟨ cong (_[ M [ N / i ] / m ]) (LC.Subst.Term.subst-var-match-< N (≤-trans (s≤s (≤-reflexive x≡m)) (s≤s (m≤m+n m i)))) ⟩
        (var x) [ M [ N / i ] / m ]
    ≡⟨ subst-≡ x m (M [ N / i ]) x≡m ⟩
        lift 0 m (M [ N / i ])
    ≡⟨ lift-[] 0 m i M N ⟩
        lift 0 m M [ N / m + i ]
    ∎
... | Above v v≥m with match v (m + i)
... | Under v<m+i =
    begin
        subst-var (match (suc v) (suc (m + i))) N [ M [ N / i ] / m ]
    ≡⟨ cong (_[ M [ N / i ] / m ]) (LC.Subst.Term.subst-var-match-< {suc v} {suc m + i} N (s≤s v<m+i)) ⟩
        (var suc v) [ M [ N / i ] / m ]
    ≡⟨ subst-> v m (M [ N / i ]) v≥m ⟩
        var v
    ∎
... | Exact v≡m+i =
    begin
        subst-var (match (suc v) (suc (m + i))) N [ M [ N / i ] / m ]
    ≡⟨ cong (_[ M [ N / i ] / m ]) (LC.Subst.Term.subst-var-match-≡ {suc v} {suc m + i} N (cong suc v≡m+i)) ⟩
        lift 0 (suc m + i) N [ M [ N / i ] / m ]
    ≡⟨ lift-subst 0 0 (m + i) m N (M [ N / i ]) (m≤m+n m i) z≤n ⟩
        lift 0 (m + i) N
    ∎
... | Above v' v>m+i =
    begin
        subst-var (match (suc (suc v')) (suc (m + i))) N [ M [ N / i ] / m ]
    ≡⟨ cong (_[ M [ N / i ] / m ]) (LC.Subst.Term.subst-var-match-> {suc v'} {suc m + i} N (s≤s v>m+i)) ⟩
        (var (suc v')) [ M [ N / i ] / m ]
    ≡⟨ subst-> v' m (M [ N / i ]) (≤-trans (s≤s (m≤m+n m i)) v>m+i) ⟩
        var v'
    ∎

subst-lemma : ∀ {m i} M N O
    → M [ O / suc m + i ] [ N [ O / i ] / m     ]
    ≡ M [ N /     m     ] [ O           / m + i ]
subst-lemma (var x) N O = subst-var-match-[] x N O
subst-lemma (ƛ M)   N O = cong ƛ_ (subst-lemma M N O)
subst-lemma (M ∙ L) N O = cong₂ _∙_ (subst-lemma M N O) (subst-lemma L N O)


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

open import HoTT
open import stash.modalities.gbm.GbmUtil

module stash.modalities.gbm.PushoutMono where

  --
  --  The goal of this file is to prove the following:
  --  Suppose we have a pushout
  --
  --        g
  --    C ------> B
  --    v         |
  --    |         |
  --  f |         |
  --    v         v
  --    A ------> D
  --
  --  and the map f is a monomorphism.  Then the square
  --  is also a pullback.
  --

  is-mono : ∀ {i j} {A : Type i} {B : Type j} → (A → B) → Type _
  is-mono {B = B} f = (b : B) → has-level (S ⟨-2⟩) (hfiber f b)

  mono-eq : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a₀ a₁ : A}
    (p : f a₀ == f a₁) → is-mono f → a₀ == a₁
  mono-eq f {a₀} {a₁} p ism = ! (fst= (fst (ism (f a₁) (a₁ , idp) (a₀ , p))))

  mono-eq-idp : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a : A}
    → (is-m : is-mono f) → mono-eq f {a₀ = a} idp is-m == idp
  mono-eq-idp f {a} ism = ap (λ x → ! (fst= x)) (snd (ism (f a) (a , idp) (a , idp)) idp)

  mono-eq-ap : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {a₀ a₁ : A}
    (p : f a₀ == f a₁) → (is-m : is-mono f) → ap f (mono-eq f p is-m) == p
  mono-eq-ap f {a₀} {a₁} p ism =
    ap f (! (fst= α)) =⟨ ! (!-ap f (fst= α)) ⟩
    ! (ap f (fst= α)) =⟨ ! (∙-unit-r (! (ap f (fst= α)))) ⟩
    ! (ap f (fst= α)) ∙ idp =⟨ ↓-app=cst-out (snd= α) |in-ctx (λ x → ! (ap f (fst= α)) ∙ x) ⟩
    ! (ap f (fst= α)) ∙ ap f (fst= α) ∙ p =⟨ ! (∙-assoc (! (ap f (fst= α))) (ap f (fst= α)) p) ⟩
    (! (ap f (fst= α)) ∙ ap f (fst= α)) ∙ p =⟨ !-inv-l (ap f (fst= α)) |in-ctx (λ x → x ∙ p) ⟩
    p ∎

    where α = fst (ism (f a₁) (a₁ , idp) (a₀ , p))

  ap-lem : ∀ {i j k} {A : Type i} {B : A → Type j} {C : Type k} (f : Σ A B → C)
       {a₀ a₁ : A} {p : a₀ == a₁} {b₀ : B a₀} {b₁ : B a₁}
       (q : b₀ == b₁ [ B ↓ p ]) → ap f (pair= p q) == ↓-cst-out (↓-Π-out (apd (curry f) p) q)
  ap-lem f {p = idp} idp = idp

  Lift-Unit-is-contr : ∀ {i} → is-contr (Lift {j = i} ⊤)
  Lift-Unit-is-contr = equiv-preserves-level (lower-equiv ⁻¹) Unit-is-contr

  Lift-Unit-is-prop : ∀ {i} → is-prop (Lift {j = i} ⊤)
  Lift-Unit-is-prop = contr-is-prop Lift-Unit-is-contr

  module MonoLemma {i} (s : Span {i} {i} {i}) (m : is-mono (Span.f s)) where

    open Span s

    private
      D = Pushout s

    mleft : A → D
    mleft = left

    mright : B → D
    mright = right

    mglue : (c : C) → mleft (f c) == mright (g c)
    mglue c = glue c

    -- Construct a fibration over the pushout
    -- whose total space is equivalent to B

    glue-equiv : (c : C) → hfiber f (f c) ≃ Lift {j = i} ⊤
    glue-equiv c = contr-equiv-LiftUnit (inhab-prop-is-contr (c , idp) (m (f c)))

    -- Now, I claim that the values of this fibration are props.
    -- How do you prove this?

    module B' = PushoutRec {d = s} (hfiber f) (cst (Lift ⊤)) (ua ∘ glue-equiv)

    B' : (d : D) → Type i
    B' = B'.f

    B'-β : (c : C) → ap B' (glue c) == ua (glue-equiv c)
    B'-β c = B'.glue-β c

    B'-is-prop : (d : D) → is-prop (B' d)
    B'-is-prop = Pushout-elim (λ a → m a) (λ b → Lift-Unit-is-prop)
      (λ c → prop-lemma (λ z → is-prop (B' z) , is-prop-is-prop) (mglue c) (m (f c))
      Lift-Unit-is-prop)

    B'-prop : (d : D) → hProp i
    B'-prop d = B' d , B'-is-prop d

    B'-pth-in : ∀ {a b} (p : mleft a == mright b) (x : B' (mleft a)) (y : B' (mright b))
      → x == y [ B' ↓ p ]
    B'-pth-in p x y = prop-lemma B'-prop p x y

    B'-pth-in' : ∀ {a b} (p : mright b == mleft a) (x : B' (mleft a)) (y : B' (mright b))
      → y == x [ B' ↓ p ]
    B'-pth-in' p x y = prop-lemma B'-prop p y x

    cpth : (c : C) → (c , idp) == (lift unit) [ B' ↓ glue c ]
    cpth c = fst (pths-ovr-contr B'-prop (glue c) (c , idp) (lift unit))

    -- Yeah, these triples of data seem to come up a bunch
    -- the point is, such data is contractible...
    data-contr : (c : C) → is-contr (Σ (B' (left (f c))) (λ l → Σ (B' (right (g c))) (λ r → l == r [ B' ↓ glue c ])))
    data-contr c = Σ-level (inhab-prop-is-contr (c , idp) (m (f c)))
      (λ l → Σ-level Lift-Unit-is-contr (λ r → pths-ovr-contr B'-prop (glue c) l r))

    data-elim : (c : C) (P : (l : B' (left (f c))) (r : B' (right (g c))) → (l == r [ B' ↓ glue c ]) → Type i)
                → (t : Σ (B' (left (f c))) (λ l → Σ (B' (right (g c))) (λ r → l == r [ B' ↓ glue c ])))
                → P (fst t) (fst (snd t)) (snd (snd t))
                → (l : B' (left (f c))) → (r : B' (right (g c))) → (q : l == r [ B' ↓ glue c ]) → P l r q
    data-elim c P t x l r q = transport (λ { (l₀ , r₀ , q₀) → P l₀ r₀ q₀ })
      (contr-has-all-paths (data-contr c) _ _) x

    module _ where

      private

        to : B → Σ D B'
        to b = mright b , lift unit

        module From = PushoutElim {d = s} {P = λ d → B' d → B}
          (λ a e → g (fst e))
          (λ b _ → b)
          (λ c → ↓-Π-in (λ {l} {r} q → ↓-cst-in (ap g (mono-eq f (snd l) m))))

        from : Σ D B' → B
        from = uncurry $ From.f

        to-from : (db : Σ D B') → to (from db) == db
        to-from = uncurry $ Pushout-elim lem₀ (λ b _ → idp)
          (λ c → ↓-Π-in (λ {l} {r} q → ↓-app=idf-in (lem₁ c l r q)))

          where lem₀ : (a : A) (l : B' (left a)) → to (from (left a , l)) == left a , l
                lem₀ .(f c) (c , idp) = ! (pair= (mglue c) (cpth c))

                P : (c : C) (l : B' (left (f c))) (r : B' (right (g c))) (q : l == r [ B' ↓ glue c ]) → Type i
                P c l r q = lem₀ (f c) l ∙' pair= (glue c) q ==
                            ap (λ v → to (from v)) (pair= (glue c) q) ∙ idp

                lem₂ : (c : C) → P c (c , idp) (lift unit) (cpth c)
                lem₂ c = ! (pair= (glue c) (cpth c)) ∙' pair= (glue c) (cpth c)
                           =⟨ !-inv'-l (pair= (glue c) (cpth c)) ⟩
                         idp =⟨ ! (mono-eq-idp f m) |in-ctx (λ x → ap to (ap g x))  ⟩
                         ap to (ap g (mono-eq f idp m))
                           =⟨ ! (↓-cst-β (pair= (glue c) (cpth c)) (ap g (mono-eq f idp m))) |in-ctx (λ x → ap to x) ⟩
                         ap to (↓-cst-out (↓-cst-in {p = (pair= (glue c) (cpth c))} (ap g (mono-eq f idp m))))
                           =⟨ ! (↓-Π-β (λ {l} {r} q → ↓-cst-in (ap g (mono-eq f (snd l) m))) (cpth c)) |in-ctx (λ x → ap to (↓-cst-out x)) ⟩
                         ap to (↓-cst-out (↓-Π-out (↓-Π-in (λ {l} {r} q → ↓-cst-in (ap g (mono-eq f (snd l) m)))) (cpth c)))
                           =⟨ ! (From.glue-β c) |in-ctx (λ x → ap to (↓-cst-out (↓-Π-out x (cpth c)))) ⟩
                         ap to (↓-cst-out (↓-Π-out (apd (curry from) (glue c)) (cpth c)))
                           =⟨ ! (ap-lem from (cpth c)) |in-ctx (λ x → ap to x) ⟩
                         ap to (ap from (pair= (glue c) (cpth c)))
                           =⟨ ∘-ap to from (pair= (glue c) (cpth c)) ⟩
                         ap (to ∘ from) (pair= (glue c) (cpth c))
                           =⟨ ! (∙-unit-r _) ⟩
                         ap (to ∘ from) (pair= (glue c) (cpth c)) ∙ idp ∎

                lem₁ : (c : C) (l : B' (left (f c))) (r : B' (right (g c))) (q : l == r [ B' ↓ glue c ])
                  → lem₀ (f c) l ∙' pair= (glue c) q ==
                     ap (λ v → to (from v)) (pair= (glue c) q) ∙ idp
                lem₁ c l r q = data-elim c (P c) ((c , idp) , (lift unit , cpth c)) (lem₂ c) l r q

      B≃B' : B ≃ Σ D B'
      B≃B' = equiv to from to-from (λ b → idp)

    -- From the above equivalence, we can prove that
    -- mright is also a mono
    mright-is-mono : is-mono mright
    mright-is-mono d = equiv-preserves-level (lem ⁻¹ ∘e (hfiber-fst d) ⁻¹) (B'-is-prop d)

      where lem : hfiber mright d ≃ hfiber fst d
            lem = hfiber-sq-eqv mright fst (fst B≃B') (idf D) (comm-sqr (λ b → idp)) (snd B≃B') (idf-is-equiv D) d

    -- Pulling back over A, we should have a space
    -- equivalent to C as well as the path spaces
    -- we are interested in.

    C' : Type i
    C' = Σ A (B' ∘ mleft)

    -- Given (b : B) and an element it is equal to in the
    -- the pushout, we can find an element in the fiber which
    -- witnesses that equaltiy

    witness-for : ∀ {a b} (p : mleft a == mright b) → hfiber f a
    witness-for p = transport! B' p (lift unit)

    -- Using the fact that mright is a mono, we can
    -- find a proof of the following
    witness-for-coh₀ : ∀ {a b} (p : mleft a == mright b) → g (fst (witness-for p)) == b
    witness-for-coh₀ {a} {b} p = mono-eq mright lem mright-is-mono

      where c : C
            c = fst (witness-for p)

            lem : mright (g c) == mright b
            lem = ! (mglue c) ∙ ap mleft (snd (witness-for p)) ∙ p

    witness-for-coh₁ : ∀ {a b} (p : mleft a == mright b)
      → (! (ap mleft (snd (witness-for p))) ∙ mglue (fst (witness-for p))) == p
         [ (λ ab → mleft (fst ab) == mright (snd ab)) ↓ (ap (λ x → (a , x)) (witness-for-coh₀ p)) ]
    witness-for-coh₁ {a} p = ↓-ap-in _ (λ b₀ → (a , b₀)) (↓-cst=app-in calc)

      where α = ap mleft (snd (witness-for p))
            β = mglue (fst (witness-for p))

            calc = (! α ∙ β) ∙' ap mright (witness-for-coh₀ p)
                      =⟨ mono-eq-ap mright (! β ∙ α ∙ p) mright-is-mono |in-ctx (λ x → (! α ∙ β) ∙' x) ⟩
                   (! α ∙ β) ∙' ! β ∙ α ∙ p =⟨ ∙'=∙ (! α ∙ β) (! β ∙ α ∙ p) ⟩
                   (! α ∙ β) ∙ ! β ∙ α ∙ p =⟨ ∙-assoc (! α) β (! β ∙ α ∙ p) ⟩
                   ! α ∙ β ∙ ! β ∙ α ∙ p =⟨ ! (∙-assoc β (! β) (α ∙ p)) |in-ctx (λ x → ! α ∙ x) ⟩
                   ! α ∙ (β ∙ ! β) ∙ α ∙ p =⟨ !-inv-r β |in-ctx (λ x → ! α ∙ x ∙ α ∙ p) ⟩
                   ! α ∙ α ∙ p =⟨ ! (∙-assoc (! α) α p) ⟩
                   (! α ∙ α) ∙ p =⟨ !-inv-l α |in-ctx (λ x → x ∙ p) ⟩
                   p ∎

    C'-equiv-pths : C' ≃ Σ (A × B) (λ ab → mleft (fst ab) == mright (snd ab))
    C'-equiv-pths = equiv to from to-from from-to

      where to : C' → Σ (A × B) (λ ab → mleft (fst ab) == mright (snd ab))
            to (a , c , p) = (a , g c) , ! (ap mleft p) ∙ mglue c

            from : Σ (A × B) (λ ab → mleft (fst ab) == mright (snd ab)) → C'
            from ((a , b) , p) = a , witness-for p

            to-from : (x : Σ (A × B) (λ ab → mleft (fst ab) == mright (snd ab))) → to (from x) == x
            to-from ((a , b) , p) = pair= (pair= idp (witness-for-coh₀ p)) (witness-for-coh₁ p)

            from-to : (c' : C') → from (to c') == c'
            from-to (a , c , p) = pair= idp (fst (m _ _ (c , p)))

    C-equiv-C' : C ≃ C'
    C-equiv-C' = equiv to from to-from from-to

      where to : C → C'
            to c = f c , (c , idp)

            from : C' → C
            from (a , c , p) = c

            to-from : (c' : C') → to (from c') == c'
            to-from (a , c , p) = pair= p (fst (pths-ovr-contr (λ a → hfiber f a , m a) p (c , idp) (c , p)))

            from-to : (c : C) → from (to c) == c
            from-to c = idp

    -- Combining the two equivalences from above
    -- gives us the result we want.

    pushout-mono-is-pullback : C ≃ Σ (A × B) (λ ab → mleft (fst ab) == mright (snd ab))
    pushout-mono-is-pullback = C'-equiv-pths ∘e C-equiv-C'


-- Andreas, 2016-09-22, issue #2183, issue reported by Ulf

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

module _ (n : Nat) where

  foo : (m : Nat) → n ≡ m → Nat
  foo m refl = {!m!}

-- Splitting on m fails currently, as it internally is .n
-- We may be doing something about this in the future.


open import FRP.JS.Bool using ( not )
open import FRP.JS.Nat using ( ) renaming ( _≟_ to _≟n_ )
open import FRP.JS.String using ( _≟_ ; _≤_ ; _<_ ; length )
open import FRP.JS.QUnit using ( TestSuite ; ok ; test ; _,_ )

module FRP.JS.Test.String where

tests : TestSuite
tests =
  ( test "≟"
    ( ok "abc ≟ abc" ("abc" ≟ "abc")
    , ok "ε ≟ abc" (not ("" ≟ "abc"))
    , ok "a ≟ abc" (not ("a" ≟ "abc"))
    , ok "abc ≟ ABC" (not ("abc" ≟ "ABC")) )
  , test "length"
    ( ok "length ε" (length "" ≟n 0)
    , ok "length a" (length "a" ≟n 1)
    , ok "length ab" (length "ab" ≟n 2)
    , ok "length abc" (length "abc" ≟n 3)
    , ok "length \"\\\"" (length "\"\\\"" ≟n 3)
    , ok "length åäö⊢ξ∀" (length "åäö⊢ξ∀" ≟n 6)
    , ok "length ⟨line-terminators⟩" (length "\r\n\x2028\x2029" ≟n 4) )
  , test "≤"
    ( ok "abc ≤ abc" ("abc" ≤ "abc")
    , ok "abc ≤ ε" (not ("abc" ≤ ""))
    , ok "abc ≤ a" (not ("abc" ≤ "a"))
    , ok "abc ≤ ab" (not ("abc" ≤ "a"))
    , ok "abc ≤ ABC" (not ("abc" ≤ "ABC"))
    , ok "ε ≤ abc" ("" ≤ "abc")
    , ok "a ≤ abc" ("a" ≤ "abc")
    , ok "ab ≤ abc" ("a" ≤ "abc")
    , ok "ABC ≤ abc" ("ABC" ≤ "abc") )
  , test "<"
    ( ok "abc < abc" (not ("abc" < "abc"))
    , ok "abc < ε" (not ("abc" < ""))
    , ok "abc < a" (not ("abc" < "a"))
    , ok "abc < ab" (not ("abc" < "a"))
    , ok "abc < ABC" (not ("abc" < "ABC"))
    , ok "ε < abc" ("" < "abc")
    , ok "a < abc" ("a" < "abc")
    , ok "ab < abc" ("a" < "abc")
    , ok "ABC < abc" ("ABC" < "abc") ) )


------------------------------------------------------------------------
-- The Agda standard library
--
-- Quotients for Heterogeneous equality
------------------------------------------------------------------------

{-# OPTIONS --with-K --safe #-}

module Relation.Binary.HeterogeneousEquality.Quotients where

open import Function
open import Level hiding (lift)
open import Relation.Binary
open import Relation.Binary.HeterogeneousEquality
open ≅-Reasoning

record Quotient {c ℓ} (S : Setoid c ℓ) : Set (suc (c ⊔ ℓ)) where
  open Setoid S renaming (Carrier to A)
  field
    Q   : Set c
    abs : A → Q

  compat : (B : Q → Set c) (f : ∀ a → B (abs a)) → Set (c ⊔ ℓ)
  compat _ f = {a a′ : A} → a ≈ a′ → f a ≅ f a′

  field
    compat-abs : compat _ abs
    lift       : (B : Q → Set c) (f : ∀ a → B (abs a)) → compat B f → ∀ q → B q
    lift-conv  : {B : Q → Set c} (f : ∀ a → B (abs a)) (p : compat B f) →
                 ∀ a → lift B f p (abs a) ≅ f a

Quotients : ∀ c ℓ → Set (suc (c ⊔ ℓ))
Quotients c ℓ = (S : Setoid c ℓ) → Quotient S

module Properties {c ℓ} {S : Setoid c ℓ} (Qu : Quotient S) where

  open Setoid S renaming (Carrier to A) hiding (refl; sym; trans)
  open Quotient Qu

  module _ {B B′ : Q → Set c} {f : ∀ a → B (abs a)} {p : compat B f} where

   lift-unique : {g : ∀ q → B′ q} → (∀ a → g (abs a) ≅ f a) →
                 ∀ x → lift B f p x ≅ g x
   lift-unique {g} ext = lift _ liftf≅g liftf≅g-ext where

     liftf≅g : ∀ a → lift B f p (abs a) ≅ g (abs a)
     liftf≅g x = begin
       lift _ f p (abs x) ≅⟨ lift-conv f p x ⟩
       f x                ≅⟨ sym (ext x) ⟩
       g (abs x)          ∎

     liftf≅g-ext : ∀ {a a′} → a ≈ a′ → liftf≅g a ≅ liftf≅g a′
     liftf≅g-ext eq = ≅-heterogeneous-irrelevantˡ _ _
                    $ cong (lift B f p) (compat-abs eq)

   lift-ext : {g : ∀ a → B′ (abs a)} {p′ : compat B′ g} → (∀ x → f x ≅ g x) →
              ∀ x → lift B f p x ≅ lift B′ g p′ x
   lift-ext {g} {p′} h = lift-unique $ λ a → begin
       lift B′ g p′ (abs a) ≅⟨ lift-conv g p′ a ⟩
       g a                  ≅⟨ sym (h a) ⟩
       f a                  ∎

  lift-conv-abs : ∀ a → lift (const Q) abs compat-abs a ≅ a
  lift-conv-abs = lift-unique (λ _ → refl)

  lift-fold : {B : Q → Set c} (f : ∀ q → B q) →
              ∀ a → lift B (f ∘ abs) (cong f ∘ compat-abs) a ≅ f a
  lift-fold f = lift-unique (λ _ → refl)

  abs-epimorphism : {B : Q → Set c} {f g : ∀ q → B q} →
                    (∀ x → f (abs x) ≅ g (abs x)) → ∀ q → f q ≅ g q
  abs-epimorphism {B} {f} {g} p q = begin
    f q                                      ≅⟨ sym (lift-fold f q) ⟩
    lift B (f ∘ abs) (cong f ∘ compat-abs) q ≅⟨ lift-ext p q ⟩
    lift B (g ∘ abs) (cong g ∘ compat-abs) q ≅⟨ lift-fold g q ⟩
    g q                                      ∎

------------------------------------------------------------------------
-- Properties provable with extensionality

module _ (ext : ∀ {a b} {A : Set a} {B₁ B₂ : A → Set b} {f₁ : ∀ a → B₁ a}
                {f₂ : ∀ a → B₂ a} → (∀ a → f₁ a ≅ f₂ a) → f₁ ≅ f₂) where

  module Properties₂
         {c ℓ} {S₁ S₂ : Setoid c ℓ} (Qu₁ : Quotient S₁) (Qu₂ : Quotient S₂)
         where

    module S₁  = Setoid S₁
    module S₂  = Setoid S₂
    module Qu₁ = Quotient Qu₁
    module Qu₂ = Quotient Qu₂

    module _  {B : _ → _ → Set c} (f : ∀ s₁ s₂ → B (Qu₁.abs s₁) (Qu₂.abs s₂)) where

     compat₂ : Set _
     compat₂ = ∀ {a b a′ b′} → a S₁.≈ a′ → b S₂.≈ b′ → f a b ≅ f a′ b′

     lift₂ : compat₂ → ∀ q q′ → B q q′
     lift₂ p = Qu₁.lift _ g (ext ∘ g-ext) module Lift₂ where

       g : ∀ a q → B (Qu₁.abs a) q
       g a = Qu₂.lift (B (Qu₁.abs a)) (f a) (p S₁.refl)

       g-ext : ∀ {a a′} → a S₁.≈ a′ → ∀ q → g a q ≅ g a′ q
       g-ext a≈a′ = Properties.lift-ext Qu₂ (λ _ → p a≈a′ S₂.refl)

     lift₂-conv : (p : compat₂) → ∀ a a′ → lift₂ p (Qu₁.abs a) (Qu₂.abs a′) ≅ f a a′
     lift₂-conv p a a′ = begin
       lift₂ p (Qu₁.abs a) (Qu₂.abs a′)
          ≅⟨ cong (_$ (Qu₂.abs a′)) (Qu₁.lift-conv (Lift₂.g p) (ext ∘ Lift₂.g-ext p) a) ⟩
       Lift₂.g p a (Qu₂.abs a′)
          ≡⟨⟩
       Qu₂.lift (B (Qu₁.abs a)) (f a) (p S₁.refl) (Qu₂.abs a′)
          ≅⟨ Qu₂.lift-conv (f a) (p S₁.refl) a′ ⟩
       f a a′
          ∎

  module Properties₃ {c ℓ} {S₁ S₂ S₃ : Setoid c ℓ}
         (Qu₁ : Quotient S₁) (Qu₂ : Quotient S₂) (Qu₃ : Quotient S₃)
         where

    module S₁  = Setoid S₁
    module S₂  = Setoid S₂
    module S₃  = Setoid S₃
    module Qu₁ = Quotient Qu₁
    module Qu₂ = Quotient Qu₂
    module Qu₃ = Quotient Qu₃

    module _ {B : _ → _ → _ → Set c}
             (f : ∀ s₁ s₂ s₃ → B (Qu₁.abs s₁) (Qu₂.abs s₂) (Qu₃.abs s₃)) where

     compat₃ : Set _
     compat₃ = ∀ {a b c a′ b′ c′} → a S₁.≈ a′ → b S₂.≈ b′ → c S₃.≈ c′ →
               f a b c ≅ f a′ b′ c′

     lift₃ : compat₃ → ∀ q₁ q₂ q₃ → B q₁ q₂ q₃
     lift₃ p = Qu₁.lift _ h (ext ∘ h-ext) module Lift₃ where

       g : ∀ a b q → B (Qu₁.abs a) (Qu₂.abs b) q
       g a b = Qu₃.lift (B (Qu₁.abs a) (Qu₂.abs b)) (f a b) (p S₁.refl S₂.refl)

       g-ext : ∀ {a a′ b b′} → a S₁.≈ a′ → b S₂.≈ b′ → ∀ c → g a b c ≅ g a′ b′ c
       g-ext a≈a′ b≈b′ = Properties.lift-ext Qu₃ (λ _ → p a≈a′ b≈b′ S₃.refl)

       h : ∀ a q₂ q₃ → B (Qu₁.abs a) q₂ q₃
       h a = Qu₂.lift (λ b → ∀ q → B (Qu₁.abs a) b q) (g a) (ext ∘ g-ext S₁.refl)

       h-ext : ∀ {a a′} → a S₁.≈ a′ → ∀ b → h a b ≅ h a′ b
       h-ext a≈a′ = Properties.lift-ext Qu₂ $ λ _ → ext (g-ext a≈a′ S₂.refl)


module _ where

record _×_ (A B : Set) : Set where
  field
    fst : A
    snd : B

open _×_

partial : ∀ {A B} → A → A × B
partial x .fst = x

open import Agda.Builtin.Equality

theorem : ∀ {A} (x : A) → partial x .snd ≡ x
theorem x = refl


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

open import HoTT

module homotopy.WedgeOfCircles {i} where

WedgeOfCircles : (I : Type i) → Type i
WedgeOfCircles I = BigWedge {A = I} (λ _ → ⊙S¹)


open import Type

module Graph.Oper {ℓ₁ ℓ₂} {V : Type{ℓ₁}} where

open import Logic.Propositional
open import Graph{ℓ₁}{ℓ₂}(V)

_∪_ : Graph → Graph → Graph
(g₁ ∪ g₂) v₁ v₂ = g₁ v₁ v₂ ∨ g₂ v₁ v₂ -- TODO: lift1On2


------------------------------------------------------------------------
-- The Agda standard library
--
-- Universes
------------------------------------------------------------------------

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

module Data.Universe where

open import Data.Product
open import Level

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

record Universe u e : Set (suc (u ⊔ e)) where
  field
    U : Set u       -- Codes.
    El : U → Set e  -- Decoding function.


{-# OPTIONS --safe #-}
module Cubical.Algebra.Ring.DirectProd where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma
open import Cubical.Algebra.Ring.Base

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

module _
  (A'@(A , Ar) : Ring ℓ)
  (B'@(B , Br) : Ring ℓ')
  where

  open RingStr Ar using ()
    renaming
    ( 0r        to 0A
    ; 1r        to 1A
    ; _+_       to _+A_
    ; -_        to -A_
    ; _·_       to _·A_
    ; +Assoc    to +AAssoc
    ; +IdR      to +AIdR
    ; +IdL      to +AIdL
    ; +InvR     to +AInvR
    ; +InvL     to +AInvL
    ; +Comm     to +AComm
    ; ·Assoc    to ·AAssoc
    ; ·IdL      to ·AIdL
    ; ·IdR      to ·AIdR
    ; ·DistR+   to ·ADistR+
    ; ·DistL+   to ·ADistL+
    ; is-set    to isSetA     )

  open RingStr Br using ()
    renaming
    ( 0r        to 0B
    ; 1r        to 1B
    ; _+_       to _+B_
    ; -_        to -B_
    ; _·_       to _·B_
    ; +Assoc    to +BAssoc
    ; +IdR      to +BIdR
    ; +IdL      to +BIdL
    ; +InvR     to +BInvR
    ; +InvL     to +BInvL
    ; +Comm     to +BComm
    ; ·Assoc    to ·BAssoc
    ; ·IdL      to ·BIdL
    ; ·IdR      to ·BIdR
    ; ·DistR+   to ·BDistR+
    ; ·DistL+   to ·BDistL+
    ; is-set    to isSetB     )

  DirectProd-Ring : Ring (ℓ-max ℓ ℓ')
  fst DirectProd-Ring = A × B
  RingStr.0r (snd DirectProd-Ring) = 0A , 0B
  RingStr.1r (snd DirectProd-Ring) = 1A , 1B
  (snd DirectProd-Ring RingStr.+ (a , b)) (a' , b') = (a +A a') , (b +B b')
  (snd DirectProd-Ring RingStr.· (a , b)) (a' , b') = (a ·A a') , (b ·B b')
  (RingStr.- snd DirectProd-Ring) (a , b) = (-A a) , (-B b)
  RingStr.isRing (snd DirectProd-Ring) =
    makeIsRing (isSet× isSetA isSetB)
    (λ x y z i → +AAssoc (fst x) (fst y) (fst z) i , +BAssoc (snd x) (snd y) (snd z) i)
    (λ x i → (+AIdR (fst x) i) , (+BIdR (snd x) i))
    (λ x i → (+AInvR (fst x) i) , +BInvR (snd x) i)
    (λ x y i → (+AComm (fst x) (fst y) i) , (+BComm (snd x) (snd y) i))
    (λ x y z i → (·AAssoc (fst x) (fst y) (fst z) i) , (·BAssoc (snd x) (snd y) (snd z) i))
    (λ x i → (·AIdR (fst x) i) , (·BIdR (snd x) i))
    (λ x i → (·AIdL (fst x) i) , (·BIdL (snd x) i))
    (λ x y z i → (·ADistR+ (fst x) (fst y) (fst z) i) , (·BDistR+ (snd x) (snd y) (snd z) i))
    (λ x y z i → (·ADistL+ (fst x) (fst y) (fst z) i) , (·BDistL+ (snd x) (snd y) (snd z) i))

module Coproduct-Equiv
  {Xr@(X , Xstr) : Ring ℓ}
  {Yr@(Y , Ystr) : Ring ℓ'}
  {X'r@(X' , X'str) : Ring ℓ''}
  {Y'r@(Y' , Y'str) : Ring ℓ'''}
  where

  open Iso
  open IsRingHom
  open RingStr

  _+X×X'_ : X × X' → X × X' → X × X'
  _+X×X'_ = _+_ (snd (DirectProd-Ring Xr X'r))

  _+Y×Y'_ : Y × Y' → Y × Y' → Y × Y'
  _+Y×Y'_ = _+_ (snd (DirectProd-Ring Yr Y'r))

  _·X×X'_ : X × X' → X × X' → X × X'
  _·X×X'_ = _·_ (snd (DirectProd-Ring Xr X'r))

  _·Y×Y'_ : Y × Y' → Y × Y' → Y × Y'
  _·Y×Y'_ = _·_ (snd (DirectProd-Ring Yr Y'r))

  re×re' : (re : RingEquiv Xr Yr) → (re' : RingEquiv X'r Y'r) → (X × X') ≃ (Y × Y')
  re×re' re re' = ≃-× (fst re) (fst re')

  Coproduct-Equiv-12 : (re : RingEquiv Xr Yr) → (re' : RingEquiv X'r Y'r) →
                        RingEquiv (DirectProd-Ring Xr X'r) (DirectProd-Ring Yr Y'r)
  fst (Coproduct-Equiv-12 re re') = re×re' re re'
  snd (Coproduct-Equiv-12 re re') = makeIsRingHom fun-pres1 fun-pres+ fun-pres·
    where
    fun-pres1 : (fst (re×re' re re')) (1r Xstr , 1r X'str) ≡ (1r (Yr .snd) , 1r (Y'r .snd))
    fun-pres1 = ≡-× (pres1 (snd re)) (pres1 (snd re'))

    fun-pres+ : (x1 x2 : X × X') → (fst (re×re' re re')) (x1 +X×X' x2) ≡ (( (fst (re×re' re re')) x1) +Y×Y' ( (fst (re×re' re re')) x2))
    fun-pres+ (x1 , x'1) (x2 , x'2) = ≡-× (pres+ (snd re) x1 x2) (pres+ (snd re') x'1 x'2)

    fun-pres· : (x1 x2 : X × X') → (fst (re×re' re re')) (x1 ·X×X' x2) ≡ (( (fst (re×re' re re')) x1) ·Y×Y' ( (fst (re×re' re re')) x2))
    fun-pres· (x1 , x'1) (x2 , x'2) = ≡-× (pres· (snd re) x1 x2) (pres· (snd re') x'1 x'2)


module Irrelevant where

open import Common.IO
open import Common.Nat
open import Common.Unit

A : Set
A = Nat

record R : Set where
  id : A → A
  id x = x

postulate r : R

id2 : .A → A → A
id2 x y = y

open R

main : IO Unit
main = printNat (id2 10 20) ,,
  printNat (id r 30) ,,
  return unit


module Tactic.Monoid where

open import Prelude
open import Tactic.Reflection
open import Tactic.Reflection.Quote

open import Tactic.Monoid.Exp
open import Tactic.Monoid.Reflect
open import Tactic.Monoid.Proofs

monoidTactic : ∀ {a} {A : Set a} {{_ : Monoid/Laws A}} → Tactic
monoidTactic {A = A} {{laws}} hole = do
  goal   ← inferNormalisedType hole
  `A     ← quoteTC A
  unify goal (def (quote _≡_) (hArg unknown ∷ hArg `A ∷ vArg unknown ∷ vArg unknown ∷ []))
    <|> do typeErrorFmt "Goal is not an equality: %t" goal
  goal   ← normalise goal
  ensureNoMetas goal
  match  ← monoidMatcher (Monoid/Laws.super laws)
  `dict  ← quoteTC (Monoid/Laws.super laws)
  `laws  ← quoteTC laws
  ensureNoMetas `dict
  debugPrintFmt "tactic.monoid" 20 "monoidTactic %t, dict = %t" goal `dict
  (lhs , rhs) , env ← parseGoal match goal
  unify hole (def (quote proof) (iArg `dict ∷ iArg `laws ∷ vArg (` lhs) ∷ vArg (` rhs) ∷
                                 vArg (quoteEnv `dict env) ∷ vArg (con (quote refl) []) ∷ []))
    <|> do typeErrorFmt "Can't prove %t == %t because %t /= %t"
                        (` lhs) (` rhs) (` (flatten lhs)) (` (flatten rhs))

macro
  auto-monoid : ∀ {a} {A : Set a} {{Laws : Monoid/Laws A}} → Tactic
  auto-monoid {{Laws}} = monoidTactic {{Laws}}


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.KleinBottle where

open import Cubical.HITs.KleinBottle.Base public
open import Cubical.HITs.KleinBottle.Properties public


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

-- Backwards evaluator and the fact that with eval, forms a reversible evaluator

module BackwardsEval where

open import Data.Unit using (tt)
open import Data.Sum using (inj₁; inj₂)
open import Data.Product using (_,_; proj₁; proj₂)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; cong₂; subst)

open import Singleton
open import PiFrac

bwd : {A B : 𝕌} → (A ⟷ B) → ⟦ B ⟧ → ⟦ A ⟧
bwd-eval : {A B : 𝕌} → (c : A ⟷ B) → (v : ⟦ A ⟧) → bwd c (eval c v) ≡ v

bwd unite₊l v = inj₂ v
bwd uniti₊l (inj₂ v) = v
bwd unite₊r v = inj₁ v
bwd uniti₊r (inj₁ v) = v
bwd swap₊ (inj₁ v) = inj₂ v
bwd swap₊ (inj₂ v) = inj₁ v
bwd assocl₊ (inj₁ (inj₁ v)) = inj₁ v
bwd assocl₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v)
bwd assocl₊ (inj₂ v) = inj₂ (inj₂ v)
bwd assocr₊ (inj₁ v) = inj₁ (inj₁ v)
bwd assocr₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v)
bwd assocr₊ (inj₂ (inj₂ v)) = inj₂ v
bwd unite⋆l v = (tt , v)
bwd uniti⋆l (tt , v) = v
bwd unite⋆r v = (v , tt)
bwd uniti⋆r (v , tt) = v
bwd swap⋆ (v₁ , v₂) = (v₂ , v₁)
bwd assocl⋆ ((v₁ , v₂) , v₃) = (v₁ , (v₂ , v₃))
bwd assocr⋆ (v₁ , (v₂ , v₃)) = ((v₁ , v₂) , v₃)
bwd dist (inj₁ (v₁ , v₂)) = (inj₁ v₁ , v₂)
bwd dist (inj₂ (v₂ , v₃)) = (inj₂ v₂ , v₃)
bwd factor (inj₁ v₁ , v₃) = inj₁ (v₁ , v₃)
bwd factor (inj₂ v₂ , v₃) = inj₂ (v₂ , v₃)
bwd distl (inj₁ (v₁ , v₂)) = (v₁ , inj₁ v₂)
bwd distl (inj₂ (v₁ , v₃)) = (v₁ , inj₂ v₃)
bwd factorl (v₁ , inj₁ v₂) = inj₁ (v₁ , v₂)
bwd factorl (v₁ , inj₂ v₃) = inj₂ (v₁ , v₃)
bwd id⟷ v = v
bwd (c₁ ⊚ c₂) v = bwd c₁ (bwd c₂ v)
bwd (c₁ ⊕ c₂) (inj₁ v) = inj₁ (bwd c₁ v)
bwd (c₁ ⊕ c₂) (inj₂ v) = inj₂ (bwd c₂ v)
bwd (c₁ ⊗ c₂) (v₁ , v₂) = (bwd c₁ v₁ , bwd c₂ v₂)
bwd (lift {_} {_} {v₁} c) (●₁ , v≡●₁) = (bwd c ●₁) , (trans (sym (bwd-eval c v₁)) (cong (bwd c) v≡●₁))
bwd tensorl ((w₁ , p₁) , (w₂ , p₂)) = (w₁ ,  w₂) , (cong₂ _,_ p₁ p₂)
bwd tensorr ((v₁ , v₂) , p) = (v₁ , cong proj₁ p) , (v₂ , cong proj₂ p)
bwd plusll (w , p) = (inj₁ w) , (cong inj₁ p)
bwd pluslr (inj₁ w₁ , refl) = w₁ , refl
bwd plusrl (w , p) = (inj₂ w) , (cong inj₂ p)
bwd plusrr (inj₂ w₂ , refl) = w₂ , refl
bwd fracl (f₁ , f₂) ((w₁ , w₂) , refl) = let _ = f₁ (w₁ , refl) ; _ = f₂ (w₂ , refl) in tt
bwd (fracr {v₁ = v₁} {v₂ = v₂}) f = (λ _ → f ((v₁ , v₂) , refl)) , (λ _ → f ((v₁ , v₂) , refl))
bwd (η v) p = tt
bwd (ε v) tt = (v , refl) , λ _ → tt
bwd (ll {t} {v} {w}) (v , refl) = w , refl
bwd (== c eq) v = bwd c (subst (Singleton ⟦ _ ⟧) (sym eq) v)

bwd-eval unite₊l (inj₂ v) = refl
bwd-eval uniti₊l v = refl
bwd-eval unite₊r (inj₁ v) = refl
bwd-eval uniti₊r v = refl
bwd-eval swap₊ (inj₁ v) = refl
bwd-eval swap₊ (inj₂ v) = refl
bwd-eval assocl₊ (inj₁ v) = refl
bwd-eval assocl₊ (inj₂ (inj₁ v)) = refl
bwd-eval assocl₊ (inj₂ (inj₂ v)) = refl
bwd-eval assocr₊ (inj₁ (inj₁ v)) = refl
bwd-eval assocr₊ (inj₁ (inj₂ v)) = refl
bwd-eval assocr₊ (inj₂ v) = refl
bwd-eval unite⋆l (tt , v) = refl
bwd-eval uniti⋆l v = refl
bwd-eval unite⋆r (v , tt) = refl
bwd-eval uniti⋆r v = refl
bwd-eval swap⋆ (v₁ , v₂) = refl
bwd-eval assocl⋆ (v₁ , (v₂ , v₃)) = refl
bwd-eval assocr⋆ ((v₁ , v₂) , v₃) = refl
bwd-eval dist (inj₁ v₁ , v₃) = refl
bwd-eval dist (inj₂ v₂ , v₃) = refl
bwd-eval factor (inj₁ (v₁ , v₃)) = refl
bwd-eval factor (inj₂ (v₂ , v₃)) = refl
bwd-eval distl (v₁ , inj₁ v₂) = refl
bwd-eval distl (v₁ , inj₂ v₃) = refl
bwd-eval factorl (inj₁ (v₁ , v₂)) = refl
bwd-eval factorl (inj₂ (v₁ , v₃)) = refl
bwd-eval id⟷ v = refl
bwd-eval (c₁ ⊚ c₂) v = trans (cong (bwd c₁) (bwd-eval c₂ (eval c₁ v))) (bwd-eval c₁ v)
bwd-eval (c₁ ⊕ c₂) (inj₁ v₁) = cong inj₁ (bwd-eval c₁ v₁)
bwd-eval (c₁ ⊕ c₂) (inj₂ v₂) = cong inj₂ (bwd-eval c₂ v₂)
bwd-eval (c₁ ⊗ c₂) (v₁ , v₂) = cong₂ _,_ (bwd-eval c₁ v₁) (bwd-eval c₂ v₂)
bwd-eval (lift c) v = pointed-all-paths
bwd-eval tensorl p = pointed-all-paths
bwd-eval tensorr (p₁ , p₂) = cong₂ _,_ pointed-all-paths pointed-all-paths
bwd-eval plusll p = pointed-all-paths
bwd-eval pluslr p = pointed-all-paths
bwd-eval plusrl p = pointed-all-paths
bwd-eval plusrr p = pointed-all-paths
bwd-eval fracl f = {!!}  -- needs recip-all-paths
bwd-eval fracr (f₁ , f₂) = {!!}
bwd-eval (η v) tt = refl
bwd-eval (ε v) (p , r) = cong₂ _,_ pointed-all-paths refl
bwd-eval (ll {t} {v} {.w}) (w , refl) = refl
bwd-eval (== c eq) p = pointed-all-paths

eval-bwd : {A B : 𝕌} → (c : A ⟷ B) → (v : ⟦ B ⟧) → eval c (bwd c v) ≡ v
eval-bwd unite₊l v = refl
eval-bwd uniti₊l (inj₂ v) = refl
eval-bwd unite₊r v = refl
eval-bwd uniti₊r (inj₁ v) = refl
eval-bwd swap₊ (inj₁ v) = refl
eval-bwd swap₊ (inj₂ v) = refl
eval-bwd assocl₊ (inj₁ (inj₁ v)) = refl
eval-bwd assocl₊ (inj₁ (inj₂ v)) = refl
eval-bwd assocl₊ (inj₂ v) = refl
eval-bwd assocr₊ (inj₁ v) = refl
eval-bwd assocr₊ (inj₂ (inj₁ v)) = refl
eval-bwd assocr₊ (inj₂ (inj₂ v)) = refl
eval-bwd unite⋆l v = refl
eval-bwd uniti⋆l (tt , v) = refl
eval-bwd unite⋆r v = refl
eval-bwd uniti⋆r (v , tt) = refl
eval-bwd swap⋆ (v₂ , v₁) = refl
eval-bwd assocl⋆ ((v₁ , v₂) , v₃) = refl
eval-bwd assocr⋆ (v₁ , (v₂ , v₃)) = refl
eval-bwd dist (inj₁ (v₁ , v₂)) = refl
eval-bwd dist (inj₂ (v₂ , v₃)) = refl
eval-bwd factor (inj₁ v₁ , v₃) = refl
eval-bwd factor (inj₂ v₂ , v₃) = refl
eval-bwd distl (inj₁ (v₁ , v₂)) = refl
eval-bwd distl (inj₂ (v₁ , v₃)) = refl
eval-bwd factorl (v₁ , inj₁ v₂) = refl
eval-bwd factorl (v₁ , inj₂ v₃) = refl
eval-bwd id⟷ v = refl
eval-bwd (c₁ ⊚ c₂) v = trans (cong (eval c₂) (eval-bwd c₁ (bwd c₂ v))) (eval-bwd c₂ v)
eval-bwd (c₁ ⊕ c₂) (inj₁ v) = cong inj₁ (eval-bwd c₁ v)
eval-bwd (c₁ ⊕ c₂) (inj₂ v) = cong inj₂ (eval-bwd c₂ v)
eval-bwd (c₁ ⊗ c₂) (v₃ , v₄) = cong₂ _,_ (eval-bwd c₁ v₃) (eval-bwd c₂ v₄)
eval-bwd (lift c) x = pointed-all-paths
eval-bwd tensorl p = cong₂ _,_ pointed-all-paths pointed-all-paths
eval-bwd tensorr p = pointed-all-paths
eval-bwd plusll p = pointed-all-paths
eval-bwd pluslr p = pointed-all-paths
eval-bwd plusrl p = pointed-all-paths
eval-bwd plusrr p = pointed-all-paths
eval-bwd fracl (f₁ , f₂) = {!!} -- needs recip-all-paths
eval-bwd fracr f = {!!}
eval-bwd (η v) (p , r) = cong₂ _,_ pointed-all-paths refl
eval-bwd (ε v) tt = refl
eval-bwd (ll {t} {.v} {w}) (v , refl) = refl
eval-bwd (== c eq) p = pointed-all-paths


module objectsInAgda where

open import Data.Product
open import interactiveProgramsAgda hiding (main)
open import NativeIO
open import Data.String.Base

record Interface  :  Set₁ where
  field  Method   :  Set
         Result   :  (m : Method) → Set

open Interface public

record Object (I : Interface) : Set where
  coinductive
  field objectMethod : (m : Method I) → Result I m × Object I

open Object public
open import Size

record IOObject (Iᵢₒ : IOInterface) (I : Interface) (i : Size) : Set where
  coinductive
  field method : ∀{j : Size< i} (m : Method I)
                   → IO Iᵢₒ ∞ (Result I m × IOObject Iᵢₒ I j)

open IOObject public

{- Example Cell -}

data CellMethod A : Set where
    get  :  CellMethod A
    put  :  A → CellMethod A

CellResult             :  ∀{A} → CellMethod A → Set
CellResult   {A} get   =  A
CellResult   (put _)   =  Unit

cellI                  :  (A : Set) → Interface
Method    (cellI A)    =  CellMethod A
Result    (cellI A) m  =  CellResult m

{- A cell as an Object -}

Cell : Set → Set
Cell A = Object (cellI A)

cell : {A : Set} → A → Cell A
objectMethod (cell a) get       = a    , cell a
objectMethod (cell a) (put a')  = unit , cell a'

{- A cell as an IOObject -}

CellC : (i : Size) → Set
CellC = IOObject ConsoleInterface (cellI String)

simpleCell : ∀{i} (s : String) → CellC i
force (method (simpleCell s)  get) =
  do' (putStrLn ("getting (" ++ s ++ ")")) λ _ →
  return (s , simpleCell s)
force (method (simpleCell _) (put s)) =
  do' (putStrLn ("putting (" ++ s ++ ")")) λ _ →
  return (_ , simpleCell s)

program : ∀{i} → CellC ∞  → IO ConsoleInterface i Unit
force (program c) =
  do' getLine          λ s →
  method c (put s)    >>= λ{ (_ , c) →
  method c get        >>= λ{ (s' , c) →
  do (putStrLn s')     λ _ →
  program c }}

main : NativeIO Unit
main = translateIOConsole (program (simpleCell "Start"))


{-# OPTIONS --safe #-}
module Cubical.Categories.Limits.Pullback where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.HITs.PropositionalTruncation.Base

open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.Instances.Cospan
open import Cubical.Categories.Limits.Limits

private
  variable
    ℓ ℓ' : Level

module _ (C : Category ℓ ℓ') where

  open Category C
  open Functor

  record Cospan : Type (ℓ-max ℓ ℓ') where
    constructor cospan
    field
      l m r : ob
      s₁ : C [ l , m ]
      s₂ : C [ r , m ]

  open Cospan

  isPullback : (cspn : Cospan) →
    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → Type (ℓ-max ℓ ℓ')
  isPullback cspn {c} p₁ p₂ H =
    ∀ {d} (h : C [ d , cspn .l ]) (k : C [ d , cspn .r ])
          (H' : h ⋆ cspn .s₁ ≡ k ⋆ cspn .s₂)
    → ∃![ hk ∈ C [ d , c ] ] (h ≡ hk ⋆ p₁) × (k ≡ hk ⋆ p₂)

  isPropIsPullback : (cspn : Cospan) →
    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → isProp (isPullback cspn p₁ p₂ H)
  isPropIsPullback cspn p₁ p₂ H =
    isPropImplicitΠ (λ x → isPropΠ3 λ h k H' → isPropIsContr)

  record Pullback (cspn : Cospan) : Type (ℓ-max ℓ ℓ') where
    field
      pbOb  : ob
      pbPr₁ : C [ pbOb , cspn .l ]
      pbPr₂ : C [ pbOb , cspn .r ]
      pbCommutes : pbPr₁ ⋆ cspn .s₁ ≡ pbPr₂ ⋆ cspn .s₂
      univProp : isPullback cspn pbPr₁ pbPr₂ pbCommutes

  open Pullback

  pullbackArrow :
    {cspn : Cospan} (pb : Pullback cspn)
    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) → C [ c , pb . pbOb ]
  pullbackArrow pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .fst

  pullbackArrowPr₁ :
    {cspn : Cospan} (pb : Pullback cspn)
    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) →
    p₁ ≡ pullbackArrow pb p₁ p₂ H ⋆ pbPr₁ pb
  pullbackArrowPr₁ pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .snd .fst

  pullbackArrowPr₂ :
    {cspn : Cospan} (pb : Pullback cspn)
    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂) →
    p₂ ≡ pullbackArrow pb p₁ p₂ H ⋆ pbPr₂ pb
  pullbackArrowPr₂ pb p₁ p₂ H = pb .univProp p₁ p₂ H .fst .snd .snd

  pullbackArrowUnique :
    {cspn : Cospan} (pb : Pullback cspn)
    {c : ob} (p₁ : C [ c , cspn .l ]) (p₂ : C [ c , cspn .r ])
    (H : p₁ ⋆ cspn .s₁ ≡ p₂ ⋆ cspn .s₂)
    (pbArrow' : C [ c , pb .pbOb ])
    (H₁ : p₁ ≡ pbArrow' ⋆ pbPr₁ pb) (H₂ : p₂ ≡ pbArrow' ⋆ pbPr₂ pb)
    → pullbackArrow pb p₁ p₂ H ≡ pbArrow'
  pullbackArrowUnique pb p₁ p₂ H pbArrow' H₁ H₂ =
    cong fst (pb .univProp p₁ p₂ H .snd (pbArrow' , (H₁ , H₂)))

  Pullbacks : Type (ℓ-max ℓ ℓ')
  Pullbacks = (cspn : Cospan) → Pullback cspn

  hasPullbacks : Type (ℓ-max ℓ ℓ')
  hasPullbacks = ∥ Pullbacks ∥₁

-- Pullbacks from limits
module _ {C : Category ℓ ℓ'} where
  open Category C
  open Functor
  open Pullback
  open LimCone
  open Cone
  open Cospan

  Cospan→Func : Cospan C → Functor CospanCat C
  Cospan→Func (cospan l m r f g) .F-ob ⓪ = l
  Cospan→Func (cospan l m r f g) .F-ob ① = m
  Cospan→Func (cospan l m r f g) .F-ob ② = r
  Cospan→Func (cospan l m r f g) .F-hom {⓪} {①} k = f
  Cospan→Func (cospan l m r f g) .F-hom {②} {①} k = g
  Cospan→Func (cospan l m r f g) .F-hom {⓪} {⓪} k = id
  Cospan→Func (cospan l m r f g) .F-hom {①} {①} k = id
  Cospan→Func (cospan l m r f g) .F-hom {②} {②} k = id
  Cospan→Func (cospan l m r f g) .F-id {⓪} = refl
  Cospan→Func (cospan l m r f g) .F-id {①} = refl
  Cospan→Func (cospan l m r f g) .F-id {②} = refl
  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {⓪} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {⓪} {⓪} {①} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {⓪} {①} {①} φ ψ = sym (⋆IdR _)
  Cospan→Func (cospan l m r f g) .F-seq {①} {①} {①} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {②} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {②} {②} {①} φ ψ = sym (⋆IdL _)
  Cospan→Func (cospan l m r f g) .F-seq {②} {①} {①} φ ψ = sym (⋆IdR _)

  LimitsOfShapeCospanCat→Pullbacks : LimitsOfShape CospanCat C → Pullbacks C
  pbOb (LimitsOfShapeCospanCat→Pullbacks H cspn) = lim (H (Cospan→Func cspn))
  pbPr₁ (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOut (H (Cospan→Func cspn)) ⓪
  pbPr₂ (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOut (H (Cospan→Func cspn)) ②
  pbCommutes (LimitsOfShapeCospanCat→Pullbacks H cspn) = limOutCommutes (H (Cospan→Func cspn)) {v = ①} tt
                          ∙ sym (limOutCommutes (H (Cospan→Func cspn)) tt)
  univProp (LimitsOfShapeCospanCat→Pullbacks H cspn) {d = d} h k H' =
    uniqueExists (limArrow (H (Cospan→Func cspn)) d cc)
                 ( sym (limArrowCommutes (H (Cospan→Func cspn)) d cc ⓪)
                 , sym (limArrowCommutes (H (Cospan→Func cspn)) d cc ②))
                 (λ _ → isProp× (isSetHom _ _) (isSetHom _ _))
                 λ a' ha' → limArrowUnique (H (Cospan→Func cspn)) d cc a'
                               (λ { ⓪ → sym (ha' .fst)
                                  ; ① → cong (a' ⋆_) (sym (limOutCommutes (H (Cospan→Func cspn)) {⓪} {①} tt))
                                      ∙∙ sym (⋆Assoc _ _ _)
                                      ∙∙ cong (_⋆ cspn .s₁) (sym (ha' .fst))
                                  ; ② → sym (ha' .snd) })
    where
    cc : Cone (Cospan→Func cspn) d
    coneOut cc ⓪ = h
    coneOut cc ① = h ⋆ cspn .s₁
    coneOut cc ② = k
    coneOutCommutes cc {⓪} {⓪} e = ⋆IdR h
    coneOutCommutes cc {⓪} {①} e = refl
    coneOutCommutes cc {①} {①} e = ⋆IdR _
    coneOutCommutes cc {②} {①} e = sym H'
    coneOutCommutes cc {②} {②} e = ⋆IdR k

  Limits→Pullbacks : Limits C → Pullbacks C
  Limits→Pullbacks H = LimitsOfShapeCospanCat→Pullbacks (H CospanCat)


module Pi.Everything where
open import Pi.Syntax     -- Syntax of Pi
open import Pi.Opsem      -- Abstract machine semantics of Pi
open import Pi.AuxLemmas  -- Some auxiliary lemmas about opsem for forward/backward deterministic proof
open import Pi.NoRepeat   -- Forward/backward deterministic lemmas and Non-repeating lemma
open import Pi.Eval       -- Evaluator for Pi
open import Pi.Interp     -- Big-step intepreter of Pi
open import Pi.Invariants -- Some invariants about abstract machine semantics
open import Pi.Properties -- Properties of Pi
open import Pi.Examples   -- Examples
open import Pi.Category   -- Pi Category


-- Andreas, 2016-10-11, AIM XXIV, issue #2250

{-# OPTIONS --injective-type-constructors #-}

open import Common.Prelude
open import Common.Equality

abstract
  f : Bool → Bool
  f x = true

  same : f true ≡ f false
  same = refl

-- f should not be treated as injective here,
-- even though f true and f false do not reduce.

not-same : f true ≡ f false → ⊥
not-same () -- should be yellow

absurd : ⊥
absurd = not-same same


------------------------------------------------------------------------
-- The Agda standard library
--
-- Concepts from rewriting theory
-- Definitions are based on "Term Rewriting Systems" by J.W. Klop
------------------------------------------------------------------------

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

module Relation.Binary.Rewriting where

open import Agda.Builtin.Equality using (_≡_ ; refl)
open import Data.Product using (_×_ ; ∃ ; -,_; _,_ ; proj₁ ; proj₂)
open import Data.Empty
open import Data.Sum.Base as Sum using (_⊎_)
open import Function using (flip)
open import Induction.WellFounded
open import Level
open import Relation.Binary.Core
open import Relation.Binary.Construct.Closure.Equivalence using (EqClosure)
open import Relation.Binary.Construct.Closure.Equivalence.Properties
open import Relation.Binary.Construct.Closure.Reflexive
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Relation.Binary.Construct.Closure.Symmetric
open import Relation.Binary.Construct.Closure.Transitive
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

-- The following definitions are taken from Klop [5]
module _ {a ℓ} {A : Set a} (_⟶_ : Rel A ℓ) where

  private
    _⟵_  = flip _⟶_
    _—↠_ = Star _⟶_
    _↔_  = EqClosure _⟶_

  IsNormalForm : A → Set _
  IsNormalForm a = ¬ ∃ λ b → (a ⟶ b)

  HasNormalForm : A → Set _
  HasNormalForm b = ∃ λ a → IsNormalForm a × (b —↠ a)

  NormalForm : Set _
  NormalForm = ∀ {a b} → IsNormalForm a → b ↔ a → b —↠ a

  WeaklyNormalizing : Set _
  WeaklyNormalizing = ∀ a → HasNormalForm a

  StronglyNormalizing : Set _
  StronglyNormalizing = WellFounded _⟵_

  UniqueNormalForm : Set _
  UniqueNormalForm = ∀ {a b} → IsNormalForm a → IsNormalForm b → a ↔ b → a ≡ b

  Confluent : Set _
  Confluent = ∀ {A B C} → A —↠ B → A —↠ C → ∃ λ D → (B —↠ D) × (C —↠ D)

  WeaklyConfluent : Set _
  WeaklyConfluent = ∀ {A B C} → A ⟶ B → A ⟶ C → ∃ λ D → (B —↠ D) × (C —↠ D)

Deterministic : ∀ {a b ℓ₁ ℓ₂} → {A : Set a} → {B : Set b} → Rel B ℓ₁ → REL A B ℓ₂ → Set _
Deterministic _≈_ _—→_ = ∀ {x y z} → x —→ y → x —→ z → y ≈ z

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

  private
    _—↠_ = Star _⟶_
    _↔_  = EqClosure _⟶_
    _⟶₊_ = Plus _⟶_

  det⇒conf : Deterministic _≡_ _⟶_ → Confluent _⟶_
  det⇒conf det ε          rs₂        = -, rs₂ , ε
  det⇒conf det rs₁        ε          = -, ε , rs₁
  det⇒conf det (r₁ ◅ rs₁) (r₂ ◅ rs₂)
    rewrite det r₁ r₂ = det⇒conf det rs₁ rs₂

  conf⇒wcr : Confluent _⟶_ → WeaklyConfluent _⟶_
  conf⇒wcr c fst snd = c (fst ◅ ε) (snd ◅ ε)

  conf⇒nf : Confluent _⟶_ → NormalForm _⟶_
  conf⇒nf c aIsNF ε = ε
  conf⇒nf c aIsNF (fwd x ◅ rest) = x ◅ conf⇒nf c aIsNF rest
  conf⇒nf c aIsNF (bwd y ◅ rest) with c (y ◅ ε) (conf⇒nf c aIsNF rest)
  ... | _ , _    , x ◅ _ = ⊥-elim (aIsNF (_ , x))
  ... | _ , left , ε     = left

  conf⇒unf : Confluent _⟶_ → UniqueNormalForm _⟶_
  conf⇒unf _ _     _     ε           = refl
  conf⇒unf _ aIsNF _     (fwd x ◅ _) = ⊥-elim (aIsNF (_ , x))
  conf⇒unf c aIsNF bIsNF (bwd y ◅ r) with c (y ◅ ε) (conf⇒nf c bIsNF r)
  ... | _ , ε     , x ◅ _ = ⊥-elim (bIsNF (_ , x))
  ... | _ , x ◅ _ , _     = ⊥-elim (aIsNF (_ , x))
  ... | _ , ε     , ε     = refl

  un&wn⇒cr : UniqueNormalForm _⟶_ → WeaklyNormalizing _⟶_ → Confluent _⟶_
  un&wn⇒cr un wn {a} {b} {c} aToB aToC with wn b | wn c
  ... | (d , (d-nf , bToD)) | (e , (e-nf , cToE))
    with un d-nf e-nf (a—↠b&a—↠c⇒b↔c (aToB ◅◅ bToD) (aToC ◅◅ cToE))
  ... | refl = d , bToD , cToE

-- Newman's lemma
  sn&wcr⇒cr : StronglyNormalizing _⟶₊_ → WeaklyConfluent _⟶_ → Confluent _⟶_
  sn&wcr⇒cr sn wcr = helper (sn _) where

    starToPlus : ∀ {a b c} → (a ⟶ b) → b —↠ c → a ⟶₊ c
    starToPlus aToB ε = [ aToB ]
    starToPlus {a} aToB (e ◅ bToC) = a ∼⁺⟨ [ aToB ] ⟩ (starToPlus e bToC)

    helper : ∀ {a b c} → (acc : Acc (flip _⟶₊_) a) →
             a —↠ b → a —↠ c → ∃ λ d → (b —↠ d) × (c —↠ d)
    helper _       ε           snd         = -, snd , ε
    helper _       fst         ε           = -, ε   , fst
    helper (acc g) (toJ ◅ fst) (toK ◅ snd) = result where

        wcrProof = wcr toJ toK
        innerPoint = proj₁ wcrProof
        jToInner = proj₁ (proj₂ wcrProof)
        kToInner = proj₂ (proj₂ wcrProof)

        lhs = helper (g _ [ toJ ]) fst jToInner
        rhs = helper (g _ [ toK ]) snd kToInner

        fromAB = proj₁ (proj₂ lhs)
        fromInnerB = proj₂ (proj₂ lhs)

        fromAC = proj₁ (proj₂ rhs)
        fromInnerC = proj₂ (proj₂ rhs)

        aToInner : _ ⟶₊ innerPoint
        aToInner = starToPlus toJ jToInner

        finalRecursion = helper (g innerPoint aToInner) fromInnerB fromInnerC

        bMidToDest = proj₁ (proj₂ finalRecursion)
        cMidToDest = proj₂ (proj₂ finalRecursion)

        result : ∃ λ d → (_ —↠ d) × (_ —↠ d)
        result = _ , fromAB ◅◅ bMidToDest , fromAC ◅◅ cMidToDest


-- Andreas, 2016-12-12, issue #2046, reported by Nad
-- Parameter refinement broke the size solver.

-- {-# OPTIONS -v tc.size.solve:100 #-}
-- {-# OPTIONS -v tc.constr.cast:100 #-}
-- -- {-# OPTIONS -v tc.sig.param:60 #-}
-- -- {-# OPTIONS -v tc.check.internal:100 #-}
-- -- {-# OPTIONS -v interaction.give:100 #-}

open import Agda.Builtin.Size using (Size; Size<_)

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

record Always {A : Set} (P : A → Set) : Set where
  field
    always : ∀ x → P x

postulate
  A : Set

module M (P : A → Set) where

  record R₁ (i : Size) (x : A) : Set where
    coinductive
    field
      force : {j : Size< i} → R₁ j x

  record R₂ (i : Size) (x : A) : Set where
    inductive
    constructor ⟨_,_⟩
    field
      f₁ : P x
      f₂ : P x → R₁ i x

data P : A → Set where
  c : (y : A) → P y → P y

postulate
  p : (x : A) → P x
  a : (i : Size) → Always (M.R₁ P i)

module _ (Unused : Set) where

  open M P

  rejected : ∀ i z → R₂ i z
  rejected i z =
    ⟨ p z
    , (λ { (c y q) →  Always.always (a _) z   })
    ⟩

-- Should succeed

{-
Solving constraints (DontDefaultToInfty)
i =< _i_31 Unused i z : Size
_i_31 Unused i z =< _i_35 z Unused i q : Size
converting size constraint i =< _i_31 Unused i z : Size
converting size constraint
_i_31 Unused i z =< _i_35 z Unused i q : Size
Solving constraint cluster
[Unused, i, z] i ≤ _i_31 Unused i z
[z, Unused, i, q] _i_31 Unused i z ≤ _i_35 z Unused i q
Size hypotheses
Canonicalized constraints
[z, Unused, i, q] Unused ≤ _i_31 z Unused i
[z, Unused, i, q] _i_31 Unused i z ≤ _i_35 z Unused i q
solution  _i_31 z Unused i  :=  Unused
  xs = [3,2,1]
  u  = Var 2 []
solution  _i_35 z Unused i q  :=  Unused
  xs = [3,2,1,0]
  u  = Var 2 []
-}


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

module VecHelpers where

open import Data.Nat
import Data.Fin as F

open import Data.Vec
open import Function renaming (_∘_ to _○_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

infixl 10 _∘̬_     -- vector composition

------------------------------------------------------------------
-- VECTOR LEMMAS AND HELPERS

vmap : {n : ℕ} → {A B : Set} → (A → B) → Vec A n → Vec B n
vmap f [] = []
vmap f (x ∷ xs) = (f x) ∷ (vmap f xs)

-- Syntactic sugar for lookup that's a lot nicer
_!!_ : {A : Set} → {n : ℕ} → Vec A n → F.Fin n → A
_!!_ v i = lookup i v

-- XXX: is this in the right order?
_∘̬_ : {m n : ℕ} {A : Set} → Vec (F.Fin n) m → Vec A n → Vec A m
v₁ ∘̬ v₂ = tabulate (λ i → v₂ !! (v₁ !! i))

_∘̬′_ : {m n : ℕ} {A : Set} → Vec (F.Fin n) m → Vec A n → Vec A m
[] ∘̬′ v₂ = []
(i ∷ is) ∘̬′  v₂ = (v₂ !! i) ∷ (is ∘̬′ v₂)

∘̬≡∘̬′ : {m n : ℕ} {A : Set} (v₁ : Vec (F.Fin n) m) (v₂ : Vec A n) →
       (v₁ ∘̬ v₂) ≡ (v₁ ∘̬′ v₂)
∘̬≡∘̬′ [] v₂ = refl
∘̬≡∘̬′ (x ∷ v₁) v₂ = cong (_∷_ (v₂ !! x)) (∘̬≡∘̬′ v₁ v₂)

ntimes : {A : Set} → ℕ → (f : A → A) → A → A
ntimes zero f a = a
ntimes (suc n) f a = f (ntimes n f a)

ntimesD : {A : Set} → {B : A → Set} → {g : A → A} → (n : ℕ) →
          (f : {a : A} → B a → B (g a)) →
          {a : A} →
          B a → B (ntimes n g a)
ntimesD zero f b = b
ntimesD {g = g} (suc n) f {a = a} b =
  f {ntimes n g a} (ntimesD {g = g} n (λ {a} → f {a}) {a = a} b)

ntails : {A : Set} → {n k : ℕ} → Vec A (ntimes k suc n) → Vec A n
ntails {k = zero} v = v
ntails {k = suc n} (x ∷ xs) = ntails {k = n} xs

ntails₀ : {A : Set} → {k : ℕ} → (v : Vec A (ntimes k suc zero)) →
          [] ≡ ntails {k = k} v
ntails₀ {k = zero} [] = refl
ntails₀ {k = suc k} (x ∷ v) = ntails₀ {k = k} v

-- Important lemma about lookup; for some reason it doesn't seem to be in the
-- library even though it's in the main agda tutorial, iirc
map!! : {n : ℕ} → {A B : Set} → (f : A → B) → (v : Vec A n) → (i : F.Fin n) →
        (vmap f v) !! i ≡ f (v !! i)
map!! {zero}  f  [] ()
map!! {suc n} f (x ∷ xs) F.zero    = refl
map!! {suc n} f (x ∷ xs) (F.suc i) = map!! f xs i

lookupTab : {A : Set} {n : ℕ} {f : F.Fin n → A} →  (i : F.Fin n) →
            (tabulate f) !! i ≡ (f i)
lookupTab {f = f} F.zero   = refl
lookupTab        (F.suc i) = lookupTab i

mapTab : {A B : Set} → {n : ℕ} → (f : A → B) → (g : F.Fin n → A) →
         vmap f (tabulate g) ≡ tabulate (f ○ g)
mapTab {n = zero}  f g = refl
mapTab {n = suc n} f g =
  cong (_∷_ (f (g F.zero))) (mapTab {n = n} f (g ○ F.suc))

-- Lemma for proving that two vectors are equal if their tabulates agree
-- on all inputs.
tabf∼g : {n : ℕ} → {A : Set} → (f g : F.Fin n → A) → (∀ x → f x ≡ g x) →
         tabulate f ≡ tabulate g
tabf∼g {zero} f g p = refl
tabf∼g {suc n} f g p with f F.zero | g F.zero | p F.zero
tabf∼g {suc n} f g p | x | .x | refl =
  cong (_∷_ x) (tabf∼g {n} (f ○ F.suc) (g ○ F.suc) (p ○ F.suc))

lookup∼vec : {n : ℕ} → {A : Set} →
             (v₁ v₂ : Vec A n) → (∀ i → v₁ !! i ≡ v₂ !! i) → v₁ ≡ v₂
lookup∼vec []          []           p = refl
lookup∼vec (x ∷ v₁) (x₁ ∷ v₂) p with p F.zero
lookup∼vec (x ∷ v₁) (.x ∷ v₂) p | refl =
  cong (_∷_ x) (lookup∼vec v₁ v₂ (p ○ F.suc))

∘̬id : {A : Set} → {n : ℕ} → (k : ℕ) → (v : Vec A (ntimes k suc n)) →
       (tabulate {n} (ntimesD {ℕ} {F.Fin} {suc} k F.suc)) ∘̬ v ≡
       (tabulate (λ i → v !! (ntimesD {ℕ} {F.Fin} {suc} k F.suc i)))
∘̬id {n = n} k v = begin
       (tabulate {n} (ntimesD {ℕ} {F.Fin} {suc} k F.suc)) ∘̬ v
         ≡⟨ refl ⟩
       (tabulate
         (λ i → v !! (tabulate (ntimesD {ℕ} {F.Fin} {suc} k F.suc) !! i)))
         ≡⟨ tabf∼g
              (λ i → v !! (tabulate (ntimesD {ℕ} {F.Fin} {suc} k F.suc) !! i))
              (λ i → v !! ntimesD {ℕ} {F.Fin} {suc} k F.suc i)
              (λ i → cong (_!!_ v) (lookupTab i)) ⟩
       (tabulate (λ i → v !! (ntimesD {ℕ} {F.Fin} {suc} k F.suc i))) ∎

map2+id : {m n : ℕ} → (v : Vec (F.Fin n) m) → {x y : F.Fin (suc (suc n))} →
          (vmap F.suc (vmap F.suc v)) ∘̬′
            (x ∷ y ∷ tabulate {n} (F.suc ○ F.suc)) ≡
          (vmap F.suc (vmap F.suc v))
map2+id [] = refl
map2+id {suc m} {n} (i ∷ v) {x} {y} =
  begin
  (vmap F.suc (vmap F.suc (i ∷ v))) ∘̬′ (x ∷ y ∷ tabulate (F.suc ○ F.suc))
    ≡⟨ refl ⟩
  (tabulate (F.suc ○ F.suc) !! i) ∷
    (vmap F.suc (vmap F.suc v)) ∘̬′ (x ∷ y ∷ tabulate (F.suc ○ F.suc))
    ≡⟨ cong (λ z → z ∷ ((vmap F.suc (vmap F.suc v))) ∘̬′ (x ∷ y ∷ tabulate (F.suc ○ F.suc)))
            (lookupTab i) ⟩
  F.suc (F.suc i) ∷ (vmap F.suc (vmap F.suc v) ∘̬′ (x ∷ y ∷ tabulate (F.suc ○ F.suc)))
    ≡⟨ cong (_∷_ (F.suc (F.suc i))) (map2+id v) ⟩
  F.suc (F.suc i) ∷ (vmap F.suc (vmap F.suc v))
    ≡⟨ refl ⟩
  (vmap F.suc (vmap F.suc (i ∷ v))) ∎

head!!0 : {n : ℕ} {A : Set} (v : Vec A (suc n)) → v !! F.zero ≡ head v
head!!0 (x ∷ v) = refl

headmap : {n : ℕ} {A B : Set} {f : A → B} (v : Vec A (suc n)) →
          head (vmap f v) ≡ f (head v)
headmap (x ∷ v) = refl

tailmap : {n : ℕ} {A B : Set} {f : A → B} (v : Vec A (suc n)) →
          tail (vmap f v) ≡ vmap f (tail v)
tailmap (x ∷ v) = refl

2suc∘̬2tail : {n : ℕ} {A : Set} (v : Vec A (suc (suc n))) →
             (tabulate (F.suc ○ F.suc)) ∘̬ v ≡ (tail (tail v))
2suc∘̬2tail (x ∷ x₁ ∷ v) =
  begin
  (tabulate (F.suc ○ F.suc)) ∘̬ (x ∷ x₁ ∷ v)
    ≡⟨ refl ⟩
  tabulate (λ i → (x ∷ x₁ ∷ v) !! (tabulate (F.suc ○ F.suc) !! i))
    ≡⟨ lookup∼vec
         (tabulate (λ i → (x ∷ x₁ ∷ v) !! (tabulate (F.suc ○ F.suc) !! i)))
         v
         (λ i →
           begin
           tabulate (λ j → (x ∷ x₁ ∷ v) !! (tabulate (F.suc ○ F.suc) !! j)) !! i
             ≡⟨ lookupTab i ⟩
           (x ∷ x₁ ∷ v) !! (tabulate (F.suc ○ F.suc) !! i)
             ≡⟨ cong (λ q → (x ∷ x₁ ∷ v) !! q) (lookupTab i) ⟩
           v !! i ∎) ⟩
  v ∎

-- upTo n returns [0, 1, ..., n-1] as Fins
upTo : (n : ℕ) → Vec (F.Fin n) n
upTo n = tabulate {n} id

upToTail : (n : ℕ) → (tail (tail (upTo (suc (suc n))))) ≡ (vmap F.suc (tail (upTo (suc n))))
upToTail n =
  begin
  tail (tail (upTo (suc (suc n))))
    ≡⟨ refl ⟩
  tabulate (F.suc ○ F.suc)
    ≡⟨ sym (mapTab F.suc F.suc) ⟩
  vmap F.suc (tabulate F.suc) ∎

sidfn : {A : Set} {n : ℕ} (v : Vec A n) (i : F.Fin n) →
        ((upTo n) ∘̬ v) !! i ≡ v !! i
sidfn {n = n} v i =
  begin
  ((upTo n) ∘̬ v) !! i
    ≡⟨ lookupTab {f = λ x → v !! ((upTo n) !! x)} i ⟩
  v !! ((upTo n) !! i)
    ≡⟨ cong (_!!_ v) (lookupTab {f = id} i) ⟩
  v !! i ∎

∘̬simpleid : {A : Set} {n : ℕ} (v : Vec A n) → (upTo n) ∘̬ v ≡ v
∘̬simpleid {n = n} v = lookup∼vec (upTo n ∘̬ v) v (sidfn v)

lookupMap : {A B : Set} → {n : ℕ} → {f : A → B} →
            (i : F.Fin n) → (v : Vec A n) →
            lookup i (vmap f v) ≡ f (lookup i v)
lookupMap F.zero    (x ∷ _)      = refl
lookupMap (F.suc i) (_ ∷ v) = lookupMap i v

lookup∘tabulate : ∀ {a n} → {A : Set a} →
                  (i : F.Fin n) → (f : F.Fin n → A) →
                  lookup i (tabulate f) ≡ f i
lookup∘tabulate F.zero    f = refl
lookup∘tabulate (F.suc i) f = lookup∘tabulate i (f ○ F.suc)

vmap∘vmap : {n : ℕ} {A B C : Set} (f : B → C) (g : A → B) (v : Vec A n) →
    vmap f (vmap g v) ≡ vmap (f ○ g) v
vmap∘vmap {zero} f g [] = refl
vmap∘vmap {suc n} f g (x ∷ v) = cong (λ y → f (g x) ∷ y) (vmap∘vmap f g v)

vmap∘id : {n : ℕ} {A : Set} {v : Vec A n} {f : A → A } → (∀ {x} → f x ≡ x) → vmap f v ≡ v
vmap∘id {zero} {v = []} eq = refl
vmap∘id {suc n} {v = (x ∷ v)} {f} eq = cong₂ _∷_  eq (vmap∘id {v = v} eq)


module SystemF.SmallStep where

open import Prelude

open import Data.Sum
open import Data.Product
open import Data.Vec hiding ([_])

open import SystemF.WellTyped
open import SystemF.Substitutions
open import SystemF.Substitutions.Lemmas

infixl 4 _≻_

-- irreducible System F terms
data Value {ν n} : Term ν n → Set where
  λ' : ∀ τ t → Value (λ' τ t)
  Λ : ∀ t → Value (Λ t)

-- single step reduction of System F terms
data _≻_ {ν n} : Term ν n → Term ν n → Set where
  -- redexes
  reduce-[] : ∀ t a → (Λ t) [ a ] ≻ t tm[/tp a ]
  reduce-· : ∀ a t {u} → (λ' a t) · u ≻ t tm[/tm u ]

  -- contextual closure
  step-·₁ : ∀ {t t' u} → t ≻ t' → t · u ≻ t' · u
  step-·₂ : ∀ {t u u'} → u ≻ u' → t · u ≻ t · u'
  step-λ-body : ∀ {a t t'} → t ≻ t' → λ' a t ≻ λ' a t'
  step-Λ-body : ∀ {t t'} → t ≻ t' → Λ t ≻ Λ t'
  step-[] : ∀ {t t' a} → t ≻ t' → t [ a ] ≻ t' [ a ]

-- multi-step reductions
data _≻⋆_ {ν n} : Term ν n → Term ν n → Set where
  ≻-step : ∀ {t u} → t ≻ u → t ≻⋆ u
  ≻-trans : ∀ {t u v} → t ≻⋆ u → u ≻⋆ v → t ≻⋆ v

∀'-value-lemma : ∀ {ν n} {Γ : Ctx ν n} {t a} → Γ ⊢ t ∈ ∀' a → Value t → ∃ λ e → t ≡ Λ e
∀'-value-lemma () (λ' τ t)
∀'-value-lemma (Λ t∈∀a) (Λ t) = t , refl

→'-value-lemma : ∀ {ν n} {Γ : Ctx ν n} {t a b} → Γ ⊢ t ∈ (a →' b) → Value t →
                 ∃ λ e → (t ≡ λ' a e) × ((a ∷ Γ) ⊢ e ∈ b)
→'-value-lemma () (Λ t)
→'-value-lemma (λ' a ⊢t∈a→b) (λ' .a t) = t , refl , ⊢t∈a→b

-- progress: welltyped terms are either values or can be reduced
progress : ∀ {ν τ} {t : Term ν 0} → [] ⊢ t ∈ τ → Value t ⊎ ∃ (_≻_ t)
progress (var ())
progress (Λ {t = t} ⊢t) = inj₁ (Λ t)
progress (λ' {t = t} a ⊢t) = inj₁ (λ' a t)
progress (_[_] ⊢t a) with progress ⊢t

-- we can rule out the possibility that t is both well typed and a value,
-- but not a lambda
-- leaving only cases that can make progress
progress (_[_] ⊢t a ) | inj₁ (λ' τ t') with ∀'-value-lemma ⊢t (λ' τ t')
progress (() [ a ]) | inj₁ (λ' τ t') | t≡Λe
progress (⊢t [ a ]) | inj₁ (Λ t) = inj₂ (, reduce-[] t a)
progress (⊢t [ a ]) | inj₂ (_ , y≻y') = inj₂ (, step-[] y≻y')

-- similar to above
progress (⊢f · ⊢t) with progress ⊢f | progress ⊢t
progress (⊢f · ⊢t) | inj₁ (λ' τ t) | inj₁ y-isval = inj₂ (, reduce-· τ t)
progress (⊢f · ⊢t) | inj₁ (Λ t) | inj₁ y-isval with →'-value-lemma ⊢f (Λ t)
progress (() · ⊢t) | inj₁ (Λ t) | inj₁ y-isval | f≡a→'b
progress (_·_ {f = f} wf-f ⊢t) | _ | inj₂ (_ , y≻y') = inj₂ (, step-·₂ y≻y')
progress (_·_ {t = t} ⊢f ⊢t) | inj₂ (_ , f≻f') | _ = inj₂ (, step-·₁ f≻f')

-- preservation: reduction preserves well-typedness
≻-preserves : ∀ {ν n} {Γ : Ctx ν n} {t t' τ} → Γ ⊢ t ∈ τ → t ≻ t' → Γ ⊢ t' ∈ τ
≻-preserves (var x) ()
≻-preserves (Λ ⊢t) (step-Λ-body t≻t') = Λ (≻-preserves ⊢t t≻t')
≻-preserves (λ' a ⊢t) (step-λ-body t≻t') = λ' a (≻-preserves ⊢t t≻t')
-- goal: (Λ t) [ a ] and t tm[/tp a ] have the same type
≻-preserves (⊢t [ a ]) (reduce-[] t .a) = WtTypeLemmas.tm[/tp]-preserves ⊢t a
≻-preserves (⊢t [ a ]) (step-[] t≻t') = (≻-preserves ⊢t t≻t') [ a ]
-- goal: (λ' a t) · u and t tm[/tm u ] have the same type
≻-preserves (λ' a ⊢t · ⊢u) (reduce-· .a t₁) = WtTermLemmas.tm[/tm]-preserves ⊢t ⊢u
≻-preserves (⊢t · ⊢u) (step-·₁ t≻t') = (≻-preserves ⊢t t≻t') · ⊢u
≻-preserves (⊢t · ⊢u) (step-·₂ u≻u') = ⊢t · (≻-preserves ⊢u u≻u')


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

module Structure where

open import Data.Nat
open import Prelude

record Struct (A : Set) : Set where
  field
    ℜ : {n : ℕ} → A ^ n → Set
    𝔉 : {n : ℕ} → A ^ n → A


module FairStream where

open import Level as Level using (zero)
open import Size
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P
open ≡-Reasoning

-- open import Data.List using (List; module List; []; _∷_; _++_; length)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product renaming (map to pmap)

open import Stream

data List⁺ (A : Set) : Set where
  one : A → List⁺ A
  _∷_ : A → List⁺ A → List⁺ A

mutual
  data LFin (A B : Set) : Set where
    lin : A × LFin A B → LFin A B
    rinl : RFin A B → LFin A B

  data RFin (A B : Set) : Set where
    rin : B × RFin A B → RFin A B
    linr : LFin A B → RFin A B

Fair Fair' : Set → Set → Set

Fair A B = Stream (LFin A B)

Fair' A B = Stream (List⁺ A × List⁺ B)

α : ∀{A B} → Fair A B → Fair' A B
hd (α {A} {B} u) = (f₁ (hd u) , g (hd u))
  where
    f₁ : LFin A B → List⁺ A
    f₂ : RFin A B → List⁺ A

    f₁ (lin (a , x)) = a ∷ f₁ x
    f₁ (rinl x) = f₂ x

    f₂ (rin (b , y)) = f₂ y
    f₂ (linr x) = f₁ x

    g : LFin A B → List⁺ B
    g (lin x) = {![]!}
    g (rinl x) = {!!}
tl (α u) = {!!}


-- {-# OPTIONS -v tc.with:40 #-}

id : (A : Set) → A → A
id A = {!id′!}
 -- C-c C-h produces:       id′ : ∀ {A} → A
 -- when it should produce: id′ : ∀ {A} → A → A


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Surjection
open import Oscar.Class.Smap
open import Oscar.Data.Constraint

module Oscar.Class.Surjextensionality where

module Surjextensionality
  {𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂} {𝔒₁ : Ø 𝔬₁} {𝔒₂ : Ø 𝔬₂}
  (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
  (_∼̇₁_ : ∀ {x y} → x ∼₁ y → x ∼₁ y → Ø ℓ₁)
  (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
  (surjection : Surjection.type 𝔒₁ 𝔒₂)
  (smap : Smap.type _∼₁_ _∼₂_ surjection surjection)
  where
  open ℭLASS (_∼₁_ ,, {- FIXME including `(λ {x y} → _∼̇₁_ {x} {y}) ,, ` leads to instance search depth exhausted in Oscar.Data.Surjextenscollation -} _∼₂_ ,, (λ {x y} → _∼̇₂_ {x} {y}) ,, surjection ,, (λ {x y} → smap {x} {y})) (∀ x y (f₁ f₂ : x ∼₁ y) → f₁ ∼̇₁ f₂ → smap f₁ ∼̇₂ smap f₂) public
  TYPE = ∀ {x y} {f₁ f₂ : x ∼₁ y} → f₁ ∼̇₁ f₂ → smap f₁ ∼̇₂ smap f₂

module Surjextensionality!
  {𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂} {𝔒₁ : Ø 𝔬₁} {𝔒₂ : Ø 𝔬₂}
  (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
  (_∼̇₁_ : ∀ {x y} → _∼₁_ x y → _∼₁_ x y → Ø ℓ₁)
  (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  (_∼̇₂_ : ∀ {x y} → _∼₂_ x y → _∼₂_ x y → Ø ℓ₂)
  ⦃ _ : Surjection.class 𝔒₁ 𝔒₂ ⦄
  ⦃ _ : Smap.class _∼₁_ _∼₂_ surjection surjection ⦄
  = Surjextensionality (_∼₁_) (λ {x y} → _∼̇₁_ {x} {y}) (_∼₂_) (λ {x y} → _∼̇₂_ {x} {y}) surjection (λ {x y} → smap {x = x} {y})

module _
  {𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂} {𝔒₁ : Ø 𝔬₁} {𝔒₂ : Ø 𝔬₂}
  {∼₁ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁}
  {∼̇₁ : ∀ {x y} → ∼₁ x y → ∼₁ x y → Ø ℓ₁}
  {∼₂ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
  {∼̇₂ : ∀ {x y} → ∼₂ x y → ∼₂ x y → Ø ℓ₂}
  {surjection : Surjection.type 𝔒₁ 𝔒₂}
  {smap : Smap.type ∼₁ ∼₂ surjection surjection}
  where
  open Surjextensionality
    ∼₁
    (λ {x y} → ∼̇₁ {x} {y})
    ∼₂
    (λ {x y} → ∼̇₂ {x} {y})
    surjection
    (λ {x y} → smap {x = x} {y})
  surjextensionality : ⦃ _ : class ⦄ → TYPE
  surjextensionality = method _ _ _ _

module _
  {𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂} {𝔒₁ : Ø 𝔬₁} {𝔒₂ : Ø 𝔬₂}
  {∼₁ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁}
  {∼̇₁ : ∀ {x y} → ∼₁ x y → ∼₁ x y → Ø ℓ₁}
  {∼₂ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
  (∼̇₂ : ∀ {x y} → ∼₂ x y → ∼₂ x y → Ø ℓ₂)
  {surjection : Surjection.type 𝔒₁ 𝔒₂}
  {smap : Smap.type ∼₁ ∼₂ surjection surjection}
  where
  open Surjextensionality
    ∼₁
    (λ {x y} → ∼̇₁ {x} {y})
    ∼₂
    (λ {x y} → ∼̇₂ {x} {y})
    surjection
    (λ {x y} → smap {x = x} {y})
  surjextensionality[_] : ⦃ _ : class ⦄ → TYPE
  surjextensionality[_] = surjextensionality
  ⟪⟫-surjextensionality[]-syntax = surjextensionality[_]
  syntax ⟪⟫-surjextensionality[]-syntax t x = ⟪ x ⟫[ t ]


{-# OPTIONS --universe-polymorphism #-}
module Reflection where

open import Common.Prelude hiding (Unit; module Unit) renaming (Nat to ℕ; module Nat to ℕ)
open import Common.Reflect

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

{-# BUILTIN EQUALITY _≡_ #-}
{-# BUILTIN REFL refl #-}

data Id {A : Set}(x : A) : (B : Set) → B → Set where
  course : Id x A x

primitive
  primTrustMe : ∀{a}{A : Set a}{x y : A} → x ≡ y

open import Common.Level

unEl : Type → Term
unEl (el _ t) = t

argᵛʳ : ∀{A} → A → Arg A
argᵛʳ = arg (arginfo visible relevant)

argʰʳ : ∀{A} → A → Arg A
argʰʳ = arg (arginfo hidden relevant)

el₀ : Term → Type
el₀ = el (lit 0)

el₁ : Term → Type
el₁ = el (lit 1)

set₀ : Type
set₀ = el₁ (sort (lit 0))

unCheck : Term → Term
unCheck (def x (_ ∷ _ ∷ arg _ t ∷ [])) = t
unCheck t = unknown

data Check {a}{A : Set a}(x : A) : Set where
  _is_of_ : (t t′ : Term) →
            Id (primTrustMe {x = unCheck t} {t′})
               (t′ ≡ t′) refl → Check x

`Check : QName
`Check = quote Check

test₁ : Check ({A : Set} → A → A)
test₁ = quoteGoal t in
        t is pi (argʰʳ set₀) (el₀ (pi (argᵛʳ (el₀ (var 0 []))) (el₀ (var 1 []))))
        of course

test₂ : (X : Set) → Check (λ (x : X) → x)
test₂ X = quoteGoal t in
          t is lam visible (var 0 []) of course

infixr 40 _`∷_

_`∷_ : Term → Term → Term
x `∷ xs = con (quote _∷_) (argᵛʳ x ∷ argᵛʳ xs ∷ [])
`[]     = con (quote []) []
`true   = con (quote true) []
`false  = con (quote false) []

test₃ : Check (true ∷ false ∷ [])
test₃ = quoteGoal t in
        t is `true `∷ `false `∷ `[] of course

`List : Term → Term
`List A = def (quote List) (argᵛʳ A ∷ [])
`ℕ      = def (quote ℕ) []

`Term : Term
`Term = def (quote Term) []
`Type : Term
`Type = def (quote Type) []
`Sort : Term
`Sort = def (quote Sort) []

test₄ : Check (List ℕ)
test₄ = quoteGoal t in
        t is `List `ℕ of course

test₅ : primQNameType (quote Term) ≡ set₀
test₅ = refl

-- TODO => test₆ : primQNameType (quote set₀) ≡ el unknown `Type ≢ el₀ `Type
test₆ : unEl (primQNameType (quote set₀)) ≡ `Type
test₆ = refl

test₇ : primQNameType (quote Sort.lit) ≡ el₀ (pi (argᵛʳ (el₀ `ℕ)) (el₀ `Sort))
test₇ = refl

mutual
  ℕdef : DataDef
  ℕdef = _

  test₈ : dataDef ℕdef ≡ primQNameDefinition (quote ℕ)
  test₈ = refl

test₉ : primDataConstructors ℕdef ≡ quote ℕ.zero ∷ quote ℕ.suc ∷ []
test₉ = refl

test₁₀ : primQNameDefinition (quote ℕ.zero) ≡ dataConstructor
test₁₀ = refl

postulate
  a : ℕ

test₁₁ : primQNameDefinition (quote a) ≡ axiom
test₁₁ = refl

test₁₂ : primQNameDefinition (quote primQNameDefinition) ≡ prim
test₁₂ = refl

record Unit : Set where

mutual
  UnitDef : RecordDef
  UnitDef = _

  test₁₃ : recordDef UnitDef ≡ primQNameDefinition (quote Unit)
  test₁₃ = refl

test₁₄ : Check 1
test₁₄ = quoteGoal t in
           t is con ( quote ℕ.suc ) (argᵛʳ (con (quote ℕ.zero) []) ∷ [])
           of course