------------------------------------------------------------------------
-- The Agda standard library
--
-- A universe which includes several kinds of "relatedness" for sets,
-- such as equivalences, surjections and bijections
------------------------------------------------------------------------

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

module Function.Related where

open import Level
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Eq      using (Equivalence)
open import Function.Injection   as Inj     using (Injection; _↣_)
open import Function.Inverse     as Inv     using (Inverse; _↔_)
open import Function.LeftInverse as LeftInv using (LeftInverse)
open import Function.Surjection  as Surj    using (Surjection)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- Wrapper types

-- Synonyms which are used to make _∼[_]_ below "constructor-headed"
-- (which implies that Agda can deduce the universe code from an
-- expression matching any of the right-hand sides).

record _←_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  constructor lam
  field app-← : B → A

open _←_ public

record _↢_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  constructor lam
  field app-↢ : B ↣ A

open _↢_ public

------------------------------------------------------------------------
-- Relatedness

-- There are several kinds of "relatedness".

-- The idea to include kinds other than equivalence and bijection came
-- from Simon Thompson and Bengt Nordström. /NAD

data Kind : Set where
  implication         : Kind
  reverse-implication : Kind
  equivalence         : Kind
  injection           : Kind
  reverse-injection   : Kind
  left-inverse        : Kind
  surjection          : Kind
  bijection           : Kind

-- Interpretation of the codes above. The code "bijection" is
-- interpreted as Inverse rather than Bijection; the two types are
-- equivalent.

infix 4 _∼[_]_

_∼[_]_ : ∀ {ℓ₁ ℓ₂} → Set ℓ₁ → Kind → Set ℓ₂ → Set _
A ∼[ implication         ] B = A → B
A ∼[ reverse-implication ] B = A ← B
A ∼[ equivalence         ] B = Equivalence (P.setoid A) (P.setoid B)
A ∼[ injection           ] B = Injection   (P.setoid A) (P.setoid B)
A ∼[ reverse-injection   ] B = A ↢ B
A ∼[ left-inverse        ] B = LeftInverse (P.setoid A) (P.setoid B)
A ∼[ surjection          ] B = Surjection  (P.setoid A) (P.setoid B)
A ∼[ bijection           ] B = Inverse     (P.setoid A) (P.setoid B)

-- A non-infix synonym.

Related : Kind → ∀ {ℓ₁ ℓ₂} → Set ℓ₁ → Set ℓ₂ → Set _
Related k A B = A ∼[ k ] B

-- The bijective equality implies any kind of relatedness.

↔⇒ : ∀ {k x y} {X : Set x} {Y : Set y} →
     X ∼[ bijection ] Y → X ∼[ k ] Y
↔⇒ {implication}         = _⟨$⟩_ ∘ Inverse.to
↔⇒ {reverse-implication} = lam ∘′ _⟨$⟩_ ∘ Inverse.from
↔⇒ {equivalence}         = Inverse.equivalence
↔⇒ {injection}           = Inverse.injection
↔⇒ {reverse-injection}   = lam ∘′ Inverse.injection ∘ Inv.sym
↔⇒ {left-inverse}        = Inverse.left-inverse
↔⇒ {surjection}          = Inverse.surjection
↔⇒ {bijection}           = id

-- Actual equality also implies any kind of relatedness.

≡⇒ : ∀ {k ℓ} {X Y : Set ℓ} → X ≡ Y → X ∼[ k ] Y
≡⇒ P.refl = ↔⇒ Inv.id

------------------------------------------------------------------------
-- Special kinds of kinds

-- Kinds whose interpretation is symmetric.

data Symmetric-kind : Set where
  equivalence : Symmetric-kind
  bijection   : Symmetric-kind

-- Forgetful map.

⌊_⌋ : Symmetric-kind → Kind
⌊ equivalence ⌋ = equivalence
⌊ bijection   ⌋ = bijection

-- The proof of symmetry can be found below.

-- Kinds whose interpretation include a function which "goes in the
-- forward direction".

data Forward-kind : Set where
  implication  : Forward-kind
  equivalence  : Forward-kind
  injection    : Forward-kind
  left-inverse : Forward-kind
  surjection   : Forward-kind
  bijection    : Forward-kind

-- Forgetful map.

⌊_⌋→ : Forward-kind → Kind
⌊ implication  ⌋→ = implication
⌊ equivalence  ⌋→ = equivalence
⌊ injection    ⌋→ = injection
⌊ left-inverse ⌋→ = left-inverse
⌊ surjection   ⌋→ = surjection
⌊ bijection    ⌋→ = bijection

-- The function.

⇒→ : ∀ {k x y} {X : Set x} {Y : Set y} → X ∼[ ⌊ k ⌋→ ] Y → X → Y
⇒→ {implication}  = id
⇒→ {equivalence}  = _⟨$⟩_ ∘ Equivalence.to
⇒→ {injection}    = _⟨$⟩_ ∘ Injection.to
⇒→ {left-inverse} = _⟨$⟩_ ∘ LeftInverse.to
⇒→ {surjection}   = _⟨$⟩_ ∘ Surjection.to
⇒→ {bijection}    = _⟨$⟩_ ∘ Inverse.to

-- Kinds whose interpretation include a function which "goes backwards".

data Backward-kind : Set where
  reverse-implication : Backward-kind
  equivalence         : Backward-kind
  reverse-injection   : Backward-kind
  left-inverse        : Backward-kind
  surjection          : Backward-kind
  bijection           : Backward-kind

-- Forgetful map.

⌊_⌋← : Backward-kind → Kind
⌊ reverse-implication ⌋← = reverse-implication
⌊ equivalence         ⌋← = equivalence
⌊ reverse-injection   ⌋← = reverse-injection
⌊ left-inverse        ⌋← = left-inverse
⌊ surjection          ⌋← = surjection
⌊ bijection           ⌋← = bijection

-- The function.

⇒← : ∀ {k x y} {X : Set x} {Y : Set y} → X ∼[ ⌊ k ⌋← ] Y → Y → X
⇒← {reverse-implication} = app-←
⇒← {equivalence}         = _⟨$⟩_ ∘ Equivalence.from
⇒← {reverse-injection}   = _⟨$⟩_ ∘ Injection.to ∘ app-↢
⇒← {left-inverse}        = _⟨$⟩_ ∘ LeftInverse.from
⇒← {surjection}          = _⟨$⟩_ ∘ Surjection.from
⇒← {bijection}           = _⟨$⟩_ ∘ Inverse.from

-- Kinds whose interpretation include functions going in both
-- directions.

data Equivalence-kind : Set where
    equivalence  : Equivalence-kind
    left-inverse : Equivalence-kind
    surjection   : Equivalence-kind
    bijection    : Equivalence-kind

-- Forgetful map.

⌊_⌋⇔ : Equivalence-kind → Kind
⌊ equivalence  ⌋⇔ = equivalence
⌊ left-inverse ⌋⇔ = left-inverse
⌊ surjection   ⌋⇔ = surjection
⌊ bijection    ⌋⇔ = bijection

-- The functions.

⇒⇔ : ∀ {k x y} {X : Set x} {Y : Set y} →
     X ∼[ ⌊ k ⌋⇔ ] Y → X ∼[ equivalence ] Y
⇒⇔ {equivalence}  = id
⇒⇔ {left-inverse} = LeftInverse.equivalence
⇒⇔ {surjection}   = Surjection.equivalence
⇒⇔ {bijection}    = Inverse.equivalence

-- Conversions between special kinds.

⇔⌊_⌋ : Symmetric-kind → Equivalence-kind
⇔⌊ equivalence ⌋ = equivalence
⇔⌊ bijection   ⌋ = bijection

→⌊_⌋ : Equivalence-kind → Forward-kind
→⌊ equivalence  ⌋ = equivalence
→⌊ left-inverse ⌋ = left-inverse
→⌊ surjection   ⌋ = surjection
→⌊ bijection    ⌋ = bijection

←⌊_⌋ : Equivalence-kind → Backward-kind
←⌊ equivalence  ⌋ = equivalence
←⌊ left-inverse ⌋ = left-inverse
←⌊ surjection   ⌋ = surjection
←⌊ bijection    ⌋ = bijection

------------------------------------------------------------------------
-- Opposites

-- For every kind there is an opposite kind.

_op : Kind → Kind
implication         op = reverse-implication
reverse-implication op = implication
equivalence         op = equivalence
injection           op = reverse-injection
reverse-injection   op = injection
left-inverse        op = surjection
surjection          op = left-inverse
bijection           op = bijection

-- For every morphism there is a corresponding reverse morphism of the
-- opposite kind.

reverse : ∀ {k a b} {A : Set a} {B : Set b} →
          A ∼[ k ] B → B ∼[ k op ] A
reverse {implication}         = lam
reverse {reverse-implication} = app-←
reverse {equivalence}         = Eq.sym
reverse {injection}           = lam
reverse {reverse-injection}   = app-↢
reverse {left-inverse}        = Surj.fromRightInverse
reverse {surjection}          = Surjection.right-inverse
reverse {bijection}           = Inv.sym

------------------------------------------------------------------------
-- For a fixed universe level every kind is a preorder and each
-- symmetric kind is an equivalence

K-refl : ∀ {k ℓ} → Reflexive (Related k {ℓ})
K-refl {implication}         = id
K-refl {reverse-implication} = lam id
K-refl {equivalence}         = Eq.id
K-refl {injection}           = Inj.id
K-refl {reverse-injection}   = lam Inj.id
K-refl {left-inverse}        = LeftInv.id
K-refl {surjection}          = Surj.id
K-refl {bijection}           = Inv.id

K-reflexive : ∀ {k ℓ} → _≡_ ⇒ Related k {ℓ}
K-reflexive P.refl = K-refl

K-trans : ∀ {k ℓ₁ ℓ₂ ℓ₃} → Trans (Related k {ℓ₁} {ℓ₂})
                                (Related k {ℓ₂} {ℓ₃})
                                (Related k {ℓ₁} {ℓ₃})
K-trans {implication}         = flip _∘′_
K-trans {reverse-implication} = λ f g → lam (app-← f ∘ app-← g)
K-trans {equivalence}         = flip Eq._∘_
K-trans {injection}           = flip Inj._∘_
K-trans {reverse-injection}   = λ f g → lam (Inj._∘_ (app-↢ f) (app-↢ g))
K-trans {left-inverse}        = flip LeftInv._∘_
K-trans {surjection}          = flip Surj._∘_
K-trans {bijection}           = flip Inv._∘_

SK-sym : ∀ {k ℓ₁ ℓ₂} → Sym (Related ⌊ k ⌋ {ℓ₁} {ℓ₂})
                          (Related ⌊ k ⌋ {ℓ₂} {ℓ₁})
SK-sym {equivalence} = Eq.sym
SK-sym {bijection}   = Inv.sym

SK-isEquivalence : ∀ k ℓ → IsEquivalence {ℓ = ℓ} (Related ⌊ k ⌋)
SK-isEquivalence k ℓ = record
  { refl  = K-refl
  ; sym   = SK-sym
  ; trans = K-trans
  }

SK-setoid : Symmetric-kind → (ℓ : Level) → Setoid _ _
SK-setoid k ℓ = record { isEquivalence = SK-isEquivalence k ℓ }

K-isPreorder : ∀ k ℓ → IsPreorder _↔_ (Related k)
K-isPreorder k ℓ = record
    { isEquivalence = SK-isEquivalence bijection ℓ
    ; reflexive     = ↔⇒
    ; trans         = K-trans
    }

K-preorder : Kind → (ℓ : Level) → Preorder _ _ _
K-preorder k ℓ = record { isPreorder = K-isPreorder k ℓ }

------------------------------------------------------------------------
-- Equational reasoning

-- Equational reasoning for related things.

module EquationalReasoning where

  infix  3 _∎
  infixr 2 _∼⟨_⟩_ _↔⟨_⟩_ _↔⟨⟩_ _≡⟨_⟩_

  _∼⟨_⟩_ : ∀ {k x y z} (X : Set x) {Y : Set y} {Z : Set z} →
           X ∼[ k ] Y → Y ∼[ k ] Z → X ∼[ k ] Z
  _ ∼⟨ X↝Y ⟩ Y↝Z = K-trans X↝Y Y↝Z

  -- Isomorphisms can be combined with any other kind of relatedness.

  _↔⟨_⟩_ : ∀ {k x y z} (X : Set x) {Y : Set y} {Z : Set z} →
           X ↔ Y → Y ∼[ k ] Z → X ∼[ k ] Z
  X ↔⟨ X↔Y ⟩ Y⇔Z = X ∼⟨ ↔⇒ X↔Y ⟩ Y⇔Z

  _↔⟨⟩_ : ∀ {k x y} (X : Set x) {Y : Set y} →
          X ∼[ k ] Y → X ∼[ k ] Y
  X ↔⟨⟩ X⇔Y = X⇔Y

  _≡⟨_⟩_ : ∀ {k ℓ z} (X : Set ℓ) {Y : Set ℓ} {Z : Set z} →
           X ≡ Y → Y ∼[ k ] Z → X ∼[ k ] Z
  X ≡⟨ X≡Y ⟩ Y⇔Z = X ∼⟨ ≡⇒ X≡Y ⟩ Y⇔Z

  _∎ : ∀ {k x} (X : Set x) → X ∼[ k ] X
  X ∎ = K-refl

  sym = SK-sym
  {-# WARNING_ON_USAGE sym
  "Warning: EquationalReasoning.sym was deprecated in v0.17.
  Please use SK-sym instead."
  #-}

------------------------------------------------------------------------
-- Every unary relation induces a preorder and, for symmetric kinds,
-- an equivalence. (No claim is made that these relations are unique.)

InducedRelation₁ : Kind → ∀ {a s} {A : Set a} →
                   (A → Set s) → A → A → Set _
InducedRelation₁ k S = λ x y → S x ∼[ k ] S y

InducedPreorder₁ : Kind → ∀ {a s} {A : Set a} →
                   (A → Set s) → Preorder _ _ _
InducedPreorder₁ k S = record
  { _≈_        = _≡_
  ; _∼_        = InducedRelation₁ k S
  ; isPreorder = record
    { isEquivalence = P.isEquivalence
    ; reflexive     = reflexive ∘
                      K-reflexive ∘
                      P.cong S
    ; trans         = K-trans
    }
  } where open Preorder (K-preorder _ _)

InducedEquivalence₁ : Symmetric-kind → ∀ {a s} {A : Set a} →
                      (A → Set s) → Setoid _ _
InducedEquivalence₁ k S = record
  { _≈_           = InducedRelation₁ ⌊ k ⌋ S
  ; isEquivalence = record
    { refl  = K-refl
    ; sym   = SK-sym
    ; trans = K-trans
    }
  }

------------------------------------------------------------------------
-- Every binary relation induces a preorder and, for symmetric kinds,
-- an equivalence. (No claim is made that these relations are unique.)

InducedRelation₂ : Kind → ∀ {a b s} {A : Set a} {B : Set b} →
                   (A → B → Set s) → B → B → Set _
InducedRelation₂ k _S_ = λ x y → ∀ {z} → (z S x) ∼[ k ] (z S y)

InducedPreorder₂ : Kind → ∀ {a b s} {A : Set a} {B : Set b} →
                   (A → B → Set s) → Preorder _ _ _
InducedPreorder₂ k _S_ = record
  { _≈_        = _≡_
  ; _∼_        = InducedRelation₂ k _S_
  ; isPreorder = record
    { isEquivalence = P.isEquivalence
    ; reflexive     = λ x≡y {z} →
                        reflexive $
                        K-reflexive $
                        P.cong (_S_ z) x≡y

    ; trans         = λ i↝j j↝k → K-trans i↝j j↝k
    }
  } where open Preorder (K-preorder _ _)

InducedEquivalence₂ : Symmetric-kind →
                      ∀ {a b s} {A : Set a} {B : Set b} →
                      (A → B → Set s) → Setoid _ _
InducedEquivalence₂ k _S_ = record
  { _≈_           = InducedRelation₂ ⌊ k ⌋ _S_
  ; isEquivalence = record
    { refl  = refl
    ; sym   = λ i↝j → sym i↝j
    ; trans = λ i↝j j↝k → trans i↝j j↝k
    }
  } where open Setoid (SK-setoid _ _)

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.17

preorder = K-preorder
{-# WARNING_ON_USAGE preorder
"Warning: preorder was deprecated in v0.17.
Please use K-preorder instead."
#-}
setoid = SK-setoid
{-# WARNING_ON_USAGE setoid
"Warning: setoid was deprecated in v0.17.
Please use SK-setoid instead."
#-}


-- BEGIN prelude.agda

-- the Haskell $ and .

($) (A::Set) (B::Set) (f :: A -> B) (a :: A) :: B
  = f a

compose (B,C,A::Set)(f :: B -> C)(g :: A -> B) :: A -> C
  = \ (x::A) -> f (g x)

{- hardwired into Agda

Integer :: Set
  = ?

Bool :: Set
  = data True | False

-}

not (b::Bool) :: Bool
  = case b of {
      (True) -> False;  -- Agda does not require @_ for built-in constructors
      (False) -> True;}

(||) (b1::Bool)(b2::Bool) :: Bool
  = case b1 of {
      (True) -> True@_;
      (False) ->
        case b2 of {
          (True) -> True@_;
          (False) -> False@_;};}

(&&) (b1::Bool)(b2::Bool) :: Bool
  = case b1 of {
      (True) ->
        case b2 of {
          (True) -> False@_;
          (False) -> True@_;};
      (False) -> False@_;}

Pair (a::Set)(b::Set) :: Set
  = data Pair (x::a) (y::b)

Triple (a::Set)(b::Set)(c::Set) :: Set
  = data Triple (x::a) (y::b) (z::c)

flip (a::Set)(b::Set)(c::Set)(f::a -> b -> c)(x::b)(y::a) :: c
  = f y x

{- hardwired into Agda:

List (a::Set) :: Set
  = data Nil | (:) (x::a) (xs::List a)

-}

foldl (a::Set)(b::Set)(f::a -> b -> a)(acc::a)(l::List b) :: a
  = case l of {
      (Nil) -> acc;
      (x:xs) -> foldl a b f (f acc x) xs;}

reverse (a::Set)(l::List a) :: List a
  = foldl (List a) a
      (flip a (List a) (List a) (\(h::a) -> \(h'::List a) -> (:)@_ h h'))
      Nil@_
      l

append (a::Set)(l1::List a)(l2::List a) :: List a
  = case l1 of {
      (Nil) -> l2;
      (x:xs) -> x : (append a xs l2);}

null (a::Set)(l::List a) :: Bool
  = case l of {
      (Nil) -> True@_;
      (x:xs) -> False@_;}

map (a,b::Set)(f::a -> b)(l::List a) :: List b
  = case l of
       (Nil)  -> Nil
       (x:xs) -> f x : map a b f xs

Maybe (a::Set) :: Set
  = data Nothing | Just (x::a)

-- Should not be here - temporary addition to provide an "interesting" type
-- data Simple = A | B | C  -gone

-- Properties
-- naive implementation of Property.hs

-- from SET.alfa
Rel (X::Set) :: Type
  = X -> X -> Set
Id (X::Set) :: Rel X
  = idata ref (x::X) :: _ x x
Zero :: Set
  = data
whenZero (X::Set)(z::Zero) :: X
  = case z of { }
Unit :: Set
  = data tt
Sum (X::Set)(Y::X -> Set) :: Set
  = sig{fst :: X;
        snd :: Y fst;}
Plus (X::Set)(Y::Set) :: Set
  = data inl (x::X) | inr (y::Y)

package Property where

  Prop :: Type
    = Set

  (===) (A :: Set) (a :: A) (b :: A) :: Prop
    = Id A a b

  -- translate forAll into a dependent function type
  forAll (A :: Set) (f :: A -> Prop) :: Prop
    = (x :: A) -> f x

  exists (A :: Set) (f :: A -> Prop) :: Prop
    = sig { witness :: A;
            prop    :: f witness; }

  (/\) (A,B :: Prop) :: Prop
    = Sum A (\(a::A) -> B)

  (\/) (A,B :: Prop) :: Prop
    = Plus A B

  (<=>) (A,B :: Prop) :: Prop
    =  (A -> B) /\ (B -> A)

  (==>) (A,B :: Prop) :: Prop
    =  (A -> B)

  true :: Prop
    = Unit

  false :: Prop
    = Zero

  nt (A :: Prop) :: Prop
    =  A -> false

  -- cannot do the naive using because of universe conflict
  -- List cannot have a parameter which is not a set, and Prop is a type
  --using (L :: List Prop) (A :: Prop) :: Prop
  --  = A

  holds (b::Bool) :: Prop
    = if b then true else false

  holdsNot (b::Bool) :: Prop
    = if b then false else true

-- Class of inhabited types

class Inhabited (a::Set) :: Set exports
  arbitrary :: a

error (a::Set)(|ia::Inhabited a)(msg::String) :: a
  = arbitrary

-- Prelude types are inhabited

instance iBool :: Inhabited Bool where
  arbitrary = True

instance iString :: Inhabited String where
  arbitrary = "I AM ARBITRARY"

instance iInteger :: Inhabited Integer where
  arbitrary = 123456789

{- Syntax error:
instance iRational :: Inhabited Rational where
  arbitrary = 0.123456789
-}

instance iList (|a::Set) :: Inhabited (List a) where
  arbitrary = Nil
-- instance iList (a::Set)(ia::Inhabited a)  :: Inhabited (List a) where

-- END prelude.agda


{-# OPTIONS --without-K #-}
module hott.loop.sum where

open import sum
open import equality
open import function.core
open import function.extensionality
open import function.isomorphism
open import function.overloading
open import sets.nat
open import pointed
open import hott.equivalence
open import hott.level.core
open import hott.loop.core
open import hott.loop.properties

private
  abstract
    loop-sum' : ∀ {i}{j}{A : Set i}{B : A → Set j}(n : ℕ)
              → (hB : (a : A) → h n (B a))
              → {a₀ : A}{b₀ : B a₀}
              → Ω n {Σ A B} (a₀ , b₀) ≅ Ω n a₀
    loop-sum' 0 hB {a₀}{b₀} = Σ-ap-iso refl≅ (λ a → contr-⊤-iso (hB a)) ·≅ ×-right-unit
    loop-sum' {A = A}{B = B} (suc n) hB {a₀}{b₀} = Ω-iso n (sym≅ Σ-split-iso) refl
                                                ·≅ loop-sum' n λ p → hB _ _ _

    loop-sum-β : ∀ {i}{j}{A : Set i}{B : A → Set j}(n : ℕ)
               → (hB : (a : A) → h n (B a))
               → {a₀ : A}{b₀ : B a₀}
               → (p : Ω n {Σ A B} (a₀ , b₀))
               → apply≅ (loop-sum' n hB) p ≡ mapΩ n proj₁ p
    loop-sum-β zero hB p = refl
    loop-sum-β (suc n) hB p
      = loop-sum-β n _ (mapΩ n apΣ p)
      · mapΩ-hom n apΣ proj₁ p
      · funext-inv (ap proj₁ (ap (mapΩP n) lem)) p
      where
        lem : ∀ {i}{j}{A : Set i}{B : A → Set j}{a₀ : A}{b₀ : B a₀}
            → _≡_ {A = PMap (_≡_ {A = Σ A B} (a₀ , b₀) (a₀ , b₀) , refl) ((a₀ ≡ a₀) , refl)}
              (proj₁ ∘ apΣ , refl)
              (ap proj₁ , refl)
        lem = apply≅ pmap-eq ((λ _ → refl) , refl)

loop-sum : ∀ {i}{j}{A : Set i}{B : A → Set j}(n : ℕ)
         → (hB : (a : A) → h n (B a))
         → {a₀ : A}{b₀ : B a₀}
         → Ω n {Σ A B} (a₀ , b₀) ≅ Ω n a₀
loop-sum n hB {a₀}{b₀} = ≈⇒≅ (mapΩ n proj₁ , subst weak-equiv eq we)
  where
    abstract
      we : weak-equiv (apply (loop-sum' n hB {a₀}{b₀}))
      we = proj₂ (≅⇒≈ (loop-sum' n hB))

      eq : apply (loop-sum' n hB {a₀}{b₀}) ≡ mapΩ n proj₁
      eq = funext (loop-sum-β n hB)


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

open import Functions.Definition
open import Numbers.Naturals.Definition
open import Sets.FinSet.Definition

module Sets.Cardinality.Finite.Definition where

record FiniteSet {a : _} (A : Set a) : Set a where
  field
    size : ℕ
    mapping : FinSet size → A
    bij : Bijection mapping


open import FRP.JS.RSet using ( RSet ; ⟦_⟧ ; _⇒_ )
open import FRP.JS.Time using ( Time )

module FRP.JS.Product where

-- We define _∧_ directly, rather than as λ t → (A t × B t)
-- in order to make _∧_ invertable. (If we used the obvious defn,
-- (A ∧ B) would only be invertable if A and B were invertable.

infixr 2 _∧_
infixr 4 _,_

data _∧_ (A B : RSet) (t : Time) : Set where
  _,_ : A t → B t → (A ∧ B) t

proj₁ : ∀ {A B} → ⟦ A ∧ B ⇒ A ⟧
proj₁ (a , b) = a

proj₂ : ∀ {A B} → ⟦ A ∧ B ⇒ B ⟧
proj₂ (a , b) = b

swap : ∀ {A B} →  ⟦ A ∧ B ⇒ B ∧ A ⟧
swap (a , b) = (b , a)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Surjections
------------------------------------------------------------------------

module Function.Surjection where

open import Level
open import Function.Equality as F
  using (_⟶_) renaming (_∘_ to _⟪∘⟫_)
open import Function.Equivalence using (Equivalence)
open import Function.Injection           hiding (id; _∘_)
open import Function.LeftInverse as Left hiding (id; _∘_)
open import Data.Product
open import Relation.Binary
import Relation.Binary.PropositionalEquality as P

-- Surjective functions.

record Surjective {f₁ f₂ t₁ t₂}
                  {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
                  (to : From ⟶ To) :
                  Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
  field
    from             : To ⟶ From
    right-inverse-of : from RightInverseOf to

-- The set of all surjections from one setoid to another.

record Surjection {f₁ f₂ t₁ t₂}
                  (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
                  Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
  field
    to         : From ⟶ To
    surjective : Surjective to

  open Surjective surjective public

  right-inverse : RightInverse From To
  right-inverse = record
    { to              = from
    ; from            = to
    ; left-inverse-of = right-inverse-of
    }

  open LeftInverse right-inverse public
    using () renaming (to-from to from-to)

  injective : Injective from
  injective = LeftInverse.injective right-inverse

  injection : Injection To From
  injection = LeftInverse.injection right-inverse

  equivalence : Equivalence From To
  equivalence = record
    { to   = to
    ; from = from
    }

-- Right inverses can be turned into surjections.

fromRightInverse :
  ∀ {f₁ f₂ t₁ t₂} {From : Setoid f₁ f₂} {To : Setoid t₁ t₂} →
  RightInverse From To → Surjection From To
fromRightInverse r = record
  { to         = from
  ; surjective = record
    { from             = to
    ; right-inverse-of = left-inverse-of
    }
  } where open LeftInverse r

-- The set of all surjections from one set to another.

infix 3 _↠_

_↠_ : ∀ {f t} → Set f → Set t → Set _
From ↠ To = Surjection (P.setoid From) (P.setoid To)

-- Identity and composition.

id : ∀ {s₁ s₂} {S : Setoid s₁ s₂} → Surjection S S
id {S = S} = record
  { to         = F.id
  ; surjective = record
    { from             = LeftInverse.to              id′
    ; right-inverse-of = LeftInverse.left-inverse-of id′
    }
  } where id′ = Left.id {S = S}

infixr 9 _∘_

_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂}
        {F : Setoid f₁ f₂} {M : Setoid m₁ m₂} {T : Setoid t₁ t₂} →
      Surjection M T → Surjection F M → Surjection F T
f ∘ g = record
  { to         = to f ⟪∘⟫ to g
  ; surjective = record
    { from             = LeftInverse.to              g∘f
    ; right-inverse-of = LeftInverse.left-inverse-of g∘f
    }
  }
  where
  open Surjection
  g∘f = Left._∘_ (right-inverse g) (right-inverse f)


module CategoryTheory.Linear where

open import CategoryTheory.Categories
open import CategoryTheory.Functor
open import CategoryTheory.BCCCs
open import CategoryTheory.Monad
open import CategoryTheory.Instances.Kleisli

module L {n} {ℂ : Category n} (ℂ-BCCC : BicartesianClosed ℂ) (Mo : Monad ℂ) where
    open Category ℂ
    open BicartesianClosed ℂ-BCCC
    open Monad Mo
    open Functor T renaming (omap to M ; fmap to M-f)
    Kl : Category n
    Kl = Kleisli ℂ Mo

    -- Linear product of two objects
    _⊛_ : (A B : obj) -> obj
    A ⊛ B = (A ⊗ M B) ⊕ (M A ⊗ B) ⊕ (A ⊗ B)

    -- First projection from linear product
    *π₁ : ∀{A B} -> A ⊛ B ~> M A
    *π₁ {A}{B} = [ η.at A ∘ π₁ ⁏ π₁ ⁏ η.at A ∘ π₁ ]

    -- Second projection from linear product
    *π₂ : ∀{A B} -> A ⊛ B ~> M B
    *π₂ {A}{B} = [ π₂ ⁏ η.at B ∘ π₂ ⁏ η.at B ∘ π₂ ]

    -- Type class for linear products of type A ⊛ B. Need to provide
    -- linear product of morphisms and product laws in order to establish
    -- that the linear product is a product in the Kleisli category of the monad.
    record LinearProduct (A B : obj) : Set (lsuc n) where
        infix 10 ⟪_,_⟫
        field
            -- | Data
            -- Linear product
            ⟪_,_⟫ : ∀{L} -> (L ~> M A) -> (L ~> M B) -> (L ~> M (A ⊛ B))

            -- | Laws
            *π₁-comm : ∀{L} -> {l₁ : L ~> M A} {l₂ : L ~> M B}
                   -> (μ.at A ∘ M-f *π₁) ∘ ⟪ l₁ , l₂ ⟫ ≈ l₁
            *π₂-comm : ∀{L} -> {l₁ : L ~> M A} {l₂ : L ~> M B}
                   -> (μ.at B ∘ M-f *π₂) ∘ ⟪ l₁ , l₂ ⟫ ≈ l₂
            ⊛-unique : ∀{P} {p₁ : P ~> M A} {p₂ : P ~> M B} {m : P ~> M A⊕B}
                    -> (μ.at A ∘ M-f *π₁) ∘ m ≈ p₁ -> (μ.at B ∘ M-f *π₂) ∘ m ≈ p₂
                    -> ⟪ p₁ , p₂ ⟫ ≈ m

        Kl-⊛ : Product Kl A B
        Kl-⊛ = record
            { A⊗B = A ⊛ B
            ; π₁ = *π₁
            ; π₂ = *π₂
            ; ⟨_,_⟩ = ⟪_,_⟫
            ; π₁-comm = *π₁-comm
            ; π₂-comm = *π₂-comm
            ; ⊗-unique = ⊛-unique
            }

-- Type class for linear categories
record Linear {n} {ℂ : Category n}
              (ℂ-BCCC : BicartesianClosed ℂ) (Mo : Monad ℂ) : Set (lsuc n) where
    open Category ℂ
    open L ℂ-BCCC Mo

    field
        linprod : ∀(A B : obj) -> LinearProduct A B

    open module Li {A} {B} = LinearProduct (linprod A B) public


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Setoids.Setoids
open import Rings.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Sequences
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Functions.Definition
open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order

module Rings.Orders.Total.Cauchy {m n o : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} {_<_ : Rel {m} {o} A} {pOrder : SetoidPartialOrder S _<_} {R : Ring S _+_ _*_} {pRing : PartiallyOrderedRing R pOrder} (order : TotallyOrderedRing pRing) where

open import Rings.Orders.Total.Lemmas order
open import Rings.Orders.Total.AbsoluteValue order

cauchy : Sequence A → Set (m ⊔ o)
cauchy s = ∀ (ε : A) → (Ring.0R R < ε) → Sg ℕ (λ N → ∀ {m n : ℕ} → (N <N m) → (N <N n) → abs (Ring._-R_ R (index s m) (index s n)) < ε)


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category

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

open Category C

open import Level

record Pullback {X Y Z}(f : X ⇒ Z)(g : Y ⇒ Z) : Set (o ⊔ ℓ ⊔ e) where
  field
    P  : Obj
    p₁ : P ⇒ X
    p₂ : P ⇒ Y

  field
    .commutes : f ∘ p₁ ≡ g ∘ p₂

    universal : ∀ {Q}(q₁ : Q ⇒ X)(q₂ : Q ⇒ Y)
              → .(commutes : (f ∘ q₁ ≡ g ∘ q₂)) → (Q ⇒ P)

    .universal-unique : ∀ {Q} {q₁ : Q ⇒ X} {q₂ : Q ⇒ Y}
                        .{commutes : f ∘ q₁ ≡ g ∘ q₂}
                          (u : Q ⇒ P)
                          .(p₁∘u≡q₁ : p₁ ∘ u ≡ q₁)
                          .(p₂∘u≡q₂ : p₂ ∘ u ≡ q₂)
                      →   u ≡ universal q₁ q₂ commutes

    .p₁∘universal≡q₁  : ∀ {Q} {q₁ : Q ⇒ X} {q₂ : Q ⇒ Y}
                          .{commutes : f ∘ q₁ ≡ g ∘ q₂}
                      →   (p₁ ∘ universal q₁ q₂ commutes ≡ q₁)

    .p₂∘universal≡q₂  : ∀ {Q} {q₁ : Q ⇒ X} {q₂ : Q ⇒ Y}
                          .{commutes : f ∘ q₁ ≡ g ∘ q₂}
                      →   (p₂ ∘ universal q₁ q₂ commutes ≡ q₂)

glue : ∀ {W X Y Z : Obj} {f0 : W ⇒ X}{f : X ⇒ Z}{g : Y ⇒ Z}
         → (p : Pullback f g) → Pullback f0 (Pullback.p₁ p) → Pullback (f ∘ f0) g
glue {f0 = f0} {f} {g} R L = record {
                      P = L.P;
                      p₁ = L.p₁;
                      p₂ = R.p₂ ∘ L.p₂;
                      commutes = begin (f ∘ f0) ∘ L.p₁   ↓⟨ assoc ⟩
                                       f ∘ f0 ∘ L.p₁     ↓⟨ ∘-resp-≡ʳ L.commutes ⟩
                                       f ∘ R.p₁ ∘ L.p₂   ↑⟨ assoc ⟩
                                       (f ∘ R.p₁) ∘ L.p₂ ↓⟨ ∘-resp-≡ˡ R.commutes ⟩
                                       (g ∘ R.p₂) ∘ L.p₂ ↓⟨ assoc ⟩
                                       g ∘ R.p₂ ∘ L.p₂   ∎;
                      universal = λ q₁ q₂ commutes → L.universal q₁ (R.universal (f0 ∘ q₁) q₂ (Equiv.trans (Equiv.sym assoc) commutes))
                                                                    (Equiv.sym R.p₁∘universal≡q₁);
                      universal-unique = λ {Q} {q₁} u p₁∘u≡q₁ p₂∘u≡q₂ →
                            L.universal-unique u p₁∘u≡q₁
                                       (R.universal-unique (L.p₂ ∘ u) (begin
                                                                         R.p₁ ∘ L.p₂ ∘ u   ↑⟨ assoc ⟩
                                                                         (R.p₁ ∘ L.p₂) ∘ u ↑⟨ ∘-resp-≡ˡ L.commutes ⟩
                                                                         (f0 ∘ L.p₁) ∘ u   ↓⟨ assoc ⟩
                                                                         f0 ∘ L.p₁ ∘ u     ↓⟨ ∘-resp-≡ʳ p₁∘u≡q₁ ⟩
                                                                         f0 ∘ q₁           ∎)
                                                   (Equiv.trans (Equiv.sym assoc) p₂∘u≡q₂));
                      p₁∘universal≡q₁ = L.p₁∘universal≡q₁;
                      p₂∘universal≡q₂ = Equiv.trans assoc (Equiv.trans (∘-resp-≡ʳ L.p₂∘universal≡q₂) R.p₂∘universal≡q₂) }
   where
    module L = Pullback L
    module R = Pullback R
    open HomReasoning


module Integer8 where

open import Data.Nat
open import Data.Nat.Properties
open import Data.Product
open import Relation.Binary.PropositionalEquality as PropEq

-- ---------- record ----------
record IsSemiGroup (A : Set) (_∙_ : A → A → A) : Set where
  field
    assoc : ∀ x y z → (x ∙ y) ∙ z ≡ x ∙ (y ∙ z)
record IsMonoid (A : Set) (_∙_ : A → A → A) (e : A) : Set where
  field
    isSemiGroup : IsSemiGroup A _∙_
    identity : (∀ x → e ∙ x ≡ x) × (∀ x → x ∙ e ≡ x)
record IsGroup (A : Set) (_∙_ : A → A → A) (e : A) (iF : A → A) : Set where
  field
    isMonoid : IsMonoid A _∙_ e
    inv : (∀ x → (iF x) ∙ x ≡ e) × (∀ x → x ∙ (iF x) ≡ e)
record IsAbelianGroup (A : Set) (_∙_ : A → A → A) (e : A) (iF : A → A) : Set where
  field
    isGroup : IsGroup A _∙_ e iF
    comm : ∀ x y → x ∙ y ≡ y ∙ x
record IsRing (A : Set) (_⊕_ _⊗_ : A → A → A) (eP eT : A) (iF : A → A) : Set where
  field
    ⊕isAbelianGroup : IsAbelianGroup A _⊕_ eP iF
    ⊗isMonoid : IsMonoid A _⊗_ eT
    isDistR : (x y z : A) → (x ⊕ y) ⊗ z ≡ (x ⊗ z) ⊕ (y ⊗ z)
    isDistL : (x y z : A) → x ⊗ (y ⊕ z) ≡ (x ⊗ y) ⊕ (x ⊗ z)
-- ----------------------------

-- ---------- practice nat ----------
ℕ+-isSemiGroup : IsSemiGroup ℕ _+_
ℕ+-isSemiGroup = record { assoc = ℕ+-assoc }
  where
    ℕ+-assoc : ∀ x y z → (x + y) + z ≡ x + (y + z)
    ℕ+-assoc zero y z = refl
    ℕ+-assoc (suc x) y z = cong suc (ℕ+-assoc x y z)

ℕ+0-isMonoid : IsMonoid ℕ _+_ 0
ℕ+0-isMonoid = record { isSemiGroup = ℕ+-isSemiGroup ; identity = (0+x≡x , x+0≡x) }
  where
    0+x≡x : ∀ x → 0 + x ≡ x
    0+x≡x x = refl
    x+0≡x : ∀ x → x + 0 ≡ x
    x+0≡x zero = refl
    x+0≡x (suc x) = cong suc (x+0≡x x)
-- -------------------------

-- ---------- Int ----------
data ℤ : Set where
  O : ℤ
  I : ℕ → ℕ → ℤ
postulate
  zeroZ : (x : ℕ) → I x x ≡ O
  zeroZ₂ : (x y : ℕ) → I (x + y) (y + x) ≡ O
-- plusInt
_++_ : ℤ → ℤ → ℤ
O ++ O = O
O ++ X = X
X ++ O = X
I x y ++ I z w = I (x + z) (y + w)
-- productInt
_**_ : ℤ → ℤ → ℤ
O ** O = O
O ** _ = O
_ ** O = O
I x y ** I z w = I (x * z + y * w) (x * w + y * z)
-- -------------------------

-- ---------- Int + ----------
ℤ++-isSemiGroup : IsSemiGroup ℤ _++_
ℤ++-isSemiGroup = record { assoc = ℤ++-assoc }
  where
    open IsSemiGroup
    ℤ++-assoc : ∀ x y z → (x ++ y) ++ z ≡ x ++ (y ++ z)
    ℤ++-assoc O O O = refl
    ℤ++-assoc O O (I x x₁) = refl
    ℤ++-assoc O (I x x₁) O = refl
    ℤ++-assoc O (I x x₁) (I x₂ x₃) = refl
    ℤ++-assoc (I x x₁) O O = refl
    ℤ++-assoc (I x x₁) O (I x₂ x₃) = refl
    ℤ++-assoc (I x x₁) (I x₂ x₃) O = refl
    ℤ++-assoc (I x x₁) (I x₂ x₃) (I x₄ x₅)
      = cong₂ I ((assoc ℕ+-isSemiGroup) x x₂ x₄) ((assoc ℕ+-isSemiGroup) x₁ x₃ x₅)

ℤ++O-isMonoid : IsMonoid ℤ _++_ O
ℤ++O-isMonoid = record { isSemiGroup = ℤ++-isSemiGroup ; identity = (O++x≡x , x++O≡x) }
  where
    O++x≡x : (x : ℤ) → (O ++ x) ≡ x
    O++x≡x O = refl
    O++x≡x (I x x₁) = refl
    x++O≡x : (x : ℤ) → (x ++ O) ≡ x
    x++O≡x O = refl
    x++O≡x (I x x₁) = refl

invℤ : ℤ → ℤ
invℤ O = O
invℤ (I x x₁) = I x₁ x
ℤ++Oinvℤ-isGroup : IsGroup ℤ _++_ O invℤ
ℤ++Oinvℤ-isGroup = record { isMonoid = ℤ++O-isMonoid ; inv = (leftInv , rightInv) }
  where
    leftInv : (x : ℤ) → (invℤ x ++ x) ≡ O
    leftInv O = refl
    leftInv (I x x₁) = zeroZ₂ x₁ x
    rightInv : (x : ℤ) → (x ++ invℤ x) ≡ O
    rightInv O = refl
    rightInv (I x x₁) = zeroZ₂ x x₁

ℤ++Oinvℤ-isAbelianGroup : IsAbelianGroup ℤ _++_ O invℤ
ℤ++Oinvℤ-isAbelianGroup = record { isGroup = ℤ++Oinvℤ-isGroup ; comm = ℤ++Oinvℤ-Comm }
  where
    ℤ++Oinvℤ-Comm : (x y : ℤ) → (x ++ y) ≡ (y ++ x)
    ℤ++Oinvℤ-Comm O O = refl
    ℤ++Oinvℤ-Comm O (I x x₁) = refl
    ℤ++Oinvℤ-Comm (I x x₁) O = refl
    ℤ++Oinvℤ-Comm (I x x₁) (I x₂ x₃) = cong₂ I (+-comm x x₂) (+-comm x₁ x₃)
-- ---------------------------

-- ---------- Int * ----------
ℤ**-isSemiGroup : IsSemiGroup ℤ _**_
ℤ**-isSemiGroup = record { assoc = ℤ**-assoc }
  where
    ℤ**-assoc : ∀ x y z → (x ** y) ** z ≡ x ** (y ** z)
    ℤ**-assoc O O O = refl
    ℤ**-assoc O O (I x x₁) = refl
    ℤ**-assoc O (I x x₁) O = refl
    ℤ**-assoc O (I x x₁) (I x₂ x₃) = refl
    ℤ**-assoc (I x x₁) O O = refl
    ℤ**-assoc (I x x₁) O (I x₂ x₃) = refl
    ℤ**-assoc (I x x₁) (I x₂ x₃) O = refl
    ℤ**-assoc (I x x₁) (I x₂ x₃) (I x₄ x₅)
      = cong₂ I (ℤ**-assoc₁ x x₁ x₂ x₃ x₄ x₅) (ℤ**-assoc₁ x x₁ x₂ x₃ x₅ x₄)
      where
        open PropEq.≡-Reasoning
        open IsSemiGroup
        ℤ**-assoc₁ : ∀ x y z u v w →
          (x * z + y * u) * v + (x * u + y * z) * w ≡ x * (z * v + u * w) + y * (z * w + u * v)
        ℤ**-assoc₁ x y z u v w = begin
            (x * z + y * u) * v + (x * u + y * z) * w
          ≡⟨ cong (\ t → (t + (x * u + y * z) * w)) (*-distribʳ-+ v (x * z) (y * u)) ⟩
            x * z * v + y * u * v + (x * u + y * z) * w
          ≡⟨ cong (\ t → (x * z * v + y * u * v + t)) (*-distribʳ-+ w (x * u) (y * z)) ⟩
            x * z * v + y * u * v + (x * u * w + y * z * w)
          ≡⟨ +-assoc (x * z * v) (y * u * v) (x * u * w + y * z * w) ⟩
            x * z * v + (y * u * v + (x * u * w + y * z * w))
          ≡⟨ cong (\ t → ((x * z * v) + t)) (+-comm (y * u * v) (x * u * w + y * z * w)) ⟩
            x * z * v + ((x * u * w + y * z * w) + y * u * v)
          ≡⟨ sym (+-assoc (x * z * v) (x * u * w + y * z * w) (y * u * v)) ⟩
            x * z * v + (x * u * w + y * z * w) + y * u * v
          ≡⟨ sym (cong (\ t → (t + y * u * v)) ((assoc ℕ+-isSemiGroup) (x * z * v) (x * u * w) (y * z * w))) ⟩
            x * z * v + x * u * w + y * z * w + y * u * v
          ≡⟨ cong (\ t → t + x * u * w + y * z * w + y * u * v) (*-assoc x z v) ⟩
            x * (z * v) + x * u * w + y * z * w + y * u * v
          ≡⟨ cong (\ t → x * (z * v) + t + y * z * w + y * u * v) (*-assoc x u w) ⟩
            x * (z * v) + x * (u * w) + y * z * w + y * u * v
          ≡⟨ cong (\ t → x * (z * v) + x * (u * w) + t + y * u * v) (*-assoc y z w) ⟩
            x * (z * v) + x * (u * w) + y * (z * w) + y * u * v
          ≡⟨ cong (\ t → x * (z * v) + x * (u * w) + y * (z * w) + t) (*-assoc y u v) ⟩
            x * (z * v) + x * (u * w) + y * (z * w) + y * (u * v)
          ≡⟨ sym (cong (\ t → (t + y * (z * w) + y * (u * v))) (*-distribˡ-+ x (z * v) (u * w))) ⟩
            x * (z * v + u * w) + y * (z * w) + y * (u * v)
          ≡⟨ +-assoc (x * (z * v + u * w)) (y * (z * w))  (y * (u * v)) ⟩
            x * (z * v + u * w) + (y * (z * w) + y * (u * v))
          ≡⟨ sym (cong (\ t → (x * (z * v + u * w) + t)) (*-distribˡ-+ y (z * w) (u * v))) ⟩
            x * (z * v + u * w) + y * (z * w + u * v)
          ∎

ℤ**1-isMonoid : IsMonoid ℤ _**_ (I 1 0)
ℤ**1-isMonoid = record { isSemiGroup = ℤ**-isSemiGroup ; identity = (1**x≡x , x**1≡x) }
  where
    1**x≡x : (x : ℤ) → (I 1 0 ** x) ≡ x
    1**x≡x O = refl
    1**x≡x (I x x₁) = cong₂ I (x+z+z≡x x) (x+z+z≡x x₁)
      where
        x+z+z≡x : (x : ℕ) → x + 0 + 0 ≡ x
        x+z+z≡x zero = refl
        x+z+z≡x (suc x) = cong suc (x+z+z≡x x)
    x**1≡x : (x : ℤ) → (x ** I 1 0) ≡ x
    x**1≡x O = refl
    x**1≡x (I x x₁) = cong₂ I (x*1+x*0≡x x x₁) (x*0+x*1=x x x₁)
      where
        x*1+x*0≡x : (x x₁ : ℕ) → x * 1 + x₁ * 0 ≡ x
        x*1+x*0≡x zero zero = refl
        x*1+x*0≡x zero (suc x₁) = x*1+x*0≡x zero x₁
        x*1+x*0≡x (suc x) zero = cong suc (x*1+x*0≡x x zero)
        x*1+x*0≡x (suc x) (suc x₁) = x*1+x*0≡x (suc x) x₁
        x*0+x*1=x : (x x₁ : ℕ) → x * 0 + x₁ * 1 ≡ x₁
        x*0+x*1=x zero zero = refl
        x*0+x*1=x zero (suc x₁) = cong suc (x*0+x*1=x zero x₁)
        x*0+x*1=x (suc x) zero = x*0+x*1=x x zero
        x*0+x*1=x (suc x) (suc x₁) = x*0+x*1=x x (suc x₁)
-- ---------------------------

-- ---------- Int + * ----------
ℤ++0invℤ-**1-isRing : IsRing ℤ _++_ _**_ O (I 1 0) invℤ
ℤ++0invℤ-**1-isRing =
  record
    { ⊕isAbelianGroup = ℤ++Oinvℤ-isAbelianGroup
    ; ⊗isMonoid = ℤ**1-isMonoid
    ; isDistR = ℤdistR
    ; isDistL = ℤdistL }
    where
      ℤdistR : (x y z : ℤ) → (x ++ y) ** z ≡ (x ** z) ++ (y ** z)
      ℤdistR O O O = refl
      ℤdistR O O (I x x₁) = refl
      ℤdistR O (I x x₁) O = refl
      ℤdistR O (I x x₁) (I x₂ x₃) = refl
      ℤdistR (I x x₁) O O = refl
      ℤdistR (I x x₁) O (I x₂ x₃) = refl
      ℤdistR (I x x₁) (I x₂ x₃) O = refl
      ℤdistR (I x x₁) (I x₂ x₃) (I x₄ x₅) = cong₂ I (ℤdistR₁ x x₂ x₄ x₁ x₃ x₅) (ℤdistR₁ x x₂ x₅ x₁ x₃ x₄)
        where
          open PropEq.≡-Reasoning
          open IsSemiGroup
          ℤdistR₁ : (x y z u v w : ℕ) →
            (x + y) * z + (u + v) * w ≡ x * z + u * w + (y * z + v * w)
          ℤdistR₁ x y z u v w = begin
              (x + y) * z + (u + v) * w
            ≡⟨ cong (\ t → t + (u + v) * w) (*-distribʳ-+ z x y) ⟩
               x * z + y * z + (u + v) * w
            ≡⟨ cong (\ t → (x * z + y * z + t)) (*-distribʳ-+ w u v) ⟩
               x * z + y * z + (u * w + v * w)
            ≡⟨ +-assoc (x * z) (y * z) (u * w + v * w) ⟩
               x * z + (y * z + (u * w + v * w))
            ≡⟨ cong (\ t → x * z + t) (+-comm (y * z) (u * w + v * w)) ⟩
               x * z + ((u * w + v * w) + y * z)
            ≡⟨ cong (\ t → x * z + t) ((assoc ℕ+-isSemiGroup) (u * w) (v * w) (y * z)) ⟩
               x * z + (u * w + (v * w + y * z))
            ≡⟨ cong (\ t → x * z + (u * w + t)) (+-comm (v * w) (y * z)) ⟩
               x * z + (u * w + (y * z + v * w))
            ≡⟨ sym ((assoc ℕ+-isSemiGroup) (x * z) (u * w) (y * z + v * w)) ⟩
               x * z + u * w + (y * z + v * w)
            ∎
      ℤdistL : (x y z : ℤ) → x ** (y ++ z) ≡ (x ** y) ++ (x ** z)
      ℤdistL O O O = refl
      ℤdistL O O (I x x₁) = refl
      ℤdistL O (I x x₁) O = refl
      ℤdistL O (I x x₁) (I x₂ x₃) = refl
      ℤdistL (I x x₁) O O = refl
      ℤdistL (I x x₁) O (I x₂ x₃) = refl
      ℤdistL (I x x₁) (I x₂ x₃) O = refl
      ℤdistL (I x x₁) (I x₂ x₃) (I x₄ x₅) = cong₂ I (ℤdistL₁ x x₁ x₂ x₃ x₄ x₅) (ℤdistL₁ x x₁ x₃ x₂ x₅ x₄)
        where
          open PropEq.≡-Reasoning
          open IsSemiGroup
          ℤdistL₁ : (x y z u v w : ℕ) →
            x * (z + v) + y * (u + w) ≡ x * z + y * u + (x * v + y * w)
          ℤdistL₁ x y z u v w = begin
               x * (z + v) + y * (u + w)
            ≡⟨ cong (\ t → t + y * (u + w)) (*-distribˡ-+ x z v) ⟩
               x * z + x * v + y * (u + w)
            ≡⟨ cong (\ t → x * z + x * v + t) (*-distribˡ-+ y u w) ⟩
               x * z + x * v + (y * u + y * w)
            ≡⟨ +-assoc (x * z) (x * v) (y * u + y * w) ⟩
               x * z + (x * v + (y * u + y * w))
            ≡⟨ sym (cong (\ t → x * z + t) ((assoc ℕ+-isSemiGroup) (x * v) (y * u) (y * w))) ⟩
               x * z + ((x * v + y * u) + y * w)
            ≡⟨ cong (\ t → x * z + (t + y * w)) (+-comm (x * v) (y * u)) ⟩
               x * z + ((y * u + x * v) + y * w)
            ≡⟨ cong (\ t → x * z + t) ((assoc ℕ+-isSemiGroup) (y * u) (x * v) (y * w)) ⟩
               x * z + (y * u + (x * v + y * w))
            ≡⟨ sym ((assoc ℕ+-isSemiGroup) (x * z) (y * u) (x * v + y * w)) ⟩
               x * z + y * u + (x * v + y * w)
            ∎
-- ---------------------------

-- (-1) * (-1) = 1
minus : I 0 1 ** I 0 1 ≡ I 1 0
minus = refl


module Golden.Insertion where

open import Agda.Builtin.Nat
open import Agda.Builtin.List
open import Agda.Builtin.Bool

insert : Nat -> List Nat -> List Nat
insert a [] = a ∷ []
insert x (a ∷ b) with x < a
... | true = x ∷ a ∷ b
... | false = a ∷ (insert x b)

lst : List Nat
lst = 2 ∷ []

slst : List Nat
slst = insert 3 lst

atDef : ∀ {a : Set} → a → List a -> Nat -> a
atDef def (x ∷ l) zero = x
atDef def (x ∷ l) (suc ix) = atDef def l ix
atDef def _ _ = def

l0 : Nat
l0 = atDef 0 slst 0

l1 : Nat
l1 = atDef 0 slst 1


module leftpad where

open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Data.Nat.Properties
open import Data.Vec
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality

data LeOrGt : ℕ → ℕ → Set where
  le : ∀ m k → LeOrGt m (k + m)
  gt : ∀ m k → LeOrGt (suc k + m) m

compare : ∀ m n → LeOrGt m n
compare zero n = cast $ le 0 n
  where cast = subst (LeOrGt 0) (+-identityʳ n)
compare (suc m) zero = cast $ gt 0 m
  where cast = subst (flip LeOrGt 0) (+-identityʳ (suc m))
compare (suc m) (suc n) with compare m n
... | le .m k = cast $ le (suc m) k
  where cast = subst (LeOrGt (suc m)) (+-suc k m)
... | gt .n k = cast $ gt (suc n) k
  where cast = subst (flip LeOrGt (suc n) ∘′ suc) (+-suc k n)

_⊔_ : ℕ → ℕ → ℕ
m ⊔ n with compare m n
... | le _ _ = n
... | gt _ _ = m

module _ {a} {A : Set a} (x : A) where

  data LeftPad {n : ℕ} (xs : Vec A n) : ∀ m → Vec A m → Set where
    Padded : ∀ k → LeftPad xs (k + n) (replicate {n = k} x ++ xs)

  leftPad : ∀ n m (xs : Vec A n) → ∃ (LeftPad xs (n ⊔ m))
  leftPad n m xs with compare n m
  ... | le .n k = , Padded k
  ... | gt .m k = , Padded 0


{-# OPTIONS --without-K --safe #-}
open import Categories.Category
open import Categories.Functor hiding (id)

-- Cocone over a Functor F (from shape category J into category C)

module Categories.Diagram.Cocone
  {o ℓ e} {o′ ℓ′ e′} {C : Category o ℓ e} {J : Category o′ ℓ′ e′} (F : Functor J C) where

open Category C
open Functor F

open import Level

record Coapex (N : Obj) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′) where
  field
    ψ       : (X : Category.Obj J) → F₀ X ⇒ N
    commute : ∀ {X Y} (f : J [ X , Y ]) → ψ Y ∘ F₁ f ≈ ψ X

record Cocone : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′) where
  field
    {N}    : Obj
    coapex : Coapex N

  open Coapex coapex public

open Coapex
open Cocone

record Cocone⇒ (c c′ : Cocone) : Set (ℓ ⊔ e ⊔ o′) where
  field
    arr     : N c ⇒ N c′
    commute : ∀ {X} → arr ∘ ψ c X ≈ ψ c′ X

open Cocone⇒


{-
This second-order equational theory was created from the following second-order syntax description:

syntax CommMonoid | CM

type
  * : 0-ary

term
  unit : * | ε
  add  : *  *  ->  * | _⊕_ l20

theory
  (εU⊕ᴸ) a |> add (unit, a) = a
  (εU⊕ᴿ) a |> add (a, unit) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊕C) a b |> add(a, b) = add(b, a)
-}

module CommMonoid.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import CommMonoid.Signature
open import CommMonoid.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution CM:Syn
open import SOAS.Metatheory.SecondOrder.Equality CM:Syn

private
  variable
    α β γ τ : *T
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ CM) α Γ → (𝔐 ▷ CM) α Γ → Set where
  εU⊕ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢       ε ⊕ 𝔞 ≋ₐ 𝔞
  ⊕A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ⊕ 𝔟) ⊕ 𝔠 ≋ₐ 𝔞 ⊕ (𝔟 ⊕ 𝔠)
  ⊕C   : ⁅ * ⁆ ⁅ * ⁆̣       ▹ ∅ ⊢       𝔞 ⊕ 𝔟 ≋ₐ 𝔟 ⊕ 𝔞

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning

-- Derived equations
εU⊕ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ⊕ ε ≋ 𝔞
εU⊕ᴿ = tr (ax ⊕C with《 𝔞 ◃ ε 》) (ax εU⊕ᴸ with《 𝔞 》)


module Negation where

-- Imports

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_)
-- open import plfa.part1.Isomorphism using (_≃_; extensionality)

-- 同型 (isomorphism)
infix 0 _≃_
record _≃_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
    to∘from : ∀ (y : B) → to (from y) ≡ y
open _≃_

postulate
  -- 外延性の公理
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

-- Negation (否定)

infix 3 ¬_
¬_ : Set → Set
¬ A = A → ⊥

¬-elim : ∀ {A : Set}
  → ¬ A
  → A
    ---
  → ⊥
¬-elim ¬x x = ¬x x

-- 二重否定の導入則
¬¬-intro : ∀ {A : Set}
  → A
    -----
  → ¬ ¬ A
¬¬-intro x  =  λ{¬x → ¬x x}

-- 二重否定の導入則
¬¬-intro′ : ∀ {A : Set}
  → A
    -----
  → ¬ ¬ A
¬¬-intro′ x ¬x = ¬x x

-- 三重否定の除去則
¬¬¬-elim : ∀ {A : Set}
  → ¬ ¬ ¬ A
    -------
  → ¬ A
¬¬¬-elim ¬¬¬x  =  λ x → ¬¬¬x (¬¬-intro x)

-- 対偶 (contraposition)
contraposition : ∀ {A B : Set}
  → (A → B)
    -----------
  → (¬ B → ¬ A)
contraposition f ¬y x = ¬y (f x)

-- 不等号(inequality)
_≢_ : ∀ {A : Set} → A → A → Set
x ≢ y  =  ¬ (x ≡ y)

_ : 1 ≢ 2
_ = λ()

peano : ∀ {m : ℕ} → zero ≢ suc m
peano = λ()

id : ⊥ → ⊥
id x = x

id′ : ⊥ → ⊥
id′ ()

id≡id′ : id ≡ id′
id≡id′ = extensionality (λ())

-- 同化
assimilation : ∀ {A : Set} (¬x ¬x′ : ¬ A) → ¬x ≡ ¬x′
assimilation ¬x ¬x′ = extensionality (λ x → ⊥-elim (¬x x))

-- Excluded middle is irrefutable

-- 排中律 (excluded middle)
postulate
  em : ∀ {A : Set} → A ⊎ ¬ A

-- 排中律は反駁できない
em-irrefutable : ∀ {A : Set} → ¬ ¬ (A ⊎ ¬ A)
em-irrefutable k = k (inj₂ λ{ x → k (inj₁ x) })


------------------------------------------------------------------------------
-- Mutual recursive functions
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.Nat.MutualRecursiveFunctions where

open import FOTC.Base
open import FOTC.Data.Nat.UnaryNumbers

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

postulate
  even : D → D
  odd  : D → D

  even-0 : even zero            ≡ true
  even-S : ∀ d → even (succ₁ d) ≡ odd d

  odd-0 : odd zero            ≡ false
  odd-S : ∀ d → odd (succ₁ d) ≡ even d
{-# ATP axioms even-0 even-S odd-0 odd-S #-}

postulate even-2 : even 2' ≡ true
{-# ATP prove even-2 #-}

postulate even-3 : even 3' ≡ false
{-# ATP prove even-3 #-}

postulate odd-2 : odd 2' ≡ false
{-# ATP prove odd-2 #-}

postulate odd-3 : odd 3' ≡ true
{-# ATP prove odd-3 #-}


module IrrelevantLambda where

postulate
  A : Set
  P : .A -> Set

f : ._ -> Set
f = λ .x -> P x

f' = λ .(x : _) -> P x

f'' = λ .{x y z : _} -> P x

g : ((.A -> Set) -> Set) -> Set
g k = k f


module Haskell.Prim.Real where

open import Haskell.Prim
open import Haskell.Prim.Ord
open import Haskell.Prim.Enum
open import Haskell.Prim.Num
open import Haskell.Prim.Eq
open import Haskell.Prim.Int
open import Haskell.Prim.Integer

-- infixr 8  _^_ _^^_
-- infixl 7  _/_ _`quot`_ _`rem`_ _`div`_ _`mod`_
-- infixl 7  _%_

data Ratio (a : Set) : Set where
    _:%_ : a -> a -> Ratio a

record Integral (a : Set) : Set where
  field
    toInteger : a -> Integer

open Integral ⦃ ... ⦄ public

instance
    isIntegralInt : Integral Int
    isIntegralInt . toInteger n = intToInteger n

infinity : Ratio Integer
notANumber : Ratio Integer
infinity   = (toInteger 1) :% (toInteger 0)
notANumber = (toInteger 0) :% (toInteger 0)

-- _%_ : {{Integral a}} -> a -> a -> Ratio a

numerator : Ratio a -> a

denominator : Ratio a -> a

-- reduce : {{Integral a}} -> a -> a -> Ratio a

numerator (x :% _) =  x
denominator (_ :% y) =  y

-- record Real {Num a} (a : Set) : Set where
--   field
--     toRational : a -> Ratio Integer


open import SOAS.Common

{-
Framework for constructing categories of objects with extra structure.
The definitions required to construct a category is:
* the category of carrier objects (e.g. sets, presheaves, etc.)
* the extra operations and laws that the carrier objects are equipped with
* the preservation properties of morphisms between the structures
* proofs that the identities and composition of the carrier category preserve
  the extra structure
-}

module SOAS.Construction.Structure
  (CarrierCat : Category 1ℓ 0ℓ 0ℓ)
  (HasStruct : Category.Obj CarrierCat → Set) where

private module ℂ = Category CarrierCat

-- The carrier of the structure, e.g. sets, presheaves, etc.
Carrier : Set₁
Carrier = ℂ.Obj

infix 1 _⋉_

-- Objects in the category for the structure: a carrier object together with
-- the algebraic structure
record Object : Set₁ where
  constructor _⋉_
  field
    𝐶 : Carrier
    ˢ : HasStruct 𝐶

open Object public

-- Properties of the morphisms between two objects, usually concerning
-- the preservation of the extra operations
MorphismProps : Set₁
MorphismProps = {𝐶₁ 𝐶₂ : Carrier}
              → HasStruct 𝐶₁
              → HasStruct 𝐶₂
              → CarrierCat [ 𝐶₁ , 𝐶₂ ] → Set

-- Morphisms in the category for the algebraic structure: an underlying
-- morphism with preservation properties of the extra structure
record Morphism (IsHomomorphism : MorphismProps) (O₁ O₂ : Object) : Set where
  constructor _⋉_
  field
    𝑓   : CarrierCat [ 𝐶 O₁ , 𝐶 O₂ ]
    ˢ⇒ : IsHomomorphism (ˢ O₁)(ˢ O₂) 𝑓

open Morphism public

-- Properties required to turn the objects and morphisms into a category; namely
-- that the identity and composition in the carrier category are homomorphisms
record CategoryProps : Set₁ where
  field
    IsHomomorphism  : MorphismProps
    id-hom   : {𝐶 : Carrier}{𝐶ˢ : HasStruct 𝐶} → IsHomomorphism 𝐶ˢ 𝐶ˢ ℂ.id
    comp-hom : {𝐶 𝐷 𝐸 : Carrier}
               {𝐶ˢ : HasStruct 𝐶}{𝐷ˢ : HasStruct 𝐷}{𝐸ˢ : HasStruct 𝐸} →
               (𝑔 : CarrierCat [ 𝐷 , 𝐸 ])(𝑓 : CarrierCat [ 𝐶 , 𝐷 ]) →
               (𝑔ʰ : IsHomomorphism 𝐷ˢ 𝐸ˢ 𝑔)(𝑓ʰ : IsHomomorphism 𝐶ˢ 𝐷ˢ 𝑓) →
               IsHomomorphism 𝐶ˢ 𝐸ˢ (𝑔 ℂ.∘ 𝑓)

module _ (P : CategoryProps) where
  open CategoryProps P

  -- Category generated from the algebraic structure
  StructCat : Category 1ℓ 0ℓ 0ℓ
  StructCat = categoryHelper (record
    { Obj = Object
    ; _⇒_ = Morphism IsHomomorphism
    ; _≈_ = λ g₁ g₂ → 𝑓 g₁ ℂ.≈ 𝑓 g₂
    ; id = ℂ.id ⋉ id-hom
    ; _∘_ = λ{ (𝑔 ⋉ 𝑔ˢ⇒) (𝑓 ⋉ 𝑓ˢ⇒) → (𝑔 ℂ.∘ 𝑓) ⋉ (comp-hom 𝑔 𝑓 𝑔ˢ⇒ 𝑓ˢ⇒)}
    ; assoc = ℂ.assoc
    ; identityˡ = ℂ.identityˡ
    ; identityʳ = ℂ.identityʳ
    ; equiv = record { refl = ℂ.Equiv.refl ; sym = ℂ.Equiv.sym ; trans = ℂ.Equiv.trans }
    ; ∘-resp-≈ = ℂ.∘-resp-≈
    })

  -- Forget the structure of a carrier object
  Forget :  Object → Carrier
  Forget (𝐶 ⋉ _) = 𝐶

  -- Forgetful functor from the structure category to the carrier category
  ForgetF : Functor StructCat CarrierCat
  ForgetF = record
    { F₀ = Forget
    ; F₁ = λ (𝑓 ⋉ _) → 𝑓
    ; identity = ℂ.Equiv.refl
    ; homomorphism = ℂ.Equiv.refl
    ; F-resp-≈ = λ x → x
    }
    where
    open ≡-Reasoning

  -- Free constructions with respect to the forgetful functor
  module Free where
    open import SOAS.Construction.Free ForgetF public


module Dave.Logic.Basics where
    open import Dave.Functions
    open import Dave.Equality
    open import Dave.Isomorphism
    open import Dave.Structures.Monoid

    {- True -}
    data ⊤ : Set where
        tt : ⊤

    η-⊤ : ∀ (w : ⊤) → tt ≡ w
    η-⊤ tt = refl

    {- False -}
    data ⊥ : Set where
        -- no clauses!

    ⊥-elim : ∀ {A : Set} → ⊥ → A
    ⊥-elim ()

    uniq-⊥ : ∀ {C : Set} (h : ⊥ → C) (w : ⊥) → ⊥-elim w ≡ h w
    uniq-⊥ h ()

    {- Product (Conjunction) -}
    data _×_ (A B : Set) : Set where
        ⟨_,_⟩ : A → B → A × B

    infixr 2 _×_

    proj₁ : {A B : Set} → A × B → A
    proj₁ ⟨ a , b ⟩ = a

    proj₂ : {A B : Set} → A × B → B
    proj₂ ⟨ a , b ⟩ = b

    ×-comm :  {A B : Set} → (A × B) ≃ (B × A)
    ×-comm = record
        {
            to = λ{ ⟨ a , b ⟩ → ⟨ b , a ⟩ };
            from = λ {⟨ b , a ⟩ → ⟨ a , b ⟩};
            from∘to = λ { ⟨ a , b ⟩ → refl };
            to∘from = λ { ⟨ b , a ⟩ → refl }
        }

    ×-assoc : ∀ {A B C : Set} → (A × B) × C ≃ A × (B × C)
    ×-assoc = record
        {
            to = λ {⟨ ⟨ a , b ⟩ , c ⟩ → ⟨ a , ⟨ b , c ⟩ ⟩};
            from = λ {⟨ a , ⟨ b , c ⟩ ⟩ → ⟨ ⟨ a , b ⟩ , c ⟩};
            from∘to = λ {⟨ ⟨ a , b ⟩ , c ⟩ → refl};
            to∘from = λ {⟨ a , ⟨ b , c ⟩ ⟩ → refl}
        }

    η-× : ∀ {A B : Set} (w : A × B) →  ⟨ proj₁ w , proj₂ w ⟩ ≡ w
    η-× ⟨ x , y ⟩ = refl

    ⊤-identityˡ : ∀ {A : Set} → ⊤ × A ≃ A
    ⊤-identityˡ = record
        {
            to      = λ{ ⟨ tt , x ⟩ → x };
            from    = λ{ x → ⟨ tt , x ⟩ };
            from∘to = λ{ ⟨ tt , x ⟩ → refl };
            to∘from = λ{ x → refl }
        }

    ⊤-identityʳ : ∀ {A : Set} → (A × ⊤) ≃ A
    ⊤-identityʳ {A} = ≃-begin
        (A × ⊤) ≃⟨ ×-comm ⟩
        (⊤ × A) ≃⟨ ⊤-identityˡ ⟩
        A ≃-∎

    {- Sum (Disjunction) -}
    data _⊎_ (A B : Set) : Set where
        inj₁ : A → A ⊎ B
        inj₂ : B → A ⊎ B

    infixr 1 _⊎_

    case-⊎ : ∀ {A B C : Set}
        → (A → C)
        → (B → C)
        → A ⊎ B
        -----------
        → C
    case-⊎ f g (inj₁ x) = f x
    case-⊎ f g (inj₂ y) = g y

    uniq-⊎ : ∀ {A B C : Set} (h : A ⊎ B → C) (w : A ⊎ B) →
        case-⊎ (h ∘ inj₁) (h ∘ inj₂) w ≡ h w
    uniq-⊎ h (inj₁ x) = refl
    uniq-⊎ h (inj₂ y) = refl

    η-⊎ : ∀ {A B : Set} (w : A ⊎ B) → case-⊎ inj₁ inj₂ w ≡ w
    η-⊎ (inj₁ x) = refl
    η-⊎ (inj₂ y) = refl

    ⊥-identityˡ : ∀ {A : Set} → ⊥ ⊎ A ≃ A
    ⊥-identityˡ = record
        {
            to = λ {(inj₂ a) → a};
            from = λ a → inj₂ a;
            from∘to = λ {(inj₂ a) → refl};
            to∘from = λ a → refl
        }

    ⊎-comm : ∀ {A B : Set} → A ⊎ B ≃ B ⊎ A
    ⊎-comm = record
        {
            to = λ {(inj₁ A) → inj₂ A
                  ; (inj₂ B) → inj₁ B};
            from = λ {(inj₁ B) → inj₂ B
                    ; (inj₂ A) → inj₁ A};
            from∘to = λ {(inj₁ x) → refl
                       ; (inj₂ x) → refl};
            to∘from = λ {(inj₁ x) → refl
                       ; (inj₂ x) → refl}
        }

    ⊎-assoc : ∀ {A B C : Set} → (A ⊎ B) ⊎ C ≃ A ⊎ (B ⊎ C)
    ⊎-assoc = record
        {
            to = λ {(inj₁ (inj₁ a)) → inj₁ a
                  ; (inj₁ (inj₂ b)) → inj₂ (inj₁ b)
                  ; (inj₂ c) → inj₂ (inj₂ c)};
            from = λ {(inj₁ a) → inj₁ (inj₁ a)
                    ; (inj₂ (inj₁ b)) → inj₁ (inj₂ b)
                    ; (inj₂ (inj₂ c)) → inj₂ c};
            from∘to = λ {(inj₁ (inj₁ x)) → refl
                       ; (inj₁ (inj₂ x)) → refl
                       ; (inj₂ x) → refl};
            to∘from = λ {(inj₁ x) → refl
                       ; (inj₂ (inj₁ x)) → refl
                       ; (inj₂ (inj₂ x)) → refl}
        }

    ⊥-identityʳ : ∀ {A : Set} → A ⊎ ⊥ ≃ A
    ⊥-identityʳ {A} = ≃-begin
        (A ⊎ ⊥) ≃⟨ ⊎-comm ⟩
        (⊥ ⊎ A) ≃⟨ ⊥-identityˡ ⟩
        A ≃-∎

    {- Equality -}
    record _⇔_ (A B : Set) : Set where
        field
            to   : A → B
            from : B → A

    open _⇔_

    ⇔-ref : ∀ {A : Set} → A ⇔ A
    ⇔-ref = record
        {
            to = λ a → a;
            from = λ a → a
        }

    ⇔-sym : ∀ {A B : Set} → A ⇔ B → B ⇔ A
    ⇔-sym A⇔B = record
        {
            to = from A⇔B;
            from = to A⇔B
        }

    ⇔-trans : ∀ {A B C : Set} → A ⇔ B → B ⇔ C → A ⇔ C
    ⇔-trans A⇔B B⇔C = record
        {
            to = λ a → to B⇔C (to A⇔B a);
            from = λ c → from A⇔B (from B⇔C c)
        }

    ⇔≃× : ∀ {A B : Set} → A ⇔ B ≃ (A → B) × (B → A)
    ⇔≃× = record
        {
            to = λ {A⇔B → ⟨ to A⇔B , from A⇔B ⟩};
            from = λ {x → record { to = proj₁ x; from = proj₂ x } };
            from∘to = λ A⇔B → refl;
            to∘from = λ {⟨ A→B , B→A ⟩ → refl}
        }


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

postulate
  A : Set
  B : A → Set
  a : A

Pi : (A → Set) → Set
Pi B = {x : A} → B x

foo : Pi \ y →  Σ (B y) \ _ → Pi \ z → Σ (y ≡ a → B z) \ _ → B y → B z → A
foo = {!!} , (\ { refl → {!!} }) , {!!}


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

module Library where

open import Data.Product
  using    ( Σ ; Σ-syntax ; _×_ )
  public

open import Function
  using    ()
  renaming ( id   to λ-id
           ; _∘_  to λ-comp
           ; flip to λ-flip )
  public

open import Level
  using    ( Level )
  renaming ( zero to ℓ-zero
           ; suc  to ℓ-suc
           ; _⊔_  to ℓ-max )
  public

open import Relation.Binary.Core
  using    ( Rel )
  public

open import Relation.Unary
  using    ( Pred )
  public

open import Relation.Binary.PropositionalEquality
  using    ( _≡_ ; module ≡-Reasoning )
  renaming ( refl  to ≡-refl
           ; sym   to ≡-sym
           ; trans to ≡-trans)
  public

open ≡-Reasoning
  using    ( _≡⟨_⟩_ )
  renaming ( begin_ to ≡-proof_
           ; _∎     to _≡-qed )
  public


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Instance.Sets where

-- Category of (Agda) Sets, aka (types, functions, pointwise equality with implicit value)
-- Note the (explicit) levels in each

open import Level
open import Relation.Binary
open import Function using (_∘′_) renaming (id to idf)
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)

open import Categories.Category

Sets : ∀ o → Category (suc o) o o
Sets o = record
  { Obj       = Set o
  ; _⇒_       = λ c d → c → d
  ; _≈_       = λ f g → ∀ {x} → f x ≡ g x
  ; id        = idf
  ; _∘_       = _∘′_
  ; assoc     = ≡.refl
  ; sym-assoc = ≡.refl
  ; identityˡ = ≡.refl
  ; identityʳ = ≡.refl
  ; identity² = ≡.refl
  ; equiv     = record
    { refl  = ≡.refl
    ; sym   = λ eq → ≡.sym eq
    ; trans = λ eq₁ eq₂ → ≡.trans eq₁ eq₂
    }
  ; ∘-resp-≈  = resp
  }
  where resp : ∀ {A B C : Set o} {f h : B → C} {g i : A → B} →
                 ({x : B} → f x ≡ h x) →
                 ({x : A} → g x ≡ i x) → {x : A} → f (g x) ≡ h (i x)
        resp {h = h} eq₁ eq₂ = ≡.trans eq₁ (≡.cong h eq₂)


-- Andreas, 2017-04-28, issue #2558 reported by Youyou Cong
-- Size solver assumed invariants that do not hold.

open import Common.Size

data Con (i : Size) : Set where
  c : {j : Size< i} → Con i  -- needed

postulate
  Tms : {i j : Size} → Con i → Con j → Set
  Ty  : (i : Size) {j : Size< i} → Con j → Set

  sub : ∀{i}{j k : Size< i} {l : Size< j} {Γ : Con k} {Δ : Con l} →
          Tms Γ Δ → Ty j Δ → Ty i Γ

  P   : ∀{A : Set} (a : A) → Set

  [][]T : {i : Size} {j : Size< i} {k : Size< ↑ i} {l : Size< ↑ (↑ i)}
          {Γ : Con l} {Δ : Con k} {Σ : Con j} {A : Ty i Σ} →
          (δ : Tms Δ Σ) →
          (σ : Tms Γ Δ) →  -- Γ needed
          P (sub σ (sub δ A))  -- sub σ needed

-- Should pass


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

module container.core where

open import level
open import sum
open import equality
open import function

module _ {li}{I : Set li} where
  -- homsets in the slice category
  _→ⁱ_ : ∀ {lx ly} → (I → Set lx) → (I → Set ly) → Set _
  X →ⁱ Y = (i : I) → X i → Y i

  -- identity of the slice category
  idⁱ : ∀ {lx}{X : I → Set lx} → X →ⁱ X
  idⁱ i x = x

  -- composition in the slice category
  _∘ⁱ_ : ∀ {lx ly lz} {X : I → Set lx}{Y : I → Set ly}{Z : I → Set lz}
       → (Y →ⁱ Z) → (X →ⁱ Y) → (X →ⁱ Z)
  (f ∘ⁱ g) i = f i ∘ g i
  infixl 9 _∘ⁱ_

  -- extensionality
  funext-isoⁱ : ∀ {lx ly} {X : I → Set lx}{Y : (i : I) → X i → Set ly}
              → {f g : (i : I)(x : X i) → Y i x}
              → (∀ i x → f i x ≡ g i x)
              ≅ (f ≡ g)
  funext-isoⁱ {f = f}{g = g}
    = (Π-ap-iso refl≅ λ i → strong-funext-iso)
    ·≅ strong-funext-iso

  funext-invⁱ : ∀ {lx ly} {X : I → Set lx}{Y : (i : I) → X i → Set ly}
              → {f g : (i : I)(x : X i) → Y i x}
              → f ≡ g → ∀ i x → f i x ≡ g i x
  funext-invⁱ = invert funext-isoⁱ

  funextⁱ : ∀ {lx ly} {X : I → Set lx}{Y : (i : I) → X i → Set ly}
          → {f g : (i : I)(x : X i) → Y i x}
          → (∀ i x → f i x ≡ g i x) → f ≡ g
  funextⁱ = apply funext-isoⁱ

-- Definition 1 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
record Container (li la lb : Level) : Set (lsuc (li ⊔ la ⊔ lb)) where
  constructor container
  field
    I : Set li
    A : I → Set la
    B : {i : I} → A i → Set lb
    r : {i : I}{a : A i} → B a → I

  -- Definition 2 in Ahrens, Capriotti and Spadotti (arXiv:1504.02949v1 [cs.LO])
  -- functor associated to this indexed container
  F : ∀ {lx} → (I → Set lx) → I → Set _
  F X i = Σ (A i) λ a → (b : B a) → X (r b)

  F-ap-iso : ∀ {lx ly}{X : I → Set lx}{Y : I → Set ly}
           → (∀ i → X i ≅ Y i)
           → ∀ i → F X i ≅ F Y i
  F-ap-iso isom i = Σ-ap-iso refl≅ λ a
                  → Π-ap-iso refl≅ λ b
                  → isom (r b)

  -- morphism map for the functor F
  imap : ∀ {lx ly}
       → {X : I → Set lx}
       → {Y : I → Set ly}
       → (X →ⁱ Y)
       → (F X →ⁱ F Y)
  imap g i (a , f) = a , λ b → g (r b) (f b)

  -- action of a functor on homotopies
  hmap : ∀ {lx ly}
       → {X : I → Set lx}
       → {Y : I → Set ly}
       → {f g : X →ⁱ Y}
       → (∀ i x → f i x ≡ g i x)
       → (∀ i x → imap f i x ≡ imap g i x)
  hmap p i (a , u) = ap (_,_ a) (funext (λ b → p (r b) (u b)))

  hmap-id : ∀ {lx ly}
          → {X : I → Set lx}
          → {Y : I → Set ly}
          → (f : X →ⁱ Y)
          → ∀ i x
          → hmap (λ i x → refl {x = f i x}) i x ≡ refl
  hmap-id f i (a , u) = ap (ap (_,_ a)) (funext-id _)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Monoid where

open import Cubical.Algebra.Base public
open import Cubical.Algebra.Definitions public

open import Cubical.Algebra.Structures public using (IsMonoid; ismonoid)
open import Cubical.Algebra.Bundles public using (Monoid; mkmonoid; MonoidCarrier)
open import Cubical.Structures.Carrier public

open import Cubical.Algebra.Monoid.Properties public
open import Cubical.Algebra.Monoid.Morphism public
open import Cubical.Algebra.Monoid.MorphismProperties public hiding (isPropIsMonoid)


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

module Test where

open import Cubical.Core.Everything         using (_≡_; Level; Type; Σ; _,_; fst; snd; _≃_; ~_)
open import Cubical.Foundations.Prelude     using (refl; sym; _∙_; cong; transport; subst; funExt; transp; I; i0; i1)
open import Cubical.Foundations.Function    using (_∘_)
open import Cubical.Foundations.Univalence  using (ua)
open import Cubical.Foundations.Isomorphism using (iso; Iso; isoToPath; section; retract)

open import Data.Bool.Base using (Bool; true; false; _∧_)
open import Data.Nat.Base  using (ℕ; zero; suc)
open import Data.Product   using (_×_; proj₁; proj₂)

natrec : (P : ℕ → Type) → P 0 → ((n : ℕ) → P n → P (suc n)) → (n : ℕ) → P n
natrec P z s zero    = z
natrec P z s (suc n) = s n (natrec P z s n)

_+_ : ℕ → ℕ → ℕ
_+_ = λ m → λ n → natrec (λ _ → ℕ) n (λ _ → suc) m

0=0 : 0 ≡ 0
0=0 = refl

suc=suc : (m n : ℕ) → m ≡ n → suc m ≡ suc n
suc=suc m n e = cong suc e

0+n=n : (n : ℕ) → 0 + n ≡ n
0+n=n = natrec (λ k → 0 + k ≡ k) 0=0 (λ n e → suc=suc n n e)

n=0+n : (n : ℕ) → n + 0 ≡ n
n=0+n = natrec (λ k → k + 0 ≡ k) 0=0 λ n e → suc=suc (n + 0) n e


module PosNat where

open import Nats
open import Data.Product
open import Equality

data ℕ⁺ : Set where
  psuc : ℕ → ℕ⁺

_→ℕ : ℕ⁺ → ℕ
psuc  zero   →ℕ = suc  zero
psuc (suc x) →ℕ = suc (psuc x →ℕ)

_⟨_⟩→ℕ⁺ : (a : ℕ) → ∃ (λ x → a ≡ suc x) → ℕ⁺
.(suc x) ⟨ x , refl ⟩→ℕ⁺ = psuc x


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Homotopy.Loopspace where

open import Cubical.Core.Everything

open import Cubical.Data.Nat

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws
open import Cubical.HITs.SetTruncation
open import Cubical.HITs.Truncation hiding (elim2)

{- loop space of a pointed type -}
Ω : {ℓ : Level} → Pointed ℓ → Pointed ℓ
Ω (_ , a) = ((a ≡ a) , refl)

{- n-fold loop space of a pointed type -}
Ω^_ : ∀ {ℓ} → ℕ → Pointed ℓ → Pointed ℓ
(Ω^ 0) p = p
(Ω^ (suc n)) p = Ω ((Ω^ n) p)

{- homotopy Group -}
π : ∀ {ℓ} (n : ℕ) (A : Pointed ℓ) → Type ℓ
π n A = ∥ typ ((Ω^ n) A) ∥ 2

{- loop space map -}
Ω→ : ∀ {ℓA ℓB} {A : Pointed ℓA} {B : Pointed ℓB} (f : A →∙ B) → (Ω A →∙ Ω B)
Ω→ (f , f∙) = (λ p → (sym f∙ ∙ cong f p) ∙ f∙) , cong (λ q → q ∙ f∙) (sym (rUnit (sym f∙))) ∙ lCancel f∙

Eckmann-Hilton : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) (α β : typ ((Ω^ (2 + n)) A))
              → α ∙ β ≡ β ∙ α
Eckmann-Hilton {A = A} n α β i =
  comp (λ k → rUnit (snd ((Ω^ (1 + n)) A)) (~ k) ≡ rUnit (snd ((Ω^ (1 + n)) A)) (~ k)) -- note : rUnit refl := lUnit refl
       (λ k → λ { (i = i0) → (cong (λ x → rUnit x (~ k)) α) ∙ cong (λ x → lUnit x (~ k)) β
               ;  (i = i1) → (cong (λ x → lUnit x (~ k)) β) ∙ cong (λ x → rUnit x (~ k)) α})
       ((λ j → α (j ∧ ~ i) ∙ β (j ∧ i)) ∙ λ j → α (~ i ∨ j) ∙ β (i ∨ j))

{- Homotopy group version -}
π-comp : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → ∥ typ ((Ω^ (suc n)) A) ∥₂
      → ∥ typ ((Ω^ (suc n)) A) ∥₂ → ∥ typ ((Ω^ (suc n)) A) ∥₂
π-comp n = elim2 (λ _ _ → setTruncIsSet) λ p q → ∣ p ∙ q ∣₂

Eckmann-Hilton-π : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) (p q : ∥ typ ((Ω^ (2 + n)) A) ∥₂)
               → π-comp (1 + n) p q ≡ π-comp (1 + n) q p
Eckmann-Hilton-π  n = elim2 (λ x y → isOfHLevelPath 2 setTruncIsSet _ _)
                             λ p q → cong ∣_∣₂ (Eckmann-Hilton n p q)


open import Structure.Operator.Monoid
open import Structure.Setoid
open import Type

module Numeral.Natural.Oper.Summation {ℓᵢ ℓ ℓₑ} {I : Type{ℓᵢ}} {T : Type{ℓ}} {_▫_ : T → T → T} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ monoid : Monoid{T = T}(_▫_) ⦄ where
open Monoid(monoid)

import      Lvl
open import Data.List
open import Data.List.Functions
open import Structure.Function
open import Structure.Operator

∑ : List(I) → (I → T) → T
∑(r) f = foldᵣ(_▫_) id (map f(r))


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

module README where

--------------------------------------------------------------------------------
-- Section 1: Introduction
--------------------------------------------------------------------------------

-- 0, 1, and 2 types
import Data.Empty using (⊥)
import Data.Unit  using (⊤)
import Data.Bool  using (Bool)

-- Dependent Sum and Product
import Data.Sigma using (Σ)
import Data.Pi    using (Π)

-- Disjoint Union
import Data.Sum using (_⊎_)
import Data.Sum.Properties using (sumAsSigma)

-- Definition 1: Path types
import Path using (_≡_)

-- Definition 2: Homotopy Levels
import HLevels using (isContr; isProp; isSet)

-- Definition 3: Fibres
import Function.Fiber using (fiber)

-- Definition 4: Equivalences
import Equiv using (isEquiv; _≃_)

-- Definition 5: Decidable
import Relation.Nullary.Decidable using (Dec)

-- Definition 6: Discrete
import Relation.Nullary.Discrete using (Discrete)
import Relation.Nullary.Discrete.Properties using (Discrete→isSet)

-- Definition 8: Propositional Truncation
import HITs.PropositionalTruncation using (∥_∥)
import HITs.PropositionalTruncation using (rec; rec→set)

--------------------------------------------------------------------------------
-- Section 2: Finiteness Predicates
--------------------------------------------------------------------------------

-- Definition 9: Split Enumerability
import Cardinality.Finite.SplitEnumerable.Container using (ℰ!)

-- Container based definition is isomophic to inductive
import Cardinality.Finite.SplitEnumerable.Isomorphism using (𝕃⇔ℒ⟨ℰ!⟩)

-- Definition 10: Container
import Container using (Container; ⟦_⟧)

-- Definition 11: List
import Container.List using (List)

-- Definition 12: Fin
import Data.Fin.Base using (Fin)

-- Definition 13: Surjections
import Function.Surjective using (_↠!_; _↠_)

-- Lemma 1
import Cardinality.Finite.SplitEnumerable using (ℰ!⇔Fin↠!)

-- Lemma 2
import Function.Surjective.Properties using (Discrete-distrib-surj)

-- Lemma 3
import Cardinality.Finite.SplitEnumerable using (ℰ!⇒Discrete)

-- Definition 14: Manifest Bishop Finiteness
import Cardinality.Finite.ManifestBishop.Container using (ℬ)

-- Container based definition is isomophic to inductive
import Cardinality.Finite.ManifestBishop.Isomorphism using (𝕃⇔ℒ⟨ℬ⟩)

-- Definition 15: Unique Membership
import Container.Membership using (_∈!_)

-- Lemma 4
import Cardinality.Finite.ManifestBishop using (ℬ⇔Fin≃)

-- Definition 16: Cardinal Finiteness
import Cardinality.Finite.Cardinal using (𝒞; 𝒞≃Fin≃)

-- Lemma 5
import Cardinality.Finite.Cardinal using (cardinality)

-- Lemma 6
import Cardinality.Finite.Cardinal using (𝒞⇒Discrete)

-- Definition 17: Manifest Enumerability
import Cardinality.Finite.ManifestEnumerable.Container using (ℰ)

-- Container based definition is isomorphic to inductive
import Cardinality.Finite.ManifestEnumerable.Isomorphism using (𝕃⇔ℒ⟨ℰ⟩)

-- Lemma 7
import Cardinality.Finite.ManifestEnumerable using (ℰ⇔Fin↠)

-- Definition 18: S¹
open import Cubical.HITs.S1 using (S¹)

-- Lemma 8
import Cardinality.Finite.ManifestEnumerable using (ℰ⟨S¹⟩)

-- Definition 19: Kuratowski finite subset
import Algebra.Construct.Free.Semilattice using (𝒦)

-- Definition 20: Membership of 𝒦
import Algebra.Construct.Free.Semilattice.Relation.Unary using (_∈_)

-- Definition 21: Kuratowski finiteness
import Cardinality.Finite.Kuratowski using (𝒦ᶠ)

-- Lemma 9
import Cardinality.Finite.Kuratowski using (isProp𝒦ᶠ)

-- Lemma 10
import Cardinality.Finite.Kuratowski using (𝒦ᶠ⟨S¹⟩)

--------------------------------------------------------------------------------
-- Section 3: Relations Between Each Finiteness Definition
--------------------------------------------------------------------------------

-- Lemma 11
import Cardinality.Finite.ManifestBishop using (ℰ!⇒ℬ)

-- Lemma 12
import Cardinality.Finite.ManifestBishop using (ℬ⇒ℰ!)

-- Lemma 13
import Cardinality.Finite.ManifestEnumerable using (ℰ!⇒ℰ)

-- Lemma 14
import Cardinality.Finite.ManifestEnumerable using (ℰ⇒ℰ!)

-- Lemma 15
import Cardinality.Finite.Cardinal using (ℬ⇒𝒞)

-- Theorem 1
import Cardinality.Finite.Cardinal using (𝒞⇒ℬ)

-- Definition 22: List Permutations
import Data.List.Relation.Binary.Permutation using (_↭_)

-- Lemma 16
import Cardinality.Finite.Kuratowski using (𝒞⇔𝒦×Discrete)

--------------------------------------------------------------------------------
-- Section 4: Relations Between Each Finiteness Definition
--------------------------------------------------------------------------------

-- Lemma 17
import Cardinality.Finite.SplitEnumerable using (ℰ!⟨⊥⟩; ℰ!⟨⊤⟩; ℰ!⟨2⟩)

-- Lemma 18
import Cardinality.Finite.SplitEnumerable using (_|Σ|_)

-- Lemma 19
import Cardinality.Finite.ManifestBishop using (_|Π|_)

-- Lemma 20
import Cardinality.Finite.Cardinal using (𝒞⇒Choice)

-- Resulting closures on 𝒞:
import Cardinality.Finite.Cardinal using
  (_∥Σ∥_; _∥⊎∥_; _∥Π∥_; _∥→∥_; _∥×∥_; _∥⇔∥_; 𝒞⟨⊥⟩; 𝒞⟨⊤⟩; 𝒞⟨Bool⟩)

-- Theorem 2:
import Cardinality.Finite.Cardinal.Category using (finSetCategory)

-- Quotients are effective
import Cubical.HITs.SetQuotients.Properties using (isEquivRel→isEffective)

-- Theorem 3:
import Cardinality.Finite.Cardinal.Category using
  ( finSetHasProducts
  ; finSetHasExp
  ; finSetHasPullbacks
  ; finSetTerminal
  ; finSetInitial
  ; finSetCoeq
  ; module PullbackSurjProofs
  )

-- Same for hSets
import Categories.HSets using
  ( hSetProd
  ; hSetExp
  ; hSetHasPullbacks
  ; hSetTerminal
  ; hSetInitial
  ; hSetCoeq
  ; module PullbackSurjProofs
  )

--------------------------------------------------------------------------------
-- Section 5: Countably Infinite Types
--------------------------------------------------------------------------------

-- Definition 23: Streams
import Codata.Stream using (Stream)

-- Definition 24: Split Countability
import Cardinality.Infinite.Split using (ℰ!)

-- Definition 25: Countability
import Cardinality.Infinite.Split using (ℰ)

-- Lemma 21
import Cardinality.Infinite.Split using (ℰ⇒Discrete)

-- Theorem 4
import Cardinality.Infinite.Split using (_|Σ|_)

-- Theorem 5
import Cardinality.Infinite.Split using (|star|)

--------------------------------------------------------------------------------
-- Section 6: Search
--------------------------------------------------------------------------------

-- Definition 26: Omniscience
import Relation.Nullary.Omniscience using (Omniscient)

-- Definition 27: Exhaustibility
import Relation.Nullary.Omniscience using (Exhaustible)

import Cardinality.Finite.Kuratowski using (𝒦ᶠ⇒Exhaustible)
import Relation.Nullary.Omniscience using (Omniscient→Exhaustible)
import Cardinality.Finite.ManifestEnumerable using (ℰ⇒Omniscient)
import Cardinality.Finite.Kuratowski using (𝒦ᶠ⇒Prop-Omniscient)

import Data.Pauli using (Pauli)
import Data.Pauli using (assoc-·)
import Data.Pauli using (not-spec)


-- Andreas, 2014-08-30, reported by asr
-- All of the following corecursive functions from Data.Stream
-- should pass the termination checker.

{-# OPTIONS --cubical-compatible --guardedness #-}
-- {-# OPTIONS -v term:20 #-}

open import Common.Coinduction
open import Common.Prelude renaming (Nat to ℕ) hiding (_∷_; map)

infixr 5 _∷_

data Stream (A : Set) : Set where
  _∷_ : (x : A) (xs : ∞ (Stream A)) → Stream A

map : ∀ {A B} → (A → B) → Stream A → Stream B
map f (x ∷ xs) = f x ∷ ♯ map f (♭ xs)

zipWith : ∀ {A B C} →
          (A → B → C) → Stream A → Stream B → Stream C
zipWith _∙_ (x ∷ xs) (y ∷ ys) = (x ∙ y) ∷ ♯ zipWith _∙_ (♭ xs) (♭ ys)

drop : ∀ {A} → ℕ → Stream A → Stream A
drop zero    xs       = xs
drop (suc n) (x ∷ xs) = drop n (♭ xs)

repeat : ∀ {A} → A → Stream A
repeat x = x ∷ ♯ repeat x

iterate : ∀ {A} → (A → A) → A → Stream A
iterate f x = x ∷ ♯ iterate f (f x)

-- Interleaves the two streams.

infixr 5 _⋎_

_⋎_ : ∀ {A} → Stream A → Stream A → Stream A
(x ∷ xs) ⋎ ys = x ∷ ♯ (ys ⋎ ♭ xs)

mutual

  -- Takes every other element from the stream, starting with the
  -- first one.

  evens : ∀ {A} → Stream A → Stream A
  evens (x ∷ xs) = x ∷ ♯ odds (♭ xs)

  -- Takes every other element from the stream, starting with the
  -- second one.

  odds : ∀ {A} → Stream A → Stream A
  odds (x ∷ xs) = evens (♭ xs)


------------------------------------------------------------------------------
--  Properties related with lists (using induction on the FOTC lists type)
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Data.List.PropertiesByInductionATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Totality properties

-- See Issue https://github.com/asr/apia/issues/81 .
lengthList-NA : D → Set
lengthList-NA ds = N (length ds)
{-# ATP definition lengthList-NA #-}

lengthList-N : ∀ {xs} → List xs → N (length xs)
lengthList-N = List-ind lengthList-NA A[] h
  where
  postulate A[] : lengthList-NA []
  {-# ATP prove A[] #-}

  postulate h : ∀ a {as} → lengthList-NA as → lengthList-NA (a ∷ as)
  {-# ATP prove h #-}

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

-- See Issue https://github.com/asr/apia/issues/81 .
++-assocA : D → D → D → Set
++-assocA ys zs as = (as ++ ys) ++ zs ≡ as ++ ys ++ zs
{-# ATP definition ++-assocA #-}

++-assoc : ∀ {xs} → List xs → ∀ ys zs → (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs
++-assoc Lxs ys zs = List-ind (++-assocA ys zs) A[] h Lxs
  where
  postulate A[] : ++-assocA ys zs []
  {-# ATP prove A[] #-}

  postulate h : ∀ a {as} → ++-assocA ys zs as → ++-assocA ys zs (a ∷ as)
  {-# ATP prove h #-}


module CoPatWith where

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just    : A -> Maybe A

data _×_ (A B : Set) : Set where
  _,_ : A -> B -> A × B

record CoList (A : Set) : Set where
  constructor inn
  field
    out : Maybe (A × CoList A)

open CoList

module With where

  map : {A B : Set}(f : A -> B)(l : CoList A) -> CoList B
  out (map f l) with out l
  out (map f l) | nothing = nothing
  out (map f l) | just (a , as) = just (f a , map f as)

module NoWith where

  map : {A B : Set}(f : A -> B)(l : CoList A) -> CoList B
  out (map {A = A}{B = B} f l) = map' f l (out l)
    where outmap : (f : A -> B)(l : CoList A)(outl : Maybe (A × CoList A)) -> Maybe (B × CoList B)
          outmap f l nothing = nothing
          outmap f l (just (a , as)) = just (f a , map f as)

module With2 where

  map : {A B : Set}(f : A -> B)(l : CoList A) -> CoList B
  out (map f (inn l)) with l
  out (map f (inn .nothing))         | nothing       = nothing
  out (map f (inn .(just (a , as)))) | just (a , as) = just (f a , map f as)

module NoWith2 where

  map : {A B : Set}(f : A -> B)(l : CoList A) -> CoList B
  out (map {A = A}{B = B} f l) = map' f l (out l)
    where outmap : (f : A -> B)(l : CoList A)(outl : Maybe (A × CoList A)) -> Maybe (B × CoList B)
          outmap f (inn .nothing)         nothing         = nothing
          outmap f (inn .(just (a , as))) (just (a , as)) = just (f a , map f as)


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

module Data.Fin.Indexed.Literals where

-- import Data.Nat as ℕ
-- import Data.Nat.Properties as ℕ
open import Data.Fin.Indexed.Base
open import Literals.Number
-- open import Relation.Nullary
open import Agda.Builtin.Nat renaming (_<_ to _<ᵇ_)
open import Data.Bool
open import Agda.Builtin.Nat using (_<_)

instance
  numberFin : ∀ {n} → Number (Fin n)
  numberFin {n} = record
    { Constraint = λ m → T (m <ᵇ n)
    ; fromNat    = λ m {{pr}} → FinFromℕ {n} m pr
    }


module Data.Fin.Map where

open import Class.Monad
open import Data.Nat
open import Data.Fin
open import Function

DepFinMap : ∀ {a} (n : ℕ) (A : Fin n -> Set a) -> Set a
DepFinMap n A = (k : Fin n) -> A k

FinMap : ∀ {a} (n : ℕ) -> Set a -> Set a
FinMap n A = DepFinMap n (λ _ -> A)

sequenceDepFinMap : ∀ {a n A} {M : Set a -> Set a} {{_ : Monad M}}
  -> DepFinMap n (λ x -> M $ A x) -> M (DepFinMap n A)
sequenceDepFinMap {n = zero} f = return λ ()
sequenceDepFinMap {n = suc n} f = do
  f' <- sequenceDepFinMap $ f ∘ suc
  fzero <- f zero
  return λ
    { zero → fzero
    ; (suc v) → f' v}


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

open import Categories.Category

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

open Category C
open HomReasoning

open import Level

private
  variable
    A B : Obj
    h i : A ⇒ B

record Coequalizer (f g : A ⇒ B) : Set (o ⊔ ℓ ⊔ e) where
  field
    {obj} : Obj
    arr   : B ⇒ obj

    equality   : arr ∘ f ≈ arr ∘ g
    coequalize : h ∘ f ≈ h ∘ g → obj ⇒ cod h
    universal  : ∀ {eq : h ∘ f ≈ h ∘ g} → h ≈ coequalize eq ∘ arr
    unique     : ∀ {eq : h ∘ f ≈ h ∘ g} → h ≈ i ∘ arr → i ≈ coequalize eq


module Numeral.Integer.Relation.Divisibility where

open import Functional
open import Logic.Propositional
import      Numeral.Natural.Relation.Divisibility as ℕ
open import Numeral.Integer
open import Type

_∣_ = (ℕ._∣_) on₂ absₙ
_∤_ = (¬_) ∘₂ (_∣_)


{-# OPTIONS --cubical --no-import-sorts --safe #-}

open import Cubical.Core.Everything
open import Cubical.Algebra.Monoid

module Cubical.Algebra.Monoid.Construct.Opposite {ℓ} (M : Monoid ℓ) where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Prod using (_,_)

open Monoid M

import Cubical.Algebra.Semigroup.Construct.Opposite semigroup as OpSemigroup
open OpSemigroup public hiding (Op-isSemigroup; Sᵒᵖ)

•ᵒᵖ-identityˡ : LeftIdentity ε _•ᵒᵖ_
•ᵒᵖ-identityˡ _ = identityʳ _

•ᵒᵖ-identityʳ : RightIdentity ε _•ᵒᵖ_
•ᵒᵖ-identityʳ _ = identityˡ _

•ᵒᵖ-identity : Identity ε _•ᵒᵖ_
•ᵒᵖ-identity = •ᵒᵖ-identityˡ , •ᵒᵖ-identityʳ

Op-isMonoid : IsMonoid Carrier _•ᵒᵖ_ ε
Op-isMonoid = record
  { isSemigroup = OpSemigroup.Op-isSemigroup
  ; identity    = •ᵒᵖ-identity
  }

Mᵒᵖ : Monoid ℓ
Mᵒᵖ = record { isMonoid = Op-isMonoid }


------------------------------------------------------------------------
-- Well-founded induction
------------------------------------------------------------------------

-- I want universe polymorphism.

open import Relation.Binary

module Induction1.WellFounded {a : Set} (_<_ : Rel a) where

open import Induction1

-- When using well-founded recursion you can recurse arbitrarily, as
-- long as the arguments become smaller, and "smaller" is
-- well-founded.

WfRec : RecStruct a
WfRec P x = ∀ y → y < x → P y

-- The accessibility predicate encodes what it means to be
-- well-founded; if all elements are accessible, then _<_ is
-- well-founded.

data Acc (x : a) : Set₁ where
  acc : (rs : WfRec Acc x) → Acc x

-- Well-founded induction for the subset of accessible elements:

module Some where

  wfRec-builder : SubsetRecursorBuilder Acc WfRec
  wfRec-builder P f x (acc rs) = λ y y<x →
    f y (wfRec-builder P f y (rs y y<x))

  wfRec : SubsetRecursor Acc WfRec
  wfRec = subsetBuild wfRec-builder

-- Well-founded induction for all elements, assuming they are all
-- accessible:

module All (allAcc : ∀ x → Acc x) where

  wfRec-builder : RecursorBuilder WfRec
  wfRec-builder P f x = Some.wfRec-builder P f x (allAcc x)

  wfRec : Recursor WfRec
  wfRec = build wfRec-builder


-- You can use _ in a binding position in notation.
module WildcardNotation where

data Σ (A : Set) (B : A → Set) : Set where
  _,_ : ∀ x → B x → Σ A B

syntax Σ A (λ _ → B) = A × B

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

syntax compose (λ _ → x) (λ _ → y) = x instead-of y
compose : {A B C : Set} → (B → C) → (A → B) → (A → C)
compose f g = λ x → f (g x)

open import Common.Prelude
open import Common.Equality

thm₁ : swap (1 , 2) ≡ (2 , 1)
thm₁ = refl

thm₂ : (a b : Nat) → (5 instead-of a) b ≡ 5
thm₂ a b = refl


open import Agda.Primitive public

variable
 ℓ ℓ' : Level

data _≡_ {X : Set ℓ} : X → X → Set ℓ where
  refl : {x : X} → x ≡ x

ap : {X : Set ℓ} {Y : Set ℓ'} (f : X → Y) {x x' : X} → x ≡ x' → f x ≡ f x'
ap f refl = refl

_∙_ : {X : Set ℓ} {x y z : X} → x ≡ y → y ≡ z → x ≡ z
p ∙ refl = p

yoneda-elem-lc : {X : Set ℓ} {x : X} {A : X → Set ℓ'} (η θ : (y : X) → x ≡ y → A y)
               → η x refl ≡ θ x refl → ∀ y p → η y p ≡ θ y p
yoneda-elem-lc η θ q y refl = ap (λ a → a) q

ext-assoc : {X : Set ℓ} {z t : X} (r : z ≡ t)
          → (λ (x y : X) (p : x ≡ y) (q : y ≡ z) → (p ∙ q) ∙ r)
          ≡ (λ (x y : X) (p : x ≡ y) (q : y ≡ z) → p ∙ (q ∙ r))
ext-assoc {ℓ} {X} {z} {t} = yoneda-elem-lc
                            -- {A = λ - → (x y : X) (p : x ≡ y) (q : y ≡ z) → x ≡ - }
                            (λ z r x y p q → (p ∙ q) ∙ r)
                            (λ z r x y p q → p ∙ (q ∙ r))
                            refl
                            t


import      Lvl
open import Type

module Data.List.Relation.Sublist {ℓ} {T : Type{ℓ}} where

open import Data.List using (List ; ∅ ; _⊰_)
open import Logic

-- Whether a list's elements are contained in another list in order.
-- Examples:
--   [1,2,3] ⊑ [1,2,3]
--   [1,2,3] ⊑ [1,2,3,4]
--   [1,2,3] ⊑ [0,1,2,3]
--   [1,2,3] ⊑ [0,1,10,2,20,3,30]
--   [0,10,20,30] ⊑ [0,1,10,2,20,3,30]
data _⊑_ : List(T) → List(T) → Stmt{ℓ} where
  empty : (∅ ⊑ ∅)
  use   : ∀{x}{l₁ l₂} → (l₁ ⊑ l₂) → ((x ⊰ l₁) ⊑ (x ⊰ l₂))
  skip  : ∀{x}{l₁ l₂} → (l₁ ⊑ l₂) → (l₁       ⊑ (x ⊰ l₂))

-- Whether a list's elements are contained in another list in order while not containing the same sublist.
-- Examples:
--   [1,2,3] ⊏ [1,2,3,4]
--   [1,2,3] ⊏ [0,1,2,3]
--   [1,2,3] ⊏ [0,1,10,2,20,3,30]
data _⊏_ : List(T) → List(T) → Stmt{ℓ} where
  use   : ∀{x}{l₁ l₂} → (l₁ ⊏ l₂) → ((x ⊰ l₁) ⊏ (x ⊰ l₂))
  skip  : ∀{x}{l₁ l₂} → (l₁ ⊑ l₂) → (l₁       ⊏ (x ⊰ l₂))


module MixfixBinders where

postulate
  M      : Set → Set
  return : ∀ {A} → A → M A
  bind   : ∀ {A B} → M A → (A → M B) → M B

infixr 40 bind
syntax bind m (λ x → m′) = x ← m , m′

postulate
  X : Set
  m₁ m₂ m₃ : M X
  f : X → X → X

foo : M X
foo = x₁ ← m₁ ,
      x₂ ← m₂ ,
      x₃ ← m₃ ,
      return (f x₁ (f x₂ x₃))

infixr 10 Σ _,_
syntax Σ A (λ x → B) = Σ x ∈ A , B
data Σ (A : Set)(B : A → Set) : Set where
  _,_ : (x : A) → B x → Σ x ∈ A , B x

infix 50 _≤_
postulate
  _≤_ : X → X → Set
  x₁ x₂ : X
  le : x₁ ≤ x₂

p : Σ x ∈ X , Σ y ∈ X , x ≤ y
p = x₁ , x₂ , le


open import Common.Prelude

pattern [_] x = x ∷ []
pattern tail {x} xs = x ∷ xs

length : ∀ {A} → List A → Nat
length [] = 0
length [ _ ] = 1
length (tail [ _ ]) = 2
length (tail (tail xs)) = 2 + length xs

data Vec (A : Set) : Nat → Set where
  nil : Vec A 0
  cons : ∀ n → A → Vec A n → Vec A (suc n)

pattern _∷v_ {n} x xs = cons n x xs

map : ∀ {A B n} → (A → B) → Vec A n → Vec B n
map f nil = nil
map f (x ∷v xs) = f x ∷v map f xs

data SomeVec (A : Set) : Set where
  someVec : ∀ n → Vec A n → SomeVec A

pattern some {n} xs = someVec n xs

null : ∀ {A} → SomeVec A → Bool
null (some nil)      = true
null (some (_ ∷v _)) = false  -- check that the hidden arg can be instantiated to a dot pattern


------------------------------------------------------------------------------
-- Properties of the Collatz function
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Program.Collatz.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Data.Nat
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityI
open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Data.Nat
open import FOTC.Program.Collatz.Data.Nat.PropertiesI

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

collatzCong : ∀ {m n} → m ≡ n → collatz m ≡ collatz n
collatzCong refl = refl

helper : ∀ {n} → N n → collatz (2' ^ succ₁ n) ≡ collatz (2' ^ n)
helper nzero =
  collatz (2' ^ 1')   ≡⟨ collatzCong (x^1≡x 2-N) ⟩
  collatz 2'          ≡⟨ collatz-even 2-Even ⟩
  collatz (div 2' 2') ≡⟨ collatzCong (div-x-x≡1 2-N S≢0) ⟩
  collatz (1')        ≡⟨ collatzCong (sym (^-0 2')) ⟩
  collatz (2' ^ 0')   ∎

helper (nsucc {n} Nn) =
  collatz (2' ^ succ₁ (succ₁ n))
    ≡⟨ collatzCong prf ⟩
  collatz (succ₁ (succ₁ (2' ^ succ₁ (succ₁ n) ∸ 2')))
    ≡⟨ collatz-even (x-Even→SSx-Even
                       (∸-N (^-N 2-N (nsucc (nsucc Nn))) 2-N)
                       (∸-Even (^-N 2-N (nsucc (nsucc Nn))) 2-N
                               (2^[x+1]-Even (nsucc Nn)) 2-Even)) ⟩
  collatz (div (succ₁ (succ₁ ((2' ^ succ₁ (succ₁ n)) ∸ 2'))) 2')
    ≡⟨ collatzCong (divLeftCong (sym prf)) ⟩
  collatz (div (2' ^ succ₁ (succ₁ n)) 2')
    ≡⟨ collatzCong (div-2^[x+1]-2≡2^x (nsucc Nn)) ⟩
  collatz (2' ^ succ₁ n) ∎
  where
  prf : 2' ^ succ₁ (succ₁ n) ≡ succ₁ (succ₁ (2' ^ succ₁ (succ₁ n) ∸ 2'))
  prf = (+∸2 (^-N 2-N (nsucc (nsucc Nn)))
             (2^x≢0 (nsucc (nsucc Nn)))
             (2^[x+1]≢1 (nsucc Nn)))

collatz-2^x : ∀ {n} → N n → collatz (2' ^ n) ≡ 1'
collatz-2^x nzero =
  collatz (2' ^ 0') ≡⟨ collatzCong (^-0 2') ⟩
  collatz 1'        ≡⟨ collatz-1 ⟩
  1'                ∎

collatz-2^x (nsucc {n} Nn) =
  collatz (2' ^ succ₁ n) ≡⟨ helper Nn ⟩
  collatz (2' ^ n)       ≡⟨ collatz-2^x Nn ⟩
  1'                     ∎


open import Level using () renaming (_⊔_ to _⊔ˡ_)
open import Relation.Binary using (_⇒_; TotalOrder; Reflexive; Symmetric; Transitive; IsEquivalence; IsPreorder; Antisymmetric)

module AKS.Extended {c ℓ₁ ℓ₂} (≤-totalOrder : TotalOrder c ℓ₁ ℓ₂) where

open TotalOrder ≤-totalOrder
  using (_≈_; _≤_; total; isEquivalence)
  renaming (Carrier to C; refl to ≤-refl; reflexive to ≤-reflexive; trans to ≤-trans )
open IsEquivalence isEquivalence
  using ()
  renaming (refl to ≈-refl; sym to ≈-sym; trans to ≈-trans)

data Extended : Set c where
  -∞  : Extended
  ⟨_⟩ : C → Extended

infixl 4 _≈ᵉ_
data _≈ᵉ_ : Extended → Extended → Set (c ⊔ˡ ℓ₁) where
  -∞≈ : -∞ ≈ᵉ -∞
  ⟨_⟩ : ∀ {b t} → b ≈ t → ⟨ b ⟩ ≈ᵉ ⟨ t ⟩

≈ᵉ-refl : Reflexive _≈ᵉ_
≈ᵉ-refl { -∞} = -∞≈
≈ᵉ-refl {⟨ _ ⟩} = ⟨ ≈-refl ⟩

≈ᵉ-sym : Symmetric _≈ᵉ_
≈ᵉ-sym -∞≈ = -∞≈
≈ᵉ-sym ⟨ x≈y ⟩ = ⟨ ≈-sym x≈y ⟩

≈ᵉ-trans : Transitive _≈ᵉ_
≈ᵉ-trans -∞≈ -∞≈ = -∞≈
≈ᵉ-trans ⟨ x≈y ⟩ ⟨ y≈z ⟩ = ⟨ ≈-trans x≈y y≈z ⟩

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

infixl 4 _≤ᵉ_
data _≤ᵉ_ : Extended → Extended → Set (c ⊔ˡ ℓ₂) where
  -∞≤_ : ∀ t → -∞ ≤ᵉ t
  ⟨_⟩  : ∀ {b t} → b ≤ t → ⟨ b ⟩ ≤ᵉ ⟨ t ⟩

≤ᵉ-refl : Reflexive _≤ᵉ_
≤ᵉ-refl { -∞} = -∞≤ -∞
≤ᵉ-refl {⟨ _ ⟩} = ⟨ ≤-refl ⟩

≤ᵉ-reflexive : _≈ᵉ_ ⇒ _≤ᵉ_
≤ᵉ-reflexive -∞≈ = -∞≤ -∞
≤ᵉ-reflexive ⟨ x≈y ⟩ = ⟨ ≤-reflexive x≈y ⟩

≤ᵉ-trans : Transitive _≤ᵉ_
≤ᵉ-trans {x} {y} {z} (-∞≤ _) (-∞≤ t) = -∞≤ t
≤ᵉ-trans {x} {y} {z} (-∞≤ _) ⟨ _ ⟩   = -∞≤ z
≤ᵉ-trans {x} {y} {z} ⟨ x≤y ⟩ ⟨ y≤z ⟩ = ⟨ (≤-trans x≤y y≤z) ⟩

≤ᵉ-isPreorder : IsPreorder _≈ᵉ_ _≤ᵉ_
≤ᵉ-isPreorder = record { isEquivalence = ≈ᵉ-isEquivalence ; reflexive = ≤ᵉ-reflexive ; trans = ≤ᵉ-trans }

module ≤ᵉ-Reasoning where
   open import Relation.Binary.Reasoning.Base.Double ≤ᵉ-isPreorder public


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

module container.equality where

open import level
open import sum
open import equality.core
open import function.isomorphism
open import function.extensionality
open import container.core
open import container.fixpoint

module Equality {li la lb lx}
                (c : Container li la lb)
                (fp : Fixpoint c lx) where
  open Container c
  open Fixpoint fp

  substX : {i : I}{a a' : A i}(p : a ≡ a')(b : B a)
         → X (r (subst B p b)) → X (r b)
  substX refl _ x = x

  substX-β : ∀ {i} {a a' : A i}
             (f : (b : B a) → X (r b))
             (f' : (b : B a') → X (r b))
             (p : a ≡ a')
           → (subst (λ a → (b : B a) → X (r b)) p f ≡ f')
           ≅ ((b : B a) → f b ≡ substX p b (f' (subst B p b)))
  substX-β f f' refl = sym≅ strong-funext-iso

  -- structural equality for container fixpoints
  I-≡ : Set (li ⊔ lx)
  I-≡ = Σ I λ i → X i × X i

  A-≡ : I-≡ → Set la
  A-≡ (_ , u , v) = head u ≡ head v

  B-≡ : {j : I-≡} → A-≡ j → Set lb
  B-≡ {_ , u , _} _ = B (head u)

  r-≡ : {j : I-≡}{p : A-≡ j} → B-≡ p → I-≡
  r-≡ {i , u , v}{p} b = r b , tail u b , substX p b (tail v (subst B p b))

  equality : Container _ _ _
  equality = record
    { I = I-≡
    ; A = A-≡
    ; B = B-≡
    ; r = (λ {j p} → r-≡ {j} {p}) }