module 120-natural-induction-necessary where

open import 010-false-true
open import 020-equivalence
open import 100-natural

-- We prove that the induction axiom is necessary.

-- Peano axioms without induction.

record NaturalWithoutInduction
  {M : Set}
  (zero : M)
  (suc : M -> M)
  (_==_ : M -> M -> Set)
  : Set1 where

  -- axioms
  field
    equiv : Equivalence _==_
    sucn!=zero : ∀ {r} -> suc r == zero -> False
    sucinjective : ∀ {r s} -> suc r == suc s -> r == s
    cong : ∀ {r s} -> r == s -> suc r == suc s
    not-induction :
      ((p : M -> Set) -> p zero -> (∀ n -> p n -> p (suc n)) -> ∀ n -> p n)
      -> False

  open Equivalence equiv public

-- Construct a model, and prove it satisfies NaturalWithoutInduction
-- but not Natural. To do this, we add an extra zero.

data M : Set where
  zero1 : M
  zero2 : M
  suc : M -> M

thm-M-is-natural-without-induction : NaturalWithoutInduction zero1 suc _≡_
thm-M-is-natural-without-induction = record {
  equiv = thm-≡-is-equivalence;
  sucn!=zero = sucn!=zero;
  sucinjective = sucinjective;
  cong = cong;
  not-induction = not-induction
  }
  where
    sucn!=zero : ∀ {r} -> suc r ≡ zero1 -> False
    sucn!=zero ()
    sucinjective : ∀ {r s} -> suc r ≡ suc s -> r ≡ s
    sucinjective refl = refl
    cong : ∀ {r s} -> r ≡ s -> suc r ≡ suc s
    cong refl = refl
    -- To prove that induction fails, we test the property "is a
    -- successor of zero1 but not of zero2". This holds for zero1 (the
    -- base case), and it also holds for every successor of n if it
    -- holds for n, but it does not hold for zero2 (or for any of its
    -- successors).
    not-induction :
      ((p : M -> Set) -> p zero1 -> (∀ n -> p n -> p (suc n)) -> ∀ n -> p n)
      -> False
    not-induction induction = induction p base hypothesis zero2
      where
        -- Property "is a successor of zero1 but not a successor of zero2".
        p : M -> Set
        p zero1 = True  -- true for zero1
        p zero2 = False -- false (no proof) for zero2
        p (suc n) = p n -- true for successor of n if and only if true for n

        -- Base case is trivial.
        base : p zero1
        base = trivial

        -- Induction hypothesis follows by application of "p n" itself
        -- due to the recursive definition of p.
        hypothesis : ∀ n -> p n -> p (suc n)
        hypothesis n pn = pn

-- To round this off, we explicitly prove that M is not natural.

thm-M-is-not-natural : (Natural zero1 suc _≡_) -> False
thm-M-is-not-natural nat =
  (NaturalWithoutInduction.not-induction thm-M-is-natural-without-induction)
  (Natural.induction nat)


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

module Cubical.Structures.Group.Morphism where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Structures.Group.Base

private
  variable
    ℓ ℓ' : Level

-- The following definition of GroupHom and GroupEquiv are level-wise heterogeneous.
-- This allows for example to deduce that G ≡ F from a chain of isomorphisms
-- G ≃ H ≃ F, even if H does not lie in the same level as G and F.

isGroupHom : (G : Group {ℓ}) (H : Group {ℓ'}) (f : ⟨ G ⟩ → ⟨ H ⟩) → Type _
isGroupHom G H f = (x y : ⟨ G ⟩) → f (x G.+ y) ≡ (f x H.+ f y) where
  module G = Group G
  module H = Group H

record GroupHom (G : Group {ℓ}) (H : Group {ℓ'}) : Type (ℓ-max ℓ ℓ') where
  constructor grouphom

  field
    fun : ⟨ G ⟩ → ⟨ H ⟩
    isHom : isGroupHom G H fun

record GroupEquiv (G : Group {ℓ}) (H : Group {ℓ'}) : Type (ℓ-max ℓ ℓ') where
  constructor groupequiv

  field
    eq : ⟨ G ⟩ ≃ ⟨ H ⟩
    isHom : isGroupHom G H (equivFun eq)

  hom : GroupHom G H
  hom = grouphom (equivFun eq) isHom


module Nats.Add.Invert where

open import Equality
open import Nats
open import Nats.Add.Comm
open import Function

------------------------------------------------------------------------
-- internal stuffs

private

  lemma′ : ∀ a b → (suc a ≡ suc b) → (a ≡ b)
  lemma′ _ _ refl = refl

  lemma : ∀ a b → (suc (a + suc a) ≡ suc (b + suc b)) → (a + a ≡ b + b)
  lemma a b
    rewrite nat-add-comm a $ suc a
          | nat-add-comm b $ suc b
            = lemma′ (a + a) (b + b) ∘ lemma′ (suc $ a + a) (suc $ b + b)

  +-invert : ∀ a b → (a + a ≡ b + b) → a ≡ b
  +-invert zero zero ev = refl
  +-invert zero (suc b) ()
  +-invert (suc a) zero ()
  +-invert (suc a) (suc b) = cong suc ∘ +-invert a b ∘ lemma a b

------------------------------------------------------------------------
-- public aliases

nat-add-invert : ∀ a b → (a + a ≡ b + b) → a ≡ b
nat-add-invert = +-invert

nat-add-invert-1 : ∀ a b → (suc a ≡ suc b) → (a ≡ b)
nat-add-invert-1 = lemma′


------------------------------------------------------------------------------
-- Proving mirror (mirror t) = t using a list of trees
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Mirror.MirrorListSL where

open import Algebra
open import Function
open import Data.List hiding ( reverse )
open import Data.List.Properties
open import Data.Product hiding ( map )

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

module LM {A : Set} = Monoid (++-monoid A)

------------------------------------------------------------------------------
-- Auxiliary functions

reverse : {A : Set} → List A → List A
reverse []       = []
reverse (x ∷ xs) = reverse xs ++ x ∷ []

++-rightIdentity : {A : Set}(xs : List A) → xs ++ [] ≡ xs
++-rightIdentity = proj₂ LM.identity

reverse-++ : {A : Set}(xs ys : List A) →
             reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++ [] ys       = sym (++-rightIdentity (reverse ys))
reverse-++ (x ∷ xs) [] = cong (λ x' → reverse x' ++ x ∷ [])
                              (++-rightIdentity xs)
reverse-++ (x ∷ xs) (y ∷ ys) =
  begin
    reverse (xs ++ y ∷ ys) ++ x ∷ []
      ≡⟨ cong (λ x' → x' ++ x ∷ []) (reverse-++ xs (y ∷ ys)) ⟩
    (reverse (y ∷ ys) ++ reverse xs) ++ x ∷ []
      ≡⟨ LM.assoc (reverse (y ∷ ys)) (reverse xs) (x ∷ []) ⟩
    reverse (y ∷ ys) ++ reverse (x ∷ xs)
  ∎

------------------------------------------------------------------------------
-- The rose tree type.
data Tree (A : Set) : Set where
  tree : A → List (Tree A) → Tree A

------------------------------------------------------------------------------
-- The mirror function.

{-# TERMINATING #-}
mirror : {A : Set} → Tree A → Tree A
mirror (tree a ts) = tree a (reverse (map mirror ts))

-- The proof of the property.
mirror-involutive : {A : Set} → (t : Tree A) → mirror (mirror t) ≡ t
helper            : {A : Set} → (ts : List (Tree A)) →
                    reverse (map mirror (reverse (map mirror ts))) ≡ ts

mirror-involutive (tree a []) = refl
mirror-involutive (tree a (t ∷ ts)) =
  begin
    tree a (reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ [])))
      ≡⟨ cong (tree a) (helper (t ∷ ts)) ⟩
    tree a (t ∷ ts)
  ∎

helper [] = refl
helper (t ∷ ts) =
  begin
    reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ []))
     ≡⟨ cong reverse
             (map-++-commute mirror (reverse (map mirror ts)) (mirror t ∷ []))
     ⟩
    reverse (map mirror (reverse (map mirror ts)) ++
            (map mirror (mirror t ∷ [])))
      ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                    (map mirror (mirror t ∷ [])))) ≡ x)
               (reverse-++ (map mirror (reverse (map mirror ts)))
                           (map mirror (mirror t ∷ [])))
               refl
      ⟩
    reverse (map mirror (mirror t ∷ [])) ++
    reverse (map mirror (reverse (map mirror ts)))
      ≡⟨ refl ⟩
    mirror (mirror t) ∷ reverse (map mirror (reverse (map mirror ts)))
      ≡⟨ cong (flip _∷_ (reverse (map mirror (reverse (map mirror ts)))))
              (mirror-involutive t)
      ⟩
    t ∷ reverse (map mirror (reverse (map mirror ts)))
      ≡⟨ cong (_∷_ t) (helper ts) ⟩
    t ∷ ts
  ∎


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

module LogicalFramework.Existential where

module LF where
  postulate
    D : Set

    -- Disjunction.
    _∨_  : Set → Set → Set
    inj₁ : {A B : Set} → A → A ∨ B
    inj₂ : {A B : Set} → B → A ∨ B
    case : {A B C : Set} → (A → C) → (B → C) → A ∨ B → C

    -- The existential quantifier type on D.
    ∃       : (A : D → Set) → Set
    _,_     : {A : D → Set}(t : D) → A t → ∃ A
    ∃-proj₁ : {A : D → Set} → ∃ A → D
    ∃-proj₂ : {A : D → Set}(h : ∃ A) → A (∃-proj₁ h)
    ∃-elim  : {A : D → Set}{B : Set} → ∃ A → (∀ {x} → A x → B) → B

  syntax ∃ (λ x → e) = ∃[ x ] e

  module FOL-Examples where
    -- Using the projections.
    ∃∀₁ : {A : D → D → Set} → ∃[ x ](∀ y → A x y) → ∀ y → ∃[ x ] A x y
    ∃∀₁ h y = ∃-proj₁ h , (∃-proj₂ h) y

    ∃∨₁ : {A B : D → Set} → ∃[ x ](A x ∨ B x) → (∃[ x ] A x) ∨ (∃[ x ] B x)
    ∃∨₁ h = case (λ Ax → inj₁ (∃-proj₁ h , Ax))
                 (λ Bx → inj₂ (∃-proj₁ h , Bx))
                 (∃-proj₂ h)

    -- Using the elimination.
    ∃∀₂ : {A : D → D → Set} → ∃[ x ](∀ y → A x y) → ∀ y → ∃[ x ] A x y
    ∃∀₂ h y = ∃-elim h (λ {x} ah → x , ah y)

    ∃∨₂ : {A B : D → Set} → ∃[ x ](A x ∨ B x) → (∃[ x ] A x) ∨ (∃[ x ] B x)
    ∃∨₂ h = ∃-elim h (λ {x} ah → case (λ Ax → inj₁ (x , Ax))
                                      (λ Bx → inj₂ (x , Bx))
                                      ah)

  module NonFOL-Examples where

    -- Using the projections.
    non-FOL₁ : {A : D → Set} → ∃ A → D
    non-FOL₁ h = ∃-proj₁ h

    -- Using the elimination.
    non-FOL₂ : {A : D → Set} → ∃ A → D
    non-FOL₂ h = ∃-elim h (λ {x} _ → x)

module Inductive where

  open import Common.FOL.FOL

  -- The existential proyections.
  ∃-proj₁ : ∀ {A} → ∃ A → D
  ∃-proj₁ (x , _) = x

  ∃-proj₂ : ∀ {A} → (h : ∃ A) → A (∃-proj₁ h)
  ∃-proj₂ (_ , Ax) = Ax

  -- The existential elimination.
  ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ {x} → A x → B) → B
  ∃-elim (_ , Ax) h = h Ax

  module FOL-Examples where
    -- Using the projections.
    ∃∀₁ : {A : D → D → Set} → ∃[ x ](∀ y → A x y) → ∀ y → ∃[ x ] A x y
    ∃∀₁ h y = ∃-proj₁ h , (∃-proj₂ h) y

    ∃∨₁ : {A B : D → Set} → ∃[ x ](A x ∨ B x) → (∃[ x ] A x) ∨ (∃[ x ] B x)
    ∃∨₁ h = case (λ Ax → inj₁ (∃-proj₁ h , Ax))
                 (λ Bx → inj₂ (∃-proj₁ h , Bx))
                 (∃-proj₂ h)

    -- Using the elimination.
    ∃∀₂ : {A : D → D → Set} → ∃[ x ](∀ y → A x y) → ∀ y → ∃[ x ] A x y
    ∃∀₂ h y = ∃-elim h (λ {x} ah → x , ah y)

    ∃∨₂ : {A B : D → Set} → ∃[ x ](A x ∨ B x) → (∃[ x ] A x) ∨ (∃[ x ] B x)
    ∃∨₂ h = ∃-elim h (λ {x} ah → case (λ Ax → inj₁ (x , Ax))
                                      (λ Bx → inj₂ (x , Bx))
                                      ah)

    -- Using pattern matching.
    ∃∀₃ : {A : D → D → Set} → ∃[ x ](∀ y → A x y) → ∀ y → ∃[ x ] A x y
    ∃∀₃ (x , Ax) y = x , Ax y

    ∃∨₃ : {A B : D → Set} → ∃[ x ](A x ∨ B x) → (∃[ x ] A x) ∨ (∃[ x ] B x)
    ∃∨₃ (x , inj₁ Ax) = inj₁ (x , Ax)
    ∃∨₃ (x , inj₂ Bx) = inj₂ (x , Bx)

  module NonFOL-Examples where

    -- Using the projections.
    non-FOL₁ : {A : D → Set} → ∃ A → D
    non-FOL₁ h = ∃-proj₁ h

    -- Using the elimination.
    non-FOL₂ : {A : D → Set} → ∃ A → D
    non-FOL₂ h = ∃-elim h (λ {x} _ → x)

    -- Using the pattern matching.
    non-FOL₃ : {A : D → Set} → ∃ A → D
    non-FOL₃ (x , _) = x


------------------------------------------------------------------------
-- The Agda standard library
--
-- The identity function
------------------------------------------------------------------------

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

module Function.Construct.Identity where

open import Data.Product using (_,_)
open import Function using (id)
open import Function.Bundles
import Function.Definitions as Definitions
import Function.Structures as Structures
open import Level
open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_; setoid)

private
  variable
    a ℓ : Level
    A : Set a

------------------------------------------------------------------------
-- Properties

module _ (_≈_ : Rel A ℓ) where

  open Definitions _≈_ _≈_

  injective : Injective id
  injective = id

  surjective : Reflexive _≈_ → Surjective id
  surjective refl x = x , refl

  bijective : Reflexive _≈_ → Bijective id
  bijective refl = injective , surjective refl

  inverseˡ : Reflexive _≈_ → Inverseˡ id id
  inverseˡ refl x = refl

  inverseʳ : Reflexive _≈_ → Inverseʳ id id
  inverseʳ refl x = refl

  inverseᵇ : Reflexive _≈_ → Inverseᵇ id id
  inverseᵇ refl = inverseˡ refl , inverseʳ refl

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

module _ {_≈_ : Rel A ℓ} (isEq : IsEquivalence _≈_) where

  open Structures _≈_ _≈_
  open IsEquivalence isEq

  isCongruent : IsCongruent id
  isCongruent = record
    { cong           = id
    ; isEquivalence₁ = isEq
    ; isEquivalence₂ = isEq
    }

  isInjection : IsInjection id
  isInjection = record
    { isCongruent = isCongruent
    ; injective   = injective _≈_
    }

  isSurjection : IsSurjection id
  isSurjection = record
    { isCongruent = isCongruent
    ; surjective  = surjective _≈_ refl
    }

  isBijection : IsBijection id
  isBijection = record
    { isInjection = isInjection
    ; surjective  = surjective _≈_ refl
    }

  isLeftInverse : IsLeftInverse id id
  isLeftInverse = record
    { isCongruent = isCongruent
    ; cong₂       = id
    ; inverseˡ    = inverseˡ _≈_ refl
    }

  isRightInverse : IsRightInverse id id
  isRightInverse = record
    { isCongruent = isCongruent
    ; cong₂       = id
    ; inverseʳ    = inverseʳ _≈_ refl
    }

  isInverse : IsInverse id id
  isInverse = record
    { isLeftInverse = isLeftInverse
    ; inverseʳ      = inverseʳ _≈_ refl
    }

------------------------------------------------------------------------
-- Setoid bundles

module _ (S : Setoid a ℓ) where

  open Setoid S

  injection : Injection S S
  injection = record
    { f         = id
    ; cong      = id
    ; injective = injective _≈_
    }

  surjection : Surjection S S
  surjection = record
    { f          = id
    ; cong       = id
    ; surjective = surjective _≈_ refl
    }

  bijection : Bijection S S
  bijection = record
    { f         = id
    ; cong      = id
    ; bijective = bijective _≈_ refl
    }

  equivalence : Equivalence S S
  equivalence = record
    { f     = id
    ; g     = id
    ; cong₁ = id
    ; cong₂ = id
    }

  leftInverse : LeftInverse S S
  leftInverse = record
    { f        = id
    ; g        = id
    ; cong₁    = id
    ; cong₂    = id
    ; inverseˡ = inverseˡ _≈_ refl
    }

  rightInverse : RightInverse S S
  rightInverse = record
    { f        = id
    ; g        = id
    ; cong₁    = id
    ; cong₂    = id
    ; inverseʳ = inverseʳ _≈_ refl
    }

  inverse : Inverse S S
  inverse = record
    { f       = id
    ; f⁻¹     = id
    ; cong₁   = id
    ; cong₂   = id
    ; inverse = inverseᵇ _≈_ refl
    }

------------------------------------------------------------------------
-- Propositional bundles

module _ (A : Set a) where

  id-↣ : A ↣ A
  id-↣ = injection (setoid A)

  id-↠ : A ↠ A
  id-↠ = surjection (setoid A)

  id-⤖ : A ⤖ A
  id-⤖ = bijection (setoid A)

  id-⇔ : A ⇔ A
  id-⇔ = equivalence (setoid A)

  id-↩ : A ↩ A
  id-↩ = leftInverse (setoid A)

  id-↪ : A ↪ A
  id-↪ = rightInverse (setoid A)

  id-↔ : A ↔ A
  id-↔ = inverse (setoid A)


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

module 04-inductive-types where

import 03-natural-numbers
open 03-natural-numbers public

-- Section 4.2 The unit type

-- Definition 4.2.1

data unit : UU lzero where
  star : unit

𝟙 = unit

ind-unit : {i : Level} {P : unit → UU i} → P star → ((x : unit) → P x)
ind-unit p star = p

-- Section 4.3 The empty type

-- Definition 4.3.1

data empty : UU lzero where

𝟘 = empty

ind-empty : {i : Level} {P : empty → UU i} → ((x : empty) → P x)
ind-empty ()

ex-falso : {i : Level} {P : empty →  UU i} → ((x : empty) → P x)
ex-falso = ind-empty

ex-falso' : {i : Level} {A : UU i} → empty → A
ex-falso' = ex-falso

-- Definition 4.3.2

¬ : {i : Level} → UU i → UU i
¬ A = A → empty

-- Section 4.4 The booleans

-- Definition 4.4.1

data bool : UU lzero where
  true false : bool

-- Example 4.4.2

neg-𝟚 : bool → bool
neg-𝟚 true = false
neg-𝟚 false = true

conjunction-𝟚 : bool → (bool → bool)
conjunction-𝟚 true true = true
conjunction-𝟚 true false = false
conjunction-𝟚 false true = false
conjunction-𝟚 false false = false

disjunction-𝟚 : bool → (bool → bool)
disjunction-𝟚 true true = true
disjunction-𝟚 true false = true
disjunction-𝟚 false true = true
disjunction-𝟚 false false = false

-- Section 4.5 Coproducts and the type of integers

-- Definition 4.5.1

data coprod {i j : Level} (A : UU i) (B : UU j) : UU (i ⊔ j)  where
  inl : A → coprod A B
  inr : B → coprod A B

ind-coprod : {i j k : Level} {A : UU i} {B : UU j} (C : coprod A B → UU k) →
  ((x : A) → C (inl x)) → ((y : B) → C (inr y)) →
  (t : coprod A B) → C t
ind-coprod C f g (inl x) = f x
ind-coprod C f g (inr x) = g x

-- Definition 4.5.2

-- The type of integers

ℤ : UU lzero
ℤ = coprod ℕ (coprod unit ℕ)

-- Inclusion of the negative integers

in-neg : ℕ → ℤ
in-neg n = inl n

-- Negative one

neg-one-ℤ : ℤ
neg-one-ℤ = in-neg zero-ℕ

-- Zero

zero-ℤ : ℤ
zero-ℤ = inr (inl star)

-- One

one-ℤ : ℤ
one-ℤ = inr (inr zero-ℕ)

-- Inclusion of the positive integers

in-pos : ℕ → ℤ
in-pos n = inr (inr n)

-- Lemma 4.5.3

{- We prove an induction principle for the integers. -}

ind-ℤ : {i : Level} (P : ℤ → UU i) → P neg-one-ℤ → ((n : ℕ) → P (inl n) → P (inl (succ-ℕ n))) → P zero-ℤ → P one-ℤ → ((n : ℕ) → P (inr (inr (n))) → P (inr (inr (succ-ℕ n)))) → (k : ℤ) → P k
ind-ℤ P p-1 p-S p0 p1 pS (inl zero-ℕ) = p-1
ind-ℤ P p-1 p-S p0 p1 pS (inl (succ-ℕ x)) = p-S x (ind-ℤ P p-1 p-S p0 p1 pS (inl x))
ind-ℤ P p-1 p-S p0 p1 pS (inr (inl star)) = p0
ind-ℤ P p-1 p-S p0 p1 pS (inr (inr zero-ℕ)) = p1
ind-ℤ P p-1 p-S p0 p1 pS (inr (inr (succ-ℕ x))) = pS x (ind-ℤ P p-1 p-S p0 p1 pS (inr (inr (x))))

-- Definition 4.5.4

succ-ℤ : ℤ → ℤ
succ-ℤ (inl zero-ℕ) = zero-ℤ
succ-ℤ (inl (succ-ℕ x)) = inl x
succ-ℤ (inr (inl star)) = one-ℤ
succ-ℤ (inr (inr x)) = inr (inr (succ-ℕ x))

-- Section 4.6 Dependent pair types

-- Definition 4.6.1

data Σ {i j : Level} (A : UU i) (B : A → UU j) : UU (i ⊔ j) where
  pair : (x : A) → (B x → Σ A B)

ind-Σ : {i j k : Level} {A : UU i} {B : A → UU j} {C : Σ A B → UU k} →
  ((x : A) (y : B x) → C (pair x y)) → ((t : Σ A B) → C t)
ind-Σ f (pair x y) = f x y

-- Definition 4.6.2

pr1 : {i j : Level} {A : UU i} {B : A → UU j} → Σ A B → A
pr1 (pair a b) = a

pr2 : {i j : Level} {A : UU i} {B : A → UU j} → (t : Σ A B) → B (pr1 t)
pr2 (pair a b) = b

-- Section 4.7 Cartesian products

-- Definition 4.7.1

prod : {i j : Level} (A : UU i) (B : UU j) → UU (i ⊔ j)
prod A B = Σ A (λ a → B)

pair' :
  {i j : Level} {A : UU i} {B : UU j} → A → B → prod A B
pair' = pair

_×_ :  {i j : Level} (A : UU i) (B : UU j) → UU (i ⊔ j)
A × B = prod A B

-- Exercises

-- Exercise 4.2

{- In this exercise we were asked to show that (A + ¬A) implies (¬¬A → A). In
   other words, we get double negation elimination for the types that are
   decidable. -}

is-decidable : {l : Level} (A : UU l) → UU l
is-decidable A = coprod A (¬ A)

double-negation-elim-is-decidable :
  {i : Level} (A : UU i) → is-decidable A → (¬ (¬ A) → A)
double-negation-elim-is-decidable A (inl x) p = x
double-negation-elim-is-decidable A (inr x) p = ind-empty (p x)

neg-triple-neg : {l : Level} (A : UU l) → (¬ (¬ (¬ A))) → (¬ A)
neg-triple-neg A f a = f (λ g → g a)

-- Exercise 4.3

exclusive-disjunction-𝟚 : bool → (bool → bool)
exclusive-disjunction-𝟚 true true = false
exclusive-disjunction-𝟚 true false = true
exclusive-disjunction-𝟚 false true = true
exclusive-disjunction-𝟚 false false = false

implication-𝟚 : bool → (bool → bool)
implication-𝟚 true true = true
implication-𝟚 true false = false
implication-𝟚 false true = true
implication-𝟚 false false = true

bi-implication-𝟚 : bool → (bool → bool)
bi-implication-𝟚 true true = true
bi-implication-𝟚 true false = false
bi-implication-𝟚 false true = false
bi-implication-𝟚 false false = true

peirce-arrow-𝟚 : bool → (bool → bool)
peirce-arrow-𝟚 true true = false
peirce-arrow-𝟚 true false = false
peirce-arrow-𝟚 false true = false
peirce-arrow-𝟚 false false = true

sheffer-stroke-𝟚 : bool → (bool → bool)
sheffer-stroke-𝟚 true true = false
sheffer-stroke-𝟚 true false = true
sheffer-stroke-𝟚 false true = true
sheffer-stroke-𝟚 false false = true

-- Exercise 4.4

pred-ℤ : ℤ → ℤ
pred-ℤ (inl x) = inl (succ-ℕ x)
pred-ℤ (inr (inl star)) = inl zero-ℕ
pred-ℤ (inr (inr zero-ℕ)) = inr (inl star)
pred-ℤ (inr (inr (succ-ℕ x))) = inr (inr x)

-- Exercise 4.5

-- Addition on ℤ

add-ℤ : ℤ → ℤ → ℤ
add-ℤ (inl zero-ℕ) l = pred-ℤ l
add-ℤ (inl (succ-ℕ x)) l = pred-ℤ (add-ℤ (inl x) l)
add-ℤ (inr (inl star)) l = l
add-ℤ (inr (inr zero-ℕ)) l = succ-ℤ l
add-ℤ (inr (inr (succ-ℕ x))) l = succ-ℤ (add-ℤ (inr (inr x)) l)

-- The negative of an integer

neg-ℤ : ℤ → ℤ
neg-ℤ (inl x) = inr (inr x)
neg-ℤ (inr (inl star)) = inr (inl star)
neg-ℤ (inr (inr x)) = inl x

-- Multiplication on ℤ

mul-ℤ : ℤ → ℤ → ℤ
mul-ℤ (inl zero-ℕ) l = neg-ℤ l
mul-ℤ (inl (succ-ℕ x)) l = add-ℤ (neg-ℤ l) (mul-ℤ (inl x) l)
mul-ℤ (inr (inl star)) l = zero-ℤ
mul-ℤ (inr (inr zero-ℕ)) l = l
mul-ℤ (inr (inr (succ-ℕ x))) l = add-ℤ l (mul-ℤ (inr (inr x)) l)

-- Exercise 4.6

Fibonacci-ℤ : ℤ → ℤ
Fibonacci-ℤ (inl zero-ℕ) = one-ℤ
Fibonacci-ℤ (inl (succ-ℕ zero-ℕ)) = neg-one-ℤ
Fibonacci-ℤ (inl (succ-ℕ (succ-ℕ x))) =
  add-ℤ (Fibonacci-ℤ (inl x)) (neg-ℤ (Fibonacci-ℤ (inl (succ-ℕ x))))
Fibonacci-ℤ (inr (inl star)) = zero-ℤ
Fibonacci-ℤ (inr (inr zero-ℕ)) = one-ℤ
Fibonacci-ℤ (inr (inr (succ-ℕ zero-ℕ))) = one-ℤ
Fibonacci-ℤ (inr (inr (succ-ℕ (succ-ℕ x)))) =
  add-ℤ (Fibonacci-ℤ (inr (inr x))) (Fibonacci-ℤ (inr (inr (succ-ℕ x))))

-- Exercise 4.7

{- In this exercise we were asked to show that 1 + 1 satisfies the induction
   principle of the booleans. In other words, type theory cannot distinguish
   the booleans from the type 1 + 1. We will see later that they are indeed
   equivalent types. -}

t0 : coprod unit unit
t0 = inl star

t1 : coprod unit unit
t1 = inr star

ind-coprod-unit-unit : {i : Level} {P : coprod unit unit → UU i} →
  P t0 → P t1 → (x : coprod unit unit) → P x
ind-coprod-unit-unit p0 p1 (inl star) = p0
ind-coprod-unit-unit p0 p1 (inr star) = p1

-- Exercise 4.8

-- Exercise 4.8(a)

data list {l : Level} (A : UU l) : UU l where
  nil : list A
  cons : A → list A → list A

in-list : {l : Level} {A : UU l} → A → list A
in-list a = cons a nil

-- Exercise 4.8(b)

fold-list :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (b : B) (μ : A → (B → B)) →
  list A → B
fold-list b μ nil = b
fold-list b μ (cons a l) = μ a (fold-list b μ l)

-- Exercise 4.8(c)

length-list :
  {l : Level} {A : UU l} → list A → ℕ
length-list = fold-list zero-ℕ (λ a → succ-ℕ)

-- Exercise 4.8(d)

sum-list-ℕ :
  list ℕ → ℕ
sum-list-ℕ = fold-list zero-ℕ add-ℕ

-- Exercise 4.8(e)

concat-list :
  {l : Level} {A : UU l} → list A → (list A → list A)
concat-list {l} {A} = fold-list id (λ a f → (cons a) ∘ f)

-- Exercise 4.8(f)

flatten-list :
  {l : Level} {A : UU l} → list (list A) → list A
flatten-list = fold-list nil concat-list

-- Exercise 4.8 (g)

reverse-list :
  {l : Level} {A : UU l} → list A → list A
reverse-list nil = nil
reverse-list (cons a l) = concat-list (reverse-list l) (in-list a)


module Plus where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

infixr 40 _+_
infix  10 _==_

_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

data _==_ (x, y : Nat) : Set where
  -- ...

postulate
  refl : {n : Nat} -> n == n
  cong : (f : Nat -> Nat){n, m : Nat} -> n == m -> f n == f m

plusZero : {n : Nat} -> n + zero == n
plusZero {zero}  = refl
plusZero {suc n} = cong suc plusZero


module Numeral.Finite.Relation.Order where

import      Lvl
open import Data
open import Data.Boolean.Stmt
open import Functional
open import Numeral.Finite
open import Numeral.Finite.Oper.Comparisons
open import Numeral.Natural
open import Type

private variable an bn cn n : ℕ
private variable a : 𝕟(an)
private variable b : 𝕟(bn)
private variable c : 𝕟(cn)

_≤_ : 𝕟(an) → 𝕟(bn) → Type
_≤_ = IsTrue ∘₂ (_≤?_)

_≥_ : 𝕟(an) → 𝕟(bn) → Type
_≥_ = IsTrue ∘₂ (_≥?_)

_<_ : 𝕟(an) → 𝕟(bn) → Type
_<_ = IsTrue ∘₂ (_<?_)

_>_ : 𝕟(an) → 𝕟(bn) → Type
_>_ = IsTrue ∘₂ (_>?_)

_≡_ : 𝕟(an) → 𝕟(bn) → Type
_≡_ = IsTrue ∘₂ (_≡?_)

_≢_ : 𝕟(an) → 𝕟(bn) → Type
_≢_ = IsTrue ∘₂ (_≢?_)

-- TODO: open import Structure.Relator.Properties

import Numeral.Natural.Relation.Order as ℕ

[≤]-minimum : (𝟎{n} ≤ a)
[≤]-minimum {a = 𝟎}   = <>
[≤]-minimum {a = 𝐒 _} = <>

-- [≤]-maximum : (bound a ℕ.≤ n) → (a ≤ maximum{n})
-- [≤]-maximum {_}    {𝟎}            ℕ.[≤]-with-[𝐒]                 = <>
-- [≤]-maximum {𝐒 an} {𝐒 a} {.(𝐒 n)} (ℕ.[≤]-with-[𝐒] {y = n} ⦃ p ⦄) = [≤]-maximum {an}{a}{n} p
[≤]-maximum : (bound a ℕ.≤ 𝐒(n)) → (a ≤ maximum{n})
[≤]-maximum {a = 𝟎}         {𝟎}   (ℕ.succ _) = <>
[≤]-maximum {a = 𝟎}         {𝐒 _} (ℕ.succ _) = <>
[≤]-maximum {a = 𝐒 a}       {𝐒 x} (ℕ.succ p) = [≤]-maximum {a = a} p
[≤]-maximum {a = 𝐒 {𝟎} ()}  {𝟎}   (ℕ.succ _)
[≤]-maximum {a = 𝐒 {𝐒 n} a} {𝟎}   (ℕ.succ ())

[≤]-reflexivity-raw : (a ≤ a)
[≤]-reflexivity-raw {a = 𝟎}   = <>
[≤]-reflexivity-raw {a = 𝐒 a} = [≤]-reflexivity-raw {a = a}

[≤]-asymmetry-raw : (a ≤ b) → (b ≤ a) → (a ≡ b)
[≤]-asymmetry-raw {a = 𝟎} {b = 𝟎}     _ _ = <>
[≤]-asymmetry-raw {a = 𝐒 a} {b = 𝐒 b} p q = [≤]-asymmetry-raw {a = a}{b = b} p q

[≤]-transitivity-raw : (a ≤ b) → (b ≤ c) → (a ≤ c)
[≤]-transitivity-raw {a = 𝟎}   {b = 𝟎}   {c = 𝟎}   p q = <>
[≤]-transitivity-raw {a = 𝟎}   {b = 𝟎}   {c = 𝐒 c} p q = <>
[≤]-transitivity-raw {a = 𝟎}   {b = 𝐒 b} {c = 𝐒 c} p q = <>
[≤]-transitivity-raw {a = 𝐒 a} {b = 𝐒 b} {c = 𝐒 c} p q = [≤]-transitivity-raw {a = a} {b = b} {c = c} p q


------------------------------------------------------------------------
-- Code for converting Vec n A → B to and from n-ary functions
------------------------------------------------------------------------

module Data.Vec.N-ary where

open import Data.Nat
open import Data.Vec
open import Data.Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- N-ary functions

N-ary : ℕ → Set → Set → Set
N-ary zero    A B = B
N-ary (suc n) A B = A → N-ary n A B

------------------------------------------------------------------------
-- Conversion

curryⁿ : ∀ {n A B} → (Vec A n → B) → N-ary n A B
curryⁿ {zero}  f = f []
curryⁿ {suc n} f = λ x → curryⁿ (f ∘ _∷_ x)

_$ⁿ_ : ∀ {n A B} → N-ary n A B → (Vec A n → B)
f $ⁿ []       = f
f $ⁿ (x ∷ xs) = f x $ⁿ xs

------------------------------------------------------------------------
-- N-ary function equality

Eq : ∀ {A B} n → Rel B → (f g : N-ary n A B) → Set
Eq zero    _∼_ f g = f ∼ g
Eq (suc n) _∼_ f g = ∀ x → Eq n _∼_ (f x) (g x)

-- A variant where all the arguments are implicit (hidden).

Eqʰ : ∀ {A B} n → Rel B → (f g : N-ary n A B) → Set
Eqʰ zero    _∼_ f g = f ∼ g
Eqʰ (suc n) _∼_ f g = ∀ {x} → Eqʰ n _∼_ (f x) (g x)

------------------------------------------------------------------------
-- Some lemmas

-- The functions curryⁿ and _$ⁿ_ are inverses.

left-inverse : ∀ {n A B} (f : Vec A n → B) →
               ∀ xs → curryⁿ f $ⁿ xs ≡ f xs
left-inverse f []       = refl
left-inverse f (x ∷ xs) = left-inverse (f ∘ _∷_ x) xs

right-inverse : ∀ {A B} n (f : N-ary n A B) →
                Eq n _≡_ (curryⁿ (_$ⁿ_ {n} f)) f
right-inverse zero    f = refl
right-inverse (suc n) f = λ x → right-inverse n (f x)

-- Conversion preserves equality.

curryⁿ-pres : ∀ {n A B _∼_} (f g : Vec A n → B) →
              (∀ xs → f xs ∼ g xs) →
              Eq n _∼_ (curryⁿ f) (curryⁿ g)
curryⁿ-pres {zero}  f g hyp = hyp []
curryⁿ-pres {suc n} f g hyp = λ x →
  curryⁿ-pres (f ∘ _∷_ x) (g ∘ _∷_ x) (λ xs → hyp (x ∷ xs))

curryⁿ-pres⁻¹ : ∀ {n A B _∼_} (f g : Vec A n → B) →
                Eq n _∼_ (curryⁿ f) (curryⁿ g) →
                ∀ xs → f xs ∼ g xs
curryⁿ-pres⁻¹ f g hyp []       = hyp
curryⁿ-pres⁻¹ f g hyp (x ∷ xs) =
  curryⁿ-pres⁻¹ (f ∘ _∷_ x) (g ∘ _∷_ x) (hyp x) xs

appⁿ-pres : ∀ {n A B _∼_} (f g : N-ary n A B) →
            Eq n _∼_ f g →
            (xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)
appⁿ-pres f g hyp []       = hyp
appⁿ-pres f g hyp (x ∷ xs) = appⁿ-pres (f x) (g x) (hyp x) xs

appⁿ-pres⁻¹ : ∀ {n A B _∼_} (f g : N-ary n A B) →
              ((xs : Vec A n) → (f $ⁿ xs) ∼ (g $ⁿ xs)) →
              Eq n _∼_ f g
appⁿ-pres⁻¹ {zero}  f g hyp = hyp []
appⁿ-pres⁻¹ {suc n} f g hyp = λ x →
  appⁿ-pres⁻¹ (f x) (g x) (λ xs → hyp (x ∷ xs))

-- Eq and Eqʰ are equivalent.

Eq-to-Eqʰ : ∀ {A B} n {_∼_ : Rel B} {f g : N-ary n A B} →
            Eq n _∼_ f g → Eqʰ n _∼_ f g
Eq-to-Eqʰ zero    eq = eq
Eq-to-Eqʰ (suc n) eq = Eq-to-Eqʰ n (eq _)

Eqʰ-to-Eq : ∀ {A B} n {_∼_ : Rel B} {f g : N-ary n A B} →
            Eqʰ n _∼_ f g → Eq n _∼_ f g
Eqʰ-to-Eq zero    eq = eq
Eqʰ-to-Eq (suc n) eq = λ _ → Eqʰ-to-Eq n eq


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Data.Vec.OperationsNat where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat renaming(_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Vec.Base
open import Cubical.Data.Sigma

private variable
  ℓ : Level

_+n-vec_ : {m : ℕ} → Vec ℕ m → Vec ℕ m → Vec ℕ m
_+n-vec_ {.zero} [] [] = []
_+n-vec_ {.(suc _)} (k ∷ v) (l ∷ v') = (k +n l) ∷ (v +n-vec v')

+n-vec-lid : {m : ℕ} → (v : Vec ℕ m) → replicate 0 +n-vec v ≡ v
+n-vec-lid {.zero} [] = refl
+n-vec-lid {.(suc _)} (k ∷ v) = cong (_∷_ k) (+n-vec-lid v)

+n-vec-rid : {m : ℕ} → (v : Vec ℕ m) → v +n-vec replicate 0 ≡ v
+n-vec-rid {.zero} [] = refl
+n-vec-rid {.(suc _)} (k ∷ v) = cong₂ _∷_ (+-zero k) (+n-vec-rid v)

+n-vec-assoc : {m : ℕ} → (v v' v'' : Vec ℕ m) → v +n-vec (v' +n-vec v'') ≡ (v +n-vec v') +n-vec v''
+n-vec-assoc [] [] [] = refl
+n-vec-assoc (k ∷ v) (l ∷ v') (p ∷ v'') = cong₂ _∷_ (+-assoc k l p) (+n-vec-assoc v v' v'')

+n-vec-comm : {m : ℕ} → (v v' : Vec ℕ m) → v +n-vec v' ≡ v' +n-vec v
+n-vec-comm {.zero} [] [] = refl
+n-vec-comm {.(suc _)} (k ∷ v) (l ∷ v') = cong₂ _∷_ (+-comm k l) (+n-vec-comm v v')

sep-vec : (k l : ℕ) → Vec ℕ (k +n l) → (Vec ℕ k) ×  (Vec ℕ l )
sep-vec zero l v = [] , v
sep-vec (suc k) l (x ∷ v) = (x ∷ fst (sep-vec k l v)) , (snd (sep-vec k l v))

sep-vec-fst : (k l : ℕ) → (v : Vec ℕ k) → (v' : Vec ℕ l) → fst (sep-vec k l (v ++ v')) ≡ v
sep-vec-fst zero l [] v' = refl
sep-vec-fst (suc k) l (x ∷ v) v' = cong (λ X → x ∷ X) (sep-vec-fst k l v v')

sep-vec-snd : (k l : ℕ) → (v : Vec ℕ k) → (v' : Vec ℕ l) → snd (sep-vec k l (v ++ v')) ≡ v'
sep-vec-snd zero l [] v' = refl
sep-vec-snd (suc k) l (x ∷ v) v' = sep-vec-snd k l v v'

sep-vec-id : (k l : ℕ) → (v : Vec ℕ (k +n l)) → fst (sep-vec k l v) ++ snd (sep-vec k l v) ≡ v
sep-vec-id zero l v = refl
sep-vec-id (suc k) l (x ∷ v) = cong (λ X → x ∷ X) (sep-vec-id k l v)

rep-concat : (k l : ℕ) → {B : Type ℓ} → (b : B) →
             replicate {_} {k} {B} b ++ replicate {_} {l} {B} b ≡ replicate {_} {k +n l} {B} b
rep-concat zero l b = refl
rep-concat (suc k) l b = cong (λ X → b ∷ X) (rep-concat k l b)

+n-vec-concat : (k l : ℕ) → (v w : Vec ℕ k) → (v' w' : Vec ℕ l)
                → (v +n-vec w) ++ (v' +n-vec w') ≡ (v ++ v') +n-vec (w ++ w')
+n-vec-concat zero l [] [] v' w' = refl
+n-vec-concat (suc k) l (x ∷ v) (y ∷ w) v' w' = cong (λ X → x +n y ∷ X) (+n-vec-concat k l v w v' w')


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

open import Functions.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Setoids.Subset
open import Setoids.Setoids
open import Setoids.Orders.Partial.Definition
open import Fields.Fields
open import Rings.Orders.Total.Definition
open import Rings.Orders.Total.Lemmas
open import Rings.Orders.Partial.Definition
open import Rings.Definition
open import Fields.Orders.LeastUpperBounds.Definition
open import Fields.Orders.Total.Definition

module Numbers.ClassicalReals.RealField where

record RealField : Agda.Primitive.Setω where
  field
    a b c : _
    A : Set a
    S : Setoid {_} {b} A
    _+_ : A → A → A
    _*_ : A → A → A
    R : Ring S _+_ _*_
    F : Field R
    _<_ : Rel {_} {c} A
    pOrder : SetoidPartialOrder S _<_
    pOrderedRing : PartiallyOrderedRing R pOrder
    orderedRing : TotallyOrderedRing pOrderedRing
    lub : {d : _} → {pred : A → Set d} → (sub : subset S pred) → (nonempty : Sg A pred) → (boundedAbove : Sg A (UpperBound pOrder sub)) → Sg A (LeastUpperBound pOrder sub)
  open Setoid S
  open Field F
  charNot2 : (Ring.1R R + Ring.1R R) ∼ Ring.0R R → False
  charNot2 = orderedImpliesCharNot2 orderedRing nontrivial
  oField : TotallyOrderedField F pOrderedRing
  oField = record { oRing = orderedRing }


module Utils where

open import Data.Fin using (Fin)
import      Data.Fin as F
open import Data.Nat

data Fromℕ (n : ℕ) : ℕ → Set where
  yes : (m : Fin n) → Fromℕ n (F.toℕ m)
  no  : (m : ℕ)     → Fromℕ n (n + m)

fromℕ : ∀ n m → Fromℕ n m
fromℕ zero m = no m
fromℕ (suc n) zero = yes F.zero
fromℕ (suc n) (suc m) with fromℕ n m
fromℕ (suc n) (suc .(F.toℕ m)) | yes m = yes (F.suc m)
fromℕ (suc n) (suc .(n + m))   | no  m = no m


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

module Categories.Functor.Construction.LiftSetoids where

open import Level
open import Relation.Binary
open import Function.Equality
open import Function using (_$_) renaming (id to idf)

open import Categories.Category
open import Categories.Category.Instance.Setoids
open import Categories.Functor

private
  variable
    c ℓ : Level

-- Use pattern-matching (instead of explicit calls to lower) to minimize the
-- number of needed parens, and also make it syntactically apparent that
-- this is indeed just a Lift.
LiftedSetoid : ∀ c′ ℓ′ → Setoid c ℓ → Setoid (c ⊔ c′) (ℓ ⊔ ℓ′)
LiftedSetoid c′ ℓ′ S = record
  { Carrier       = Lift c′ Carrier
  ; _≈_           = λ where (lift x) (lift y) → Lift ℓ′ $ x ≈ y
  ; isEquivalence = record
    { refl  = lift refl
    ; sym   = λ where (lift eq)            → lift $ sym eq
    ; trans = λ where (lift eq) (lift eq′) → lift $ trans eq eq′
    }
  }
  where open Setoid S

LiftSetoids : ∀ c′ ℓ′ → Functor (Setoids c ℓ) (Setoids (c ⊔ c′) (ℓ ⊔ ℓ′))
LiftSetoids c′ ℓ′ = record
  { F₀           = LiftedSetoid c′ ℓ′
  ; F₁           = λ f → record
    { _⟨$⟩_  = λ where (lift x)  → lift $ f ⟨$⟩ x
    ; cong  = λ where (lift eq) → lift $ cong f eq
    }
  ; identity     = idf
  ; homomorphism = λ where {f = f} {g = g} (lift eq) → lift $ cong g $ cong f eq
  ; F-resp-≈     = λ where fx≈gy (lift x≈y)          → lift $ fx≈gy x≈y
  }


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

module PolynomialFunctors where

-- From: Ulf Norell. Dependently typed programming in Agda. In Koopman
-- et al., editors. Advanced Functional Programming (AFP 2008), volume
-- 5832 of LNCS. Springer-Verlag, 2009. pages 230–266.

infixr 50 _|+|_ _⊕_
infixr 60 _|x|_ _×_

record True : Set where

data _⊕_ (A B : Set) : Set where
  inl : A → A ⊕ B
  inr : B → A ⊕ B

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

data Functor : Set₁ where
  |Id|  : Functor
  |K|   : Set → Functor
  _|+|_ : Functor → Functor → Functor
  _|x|_ : Functor → Functor → Functor

[_] : Functor → Set → Set
[ |Id|    ] X = X
[ |K| A   ] X = A
[ F |+| G ] X = [ F ] X ⊕ [ G ] X
[ F |x| G ] X = [ F ] X × [ G ] X

data μ_ (F : Functor) : Set where
  <_> : [ F ] (μ F) → μ F

NatF : Functor
NatF = |K| True |+| |Id|

NAT : Set
NAT = μ NatF

Z : NAT
Z = < inl _ >

S : NAT → NAT
S n = < inr n >

_+_ : NAT → NAT → NAT
m + < inl _ > = m
m + < inr n > = S (m + n)

ListF : (A : Set) → Functor
ListF = λ A → |K| True |+| |K| A |x| |Id|

LIST : (A : Set) → Set
LIST = λ A → μ (ListF A)

nil : {A : Set} → LIST A
nil = < inl _ >

cons : {A : Set} → A → LIST A → LIST A
cons x xs = < inr (x , xs) >


{-# OPTIONS --without-K --safe #-}
module Categories.Comonad where

open import Level

open import Categories.Category using (Category)
open import Categories.Functor using (Functor; Endofunctor; _∘F_) renaming (id to idF)
open import Categories.NaturalTransformation renaming (id to idN)
open import Categories.NaturalTransformation.NaturalIsomorphism hiding (_≃_)
open import Categories.NaturalTransformation.Equivalence
open NaturalIsomorphism

record Comonad {o ℓ e} (C : Category o ℓ e) : Set (o ⊔ ℓ ⊔ e) where
  field
    F : Endofunctor C
    ε : NaturalTransformation F idF
    δ : NaturalTransformation F (F ∘F F)

  module F = Functor F
  module ε = NaturalTransformation ε
  module δ = NaturalTransformation δ

  open Category C
  open Functor F

  field
    assoc     : ∀ {X : Obj} → δ.η (F₀ X) ∘ δ.η X ≈ F₁ (δ.η X) ∘ δ.η X
    sym-assoc : ∀ {X : Obj} → F₁ (δ.η X) ∘ δ.η X ≈ δ.η (F₀ X) ∘ δ.η X
    identityˡ : ∀ {X : Obj} → F₁ (ε.η X) ∘ δ.η X ≈ id
    identityʳ : ∀ {X : Obj} → ε.η (F₀ X) ∘ δ.η X ≈ id


record SemiRing : Set1 where
  field
    R    : Set
    _+_  : R -> R -> R
    zero : R
    _*_  : R -> R -> R
    one  : R

module Vectors (S : SemiRing) where

  open SemiRing S
  open import Data.Nat renaming (ℕ to Nat; zero to z; _*_ to times; _+_ to plus)
  open import Data.Fin renaming (zero to z) hiding (_+_)
  open import RMonads
  open import Functors.Fin
  open import Data.Bool
  open import Function
  open import Relation.Binary.HeterogeneousEquality

  Vec : Nat -> Set
  Vec n = Fin n -> R

  Matrix : Nat -> Nat -> Set
  Matrix m n = Fin m -> Vec n

  -- unit
  delta : forall {n} -> Matrix n n
  delta i j = if feq i j then one else zero

  transpose : forall {m n} -> Matrix m n -> Matrix n m
  transpose A = λ j i -> A i j

  dot : forall {n} -> Vec n -> Vec n -> R
  dot {z}     x y = zero
  dot {suc n} x y = (x z * y z) + dot (x ∘ suc) (y ∘ suc)

  mult : forall {m n} -> Matrix m n -> Vec m -> Vec n
  mult A x = λ j -> dot (transpose A j) x

  VecRMon : RMonad FinF
  VecRMon = rmonad
    Vec
    delta
    mult
    {!!}
    {!!}
    {!!}

    where
{-
    lem : forall {n}(x : Vec n)(j : Fin n) -> dot (λ i → if feq i j then one else zero) x ≅ x j
    lem {z} x ()
    lem {suc n} x z = {!lem {n} (x ∘ suc) !}
    lem {suc n} x (suc j) = {!!}

 -}


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

module Avionics.Probability where

--open import Data.Fin using (Fin; fromℕ<)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product using (_×_; _,_)
open import Data.Vec using (Vec; lookup)
open import Relation.Binary.PropositionalEquality using (refl)
open import Relation.Unary using (_∈_)

open import Avionics.Real using (
    ℝ; _+_; _-_; _*_; _÷_; _^_; √_; 1/_; _^2;
    -1/2; π; e; 2ℝ; 1ℝ; 0ℝ;
    ⟨0,∞⟩; [0,∞⟩; [0,1])

record Dist (Input : Set) : Set where
  field
    pdf : Input → ℝ
    cdf : Input → ℝ
    pdf→[0,∞⟩ : ∀ x → pdf x ∈ [0,∞⟩
    cdf→[0,1] : ∀ x → cdf x ∈ [0,1]
    --∫pdf≡cdf : ∫ pdf ≡ cdf
    --∫pdf[-∞,∞]≡1ℝ : ∫ pdf [ -∞ , ∞ ] ≡ 1ℝ

record NormalDist : Set where
  constructor ND
  field
    μ : ℝ
    σ : ℝ
    --.0<σ : 0ℝ <? σ

  dist : Dist ℝ
  dist = record
    {
      pdf = pdf
    ; cdf = ?
    ; pdf→[0,∞⟩ = ?
    ; cdf→[0,1] = ?
    }
    where
      √2π = (√ (2ℝ * π))
      1/⟨σ√2π⟩ = (1/ (σ * √2π))

      pdf : ℝ → ℝ
      pdf x = 1/⟨σ√2π⟩ * e ^ (-1/2 * (⟨x-μ⟩÷σ ^2))
        where
          ⟨x-μ⟩÷σ = ((x - μ) ÷ σ)

-- Bivariate Normal Distribution
-- Representation taken from: https://upload.wikimedia.org/wikipedia/commons/a/a2/Cumulative_function_n_dimensional_Gaussians_12.2013.pdf
record BiNormalDist : Set where
  constructor ND
  field
    μ₁ : ℝ
    μ₂ : ℝ
    σ₁ : ℝ
    σ₂ : ℝ
    ρ : ℝ

  μ : ℝ × ℝ
  μ = μ₁ , μ₂

  Σ : ℝ × ℝ × ℝ × ℝ
  Σ = σ₁ , (ρ * σ₁ * σ₂) , (ρ * σ₁ * σ₂) , σ₂

  Σ-¹ : ℝ × ℝ × ℝ × ℝ
  Σ-¹ = ( 1/1-ρ² * (1ℝ ÷ σ₁)
        , 1/1-ρ² * -ρ/σ₁σ₂
        , 1/1-ρ² * -ρ/σ₁σ₂
        , 1/1-ρ² * (1ℝ ÷ σ₂))
    where 1/1-ρ² = 1ℝ ÷ (1ℝ - ρ * ρ)
          -ρ/σ₁σ₂ = (0ℝ - ρ) ÷ (σ₁ * σ₂)

  dist : Dist ℝ
  dist = record
    {
      pdf = ?
    ; cdf = ?
    ; pdf→[0,∞⟩ = ?
    ; cdf→[0,1] = ?
    }

Mat : ℕ → Set
Mat n = Vec (Vec ℝ n) n

-- Multivariate Normal Distribution
record MultiNormal : Set where
  constructor MultiND
  field
    n : ℕ
    μ : Vec ℝ n
    Σ : Mat n

  dist : Dist (Vec ℝ n)
  dist = record
    {
      pdf = ?
    ; cdf = ?
    ; pdf→[0,∞⟩ = ?
    ; cdf→[0,1] = ?
    }

--num : Vec ℕ 2 → ℕ
--num vec = lookup vec (fromℕ< {0} _)

--num2 : MultiNormal → ℝ
--num2 mn = lookup μ (fromℕ< {0} _)
--  where open MultiNormal mn using (n; μ; Σ) --; dist)
--        --open Dist dist using (pdf)


{-# OPTIONS --without-K --safe #-}
module Categories.Functor.Coalgebra where

-- Co-algebras of a Functor
open import Level
open import Function using (_$_)

open import Categories.Category using (Category)
open import Categories.Functor using (Functor; Endofunctor)

record F-Coalgebra {o ℓ e} {C : Category o ℓ e} (F : Endofunctor C) : Set (o ⊔ ℓ) where
  open Category C
  field
    A : Obj
    α : A ⇒ Functor.F₀ F A

open F-Coalgebra

-- Given a F-Coalgebra F, one can apply F to it to obtain an new 'iterated' F-Coalgebra
iterate : ∀ {o ℓ e} {C : Category o ℓ e} {F : Endofunctor C} → F-Coalgebra F → F-Coalgebra F
iterate {F = F} F-alg = record { A = Functor.F₀ F $ A F-alg ; α = Functor.F₁ F $ α F-alg }


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

open import LogicalFormulae
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Rings.IntegralDomains.Definition

module Rings.Associates.Lemmas {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} {R : Ring S _+_ _*_} (intDom : IntegralDomain R) where

open import Rings.Divisible.Definition R
open import Rings.IntegralDomains.Lemmas intDom
open import Rings.Associates.Definition intDom
open import Rings.Ideals.Definition R
open Setoid S
open Ring R
open Equivalence eq

associatesEquiv : Equivalence Associates
Equivalence.reflexive associatesEquiv {x} = 1R , ((1R , identIsIdent) ,, symmetric (transitive *Commutative identIsIdent))
Equivalence.symmetric associatesEquiv {x} {y} (a , ((invA , prInv) ,, x=ya)) = invA , ((a , transitive *Commutative prInv) ,, transitive (symmetric identIsIdent) (transitive (*WellDefined (symmetric prInv) reflexive) (transitive *Commutative (transitive *Associative (*WellDefined (symmetric x=ya) reflexive)))))
Equivalence.transitive associatesEquiv {x} {y} {z} (a , ((invA , prInvA) ,, x=ya)) (b , ((invB , prInvB) ,, y=zb)) = (a * b) , (((invA * invB) , transitive *Associative (transitive (*WellDefined (transitive *Commutative *Associative) reflexive) (transitive (symmetric *Associative) (transitive (*WellDefined (transitive *Commutative prInvA) prInvB) identIsIdent)))) ,, transitive x=ya (transitive (*WellDefined y=zb reflexive) (transitive (symmetric *Associative) (*WellDefined reflexive *Commutative))))

associateImpliesMutualDivision : {a b : A} → Associates a b → a ∣ b
associateImpliesMutualDivision {a} {b} (x , ((invX , prInvX) ,, a=bx)) = invX , transitive (transitive (*WellDefined a=bx reflexive) (transitive (transitive (symmetric *Associative) (*WellDefined reflexive prInvX)) *Commutative)) identIsIdent

mutualDivisionImpliesAssociate : {a b : A} → (a ∣ b) → (b ∣ a) → ((a ∼ 0R) → False) → Associates a b
mutualDivisionImpliesAssociate {a} {b} (r , ar=b) (s , bs=a) a!=0 = s , ((r , cancelIntDom {a = a} (transitive (transitive (transitive (*WellDefined reflexive *Commutative) (transitive *Associative (*WellDefined ar=b reflexive))) bs=a) (transitive (symmetric identIsIdent) *Commutative)) a!=0) ,, symmetric bs=a)

mutualDivisionImpliesAssociate' : {a b : A} → (a ∣ b) → (b ∣ a) → (a ∼ 0R) → Associates a b
mutualDivisionImpliesAssociate' {a} {b} (r , ar=b) (s , bs=a) a=0 = 1R , ((1R , identIsIdent) ,, transitive a=0 (symmetric (transitive (*WellDefined b=0 reflexive) (transitive *Commutative timesZero))))
  where
    b=0 : b ∼ 0R
    b=0 = transitive (symmetric ar=b) (transitive (transitive *Commutative (*WellDefined reflexive a=0)) (timesZero {r}))

associateImpliesGeneratedIdealsEqual : {a b : A} → Associates a b → {x : A} → generatedIdealPred a x → generatedIdealPred b x
associateImpliesGeneratedIdealsEqual {a} {b} (r , ((s , rs=1) ,, a=br)) {x} (c , ac=x) = (r * c) , transitive *Associative (transitive (*WellDefined (symmetric a=br) reflexive) ac=x)

associateImpliesGeneratedIdealsEqual' : {a b : A} → Associates a b → {x : A} → generatedIdealPred b x → generatedIdealPred a x
associateImpliesGeneratedIdealsEqual' assoc = associateImpliesGeneratedIdealsEqual (Equivalence.symmetric associatesEquiv assoc)


module Misc.NumeralSystem where -- One Numeral System to rule them all!?

open import Data.Maybe using (Maybe; nothing; just)
open import Data.Nat
open import Data.Product

open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)
open import Relation.Nullary using (¬_ ; yes; no)

open import Relation.Binary

open import Level
  renaming (zero to lzero; suc to lsuc)

open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl; setoid; cong)

open import Data.Nat.Properties using (≤-step)
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

infixr 5 _∷[_,_]_

--------------------------------------------------------------------------------
--  PN - Positional Notation
--  http://en.wikipedia.org/wiki/Positional_notation
--
--  base: b
--  digits: consecutive ℕ from m to n
--                             ●────○

data PN (b m n : ℕ) : Set where
  [_] : m < n → PN b m n
  _∷[_,_]_ : (x : ℕ) → (m ≤ x) → (x < n) → PN b m n → PN b m n

--------------------------------------------------------------------------------
toℕ : ∀ {b m n} → PN b m n → ℕ
toℕ [ _ ] = 0
toℕ {b} (x ∷[ x≥m , x<n ] xs) = x + b * toℕ xs

private
   ≤→< : ∀ {m n} → m ≤ n → ¬ (m ≡ n) → m < n
   ≤→< {n = zero} z≤n 0≠0 = ⊥-elim (0≠0 refl)
   ≤→< {n = suc n} z≤n neq = s≤s z≤n
   ≤→< (s≤s m≤n) 1+m≠1+n = s≤s (≤→< m≤n (λ m≡n → 1+m≠1+n (cong suc m≡n)))

--------------------------------------------------------------------------------
-- increment
-- the image of 'incr' is "continuous" if when
--    b = 1 ⇒ m ≥ 1, n ≥ 2m
--    b > 1 ⇒ m ≥ 0, n ≥ m + b, n ≥ 1 + mb

incr : ∀ {b m n} → m ≤ 1 → 2 ≤ n → PN b m n → PN b m n
incr m≤1 2≤n [ m<n ] = 1 ∷[ m≤1 , 2≤n ] [ m<n ]
incr {b} {m} {n} m≤1 2≤n (x ∷[ m≤x , x<n ] xs) with suc x ≟ n
incr {b} {m} m≤1 2≤n (x ∷[ m≤x , x<n ] xs) | no  1+x≠n = suc x ∷[ ≤-step m≤x , ≤→< x<n 1+x≠n ] xs
incr {b} {m} m≤1 2≤n (x ∷[ m≤x , x<n ] xs) | yes refl  = m ∷[ ≤-refl , s≤s m≤x ] incr m≤1 2≤n xs

base=1-incr : ∀ {m n} → 1 ≤ m → m * 2 ≤ n → PN 1 m n → PN 1 m n
base=1-incr {m} {n} 1≤m 2m≤n [ m<n ] = m ∷[ ≤-refl , m<n ] [ m<n ]
base=1-incr {m} {n} 1≤m 2m≤n (x ∷[ m≤x , x<n ] xs) with suc x ≟ n
base=1-incr {m} {n} 1≤m 2m≤n (x ∷[ m≤x , x<n ] xs) | no 1+x≠n = suc x ∷[ ≤-step m≤x , ≤→< x<n 1+x≠n ] xs
base=1-incr {m} 1≤m 2m≤n (x ∷[ m≤x , x<n ] xs) | yes refl = m ∷[ ≤-refl , s≤s m≤x ] base=1-incr 1≤m 2m≤n xs

base>1-incr : ∀ {b m n} → 1 < b → 0 ≤ m → m + b ≤ n → m * b + 1 ≤ n → PN b m n → PN b m n
base>1-incr {b} {m} {n} 1<b 0≤m m+b≤n mb+1≤n [ m<n ] = m ∷[ ≤-refl , m<n ] [ m<n ]
base>1-incr {b} {m} {n} 1<b 0≤m m+b≤n mb+1≤n (x ∷[ m≤x , x<n ] xs) with suc x ≟ n
base>1-incr {b} {m} {n} 1<b 0≤m m+b≤n mb+1≤n (x ∷[ m≤x , x<n ] xs) | no 1+x≠n = suc x ∷[ ≤-step m≤x , ≤→< x<n 1+x≠n ] xs
base>1-incr {b} {m} 1<b 0≤m m+b≤n mb+1≤n (x ∷[ m≤x , x<n ] xs) | yes refl = m ∷[ ≤-refl , s≤s m≤x ] base>1-incr 1<b 0≤m m+b≤n mb+1≤n xs

--
--   A ── incr ⟶ A'
--   |             |
--  toℕ           toℕ
--   ↓             ↓
--   n ── suc ⟶ suc n
--

-- first attempt :p
-- unary-toℕ-hom : (a : PN 1 1 2) → suc (toℕ a) ≡ toℕ (base=1-incr (s≤s z≤n) (s≤s (s≤s z≤n)) a)
-- unary-toℕ-hom [ m<n ] = refl
-- unary-toℕ-hom (zero ∷[ () , x<n ] xs)
-- unary-toℕ-hom (suc zero ∷[ m≤x , x<n ] xs) = cong suc {!   !}
-- unary-toℕ-hom (suc (suc x) ∷[ m≤x , s≤s (s≤s ()) ] xs)

--------------------------------------------------------------------------------
--  Instances

private
  -- Unary
  Unary : Set
  Unary = PN 1 1 2

  u₀ : Unary
  u₀ = 1 ∷[ s≤s z≤n , s≤s (s≤s z≤n) ] 1 ∷[ s≤s z≤n , s≤s (s≤s z≤n) ] [ s≤s (s≤s z≤n) ]

  -- Binary
  Bin : Set
  Bin = PN 2 0 2

  b₀ : Bin
  b₀ = 1 ∷[ z≤n , s≤s (s≤s z≤n) ] 0 ∷[ z≤n , s≤s z≤n ] [ s≤s z≤n ]

  -- Zeroless Binary
  Bin+ : Set
  Bin+ = PN 2 1 3


module Golden.Factorial where

open import Agda.Builtin.Nat

fac : Nat -> Nat
fac 0 = 1
fac (suc n) = suc n * fac n

a = fac 0
b = fac 10


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

open import Groups.Definition
open import Setoids.Setoids
open import Setoids.Orders.Partial.Definition
open import Functions.Definition
open import Rings.Definition

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

module Rings.Orders.Partial.Definition {n m : _} {A : Set n} {S : Setoid {n} {m} A} {_+_ : A → A → A} {_*_ : A → A → A} (R : Ring S _+_ _*_) where

open Ring R
open Group additiveGroup
open Setoid S
open import Groups.Orders.Partial.Definition

record PartiallyOrderedRing {p : _} {_<_ : Rel {_} {p} A} (pOrder : SetoidPartialOrder S _<_) : Set (lsuc n ⊔ m ⊔ p) where
  field
    orderRespectsAddition : {a b : A} → (a < b) → (c : A) → (a + c) < (b + c)
    orderRespectsMultiplication : {a b : A} → (0R < a) → (0R < b) → (0R < (a * b))
  open SetoidPartialOrder pOrder

toGroup : {p : _} {_<_ : Rel {_} {p} A} {pOrder : SetoidPartialOrder S _<_} → PartiallyOrderedRing pOrder → PartiallyOrderedGroup additiveGroup pOrder
PartiallyOrderedGroup.orderRespectsAddition (toGroup p) = PartiallyOrderedRing.orderRespectsAddition p


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

open import Categories.Category

-- the usual notion requires C to have finite limits.
-- this definition is a generalization by omitting that requirement as the definition
-- itself does not involve any limit.
module Categories.Diagram.SubobjectClassifier {o ℓ e} (C : Category o ℓ e) where

open Category C

open import Level

open import Categories.Object.Terminal C
open import Categories.Morphism C
open import Categories.Diagram.Pullback C

record SubobjectClassifier : Set (o ⊔ ℓ ⊔ e) where
  field
    Ω        : Obj
    terminal : Terminal

  module terminal = Terminal terminal
  open terminal

  field
    true      : ⊤ ⇒ Ω
    universal : ∀ {X Y} {f : X ⇒ Y} → Mono f → Y ⇒ Ω
    pullback  : ∀ {X Y} {f : X ⇒ Y} {mono : Mono f} → Pullback (universal mono) true
    unique    : ∀ {X Y} {f : X ⇒ Y} {g} {mono : Mono f} → Pullback g true → universal mono ≈ g


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

open import LogicalFormulae
open import Groups.Definition
open import Groups.Abelian.Definition
open import Groups.FiniteGroups.Definition
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Setoids.Setoids
open import Sets.FinSet.Definition
open import Sets.FinSet.Lemmas
open import Functions.Definition
open import Functions.Lemmas
open import Semirings.Definition
open import Numbers.Modulo.Definition
open import Numbers.Modulo.Addition
open import Orders.Total.Definition
open import Numbers.Modulo.ModuloFunction

module Numbers.Modulo.Group where

open TotalOrder ℕTotalOrder
open Semiring ℕSemiring

private
  0<s : {n : ℕ} → 0 <N succ n
  0<s {n} = le n (applyEquality succ (Semiring.sumZeroRight ℕSemiring n))

  inverseN : {n : ℕ} → .(0<n : 0 <N n) → (x : ℤn n 0<n) → ℤn n 0<n
  inverseN 0<n record { x = 0 ; xLess = _ } = record { x = 0 ; xLess = 0<n }
  inverseN 0<n record { x = succ x ; xLess = xLess } with <NProp xLess
  ... | le subtr pr = record { x = succ subtr ; xLess = le x (transitivity (commutative (succ x) (succ subtr)) pr) }

  invLeft : {n : ℕ} → .(0<n : 0 <N n) → (x : ℤn n 0<n) → _+n_ 0<n (inverseN 0<n x) x ≡ record { x = 0 ; xLess = 0<n }
  invLeft {n} 0<n record { x = 0 ; xLess = xLess } = plusZnIdentityLeft 0<n (record { x = 0 ; xLess = 0<n })
  invLeft {n} 0<n record { x = (succ x) ; xLess = xLess } with <NProp xLess
  ... | le subtr pr rewrite pr = equalityZn (modN 0<n)

ℤnGroup : (n : ℕ) → .(pr : 0 <N n) → Group (reflSetoid (ℤn n pr)) (_+n_ pr)
Group.+WellDefined (ℤnGroup n 0<n) refl refl = refl
Group.0G (ℤnGroup n 0<n) = record { x = 0 ; xLess = 0<n }
Group.inverse (ℤnGroup n 0<n) = inverseN 0<n
Group.+Associative (ℤnGroup n 0<n) {a} {b} {c} = equalityCommutative (plusZnAssociative 0<n a b c)
Group.identRight (ℤnGroup n 0<n) {a} = plusZnIdentityRight 0<n a
Group.identLeft (ℤnGroup n 0<n) {a} = plusZnIdentityLeft 0<n a
Group.invLeft (ℤnGroup n 0<n) {a} = invLeft 0<n a
Group.invRight (ℤnGroup n 0<n) {a} = transitivity (plusZnCommutative 0<n a (inverseN 0<n a)) (invLeft 0<n a)

ℤnAbGroup : (n : ℕ) → (pr : 0 <N n) → AbelianGroup (ℤnGroup n pr)
AbelianGroup.commutative (ℤnAbGroup n pr) {a} {b} = plusZnCommutative pr a b

ℤnFinite : (n : ℕ) → (pr : 0 <N n) → FiniteGroup (ℤnGroup n pr) (FinSet n)
SetoidToSet.project (FiniteGroup.toSet (ℤnFinite (succ n) 0<n)) record { x = x ; xLess = xLess } = ofNat x xLess
SetoidToSet.wellDefined (FiniteGroup.toSet (ℤnFinite (succ n) 0<n)) x y x=y rewrite x=y = refl
SetoidToSet.surj (FiniteGroup.toSet (ℤnFinite (succ n) 0<n)) b = record { x = toNat b ; xLess = toNatSmaller b } , ofNatToNat b
SetoidToSet.inj (FiniteGroup.toSet (ℤnFinite (succ n) 0<n)) record { x = x ; xLess = xLess } record { x = y ; xLess = yLess } eq = equalityZn (ofNatInjective x y xLess yLess eq)
FiniteGroup.finite (ℤnFinite n pr) = record { size = n ; mapping = id ; bij = idIsBijective }


------------------------------------------------------------------------
-- A derivative operator for parsers
------------------------------------------------------------------------

-- Similar to the derivative operator in Brzozowski's "Derivatives of
-- Regular Expressions".

module TotalParserCombinators.Derivative where

-- Definition of the derivative.

open import TotalParserCombinators.Derivative.Definition public

-- The derivative operator is sound and complete with respect to the
-- semantics.

open import TotalParserCombinators.Derivative.SoundComplete public
  hiding (complete′)

-- A proof showing that the derivative operator does not introduce any
-- unneeded ambiguity.

open import TotalParserCombinators.Derivative.LeftInverse public

-- A proof showing that the derivative operator does not remove any
-- ambiguity.

open import TotalParserCombinators.Derivative.RightInverse public
  hiding (sound∘complete′)

-- Some corollaries.

open import TotalParserCombinators.Derivative.Corollaries public


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

open import Categories.Category.Core

module Categories.Morphism.Regular.Properties {o ℓ e} (𝒞 : Category o ℓ e) where

open import Categories.Morphism 𝒞
open import Categories.Morphism.Regular 𝒞
open import Categories.Diagram.Equalizer 𝒞
open import Categories.Diagram.Equalizer.Properties 𝒞
open import Categories.Diagram.Coequalizer.Properties 𝒞

open Category 𝒞

private
  variable
    A B : Obj
    f g : A ⇒ B

Section⇒RegularMono : f SectionOf g → RegularMono f
Section⇒RegularMono {f = f} {g = g} g∘f≈id = record
  { g = id
  ; h = f ∘ g
  ; equalizer = section-equalizer g∘f≈id
  }

Retract⇒RegularEpi : f RetractOf g → RegularEpi f
Retract⇒RegularEpi {f = f} {g = g} f∘g≈id = record
  { h = g ∘ f
  ; g = id
  ; coequalizer = retract-coequalizer f∘g≈id
  }


module lambda.untyped where

open import Data.Nat
open import Data.Fin hiding (lift)

data term (n : ℕ) : Set where
  lam : term (suc n) → term n
  var : Fin n → term n
  app : term n → term n → term n

data norm {n : ℕ} : term n → Set
data neut {n : ℕ} : term n → Set

data norm {n} where
  lam : {x : term (suc n)} → norm x → norm (lam x)
  gnd : {x : term n} → neut x → norm x

data neut {n} where
  var : {i : Fin n} → neut (var i)
  app : {x y : term n} → neut x → norm y → neut (app x y)

lift : ∀ {n} → term n → term (suc n)
lift (lam x) = lam (lift x)
lift (var i) = var (suc i)
lift (app x y) = app (lift x) (lift y)

lift₁ : ∀ {n} → term (suc n) → term (suc (suc n))
lift₁ (lam x) = lam (lift₁ x)
lift₁ (var zero) = var zero
lift₁ (var (suc i)) = var (suc (suc i))
lift₁ (app x y) = app (lift₁ x) (lift₁ y)

↑ : ∀ {n m} → (Fin n → term m) → Fin (suc n) → term (suc m)
↑ ρ zero = var zero
↑ ρ (suc i) = lift (ρ i)

subst : ∀ {n m} → term n → (Fin n → term m) → term m
subst (lam x) ρ = lam (subst x (↑ ρ))
subst (var i) ρ = ρ i
subst (app x y) ρ = app (subst x ρ) (subst y ρ)

subst₁ : ∀ {n} → term (suc n) → term n → term n
subst₁ x y = subst x (λ {zero → y; (suc i) → var i})

data _→β_ {n : ℕ} : term n → term n → Set where
  β-beta : ∀ {x y} → app (lam x) y →β subst₁ x y
  β-app₁ : ∀ {x y z} → x →β y → app x z →β app y z
  β-app₂ : ∀ {x y z} → y →β z → app x y →β app x z
  β-lam : ∀ {x y} → x →β y → lam x →β lam y

data _β*_ {n : ℕ} : term n → term n → Set where
  ε : ∀ {x} → x β* x
  _←_ : ∀ {x y z} → x →β y → y β* z → x β* z


open import Oscar.Prelude
open import Oscar.Class.Reflexivity
open import Oscar.Class.Symmetry
open import Oscar.Class.Transitivity

module Oscar.Class.IsEquivalence where

record IsEquivalence
  {𝔬} {𝔒 : Ø 𝔬}
  {ℓ} (_≈_ : 𝔒 → 𝔒 → Ø ℓ)
  : Ø 𝔬 ∙̂ ℓ where
  constructor ∁
  field
    ⦃ `𝓡eflexivity ⦄ : Reflexivity.class _≈_
    ⦃ `𝓢ymmetry ⦄ : Symmetry.class _≈_
    ⦃ `𝓣ransitivity  ⦄ : Transitivity.class _≈_


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

open import Agda.Builtin.Nat using (Nat; zero; suc)
open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

variable
  k l m n : Nat

postulate
  max : Nat → Nat → Nat
  max-0l : max 0 n ≡ n
  max-0r : max m 0 ≡ m
  max-diag : max m m ≡ m
  max-ss : max (suc m) (suc n) ≡ suc (max m n)
  max-diag-s : max (suc m) (suc m) ≡ suc m -- for global confluence
  max-assoc : max (max k l) m ≡ max k (max l m)

{-# REWRITE max-0l max-0r #-}
{-# REWRITE max-ss max-diag max-diag-s #-}
--{-# REWRITE max-assoc #-} -- not confluent!

postulate
  _+_ : Nat → Nat → Nat
  plus-0l : 0 + n ≡ n
  plus-0r : m + 0 ≡ m
  plus-00 : 0 + 0 ≡ 0  -- for global confluence
  plus-suc-l : (suc m) + n ≡ suc (m + n)
  plus-suc-0 : (suc m) + 0 ≡ suc m -- for global confluence
  plus-suc-r : m + (suc n) ≡ suc (m + n)
  plus-0-suc : 0 + (suc n) ≡ suc n
  plus-suc-suc : (suc m) + (suc n) ≡ suc (suc (m + n))
  plus-assoc : (k + l) + m ≡ k + (l + m) -- not accepted by global confluence check

{-# REWRITE plus-00 plus-0l plus-0r
            plus-suc-l plus-suc-0
            plus-suc-r plus-0-suc
            plus-suc-suc #-}

postulate
  _*_ : Nat → Nat → Nat
  mult-0l : 0 * n ≡ 0
  mult-0r : m * 0 ≡ 0
  mult-00 : 0 * 0 ≡ 0
  mult-suc-l : (suc m) * n ≡ n + (m * n)
  mult-suc-l-0 : (suc m) * 0 ≡ 0
  mult-suc-r : m * (suc n) ≡ (m * n) + m
  plus-mult-distr-l : k * (l + m) ≡ (k * l) + (k * m)
  plus-mult-distr-r : (k + l) * m ≡ (k * m) + (l * m)
  mult-assoc : (k * l) * m ≡ k * (l * m)

{-# REWRITE mult-0l mult-0r mult-00
            mult-suc-l mult-suc-l-0 #-}
--{-# REWRITE mult-suc-r #-} -- requires rule plus-assoc!
--{-# REWRITE plus-mult-distr-l #-}
--{-# REWRITE plus-mult-distr-r #-}
--{-# REWRITE mult-assoc #-}


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

open import Categories.Category
open import Categories.Functor.Bifunctor

module Categories.Diagram.End {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where

private
  module D = Category D
  open D
  open HomReasoning
  open Equiv
  variable
    A B : Obj
    f g : A ⇒ B

open import Level

open import Categories.Diagram.Wedge F
open import Categories.NaturalTransformation.Dinatural

record End : Set (levelOfTerm F) where
  field
    wedge : Wedge

  module wedge = Wedge wedge
  open wedge public
  open Wedge

  field
    factor    : (W : Wedge) → E W ⇒ wedge.E
    universal : ∀ {W : Wedge} {A} → wedge.dinatural.α A ∘ factor W ≈ dinatural.α W A
    unique    : ∀ {W : Wedge} {g : E W ⇒ wedge.E} → (∀ {A} → wedge.dinatural.α A ∘ g ≈ dinatural.α W A) → factor W ≈ g

  η-id : factor wedge ≈ D.id
  η-id = unique identityʳ

  unique′ :(∀ {A} → wedge.dinatural.α A ∘ f ≈ wedge.dinatural.α A ∘ g) → f ≈ g
  unique′ {f = f} {g = g} eq = ⟺ (unique {W = Wedge-∘ wedge f} refl) ○ unique (⟺ eq)


module Cats.Trans where

open import Level using (_⊔_)

open import Cats.Category.Base
open import Cats.Functor using (Functor)

open Functor

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  where

  infixr 9 _∘_

  private
    module C = Category C
    module D = Category D
    open D.≈-Reasoning

  record Trans (F G : Functor C D) : Set (lo ⊔ la ⊔ la′ ⊔ l≈′) where
    field
      component : (c : C.Obj) → fobj F c D.⇒ fobj G c
      natural : ∀ {c d} {f : c C.⇒ d}
        → component d D.∘ fmap F f D.≈ fmap G f D.∘ component c

  open Trans public

  id : ∀ {F} → Trans F F
  id {F} = record
      { component = λ _ → D.id
      ; natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
      }

  _∘_ : ∀ {F G H} → Trans G H → Trans F G → Trans F H
  _∘_ {F} {G} {H} θ ι = record
      { component = λ c → component θ c D.∘ component ι c
      ; natural = λ {c} {d} {f} →
          begin
            (component θ d D.∘ component ι d) D.∘ fmap F f
          ≈⟨ D.assoc ⟩
            component θ d D.∘ component ι d D.∘ fmap F f
          ≈⟨ D.∘-resp-r (natural ι) ⟩
            component θ d D.∘ fmap G f D.∘ component ι c
          ≈⟨ D.unassoc ⟩
            (component θ d D.∘ fmap G f) D.∘ component ι c
          ≈⟨ D.∘-resp-l (natural θ)  ⟩
            (fmap H f D.∘ component θ c) D.∘ component ι c
          ≈⟨ D.assoc ⟩
            fmap H f D.∘ component θ c D.∘ component ι c
          ∎
      }


module Functional.Combinations where

open import Type

-- TODO: Generalize these. Probably by lists and foldᵣ of combination and rotation construction functions. Also categorically or dependently
rotate₃Fn₃Op₂ : ∀{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (A → A → A → B) → (B → B → B) → (A → A → A → B)
rotate₃Fn₃Op₂(F)(_▫_) a b c = (F a b c) ▫ ((F b c a) ▫ (F c a b))

combine₃Fn₂Op₂ : ∀{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (A → A → B) → (B → B → B) → (A → A → A → B)
combine₃Fn₂Op₂(F)(_▫_) a b c = (F a b) ▫ ((F a c) ▫ (F b c))

all₃Fn₁Op₂ : ∀{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (A → B) → (B → B → B) → (A → A → A → B)
all₃Fn₁Op₂(F)(_▫_) a b c = (F a) ▫ ((F b) ▫ (F c))

combine₄Fn₃Op₂ : ∀{ℓ₁ ℓ₂}{A : Type{ℓ₁}}{B : Type{ℓ₂}} → (A → A → A → B) → (B → B → B) → (A → A → A → A → B)
combine₄Fn₃Op₂(F)(_▫_) a b c d = (F a b c) ▫ ((F a b d) ▫ ((F a c d) ▫ (F b c d)))


--
-- Inspired by a blog post written by Arnaud Bailly
-- https://abailly.github.io/posts/dependently-typed-date.html
--

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

module Date where

open import Data.Nat using (ℕ; zero; suc; _≡ᵇ_; _<_; _≤_; z≤n; s≤s; _≤?_; _<?_)
open import Data.Nat.DivMod using (_%_)
open import Data.Bool using (Bool; true; false; _∧_; _∨_; not)
open import Data.Maybe using (Maybe; just; nothing)

open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (True; toWitness)

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

module Day where
    data t : Set where
        Day : (n : ℕ) → {True (1 ≤? n)} → t   -- Capture a day which should not be zero

    make : (n : ℕ) → {True (1 ≤? n)} → t
    make = Day

    value : t → ℕ
    value (Day n) = n

module Year where
    t : Set
    t = ℕ

    isLeap : t → Bool
    isLeap y = (check4 ∧ not check100) ∨ check400
        where check4   = y % 4   ≡ᵇ 0
              check100 = y % 100 ≡ᵇ 0
              check400 = y % 400 ≡ᵇ 0

module Month where
    data t : Set where
        January    : t
        February   : t
        March      : t
        April      : t
        May        : t
        June       : t
        July       : t
        August     : t
        September  : t
        October    : t
        November   : t
        December   : t

    toNat : t → ℕ
    toNat January    = 1
    toNat February   = 2
    toNat March      = 3
    toNat April      = 4
    toNat May        = 5
    toNat June       = 6
    toNat July       = 7
    toNat August     = 8
    toNat September  = 9
    toNat October    = 10
    toNat November   = 11
    toNat December   = 12

    next : t → t
    next January   = February
    next February  = March
    next March     = April
    next April     = May
    next May       = June
    next June      = July
    next July      = August
    next August    = September
    next September = October
    next October   = November
    next November  = December
    next December  = January

    duration : t → Year.t → Day.t
    duration January _   = Day.make 31
    duration February year with Year.isLeap year
    ... | true           = Day.make 29
    ... | false          = Day.make 28
    duration March _     = Day.make 31
    duration April _     = Day.make 30
    duration May _       = Day.make 31
    duration June _      = Day.make 30
    duration July _      = Day.make 31
    duration August _    = Day.make 31
    duration September _ = Day.make 30
    duration October _   = Day.make 31
    duration November _  = Day.make 30
    duration December _  = Day.make 31

{-
module Date where
    data t : Set where
       Valid   : (year : Year.t) → (month : Month.t) → (day : ℕ)
               → {≤max : True (day ≤? Day.value (Month.duration month year))}
               → {min≤ : True (1 ≤? day)}
                --------------------------------------------------------------
               → t

    make = Valid

    changeMonth : (year : Year.t) → (month : Month.t) -> t
    changeMonth year Month.December = make (suc year) Month.January 1
    changeMonth year month          = make year (Month.next month) 1

    addOneDay : t → t
    addOneDay (Valid year month day) with (suc day) ≤? Day.value (Month.duration month year)
    ... | yes proof = Valid year month (suc day) {proof} {s≤s z≤n}
    ... | no  _     = changeMonth year month
    addOneDay d     = d
-}

module Date where
    data t : Set where
       Valid   : (year : Year.t) → (month : Month.t) → (day : ℕ)
               → {≤max : day ≤ Day.value (Month.duration month year)}
               → {min≤ : 1 ≤ day}
                --------------------------------------------------------------
               → t
       Invalid : t

    1≤month : ∀ {month year} -> 1 ≤ Day.value (Month.duration month year)
    1≤month {Month.January} {year} =
        begin
           1 ≤ Day.value (Month.duration month year)

{-
    make : (year : Year.t) → (month : Month.t) → (day : ℕ) → t
    make year month day with day ≤? Day.value (Month.duration month year) | 1 ≤? day
    ... | yes p1 | yes p2 = Valid year month day {p1} {p2}
    ... | _      | _      = Invalid

    changeMonth : (year : Year.t) → (month : Month.t) -> t
    changeMonth year Month.December = Valid (suc year) Month.January 1 {1≤month} {s≤s z≤n}
    changeMonth year month          = Valid year (Month.next month) 1 {1≤month} {s≤s z≤n}

    addOneDay : t → t
    addOneDay (Valid year month day) with (suc day) ≤? Day.value (Month.duration month year)
    ... | yes proof = Valid year month (suc day) {proof} {s≤s z≤n}
    ... | no  _     = changeMonth year month
    addOneDay d     = d

    -- addDays : t → ℕ → t
-}


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

open import HoTT

module cw.Attached {i j k : ULevel} where

-- The type of attaching maps.
-- In intended uses, [B] is the type of cells and [C] is the [Sphere]s.
Attaching : (A : Type i) (B : Type j) (C : Type k) → Type (lmax i (lmax j k))
Attaching A B C = B → C → A

module _ {A : Type i} {B : Type j} {C : Type k} where

  -- [Attached] is the type with all the cells attached.

  Attached-span : Attaching A B C → Span {i} {j} {lmax j k}
  Attached-span attaching = span A B (B × C) (uncurry attaching) fst

  Attached : Attaching A B C → Type (lmax i (lmax j k))
  Attached attaching = Pushout (Attached-span attaching)

module _ {A : Type i} {B : Type j} {C : Type k} {attaching : Attaching A B C} where

  incl : A → Attached attaching
  incl = left

  hub : B → Attached attaching
  hub = right

  spoke : ∀ b c → incl (attaching b c) == hub b
  spoke = curry glue

  module AttachedElim {l} {P : Attached attaching → Type l}
    (incl* : (a : A) → P (incl a))
    (hub* : (b : B) → P (hub b))
    (spoke* : (b : B) (c : C)
      → incl* (attaching b c) == hub* b [ P ↓ spoke b c ]) where

    module P = PushoutElim
      {d = Attached-span attaching} {P = P}
      incl* hub* (uncurry spoke*)

    f = P.f
    spoke-β = curry P.glue-β

  open AttachedElim public using () renaming (f to Attached-elim)

  module AttachedRec {l} {D : Type l}
    (incl* : (a : A) → D)
    (hub* : (b : B) → D)
    (spoke* : (b : B) (c : C) → incl* (attaching b c) == hub* b) where

    module P = PushoutRec
      {d = Attached-span attaching} {D = D}
      incl* hub* (uncurry spoke*)

    f = P.f
    spoke-β = curry P.glue-β

  open AttachedRec public using () renaming (f to Attached-rec)


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

module Formalization where

open import Agda.Primitive using (lsuc)

open import Relation.Binary.PropositionalEquality
open Relation.Binary.PropositionalEquality.≡-Reasoning

open import Level

-- Recall Lemma 1.12

ind₌ : ∀{a b}{A : Set a} → (C : (x y : A) → (x ≡ y) → Set b) → ((x : A) → C x x refl) → {x y : A} → (p : x ≡ y) → C x y p
ind₌ C c {x}{y} p rewrite p = c y

-- Types are higher groupoids
-- --------------------------

-- This is the *central* idea of HoTT.  A Type isn't just an atomic entity, it's a homotopic space.
-- An ∞-groupoid consists of
--   ∘ a collection of objects
--   ∘ a collection of morphisms between objects, and then morphisms between morphisms, and so on
--   ∘ equipped with some complex algebraic structure
--
-- a morphism at level k is called a k- morphism. Morphisms at each level have
--   ∘ identity
--   ∘ composition
--   ∘ inverse operations
--
-- which are weak in the sense that they satisfy the groupoid laws (associativity
-- of composition, identity is a unit for composition, inverses cancel) only up
-- to morphisms at the next level, and this weakness gives rise to further structure.

-- Example
--
-- Because associativity of composition of morphisms p (q r) = (p q) r is itself a higher-dimensional morphism
-- we need additional operators to talk about them.  For example:

{- Mac Lane's Pentagon
 ---------------------

 All the various ways to reassociate p (q (r s))

                                  /- ((p q) r) s -\
                                 /                 \
                      (p (q r)) s                   (p q) (r s)
                                |                   |
                                |                   |
                      p ((q r) s) ----------------- p (q (r s))

-}

-- Moreover, all of this higher groupoid structure comes automagically from the induction principle
-- on Id.

-- "Informally, the induction principle for identity types says that if we
-- construct an object (or prove a statement) which depends on an inhabitant
-- p : x == y of an identity type,
data _==_ {i} {A : Set i} (a : A) : A → Set (lsuc i) where
  idp : a == a -- then it suffices to perform the construction (or the proof) in
               -- the special case when x and y are the same (judgmentally)
               -- and p is the reflexivity element reflx : x = x (judgmentally)

-- Lemma 2.1.1 "Paths can be reversed"

-- first proof

_⁻¹ : ∀ {i} {A : Set i}{x y : A} → (x ≡ y) → (y ≡ x)
_⁻¹ {i} {A} = λ p → ind₌ D d  p where
  D : (x y : A) → x ≡ y → Set i
  D = λ x y p → (y ≡ x)

  d : (x : A) → D x x refl
  d = λ x → refl

-- second proof

inv-sym : ∀ {i} {A : Set i}{x y : A} → (x ≡ y) → (y ≡ x)
inv-sym refl = refl

-- Lemma 2.1.2 & 2.1.3 "paths can be concatenated (strung together)"

-- First proof.  We need the type family D : Π (x, y : A) Π (p : x ≡ y) → Type.  From that we
--               produce an element d : D x x reflₓ (simply identity) then apply the induction
--               principle above to D and d.
composite : ∀ {i} {A : Set i}{x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
composite {i} {A} {_}{_}{z} p = ind₌ D d p where
  D : (x y : A) → (p : x ≡ y) → Set i
  D x y _ = y ≡ z → x ≡ z

  d : (x₁ : A) → D x₁ x₁ refl
  d _ = λ x → x

-- Second proof. We need the type family D : Π (x, y : A) Π (p : x ≡ y) → Type again.  From that
--               we produce an element d (x) : D x x reflₓ again, but rather than the identity we go a
--               step further and define E : Π (x z : A) Π (q : x ≡ z) → Type.  We then produce an
--               element e (x) : E x x reflₓ.  Induction on D d then unfolds to induction on D then E e.
composite' : ∀ {i} {A : Set i}{x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
composite' {i} {A} {_}{_}{z} = ind₌ D d where
  D : (x y : A) → (p : x ≡ y) → Set i
  D x y _ = y ≡ z → x ≡ z

  d : (x : A) → D x x refl
  d x = ind₌ E e where
    E : (x z : A) → (q : x ≡ z) → Set i
    E x z _ = x ≡ z

    e : (x : A) → E x x refl
    e x = refl

-- Third proof.  Everything is reflexivity you fool.  The hell did you do all that work for before?
composite'' : ∀ {i} {A : Set i}{x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
composite'' refl refl = refl

--   Equality   |        Homotopy        |     ∞-Groupoid
-- reflexivity  | constant path          | identity morphism
-- symmetry     | inversion of paths     | inverse morphism
-- transitivity | concatenation of paths | composition of morphisms

open import Function

-- Lemma 2.1.4
-- These are all propositional equalities living in the type of identity types.
-- Topologically they are paths of paths, and we can form a homotopy between them.

-- For my next trick, I will need composition of paths

-- Reflexivity right
lem-1-r : ∀ {i} {A : Set i}{x y : A}{p : x ≡ y} → p ≡ (composite p refl)
lem-1-r {i} {A} {x}{y} {p} = ind₌ D d p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = p ≡ composite p refl

  d : (x₁ : A) → D x₁ x₁ refl
  d = λ x → refl

-- Reflexivity left
lem-1-l : ∀ {i} {A : Set i}{x y : A}{p : x ≡ y} → p ≡ (composite refl p)
lem-1-l {i} {A} {x}{y} {p} = ind₌ D d p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = p ≡ composite refl p

  d : (x₁ : A) → D x₁ x₁ refl
  d = λ x → refl

lem-2-l : ∀ {i} {A : Set i}{x y : A}{p : x ≡ y} → composite ((p)⁻¹) p ≡ refl
lem-2-l {i} {A} {x}{y} {p} = ind₌ D d p where
  D : (x y : A) → (p : x ≡ y) → Set i
  D x y p = composite ((p)⁻¹) p ≡ refl

  d : (x₁ : A) → D x₁ x₁ refl
  d = λ x → refl

lem-2-r : ∀ {i} {A : Set i}{x y : A}{p : x ≡ y} → composite p ((p)⁻¹) ≡ refl
lem-2-r {i} {A} {x}{y} {p} = ind₌ D d p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = composite p ((p)⁻¹) ≡ refl

  d : (x₁ : A) → D x₁ x₁ refl
  d = λ x → refl

-- Inversion of identity
lem-3 : ∀ {i} {A : Set i}{x y : A}{p : x ≡ y} → ((p)⁻¹)⁻¹ ≡ p
lem-3 {i} {A} {x}{y} {p} = ind₌ D d p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = ((p)⁻¹)⁻¹ ≡ p

  d : (x₁ : A) → D x₁ x₁ refl
  d = λ _ → refl

{-
-- Transitivity of identity
lem-4 : ∀ {i} {A : Set i}{x y z w : A}{p : x ≡ y}{q : y ≡ z}{r : z ≡ w} → composite p (composite q r) ≡ composite (composite p q) r
lem-4 {i} {A} {_}{_}{z} = ind₌ D₁ d₁ where
  D₁ : (x y : A) → (x ≡ y) → Set i
  D₁ x y p = (z w : A)(q : y ≡ z)(r : z ≡ w) → composite p (composite q r) ≡ composite (composite p q) r

  d₁ : (x₁ : A) → D₁ x₁ x₁ refl
  d₁ _ = ind₌ D₂ d₂ where
    D₂ : (x z : A) → (q : x ≡ z) → Set i
    D₂ x z q = (w : A)(r : z ≡ w) → composite refl (composite q r) ≡ composite (composite refl q) r

    d₂ :  (x₂ : A) → D₂ x₂ x₂ refl
    d₂ _ = ind₌ D₃ d₃ where
       D₃ : (x w : A) → (r : x ≡ w) → Set i
       D₃ x w r = (composite refl (composite refl r)) ≡ (composite (composite refl refl) r)

       d₃ : (x₃ : A) → D₃ x₃ x₃ refl
       d₃ _ = composite refl (composite refl refl) ≡ composite (composite refl refl) refl
-}

-- Lemma 2.1.6

open import Data.Product using (Σ ; _,_ ; proj₁ ; proj₂)
open import Data.Nat using (ℕ ; suc)

-- We need pointed sets for this part
Set• : ∀ i → Set _
Set• i = Σ (Set i) λ X → X

-- The loop space of a type is
--  - A base point
--  - A loop (reflexivity) about that point
Ω₁ : ∀ {i} → Set• i → Set• i
Ω₁ (X , x) = ((x ≡ x) , refl)

-- Construct arbitrary n-dimensional loop spaces
Ωⁿ : ∀ {i} → ℕ → Set• i → Set• _
Ωⁿ 0 x = x
Ωⁿ (suc n) x = Ωⁿ n (Ω₁ x)

-- Projects the type from an n-dimensional loop space
Ω : ∀ {i} → ℕ → {X : Set i} → X → Set i
Ω n {X} x = proj₁ (Ωⁿ n (X , x))

-- Projects the loop from an n-dimensional loop space
loop : ∀ {i} n {X : Set i}(x : X) → Ω n x
loop n {X} x = proj₂ (Ωⁿ n (X , x))

-- Composition operation on n-dimensional loop spaces
_×_ : ∀ {i} n {A : Set i}{x : A} → Ω n x → Ω n x → Ω n x
_×_ n {A} {x} x₁ x₂ = loop n x

-- 2.2.1

-- We're type theorists, so we like functor-looking things.
-- Paths are functor looking things.
-- We like paths
-- They respect equality and are all continuous-like
ap : ∀ {i j} {A : Set i}{B : Set j}{x y : A}{f : A → B} → (x ≡ y) → (f x ≡ f y)
ap {i}{j} {A}{B} {x}{y}{f} p = ind₌ D d p where
  D : (x y : A) → (p : x ≡ y) → Set j
  D x y p = f x ≡ f y

  d : (x : A) → D x x refl
  d = λ x → refl

ap₂ : ∀ {i j k} {A : Set i}{B : Set j}{C : Set k}{x x′ : A}{y y′ : B}(f : A → B → C) → (x ≡ x′) → (y ≡ y′) → (f x y ≡ f x′ y′)
ap₂ f p q = composite (ap {f = λ _ → f _ _} p) (ap {f = f _} q)

ap' : ∀ {i j} {A : Set i}{B : Set j}{x y : A} → (f : A → B) → ((x ≡ y) → (f x ≡ f y))
ap' f refl = refl

-- 2.3

-- The dependently typed version of `ap` takes a type family and relates its instantiations with p
transport : ∀ {i} {A : Set i}{P : A → Set i}{x y : A} → (p : x ≡ y) → (P x → P y)
transport {i} {A}{P} {x}{y} p = ind₌ D d p where
    D : (x y : A) → (p : x ≡ y) → Set i
    D x y p = P x → P y

    d : (x : A) → D x x refl
    d = λ x → id
-- Topologically, we can view transport as a "path lifting" operation
-- That is, we lift the path p to a path in the space ∑[ x ∈ A ] P(x) provided we have a
-- base point u in the lifted space.
--
-- Basically, P respects equality
path-lifting : ∀ {a p}{A : Set a}{x y : A}{P : A → Set p} → (u : P x) → (p : x ≡ y) → (x , u) ≡ (y , u)
path-lifting = λ {a} {p} {A} {x} {y} {P} u → cong (λ z → z , u)

-- Look, transport works in the "upper" space too!
apd : ∀ {i} {A : Set i}{P : A → Set i}{f : (x : A) → P x}{x y : A} → (p : x ≡ y) → (transport p (f x) ≡ f y)
apd {i} {A}{P} {f}{x}{y} p = ind₌ D d p where
  D : (x y : A) → (p : x ≡ y) → Set i
  D x y p = transport p (f x) ≡ f y

  d : (x : A) → D x x refl
  d = λ x → refl

-- By induction, it suffices to assume p is refl.  Because of course it does.
apd' : ∀ {i} {A : Set i}{P : A → Set i}{f : (x : A) → P x}{x y : A} → (p : x ≡ y) → (transport p (f x) ≡ f y)
apd' refl = refl

-- We can also fix B and make transport work like fmap with equalities.
transportconst : ∀ {i} {A : Set i}{B : Set i}{P : A → B}{x y : A} → (p : x ≡ y) → (b : B) → transport p b ≡ b
transportconst {i} {A}{B}{P} {x}{y} p b = ind₌ D d p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = transport p b ≡ b

  d : (x : A) → D x x refl
  d = λ x → refl

{-
lem-2-3-8 : ∀ {i} {A : Set i}{B : Set i}{f : A → B}{x y : A} → (p : x ≡ y) → apd p ≡ transportconst (ap p) (f x)
lem-2-3-8 {i} {A}{B}{f} {x}{y} p = ind₌ D d p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = apd p ≡ transportconst (f x) ∘ ap p

  d : (x : A) → D x x refl
  d = refl
-}

{-
lem-2-3-9 : ∀ {i} {A : Set i}{P : A → Set i}{x y z : A} → (p : x ≡ y) → (q : y ≡ z) → (u : P x) → transport q (transport p u) ≡ transport (p ∘ q) u
lem-2-3-9 = ?
-}

-- Homotopies

-- Under Propositions-as-Types two functions are the same if they give the same outputs on the
-- same inputs.  Which looks like this: a type whose terms are proofs of that^
_∼_ : ∀ {a b} {A : Set a}{P : A → Set b} → (f g : (x : A) → P x) → Set (a ⊔ b)
_∼_ {a}{b} {A}{P} f g = (x : A) → f x ≡ g x

-- 2.4.2

lem-2-4-2 : ∀ {a} {A : Set a}{B : Set a} → (f : A → B) → f ∼ f
lem-2-4-2 f = λ _ → refl

lem-2-4-2' : ∀ {a} {A : Set a}{B : Set a} → (f g : A → B) → (f ∼ g) → (g ∼ f)
lem-2-4-2' f g x x₁ = sym (x x₁)

-- For any A and B, a quasi-inverse of f is a triple with
--    ∘ A way back (an inverse for the homomorphism)
--    ∘ Homotopies:
--        ⊚ α : f ∘ g ∼ id
--        ⊚ β : g ∘ f ∼ id
-- For now, because I am lazy, the presence of a quasi-inverse will count
-- as our definition of equivalence for now.  Sorry.
record IsEquiv {i j}{A : Set i}{B : Set j}(to : A → B) : Set (i ⊔ j) where
  field
    from : B → A
    iso₁ : (x : A) → from (to x) ≡ x
    iso₂ : (y : B) → to (from y) ≡ y

-- Example 2.4.7: Identity is an equivalence.
id-is-equiv : ∀ {i} (A : Set i) → IsEquiv (id {i}{A})
id-is-equiv {i} A = record
  { from = id {i}{A}
  ; iso₁ = λ _ → refl
  ; iso₂ = λ _ → refl
  }

-- Type equivalence is also an equivalence, just on the Universe because:
--    ∘ id-is-equiv works for it, therefore A ≃ A
--    ∘ With A ≃ B, we can always make B ≃ A
--    ∘ With A ≃ B and B ≃ C we have A ≃ C
_≃_ : ∀ {i j} (A : Set i) (B : Set j) → Set (i ⊔ j)
A ≃ B = Σ (A → B) IsEquiv

open import Data.Product renaming (_×_ to _×p_)

split-path : ∀ {i j}{A : Set i}{B : Set j}{x y : A ×p B} → x ≡ y → (proj₁ x ≡ proj₁ y) ×p (proj₂ x ≡ proj₂ y)
split-path p = ap {f = proj₁} p , ap {f = proj₂} p

pair₌ : ∀ {i j}{A : Set i}{B : Set j}{x y : A ×p B} → (proj₁ x ≡ proj₁ y) ×p (proj₂ x ≡ proj₂ y) → x ≡ y
pair₌ (p , q) = ap₂ _,_ p q

instance
  split-is-equiv : ∀ {i j}{A : Set i}{B : Set j}{x y : A ×p B} → IsEquiv (pair₌ {x = x}{y = y})
  split-is-equiv {x = x}{y = y} = record
    { from = split-path
    ; iso₁ = λ pq →
            ind₌ (λ _ _ p → ∀ {b₁ b₂} (q : b₁ ≡ b₂) →
              split-path (pair₌ (p , q)) ≡ (p , q))
            (λ _ q → ind₌
              (λ _ _ q →
                split-path (pair₌ (refl , q)) ≡ (refl , q))
              (λ _ → refl) q)
                (proj₁ pq) (proj₂ pq)
    ; iso₂ = ind₌ (λ _ _ p → pair₌ (split-path p) ≡ p) (λ _ → refl)
    }

{-
happly : ∀ {i}{A : Set i}{f g : A → Set i} → (f ≡ g) → ((x : A) → f x ≡ g x)
happly p x = ap' (λ u → u x)
-}

-- 2.10

-- This says, when you get down to it, id on universes is a
-- type family with a total space of pointed types.  Turns out
-- Ω isn't just for horses.
idtoeqv : ∀ {i} {A : Set i}{B : Set i} → (A ≡ B) → (A ≃ B)
idtoeqv {_}{A} refl = (id , id-is-equiv A)

-- With idtoeqv in hand, we have to ask Agda nicely to make idtoeqv an equivalence.

postulate -- Just kidding
  ua : ∀ {i} {A : Set i}{B : Set i} → (A ≃ B) ≃ (A ≡ B)
-- ^This says "equivalent types may be identified"

-- 2.12

{-
data _⊎_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inl : (x : A) → A ⊎ B
  inr : (y : B) → A ⊎ B

code : ∀ {a b}{{A : Set a}}{{B : Set b}} → A ⊎ B → Set (a ⊔ b)
code (inl a) = ?
code (inr b) = ⊥

code-lem : ∀ {a b}{{A : Set a}}{{B : Set b}} → (x : A ⊎ B) → (a₀ : A) → ((inl a₀ ≡ x) ≃ code x)
code-lem {{A}} {{B}} x a₀ = ? where
    encode : (x : A ⊎ B) → (p : inl a₀ ≡ x) → code x
    encode x p = transport p refl

    decode : (x : A ⊎ B) → (c : code x) → inl a₀ ≡ x
    decode x c = ?
-}

open import Data.Nat
open import Data.Unit
open import Data.Empty

code : ℕ → ℕ → Set
code ℕ.zero ℕ.zero = ⊤
code ℕ.zero (ℕ.suc m) = ⊥
code (ℕ.suc n) ℕ.zero = ⊥
code (ℕ.suc n) (ℕ.suc m) = code n m

-- 2.13

natcode-lem : ∀ {m n : ℕ} → (m ≡ n) → code m n
natcode-lem {x}{y} p = encode {x}{y} p where
  encode : ∀ {m n : ℕ} → (m ≡ n) → code m n
  encode {m}{n} p = transport p (r m) where
    r : (n : ℕ) → code n n
    r ℕ.zero = tt
    r (ℕ.suc n) = r n

  decode : ∀ {m n : ℕ} → code m n → (m ≡ n)
  decode {ℕ.zero} {ℕ.zero} tt = refl
  decode {ℕ.zero} {ℕ.suc _} ()
  decode {ℕ.suc _} {ℕ.zero} ()
  decode {ℕ.suc m} {ℕ.suc n} c = cong ℕ.suc (decode c)

  enc-dec-quasi : ∀ {n : ℕ} → decode {n}{n} (encode {n}{n} refl) ≡ refl
  enc-dec-quasi {ℕ.zero} = refl
  enc-dec-quasi {ℕ.suc n₁} = {! !}


{-# OPTIONS --safe #-}

module Data.Vec.Sigma where

open import Prelude
open import Data.Unit.UniversePolymorphic renaming (⊤ to ⊤′)

Vec⁺ : Type a → ℕ → Type a
Vec⁺ A zero    = A
Vec⁺ A (suc n) = A × Vec⁺ A n

Vec : Type a → ℕ → Type a
Vec A 0       = ⊤′
Vec A (suc n) = Vec⁺ A n

private variable n : ℕ

open import Data.List using (List; _∷_; [])

toList⁺ : Vec⁺ A n → List A
toList⁺ {n = zero } x = x ∷ []
toList⁺ {n = suc n} (x , xs) = x ∷ toList⁺ xs

toList : Vec A n → List A
toList {n = zero } _ = []
toList {n = suc n} = toList⁺


------------------------------------------------------------------------
-- The Agda standard library
--
-- Examples showing how the case expressions can be used
------------------------------------------------------------------------

module README.Case where

open import Data.Fin   hiding (pred)
open import Data.Maybe hiding (from-just)
open import Data.Nat   hiding (pred)
open import Function

-- Some simple examples.

empty : ∀ {a} {A : Set a} → Fin 0 → A
empty i = case i of λ()

pred : ℕ → ℕ
pred n = case n of λ
  { zero    → zero
  ; (suc n) → n
  }

from-just : ∀ {a} {A : Set a} (x : Maybe A) → From-just A x
from-just x = case x return From-just _ of λ
  { (just x) → x
  ; nothing  → _
  }

-- Note that some natural uses of case are rejected by the termination
-- checker:
--
-- plus : ℕ → ℕ → ℕ
-- plus m n = case m of λ
--   { zero    → n
--   ; (suc m) → suc (plus m n)
--   }


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

-- | Quotient integer
module QuoInt where

open import Cubical.Core.Everything
open import Cubical.HITs.Ints.QuoInt renaming (_+ℤ_ to _+_; ℤ to Z)

open import Cubical.Data.Nat hiding (_+_)
open import Cubical.Foundations.Prelude

+-i-zero : ∀ a i → posneg i + a ≡ a
+-i-zero a i =
  cong (_+ a) (lemma₁ i)
  ∙ -- x ≡ y → y ≡ z → x ≡ z
  lemma₀ a
  where
    lemma₀ : ∀ a → pos 0 + a ≡ a
    lemma₀ (pos zero) = refl
    lemma₀ (pos (suc n)) = cong sucℤ (lemma₀ (pos n))
    lemma₀ (neg zero) = posneg
    lemma₀ (neg (suc n)) = cong predℤ (lemma₀ (neg n))
    lemma₀ (posneg i) j = posneg (i ∧ j)

    lemma₁ : ∀ i → posneg i ≡ pos 0
    lemma₁ i j = posneg (i ∧ ~ j)


open import Data.Boolean
open import Type

module Data.List.Sorting.HeapSort {ℓ} {T : Type{ℓ}} (_≤?_ : T → T → Bool) where

import      Lvl
open import Data.List
import      Data.List.Functions as List
open import Data.BinaryTree
import      Data.BinaryTree.Heap as Heap
open import Functional using (_∘_)

heapSort : List(T) → List(T)
heapSort = Heap.foldOrdered(_≤?_)(_⊰_) ∅ ∘ List.foldᵣ(Heap.insert(_≤?_)) emptyTree

module Proofs where


module Ints where

open import Nats public
  using (ℕ; zero; _∸_)
  renaming (suc to nsuc; _+_ to _:+:_; _*_ to _:*:_)
open import Agda.Builtin.Int public
  renaming (Int to ℤ; negsuc to -[1+_]; pos to +_)

infix  8 -_
-- infixl 7 _*_ _⊓_
infixl 6 _+_ _-_ _⊖_

∣_∣ : ℤ → ℕ
∣ + n      ∣ = n
∣ -[1+ n ] ∣ = nsuc n

-_ : ℤ → ℤ
- (+ nsuc n) = -[1+ n ]
- (+ zero)   = + zero
- -[1+ n ]   = + nsuc n

_⊖_ : ℕ → ℕ → ℤ
m      ⊖ zero   = + m
zero   ⊖ nsuc n = -[1+ n ]
nsuc m ⊖ nsuc n = m ⊖ n

_+_ : ℤ → ℤ → ℤ
-[1+ m ] + -[1+ n ] = -[1+ nsuc (m :+: n) ]
-[1+ m ] + +    n   = n ⊖ nsuc m
+    m   + -[1+ n ] = m ⊖ nsuc n
+    m   + +    n   = + (m :+: n)

_-_ : ℤ → ℤ → ℤ
i - j = i + - j

suc : ℤ → ℤ
suc i = + 1 + i


module Type.Properties.Homotopy where

open import Functional
import      Lvl
open import Numeral.Natural
open import Structure.Setoid
open import Type
open import Type.Dependent
open import Syntax.Function

private variable ℓ ℓ₁ ℓ₂ ℓₑ : Lvl.Level
private variable T A B : Type{ℓ}
private variable n : ℕ

module _ {ℓ} ⦃ equiv : ∀{T : Type{ℓ}} → Equiv{ℓ}(T) ⦄ where -- TODO: Maybe the requirements can be relaxed to a tower of equivalences?
  module Names where
    HomotopyLevel : ℕ → (A : Type{ℓ}) → Type
    HomotopyLevel(𝟎)      (A) = Σ(A)(x ↦ ∀{y} → (y ≡ x))
    HomotopyLevel(𝐒(𝟎))   (A) = ∀{x y : A} → (x ≡ y)
    HomotopyLevel(𝐒(𝐒(n)))(A) = ∀{x y : A} → HomotopyLevel(𝐒(n))(x ≡ y)

    Truncation = HomotopyLevel ∘ 𝐒 ∘ 𝐒

  record HomotopyLevel(n : ℕ) (A : Type{ℓ}) : Type{ℓ} where
    constructor intro
    field proof : Names.HomotopyLevel(n)(A)

  Truncation = HomotopyLevel ∘ 𝐒 ∘ 𝐒

-- TODO: Where should this be stated?
-- ExcludedMiddle : (A : Type{ℓ}) ⦃ equiv-A : Equiv{ℓₑ}(A) ⦄ → Stmt
-- ExcludedMiddle(A) = MereProposition(A) → (IsUnit(A) ∨ IsEmpty(A))


open import Prelude
open import Nat
open import Agda.Primitive using (Level; lzero; lsuc) renaming (_⊔_ to lmax)

module List where

  -- definitions

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

  _++_ : {A : Set} → List A → List A → List A
  [] ++ l₂ = l₂
  (h :: l₁) ++ l₂ = h :: (l₁ ++ l₂)

  infixl 50 _++_

  ∥_∥ : {A : Set} → List A → Nat
  ∥ [] ∥ = Z
  ∥ a :: as ∥ = 1+ ∥ as ∥

  _⟦_⟧ : {A : Set} → List A → Nat → Maybe A
  [] ⟦ i ⟧ = None
  (a :: as) ⟦ Z ⟧ = Some a
  (a :: as) ⟦ 1+ i ⟧ = as ⟦ i ⟧

  map : {A B : Set} → (A → B) → List A → List B
  map f [] = []
  map f (a :: as) = f a :: map f as

  foldl : {A B : Set} → (B → A → B) → B → List A → B
  foldl f b [] = b
  foldl f b (a :: as) = foldl f (f b a) as

  concat : {A : Set} → List (List A) → List A
  concat [] = []
  concat (l1 :: rest) = l1 ++ (concat rest)

  -- if the lists aren't the same length,
  -- the extra elements of the longer list are ignored
  zip : {A B : Set} → List A → List B → List (A ∧ B)
  zip []        _         = []
  zip (a :: as) []        = []
  zip (a :: as) (b :: bs) = (a , b) :: zip as bs

  unzip : {A B : Set} → List (A ∧ B) → (List A ∧ List B)
  unzip [] = ([] , [])
  unzip ((a , b) :: rest)
    with unzip rest
  ... | (as , bs) = (a :: as , b :: bs)

  reverse : {A : Set} → List A → List A
  reverse [] = []
  reverse (a :: as) = reverse as ++ (a :: [])

  -- theorems

  list-==-dec :  {A : Set} →
                 (l1 l2 : List A) →
                 ((a1 a2 : A) → a1 == a2 ∨ a1 ≠ a2) →
                 l1 == l2 ∨ l1 ≠ l2
  list-==-dec [] [] A-==-dec       = Inl refl
  list-==-dec [] (_ :: _) A-==-dec = Inr (λ ())
  list-==-dec (_ :: _) [] A-==-dec = Inr (λ ())
  list-==-dec (h1 :: t1) (h2 :: t2) A-==-dec
    with A-==-dec h1 h2
  ... | Inr ne = Inr (λ where refl → ne refl)
  ... | Inl refl
    with list-==-dec t1 t2 A-==-dec
  ... | Inr ne = Inr (λ where refl → ne refl)
  ... | Inl refl = Inl refl

  -- if the items of two lists are equal, then the lists are equal
  ==-per-elem : {A : Set} → {l1 l2 : List A} →
                 ((i : Nat) → l1 ⟦ i ⟧ == l2 ⟦ i ⟧) →
                 l1 == l2
  ==-per-elem {l1 = []} {[]} items== = refl
  ==-per-elem {l1 = []} {h2 :: t2} items== = abort (somenotnone (! (items== Z)))
  ==-per-elem {l1 = h1 :: t1} {[]} items== = abort (somenotnone (items== Z))
  ==-per-elem {l1 = h1 :: t1} {h2 :: t2} items==
    rewrite someinj (items== Z) | ==-per-elem {l1 = t1} {t2} (λ i → items== (1+ i))
      = refl

  -- _++_ theorems
  ++assc : ∀{A a1 a2 a3} → (_++_ {A} a1 a2) ++ a3 == a1 ++ (a2 ++ a3)
  ++assc {A} {[]} {a2} {a3} = refl
  ++assc {A} {x :: a1} {a2} {a3} with a1 ++ a2 ++ a3 | ++assc {A} {a1} {a2} {a3}
  ++assc {A} {x :: a1} {a2} {a3} | _ | refl = refl

  l++[]==l : {A : Set} (l : List A) →
              l ++ [] == l
  l++[]==l [] = refl
  l++[]==l (a :: as)
    rewrite l++[]==l as
      = refl

  -- ∥_∥ theorem
  ∥-++-comm : ∀{A a1 a2} → ∥ a1 ∥ + (∥_∥ {A} a2) == ∥ a1 ++ a2 ∥
  ∥-++-comm {A} {[]} {a2} = refl
  ∥-++-comm {A} {a :: a1} {a2} = 1+ap (∥-++-comm {A} {a1})

  -- _⟦_⟧ and ++ theorem
  ⦇l1++[a]++l2⦈⟦∥l1∥⟧==a : {A : Set} {l1 l2 : List A} {a : A} →
                             (h : ∥ l1 ∥ < ∥ l1 ++ (a :: []) ++ l2 ∥) →
                             ((l1 ++ (a :: []) ++ l2) ⟦ ∥ l1 ∥ ⟧ == Some a)
  ⦇l1++[a]++l2⦈⟦∥l1∥⟧==a {l1 = []} h = refl
  ⦇l1++[a]++l2⦈⟦∥l1∥⟧==a {l1 = a1 :: l1rest} {l2} {a} h = ⦇l1++[a]++l2⦈⟦∥l1∥⟧==a {l1 = l1rest} {l2} {a} (1+n<1+m→n<m h)

  -- packaging of list indexing results
  list-index-dec : {A : Set} (l : List A) (i : Nat) →
                    l ⟦ i ⟧ == None ∨ Σ[ a ∈ A ] (l ⟦ i ⟧ == Some a)
  list-index-dec l i
    with l ⟦ i ⟧
  ... | None   = Inl refl
  ... | Some a = Inr (a , refl)

  -- theorems characterizing the partiality of list indexing
  list-index-some : {A : Set} {l : List A} {i : Nat} →
                     i < ∥ l ∥ →
                     Σ[ a ∈ A ] (l ⟦ i ⟧ == Some a)
  list-index-some {l = []}      {Z}    i<∥l∥ = abort (n≮0 i<∥l∥)
  list-index-some {l = a :: as} {Z}    i<∥l∥ = _ , refl
  list-index-some {l = a :: as} {1+ i} i<∥l∥ = list-index-some (1+n<1+m→n<m i<∥l∥)

  list-index-none : {A : Set} {l : List A} {i : Nat} →
                     ∥ l ∥ ≤ i →
                     l ⟦ i ⟧ == None
  list-index-none {l = []}             i≥∥l∥ = refl
  list-index-none {l = a :: as} {1+ i} i≥∥l∥ = list-index-none (1+n≤1+m→n≤m i≥∥l∥)

  list-index-some-conv : {A : Set} {l : List A} {i : Nat} {a : A} →
                          l ⟦ i ⟧ == Some a →
                          i < ∥ l ∥
  list-index-some-conv {l = l} {i} i≥∥l∥
    with <dec ∥ l ∥ i
  ... | Inr (Inr i<∥l∥) = i<∥l∥
  ... | Inr (Inl refl)
    rewrite list-index-none {l = l} {∥ l ∥} ≤refl
      = abort (somenotnone (! i≥∥l∥))
  ... | Inl ∥l∥<i
    rewrite list-index-none (n<m→n≤m ∥l∥<i)
      = abort (somenotnone (! i≥∥l∥))

  list-index-none-conv : {A : Set} {l : List A} {i : Nat} →
                          l ⟦ i ⟧ == None →
                          ∥ l ∥ ≤ i
  list-index-none-conv {l = l} {i} i≥∥l∥
    with <dec ∥ l ∥ i
  ... | Inl ∥l∥<i       = n<m→n≤m ∥l∥<i
  ... | Inr (Inl refl) = ≤refl
  ... | Inr (Inr i<∥l∥)
    with list-index-some i<∥l∥
  ... | _ , i≱∥l∥ rewrite i≥∥l∥ = abort (somenotnone (! i≱∥l∥))

  ∥l1∥==∥l2∥→l1[i]→l2[i] : {A B : Set} {la : List A} {lb : List B} {i : Nat} {a : A} →
                             ∥ la ∥ == ∥ lb ∥ →
                             la ⟦ i ⟧ == Some a →
                             Σ[ b ∈ B ] (lb ⟦ i ⟧ == Some b)
  ∥l1∥==∥l2∥→l1[i]→l2[i] {i = i} ∥la∥==∥lb∥ la[i]==a
    = list-index-some (tr (λ y → i < y) ∥la∥==∥lb∥ (list-index-some-conv la[i]==a))

  ∥l1∥==∥l2∥→¬l1[i]→¬l2[i] : {A B : Set} {la : List A} {lb : List B} {i : Nat} →
                                ∥ la ∥ == ∥ lb ∥ →
                                la ⟦ i ⟧ == None →
                                lb ⟦ i ⟧ == None
  ∥l1∥==∥l2∥→¬l1[i]→¬l2[i] {i = i} ∥la∥==∥lb∥ la[i]==None
    = list-index-none (tr (λ y → y ≤ i) ∥la∥==∥lb∥ (list-index-none-conv la[i]==None))

  -- map theorem
  map-++-comm : ∀{A B f a b} → map f a ++ map f b == map {A} {B} f (a ++ b)
  map-++-comm {a = []} = refl
  map-++-comm {A} {B} {f} {h :: t} {b} with map f (t ++ b) | map-++-comm {A} {B} {f} {t} {b}
  map-++-comm {A} {B} {f} {h :: t} {b} | _ | refl = refl

  -- foldl theorem
  foldl-++ : {A B : Set} {l1 l2 : List A} {f : B → A → B} {b0 : B} →
              foldl f b0 (l1 ++ l2) == foldl f (foldl f b0 l1) l2
  foldl-++ {l1 = []} = refl
  foldl-++ {l1 = a1 :: l1rest} = foldl-++ {l1 = l1rest}

  -- zip/unzip theorems
  unzip-inv : {A B : Set} {l : List (A ∧ B)} {la : List A} {lb : List B} →
               unzip l == (la , lb) →
               l == zip la lb
  unzip-inv {l = []} form
    with form
  ... | refl = refl
  unzip-inv {l = (a' , b') :: rest} {a :: as} {b :: bs} form
    with unzip rest  | unzip-inv {l = rest} refl | form
  ...  | (as' , bs') | refl                      | refl = refl

  zip-inv : {A B : Set} {la : List A} {lb : List B} →
             ∥ la ∥ == ∥ lb ∥ →
             unzip (zip la lb) == (la , lb)
  zip-inv {la = []}      {[]}      len-eq = refl
  zip-inv {la = a :: as} {b :: bs} len-eq
    with unzip (zip as bs) | zip-inv (1+inj len-eq)
  ...  | (as' , bs')       | refl                   = refl

  -- reverse theorems
  reverse-single : {A : Set} {a : A} → reverse (a :: []) == a :: []
  reverse-single = refl

  reverse-++ : {A : Set} {l1 l2 : List A} →
                reverse (l1 ++ l2) == reverse l2 ++ reverse l1
  reverse-++ {l1 = []} {l2}
    rewrite l++[]==l (reverse l2)
      = refl
  reverse-++ {l1 = a1 :: as1} {l2}
    rewrite reverse-++ {l1 = as1} {l2}
      = ++assc {a1 = reverse l2}

  reverse-inv : {A : Set} {l : List A} → reverse (reverse l) == l
  reverse-inv {l = []} = refl
  reverse-inv {l = a :: as}
    rewrite reverse-++ {l1 = reverse as} {a :: []} | reverse-inv {l = as}
      = refl


{-# OPTIONS --universe-polymorphism #-}
module Categories.Discrete where

open import Level
open import Data.Unit using (⊤)
open import Function using (flip)

open import Categories.Category
open import Categories.Support.PropositionalEquality

Discrete : ∀ {o} (A : Set o) → Category o o zero
Discrete A = record
  { Obj = A
  ; _⇒_ = _≣_
  ; _≡_ = λ _ _ → ⊤
  ; _∘_ = flip ≣-trans
  ; id = ≣-refl
  ; assoc = _
  ; identityˡ = _
  ; identityʳ = _
  ; equiv = _
  ; ∘-resp-≡ = _
  }