{-# OPTIONS --without-K #-}
module sets.list.core where

open import sum
import sets.vec.core as V
open import sets.nat.core

List : ∀ {i} → Set i → Set i
List A = Σ ℕ (V.Vec A)

module _ {i}{A : Set i} where
  vec-to-list : ∀ {n} → V.Vec A n → List A
  vec-to-list {n} xs = n , xs

  [] : List A
  [] = 0 , V.[]

  infixr 4 _∷_
  _∷_ : A → List A → List A
  x ∷ (n , xs) = suc n , x V.∷ xs


------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic using Agsy
------------------------------------------------------------------------------

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

module FOT.Agsy.AxiomaticPA where

open import Common.FOL.FOL public renaming ( D to ℕ )

infixl 10 _*_
infix  7  _≐_
infixl 9  _+_

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

-- Non-logical constants
postulate
  zero : ℕ
  succ : ℕ → ℕ
  _+_  : ℕ → ℕ → ℕ
  _*_  : ℕ → ℕ → ℕ
  _≐_  : ℕ → ℕ → Set

-- Proper axioms
-- (From Elliott Mendelson. Introduction to mathematical
-- logic. Chapman & Hall, 4th edition, 1997, p. 155)

-- N.B. We make the recursion in the first argument for _+_ and _*_.

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + m
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wf P(n) of PA.

postulate
  S₁ : {m n o : ℕ} → m ≐ n → m ≐ o → n ≐ o
  S₂ : ∀ {m n} → m ≐ n → succ m ≐ succ n
  S₃ : ∀ {n} → ¬ (zero ≐ succ n)
  S₄ : ∀ {m n} → succ m ≐ succ n → m ≐ n
  S₅ : ∀ n →   zero   + n ≐ n
  S₆ : ∀ m n → succ m + n ≐ succ (m + n)
  S₇ : ∀ n →   zero   * n ≐ zero
  S₈ : ∀ m n → succ m * n ≐ n + m * n
  S₉ : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n

-- Properties

refl : ∀ {n} → n ≐ n
refl {n} = S₁ (S₅ n) (S₅ n) -- Via Agsy {-m}

sym : ∀ {m n} → m ≐ n → n ≐ m
sym h = S₁ h refl  -- Via Agsy {-m}

trans : ∀ {m n o} → m ≐ n → n ≐ o → m ≐ o
trans h₁ h₂ = S₁ (sym h₁) h₂  -- Via Agsy {-m}

+-rightIdentity : ∀ n → n + zero ≐ n
+-rightIdentity n = {!-t 20 -m!}  -- Agsy fails


import      Lvl
open import Structure.Setoid
open import Type

module Structure.Operator.Vector.Subspaces.Kernel
  {ℓₛ ℓₛₑ}
  {S : Type{ℓₛ}}
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  {_+ₛ_ _⋅ₛ_ : S → S → S}
  where

open import Logic.Predicate
open import Sets.ExtensionalPredicateSet as PredSet using (PredSet ; _∈_ ; [∋]-binaryRelator)
open import Structure.Container.SetLike as SetLike using (SetElement)
open import Structure.Function.Multi
open import Structure.Operator
open import Structure.Operator.Properties
open import Structure.Operator.Vector
open import Structure.Operator.Vector.LinearMap
open import Structure.Operator.Vector.Proofs
open import Structure.Operator.Vector.Subspace
open import Structure.Relator.Properties
open import Syntax.Implication
open import Syntax.Transitivity

open VectorSpace ⦃ … ⦄
open VectorSpaceVObject ⦃ … ⦄ using (_+ᵥ_; _⋅ₛᵥ_)
open VectorSpaceVObject       using (Vector)

private variable ℓ ℓᵥ ℓᵥₑ : Lvl.Level
private variable V W : VectorSpaceVObject {ℓᵥ = ℓᵥ} {ℓᵥₑ = ℓᵥₑ} ⦃ equiv-S = equiv-S ⦄ (_+ₛ_)(_⋅ₛ_)
private variable F : V →ˡⁱⁿᵉᵃʳᵐᵃᵖ W

kernel : (V →ˡⁱⁿᵉᵃʳᵐᵃᵖ W) → PredSet(Vector(V))
kernel {V = V}{W = W} ([∃]-intro f) = PredSet.unapply f(𝟎ᵥ)

kernel-subspace : Subspace(kernel(F))
SetLike.FunctionProperties._closed-under₂_.proof (Subspace.add-closure (kernel-subspace {_} {_} {V} {_} {_} {W} {F = F@([∃]-intro f)})) {x} {y} xkern ykern =
  • (
    xkern         ⇒
    x ∈ kernel(F) ⇒-[]
    f(x) ≡ 𝟎ᵥ     ⇒-end
  )
  • (
    ykern         ⇒
    y ∈ kernel(F) ⇒-[]
    f(y) ≡ 𝟎ᵥ     ⇒-end
  )                       ⇒₂-[ congruence₂{A₁ = Vector(W)}{A₂ = Vector(W)}(_+ᵥ_) ]
  f(x) +ᵥ f(y) ≡ 𝟎ᵥ +ᵥ 𝟎ᵥ ⇒-[ _🝖 identityᵣ(_+ᵥ_)(𝟎ᵥ) ]
  f(x) +ᵥ f(y) ≡ 𝟎ᵥ       ⇒-[ preserving₂(f)(_+ᵥ_)(_+ᵥ_) 🝖_ ]
  f(x +ᵥ y) ≡ 𝟎ᵥ          ⇒-[]
  (x +ᵥ y) ∈ kernel(F)    ⇒-end
  where
    instance _ = V
    instance _ = W
SetLike.FunctionProperties._closed-under₁_.proof (Subspace.mul-closure (kernel-subspace {_}{_}{V}{_}{_}{W} {F = F@([∃]-intro f)}) {s}) {v} vkern =
  vkern ⇒
  v ∈ kernel(F)         ⇒-[]
  f(v) ≡ 𝟎ᵥ             ⇒-[ congruence₂ᵣ(_⋅ₛᵥ_)(s) ]
  s ⋅ₛᵥ f(v) ≡ s ⋅ₛᵥ 𝟎ᵥ ⇒-[ _🝖 [⋅ₛᵥ]-absorberᵣ ]
  s ⋅ₛᵥ f(v) ≡ 𝟎ᵥ       ⇒-[ preserving₁(f)(s ⋅ₛᵥ_)(s ⋅ₛᵥ_) 🝖_ ]
  f(s ⋅ₛᵥ v) ≡ 𝟎ᵥ       ⇒-[]
  (s ⋅ₛᵥ v) ∈ kernel(F) ⇒-end
  where
    instance _ = V
    instance _ = W


module ModuleInfix where

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

module Sort(A : Set)(_≤_ : A → A → Bool)(_⊝_ : A → A → A)(zero : A) where

  infix 1 _≤_
  infix 2 _⊝_

  insert : A → List A → List A
  insert x [] = x ∷ []
  insert x (y ∷ ys) with zero ≤ (y ⊝ x)
  insert x (y ∷ ys)    | true  = x ∷ y ∷ ys
  insert x (y ∷ ys)    | false = y ∷ insert x ys

  sort : List A → List A
  sort []       = []
  sort (x ∷ xs) = insert x (sort xs)


------------------------------------------------------------------------------
-- Conversion functions i, j and k.
------------------------------------------------------------------------------

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

module FOT.FOTC.IJK where

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

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

data ℕ : Set where
  z : ℕ
  s : ℕ → ℕ

-- Conversion functions from/to ℕ and N.
i : ℕ → D
i z     = zero
i (s n) = succ₁ (i n)

j : (n : ℕ) → N (i n)
j z     = nzero
j (s n) = nsucc (j n)

k : {n : D} → N n → ℕ
k nzero      = z
k (nsucc Nn) = s (k Nn)

_+_ : ℕ → ℕ → ℕ
z   + n = n
s m + n = s (m + n)


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

open import M-types.Base.Core
open import M-types.Base.Sum
open import M-types.Base.Prod
open import M-types.Base.Eq

module M-types.Base.Equi where
    Qinv : {X : Ty ℓ₀} {Y : Ty ℓ₁} →
        ∏[ f ∈ (X → Y)] Ty (ℓ-max ℓ₀ ℓ₁)
    Qinv {_} {_} {X} {Y} f = ∑[ g ∈ (Y → X) ]
        (∏[ x ∈ X ] g (f x) ≡ x) ×
        (∏[ y ∈ Y ] f (g y) ≡ y)

    IsEqui : {X : Ty ℓ₀} {Y : Ty ℓ₁} →
        ∏[ f ∈ (X → Y) ] Ty (ℓ-max ℓ₀ ℓ₁)
    IsEqui {_} {_} {X} {Y} f =
        (∑[ g ∈ (Y → X) ] ∏[ x ∈ X ] g (f x) ≡ x) ×
        (∑[ g ∈ (Y → X) ] ∏[ y ∈ Y ] f (g y) ≡ y)

    infixr 8 _≃_
    _≃_ : ∏[ X ∈ Ty ℓ₀ ] ∏[ Y ∈ Ty ℓ₁ ] Ty (ℓ-max ℓ₀ ℓ₁)
    X ≃ Y = ∑[ f ∈ (X → Y) ] IsEqui f

    Qinv→IsEqui : {X : Ty ℓ₀} {Y : Ty ℓ₁} {f : X → Y} →
        Qinv f → IsEqui f
    Qinv→IsEqui (g , hom₀ , hom₁) = ((g , hom₀) , (g , hom₁))

    IsEqui→Qinv : {X : Ty ℓ₀} {Y : Ty ℓ₁} {f : X → Y} →
        IsEqui f → Qinv f
    IsEqui→Qinv {_} {_} {_} {_} {f} ((g₀ , hom₀) , (g₁ , hom₁)) =
        (
            g₀ ,
            hom₀ ,
            λ y → ap f (ap g₀ (hom₁ y)⁻¹ · hom₀ (g₁ y)) · hom₁ y
        )

    inv : {X : Ty ℓ₀} {Y : Ty ℓ₁} →
        ∏[ equi ∈ X ≃ Y ] (Y → X)
    inv (fun , isEqui) = pr₀ (IsEqui→Qinv isEqui)

    hom₀ : {X : Ty ℓ₀} {Y : Ty ℓ₁} →
        ∏[ equi ∈ X ≃ Y ] ∏[ x ∈ X ] inv equi (fun equi x) ≡ x
    hom₀ (fun , isEqui) = pr₀ (pr₁ (IsEqui→Qinv isEqui))

    hom₁ : {X : Ty ℓ₀} {Y : Ty ℓ₁} →
        ∏[ equi ∈ X ≃ Y ] ∏[ y ∈ Y ] fun equi (inv equi y) ≡ y
    hom₁ (fun , isEqui) = pr₁ (pr₁ (IsEqui→Qinv isEqui))


------------------------------------------------------------------------------
-- Proving properties without using pattern matching on refl
------------------------------------------------------------------------------

{-# OPTIONS --no-pattern-matching #-}
{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}

module FOT.DistributiveLaws.NoPatternMatchingOnRefl where

open import DistributiveLaws.Base

------------------------------------------------------------------------------
-- From DistributiveLaws.PropertiesI

-- Congruence properties

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong {a} {c = c} h = subst (λ t → a · c ≡ t · c) h refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong {a} {b} h = subst (λ t → a · b ≡ a · t) h refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bisimilarity for Colists
------------------------------------------------------------------------

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

module Codata.Colist.Bisimilarity where

open import Level using (Level; _⊔_)
open import Size
open import Codata.Thunk
open import Codata.Colist
open import Data.List.Base using (List; []; _∷_)
open import Data.List.Relation.Binary.Pointwise using (Pointwise; []; _∷_)
open import Data.List.NonEmpty as List⁺  using (List⁺; _∷_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as Eq using (_≡_)

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

data Bisim {A : Set a} {B : Set b} (R : REL A B r) (i : Size) :
           REL (Colist A ∞) (Colist B ∞) (r ⊔ a ⊔ b) where
  []  : Bisim R i [] []
  _∷_ : ∀ {x y xs ys} → R x y → Thunk^R (Bisim R) i xs ys →
        Bisim R i (x ∷ xs) (y ∷ ys)

module _ {R : Rel A r} where

 reflexive : Reflexive R → Reflexive (Bisim R i)
 reflexive refl^R {[]}     = []
 reflexive refl^R {r ∷ rs} = refl^R ∷ λ where .force → reflexive refl^R

module _ {P : REL A B p} {Q : REL B A q} where

 symmetric : Sym P Q → Sym (Bisim P i) (Bisim Q i)
 symmetric sym^PQ []       = []
 symmetric sym^PQ (p ∷ ps) = sym^PQ p ∷ λ where .force → symmetric sym^PQ (ps .force)

module _ {P : REL A B p} {Q : REL B C q} {R : REL A C r} where

 transitive : Trans P Q R → Trans (Bisim P i) (Bisim Q i) (Bisim R i)
 transitive trans^PQR []       []       = []
 transitive trans^PQR (p ∷ ps) (q ∷ qs) =
   trans^PQR p q ∷ λ where .force → transitive trans^PQR (ps .force) (qs .force)

------------------------------------------------------------------------
-- Congruence rules

module _ {R : REL A B r} where

  ++⁺ : ∀ {as bs xs ys} → Pointwise R as bs →
        Bisim R i xs ys → Bisim R i (fromList as ++ xs) (fromList bs ++ ys)
  ++⁺ []       rs = rs
  ++⁺ (r ∷ pw) rs = r ∷ λ where .force → ++⁺ pw rs

  ⁺++⁺ : ∀ {as bs xs ys} → Pointwise R (List⁺.toList as) (List⁺.toList bs) →
         Thunk^R (Bisim R) i xs ys → Bisim R i (as ⁺++ xs) (bs ⁺++ ys)
  ⁺++⁺ (r ∷ pw) rs = r ∷ λ where .force → ++⁺ pw (rs .force)

------------------------------------------------------------------------
-- Pointwise Equality as a Bisimilarity

module _ {A : Set a} where

  infix 1 _⊢_≈_
  _⊢_≈_ : ∀ i → Colist A ∞ → Colist A ∞ → Set a
  _⊢_≈_ = Bisim _≡_

  refl : Reflexive (i ⊢_≈_)
  refl = reflexive Eq.refl

  fromEq : ∀ {as bs} → as ≡ bs → i ⊢ as ≈ bs
  fromEq Eq.refl = refl

  sym : Symmetric (i ⊢_≈_)
  sym = symmetric Eq.sym

  trans : Transitive (i ⊢_≈_)
  trans = transitive Eq.trans

isEquivalence : {R : Rel A r} → IsEquivalence R → IsEquivalence (Bisim R i)
isEquivalence equiv^R = record
  { refl  = reflexive equiv^R.refl
  ; sym   = symmetric equiv^R.sym
  ; trans = transitive equiv^R.trans
  } where module equiv^R = IsEquivalence equiv^R

setoid : Setoid a r → Size → Setoid a (a ⊔ r)
setoid S i = record
  { isEquivalence = isEquivalence {i = i} (Setoid.isEquivalence S)
  }

module ≈-Reasoning {a} {A : Set a} {i} where

  open import Relation.Binary.Reasoning.Setoid (setoid (Eq.setoid A) i) public


module map-is-foldr where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; cong)
open Eq.≡-Reasoning
open import lists using (List; []; _∷_; map; foldr)

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

-- 外延性の公理を利用した証明のための補題
lemma : ∀ {A B : Set} → (f : A → B) → (xs : List A)
  → map f xs ≡ foldr (λ x xs → f x ∷ xs) [] xs
lemma f [] =
  begin
    map f []
  ≡⟨⟩
    []
  ≡⟨⟩
    foldr (λ x xs → f x ∷ xs) [] []
  ∎
lemma f (x ∷ xs) =
  begin
    map f (x ∷ xs)
  ≡⟨⟩
    f x ∷ map f xs
  ≡⟨ cong (f x ∷_) (lemma f xs) ⟩
    f x ∷ foldr (λ x xs → f x ∷ xs) [] xs
  ≡⟨⟩
    foldr (λ x xs → f x ∷ xs) [] (x ∷ xs)
  ∎

-- mapが畳み込みで表現できることの証明
map-is-foldr : ∀ {A B : Set} → (f : A → B)
  → map f ≡ foldr (λ x xs → f x ∷ xs) []
map-is-foldr f = extensionality (lemma f)


open import Relation.Binary.Core using (Rel)

module GGT.Definitions
  {a b ℓ₁ ℓ₂}
  {G : Set a}      -- The underlying group carrier
  {Ω : Set b}      -- The underlying space
  (_≈_ : Rel G ℓ₁) -- The underlying group equality
  (_≋_ : Rel Ω ℓ₂) -- The underlying space equality
  where

open import Level
open import Algebra.Core
open import Relation.Unary
open import Algebra.Bundles using (Group)
open import Algebra.Definitions _≋_ using (Congruent₁)

ActAssoc : Opᵣ G Ω → Op₂ G → Set _
ActAssoc _·_ _∙_ = ∀ (o : Ω) (g : G) (h : G) → (o · (g ∙ h)) ≋ ((o · g) · h)

ActLeftIdentity : G → Opᵣ G Ω → Set _
ActLeftIdentity ε _·_ = ∀ (o : Ω) → (o · ε) ≋ o

·-≋-Congruence : Opᵣ G Ω → Set _
·-≋-Congruence _·_ = ∀ (g : G) → Congruent₁ (_· g)
-- ∀ (o1 o2 : Ω) (g : G) → o1 ≋ o2 → (o1 · g) ≋ (o2 · g)

≈-Ext : Opᵣ G Ω → Set _
≈-Ext _·_ = ∀ {g h : G} → ∀ {o : Ω} → g ≈ h → (o · g) ≋ (o · h)


-- This file is ported from a part of Martin Escardó's HoTT lecture notes
-- (https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html).

{-# OPTIONS --without-K --safe #-}
module Util.HoTT.Section where

open import Util.HoTT.HLevel.Core
open import Util.Prelude
open import Util.Relation.Binary.PropositionalEquality using
  ( Σ-≡⁺ ; subst-subst-sym )

private
  variable
    α β γ : Level
    A B C : Set α

infix 4 _◁_

record HasSection {A : Set α} {B : Set β} (f : A → B) : Set (α ⊔ℓ β) where
  field
    section : B → A
    isSection : ∀ x → f (section x) ≡ x

open HasSection public

record _◁_ (A : Set α) (B : Set β) : Set (α ⊔ℓ β) where
  field
    retraction : B → A
    hasSection : HasSection retraction

  open HasSection hasSection public renaming (isSection to retraction∘section)

open _◁_ public

◁-refl : A ◁ A
◁-refl = record
  { retraction = id
  ; hasSection = record
    { section = id
    ; isSection = λ _ → refl
    }
  }

◁-trans : A ◁ B → B ◁ C → A ◁ C
◁-trans A◁B B◁C = record
  { retraction = A◁B .retraction ∘ B◁C .retraction
  ; hasSection = record
    { section = B◁C .section ∘ A◁B .section
    ; isSection = λ x
        → trans (cong (A◁B .retraction) (B◁C .retraction∘section _))
            (A◁B .retraction∘section _)
    }
  }

Σ-◁ : {A : Set α} {B : A → Set β} {C : A → Set γ}
  → (∀ a → B a ◁ C a)
  → Σ A B ◁ Σ A C
Σ-◁ B◁C = record
  { retraction = λ { (a , c) → a , B◁C a .retraction c }
  ; hasSection = record
    { section = λ { (a , b) → a , B◁C a .section b }
    ; isSection = λ { (a , b) → cong (a ,_) (B◁C a .retraction∘section b) }
    }
  }

◁-pres-IsContr : A ◁ B → IsContr B → IsContr A
◁-pres-IsContr A◁B (b , canon)
  = A◁B .retraction b
  , λ a
      → trans (cong (A◁B .retraction) (canon (A◁B .section a)))
          (A◁B .retraction∘section a)

Σ-◁-reindexing : {A : Set α} {B : Set β} {P : A → Set γ}
  → (r : A ◁ B)
  → Σ A P ◁ Σ B (P ∘ r .retraction)
Σ-◁-reindexing {P = P} r = record
  { retraction = λ { (b , x) → r .retraction b , x }
  ; hasSection = record
    { section = λ where
        (a , x) → r .section a , subst P (sym (r .retraction∘section a)) x
    ; isSection = λ where
        (a , x) → Σ-≡⁺
          ( r .retraction∘section a
          , subst-subst-sym (r .retraction∘section a)
          )
    }
  }


{-

        Agda Implementors' Meeting VI

                  Göteborg
             May 24 - 3zero, 2zerozero7

                Hello Agda!

                Ulf Norell

-}

-- Records are labeled sigma types.

module R where

{-

  A very simple record.

-}

data Nat : Set where
  zero : Nat
  succ : Nat

record Point : Set where
  field x : Nat
        y : Nat

-- A record can be seen as a one constructor datatype. In this case:
data Point' : Set where
  mkPoint : (x : Nat)(y : Nat) -> Point'

-- There are a few differences, though:

-- To construct a record you use the syntax record { ..; x = e; .. }
origin : Point
origin = record { x = zero; y = zero }

-- instead of
origin' : Point'
origin' = mkPoint zero zero

-- What's more interesting is that you get projection functions
-- for free when you declare a record. More precisely, you get a module
-- parameterised over a record, containing functions corresponding to the
-- fields. In the Point example you get:
{-
  module Point (p : Point) where
    x : Nat
    y : Nat
-}

-- So Point.x : Point -> Nat is the projection function for the field x.
getX : Point -> Nat
getX = Point.x
-- getX = x


{-# OPTIONS --without-K --safe #-}
open import Categories.Category.Core

-- slice category (https://ncatlab.org/nlab/show/over+category)
-- TODO: Forgetful Functor from Slice to 𝒞
module Categories.Category.Slice {o ℓ e} (𝒞 : Category o ℓ e) where

open Category 𝒞
open HomReasoning

open import Level
open import Function using (_$_)
open import Relation.Binary using (Rel)

open import Categories.Morphism.Reasoning 𝒞

record SliceObj (X : Obj) : Set (o ⊔ ℓ) where
  constructor sliceobj
  field
    {Y} : Obj
    arr : Y ⇒ X

private
  variable
    A : Obj
    X Y Z : SliceObj A

record Slice⇒ {A : Obj} (X Y : SliceObj A) : Set (ℓ ⊔ e) where
  constructor slicearr
  module X = SliceObj X
  module Y = SliceObj Y
  field
    {h} : X.Y ⇒ Y.Y
    △   : Y.arr ∘ h ≈ X.arr

Slice : Obj → Category _ _ _
Slice A       = record
  { Obj       = SliceObj A
  ; _⇒_       = Slice⇒
  ; _≈_       = λ where
    (slicearr {f} _) (slicearr {g} _) → f ≈ g
  ; id        = slicearr identityʳ
  ; _∘_       = _∘′_
  ; assoc     = assoc
  ; sym-assoc = sym-assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identity²
  ; equiv     = record -- must be expanded to get levels to work out
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  ; ∘-resp-≈  = ∘-resp-≈
  }
  where _∘′_ : Slice⇒ Y Z → Slice⇒ X Y → Slice⇒ X Z
        _∘′_ {Y = sliceobj y} {Z = sliceobj z} {X = sliceobj x} (slicearr {g} △) (slicearr {f} △′) = slicearr $ begin
          z ∘ g ∘ f ≈⟨ pullˡ △ ⟩
          y ∘ f     ≈⟨ △′ ⟩
          x         ∎


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

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

module Sets.Cardinality.Finite.Lemmas where

finsetInjectIntoℕ : {n : ℕ} → Injection (toNat {n})
finsetInjectIntoℕ {zero} {()}
finsetInjectIntoℕ {succ n} = ans
  where
    ans : {n : ℕ} → {x y : FinSet (succ n)} → (toNat x ≡ toNat y) → x ≡ y
    ans {zero} {fzero} {fzero} _ = refl
    ans {zero} {fzero} {fsucc ()}
    ans {zero} {fsucc ()} {y}
    ans {succ n} {fzero} {fzero} pr = refl
    ans {succ n} {fzero} {fsucc y} ()
    ans {succ n} {fsucc x} {fzero} ()
    ans {succ n} {fsucc x} {fsucc y} pr with succInjective pr
    ... | pr' = applyEquality fsucc (ans {n} {x} {y} pr')


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by posets
------------------------------------------------------------------------

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

open import Relation.Binary

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

open Poset P renaming (Carrier to A)

open import Function using (flip)
import Relation.Binary.Construct.NonStrictToStrict _≈_ _≤_ as ToStrict
import Relation.Binary.Properties.Preorder preorder as PreorderProperties
open import Relation.Nullary using (¬_)

private
  _≉_ : Rel A p₂
  x ≉ y = ¬ (x ≈ y)

------------------------------------------------------------------------
-- The _≥_ relation is also a poset.

infix 4 _≥_

_≥_ : Rel A p₃
x ≥ y = y ≤ x

open PreorderProperties public
  using ()
  renaming
  ( invIsPreorder to ≥-isPreorder
  ; invPreorder   to ≥-preorder
  )

≥-isPartialOrder : IsPartialOrder _≈_ _≥_
≥-isPartialOrder = record
  { isPreorder   = PreorderProperties.invIsPreorder
  ; antisym      = flip antisym
  }

≥-poset : Poset p₁ p₂ p₃
≥-poset = record
  { isPartialOrder = ≥-isPartialOrder
  }

open Poset ≥-poset public
  using ()
  renaming
  ( refl      to ≥-refl
  ; reflexive to ≥-reflexive
  ; trans     to ≥-trans
  ; antisym   to ≥-antisym
  )

------------------------------------------------------------------------
-- Partial orders can be turned into strict partial orders

infix 4 _<_

_<_ : Rel A _
_<_ = ToStrict._<_

<-isStrictPartialOrder : IsStrictPartialOrder _≈_ _<_
<-isStrictPartialOrder = ToStrict.<-isStrictPartialOrder isPartialOrder

<-strictPartialOrder : StrictPartialOrder _ _ _
<-strictPartialOrder = record
  { isStrictPartialOrder = <-isStrictPartialOrder
  }

open StrictPartialOrder <-strictPartialOrder public
  using ( <-resp-≈; <-respʳ-≈; <-respˡ-≈)
  renaming
  ( irrefl to <-irrefl
  ; asym   to <-asym
  ; trans  to <-trans
  )

<⇒≉ : ∀ {x y} → x < y → x ≉ y
<⇒≉ = ToStrict.<⇒≉

≤∧≉⇒< : ∀ {x y} → x ≤ y → x ≉ y → x < y
≤∧≉⇒< = ToStrict.≤∧≉⇒<

<⇒≱ : ∀ {x y} → x < y → ¬ (y ≤ x)
<⇒≱ = ToStrict.<⇒≱ antisym

≤⇒≯ : ∀ {x y} → x ≤ y → ¬ (y < x)
≤⇒≯ = ToStrict.≤⇒≯ antisym

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

-- Version 1.2

invIsPartialOrder = ≥-isPartialOrder
{-# WARNING_ON_USAGE invIsPartialOrder
"Warning: invIsPartialOrder was deprecated in v1.2.
Please use ≥-isPartialOrder instead."
#-}

invPoset = ≥-poset
{-# WARNING_ON_USAGE invPoset
"Warning: invPoset was deprecated in v1.2.
Please use ≥-poset instead."
#-}

strictPartialOrder = <-strictPartialOrder
{-# WARNING_ON_USAGE strictPartialOrder
"Warning: strictPartialOrder was deprecated in v1.2.
Please use <-strictPartialOrder instead."
#-}


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

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Algebra
open import Cubical.Algebra.Magma.Morphism

open import Cubical.Algebra.Magma.MorphismProperties public
  using (MagmaPath; uaMagma; carac-uaMagma; Magma≡; caracMagma≡)

private
  variable
    ℓ : Level

isPropIsMagma : {M : Type ℓ} {_•_ : Op₂ M} → isProp (IsMagma M _•_)
isPropIsMagma (ismagma x) (ismagma y) = cong ismagma (isPropIsSet x y)


-- This is the preferred version of the integers in the library. Other
-- versions can be found in the MoreInts directory.
{-# OPTIONS --safe #-}
module Cubical.Data.Int.Base where

open import Cubical.Core.Everything
open import Cubical.Data.Bool
open import Cubical.Data.Nat hiding (_+_ ; _·_) renaming (isEven to isEvenℕ ; isOdd to isOddℕ)

infix  8 -_
infixl 7 _·_
infixl 6 _+_ _-_

data ℤ : Type₀ where
  pos    : (n : ℕ) → ℤ
  negsuc : (n : ℕ) → ℤ

neg : (n : ℕ) → ℤ
neg zero    = pos zero
neg (suc n) = negsuc n

sucℤ : ℤ → ℤ
sucℤ (pos n)          = pos (suc n)
sucℤ (negsuc zero)    = pos zero
sucℤ (negsuc (suc n)) = negsuc n

predℤ : ℤ → ℤ
predℤ (pos zero)    = negsuc zero
predℤ (pos (suc n)) = pos n
predℤ (negsuc n)    = negsuc (suc n)

isEven : ℤ → Bool
isEven (pos n) = isEvenℕ n
isEven (negsuc n) = isOddℕ n

isOdd : ℤ → Bool
isOdd (pos n) = isOddℕ n
isOdd (negsuc n) = isEvenℕ n

abs : ℤ → ℕ
abs (pos n) = n
abs (negsuc n) = suc n

_ℕ-_ : ℕ → ℕ → ℤ
a ℕ- 0 = pos a
0 ℕ- suc b = negsuc b
suc a ℕ- suc b = a ℕ- b

_+pos_ : ℤ → ℕ  → ℤ
z +pos 0 = z
z +pos (suc n) = sucℤ (z +pos n)

_+negsuc_ : ℤ → ℕ → ℤ
z +negsuc 0 = predℤ z
z +negsuc (suc n) = predℤ (z +negsuc n)

_+_ : ℤ → ℤ → ℤ
m + pos n = m +pos n
m + negsuc n = m +negsuc n

-_ : ℤ → ℤ
- pos zero = pos zero
- pos (suc n) = negsuc n
- negsuc n = pos (suc n)

_-_ : ℤ → ℤ → ℤ
m - n = m + (- n)

_·_ : ℤ → ℤ → ℤ
pos zero · m = pos zero
pos (suc n) · m = m + pos n · m
negsuc zero · m = - m
negsuc (suc n) · m = - m + negsuc n · m

-- Natural number and negative integer literals for ℤ

open import Cubical.Data.Nat.Literals public

instance
  fromNatℤ : HasFromNat ℤ
  fromNatℤ = record { Constraint = λ _ → Unit ; fromNat = λ n → pos n }

instance
  fromNegℤ : HasFromNeg ℤ
  fromNegℤ = record { Constraint = λ _ → Unit ; fromNeg = λ n → neg n }


module SystemF.Substitutions.Types where

open import Prelude
open import SystemF.Syntax.Type
open import Data.Fin.Substitution
open import Data.Star hiding (map)
open import Data.Vec

module TypeSubst where
  module TypeApp {T} (l : Lift T Type) where
    open Lift l hiding (var)

    infixl 8 _/_

    _/_ : ∀ {m n} → Type m → Sub T m n → Type n
    tc c     / σ = tc c
    tvar x   / σ = lift (lookup x σ)
    (a →' b) / σ = (a / σ) →' (b / σ)
    (a ⟶ b) / σ = (a / σ) ⟶ (b / σ)
    ∀' a     / σ = ∀' (a / σ ↑)

    open Application (record { _/_ = _/_ }) using (_/✶_)

    →'-/✶-↑✶ : ∀ k {m n a b} (ρs : Subs T m n) →
               (a →' b) /✶ ρs ↑✶ k ≡ (a /✶ ρs ↑✶ k) →' (b /✶ ρs ↑✶ k)
    →'-/✶-↑✶ k ε        = refl
    →'-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (→'-/✶-↑✶ k ρs) refl

    ⟶-/✶-↑✶ : ∀ k {m n a b} (ρs : Subs T m n) →
               (a ⟶ b) /✶ ρs ↑✶ k ≡ (a /✶ ρs ↑✶ k) ⟶ (b /✶ ρs ↑✶ k)
    ⟶-/✶-↑✶ k ε        = refl
    ⟶-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (⟶-/✶-↑✶ k ρs) refl

    ∀'-/✶-↑✶ : ∀ k {m n a} (ρs : Subs T m n) →
               (∀' a) /✶ ρs ↑✶ k ≡ ∀' (a /✶ ρs ↑✶ (1 + k))
    ∀'-/✶-↑✶ k ε        = refl
    ∀'-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (∀'-/✶-↑✶ k ρs) refl

    tc-/✶-↑✶ : ∀ k {c m n} (ρs : Subs T m n) →
               (tc c) /✶ ρs ↑✶ k ≡ tc c
    tc-/✶-↑✶ k ε        = refl
    tc-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (tc-/✶-↑✶ k ρs) refl

  typeSubst : TermSubst Type
  typeSubst = record { var = tvar; app = TypeApp._/_ }

  open TermSubst typeSubst public hiding (var)

  infix 8 _[/_]

  -- Shorthand for single-variable type substitutions
  _[/_] : ∀ {n} → Type (suc n) → Type n → Type n
  a [/ b ] = a / sub b

open TypeSubst public using ()
  renaming (_/_ to _tp/tp_; _[/_] to _tp[/tp_]; weaken to tp-weaken)


{-# OPTIONS --universe-polymorphism #-}

module Issue293a where

open import Agda.Primitive
  using (Level; _⊔_) renaming (lzero to zero; lsuc to suc)

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

record RawMonoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Carrier → Carrier → Set ℓ
    _∙_     : Carrier → Carrier → Carrier
    ε       : Carrier

module M (rm : RawMonoid zero zero) where

  open RawMonoid rm

  thm : ∀ x → x ∙ ε ≈ x
  thm = {!!}

  -- Previous agda2-goal-and-context:

  -- rm : RawMonoid zero zero
  -- ------------------------
  -- Goal: (x : RawMonoid.Carrier rm) →
  --       RawMonoid._≈_ rm (RawMonoid._∙_ rm x (RawMonoid.ε rm)) x

  -- Current agda2-goal-and-context:

  -- rm : RawMonoid zero zero
  -- ------------------------
  -- Goal: (x : Carrier) → x ∙ ε ≈ x

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

record RawMonoid′ : Set₁ where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set
    _≈_     : Carrier → Carrier → Set
    _∙_     : Carrier → Carrier → Carrier
    ε       : Carrier

module M′ (rm : RawMonoid′) where

  open RawMonoid′ rm

  thm′ : ∀ x → x ∙ ε ≈ x
  thm′ = {!!}

  -- Previous and current agda2-goal-and-context:

  -- rm : RawMonoid′
  -- ---------------
  -- Goal: (x : Carrier) → x ∙ ε ≈ x

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

-- UP isn't relevant.

record RawMonoid″ (Carrier : Set) : Set₁ where
  infixl 7 _∙_
  infix  4 _≈_
  field
    _≈_     : Carrier → Carrier → Set
    _∙_     : Carrier → Carrier → Carrier
    ε       : Carrier

data Bool : Set where
  true false : Bool

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

module M″ (rm : RawMonoid″ (List Bool)) where

  open RawMonoid″ rm

  thm″ : ∀ x → x ∙ ε ≈ x
  thm″ = {!!}

  -- Previous agda2-goal-and-context:

  -- rm : RawMonoid″ (List Bool)
  -- ---------------------------
  -- Goal: (x : List Bool) →
  --       RawMonoid″._≈_ rm (RawMonoid″._∙_ rm x (RawMonoid″.ε rm)) x

  -- Current agda2-goal-and-context:

  -- rm : RawMonoid″ (List Bool)
  -- ---------------------------
  -- Goal: (x : List Bool) → x ∙ ε ≈ x


{-# OPTIONS --safe #-}

module Confluence where

open import Relation.Binary.PropositionalEquality
  using (_≡_; refl)

cong : ∀ {A B : Set} {x y : A} (f : A → B) → x ≡ y → f x ≡ f y
cong f refl = refl

data ℕ : Set where
  Z : ℕ
  S : ℕ → ℕ

add : ℕ → ℕ → ℕ
add n Z = n
add n (S m) = S (add n m)

_ : ∀ {a : ℕ} → add a Z ≡ a
_ = refl

thm : ∀ {a : ℕ} → add Z a ≡ a
thm {a = Z} = refl
thm {a = (S m)} = cong S thm
-- Confluence checking is not supported;
-- Check out Jesper Cockx's Phd thesis for overlapping patterns.


{-

Smith Normal Form

Referrences:
  Guillaume Cano, Cyril Cohen, Maxime Dénès, Anders Mörtberg, Vincent Siles,
  "Formalized linear algebra over Elementary Divisor Rings in Coq"
  (https://arxiv.org/abs/1601.07472)

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.IntegerMatrix.Smith where

open import Cubical.Algebra.IntegerMatrix.Smith.NormalForm public
open import Cubical.Algebra.IntegerMatrix.Smith.Normalization public using (smith)


module Type.Category.ExtensionalFunctionsCategory{ℓ} where

open import Data
open import Functional
open import Function.Equals
open import Function.Equals.Proofs
open import Logic.Propositional
import      Relator.Equals as Eq
open import Relator.Equals.Proofs.Equiv
open import Structure.Category
open import Structure.Categorical.Properties
open import Type
open import Type.Properties.Singleton

-- The set category but the equality on the morphisms/functions is pointwise/extensional.
typeExtensionalFnCategory : Category{Obj = Type{ℓ}}(_→ᶠ_) ⦃ [⊜]-equiv ⦃ [≡]-equiv ⦄ ⦄
Category._∘_ typeExtensionalFnCategory = _∘_
Category.id  typeExtensionalFnCategory = id
Category.binaryOperator typeExtensionalFnCategory = [⊜][∘]-binaryOperator
Morphism.Associativity.proof (Category.associativity typeExtensionalFnCategory) {x = _} {_} {_} {x = f} {g} {h} = [⊜]-associativity {x = f}{y = g}{z = h}
Category.identity typeExtensionalFnCategory = [∧]-intro (Morphism.intro (Dependent.intro Eq.[≡]-intro)) (Morphism.intro (Dependent.intro Eq.[≡]-intro))

typeExtensionalFnCategoryObject : CategoryObject
typeExtensionalFnCategoryObject = intro typeExtensionalFnCategory

Empty-initialObject : Object.Initial{Obj = Type{ℓ}}(_→ᶠ_) ⦃ [⊜]-equiv ⦃ [≡]-equiv ⦄ ⦄ (Empty)
IsUnit.unit Empty-initialObject = empty
_⊜_.proof (IsUnit.uniqueness Empty-initialObject {f}) {}

Unit-terminalObject : Object.Terminal{Obj = Type{ℓ}}(_→ᶠ_) ⦃ [⊜]-equiv ⦃ [≡]-equiv ⦄ ⦄ (Unit)
IsUnit.unit Unit-terminalObject = const <>
_⊜_.proof (IsUnit.uniqueness Unit-terminalObject {f}) {_} = Eq.[≡]-intro


module VaryingClauseArity where

-- see also thread https://lists.chalmers.se/pipermail/agda-dev/2015-January/000041.html

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

Sum : Nat → Set
Sum 0       = Nat
Sum (suc n) = Nat → Sum n

sum : (acc : Nat) (n : Nat) → Sum n
sum acc 0         = acc
sum acc (suc n) 0 = sum acc n
sum acc (suc n) m = sum (m + acc) n

-- expected:
-- 10
-- 20
-- 33
main : IO Unit
main = printNat (sum 10 0) ,,
  putStr "\n" ,,
  printNat (sum 20 1 0) ,,
  putStr "\n" ,,
  printNat (sum 30 1 3)


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

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 Setoids.Orders.Total.Definition
open import Sets.EquivalenceRelations
open import Rings.Orders.Total.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Definition
open import Fields.Fields
open import Groups.Definition
open import Sequences
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Semirings.Definition
open import Functions.Definition
open import Fields.Orders.Total.Definition
open import Numbers.Primes.PrimeNumbers

module Fields.Orders.Limits.Lemmas {a b c : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {_<_ : Rel {_} {c} A} {R : Ring S _+_ _*_} {pOrder : SetoidPartialOrder S _<_} {F : Field R} {pRing : PartiallyOrderedRing R pOrder} (oF : TotallyOrderedField F pRing) where

open Ring R
open TotallyOrderedField oF
open TotallyOrderedRing oRing
open PartiallyOrderedRing pRing
open import Rings.Orders.Total.Lemmas oRing
open import Rings.Orders.Total.AbsoluteValue oRing
open import Rings.Orders.Partial.Lemmas pRing
open SetoidTotalOrder total
open SetoidPartialOrder pOrder
open Group additiveGroup
open import Groups.Lemmas additiveGroup
open Setoid S
open Equivalence eq
open Field F
open import Fields.CauchyCompletion.Definition (TotallyOrderedField.oRing oF) F
open import Fields.Orders.Limits.Definition oF
open import Fields.Lemmas F
open import Fields.Orders.Total.Lemmas oF
open import Rings.Characteristic R
open import Rings.InitialRing R
open import Rings.Orders.Total.Cauchy oRing

private
  2!=3 : 2 ≡ 3 → False
  2!=3 ()

convergentSequenceCauchy : (nontrivial : 0R ∼ 1R → False) → {a : Sequence A} → {r : A} → a ~> r → cauchy a
convergentSequenceCauchy _ {a} {r} a->r e 0<e with halve (λ i → charNotN 1 (transitive (transitive +Associative identRight) i)) e
... | e/2 , prE/2 with a->r e/2 (halvePositive' prE/2 0<e)
... | N , pr = N , λ {m} {n} → ans m n
  where
    ans : (m n : ℕ) → N <N m → N <N n → abs (index a m + inverse (index a n)) < e
    ans m n N<m N<n = <WellDefined reflexive prE/2 (bothNearImpliesNear {r} e/2 (halvePositive' prE/2 0<e) (pr m N<m) (pr n N<n))


------------------------------------------------------------------------------
-- Definition of the gcd of two natural numbers using the Euclid's algorithm
------------------------------------------------------------------------------

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

module FOTC.Program.GCD.Total.GCD where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities

------------------------------------------------------------------------------
-- In GHC ≥ 7.2.1 the gcd is a total function, i.e. gcd 0 0 = 0.

postulate
  gcd    : D → D → D
  gcd-eq : ∀ m n → gcd m n ≡
           (if (iszero₁ n)
              then m
              else (if (iszero₁ m)
                      then n
                      else (if (gt m n)
                             then gcd (m ∸ n) n
                             else gcd m (n ∸ m))))
{-# ATP axiom gcd-eq #-}


module TLP01 where

open import Data.Bool
open import Data.Nat
open import Data.String
open import Relation.Binary.PropositionalEquality
  as PropEq using (_≡_; refl; sym; cong; cong₂; trans)

_==ℕ_ : ℕ → ℕ → Bool
zero  ==ℕ zero  = true
suc n ==ℕ suc m = n ==ℕ m
_     ==ℕ _     = false

_<ℕ_ : ℕ → ℕ → Bool
_     <ℕ zero  = false
zero  <ℕ suc _ = true
suc n <ℕ suc m = n <ℕ m

-- ----- Star型の定義と同値性 -----
data Star : Set where
  NIL : Star
  TRU : Star
  N   : ℕ → Star
  S   : String → Star
  C   : Star → Star → Star

eqStar : Star → Star → Bool
eqStar NIL NIL = true
eqStar NIL _ = false
eqStar TRU TRU = true
eqStar TRU _ = false
eqStar (N x) (N y) = x ==ℕ y
eqStar (N _) _ = false
eqStar (S x) (S y) = x == y
eqStar (S _) _ = false
eqStar (C x x₁) (C y y₁) = eqStar x y ∧ eqStar x₁ y₁
eqStar (C _ _) _ = false

-- ----- 組込関数の定義 -----
CONS : Star → Star → Star
CONS = C

CAR : Star → Star
CAR (C x _) = x
CAR _ = NIL

CDR : Star → Star
CDR (C _ x₁) = x₁
CDR _ = NIL

ATOM : Star → Star
ATOM (C _ _) = NIL
ATOM _ = TRU

IF : Star → Star → Star → Star
IF TRU a _ = a
IF q a e = if eqStar q NIL then e else a

EQUAL : Star → Star → Star
EQUAL x y = if eqStar x y then TRU else NIL

s-size : Star → ℕ
s-size (C a b) = s-size a + s-size b + 1
s-size _ = 0
SIZE : Star → Star
SIZE x = N (s-size x)

s2n : Star → ℕ
s2n (N x) = x
s2n _ = 0
LT : Star → Star → Star
LT x y = if s2n x <ℕ s2n y then TRU else NIL

-- ----- Starから≡に -----
postulate
  ts : Star → Set
  ~ : Star → Star
  equal-eq : {x y : Star} → ts (EQUAL x y) →  x ≡ y
  ifAP : {q x y : Star} → ts (IF q (EQUAL x y) TRU) → (ts q → x ≡ y)
  ifEP : {q x y : Star} → ts (IF q TRU (EQUAL x y)) → (ts (~ q) → x ≡ y)
-- ----- 公理 -----
  equal-same : (x : Star) → ts (EQUAL x x)
  equal-swap : (x y : Star) → ts (EQUAL (EQUAL x y) (EQUAL y x))
  equal-if : (x y : Star) → ts (IF (EQUAL x y) (EQUAL x y) TRU)
  atom/cons : (x y : Star) → ts (EQUAL (ATOM (CONS x y)) NIL)
  car/cons : (x y : Star) → ts (EQUAL (CAR (CONS x y)) x)
  cdr/cons : (x y : Star) → ts (EQUAL (CDR (CONS x y)) y)
  cons/car+cdr : (x : Star)
    → ts (IF (ATOM x) TRU (EQUAL (CONS (CAR x) (CDR x)) x))
  if-true : (x y : Star) → ts (EQUAL (IF TRU x y) x)
  if-false : (x y : Star) → ts (EQUAL (IF NIL x y) y)
  if-same : (x y : Star) → ts (EQUAL (IF x y y) y)
  if-nest-A : (x y z : Star) → ts (IF x (EQUAL (IF x y z) y) TRU)
  if-nest-E : (x y z : Star) → ts (IF x TRU (EQUAL (IF x y z) z))
  size/car : (x : Star)
    → ts (IF (ATOM x) TRU (EQUAL (LT (SIZE (CAR x)) (SIZE x)) TRU))
  size/cdr : (x : Star)
    → ts (IF (ATOM x) TRU (EQUAL (LT (SIZE (CDR x)) (SIZE x)) TRU))

-- ----- 練習 -----
postulate
  -- a b : Star
  foo : ts (EQUAL TRU NIL)
hoge6 : (a b : Star)
  → (IF (EQUAL TRU NIL) TRU TRU) ≡ (IF (EQUAL TRU NIL) NIL TRU)
hoge6 a b = ifAP (equal-if TRU NIL) foo

hoge2 : (ATOM (CONS TRU TRU)) ≡ NIL
hoge2 = equal-eq (atom/cons TRU TRU)

-- hoge2' : (ATOM (CONS TRU TRU)) ≡ NIL
-- hoge2' rewrite (equal-eq (atom-cons TRU TRU)) = {!!}

hoge3 : (C TRU NIL) ≡ (C TRU NIL)
hoge3 = equal-eq (equal-same (C TRU NIL))

hoge4 : (EQUAL TRU TRU) ≡ TRU
hoge4 = begin
    (if eqStar TRU TRU then TRU else NIL)
  ≡⟨ refl ⟩
    TRU
  ∎
  where open PropEq.≡-Reasoning

hoge5 : (EQUAL NIL NIL) ≡ TRU
hoge5 = refl

postulate
  j : (x : Star) → ts (~ (ATOM x))
hoge7 : (x : ℕ)
  → (IF (ATOM (N x)) TRU (LT (SIZE (CDR (N x))) (SIZE (N x)))) ≡ (IF (ATOM (N x)) TRU TRU)
hoge7 x = ifEP (size/cdr (N x)) (j (N x))
-- -----

{-
-- ----- 停止性で引っかかる -----
memb?' : Star → Star
memb?' xs =
  (IF (ATOM xs)
       NIL
       (IF (EQUAL (CAR xs) (S "?"))
           TRU
           (memb?' (CDR xs))))
-}
-- ----- memb?の停止性 -----
-- ----- SIZEを使う時はℕを引数にとる
postulate
  premise : (xs : Star) → ts (~ (ATOM xs))
measure-memb? : (x : ℕ)
  → (IF (ATOM (N x))
        TRU
        (IF (EQUAL (CAR (N x)) (S "?"))
            TRU
            (LT (SIZE (CDR (N x))) (SIZE (N x)))))
    ≡ TRU
measure-memb? x = begin
    (IF (ATOM (N x))
        TRU
        (IF (EQUAL (CAR (N x)) (S "?"))
            TRU
            (LT (SIZE (CDR (N x))) (SIZE (N x)))))
  ≡⟨ ifEP (size/cdr (N x)) (premise (N x)) ⟩
    (IF (ATOM (N x))
        TRU
        (IF (EQUAL (CAR (N x)) (S "?"))
            TRU
            TRU))
  ≡⟨ equal-eq (if-same (EQUAL (CAR (N x)) (S "?")) TRU) ⟩
    (IF (ATOM (N x))
        TRU
        TRU)
  ≡⟨ equal-eq (if-same (ATOM (N x)) TRU) ⟩
    TRU
  ∎
  where open PropEq.≡-Reasoning

-- ----- memb?の定義 -----
postulate
  memb? : Star → Star
  def-memb? : (xs : Star) →
    memb? xs ≡
      (IF (ATOM xs)
          NIL
          (IF (EQUAL (CAR xs) (S "?"))
              TRU
              (memb? (CDR xs))))
-- ----- rembの定義 -----
postulate
  remb : Star → Star
  def-remb : (xs : Star) →
    remb xs ≡
      (IF (ATOM xs)
          (S "'()")
          (IF (EQUAL (CAR xs) (S "?"))
              (remb (CDR xs))
              (CONS (CAR xs)
                 (remb (CDR xs)))))
-- ----- 帰納的な証明(未完) -----
-- ----- ATOMを使う時はC x yを引数にとる
postulate
  premise2 : (xs : Star) → ts (ATOM xs)
atomt : (ATOM (S "'()")) ≡ TRU
atomt = refl
memb?/remb : (x y : Star)
  → (IF (ATOM (C x y))
        (EQUAL (memb? (remb (C x y))) NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU))
    ≡      (IF (ATOM (C x y))
        (EQUAL (IF TRU
                    NIL
                    (IF (EQUAL (CAR (S "'()")) (S "?"))
                        TRU
                        (memb? (CDR (S "'()")))))
                        NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU))
memb?/remb x y = begin
    (IF (ATOM (C x y))
        (EQUAL (memb? (remb (C x y))) NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU))
  ≡⟨ cong (λ t → ((IF (ATOM (C x y))
        (EQUAL (memb? t) NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU)))) (def-remb (C x y)) ⟩
    (IF (ATOM (C x y))
        (EQUAL (memb? (IF (ATOM (C x y))
          (S "'()")
          (IF (EQUAL (CAR (C x y)) (S "?"))
              (remb (CDR (C x y)))
              (CONS (CAR (C x y))
                 (remb (CDR (C x y)))))))
                        NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU))
  ≡⟨ ifAP (if-nest-A (ATOM (C x y)) (S "'()") ((IF (EQUAL (CAR (C x y)) (S "?"))
              (remb (CDR (C x y)))
              (CONS (CAR (C x y))
                 (remb (CDR (C x y))))))) (premise2 (C x y)) ⟩
    (IF (ATOM (C x y))
        (EQUAL (memb?
          (S "'()"))
                        NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU))
  ≡⟨ cong ((λ t → (IF (ATOM (C x y))
        (EQUAL t
                        NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU)))) (def-memb? ((S "'()"))) ⟩
    (IF (ATOM (C x y))
        (EQUAL (IF (ATOM (S "'()"))
                    NIL
                    (IF (EQUAL (CAR (S "'()")) (S "?"))
                        TRU
                        (memb? (CDR (S "'()")))))
                        NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU))
  ≡⟨ cong ((λ t →     (IF (ATOM (C x y))
        (EQUAL (IF t
                    NIL
                    (IF (EQUAL (CAR (S "'()")) (S "?"))
                        TRU
                        (memb? (CDR (S "'()")))))
                        NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU)))) atomt ⟩
    (IF (ATOM (C x y))
        (EQUAL (IF TRU
                    NIL
                    (IF (EQUAL (CAR (S "'()")) (S "?"))
                        TRU
                        (memb? (CDR (S "'()")))))
                        NIL)
        (IF (EQUAL (memb? (remb (CDR (C x y)))) NIL)
            (EQUAL (memb? (remb (C x y))) NIL)
            TRU))
  ∎
  where open PropEq.≡-Reasoning


module plfa.part1.Relations where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Nat.Properties using (+-comm; +-identityʳ)

data _≤_ : ℕ → ℕ → Set where

  z≤n : ∀ {n : ℕ}
      --------
    → zero ≤ n

  s≤s : ∀ {m n : ℕ}
    → m ≤ n
      -------------
    → suc m ≤ suc n

infix 4 _≤_

inv-s≤s : ∀ {m n : ℕ}
  → suc m ≤ suc n
    -------------
  → m ≤ n
inv-s≤s (s≤s m≤n) = m≤n

inv-z≤n : ∀ {m : ℕ}
  → m ≤ zero
    --------
  → m ≡ zero
inv-z≤n z≤n = refl

≤-refl : ∀ {n} → n ≤ n
≤-refl {zero} = z≤n
≤-refl {suc n} = s≤s ≤-refl

≤-trans : ∀ {m n p} → m ≤ n → n ≤ p → m ≤ p
≤-trans z≤n n = z≤n
≤-trans (s≤s m) (s≤s n) = s≤s (≤-trans m n)

≤-antisymm : ∀ {m n} → m ≤ n → n ≤ m → m ≡ n
≤-antisymm z≤n z≤n = refl
≤-antisymm (s≤s m) (s≤s n) = cong suc (≤-antisymm m n)

data Total (m n : ℕ) : Set where

  forward :
      m ≤ n
      ---------
    → Total m n

  flipped :
      n ≤ m
      ---------
    → Total m n

≤-total : ∀ (m n : ℕ) → Total m n
≤-total zero n = forward z≤n
≤-total (suc m) (zero) = flipped z≤n
≤-total (suc m) (suc n) with ≤-total m n
...                        | forward a = forward (s≤s a)
...                        | flipped b = flipped (s≤s b)

+-monoʳ-≤ : ∀ (n p q : ℕ)
  → p ≤ q
    -------------
  → n + p ≤ n + q
+-monoʳ-≤ zero    p q p≤q = p≤q
+-monoʳ-≤ (suc n) p q p≤q = s≤s (+-monoʳ-≤ n p q p≤q)

+-monoˡ-≤ : ∀ (m n p : ℕ)
  → m ≤ n
    -------------
  → m + p ≤ n + p
+-monoˡ-≤ m n p m≤n rewrite +-comm m p | +-comm n p = +-monoʳ-≤ p m n m≤n

+-mono-≤ : ∀ (m n p q : ℕ)
  → m ≤ n
  → p ≤ q
    -------------
  → m + p ≤ n + q
+-mono-≤ m n p q m≤n p≤q =
  ≤-trans (+-monoˡ-≤ m n p m≤n) (+-monoʳ-≤ n p q p≤q)

data even : ℕ → Set
data odd  : ℕ → Set

data even where

  zero :
      ---------
      even zero

  suc  : ∀ {n : ℕ}
    → odd n
      ------------
    → even (suc n)

data odd where

  suc  : ∀ {n : ℕ}
    → even n
      -----------
    → odd (suc n)

e+e≡e : ∀ {m n : ℕ}
  → even m
  → even n
    ------------
  → even (m + n)

o+e≡o : ∀ {m n : ℕ}
  → odd m
  → even n
    -----------
  → odd (m + n)

e+e≡e zero     en  =  en
e+e≡e (suc om) en  =  suc (o+e≡o om en)

o+e≡o (suc em) en  =  suc (e+e≡e em en)

o+o≡e : ∀ {m n : ℕ}
  → odd m
  → odd n
  → even (m + n)
o+o≡e {suc a} {suc b} (suc m) (suc n)
  rewrite +-comm a (suc b) = suc (o+e≡o (suc n) m)


-- simulating streams by Nat -> A

module Stream where

data Bool : Set where
    true  : Bool
    false : Bool

if_then_else_ : forall {A} -> Bool -> A -> A -> A
if true  then t else e = t
if false then t else e = e

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

Stream : Set -> Set
Stream A = Nat -> A

_::_ : forall {A} -> A -> Stream A -> Stream A
_::_ a as zero     = a
_::_ a as (succ n) = as n

map : forall {A B} -> (A -> B) -> Stream A -> Stream B
map f as n = f (as n)

head : forall {A} -> Stream A -> A
head as = as zero

tail : forall {A} -> Stream A -> Stream A
tail as n = as (succ n)

-- construct the stream a :: f a :: f (f a) :: ...

iterate : forall {A} -> (A -> A) -> A -> Stream A
iterate f a zero = a
iterate f a (succ n) = iterate f (f a) n

zipWith : forall {A B C} -> (A -> B -> C) -> Stream A -> Stream B -> Stream C
zipWith f as bs n = f (as n) (bs n)

-- merge with with
merge : forall {A} -> (A -> A -> Bool) -> Stream A -> Stream A -> Stream A
merge le as bs with le (head as) (head bs)
merge le as bs | true  = head as :: merge le (tail as) bs
merge le as bs | false = head bs :: merge le as (tail bs)

{-
-- without with
merge' : forall {A} -> (A -> A -> Bool) -> Stream A -> Stream A -> Stream A
merge' le as bs = if le (head as) (head bs)
                  then (head as :: merge' le (tail as) bs)
                  else (head bs :: merge' le as (tail bs))
-}

-- BOTH VARIANTS OF MERGE ARE NOT STRUCTURALLY RECURSIVE


-- Kleene's three-valued logic

module bool-kleene where

open import bool
open import eq

data 𝔹ₖ : Set where
  tt : 𝔹ₖ
  ff : 𝔹ₖ
  uu : 𝔹ₖ

infix  7 ~ₖ_
infixr 6 _&&ₖ_
infixr 5 _||ₖ_
--infixr 4 _impₖ_

~ₖ_ : 𝔹ₖ → 𝔹ₖ
~ₖ tt = ff
~ₖ ff = tt
~ₖ uu = uu

-- and
_&&ₖ_ : 𝔹ₖ → 𝔹ₖ → 𝔹ₖ
tt &&ₖ b = b
ff &&ₖ b = ff
uu &&ₖ ff = ff
uu &&ₖ b = uu

-- or
_||ₖ_ : 𝔹ₖ → 𝔹ₖ → 𝔹ₖ
ff ||ₖ b = b
tt ||ₖ b = tt
uu ||ₖ tt = tt
uu ||ₖ b = uu

-- implication
_impₖ_ : 𝔹ₖ → 𝔹ₖ → 𝔹ₖ
tt impₖ b2 = b2
ff impₖ b2 = tt
uu impₖ tt = tt
uu impₖ b = uu

knownₖ : 𝔹ₖ → 𝔹
knownₖ tt = tt
knownₖ ff = tt
knownₖ uu = ff

to-𝔹 : (b : 𝔹ₖ) → knownₖ b ≡ tt → 𝔹
to-𝔹 tt p = tt
to-𝔹 ff p = ff
to-𝔹 uu ()


open import Relation.Binary.Core

module Bound.Lower.Order.Properties {A : Set}
                 (_≤_ : A → A → Set)
                 (trans≤ : Transitive _≤_)  where

open import Bound.Lower A
open import Bound.Lower.Order _≤_

transLeB : {a b c : Bound} → LeB a b → LeB b c → LeB a c
transLeB lebx _ = lebx
transLeB (lexy x≤y) (lexy y≤z) = lexy (trans≤ x≤y y≤z)


module Inductive.Examples.List where

open import Inductive
open import Tuple hiding (_++_)

open import Data.Fin
open import Data.Product hiding (map)
open import Data.List hiding (List; map; foldr; _++_)
open import Data.Vec hiding (map; foldr; _++_)

List : Set → Set
List A = Inductive (([] , []) ∷ (((A ∷ []) , ([] ∷ [])) ∷ []))

nil : {A : Set} → List A
nil = construct zero [] []

cons : {A : Set} → A → List A → List A
cons x xs = construct (suc zero) (x ∷ []) ((λ _ → xs) ∷ [])

map : {A B : Set} → (A → B) → List A → List B
map f = rec (nil ∷ ((λ a as ras → cons (f a) ras) ∷ []))

foldr : {A B : Set} → (A → B → B) → B → List A → B
foldr f b = rec (b ∷ (λ a as ras → f a ras) ∷ [])

_++_ : {A : Set} → List A → List A → List A
xs ++ ys = rec (ys ∷ (λ a as ras → cons a ras) ∷ []) xs


module sv20.assign2.Second where

open import sv20.assign2.SetTheory.Logic   using (_⇔_; ¬_; _∧_; _∨_) renaming (_,_ to ⟨_,_⟩)
open import sv20.assign2.SetTheory.ZAxioms using (𝓢; _⊆_; _∈_; _∉_; _≡_; _⊂_; sym; cong; subs; trans;
                                                  proj₁; proj₂;
                                                  empt; ext; union; pair; pow; sub; pem; sum)
open import sv20.assign2.SetTheory.Algebra using (_∪_; _-_; _∩_)

∪-dist : (A B C : 𝓢) → A ∪ (B ∪ C) ≡ (A ∪ B) ∪ C
∪-dist = ?

-- I could try going this route. This would prove certain things using
-- ZFC and would be really neat but requires too much work.


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties related to negation
------------------------------------------------------------------------

module Relation.Nullary.Negation where

open import Relation.Nullary
open import Relation.Unary
open import Data.Bool
open import Data.Empty
open import Function
open import Data.Product as Prod
open import Data.Fin using (Fin)
open import Data.Fin.Dec
open import Data.Sum as Sum
open import Category.Monad
open import Level

contradiction : ∀ {p w} {P : Set p} {Whatever : Set w} →
                P → ¬ P → Whatever
contradiction p ¬p = ⊥-elim (¬p p)

contraposition : ∀ {p q} {P : Set p} {Q : Set q} →
                 (P → Q) → ¬ Q → ¬ P
contraposition f ¬q p = contradiction (f p) ¬q

-- Note also the following use of flip:

private
  note : ∀ {p q} {P : Set p} {Q : Set q} →
         (P → ¬ Q) → Q → ¬ P
  note = flip

-- If we can decide P, then we can decide its negation.

¬? : ∀ {p} {P : Set p} → Dec P → Dec (¬ P)
¬? (yes p) = no (λ ¬p → ¬p p)
¬? (no ¬p) = yes ¬p

------------------------------------------------------------------------
-- Quantifier juggling

∃⟶¬∀¬ : ∀ {a p} {A : Set a} {P : A → Set p} →
        ∃ P → ¬ (∀ x → ¬ P x)
∃⟶¬∀¬ = flip uncurry

∀⟶¬∃¬ : ∀ {a p} {A : Set a} {P : A → Set p} →
        (∀ x → P x) → ¬ ∃ λ x → ¬ P x
∀⟶¬∃¬ ∀xPx (x , ¬Px) = ¬Px (∀xPx x)

¬∃⟶∀¬ : ∀ {a p} {A : Set a} {P : A → Set p} →
        ¬ ∃ (λ x → P x) → ∀ x → ¬ P x
¬∃⟶∀¬ = curry

∀¬⟶¬∃ : ∀ {a p} {A : Set a} {P : A → Set p} →
        (∀ x → ¬ P x) → ¬ ∃ (λ x → P x)
∀¬⟶¬∃ = uncurry

∃¬⟶¬∀ : ∀ {a p} {A : Set a} {P : A → Set p} →
        ∃ (λ x → ¬ P x) → ¬ (∀ x → P x)
∃¬⟶¬∀ = flip ∀⟶¬∃¬

-- When P is a decidable predicate over a finite set the following
-- lemma can be proved.

¬∀⟶∃¬ : ∀ n {p} (P : Fin n → Set p) → Decidable P →
        ¬ (∀ i → P i) → ∃ λ i → ¬ P i
¬∀⟶∃¬ n P dec ¬P = Prod.map id proj₁ $ ¬∀⟶∃¬-smallest n P dec ¬P

------------------------------------------------------------------------
-- Double-negation

¬¬-map : ∀ {p q} {P : Set p} {Q : Set q} →
         (P → Q) → ¬ ¬ P → ¬ ¬ Q
¬¬-map f = contraposition (contraposition f)

-- Stability under double-negation.

Stable : ∀ {ℓ} → Set ℓ → Set ℓ
Stable P = ¬ ¬ P → P

-- Everything is stable in the double-negation monad.

stable : ∀ {p} {P : Set p} → ¬ ¬ Stable P
stable ¬[¬¬p→p] = ¬[¬¬p→p] (λ ¬¬p → ⊥-elim (¬¬p (¬[¬¬p→p] ∘ const)))

-- Negated predicates are stable.

negated-stable : ∀ {p} {P : Set p} → Stable (¬ P)
negated-stable ¬¬¬P P = ¬¬¬P (λ ¬P → ¬P P)

-- Decidable predicates are stable.

decidable-stable : ∀ {p} {P : Set p} → Dec P → Stable P
decidable-stable (yes p) ¬¬p = p
decidable-stable (no ¬p) ¬¬p = ⊥-elim (¬¬p ¬p)

¬-drop-Dec : ∀ {p} {P : Set p} → Dec (¬ ¬ P) → Dec (¬ P)
¬-drop-Dec (yes ¬¬p) = no ¬¬p
¬-drop-Dec (no ¬¬¬p) = yes (negated-stable ¬¬¬p)

-- Double-negation is a monad (if we assume that all elements of ¬ ¬ P
-- are equal).

¬¬-Monad : ∀ {p} → RawMonad (λ (P : Set p) → ¬ ¬ P)
¬¬-Monad = record
  { return = contradiction
  ; _>>=_  = λ x f → negated-stable (¬¬-map f x)
  }

¬¬-push : ∀ {p q} {P : Set p} {Q : P → Set q} →
          ¬ ¬ ((x : P) → Q x) → (x : P) → ¬ ¬ Q x
¬¬-push ¬¬P⟶Q P ¬Q = ¬¬P⟶Q (λ P⟶Q → ¬Q (P⟶Q P))

-- A double-negation-translated variant of excluded middle (or: every
-- nullary relation is decidable in the double-negation monad).

excluded-middle : ∀ {p} {P : Set p} → ¬ ¬ Dec P
excluded-middle ¬h = ¬h (no (λ p → ¬h (yes p)))

-- If Whatever is instantiated with ¬ ¬ something, then this function
-- is call with current continuation in the double-negation monad, or,
-- if you will, a double-negation translation of Peirce's law.
--
-- In order to prove ¬ ¬ P one can assume ¬ P and prove ⊥. However,
-- sometimes it is nice to avoid leaving the double-negation monad; in
-- that case this function can be used (with Whatever instantiated to
-- ⊥).

call/cc : ∀ {w p} {Whatever : Set w} {P : Set p} →
          ((P → Whatever) → ¬ ¬ P) → ¬ ¬ P
call/cc hyp ¬p = hyp (λ p → ⊥-elim (¬p p)) ¬p

-- The "independence of premise" rule, in the double-negation monad.
-- It is assumed that the index set (Q) is inhabited.

independence-of-premise
  : ∀ {p q r} {P : Set p} {Q : Set q} {R : Q → Set r} →
    Q → (P → Σ Q R) → ¬ ¬ (Σ[ x ∈ Q ] (P → R x))
independence-of-premise {P = P} q f = ¬¬-map helper excluded-middle
  where
  helper : Dec P → _
  helper (yes p) = Prod.map id const (f p)
  helper (no ¬p) = (q , ⊥-elim ∘′ ¬p)

-- The independence of premise rule for binary sums.

independence-of-premise-⊎
  : ∀ {p q r} {P : Set p} {Q : Set q} {R : Set r} →
    (P → Q ⊎ R) → ¬ ¬ ((P → Q) ⊎ (P → R))
independence-of-premise-⊎ {P = P} f = ¬¬-map helper excluded-middle
  where
  helper : Dec P → _
  helper (yes p) = Sum.map const const (f p)
  helper (no ¬p) = inj₁ (⊥-elim ∘′ ¬p)

private

  -- Note that independence-of-premise-⊎ is a consequence of
  -- independence-of-premise (for simplicity it is assumed that Q and
  -- R have the same type here):

  corollary : ∀ {p ℓ} {P : Set p} {Q R : Set ℓ} →
              (P → Q ⊎ R) → ¬ ¬ ((P → Q) ⊎ (P → R))
  corollary {P = P} {Q} {R} f =
    ¬¬-map helper (independence-of-premise
                     true ([ _,_ true , _,_ false ] ∘′ f))
    where
    helper : ∃ (λ b → P → if b then Q else R) → (P → Q) ⊎ (P → R)
    helper (true  , f) = inj₁ f
    helper (false , f) = inj₂ f

-- The classical statements of excluded middle and double-negation
-- elimination.

Excluded-Middle : (ℓ : Level) → Set (suc ℓ)
Excluded-Middle p = {P : Set p} → Dec P

Double-Negation-Elimination : (ℓ : Level) → Set (suc ℓ)
Double-Negation-Elimination p = {P : Set p} → Stable P

private

  -- The two statements above are equivalent. The proofs are so
  -- simple, given the definitions above, that they are not exported.

  em⇒dne : ∀ {ℓ} → Excluded-Middle ℓ → Double-Negation-Elimination ℓ
  em⇒dne em = decidable-stable em

  dne⇒em : ∀ {ℓ} → Double-Negation-Elimination ℓ → Excluded-Middle ℓ
  dne⇒em dne = dne excluded-middle


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Interval.Base where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

data Interval : Type₀ where
  zero : Interval
  one  : Interval
  seg  : zero ≡ one

isContrInterval : isContr Interval
isContrInterval = (zero , (λ x → rem x))
  where
  rem : (x : Interval) → zero ≡ x
  rem zero      = refl
  rem one       = seg
  rem (seg i) j = seg (i ∧ j)

funExtInterval : ∀ {ℓ} (A B : Type ℓ) (f g : A → B) → ((x : A) → f x ≡ g x) → f ≡ g
funExtInterval A B f g p = λ i x → hmtpy x (seg i)
  where
  hmtpy : A → Interval → B
  hmtpy x zero    = f x
  hmtpy x one     = g x
  hmtpy x (seg i) = p x i

intervalElim : (A : Interval → Type₀) (x : A zero) (y : A one)
               (p : PathP (λ i → A (seg i)) x y) → (x : Interval) → A x
intervalElim A x y p zero    = x
intervalElim A x y p one     = y
intervalElim A x y p (seg i) = p i

-- Note that this is not definitional (it is not proved by refl)
intervalEta : ∀ {A : Type₀} (f : Interval → A) → intervalElim _ (f zero) (f one) (λ i → f (seg i)) ≡ f
intervalEta f i zero    = f zero
intervalEta f i one     = f one
intervalEta f i (seg j) = f (seg j)


{-# OPTIONS --no-exact-split --safe #-}
module Cubical.Data.Nat.Base where

open import Cubical.Core.Primitives

open import Agda.Builtin.Nat public
  using (zero; suc; _+_)
  renaming (Nat to ℕ; _-_ to _∸_; _*_ to _·_)

open import Cubical.Data.Nat.Literals public
open import Cubical.Data.Bool.Base
open import Cubical.Data.Sum.Base hiding (elim)
open import Cubical.Data.Empty.Base hiding (elim)
open import Cubical.Data.Unit.Base

predℕ : ℕ → ℕ
predℕ zero = zero
predℕ (suc n) = n

caseNat : ∀ {ℓ} → {A : Type ℓ} → (a0 aS : A) → ℕ → A
caseNat a0 aS zero    = a0
caseNat a0 aS (suc n) = aS

doubleℕ : ℕ → ℕ
doubleℕ zero = zero
doubleℕ (suc x) = suc (suc (doubleℕ x))

-- doublesℕ n m = 2^n · m
doublesℕ : ℕ → ℕ → ℕ
doublesℕ zero m = m
doublesℕ (suc n) m = doublesℕ n (doubleℕ m)

-- iterate
iter : ∀ {ℓ} {A : Type ℓ} → ℕ → (A → A) → A → A
iter zero f z    = z
iter (suc n) f z = f (iter n f z)

elim : ∀ {ℓ} {A : ℕ → Type ℓ}
  → A zero
  → ((n : ℕ) → A n → A (suc n))
  → (n : ℕ) → A n
elim a₀ _ zero = a₀
elim a₀ f (suc n) = f n (elim a₀ f n)

isEven isOdd : ℕ → Bool
isEven zero = true
isEven (suc n) = isOdd n
isOdd zero = false
isOdd (suc n) = isEven n

--Typed version
private
  toType : Bool → Type
  toType false = ⊥
  toType true = Unit

isEvenT : ℕ → Type
isEvenT n = toType (isEven n)

isOddT : ℕ → Type
isOddT n = isEvenT (suc n)

isZero : ℕ → Bool
isZero zero = true
isZero (suc n) = false

-- exponential

_^_ : ℕ → ℕ → ℕ
m ^ 0 = 1
m ^ (suc n) = m · m ^ n


module ReasoningEx where

open import Prelude
open import T
open import Contexts
open import Eq
open import Eq.Theory
open import Eq.ObsTheory

---- some example programs
-- boy, de bruijn indexes are unreadable
w = weaken-closed

plus-rec : ∀{Γ} → TExp Γ nat → TExp Γ nat → TExp Γ nat
plus-rec n m = rec n m (suc (var Z))

t-plus1 : TCExp (nat ⇒ nat ⇒ nat)
t-plus1 = Λ (Λ (plus-rec (var Z) (var (S Z))))
t-plus2 : TCExp (nat ⇒ nat ⇒ nat)
t-plus2 = Λ (Λ (plus-rec (var (S Z)) (var Z)))

plus-adds : ∀{Γ} → (n : Nat) (m : Nat) →
            Γ ⊢ plus-rec (t-numeral n) (t-numeral m) ≅ t-numeral (n +n m) :: nat
plus-adds Z m = obs-contains-def def-rec-z
plus-adds {Γ} (S n) m with
  (def-rec-s {Γ} {e = (t-numeral n)} {e0 = t-numeral m} {es = suc (var Z)})
-- If I don't name the def eq thing above and use it directly, agda uses all my core.
... | bullshit-workaround with obs-contains-def bullshit-workaround
... | step-eq with obs-congruence (plus-adds {Γ} n m) (suc ∘)
... | reccase = obs-trans step-eq reccase

help : (n : Nat) → ObservEq (nat :: []) nat
                   (rec (t-numeral n) (var Z) (suc (var Z)))
                   (rec (var Z) (t-numeral n) (suc (var Z)))
help n = {!!}

plus-commutes : [] ⊢ t-plus1 ≅ t-plus2 :: nat ⇒ nat ⇒ nat
plus-commutes with
  def-cong (def-beta {e = Λ (plus-rec (var Z) (var (S Z)))} {e' = var (S Z)}) (∘ $e var Z) |
  def-cong (def-beta {e = Λ (plus-rec (var (S Z)) (var Z))} {e' = var (S Z)}) (∘ $e var Z)
... | beq1 | beq2 with def-beta {e = plus-rec (var Z) (var (S (S Z)))} {e' = var Z} |
                       def-beta {e = plus-rec (var (S (S Z))) (var Z)} {e' = var Z}
... | beq1' | beq2' with obs-contains-def (def-trans beq1 beq1') | obs-contains-def (def-trans beq2 beq2')
... | oeq1 | oeq2 with function-induction-obs help
... | main-eq with obs-trans oeq1 (obs-trans main-eq (obs-sym oeq2))
... | lol = function-ext-obs (function-ext-obs lol)


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

  -- empty type
  data ⊥ : Set where

  -- from false, derive whatever
  abort : ∀ {C : Set} → ⊥ → C
  abort ()

  -- unit
  data ⊤ : Set where
    <> : ⊤

  -- sums
  data _+_ (A B : Set) : Set where
    Inl : A → A + B
    Inr : B → A + B

  -- pairs
  infixr 1 _,_
  record Σ {l1 l2 : Level} (A : Set l1) (B : A → Set l2) : Set (lmax l1 l2) where
    constructor _,_
    field
      π1 : A
      π2 : B π1
  open Σ public

  -- Sigma types, or dependent pairs, with nice notation.
  syntax Σ A (\ x -> B) = Σ[ x ∈ A ] B

  _×_ : {l1 : Level} {l2 : Level} → (Set l1) → (Set l2) → Set (lmax l1 l2)
  A × B = Σ A λ _ → B

  infixr 1 _×_
  infixr 1 _+_

  -- equality
  data _==_ {l : Level} {A : Set l} (M : A) : A → Set l where
    refl : M == M

  infixr 9 _==_

  -- disequality
  _≠_ : {l : Level} {A : Set l} → (a b : A) → Set l
  a ≠ b = (a == b) → ⊥

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

  -- transitivity of equality
  _·_ : {l : Level} {α : Set l} {x y z : α} → x == y → y == z → x == z
  refl · refl = refl

  -- symmetry of equality
  ! : {l : Level} {α : Set l} {x y : α} → x == y → y == x
  ! refl = refl

  -- ap, in the sense of HoTT, that all functions respect equality in their
  -- arguments. named in a slightly non-standard way to avoid naming
  -- clashes with hazelnut constructors.
  ap1 : {l1 l2 : Level} {α : Set l1} {β : Set l2} {x y : α} (F : α → β)
          → x == y → F x == F y
  ap1 F refl = refl

  -- transport, in the sense of HoTT, that fibrations respect equality
  tr : {l1 l2 : Level} {α : Set l1} {x y : α}
                    (B : α → Set l2)
                    → x == y
                    → B x
                    → B y
  tr B refl x₁ = x₁

  -- options
  data Maybe (A : Set) : Set where
    Some : A → Maybe A
    None : Maybe A

  -- the some constructor is injective. perhaps unsurprisingly.
  someinj : {A : Set} {x y : A} → Some x == Some y → x == y
  someinj refl = refl

  --  some isn't none.
  somenotnone : {A : Set} {x : A} → Some x == None → ⊥
  somenotnone ()

  -- function extensionality, used to reason about contexts as finite
  -- functions.
  postulate
     funext : {A : Set} {B : A → Set} {f g : (x : A) → (B x)} →
              ((x : A) → f x == g x) → f == g

  -- non-equality is commutative
  flip : {A : Set} {x y : A} → (x == y → ⊥) → (y == x → ⊥)
  flip neq eq = neq (! eq)

  -- two types are said to be equivalent, or isomorphic, if there is a pair
  -- of functions between them where both round-trips are stable up to ==
  _≃_ : Set → Set → Set
  _≃_ A B = Σ[ f ∈ (A → B) ] Σ[ g ∈ (B → A) ]
             (((a : A) → g (f a) == a) × (((b : B) → f (g b) == b)))


{-

This is a HoTT-UF core library based on cubical type theory, where the
cubical machinery is hidden, using the HoTT Book terminology and
notation.

The point is that function extensionality, propositional truncation
and univalence compute (an example is given below).

For the moment, this requires the development version of Agda.

-}

{-# OPTIONS --cubical --exact-split --safe #-}

module Cubical.Foundations.HoTT-UF where

open import Cubical.Core.Primitives hiding ( _≡_ )
open import Cubical.Core.Id public

open import Cubical.Foundations.Id public
     using ( _≡_            -- The identity type.
           ; refl           -- Unfortunately, pattern matching on refl is not available.
           ; J              -- Until it is, you have to use the induction principle J.

           ; transport      -- As in the HoTT Book.
           ; ap
           ; _∙_
           ; _⁻¹

           ; _≡⟨_⟩_         -- Standard equational reasoning.
           ; _∎

           ; funExt         -- Function extensionality
                            -- (can also be derived from univalence).

           ; Σ              -- Sum type. Needed to define contractible types, equivalences
           ; _,_            -- and univalence.
           ; pr₁            -- The eta rule is available.
           ; pr₂

           ; isProp         -- The usual notions of proposition, contractible type, set.
           ; isContr
           ; isSet

           ; isEquiv        -- A map with contractible fibers
                            -- (Voevodsky's version of the notion).
           ; _≃_            -- The type of equivalences between two given types.
           ; EquivContr     -- A formulation of univalence.

           ; ∥_∥             -- Propositional truncation.
           ; ∣_∣             -- Map into the propositional truncation.
           ; ∥∥-isProp       -- A truncated type is a proposition.
           ; ∥∥-recursion    -- Non-dependent elimination.
           ; ∥∥-induction    -- Dependent elimination.
           )

{-

Here is an illustration of how function extensionality computes.

-}

private

  data ℕ : Type₀ where
   zero : ℕ
   succ : ℕ → ℕ

  f g : ℕ → ℕ

  f n = n

  g zero = zero
  g (succ n) = succ (g n)

  h : (n : ℕ) → f n ≡ g n
  h zero = refl
  h (succ n) = ap succ (h n)

  p : f ≡ g
  p = funExt h

  five : ℕ
  five = succ (succ (succ (succ (succ zero))))

  a : Σ ℕ (λ n → f n ≡ five)
  a = five , refl

  b : Σ ℕ (λ n → g n ≡ five)
  b = transport (λ - → Σ ℕ (λ n → - n ≡ five)) p a

  c : pr₁ b ≡ five
  c = refl

{-

If we had funExt as a postulate, then the definition of c would not
type check. Moreover, the term pr₁ b would not evaluate to five, as it
does with the cubical type theory implementation of funext.

TODO. A similar computational example with univalence.

-}


-- Issue #2814 reported by tomjack on 2017-10-18

{-# OPTIONS --cubical --rewriting #-}

-- prelude stolen from Saizan/cubical-demo

open import Agda.Primitive.Cubical public

postulate
  Path' : ∀ {ℓ} {A :     Set ℓ} → A    → A    → Set ℓ
  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ

{-# BUILTIN PATHP        PathP     #-}

infix 4 _≡_
_≡_ : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ
_≡_ {A = A} = PathP (λ _ → A)

Path = _≡_

refl : ∀ {ℓ} {A : Set ℓ} {x : A} → x ≡ x
refl {x = x} = λ _ → x

postulate
  Rewrite : ∀ {ℓ} {A : Set ℓ} → A → A → Set

{-# BUILTIN REWRITE Rewrite #-}

module Good where
  postulate
    Unit : Set
    unit : Unit

  module UnitElim (P : Unit → Set) (unit* : P unit) where
    postulate
      Unit-elim : (x : Unit) → P x
      unit-β : Rewrite (Unit-elim unit) unit*
  open UnitElim public
  {-# REWRITE unit-β #-}

  test₁ : {C : Set} {c₀ : C} → Path {A = C} (Unit-elim (λ _ → C) c₀ unit) c₀
  test₁ = refl

  test₂ : {C : Set} {c₀ : C} → Path {A = Path c₀ c₀} (λ j → Unit-elim (λ _ → C) c₀ unit) refl
  test₂ = refl

-- same code, but with a dummy module parameter
module Bad (Dummy : Set) where
  postulate
    Unit : Set
    unit : Unit

  module UnitElim (P : Unit → Set) (unit* : P unit) where
    postulate
      Unit-elim : (x : Unit) → P x
      unit-β : Rewrite (Unit-elim unit) unit*
  open UnitElim public
  {-# REWRITE unit-β #-}

  test₁ : {C : Set} {c₀ : C} → Path {A = C} (Unit-elim (λ _ → C) c₀ unit) c₀
  test₁ = refl
  test₂ : {C : Set} {c₀ : C} → Path {A = Path c₀ c₀} (λ j → Unit-elim (λ _ → C) c₀ unit) refl
  test₂ = refl

-- WAS:
-- Unit-elim (λ _ → .C) .c₀ unit != .c₀ of type .C
-- when checking that the expression refl has type
-- Path (λ j → Unit-elim (λ _ → .C) .c₀ unit) refl

-- SHOULD: succeed


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Construction.Properties.EilenbergMoore where

open import Level
import Relation.Binary.PropositionalEquality as ≡

open import Categories.Adjoint
open import Categories.Adjoint.Properties
open import Categories.Category
open import Categories.Functor using (Functor; _∘F_)
open import Categories.Functor.Equivalence
open import Categories.Monad

open import Categories.NaturalTransformation renaming (id to idN)
open import Categories.Morphism.HeterogeneousIdentity

open import Categories.Adjoint.Construction.EilenbergMoore
open import Categories.Category.Construction.EilenbergMoore

private
  variable
    o ℓ e : Level
    𝒞 𝒟 : Category o ℓ e

module _ {F : Functor 𝒞 𝒟} {G : Functor 𝒟 𝒞} (F⊣G : Adjoint F G) where
  private
    T : Monad 𝒞
    T = adjoint⇒monad F⊣G

    𝒞ᵀ : Category _ _ _
    𝒞ᵀ = EilenbergMoore T

    module 𝒞 = Category 𝒞
    module 𝒟 = Category 𝒟
    module 𝒞ᵀ = Category 𝒞ᵀ

    open 𝒞.HomReasoning

    module T = Monad T
    module F = Functor F
    module G = Functor G

    open Adjoint F⊣G
    open NaturalTransformation

  -- Maclane's Comparison Functor
  ComparisonF : Functor 𝒟 𝒞ᵀ
  ComparisonF = record
    { F₀ = λ X → record
      { A = G.F₀ X
      ; action = G.F₁ (counit.η X)
      ; commute = commute (G ∘ˡ counit) (counit.η X)
      ; identity = zag
      }
    ; F₁ = λ {A} {B} f → record
      { arr = G.F₁ f
      ; commute =  begin
        𝒞 [ G.F₁ f ∘ G.F₁ (counit.η A) ]               ≈˘⟨ G.homomorphism ⟩
        G.F₁ (𝒟 [ f ∘ (counit.η A) ])                  ≈˘⟨ G.F-resp-≈ (counit.commute f) ⟩
        G.F₁ (𝒟 [ counit.η B ∘ F.F₁ (G.F₁ f) ])        ≈⟨ G.homomorphism  ⟩
        𝒞 [ G.F₁ (counit.η B) ∘ G.F₁ (F.F₁ (G.F₁ f)) ] ∎
      }
    ; identity = G.identity
    ; homomorphism = G.homomorphism
    ; F-resp-≈ = G.F-resp-≈
    }

  private
    K = ComparisonF
    module K = Functor K
    module Gᵀ = Functor (Forgetful T)
    module Fᵀ = Functor (Free T)

  Comparison∘F≡Free : (ComparisonF ∘F F) ≡F Free T
  Comparison∘F≡Free = record
    { eq₀ = λ X → ≡.refl
    ; eq₁ = λ {A} {B} f → begin
      Module⇒.arr (𝒞ᵀ [ (hid 𝒞ᵀ ≡.refl) ∘ K.F₁ (F.F₁ f) ]) ≈⟨ hid-refl 𝒞ᵀ {A = K.F₀ (F.F₀ B)} ⟩∘⟨refl ⟩
      Module⇒.arr (𝒞ᵀ [ 𝒞ᵀ.id ∘ K.F₁ (F.F₁ f) ])           ≈⟨ 𝒞.identityˡ {f = Module⇒.arr (K.F₁ (F.F₁ f))} ⟩
      Module⇒.arr (K.F₁ (F.F₁ f))                           ≈⟨ refl ⟩
      Module⇒.arr (Fᵀ.F₁ f)                                 ≈˘⟨ 𝒞ᵀ.identityʳ {f = Fᵀ.F₁ f} ⟩
      Module⇒.arr (𝒞ᵀ [ Fᵀ.F₁ f ∘ 𝒞ᵀ.id ])                 ≈˘⟨ refl⟩∘⟨ hid-refl 𝒞ᵀ {A = Fᵀ.F₀ A} ⟩
      Module⇒.arr (𝒞ᵀ [ Fᵀ.F₁ f ∘ (hid 𝒞ᵀ ≡.refl) ])       ∎
    }

  Forgetful∘ComparisonF≡G : (Forgetful T ∘F ComparisonF) ≡F G
  Forgetful∘ComparisonF≡G = record
    { eq₀ = λ X → ≡.refl
    ; eq₁ = λ f → begin
      𝒞 [ (hid 𝒞 ≡.refl) ∘ (Gᵀ.F₁ (K.F₁ f)) ] ≈⟨ hid-refl 𝒞 ⟩∘⟨refl ⟩
      𝒞 [ 𝒞.id ∘ (Gᵀ.F₁ (K.F₁ f)) ]           ≈⟨ 𝒞.identityˡ ⟩
      (Gᵀ.F₁ (K.F₁ f))                         ≈⟨ refl ⟩
      G.F₁ f                                   ≈˘⟨ 𝒞.identityʳ ⟩
      𝒞 [ G.F₁ f ∘ 𝒞.id ]                     ≈˘⟨ refl⟩∘⟨ hid-refl 𝒞 ⟩
      𝒞 [ G.F₁ f ∘ (hid 𝒞 ≡.refl) ]           ∎
    }


{-# OPTIONS --exact-split #-}

module ExactSplitParity where

data Bool : Set where
  true false : Bool

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

parity : ℕ → ℕ → Bool
parity zero          zero          = true
parity zero          (suc zero)    = false
parity zero          (suc (suc n)) = parity zero n
parity (suc zero)    zero          = false
parity (suc (suc m)) zero          = parity m zero
parity (suc m)       (suc n)       = parity m n


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

-- Definitions for the types of a polynomial stored in sparse horner
-- normal form.
--
-- These definitions ensure that the polynomial is actually in fully
-- canonical form, with no trailing zeroes, etc.

open import Polynomial.Parameters

module Polynomial.NormalForm.Definition
  {a ℓ}
  (coeffs : RawCoeff a ℓ)
  where

open import Polynomial.NormalForm.InjectionIndex

open import Relation.Nullary using (¬_)
open import Level            using (_⊔_)
open import Data.Empty       using (⊥)
open import Data.Unit        using (⊤)
open import Data.Nat         using (ℕ; suc; zero)
open import Data.Bool        using (T)
open import Data.List.Kleene public

infixl 6 _Δ_
record PowInd {c} (C : Set c) : Set c where
  inductive
  constructor _Δ_
  field
    coeff : C
    pow   : ℕ
open PowInd public

open RawCoeff coeffs

mutual
  -- A Polynomial is indexed by the number of variables it contains.
  infixl 6 _Π_
  record Poly (n : ℕ) : Set a where
    inductive
    constructor _Π_
    field
      {i}  : ℕ
      flat : FlatPoly i
      i≤n  : i ≤′ n

  data FlatPoly : ℕ → Set a where
    Κ : Carrier → FlatPoly zero
    Σ : ∀ {n} → (xs : Coeff n +) → .{xn : Norm xs} → FlatPoly (suc n)

  -- A list of coefficients, paired with the exponent *gap* from the
  -- preceding coefficient. In other words, to represent the
  -- polynomial:
  --
  --   3 + 2x² + 4x⁵ + 2x⁷
  --
  -- We write:
  --
  --   [(3,0),(2,1),(4,2),(2,1)]
  --
  -- Which can be thought of as a representation of the expression:
  --
  --   x⁰ * (3 + x * x¹ * (2 + x * x² * (4 + x * x¹ * (2 + x * 0))))
  --
  -- This is sparse Horner normal form.

  Coeff : ℕ → Set a
  Coeff n = PowInd (NonZero n)

  -- We disallow zeroes in the coefficient list. This condition alone
  -- is enough to ensure a unique representation for any polynomial.
  infixl 6 _≠0
  record NonZero (i : ℕ) : Set a where
    inductive
    constructor _≠0
    field
      poly : Poly i
      .{poly≠0} : ¬ Zero poly

  -- This predicate is used (in its negation) to ensure that no
  -- coefficient is zero, preventing any trailing zeroes.
  Zero : ∀ {n} → Poly n → Set
  Zero (Κ x Π _) = T (Zero-C x)
  Zero (Σ _ Π _) = ⊥

  -- This predicate is used to ensure that all polynomials are in
  -- normal form: if a particular level is constant, than it can
  -- be collapsed into the level below it.
  Norm : ∀ {i} → Coeff i + → Set
  Norm (_ Δ zero  & [])  = ⊥
  Norm (_ Δ zero  & ∹ _) = ⊤
  Norm (_ Δ suc _ & _)   = ⊤
open NonZero public
open Poly public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Convenient syntax for reasoning with a setoid
------------------------------------------------------------------------

-- Example use:

-- n*0≡0 : ∀ n → n * 0 ≡ 0
-- n*0≡0 zero    = refl
-- n*0≡0 (suc n) = begin
--   suc n * 0 ≈⟨ refl ⟩
--   n * 0 + 0 ≈⟨ ... ⟩
--   n * 0     ≈⟨ n*0≡0 n ⟩
--   0         ∎

-- Module `≡-Reasoning` in `Relation.Binary.PropositionalEquality`
-- is recommended for equational reasoning when the underlying equality is
-- `_≡_`.

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

open import Relation.Binary

module Relation.Binary.Reasoning.Setoid {s₁ s₂} (S : Setoid s₁ s₂) where

open Setoid S

------------------------------------------------------------------------
-- Reasoning combinators

open import Relation.Binary.Reasoning.PartialSetoid partialSetoid public
open import Relation.Binary.Reasoning.Base.Single _≈_ refl trans public
  using (_∎)


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

open import Categories.Category
open import Categories.Category.Monoidal

module Categories.Category.Monoidal.Symmetric {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) where

open import Level

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

open import Categories.Functor.Bifunctor
open import Categories.Functor.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)

open import Categories.Morphism C
open import Categories.Morphism.Properties C
open import Categories.Category.Monoidal.Braided M
open Category C
open Commutation

private
  variable
    X Y Z : Obj

-- symmetric monoidal category
-- commutative braided monoidal category
--
-- the reason why we define symmetric categories via braided monoidal categories could
-- be not obvious, but it is the right definition: it requires again a redundant
-- hexagon proof which allows achieves definitional equality of the opposite.
record Symmetric : Set (levelOfTerm M) where
  field
    braided : Braided

  module braided = Braided braided
  open braided public

  private
    B : ∀ {X Y} → X ⊗₀ Y ⇒ Y ⊗₀ X
    B {X} {Y} = braiding.⇒.η (X , Y)

  field
    commutative : B {X} {Y} ∘ B {Y} {X} ≈ id

  braided-iso : X ⊗₀ Y ≅ Y ⊗₀ X
  braided-iso = record
    { from = B
    ; to   = B
    ; iso  = record
      { isoˡ = commutative
      ; isoʳ = commutative
      }
    }

  module braided-iso {X Y} = _≅_ (braided-iso {X} {Y})

private
  record Symmetric′ : Set (levelOfTerm M) where
    open Monoidal M

    field
      braiding : NaturalIsomorphism ⊗ (flip-bifunctor ⊗)

    module braiding = NaturalIsomorphism braiding

    private
      B : ∀ {X Y} → X ⊗₀ Y ⇒ Y ⊗₀ X
      B {X} {Y} = braiding.⇒.η (X , Y)

    field
      commutative : B {X} {Y} ∘ B {Y} {X} ≈ id
      hexagon     : [ (X ⊗₀ Y) ⊗₀ Z ⇒ Y ⊗₀ Z ⊗₀ X ]⟨
                      B  ⊗₁ id                    ⇒⟨ (Y ⊗₀ X) ⊗₀ Z ⟩
                      associator.from             ⇒⟨ Y ⊗₀ X ⊗₀ Z ⟩
                      id ⊗₁ B
                    ≈ associator.from             ⇒⟨ X ⊗₀ Y ⊗₀ Z ⟩
                      B                           ⇒⟨ (Y ⊗₀ Z) ⊗₀ X ⟩
                      associator.from
                    ⟩

    braided-iso : X ⊗₀ Y ≅ Y ⊗₀ X
    braided-iso = record
      { from = B
      ; to   = B
      ; iso  = record
        { isoˡ = commutative
        ; isoʳ = commutative
        }
      }

    module braided-iso {X Y} = _≅_ (braided-iso {X} {Y})

    -- we don't define [Symmetric] from [Braided] because we want to avoid asking
    -- [hexagon₂], which can readily be proven using the [hexagon] and [commutative].
    braided : Braided
    braided = record
      { braiding = braiding
      ; hexagon₁ = hexagon
      ; hexagon₂ = λ {X Y Z} →
                     Iso-≈ hexagon
                           (Iso-∘ (Iso-∘ ([ -⊗ Y ]-resp-Iso braided-iso.iso) associator.iso)
                                  ([ X ⊗- ]-resp-Iso braided-iso.iso))
                           (Iso-∘ (Iso-∘ associator.iso braided-iso.iso)
                                  associator.iso)
      }

symmetricHelper : Symmetric′ → Symmetric
symmetricHelper S = record
  { braided     = braided
  ; commutative = commutative
  }
  where open Symmetric′ S


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

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

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

module Fields.FieldOfFractions.Setoid {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (I : IntegralDomain R) where

record fieldOfFractionsSet : Set (a ⊔ b) where
  field
    num : A
    denom : A
    .denomNonzero : (Setoid._∼_ S denom (Ring.0R R) → False)

fieldOfFractionsSetoid : Setoid fieldOfFractionsSet
Setoid._∼_ fieldOfFractionsSetoid (record { num = a ; denom = b ; denomNonzero = b!=0 }) (record { num = c ; denom = d ; denomNonzero = d!=0 }) = Setoid._∼_ S (a * d) (b * c)
Equivalence.reflexive (Setoid.eq fieldOfFractionsSetoid) {record { num = a ; denom = b ; denomNonzero = b!=0 }} = Ring.*Commutative R
Equivalence.symmetric (Setoid.eq fieldOfFractionsSetoid) {record { num = a ; denom = b ; denomNonzero = b!=0 }} {record { num = c ; denom = d ; denomNonzero = d!=0 }} ad=bc = transitive (Ring.*Commutative R) (transitive (symmetric ad=bc) (Ring.*Commutative R))
  where
    open Equivalence (Setoid.eq S)
Equivalence.transitive (Setoid.eq fieldOfFractionsSetoid) {record { num = a ; denom = b ; denomNonzero = b!=0 }} {record { num = c ; denom = d ; denomNonzero = d!=0 }} {record { num = e ; denom = f ; denomNonzero = f!=0 }} ad=bc cf=de = p5
  where
    open Setoid S
    open Ring R
    open Equivalence eq
    p : (a * d) * f ∼ (b * c) * f
    p = Ring.*WellDefined R ad=bc reflexive
    p2 : (a * f) * d ∼ b * (d * e)
    p2 = transitive (transitive (symmetric *Associative) (transitive (*WellDefined reflexive *Commutative) *Associative)) (transitive p (transitive (symmetric *Associative) (*WellDefined reflexive cf=de)))
    p3 : (a * f) * d ∼ (b * e) * d
    p3 = transitive p2 (transitive (*WellDefined reflexive *Commutative) *Associative)
    p4 : ((d ∼ 0R) → False) → ((a * f) ∼ (b * e))
    p4 = cancelIntDom I (transitive *Commutative (transitive p3 *Commutative))
    p5 : (a * f) ∼ (b * e)
    p5 = p4 λ t → exFalso (d!=0 t)


module Natural where

open import Agda.Builtin.Equality

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

-- seven = suc (suc (suc (suc (suc (suc (suc zero))))))

{-# BUILTIN NATURAL ℕ #-}

_+_ : ℕ → ℕ → ℕ
infixl 6 _+_
zero + b = b
(suc a) + b = suc (a + b)

{-# BUILTIN NATPLUS _+_ #-}

+-id : ∀ (a : ℕ) → a + zero ≡ zero + a
+-id zero = refl
+-id (suc a) rewrite +-id a = refl

+-comm : ∀ (a b : ℕ) → a + b ≡ b + a
+-comm zero b rewrite +-id b = refl
+-comm (suc a) zero rewrite +-id (suc a) = refl
+-comm (suc a) (suc b)
    rewrite +-comm a (suc b)
    | +-comm b (suc a)
    | +-comm a b  = refl

+-asso : ∀ (a b c : ℕ) → a + b + c ≡ a + (b + c)
+-asso zero b c = refl
+-asso (suc a) zero c
    rewrite +-id (suc a)
    | +-id a = refl
+-asso (suc a) (suc b) zero
    rewrite +-id (suc a + suc b)
    | +-id b = refl
+-asso (suc a) (suc b) (suc c)
    rewrite (+-comm a (suc b))
    | +-comm (b + a) (suc c)
    | +-comm b a
    | +-comm c (a + b)
    | +-comm b (suc c)
    | +-comm a (suc (suc (c + b)))
    | +-comm c b
    | +-comm (b + c) a
    | +-asso a b c = refl

+-rear : ∀ (a b c d : ℕ) → a + b + (c + d) ≡ a + (b + c) + d
+-rear zero b c d rewrite +-asso b c d = refl
+-rear (suc a) b c d
    rewrite (+-asso (suc a) b (c + d))
    | +-asso a (b + c) d
    | +-asso b c d = refl

+-swap : ∀ (a b c : ℕ) → a + (b + c) ≡ b + (a + c)
+-swap a b c
    rewrite (+-comm a (b + c))
    | +-comm b (a + c)
    | +-asso a c b
    | +-comm c b
    | +-comm a (b + c) = refl

_*_ : ℕ → ℕ → ℕ
infixl 7 _*_
zero * b = zero
suc a * b = b + a * b

{-# BUILTIN NATTIMES _*_ #-}

*-id : ∀ (a : ℕ) → a * (suc zero) ≡ (suc zero) * a
*-id zero = refl
*-id (suc a)
    rewrite +-comm (suc zero) a
    | *-id a = refl

*-z : ∀ (a : ℕ) → a * zero ≡ zero * a
*-z zero = refl
*-z (suc a) rewrite *-z a = refl

*-comm : ∀ (a b : ℕ) → a * b ≡ b * a
*-comm zero b rewrite *-z b = refl
*-comm (suc a) zero rewrite *-z a = refl
*-comm (suc a) (suc b)
    rewrite (*-comm a (suc b))
    | (*-comm b (suc a))
    | (*-comm a b )
    | (+-comm b (a + b * a))
    | (+-comm a (b + b * a))
    | (+-comm a (b * a))
    | (+-comm b (b * a))
    | (+-asso (b * a) a b)
    | (+-asso (b * a) b a)
    | (+-comm a b) = refl

*-+-dist-r : ∀ (a b c : ℕ) → (a + b) * c ≡ a * c + b * c
*-+-dist-r zero b c = refl
*-+-dist-r (suc a) zero c
    rewrite (+-comm (suc a) zero)
    | +-comm a zero
    | +-asso c (a * c) zero
    | +-comm (a * c) zero = refl
*-+-dist-r (suc a) (suc b) c
    rewrite (+-comm a (suc b))
    | +-rear c (a * c) c (b * c)
    | +-comm (a * c) c
    | +-asso c (c + a * c) (b * c)
    | +-asso c (a * c) (b * c)
    | +-comm (a * c) (b * c)
    | *-+-dist-r b a c = refl

*-+-dist-l : ∀ (a b c : ℕ) → a * (b + c) ≡ a * b + a * c
*-+-dist-l a zero c rewrite (*-z a) = refl
*-+-dist-l a (suc b) zero
    rewrite (+-comm (suc b) zero)
    | *-z a
    | +-comm (a * suc b) zero = refl
*-+-dist-l a (suc b) (suc c)
    rewrite (+-comm b (suc c))
    | *-comm a (suc (suc (c + b)))
    | *-comm a (suc b)
    | *-comm a (suc c)
    | +-rear a (b * a) a (c * a)
    | +-comm (b * a) a
    | +-asso a (a + b * a) (c * a)
    | +-asso a (b * a) (c * a)
    | +-comm (b * a) (c * a)
    | *-comm (c + b) a
    | *-comm c a
    | *-comm b a
    | *-+-dist-l a c b = refl

*-asso : ∀ (a b c : ℕ) → a * b * c ≡ a * (b * c)
*-asso zero b c = refl
*-asso (suc a) zero c rewrite (*-asso a zero c) = refl
*-asso (suc a) (suc b) c
    rewrite (*-+-dist-r (suc b) (a * suc b) c)
    | *-asso a (suc b) c = refl

_^_ : ℕ → ℕ → ℕ
m ^ zero = suc zero
m ^ (suc n) = m * (m ^ n)

^-dist-+-*-l : ∀ (a b c : ℕ) →  a ^ (b + c) ≡ (a ^ b) * (a ^ c)
^-dist-+-*-l a zero c
    rewrite (+-comm zero (a ^ c))
    | +-asso (a ^ c) zero zero = refl
^-dist-+-*-l a (suc b) c
    rewrite *-asso a (a ^ b) (a ^ c)
    | ^-dist-+-*-l a b c = refl

^-dist-*-r : ∀ (a b c : ℕ) → (a * b) ^ c ≡ (a ^ c) * (b ^ c)
^-dist-*-r a b zero rewrite (+-comm (suc zero) zero) = refl
^-dist-*-r a b (suc c)
    rewrite (*-asso a (a ^ c) (b * (b ^ c)))
    | *-comm (a ^ c) (b * (b ^ c))
    | *-asso b (b ^ c) (a ^ c)
    | *-comm (b ^ c) (a ^ c)
    | *-asso a b ((a * b) ^ c)
    | ^-dist-*-r a b c = refl

^-asso-* : ∀ (a b c : ℕ) → (a ^ b) ^ c ≡ a ^ (b * c)
^-asso-* a b zero rewrite (*-comm b zero) = refl
^-asso-* a b (suc c)
    rewrite (*-comm b (suc c))
    | ^-dist-+-*-l a b (c * b)
    | *-comm c b
    | ^-asso-* a b c = refl

data Bin : Set where
    ⟨⟩ : Bin
    _O : Bin → Bin
    _I : Bin → Bin

inc : Bin → Bin
inc ⟨⟩ = ⟨⟩ I
inc (n O) = n I
inc (n I) = (inc n) O

to : ℕ → Bin
to zero = ⟨⟩ O
to (suc n) = inc (to n)

from : Bin → ℕ
from ⟨⟩ = zero
from (n O) = 2 * (from n)
from (n I) = suc (2 * (from n))

thm₁ : ∀ (b : Bin) → from (inc b) ≡ suc (from b)
thm₁ ⟨⟩ = refl
thm₁ (a O) = refl
thm₁ (a I)
    rewrite thm₁ a
    | +-comm (suc (from a)) zero
    | +-comm (from a) zero
    | +-comm (from a) (suc (from a)) = refl

-- thm₂ : ∀ (b : Bin) → to (from b) = b
-- 这是错误的，因为 Bin 中的 (⟨⟩ O) 和 (⟨⟩)
-- 都和 自然数 的 0 对应
-- from 并非单射

thm₃ : ∀ (n : ℕ) → from (to n) ≡ n
thm₃ zero = refl
thm₃ (suc n)
  rewrite thm₁ (to (suc n))
    | thm₁ (to n)
    | thm₃ n = refl


module Structure.Operator.Vector.FiniteDimensional.LinearMaps.ChangeOfBasis where

open import Functional
import      Lvl
open import Numeral.CoordinateVector as Vec using () renaming (Vector to Vec)
open import Numeral.Finite
open import Numeral.Natural
open import Structure.Function.Multi
open import Structure.Operator.Properties
open import Structure.Operator.Vector.FiniteDimensional
open import Structure.Operator.Vector.LinearCombination
open import Structure.Operator.Vector.LinearMap
open import Structure.Operator.Vector.Proofs
open import Structure.Operator.Vector
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓ ℓᵥ ℓₛ ℓᵥₑ ℓₛₑ : Lvl.Level
private variable V Vₗ Vᵣ S : Type{ℓ}
private variable _+ᵥ_ : V → V → V
private variable _⋅ₛᵥ_ : S → V → V
private variable _+ₛ_ _⋅ₛ_ : S → S → S
private variable n : ℕ
private variable i j k : 𝕟(n)
private variable vf : Vec(n)(V)

module _
  ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpace : VectorSpace{V = V}{S = S}(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_))
  where

  open VectorSpace(vectorSpace)

  -- changeBasis : LinearOperator(vectorSpace)(linearCombination )


{-# OPTIONS --without-K #-}
module sets.fin.ordering where

open import equality.core
open import function.isomorphism
open import sets.core
open import sets.fin.core
open import sets.fin.properties
import sets.nat.ordering as N

_<_ : ∀ {n} → Fin n → Fin n → Set
i < j = toℕ i N.< toℕ j
infixr 4 _<_

ord-from-ℕ : ∀ {n} {i j : Fin n}
           → Ordering N._<_ (toℕ i) (toℕ j)
           → Ordering _<_ i j
ord-from-ℕ (lt p) = lt p
ord-from-ℕ (eq p) = eq (toℕ-inj p)
ord-from-ℕ (gt p) = gt p

compare : ∀ {n} → (i j : Fin n) → Ordering _<_ i j
compare i j = ord-from-ℕ (N.compare (toℕ i) (toℕ j))


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

open import Categories.Category.Core

module Categories.Object.Product.Limit {o ℓ e} (C : Category o ℓ e) where

open import Level
open import Data.Nat.Base using (ℕ)
open import Data.Fin.Base using (Fin)
open import Data.Fin.Patterns

open import Categories.Category.Lift
open import Categories.Category.Finite.Fin
open import Categories.Category.Finite.Fin.Construction.Discrete
open import Categories.Object.Product C
open import Categories.Diagram.Limit
open import Categories.Functor.Core

import Categories.Category.Construction.Cones as Co
import Categories.Morphism.Reasoning as MR

private
  module C = Category C
  open C
  open MR C
  open HomReasoning

module _ {o′ ℓ′ e′} {F : Functor (liftC o′ ℓ′ e′ (Discrete 2)) C} where
  private
    module F = Functor F
    open F

  limit⇒product : Limit F → Product (F₀ (lift 0F)) (F₀ (lift 1F))
  limit⇒product L = record
    { A×B      = apex
    ; π₁       = proj (lift 0F)
    ; π₂       = proj (lift 1F)
    ; ⟨_,_⟩    = λ f g → rep record
      { apex = record
        { ψ       = λ { (lift 0F) → f
                      ; (lift 1F) → g }
        ; commute = λ { {lift 0F} {lift 0F} (lift 0F) → elimˡ identity
                      ; {lift 1F} {lift 1F} (lift 0F) → elimˡ identity }
        }
      }
    ; project₁ = commute
    ; project₂ = commute
    ; unique   = λ {_} {h} eq eq′ → terminal.!-unique record
      { arr     = h
      ; commute = λ { {lift 0F} → eq
                    ; {lift 1F} → eq′ }
      }
    }
    where open Limit L

module _ o′ ℓ′ e′ A B where
  open Equiv

  product⇒limit-F : Functor (liftC o′ ℓ′ e′ (Discrete 2)) C
  product⇒limit-F = record
    { F₀           = λ { (lift 0F) → A
                       ; (lift 1F) → B }
    ; F₁           = λ { {lift 0F} {lift 0F} _ → C.id
                       ; {lift 1F} {lift 1F} _ → C.id }
    ; identity     = λ { {lift 0F} → refl
                       ; {lift 1F} → refl }
    ; homomorphism = λ { {lift 0F} {lift 0F} {lift 0F} → sym identity²
                       ; {lift 1F} {lift 1F} {lift 1F} → sym identity² }
    ; F-resp-≈     = λ { {lift 0F} {lift 0F} _ → refl
                       ; {lift 1F} {lift 1F} _ → refl }
    }

module _ o′ ℓ′ e′ {A B} (p : Product A B) where
  open Product p
  private
    F = product⇒limit-F o′ ℓ′ e′ A B
    open Functor F

  product⇒limit : Limit F
  product⇒limit = record
    { terminal = record
      { ⊤        = record
        { N    = A×B
        ; apex = record
          { ψ       = λ { (lift 0F) → π₁
                        ; (lift 1F) → π₂ }
          ; commute = λ { {lift 0F} {lift 0F} (lift 0F) → identityˡ
                        ; {lift 1F} {lift 1F} (lift 0F) → identityˡ }
          }
        }
      ; !        = λ {K} →
        let open Co.Cone F K
        in record
        { arr     = ⟨ ψ (lift 0F) , ψ (lift 1F) ⟩
        ; commute = λ { {lift 0F} → project₁
                      ; {lift 1F} → project₂ }
        }
      ; !-unique = λ {K} f →
        let module K = Co.Cone F K
            module f = Co.Cone⇒ F f
        in begin
          ⟨ K.ψ (lift 0F) , K.ψ (lift 1F) ⟩ ≈˘⟨ ⟨⟩-cong₂ f.commute f.commute ⟩
          ⟨ π₁ ∘ f.arr , π₂ ∘ f.arr ⟩       ≈⟨ g-η ⟩
          f.arr                             ∎
      }
    }


module Examples where

open import Prelude
open import Star
open import Modal

El : Set -> Rel True
El A _ _ = A

List : Set -> Set
List A = Star (El A) _ _

Nat = List True

zero : Nat
zero = ε

suc : Nat -> Nat
suc n = _ • n

-- Vectors

Vec : Set -> Nat -> Set
Vec A = All (\_ -> A)

infixr 40 _::_
_::_ : {A : Set}{n : Nat} -> A -> Vec A n -> Vec A (suc n)
x :: xs = check x • xs

-- Fin

Fin : Nat -> Set
Fin = Any (\_ -> True)

-- Turning a vector to a list

vecToList : {A : Set}{n : Nat} -> Vec A n -> List A
vecToList {A} = map ! uncheck

listToVec : {A : Set}(xs : List A) -> Vec A (length xs)
listToVec  ε       = ε
listToVec (x • xs) = x :: listToVec xs

-- span

test : Vec Nat (suc (suc (suc zero)))
test = zero :: suc zero :: suc (suc zero) :: ε


------------------------------------------------------------------------
-- Regular expressions
------------------------------------------------------------------------

open import Setoids

module RegExps (S : Setoid) where

infix  8 _⋆
infixl 7 _⊙_
infixl 6 _∣_
infix  1 _∈‿⟦_⟧

open import Prelude
private open module S' = Setoid S

------------------------------------------------------------------------
-- Regular expressions

data RegExp : Set where
  ∅   : RegExp                      -- Matches nothing.
  ε   : RegExp                      -- Matches the empty string.
  •   : RegExp                      -- Matches any single character.
  sym : carrier -> RegExp           -- Matches the given character.
  _⋆  : RegExp -> RegExp            -- Kleene star.
  _∣_ : RegExp -> RegExp -> RegExp  -- Choice.
  _⊙_ : RegExp -> RegExp -> RegExp  -- Sequencing.

------------------------------------------------------------------------
-- Size of a regular expression

size : RegExp -> ℕ
size (re ⋆)      = 1 + size re
size (re₁ ∣ re₂) = 1 + size re₁ + size re₂
size (re₁ ⊙ re₂) = 1 + size re₁ + size re₂
size _           = 1

------------------------------------------------------------------------
-- Semantics of regular expressions

-- The type xs ∈‿⟦ re ⟧ is inhabited iff xs matches the regular
-- expression re.

data _∈‿⟦_⟧ : [ carrier ] -> RegExp -> Set where
  matches-ε   : [] ∈‿⟦ ε ⟧
  matches-•   : forall {x} -> x ∷ [] ∈‿⟦ • ⟧
  matches-sym : forall {x y} -> x ≈ y -> x ∷ [] ∈‿⟦ sym y ⟧
  matches-⋆   : forall {xs re}
              -> xs ∈‿⟦ ε ∣ re ⊙ re ⋆ ⟧ -> xs ∈‿⟦ re ⋆ ⟧
  matches-∣ˡ   : forall {xs re₁ re₂}
              -> xs ∈‿⟦ re₁ ⟧ -> xs ∈‿⟦ re₁ ∣ re₂ ⟧
  matches-∣ʳ   : forall {xs re₁ re₂}
              -> xs ∈‿⟦ re₂ ⟧ -> xs ∈‿⟦ re₁ ∣ re₂ ⟧
  matches-⊙   : forall {xs₁ xs₂ re₁ re₂}
              -> xs₁ ∈‿⟦ re₁ ⟧ -> xs₂ ∈‿⟦ re₂ ⟧
              -> xs₁ ++ xs₂ ∈‿⟦ re₁ ⊙ re₂ ⟧

------------------------------------------------------------------------
-- Is the regular expression bypassable?

bypassable : (re : RegExp) -> Maybe ([] ∈‿⟦ re ⟧)
bypassable ∅           = nothing
bypassable ε           = just matches-ε
bypassable •           = nothing
bypassable (sym _)     = nothing
bypassable (re ⋆)      = just (matches-⋆ (matches-∣ˡ matches-ε))
bypassable (re₁ ∣ re₂) with bypassable re₁ | bypassable re₂
bypassable (re₁ ∣ re₂) | just m  | _       = just (matches-∣ˡ m)
bypassable (re₁ ∣ re₂) | nothing | just m  = just (matches-∣ʳ m)
bypassable (re₁ ∣ re₂) | nothing | nothing = nothing
bypassable (re₁ ⊙ re₂) with bypassable re₁ | bypassable re₂
bypassable (re₁ ⊙ re₂) | just m₁ | just m₂ = just (matches-⊙ m₁ m₂)
bypassable (re₁ ⊙ re₂) | _       | _       = nothing


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

open import Relation.Binary.Core

module Quasigroup.Definitions
  {a ℓ} {A : Set a}   -- The underlying set
  (_≈_ : Rel A ℓ)     -- The underlying equality
  where

open import Algebra.Core
open import Data.Product

LatinSquareProperty₁ : Op₂ A → Set _
LatinSquareProperty₁ _*_ = ∀ a b x  → (a * x) ≈ b

LatinSquareProperty₂ : Op₂ A → Set _
LatinSquareProperty₂ _*_ = ∀ a b y → (y * a) ≈ b

LatinSquareProperty : Op₂ A → Set _
LatinSquareProperty _*_ = (LatinSquareProperty₁ _*_) × (LatinSquareProperty₂ _*_)


module Lib.Prelude where

infixr 90 _∘_
infixr 1 _,_

id : {A : Set} -> A -> A
id x = x

_∘_ : {A : Set}{B : A -> Set}{C : {x : A} -> B x -> Set}
      (f : {x : A}(y : B x) -> C y)(g : (x : A) -> B x)(x : A) ->
      C (g x)
(f ∘ g) x = f (g x)

data Unit : Set where
  unit : Unit

{-# COMPILED_DATA Unit () () #-}

postulate String : Set

{-# BUILTIN STRING String #-}

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

{-# COMPILED_DATA _×_ (,) (,) #-}

fst : {A B : Set} -> A × B -> A
fst (x , y) = x

snd : {A B : Set} -> A × B -> B
snd (x , y) = y


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

open import Level

open import Categories.Category
open import Categories.Category.Instance.One
open import Categories.Category.Product
open import Categories.Functor renaming (id to idF)
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper)
import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e : Level
    C D : Category o ℓ e

const : (d : Category.Obj D) → Functor C D
const {D = D} d = record
  { F₀           = λ _ → d
  ; F₁           = λ _ → id
  ; identity     = refl
  ; homomorphism = sym identity²
  ; F-resp-≈     = λ _ → refl
  }
  where open Category D
        open Equiv

const! : (d : Category.Obj D) → Functor (One {0ℓ} {0ℓ} {0ℓ}) D
const! = const

constˡ : (c : Category.Obj C) → Functor D (Product C D)
constˡ c = const c ※ idF

constʳ : (c : Category.Obj C) → Functor D (Product D C)
constʳ c = idF ※ (const c)

constNat : ∀ {A B} → Category._⇒_ D A B → NaturalTransformation (const {D = D} {C = C} A) (const B)
constNat {D = D} f = ntHelper record
  { η       = λ _ → f
  ; commute = λ _ → MR.id-comm D
  }


open import Agda.Builtin.Nat

variable {n} : Nat

data Vec (A : Set) : Nat → Set where
  []  : Vec A 0
  _∷_ : A → Vec A n → Vec A (suc n)

cons : ∀ {m A} → A → Vec A m → Vec A (suc m)
cons = _∷_

module _ (A : Set) where
  data Vec' : Nat → Set where
    []  : Vec' 0
    _∷_ : A → Vec' n → Vec' (suc n)

cons' : ∀ {m A} → A → Vec' A m → Vec' A (suc m)
cons' = _∷_