module Algebra.Dioid.Bool.Theorems where

open import Algebra.Dioid
open import Algebra.Dioid.Bool

or-left-congruence : ∀ {b c d : Bool} -> b ≡ c -> (b or d) ≡ (c or d)
or-left-congruence {b} {.b} {d} reflexivity = reflexivity
or-left-congruence {b} {c} {d} (symmetry eq) = symmetry (or-left-congruence eq)
or-left-congruence {b} {c} {d} (transitivity eq eq₁) = transitivity (or-left-congruence eq) (or-left-congruence eq₁)

or-right-congruence : ∀ {b c d : Bool} -> c ≡ d -> (b or c) ≡ (b or d)
or-right-congruence {b} {c} {.c} reflexivity = reflexivity
or-right-congruence {b} {c} {d} (symmetry eq) = symmetry (or-right-congruence eq)
or-right-congruence {b} {c} {d} (transitivity eq eq₁) = transitivity (or-right-congruence eq) (or-right-congruence eq₁)

and-left-congruence : ∀ {b c d : Bool} -> b ≡ c -> (b and d) ≡ (c and d)
and-left-congruence {b} {.b} {d} reflexivity = reflexivity
and-left-congruence {b} {c} {d} (symmetry eq) = symmetry (and-left-congruence eq)
and-left-congruence {b} {c} {d} (transitivity eq eq₁) = transitivity (and-left-congruence eq) (and-left-congruence eq₁)

and-right-congruence : ∀ {b c d : Bool} -> c ≡ d -> (b and c) ≡ (b and d)
and-right-congruence {b} {c} {.c} reflexivity = reflexivity
and-right-congruence {b} {c} {d} (symmetry eq) = symmetry (and-right-congruence eq)
and-right-congruence {b} {c} {d} (transitivity eq eq₁) = transitivity (and-right-congruence eq) (and-right-congruence eq₁)

or-idempotence : ∀ {b : Bool} -> (b or b) ≡ b
or-idempotence {true} = reflexivity
or-idempotence {false} = reflexivity

or-commutativity : ∀ {b c : Bool} -> (b or c) ≡ (c or b)
or-commutativity {true} {true} = reflexivity
or-commutativity {true} {false} = reflexivity
or-commutativity {false} {true} = reflexivity
or-commutativity {false} {false} = reflexivity

or-associativity : ∀ {b c d : Bool} -> (b or (c or d)) ≡ ((b or c) or d)
or-associativity {true} {c} {d} = reflexivity
or-associativity {false} {true} {d} = reflexivity
or-associativity {false} {false} {true} = reflexivity
or-associativity {false} {false} {false} = reflexivity

or-false-identity : ∀ {b : Bool} -> (b or false) ≡ b
or-false-identity {true} = reflexivity
or-false-identity {false} = reflexivity

and-associativity : ∀ {b c d : Bool} -> (b and (c and d)) ≡ ((b and c) and d)
and-associativity {true} {true} {true} = reflexivity
and-associativity {true} {true} {false} = reflexivity
and-associativity {true} {false} {d} = reflexivity
and-associativity {false} {c} {d} = reflexivity

and-left-false : ∀ {b : Bool} -> (false and b) ≡ false
and-left-false {b} = reflexivity

and-right-false : ∀ {b : Bool} -> (b and false) ≡ false
and-right-false {true} = reflexivity
and-right-false {false} = reflexivity

and-left-true : ∀ {b : Bool} -> (true and b) ≡ b
and-left-true {true} = reflexivity
and-left-true {false} = reflexivity

and-right-true : ∀ {b : Bool} -> (b and true) ≡ b
and-right-true {true} = reflexivity
and-right-true {false} = reflexivity

left-distributivity : ∀ {b c d : Bool} -> (b and (c or d)) ≡ ((b and c) or (b and d))
left-distributivity {true} {true} {d} = reflexivity
left-distributivity {true} {false} {true} = reflexivity
left-distributivity {true} {false} {false} = reflexivity
left-distributivity {false} {c} {d} = reflexivity

right-distributivity : ∀ {b c d : Bool} -> ((b or c) and d) ≡ ((b and d) or (c and d))
right-distributivity {true} {true} {true} = reflexivity
right-distributivity {true} {true} {false} = reflexivity
right-distributivity {true} {false} {true} = reflexivity
right-distributivity {true} {false} {false} = reflexivity
right-distributivity {false} {true} {true} = reflexivity
right-distributivity {false} {true} {false} = reflexivity
right-distributivity {false} {false} {d} = reflexivity

bool-dioid : Dioid Bool _≡_
bool-dioid = record
  { zero = false
  ; one  = true
  ; _+_  = _or_
  ; _*_  = _and_
  ; reflexivity  = reflexivity
  ; symmetry     = symmetry
  ; transitivity = transitivity

  ; +left-congruence  = or-left-congruence
  ; *left-congruence  = and-left-congruence
  ; *right-congruence = and-right-congruence

  ; +idempotence   = or-idempotence
  ; +commutativity = or-commutativity
  ; +associativity = or-associativity
  ; +zero-identity = or-false-identity

  ; *associativity  = and-associativity
  ; *left-zero      = λ {r} → reflexivity
  ; *right-zero     = and-right-false
  ; *left-identity  = and-left-true
  ; *right-identity = and-right-true

  ; left-distributivity  = left-distributivity
  ; right-distributivity = right-distributivity
  }


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

open import Categories.Category

-- this module characterizes a category of all equalizer indexed by I.
-- this notion formalizes a category with all equalizer up to certain cardinal.
module Categories.Diagram.Equalizer.Indexed {o ℓ e} (C : Category o ℓ e) where

open import Level

open Category C

record IndexedEqualizerOf {i} {I : Set i} {A B : Obj} (M : I → A ⇒ B) : Set (i ⊔ o ⊔ e ⊔ ℓ) where
  field
    E   : Obj
    arr : E ⇒ A

    -- a reference morphism
    ref : E ⇒ B
    equality  : ∀ i → M i ∘ arr ≈ ref
    equalize  : ∀ {X} (h : X ⇒ A) (r : X ⇒ B) → (∀ i → M i ∘ h ≈ r) → X ⇒ E
    universal : ∀ {X} (h : X ⇒ A) (r : X ⇒ B) (eq : ∀ i → M i ∘ h ≈ r) → h ≈ arr ∘ equalize h r eq
    unique    : ∀ {X} {l : X ⇒ E} (h : X ⇒ A) (r : X ⇒ B) (eq : ∀ i → M i ∘ h ≈ r) → h ≈ arr ∘ l → l ≈ equalize h r eq

record IndexedEqualizer {i} (I : Set i) : Set (i ⊔ o ⊔ e ⊔ ℓ) where
  field
    A B         : Obj
    M           : I → A ⇒ B
    equalizerOf : IndexedEqualizerOf M

  open IndexedEqualizerOf equalizerOf public

AllEqualizers : ∀ i → Set (o ⊔ ℓ ⊔ e ⊔ suc i)
AllEqualizers i = (I : Set i) → IndexedEqualizer I

AllEqualizersOf : ∀ i → Set (o ⊔ ℓ ⊔ e ⊔ suc i)
AllEqualizersOf i = ∀ {I : Set i} {A B : Obj} (M : I → A ⇒ B) → IndexedEqualizerOf M


{-# OPTIONS --without-K #-}
module sets.nat.properties where

open import equality.core
open import equality.calculus
open import equality.reasoning
open import function.isomorphism.core
open import sets.nat.core
open import sets.empty

+-left-unit : ∀ n → 0 + n ≡ n
+-left-unit n = refl

+-right-unit : ∀ n → n + 0 ≡ n
+-right-unit zero = refl
+-right-unit (suc n) = ap suc (+-right-unit n)

+-associativity : ∀ n m p → n + m + p ≡ n + (m + p)
+-associativity 0 m p = refl
+-associativity (suc n) m p = ap suc (+-associativity n m p)

+-left-cancel : ∀ n → injective (_+_ n)
+-left-cancel 0 p = p
+-left-cancel (suc n) p = +-left-cancel n (ap pred p)

right-distr : ∀ n m p → (n + m) * p ≡ n * p + m * p
right-distr 0 m p = refl
right-distr (suc n) m p = begin
    p + (n + m) * p
  ≡⟨ ap (_+_ p) (right-distr n m p) ⟩
    p + (n * p + m * p)
  ≡⟨ sym (+-associativity p (n * p) (m * p)) ⟩
    p + n * p + m * p
  ∎
  where open ≡-Reasoning

*-left-unit : ∀ n → 1 * n ≡ n
*-left-unit n = +-right-unit n

*-right-unit : ∀ n → n * 1 ≡ n
*-right-unit zero = refl
*-right-unit (suc n) = ap suc (*-right-unit n)

*-associativity : ∀ n m p → n * m * p ≡ n * (m * p)
*-associativity 0 m p = refl
*-associativity (suc n) m p =
    right-distr m (n * m) p
  · ap (λ z → (m * p) + z)
         (*-associativity n m p)

+-commutativity : ∀ n m → n + m ≡ m + n
+-commutativity 0 m = sym (+-right-unit m)
+-commutativity (suc n) m = begin
    suc (n + m)
  ≡⟨ ap suc (+-commutativity n m) ⟩
    suc (m + n)
  ≡⟨ lem m n ⟩
    m + suc n
  ∎
  where
    open ≡-Reasoning
    lem : ∀ n m → suc n + m ≡ n + suc m
    lem 0 m = refl
    lem (suc n) m = ap suc (lem n m)

left-distr : ∀ n m p → n * (m + p) ≡ n * m + n * p
left-distr 0 m p = refl
left-distr (suc n) m p = begin
    m + p + n * (m + p)
  ≡⟨ +-associativity m p _ ⟩
    m + (p + n * (m + p))
  ≡⟨ ap (λ z → m + (p + z))
          (left-distr n m p) ⟩
    m + (p + (n * m + n * p))
  ≡⟨ ap (_+_ m)
          (sym (+-associativity p (n * m) _)) ⟩
    m + (p + n * m + n * p)
  ≡⟨ ap (λ z → m + (z + n * p))
          (+-commutativity p (n * m)) ⟩
    m + (n * m + p + n * p)
  ≡⟨ ap (_+_ m) (+-associativity (n * m) p _) ⟩
    m + (n * m + (p + n * p))
  ≡⟨ sym (+-associativity m (n * m) _) ⟩
    m + n * m + (p + n * p)
  ∎
  where open ≡-Reasoning

left-zero : ∀ n → 0 * n ≡ 0
left-zero n = refl

right-zero : ∀ n → n * 0 ≡ 0
right-zero 0 = refl
right-zero (suc n) = right-zero n

*-commutativity : ∀ n m → n * m ≡ m * n
*-commutativity 0 m = sym (right-zero m)
*-commutativity (suc n) m = begin
    m + n * m
  ≡⟨ ap₂ _+_ (sym (*-right-unit m))
               (*-commutativity n m) ⟩
    m * 1 + m * n
  ≡⟨ sym (left-distr m 1 n) ⟩
    m * suc n
  ∎
  where open ≡-Reasoning

suc-fixpoint : ∀ {n} → ¬ (suc n ≡ n)
suc-fixpoint {zero} ()
suc-fixpoint {suc n} p = suc-fixpoint (suc-inj p)


module PLRTree.Complete {A : Set} where

open import PLRTree {A}
open import PLRTree.Equality {A}

data _⋗_ :  PLRTree → PLRTree → Set where
  ⋗lf : (x : A)
                   → node perfect x leaf leaf ⋗ leaf
  ⋗nd : {l r l' r' : PLRTree}
                   (x x' : A)
                   → l ≃ r
                   → l' ≃ r'
                   → l ⋗ l'
                   → node perfect x l r ⋗ node perfect x' l' r'

mutual
  data _⋘_ : PLRTree → PLRTree → Set where
    x⋘ : (x y z : A)
                  → node right x (node perfect y leaf leaf) leaf ⋘ node perfect z leaf leaf
    l⋘ : {l r l' r' : PLRTree}
                  → (x x' : A)
                  → l ⋘ r
                  → l' ≃ r'
                  → r ≃ l'
                  → (node left x l r) ⋘ (node perfect x' l' r')
    r⋘ : {l r l' r' : PLRTree}
                  → (x x' : A)
                  → l ⋙ r
                  → l' ≃ r'
                  → l ⋗ l'
                  → (node right x l r) ⋘ (node perfect x' l' r')

  data _⋙_ : PLRTree → PLRTree → Set where
    ⋙p : {l r : PLRTree}
                  → l ⋗ r
                  → l ⋙ r
    ⋙l : {l r l' r' : PLRTree}
                  → (x x' : A)
                  → l ≃ r
                  → l' ⋘ r'
                  → l ⋗ r'
                  → (node perfect x l r) ⋙ (node left x' l' r')
    ⋙r : {l r l' r' : PLRTree}
                  → (x x' : A)
                  → l ≃ r
                  → l' ⋙ r'
                  → l ≃ l'
                  → (node perfect x l r) ⋙ (node right x' l' r')

data Complete : PLRTree → Set where
  leaf : Complete leaf
  perfect : {l r : PLRTree}
                   (x : A)
                   → Complete l
                   → Complete r
                   → l ≃ r
                   → Complete (node perfect x l r)
  left : {l r : PLRTree}
                   (x : A)
                   → Complete l
                   → Complete r
                   → l ⋘ r
                   → Complete (node left x l r)
  right : {l r : PLRTree}
                   (x : A)
                   → Complete l
                   → Complete r
                   → l ⋙ r
                   → Complete (node right x l r)


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

open import Groups.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations

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

-- Following Part IB's course Groups, Rings, and Modules, we take rings to be commutative with one.
module Rings.Definition where

record Ring {n m} {A : Set n} (S : Setoid {n} {m} A) (_+_ : A → A → A) (_*_ : A → A → A) : Set (lsuc n ⊔ m) where
  field
    additiveGroup : Group S _+_
  open Group additiveGroup
  open Setoid S
  open Equivalence eq
  0R : A
  0R = 0G
  _-R_ : A → A → A
  a -R b = a + (inverse b)
  field
    *WellDefined : {r s t u : A} → (r ∼ t) → (s ∼ u) → r * s ∼ t * u
    1R : A
    groupIsAbelian : {a b : A} → a + b ∼ b + a
    *Associative : {a b c : A} → (a * (b * c)) ∼ (a * b) * c
    *Commutative : {a b : A} → a * b ∼ b * a
    *DistributesOver+ : {a b c : A} → a * (b + c) ∼ (a * b) + (a * c)
    identIsIdent : {a : A} → 1R * a ∼ a
  timesZero : {a : A} → a * 0R ∼ 0R
  timesZero {a} = symmetric (transitive (transitive (symmetric invLeft) (+WellDefined reflexive (transitive (*WellDefined {a} {a} reflexive (symmetric identRight)) *DistributesOver+))) (transitive +Associative (transitive (+WellDefined invLeft reflexive) identLeft)))
  timesZero' : {a : A} → 0R * a ∼ 0R
  timesZero' {a} = transitive *Commutative timesZero
  *DistributesOver+' : {a b c : A} → (a + b) * c ∼ (a * c) + (b * c)
  *DistributesOver+' = transitive *Commutative (transitive *DistributesOver+ (+WellDefined *Commutative *Commutative))
  *Associative' : {a b c : A} → ((a * b) * c) ∼ (a * (b * c))
  *Associative' = symmetric *Associative
  identIsIdent' : {a : A} → a * 1R ∼ a
  identIsIdent' = transitive *Commutative identIsIdent


module Formalization.Monoid where

import      Lvl
open import Numeral.Finite using (𝕟)
open import Numeral.Natural using (ℕ)
open import Type
open import Type.Dependent
open import Syntax.Function

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

module Semigroup where
  -- A term in the language of a semigroup.
  -- It consists of a finite number of variables and a binary operator on its elements.
  data Term (n : ℕ) : Type{Lvl.𝟎} where
    var : 𝕟(n) → Term(n)
    _▫_ : Term(n) → Term(n) → Term(n)

module Monoid where
  open import Data.List
  open import Data.List.Functions

  -- A term in the language of a monoid.
  -- It consists of a finite number of variables, an identity element, and a binary operator on its elements.
  data Term (n : ℕ) : Type{Lvl.𝟎} where
    var : 𝕟(n) → Term(n)
    _▫_ : Term(n) → Term(n) → Term(n)
    id : Term(n)

  -- A fully normalised term in the language of a monoid is always able to be represented as a list of variables.
  -- See `normalize` for how a term is represented as a list.
  NormalForm : ℕ → Type
  NormalForm(n) = List(𝕟(n))

  -- Normalizes a term to its normal form.
  normalize : Term(n) → NormalForm(n)
  normalize (var v) = singleton v
  normalize (x ▫ y) = normalize x ++ normalize y
  normalize id      = ∅

  open import Structure.Function
  open import Structure.Function.Multi
  open import Structure.Operator
  open import Structure.Operator.Monoid
  open import Structure.Operator.Properties
  open import Structure.Relator.Properties
  open import Structure.Setoid
  open import Syntax.Transitivity

  module Semantics ⦃ equiv : Equiv{ℓₑ}(T) ⦄ (_∙_ : T → T → T) ⦃ monoid : Monoid(_∙_) ⦄ where
    open Structure.Operator.Monoid.Monoid(monoid) using () renaming (id to 𝑒)

    -- The environment for evaluating an expression is just a mapping from its variables to the values.
    Env : ℕ → Type
    Env(n) = (𝕟(n) → T)

    -- The semantics of the terms.
    eval : Env(n) → Term(n) → T
    eval env (var n) = env n
    eval env (x ▫ y) = eval env x ∙ eval env y
    eval env id      = 𝑒

    -- The semantics of the normal form.
    evalNormal : Env(n) → NormalForm(n) → T
    evalNormal env ∅       = 𝑒
    evalNormal env (v ⊰ l) = env v ∙ evalNormal env l

    module Proofs where
      private variable env : Env(n)
      private variable e : Term(n)

      instance
        eval-preserves : Preserving₂(eval env)(_▫_)(_∙_)
        eval-preserves = intro(reflexivity(_≡_))

      instance
        evalNormal-preserves : Preserving₂(evalNormal env)(_++_)(_∙_)
        evalNormal-preserves {env = env} = intro(\{x y} → proof{x}{y}) where
          proof : Names.Preserving₂(evalNormal env)(_++_)(_∙_)
          proof {∅}      {ys} = symmetry(_≡_) (identityₗ(_∙_)(𝑒))
          proof {x ⊰ xs} {ys} =
            evalNormal env ((x ⊰ xs) ++ ys)                 🝖[ _≡_ ]-[]
            evalNormal env (x ⊰ (xs ++ ys))                 🝖[ _≡_ ]-[]
            env x ∙ evalNormal env (xs ++ ys)               🝖[ _≡_ ]-[ congruence₂ᵣ(_∙_)(_) (proof {xs}{ys}) ]
            env x ∙ (evalNormal env xs ∙ evalNormal env ys) 🝖[ _≡_ ]-[ associativity(_∙_) ]-sym
            (env x ∙ evalNormal env xs) ∙ evalNormal env ys 🝖[ _≡_ ]-[]
            evalNormal env (x ⊰ xs) ∙ evalNormal env ys     🝖-end

      normalize-eval-correctness : (evalNormal env (normalize e) ≡ eval env e)
      normalize-eval-correctness {env = env} {var v} = identityᵣ(_∙_)(𝑒)
      normalize-eval-correctness {env = env} {x ▫ y} =
        evalNormal env (normalize (x ▫ y))                          🝖[ _≡_ ]-[]
        evalNormal env (normalize x ++ normalize y)                 🝖[ _≡_ ]-[ preserving₂(evalNormal env)(_++_)(_∙_) {normalize x}{normalize y} ]
        evalNormal env (normalize x) ∙ evalNormal env (normalize y) 🝖[ _≡_ ]-[ congruence₂(_∙_) (normalize-eval-correctness{env = env}{x}) (normalize-eval-correctness{env = env}{y}) ]
        eval env x ∙ eval env y                                     🝖[ _≡_ ]-[]
        eval env (x ▫ y)                                            🝖-end
      normalize-eval-correctness {env = env} {id}    = reflexivity(_≡_)

module CommutativeMonoid where

module CommutativeRig where
  open import Data.ListSized
  open import Formalization.Polynomial as Polynomial using (Polynomial)

  -- A term in the language of a commutative rig.
  -- It consists of a finite number of variables and a binary operator on its elements.
  data Term (n : ℕ) : Type{Lvl.𝟎} where
    var : 𝕟(n) → Term(n)
    _➕_ : Term(n) → Term(n) → Term(n)
    _✖_ : Term(n) → Term(n) → Term(n)
    𝟎 : Term(n)
    𝟏 : Term(n)

  NormalForm : ℕ → Type
  NormalForm = Polynomial

  {-
  normalize : Term(n) → NormalForm(n)
  normalize (var x) = {!!}
  normalize (t ➕ t₁) = {!!}
  normalize (t ✖ t₁) = {!!}
  normalize 𝟎 = {!!}
  normalize 𝟏 = {!!}
  -}


module Ordinals where

import Level
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Nat using (ℕ) renaming (zero to z; suc to s)
open import Data.Empty

postulate
  ext₀ : Extensionality Level.zero Level.zero
  ext₁ : Extensionality Level.zero (Level.suc Level.zero)

data Ord : Set₁ where
  zero : Ord
  succ : Ord → Ord
  sup  : (A : Set) → (f : A → Ord) → Ord

infixl 10 _≤_

module CountableOrdinals where
  inj-ℕ-Ord : ℕ → Ord
  inj-ℕ-Ord z     = zero
  inj-ℕ-Ord (s n) = succ (inj-ℕ-Ord n)

  ω : Ord
  ω = sup ℕ inj-ℕ-Ord

  _∔_ : Ord → ℕ → Ord
  α ∔ z     = α
  α ∔ (s n) = succ (α ∔ n)

  _ẋ_ : Ord → ℕ → Ord
  α ẋ z     = zero
  α ẋ (s n) = sup ℕ (λ k → (α ẋ n) ∔ k)

  _^^_ : Ord → ℕ → Ord
  α ^^ z     = succ zero
  α ^^ (s n) = sup ℕ (λ k → (α ^^ n) ẋ k)

  ω+ : ℕ → Ord
  ω+ n = ω ∔ n

  ω× : ℕ → Ord
  ω× n = ω ẋ n

  ω^ : ℕ → Ord
  ω^ n = ω ^^ n

  ω+1≢ω : sup ℕ (succ ∘ inj-ℕ-Ord) ≡ ω → ⊥
  ω+1≢ω p = {!!}

-- This should not be provable!
-- succ-sup : ∀ A f → sup A (succ ∘ f) ≡ succ (sup A f)
-- succ-sup A f = {!!}

_+_ : Ord → Ord → Ord
α + zero    = α
α + succ β  = succ (α + β)
α + sup A f = sup A (λ x → α + f x)

zeroₗ : ∀ α → zero + α ≡ α
zeroₗ zero      = refl
zeroₗ (succ α)  = cong succ (zeroₗ α)
zeroₗ (sup A f) = cong (sup A) (ext₁ (λ x → zeroₗ (f x)))

succₗ : ∀ α β → succ α + β ≡ succ (α + β)
succₗ α zero = refl
succₗ α (succ β) = cong succ (succₗ α β)
succₗ α (sup A f) = {!!}
-- trans (cong (sup A) (ext₁ (λ x → succₗ α (f x))))
                    --       (succ-sup A (λ x → α + f x))

_≤_ : Ord → Ord → Set₁
α ≤ β = ∃ λ γ → α + γ ≡ β

≤-refl : ∀ α → α ≤ α
≤-refl α = (zero , refl)

zero-min : ∀ α → zero ≤ α
zero-min α = (α , zeroₗ α)

≤-succ : ∀ α β → α ≤ β → succ α ≤ succ β
≤-succ α β (γ , p) = (γ , trans (succₗ α γ) (cong succ p))

≤-step : ∀ α β → α ≤ β → α ≤ succ β
≤-step α β (γ , p) = (succ γ , cong succ p)

≤-sup-step : ∀ α A f → (∀ x → α ≤ f x) → α ≤ sup A f
≤-sup-step α A f p = (sup A (proj₁ ∘ p) , cong (sup A) (ext₁ (proj₂ ∘ p)))

≤-supₗ : ∀ A f β → (∀ x → f x ≤ β) → sup A f ≤ β
≤-supₗ A f β p = (sup A (proj₁ ∘ p) , {!!})
  where
    q : (x : A) → (f x + proj₁ (p x)) ≡ β
    q = proj₂ ∘ p

≤-sup : ∀ A f g → (∀ x → f x ≤ g x) → sup A f ≤ sup A g
≤-sup A f g p = (sup A (proj₁ ∘ p) , {!!}) -- cong (sup A) (ext₁ {!!}))
  where
    q : (x : A) → (f x + proj₁ (p x)) ≡ g x
    q = proj₂ ∘ p

    q' : (x : A) → (sup A f + (proj₁ ∘ p) x) ≡ g x
    q' = {!!}

lem₁ : ∀ α β → α ≤ α + β
lem₁ α zero      = ≤-refl α
lem₁ α (succ β)  = ≤-step α (α + β) (lem₁ α β)
lem₁ α (sup A f) = ≤-sup-step α A (λ x → α + f x) (λ x → lem₁ α (f x))

lem₂ : ∀ α β → β ≤ α + β
lem₂ α zero = zero-min (α + zero)
lem₂ α (succ β) = ≤-succ β (α + β) (lem₂ α β)
lem₂ α (sup A f) = ≤-sup A f (λ x → α + f x) (λ x → lem₂ α (f x))


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

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

open import Functions.Definition

module Sets.EquivalenceRelations where

Reflexive : {a b : _} {A : Set a} (r : Rel {a} {b} A) → Set (a ⊔ b)
Reflexive {A = A} r = {x : A} → r x x

Symmetric : {a b : _} {A : Set a} (r : Rel {a} {b} A) → Set (a ⊔ b)
Symmetric {A = A} r = {x y : A} → r x y → r y x

Transitive : {a b : _} {A : Set a} (r : Rel {a} {b} A) → Set (a ⊔ b)
Transitive {A = A} r = {x y z : A} → r x y → r y z → r x z

record Equivalence {a b : _} {A : Set a} (r : Rel {a} {b} A) : Set (a ⊔ lsuc b) where
  field
    reflexive : Reflexive r
    symmetric : Symmetric r
    transitive : Transitive r
    -- See https://lists.chalmers.se/pipermail/agda/2016/009090.html
  transitive' : {x y z : A} → r y z → r x y → r x z
  transitive' p2 p1 = transitive p1 p2


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

open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import LogicalFormulae
open import Orders.Total.Definition
open import Orders.Partial.Definition
open import Setoids.Setoids
open import Functions.Definition
open import Sequences
open import Setoids.Orders.Partial.Definition

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

module Setoids.Orders.Partial.Sequences {a b c : _} {A : Set a} {S : Setoid {a} {b} A} {_<_ : Rel {a} {c} A} (p : SetoidPartialOrder S _<_) where

open SetoidPartialOrder p

WeaklyIncreasing' : (Sequence A) → Set (b ⊔ c)
WeaklyIncreasing' s = (m n : ℕ) → (m <N n) → (index s m) <= (index s n)

WeaklyIncreasing : (Sequence A) → Set (b ⊔ c)
WeaklyIncreasing s = (m : ℕ) → (index s m) <= index s (succ m)

tailRespectsWeaklyIncreasing : (a : Sequence A) → WeaklyIncreasing a → WeaklyIncreasing (Sequence.tail a)
tailRespectsWeaklyIncreasing a incr m = incr (succ m)

weaklyIncreasingImplies' : (a : Sequence A) → WeaklyIncreasing a → WeaklyIncreasing' a
weaklyIncreasingImplies' a x zero (succ zero) m<n = x 0
weaklyIncreasingImplies' a x zero (succ (succ n)) m<n = <=Transitive (weaklyIncreasingImplies' a x zero (succ n) (succIsPositive n)) (x (succ n))
weaklyIncreasingImplies' a x (succ m) (succ n) m<n = weaklyIncreasingImplies' (Sequence.tail a) (tailRespectsWeaklyIncreasing a x) m n (canRemoveSuccFrom<N m<n)

weaklyIncreasing'Implies : (a : Sequence A) → WeaklyIncreasing' a → WeaklyIncreasing a
weaklyIncreasing'Implies a incr m = incr m (succ m) (le 0 refl)

StrictlyIncreasing' : (Sequence A) → Set (c)
StrictlyIncreasing' s = (m n : ℕ) → (m <N n) → (index s m) < (index s n)

StrictlyIncreasing : (Sequence A) → Set (c)
StrictlyIncreasing s = (m : ℕ) → (index s m) < index s (succ m)

tailRespectsStrictlyIncreasing : (a : Sequence A) → StrictlyIncreasing a → StrictlyIncreasing (Sequence.tail a)
tailRespectsStrictlyIncreasing a incr m = incr (succ m)

strictlyIncreasingImplies' : (a : Sequence A) → StrictlyIncreasing a → StrictlyIncreasing' a
strictlyIncreasingImplies' a x zero (succ zero) m<n = x 0
strictlyIncreasingImplies' a x zero (succ (succ n)) m<n = <Transitive (strictlyIncreasingImplies' a x zero (succ n) (succIsPositive n)) (x (succ n))
strictlyIncreasingImplies' a x (succ m) (succ n) m<n = strictlyIncreasingImplies' (Sequence.tail a) (tailRespectsStrictlyIncreasing a x) m n (canRemoveSuccFrom<N m<n)

strictlyIncreasing'Implies : (a : Sequence A) → StrictlyIncreasing' a → StrictlyIncreasing a
strictlyIncreasing'Implies a incr m = incr m (succ m) (le 0 refl)


module ImplArg2 where

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

data Vec (A : Set) : Nat -> Set where
  vnil  : Vec A zero
  vcons : {n : Nat} -> A -> Vec A n -> Vec A (suc n)

cons : {A : Set} (a : A) {n : Nat} -> Vec A n -> Vec A (suc n)
cons a = vcons a


------------------------------------------------------------------------
-- Integer division
------------------------------------------------------------------------

module Data.Nat.DivMod where

open import Data.Nat
open import Data.Nat.Properties
open SemiringSolver
open import Data.Fin as Fin using (Fin; zero; suc; toℕ; fromℕ)
import Data.Fin.Props as Fin
open import Induction.Nat
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning
open import Data.Function

------------------------------------------------------------------------
-- Some boring lemmas

private

  lem₁ : ∀ m k → _
  lem₁ m k = cong suc $ begin
    m
      ≡⟨ Fin.inject+-lemma m k ⟩
    toℕ (Fin.inject+ k (fromℕ m))
      ≡⟨ solve 1 (λ x → x := x :+ con 0) refl _ ⟩
    toℕ (Fin.inject+ k (fromℕ m)) + 0
      ∎

  lem₂ : ∀ n → _
  lem₂ = solve 1 (λ n → con 1 :+ n  :=  con 1 :+ (n :+ con 0)) refl

  lem₃ : ∀ n k q r eq → _
  lem₃ n k q r eq = begin
      suc n + k
        ≡⟨ solve 2 (λ n k → con 1 :+ n :+ k  :=  n :+ (con 1 :+ k))
                   refl n k ⟩
      n + suc k
        ≡⟨ cong (_+_ n) eq ⟩
      n + (toℕ r + q * n)
        ≡⟨ solve 3 (λ n r q → n :+ (r :+ q :* n)  :=
                              r :+ (con 1 :+ q) :* n)
                   refl n (toℕ r) q ⟩
      toℕ r + suc q * n
        ∎

------------------------------------------------------------------------
-- Division

-- A specification of integer division.

data DivMod : ℕ → ℕ → Set where
  result : {divisor : ℕ} (q : ℕ) (r : Fin divisor) →
           DivMod (toℕ r + q * divisor) divisor

-- Sometimes the following type is more usable; functions in indices
-- can be inconvenient.

data DivMod' (dividend divisor : ℕ) : Set where
  result : (q : ℕ) (r : Fin divisor)
           (eq : dividend ≡ toℕ r + q * divisor) →
           DivMod' dividend divisor

-- Integer division with remainder.

-- Note that Induction.Nat.<-rec is used to ensure termination of
-- division. The run-time complexity of this implementation of integer
-- division should be linear in the size of the dividend, assuming
-- that well-founded recursion and the equality type are optimised
-- properly (see "Inductive Families Need Not Store Their Indices"
-- (Brady, McBride, McKinna, TYPES 2003)).

_divMod'_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} →
            DivMod' dividend divisor
_divMod'_ m n {≢0} = <-rec Pred dm m n {≢0}
  where
  Pred : ℕ → Set
  Pred dividend = (divisor : ℕ) {≢0 : False (divisor ≟ 0)} →
                  DivMod' dividend divisor

  1+_ : ∀ {k n} → DivMod' (suc k) n → DivMod' (suc n + k) n
  1+_ {k} {n} (result q r eq) = result (1 + q) r (lem₃ n k q r eq)

  dm : (dividend : ℕ) → <-Rec Pred dividend → Pred dividend
  dm m       rec zero    {≢0 = ()}
  dm zero    rec (suc n)            = result 0 zero refl
  dm (suc m) rec (suc n)            with compare m n
  dm (suc m) rec (suc .(suc m + k)) | less .m k    = result 0 r  (lem₁ m k)
                                        where r = suc (Fin.inject+ k (fromℕ m))
  dm (suc m) rec (suc .m)           | equal .m     = result 1 zero (lem₂ m)
  dm (suc .(suc n + k)) rec (suc n) | greater .n k =
    1+ rec (suc k) le (suc n)
    where le = s≤′s (s≤′s (n≤′m+n n k))

-- A variant.

_divMod_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} →
           DivMod dividend divisor
_divMod_ m n {≢0} with _divMod'_ m n {≢0}
.(toℕ r + q * n) divMod n | result q r refl = result q r

-- Integer division.

_div_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} → ℕ
_div_ m n {≢0} with _divMod_ m n {≢0}
.(toℕ r + q * n) div n | result q r = q

-- The remainder after integer division.

_mod_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} → Fin divisor
_mod_ m n {≢0} with _divMod_ m n {≢0}
.(toℕ r + q * n) mod n | result q r = r


import Structure.Logic.Classical.NaturalDeduction

module Structure.Logic.Classical.SetTheory.Relation {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicLogic : _ ⦄ (_∈_ : Domain → Domain → Formula) where
open Structure.Logic.Classical.NaturalDeduction.ClassicalLogic {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} (classicLogic)

open import Syntax.Function
open import Structure.Logic.Classical.SetTheory.SetBoundedQuantification {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicLogic ⦄ (_∈_)

UnaryRelator : Set(_)
UnaryRelator = (Domain → Formula)

BinaryRelator : Set(_)
BinaryRelator = (Domain → Domain → Formula)

-- Containment
-- (a ∋ x) means that the set a contains the set x.
_∋_ : BinaryRelator
_∋_ a x = (x ∈ a)

-- Non-containment
_∌_ : BinaryRelator
_∌_ a x = ¬(x ∈ a)

-- Not element of
_∉_ : BinaryRelator
_∉_ x a = ¬(x ∈ a)

-- Subset of
_⊆_ : BinaryRelator
_⊆_ a b = ∀ₗ(x ↦ (x ∈ a) ⟶ (x ∈ b))

-- Superset of
_⊇_ : BinaryRelator
_⊇_ a b = ∀ₗ(x ↦ (x ∈ a) ⟵ (x ∈ b))

-- Equality of
_≡ₛ_ : BinaryRelator
_≡ₛ_ a b = ∀ₗ(x ↦ (x ∈ a) ⟷ (x ∈ b))

-- The statement that the set s is empty
Empty : UnaryRelator
Empty(s) = ∀ₗ(x ↦ ¬(x ∈ s))

-- The statement that the set s is non-empty
NonEmpty : UnaryRelator
NonEmpty(s) = ∃ₗ(x ↦ (x ∈ s))

-- The statement that the set s is a set that contains all sets
Universal : UnaryRelator
Universal(s) = ∀ₗ(x ↦ (x ∈ s))

-- The statement that the sets s₁ and s₂ are disjoint
Disjoint : BinaryRelator
Disjoint(s₁)(s₂) = ∀ₗ(x ↦ ¬((x ∈ s₁)∧(x ∈ s₂)))
-- ¬ ∃ₗ(x ↦ (x ∈ s₁)∧(x ∈ s₂))

-- The statement that the sets in ss are all pairwise disjoint
PairwiseDisjoint : UnaryRelator
PairwiseDisjoint(ss) = ∀ₛ(ss)(s₁ ↦ ∀ₛ(ss)(s₂ ↦ ∀ₗ(x ↦ (x ∈ s₁)∧(x ∈ s₂) ⟶ (s₁ ≡ s₂))))
-- ∀ₛ(ss)(s₁ ↦ ∀ₛ(ss)(s₂ ↦ (s₁ ≢ s₂) → Disjoint(s₁)(s₂)))

-- The statement that the relation predicate F can be interpreted as a partial function
PartialFunction : BinaryRelator → Domain → Formula
PartialFunction(F) (dom) = ∀ₛ(dom)(x ↦ Unique(y ↦ F(x)(y)))

-- The statement that the relation predicate F can be interpreted as a total function
TotalFunction : BinaryRelator → Domain → Formula
TotalFunction(F) (dom) = ∀ₛ(dom)(x ↦ ∃ₗ!(y ↦ F(x)(y)))

-- A binary relator modifier which makes the binary relator to a statement about all distinct pairs in a set.
-- Note: This is specifically for irreflexive binary relations.
Pairwise : BinaryRelator → UnaryRelator
Pairwise Related (S) = ∀ₛ(S)(a ↦ ∀ₛ(S)(b ↦ (a ≢ b) ⟶ Related(a)(b)))


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

-- It's possible to compute levels
module ComputedLevels where

open import Common.Level

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

N-ary-level : Level → Level → ℕ → Level
N-ary-level ℓ₁ ℓ₂ zero    = ℓ₂
N-ary-level ℓ₁ ℓ₂ (suc n) = ℓ₁ ⊔ N-ary-level ℓ₁ ℓ₂ n

N-ary : ∀ {ℓ₁ ℓ₂} (n : ℕ) → Set ℓ₁ → Set ℓ₂ → Set (N-ary-level ℓ₁ ℓ₂ n)
N-ary zero    A B = B
N-ary (suc n) A B = A → N-ary n A B


{-# OPTIONS --guardedness #-}

module Iterator where

import      Lvl
open import Data.Option as Option using (Option ; Some ; None)
open import Data.Tuple  as Tuple  using (_⨯_ ; _,_)
open import Type

private variable ℓ : Lvl.Level
private variable T A B : Type{ℓ}
private variable a x init : T
private variable f : A → B

-- A finite/infinite sequence.
record Iterator (T : Type{ℓ}) : Type{ℓ} where
  coinductive
  field
    next : Option(T ⨯ Iterator(T))

open Iterator

empty : Iterator(T)
next empty = None

singleton : T → Iterator(T)
next(singleton x) = Some(x , empty)

prepend : T → Iterator(T) -> Iterator(T)
next(prepend x i) = Some(x , i)

import Data.Option.Functions as Option

head : Iterator(T) → Option(T)
head i = Option.map Tuple.left (next(i))

tail : Iterator(T) → Option(Iterator(T))
tail i = Option.map Tuple.right (next(i))

open import Functional

tail₀ : Iterator(T) → Iterator(T)
tail₀ = (Option._or empty) ∘ tail

open import Numeral.Natural
open import Numeral.Natural.Induction

index : ℕ → Iterator(T) → Option(T)
index n      i with next(i)
index _      _ | None        = None
index 𝟎      _ | Some(x , r) = Some x
index (𝐒(k)) _ | Some(x , r) = index k r

repeat : T → Iterator(T)
next(repeat(x)) = Some(x , repeat(x))

map : (A → B) → (Iterator(A) → Iterator(B))
next(map f(i)) with next(i)
... | None        = None
... | Some(x , r) = Some(f(x) , map f(r))
-- Option.map (Tuple.map f (map f)) (next i)


module Bin-predicates where

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

-- 2進数の表現
data Bin : Set where
  ⟨⟩ : Bin
  _O : Bin → Bin
  _I : Bin → Bin

-- 2進数のインクリメント
inc : Bin → Bin
inc ⟨⟩    = ⟨⟩ I
inc (b O) = b I
inc (b I) = inc b O

-- 自然数から2進数への変換
to : ℕ → Bin
to zero    = ⟨⟩ O
to (suc n) = inc (to n)

-- 2進数から自然数への変換
from : Bin → ℕ
from ⟨⟩    = zero
from (b O) = 2 * (from b)
from (b I) = 2 * (from b) + 1

2*n≡n+n : ∀ (n : ℕ) → 2 * n ≡ n + n
2*n≡n+n n rewrite +-identityʳ n = refl

+-suc-suc : ∀ (m n : ℕ) → (suc m) + (suc n) ≡ suc (suc (m + n))
+-suc-suc m n rewrite +-suc (suc m) n | sym (+-assoc 1 m n) = refl

-- 変換の前後どちらでインクリメントしても結果は等しい
from∘inc≡suc∘from : ∀ (b : Bin) → from (inc b) ≡ suc (from b)
from∘inc≡suc∘from ⟨⟩ = refl
from∘inc≡suc∘from (b O) rewrite +-suc (from (b O)) zero | +-identityʳ (from (b O)) = refl
from∘inc≡suc∘from (b I) rewrite from∘inc≡suc∘from b | 2*n≡n+n (suc (from b)) | +-suc-suc (from b) (from b) | sym (2*n≡n+n (from b)) | +-comm 1 (2 * (from b)) = refl

data One : Bin → Set where
  ⟨⟩I : One (⟨⟩ I)
  _O : ∀ {b : Bin} → One b → One (b O)
  _I : ∀ {b : Bin} → One b → One (b I)

data Can : Bin → Set where
  ⟨⟩O : Can (⟨⟩ O)
  can : ∀ {b : Bin} → One b → Can b

-- Can b
-- ------------
-- Can (inc b)

inc-one : ∀ {b : Bin} → One b → One (inc b)
inc-one ⟨⟩I    = ⟨⟩I O
inc-one (ob O) = ob I
inc-one (ob I) = (inc-one ob) O

inc-can : ∀ {b : Bin} → Can b → Can (inc b)
inc-can ⟨⟩O          = can ⟨⟩I
inc-can (can ⟨⟩I)    = can (⟨⟩I O)
inc-can (can (ob O)) = can (ob I)
inc-can (can (ob I)) = can (inc-one (ob I))

-- ----------
-- Can (to n)

can-ℕ : ∀ (n : ℕ) → Can (to n)
can-ℕ zero    = ⟨⟩O
can-ℕ (suc n) = inc-can (can-ℕ n)

-- Can b
-- ---------------
-- to (from b) ≡ b

to∘from∘inc≡inc∘to∘from : ∀ (b : Bin) → to (from (inc b)) ≡ inc (to (from b))
to∘from∘inc≡inc∘to∘from ⟨⟩ =
  begin
    to (from (inc ⟨⟩))
  ≡⟨⟩
    to (from (⟨⟩ I))
  ≡⟨⟩
    to 1
  ≡⟨⟩
    ⟨⟩ I
  ≡⟨⟩
    inc ⟨⟩
  ≡⟨⟩
    inc (to zero)
  ≡⟨⟩
    inc (to (from ⟨⟩))
  ∎
to∘from∘inc≡inc∘to∘from (b O) =
  begin
    to (from (inc (b O)))
  ≡⟨⟩
    to (from (b I))
  ≡⟨⟩
    to (2 * (from b) + 1)
  ≡⟨⟩
    to (2 * (from b) + (suc zero))
  ≡⟨ cong to (+-suc (2 * (from b)) zero) ⟩
    to (suc (2 * (from b) + zero))
  ≡⟨ cong (λ 2*fromb → to (suc 2*fromb)) (+-identityʳ (2 * (from b))) ⟩
    to (suc (2 * (from b)))
  ≡⟨⟩
    inc (to (2 * (from b)))
  ≡⟨⟩
    inc (to (from (b O)))
  ∎
to∘from∘inc≡inc∘to∘from (b I) =
  begin
    to (from (inc (b I)))
  ≡⟨⟩
    to (from ((inc b) O))
  ≡⟨⟩
    to (2 * (from (inc b)))
  ≡⟨ cong (λ suc∘fromb → to (2 * suc∘fromb)) (from∘inc≡suc∘from b) ⟩
    to (2 * (suc (from b)))
  ≡⟨ cong to (2*n≡n+n (suc (from b))) ⟩
    to ((suc (from b)) + (suc (from b)))
  ≡⟨ cong to (+-suc-suc (from b) (from b)) ⟩
    to (suc (suc ((from b) + (from b))))
  ≡⟨ cong (λ 2*fromb → to (suc (suc 2*fromb))) (sym (2*n≡n+n (from b))) ⟩
    to (suc (suc (2 * (from b))))
  ≡⟨ cong (λ 2*fromb+1 → to (suc 2*fromb+1)) (+-comm 1 (2 * (from b))) ⟩
    to (suc (2 * (from b) + 1))
  ≡⟨⟩
    to (suc (from (b I)))
  ≡⟨⟩
    inc (to (from (b I)))
  ∎

to∘from : ∀ {b : Bin} → Can b → to (from b) ≡ b
to∘from ⟨⟩O =
  begin
    to (from (⟨⟩ O))
  ≡⟨⟩
    to (2 * from ⟨⟩)
  ≡⟨⟩
    to (2 * zero)
  ≡⟨⟩
    to zero
  ≡⟨⟩
    ⟨⟩ O
  ∎
to∘from (can ⟨⟩I) =
  begin
    to (from (⟨⟩ I))
  ≡⟨⟩
    to (2 * from ⟨⟩ + 1)
  ≡⟨⟩
    to (2 * zero + 1)
  ≡⟨⟩
    to 1
  ≡⟨⟩
    ⟨⟩ I
  ∎
to∘from {b O} (can (ob O)) = {!!} -- TODO
to∘from {b I} (can (ob I)) =
  begin
    to (from (b I))
  ≡⟨⟩
    to (from (inc (b O)))
  ≡⟨ to∘from∘inc≡inc∘to∘from (b O) ⟩
    inc (to (from (b O)))
  ≡⟨ cong inc (to∘from (can (ob O))) ⟩
    inc (b O)
  ≡⟨⟩
    b I
  ∎


module Quantifiers where

-- Imports

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Relation.Nullary using (¬_)
open import Data.Product using (_×_; proj₁; proj₂) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
-- open import plfa.part1.Isomorphism using (_≃_; extensionality)

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

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

-- Universals

-- 全称量化子の除去則
∀-elim : ∀ {A : Set} {B : A → Set}
  → (L : ∀ (x : A) → B x)
  → (M : A)
    ---------------------
  → B M
∀-elim L M = L M

-- Existentials

-- 依存和型 (dependent sum type)
data Σ (A : Set) (B : A → Set) : Set where
  ⟨_,_⟩ : (x : A) → B x → Σ A B

Σ-syntax = Σ
infix 2 Σ-syntax
syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

record Σ′ (A : Set) (B : A → Set) : Set where
  field
    proj₁′ : A
    proj₂′ : B proj₁′

-- 存在量化子 (existential quantifier)
∃ : ∀ {A : Set} (B : A → Set) → Set
∃ {A} B = Σ A B

∃-syntax = ∃
syntax ∃-syntax (λ x → B) = ∃[ x ] B

-- 存在量化子の除去則
∃-elim : ∀ {A : Set} {B : A → Set} {C : Set}
  → (∀ x → B x → C)
  → ∃[ x ] B x
    ---------------
  → C
∃-elim f ⟨ x , y ⟩ = f x y

∀∃-currying : ∀ {A : Set} {B : A → Set} {C : Set}
  → (∀ x → B x → C) ≃ (∃[ x ] B x → C)
∀∃-currying =
  record
    { to      = λ{ f → λ{ ⟨ x , y ⟩ → f x y }}
    ; from    = λ{ g → λ{ x → λ{ y → g ⟨ x , y ⟩ }}}
    ; from∘to = λ{ f → refl }
    ; to∘from = λ{ g → extensionality λ{ ⟨ x , y ⟩ → refl }}
    }

-- An existential example

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

data even where

  even-zero : even zero

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

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

even-∃ : ∀ {n : ℕ} → even n → ∃[ m ] (    m * 2 ≡ n)
odd-∃  : ∀ {n : ℕ} →  odd n → ∃[ m ] (1 + m * 2 ≡ n)

even-∃ even-zero                      = ⟨ zero , refl ⟩
even-∃ (even-suc o) with odd-∃ o
...                    | ⟨ m , refl ⟩ = ⟨ suc m , refl ⟩

odd-∃  (odd-suc e)  with even-∃ e
...                    | ⟨ m , refl ⟩ = ⟨ m , refl ⟩

∃-even : ∀ {n : ℕ} → ∃[ m ] (    m * 2 ≡ n) → even n
∃-odd  : ∀ {n : ℕ} → ∃[ m ] (1 + m * 2 ≡ n) →  odd n

∃-even ⟨  zero , refl ⟩ = even-zero
∃-even ⟨ suc m , refl ⟩ = even-suc (∃-odd ⟨ m , refl ⟩)

∃-odd  ⟨     m , refl ⟩ = odd-suc (∃-even ⟨ m , refl ⟩)

-- Existentials, Universals, and Negation

-- B(x)が成り立たないxが存在することと、任意のxについてB(x)が成り立たないことは同型
¬∃≃∀¬ : ∀ {A : Set} {B : A → Set}
  → (¬ ∃[ x ] B x) ≃ ∀ x → ¬ B x
¬∃≃∀¬ =
  record
    { to      = λ{ ¬∃xy x y → ¬∃xy ⟨ x , y ⟩ }
    ; from    = λ{ ∀¬xy ⟨ x , y ⟩ → ∀¬xy x y }
    ; from∘to = λ{ ¬∃xy → extensionality λ{ ⟨ x , y ⟩ → refl } }
    ; to∘from = λ{ ∀¬xy → refl }
    }


{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.Instances.DiffInt where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Int.MoreInts.DiffInt renaming ( _+_ to _+ℤ_ ; _-_ to _-ℤ_)

open import Cubical.Algebra.Group.Base

open import Cubical.HITs.SetQuotients

open GroupStr

ℤGroup : Group₀
fst ℤGroup = ℤ
1g (snd ℤGroup) = [ 0 , 0 ]
_·_ (snd ℤGroup) = _+ℤ_
inv (snd ℤGroup) = -ℤ_
isGroup (snd ℤGroup) = makeIsGroup
                       ℤ-isSet
                       +ℤ-assoc
                       (λ x → zero-identityʳ 0 x)
                       (λ x → zero-identityˡ 0 x)
                       -ℤ-invʳ
                       -ℤ-invˡ


module Lec3 where

open import CS410-Prelude

not : Two -> Two
not tt = ff
not ff = tt

data TwoTestable (b : Two) : (x : Two) -> Set where
  same : TwoTestable b b
  diff : TwoTestable b (not b)

twoTest : (b x : Two) -> TwoTestable b x
twoTest tt tt = same
twoTest tt ff = diff
twoTest ff tt = diff
twoTest ff ff = same

twoTest' : (b x : Two) -> TwoTestable b x
twoTest' = caseTwo (caseTwo same diff) (caseTwo diff same)

xor : Two -> Two -> Two
xor b x with twoTest b x
xor b .b       | same = ff
xor b .(not b) | diff = tt

xorHelp : (b x : Two) -> TwoTestable b x -> Two
xorHelp b .b       same = ff
xorHelp b .(not b) diff = tt

xor' : Two -> Two -> Two
xor' b x = xorHelp b x (twoTest b x)


module Numeric.Nat.Prime.FundamentalTheorem where

open import Prelude
open import Control.WellFounded
open import Container.List
open import Container.List.Permutation
open import Container.List.Properties
open import Numeric.Nat
open import Tactic.Nat

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

private
  primeProd=1-is-empty : ∀ ps → All Prime ps → productR ps ≡ 1 → ps ≡ []
  primeProd=1-is-empty [] _ _ = refl
  primeProd=1-is-empty (p ∷ ps) (prime p>1 _ ∷ _) pps=1 =
    let p=1 : p ≡ 1
        p=1 = mul=1-l p (productR ps) pps=1
    in case p=1 of λ where refl → refute p>1

  0<1<2 : ∀ {n} ⦃ _ : NonZero n ⦄ → n < 2 → n ≡ 1
  0<1<2 {0} ⦃ () ⦄ n<2
  0<1<2 {1} n<2 = refl
  0<1<2 {suc (suc _)} n<2 = refute n<2

  1>0 : ∀ {n} → n > 1 → NonZero n
  1>0 {0} n>1 = refute n>1
  1>0 {suc _} _ = _

  product-deleteIx : ∀ {a} ⦃ _ : NonZero a ⦄ (as : List Nat) (i : a ∈ as) →
                       productR as ≡ a * productR (deleteIx as i)
  product-deleteIx (a ∷ as) zero!   = refl
  product-deleteIx {a} (b ∷ as) (suc i) =
    b * productR as                  ≡⟨ b *_ $≡ product-deleteIx as i  ⟩
    b * productR (a ∷ deleteIx as i) ≡⟨ auto ⟩
    a * productR (b ∷ deleteIx as i) ∎

--- Factorisation ---------

record Factorisation (n : Nat) : Set where
  no-eta-equality
  constructor mkFactors
  field
    factors       : List Nat
    factors-prime : All Prime factors
    factors-sound : productR factors ≡ n

open Factorisation

mul-factors : ∀ {a b} → Factorisation a → Factorisation b → Factorisation (a * b)
mul-factors {a} {b} (mkFactors ps psP ps=a) (mkFactors qs qsP qs=b) =
  mkFactors (ps ++ qs) (psP ++All qsP) $
    productR (ps ++ qs)       ≡⟨ product-++ ps _ ⟩
    productR ps * productR qs ≡⟨ _*_ $≡ ps=a *≡ qs=b ⟩
    a * b ∎

private
  factorise′ : ∀ n ⦃ _ : NonZero n ⦄ → Acc _<_ n → Factorisation n
  factorise′ n (acc wf) =
    case isPrime n of λ where
      (yes p) → mkFactors (n ∷ []) (p ∷ []) auto
      (no (composite a b a>1 b>1 refl)) →
        let instance _ = 1>0 a>1; _ = 1>0 b>1 in
        mul-factors (factorise′ a (wf a (less-mul-l a>1 b>1)))
                    (factorise′ b (wf b (less-mul-r a>1 b>1)))
      (tiny n<2) → mkFactors [] [] (sym (0<1<2 n<2))

  find-prime : ∀ p ps → Prime p → All Prime ps → p Divides productR ps → p ∈ ps
  find-prime p [] isP isPs p|1 = ⊥-elim (prime-divide-coprime p 1 1 isP refl p|1 p|1)
  find-prime p (q ∷ qs) isP (qP ∷ isPs) p|qqs =
    case prime-split q (productR qs) isP p|qqs of λ where
      (left  p|q)  → zero (prime-divide-prime isP qP p|q)
      (right p|qs) → suc  (find-prime p qs isP isPs p|qs)

  unique : (ps qs : List Nat) → All Prime ps → All Prime qs → productR ps ≡ productR qs → Permutation ps qs
  unique [] qs ips iqs ps=qs = case primeProd=1-is-empty qs iqs (sym ps=qs) of λ where refl → []
  unique (p ∷ ps) qs (pP ∷ psP) qsP pps=qs =
    let instance _ = prime-nonzero pP
        p|qs : p Divides productR qs
        p|qs = factor (productR ps) (by pps=qs)
        i : p ∈ qs
        i = find-prime p qs pP qsP p|qs
        ps=qs/p : productR ps ≡ productR (deleteIx qs i)
        ps=qs/p = mul-inj₂ p _ _ (pps=qs ⟨≡⟩ product-deleteIx qs i )
    in i ∷ unique ps (deleteIx qs i) psP (deleteAllIx qsP i) ps=qs/p

--- The Fundamental Theorem of arithmetic:
--    any nonzero natural number can be factored into a product of primes,
--    and the factorisation is unique up to permutation.

factorise : (n : Nat) ⦃ _ : NonZero n ⦄ → Factorisation n
factorise n = factorise′ n (wfNat n)

factors-unique : ∀ {n} (f₁ f₂ : Factorisation n) → Permutation (factors f₁) (factors f₂)
factors-unique (mkFactors ps psP ps=n) (mkFactors qs qsP qs=n) =
  unique ps qs psP qsP (ps=n ⟨≡⟩ʳ qs=n)


module product where

open import level

----------------------------------------------------------------------
-- types
----------------------------------------------------------------------

data Σ {ℓ ℓ'} (A : Set ℓ) (B : A → Set ℓ') : Set (ℓ ⊔ ℓ') where
  _,_ : (a : A) → (b : B a) → Σ A B

data Σi {ℓ ℓ'} (A : Set ℓ) (B : A → Set ℓ') : Set (ℓ ⊔ ℓ') where
  ,_ : {a : A} → (b : B a) → Σi A B

_×_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
A × B = Σ A (λ x → B)

_i×_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
A i× B = Σi A (λ x → B)

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infix 1 Σ-syntax
infixr 2 _×_ _i×_ _∧_
infixr 4 _,_
infix  4 ,_

-- This provides the syntax: Σ[ x ∈ A ] B it is taken from the Agda
-- standard library. This style is nice when working in Set.
Σ-syntax : ∀ {a b} (A : Set a) → (A → Set b) → Set (a ⊔ b)
Σ-syntax = Σ

syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------
fst : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A × B → A
fst (a , b) = a

snd : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A × B → B
snd (a , b) = b

⟨_,_⟩ : ∀{ℓ₁ ℓ₂ ℓ₃ ℓ₄}
         {A : Set ℓ₁}{B : Set ℓ₂}
         {C : Set ℓ₃}{D : Set ℓ₄}
       → (A → C)
       → (B → D)
       → (A × B → C × D)
⟨ f , g ⟩ (a , b) = f a , g b

twist-× : ∀{ℓ₁ ℓ₂}
     {A : Set ℓ₁}{B : Set ℓ₂}
    → A × B
    → B × A
twist-× (a , b) = (b , a)

rl-assoc-× : ∀{ℓ₁ ℓ₂ ℓ₃}
             {A : Set ℓ₁}{B : Set ℓ₂}
             {C : Set ℓ₃}
           → A × (B × C)
           → (A × B) × C
rl-assoc-× (a , b , c) =  ((a , b) , c)

lr-assoc-× : ∀{ℓ₁ ℓ₂ ℓ₃}
             {A : Set ℓ₁}{B : Set ℓ₂}
             {C : Set ℓ₃}
           → (A × B) × C
           → A × (B × C)
lr-assoc-× ((a , b) , c) = (a , b , c)

----------------------------------------------------------------------
-- some logical notation
----------------------------------------------------------------------
_∧_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
_∧_ = _×_

∃ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : A → Set ℓ') → Set (ℓ ⊔ ℓ')
∃ = Σ

∃i : ∀ {ℓ ℓ'} (A : Set ℓ) (B : A → Set ℓ') → Set (ℓ ⊔ ℓ')
∃i = Σi


module Integer.Difference.Properties where

open import Data.Product as Σ
open import Data.Product.Relation.Pointwise.NonDependent
open import Data.Unit
open import Equality
open import Integer.Difference
open import Natural as ℕ using (ℕ; zero; suc)
open import Quotient as /
open import Relation.Binary
open import Syntax

open Equality.FunctionProperties

+-comm : Commutative {A = ℤ} _+_
+-comm =
  ⟦⟧-≗₂ uip _ _ λ where
    (a – b) (c – d) →
      cong ⟦_⟧ (cong₂ _–_ (⟨ ℕ.+-comm a c ⟩) (⟨ ℕ.+-comm d b ⟩))

+-identityˡ : LeftIdentity {A = ℤ} 0 _+_
+-identityˡ =
  ⟦⟧-≗ uip _ _ λ where
    (a – b) →
      cong (λ z → ⟦ a – z ⟧) ⟨ ℕ.+-identityʳ b ⟩

+-identityʳ : RightIdentity {A = ℤ} 0 _+_
+-identityʳ =
  ⟦⟧-≗ uip _ _ λ where
    (a – b) →
      cong (λ z → ⟦ z – b ⟧) ⟨ ℕ.+-identityʳ a ⟩

+-assoc : Associative {A = ℤ} _+_
+-assoc =
  ⟦⟧-≗₃ uip _ _
    λ where
      (a – b) (c – d) (e – f) →
        cong ⟦_⟧ (cong₂ _–_ (sym (ℕ.+-assoc a _ _)) (ℕ.+-assoc f _ _))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.FinData.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Data.Nat
open import Cubical.Data.Bool.Base
open import Cubical.Relation.Nullary

private
  variable
    ℓ : Level
    A B : Type ℓ

data Fin : ℕ → Type₀ where
  zero : {n : ℕ} → Fin (suc n)
  suc  : {n : ℕ} (i : Fin n) → Fin (suc n)

toℕ : ∀ {n} → Fin n → ℕ
toℕ zero    = 0
toℕ (suc i) = suc (toℕ i)

fromℕ : (n : ℕ) → Fin (suc n)
fromℕ zero    = zero
fromℕ (suc n) = suc (fromℕ n)

¬Fin0 : ¬ Fin 0
¬Fin0 ()

_==_ : ∀ {n} → Fin n → Fin n → Bool
zero == zero   = true
zero == suc _  = false
suc _ == zero  = false
suc m == suc n = m == n

foldrFin : ∀ {n} → (A → B → B) → B → (Fin n → A) → B
foldrFin {n = zero}  _ b _ = b
foldrFin {n = suc n} f b l = f (l zero) (foldrFin f b (l ∘ suc))


{-
 Definition of a basis of a distributive lattice as a generating sub-meet-semilattice
-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.DistLattice.Basis where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Powerset

open import Cubical.Functions.Embedding

open import Cubical.Data.Sigma
open import Cubical.Data.Nat using (ℕ ; zero ; suc)
open import Cubical.Data.FinData
open import Cubical.Data.Bool

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Macro
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Monoid.BigOp
open import Cubical.Algebra.CommMonoid
open import Cubical.Algebra.Semilattice
open import Cubical.Algebra.Lattice
open import Cubical.Algebra.DistLattice
open import Cubical.Algebra.DistLattice.BigOps

private
  variable
    ℓ : Level

module _ (L' : DistLattice ℓ) where
 private L = fst L'
 open DistLatticeStr (snd L')
 open Join L'

 record IsGenSublattice (M : Semilattice ℓ) (e : fst M → L) : Type ℓ where
  constructor
   isgensublattice
  open SemilatticeStr (snd M) renaming (ε to 0s ; _·_ to _∧s_)
  field
   isInj : ∀ x y → e x ≡ e y → x ≡ y
   pres0 : e 0s ≡ 0l
   resp∧ : ∀ x y → e (x ∧s y) ≡ e x ∧l e y
   ⋁Gen : ∀ (x : L) → ∃[ n ∈ ℕ ] Σ[ α ∈ FinVec (fst M) n ] (⋁ (e ∘ α) ≡ x)

 -- TODO: prove equivalence with the more set-theoretical definition
 record IsBasis (S : ℙ L) : Type ℓ where
  constructor
   isbasis
  field
   contains1 : 1l ∈ S
   ∧lClosed : ∀ (x y : L) → x ∈ S → y ∈ S → x ∧l y ∈ S
   ⋁Basis : ∀ (x : L) → ∃[ n ∈ ℕ ] Σ[ α ∈ FinVec L n ] (∀ i → α i ∈ S) × (⋁ α ≡ x)

 open IsBasis
 open SemilatticeStr
 Basis→MeetSemilattice : (S : ℙ L) → IsBasis S → Semilattice ℓ
 fst (Basis→MeetSemilattice S isBasisS) = Σ[ l ∈ L ] (l ∈ S)
 ε (snd (Basis→MeetSemilattice S isBasisS)) = 1l , isBasisS .contains1
 _·_ (snd (Basis→MeetSemilattice S isBasisS)) x y = fst x ∧l fst y
                                                  , isBasisS .∧lClosed _ _ (snd x) (snd y)
 isSemilattice (snd (Basis→MeetSemilattice S isBasisS)) = makeIsSemilattice
   (isSetΣ (isSetDistLattice L') λ _ → isProp→isSet (S _ .snd))
     (λ _ _ _ → Σ≡Prop (λ _ → S _ .snd) (∧lAssoc _ _ _))
       (λ _ → Σ≡Prop (λ _ → S _ .snd) (∧lRid _))
         (λ _ → Σ≡Prop (λ _ → S _ .snd) (∧lLid _))
           (λ _ _ → Σ≡Prop (λ _ → S _ .snd) (∧lComm _ _))
             λ _ → Σ≡Prop (λ _ → S _ .snd) (∧lIdem _)


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

-- https://ncatlab.org/nlab/show/span
-- The colimit of a functor from this category is a pushout in the target category.
module Categories.Category.Instance.Span where

open import Level
open import Categories.Category
open import Relation.Binary.PropositionalEquality

data SpanObj : Set where
  center : SpanObj
  left   : SpanObj
  right  : SpanObj

data SpanArr : SpanObj → SpanObj → Set where
  span-id   : ∀ {o} → SpanArr o o
  span-arrˡ : SpanArr center left
  span-arrʳ : SpanArr center right

span-compose : ∀ {x y z} → SpanArr y z → SpanArr x y → SpanArr x z
span-compose span-id span-id   = span-id
span-compose span-id span-arrˡ = span-arrˡ
span-compose span-id span-arrʳ = span-arrʳ
span-compose span-arrˡ span-id = span-arrˡ
span-compose span-arrʳ span-id = span-arrʳ

Span : Category 0ℓ 0ℓ 0ℓ
Span = record
  { Obj       = SpanObj
  ; _⇒_       = SpanArr
  ; _≈_       = _≡_
  ; id        = span-id
  ; _∘_       = span-compose
  ; assoc     = assoc
  ; sym-assoc = sym assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = λ {x} → identity² {x}
  ; equiv     = isEquivalence
  ; ∘-resp-≈  = λ { refl refl → refl }
  }
  where assoc : ∀ {x y z w} {f : SpanArr x y} {g : SpanArr y z} {h : SpanArr z w} →
                               span-compose (span-compose h g) f ≡
                               span-compose h (span-compose g f)
        assoc {_} {_} {_} {_} {span-id} {span-id} {span-id}   = refl
        assoc {_} {_} {_} {_} {span-id} {span-id} {span-arrˡ} = refl
        assoc {_} {_} {_} {_} {span-id} {span-id} {span-arrʳ} = refl
        assoc {_} {_} {_} {_} {span-id} {span-arrˡ} {span-id} = refl
        assoc {_} {_} {_} {_} {span-id} {span-arrʳ} {span-id} = refl
        assoc {_} {_} {_} {_} {span-arrˡ} {span-id} {span-id} = refl
        assoc {_} {_} {_} {_} {span-arrʳ} {span-id} {span-id} = refl

        identityˡ : ∀ {x y} {f : SpanArr x y} → span-compose span-id f ≡ f
        identityˡ {_} {_} {span-id}   = refl
        identityˡ {_} {_} {span-arrˡ} = refl
        identityˡ {_} {_} {span-arrʳ} = refl

        identityʳ : ∀ {x y} {f : SpanArr x y} → span-compose f span-id ≡ f
        identityʳ {_} {_} {span-id}   = refl
        identityʳ {_} {_} {span-arrˡ} = refl
        identityʳ {_} {_} {span-arrʳ} = refl

        identity² : {x : SpanObj} → span-compose span-id span-id ≡ span-id
        identity² = refl


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

-- The category of partially ordered sets and order-preserving maps.

open import Level
open import Relation.Binary using (Poset; IsEquivalence; _Preserves_⟶_)
open import Relation.Binary.OrderMorphism using (_⇒-Poset_; id; _∘_)

open import Categories.Category

open Poset renaming (_≈_ to ₍_₎_≈_; _≤_ to ₍_₎_≤_)
open _⇒-Poset_

module _ {a₁ a₂ a₃ b₁ b₂ b₃} {A : Poset a₁ a₂ a₃} {B : Poset b₁ b₂ b₃} where

  infix 4 _≗_

  -- Order morphisms preserve equality.

  fun-resp-≈ : (f : A ⇒-Poset B) → fun f Preserves ₍ A ₎_≈_ ⟶ ₍ B ₎_≈_
  fun-resp-≈ f x≈y = antisym B (monotone f (reflexive A x≈y))
                               (monotone f (reflexive A (Eq.sym A x≈y)))

  -- Pointwise equality (on order preserving maps).

  _≗_ : (f g : A ⇒-Poset B) → Set (a₁ ⊔ b₂)
  f ≗ g = ∀ {x} → ₍ B ₎ fun f x ≈ fun g x

  ≗-isEquivalence : IsEquivalence _≗_
  ≗-isEquivalence = record
    { refl    = Eq.refl B
    ; sym     = λ f≈g → Eq.sym B f≈g
    ; trans   = λ f≈g g≈h → Eq.trans B f≈g g≈h
    }

  module ≗ = IsEquivalence ≗-isEquivalence

-- The category of posets and order-preserving maps.

Posets : ∀ c ℓ₁ ℓ₂ → Category (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) (c ⊔ ℓ₂) (c ⊔ ℓ₁)
Posets c ℓ₁ ℓ₂ = record
  { Obj       = Poset c ℓ₁ ℓ₂
  ; _⇒_       = _⇒-Poset_
  ; _≈_       = _≗_
  ; id        = id
  ; _∘_       = _∘_
  ; assoc     = λ {_ _ _ D} → Eq.refl D
  ; sym-assoc = λ {_ _ _ D} → Eq.refl D
  ; identityˡ = λ {_ B} → Eq.refl B
  ; identityʳ = λ {_ B} → Eq.refl B
  ; identity² = λ {A} → Eq.refl A
  ; equiv     = ≗-isEquivalence
  ; ∘-resp-≈  = λ {_ _ C _ h} f≈h g≈i → Eq.trans C f≈h (fun-resp-≈ h g≈i)
  }
  where


module hierarchy where

data Bool : Set where
  true  : Bool
  false : Bool

_and_ : Bool → Bool → Bool
true and true = true
true and false = false
false and true = false
false and false = false

_or_ : Bool → Bool → Bool
true or true = true
true or false = true
false or true = true
false or false = false

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

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

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

_∈_ : ℕ → List ℕ → Bool
x ∈ []      = false
x ∈ (y :: ys) with x == y
...              | true  = true
...              | false = x ∈ ys

_⊂_ : List ℕ → List ℕ → Bool
[] ⊂ ys      = true
(x :: xs) ⊂ ys with x ∈ ys
...               | true  = xs ⊂ ys
...               | false = false

_++_ : {A : Set} → List A → List A → List A
[] ++ ys        = ys
(x :: xs) ++ ys = x :: (xs ++ ys)

map : {A : Set} → (A → A) → List A → List A
map f []        = []
map f (x :: xs) = (f x) :: (map f xs)

any : {A : Set} → (A → Bool) → List A → Bool
any _ []        = false
any f (x :: xs) = (f x) or (any f xs)

all : {A : Set} → (A → Bool) → List A → Bool
all _ []        = true
all f (x :: xs) = (f x) and (all f xs)

data Arrow : Set where
  _⇒_ : List ℕ → ℕ → Arrow

_⇔_ : Arrow → Arrow → Bool
(at ⇒ ah) ⇔ (bt ⇒ bh) = ((at ⊂ bt) and (bt ⊂ at)) and (ah == bh)

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []      = false
x ∈∈ (y :: ys) with x ⇔ y
...               | true  = true
...               | false = x ∈∈ ys

_⊂⊂_ : List Arrow → List Arrow → Bool
[] ⊂⊂ ys      = true
(x :: xs) ⊂⊂ ys with x ∈∈ ys
...                | true  = xs ⊂⊂ ys
...                | false = false

ArrowSearch : List Arrow → List Arrow → ℕ → Bool
ArrowSearch [] ds g = false
ArrowSearch (([] ⇒ h) :: cs) ds g with (h == g)
...         | true  = true
...         | false = ArrowSearch cs (([] ⇒ h) :: ds) g
ArrowSearch ((ts ⇒ h) :: cs) ds g with (h == g)
...         | true  = (all (ArrowSearch (cs ++ ds) []) ts)
                  or (ArrowSearch cs ((ts ⇒ h) :: ds) g)
...         | false = ArrowSearch cs ((ts ⇒ h) :: ds) g

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ ((t :: ts) ⇒ h) = (([] ⇒ t) :: cs) ⊢ (ts ⇒ h)
cs ⊢ ([] ⇒ h)        = ArrowSearch cs [] h


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

open import Categories.Category
open import Categories.Category.CartesianClosed.Locally

module Categories.Category.CartesianClosed.Locally.Properties {o ℓ e} {C : Category o ℓ e}
  (LCCC : Locally C) where

open import Categories.Category.CartesianClosed
open import Categories.Category.Slice
open import Categories.Category.Slice.Properties
open import Categories.Functor
open import Categories.Functor.Slice

private
  module C = Category C
  open C
  open Locally LCCC
  variable
    A B : Obj

module _ (f : A ⇒ B) where
  open CartesianClosed (sliceCCC B)

  private
    C/A   = Slice C A
    C/B   = Slice C B
    C/B/f = Slice C/B (sliceobj f)

    fObj : SliceObj C B
    fObj = sliceobj f

    i : Slice⇒ C ⊤ (fObj ^ fObj)
    i = λg π₂

    J : Functor C/A C/B/f
    J = slice⇒slice-slice C f

    I : Functor (Slice C/B (fObj ^ fObj)) C/B
    I = pullback-functorial C/B slice-pullbacks i

    K : Functor C/B/f (Slice C/B (fObj ^ fObj))
    K = Base-F C/B (fObj ⇨-)

  -- this functor should be the right adjoint functor of (BaseChange* C pullbacks f).
  BaseChange⁎ : Functor C/A C/B
  BaseChange⁎ = I ∘F K ∘F J


module Sec4 where
-- open import Sec2

Prop : Set₁
Prop = Set

Value : Set₁
Value = Set

-- XXX: The true type
data ⊤ : Prop where
  ⋆ : ⊤

-- XXX: The false type
data ⊥ : Prop where

-- XXX: Conjunction of Propositions
data _∧_ (A B : Prop) : Prop where
  and : A → B → (A ∧ B)

-- XXX: The disjuction of propositions
data _∨_ (A B : Prop) : Prop where
  ora : A → A ∨ B
  orb : B → A ∨ B

-- XXX: implication
data _⇒_ (A B : Prop) : Prop where
  impl : (f : A → B) → A ⇒ B

infixr 2 _⇒_

-- XXX: equivalence
data _⇔_ (A B : Prop) : Prop where
  eq : (f₁ : A ⇒ B) → (f₂ : B ⇒ A) → A ⇔ B

-- XXX: Negation as a function
data ¬_ (A : Prop) : Prop where
  neg : A ⇒ ⊥ → (¬ A)

-- XXX: Elimination rules as functions

-- XXX: Eliminating ≡>
elim-⇒ : {A B : Prop} → (f₁ : A ⇒ B) → A → B
elim-⇒ (impl f) x = f x

elim1-⇔ : {A B : Prop} → (A ⇔ B) → A → B
elim1-⇔ (eq (impl f) _) x = f x
elim2-⇔ : {A B : Prop} → (A ⇔ B) → B → A
elim2-⇔ (eq _ (impl f₁)) x = f₁ x

-- XXX: Eliminating disjunction
elim-∨ : {A B C : Prop} → (A ∨ B) → (A → C) → (B → C) → C
elim-∨ (ora x) f₁ _ = f₁ x
elim-∨ (orb x) _ f₂ = f₂ x

-- XXX: Eliminating conjuction
elim1-∧ : {A B : Prop} → (A ∧ B) → A
elim1-∧ (and x x₁) = x
elim2-∧ : {A B : Prop} → (A ∧ B) → B
elim2-∧ (and x x₁) = x₁

-- TODO: Example of proofs of tautology
-- XXX: Easy one
ex1 : {A B : Prop} → ((A ⇒ B) ∧ (B ⇒ A)) ⇔ (A ⇔ B)
ex1 {A} {B} =
        eq
        (impl (λ x →
          let x1 = elim1-∧ x
              x2 = elim2-∧ x
          in
          eq (impl (λ x₁ → elim-⇒ x1 x₁))
             (impl (λ x₁ → elim-⇒ x2 x₁))))

        (impl (λ x →
                   let x1 = elim1-⇔ x
                       x2 = elim2-⇔ x
                   in
                   and
                   (impl (λ x₁ → x1 x₁))
                   (impl (λ x₁ → x2 x₁))))

-- XXX: Transitivity
ex2 : {A B C : Prop} → ((A ⇒ B) ∧ (B ⇒ C)) ⇒ (A ⇒ C)
ex2 = impl (λ x →
           impl (λ x₁ → elim-⇒ (elim2-∧ x) (elim-⇒ (elim1-∧ x) x₁)))

-- XXX: Transitivity in the function space of Agda itself. Equivalent to
-- the above one.
trans : {A B C : Set} → ((A → B) ∧ (B → C)) → (A → C)
trans (and x1 x2) z = let t = x1 z
                          t1 = x2 t
                      in t1
-- (elim-⇒ x x₂)
transitivity : {A B C : Prop} → (A ⇒ B) ⇒ (B ⇒ C) ⇒ (A ⇒ C)
transitivity = impl (λ x →
                    impl
                      (λ x₁ → impl
                              (λ x₂ →
                                elim-⇒ x₁ (elim-⇒ x x₂))))

-- XXX: Moving ∧ into Agda's space. Equivalent to transitivity and trans
-- above.
trans' : {A B C : Set} → (A → B) → (B → C) → (A → C)
trans' x y = λ z → y (x z)

-- XXX: absorption law
absorption : {P Q : Prop} → (P ∨ (P ∧ Q)) ⇔ P
absorption {p} {q} =
               eq
               (impl (λ x → let x1 = elim-∨ x (λ p → p) (λ y → elim1-∧ y) in x1))
               (impl (λ x → ora x))

-- XXX: commutativity
commute : {P Q : Prop} → (P ∧ Q) ⇔ (Q ∧ P)
commute = eq (impl (λ x → and (elim2-∧ x) (elim1-∧ x)))
             (impl (λ x → and (elim2-∧ x) (elim1-∧ x)))

-- XXX: associativity
associative : {P Q R : Prop} → ((P ∧ Q) ∧ R) ⇔ (P ∧ (Q ∧ R))
associative  = eq
               (impl (λ x →
                        and (elim1-∧ (elim1-∧ x))
                            (and (elim2-∧ (elim1-∧ x)) (elim2-∧ x))))
               (impl (λ x →
                        and (and (elim1-∧ x) (elim1-∧ (elim2-∧ x)))
                            (elim2-∧ (elim2-∧ x))))

elim-neg : {A : Prop} → A → (¬ A) → ⊥
elim-neg y (neg x) = elim-⇒ x y

eet : {A B : Prop} → ((¬ A) ∧ (¬ B)) ⇒ (¬ (A ∧ B))
eet = impl (λ x → neg (impl (λ x₁ → elim-neg (elim1-∧ x₁) (elim1-∧ x))))

-- tt : {A : Prop} → (A ∨ (¬ A)) → (¬ (¬ A)) → A
-- tt (ora x) (neg y) = x
-- tt {A} (orb x) (neg y) =
--                        let
--                          z = elim-⇒ y x
--                          t = elim-neg {!!} x
--                        in
--                        {!!}

-- XXX: A ⇒ ¬¬ A
f : {A : Prop} → A ⇒ (¬ (¬ A))
f = impl (λ x → neg (impl (λ x₁ → elim-neg x x₁)))

-- A⇔¬¬A : {A : Prop} → A ⇔ (¬ (¬ A))
-- A⇔¬¬A = eq (impl (λ x → neg (impl (λ x₁ → elim-neg x x₁))))
--            (impl (λ x → {!!}))

-- A⇔A⇒⊥⇒⊥ : {A : Prop} → (A ⇔ ((A ⇒ ⊥) ⇒ ⊥))
-- A⇔A⇒⊥⇒⊥ = eq (impl (λ x → impl (λ x₁ → elim-⇒ x₁ x)))
--          (impl (λ x → {!!}))

-- AC⇒Contra : {A : Prop} → (A ∨ (¬ A)) ⇒ ((¬ (¬ A)) ⇒ A)
-- AC⇒Contra = impl (λ x → impl (λ x₁ → {!!}))

-- XXX: Axiom of choice one way
C-⇒ : {P : Prop} → (P ∨ (¬ P)) ⇒ ⊤
C-⇒ = impl (λ _ → ⋆)

-- XXX: Axiom of choice
-- C-⇔ : {P : Prop} → (P ∨ (¬ P)) ⇔ ⊤
-- C-⇔ = eq
--       (impl (λ _ → ⋆))
--       -- XXX: The following proof is impossible todo
--       -- Goal: .P ∨ (¬ .P)
--       -- ————————————————————————————————————————————————————————————
--       -- x  : ⊤
--       -- .P : Prop
--       (impl (λ x → {!!})) -- XXX: We do not have any proof object of P
--                           -- on the right hand side. This is the
--                           -- difference between constructive logic, and
--                           -- classical logic.

-- distributive : {p q r : Prop} → (p ∧ (q ∨ r)) ⇔ ((p ∧ q) ∨ (p ∧ r))
-- distributive =
--                eq
--                (impl (λ x →
--                         let p = elim1-∧ x
--                             x2 = elim2-∧ x
--                             x3 = elim-∨ x2 (λ q → q) (λ x₁ → {!!})
--                         in
--                         ora (and p x3)))
--                (impl (λ x →
--                         let x1 = elim-∨ x (λ l → elim1-∧ l) (λ r → elim1-∧ r)
--                             x2 = elim-∨ x (λ x₁ → {!!}) (λ r → elim2-∧ r)
--                         in
--                         and x1 (orb x2)))

and-⇒ : {A B : Prop} → (A ∧ B) ⇒ (A ⇒ B)
and-⇒ = impl (λ x → impl (λ x₁ → elim2-∧ x))

tii : {A B C : Prop} → ((A ∧ B) ⇒ C) ⇒ (A ⇒ (B ⇒ C))
tii  = impl (λ x → impl (λ x₁ → impl (λ x₂ → elim-⇒ x (and x₁ x₂))))

-- tii2 : {A B : Prop} → (((¬ A) ∨ B) ∧ A) ⇒ B
-- tii2 = impl (λ x →
--             let
--               x₁ = elim1-∧ x
--               x₂ = elim2-∧ x
--             in
--             {!!})

-- contradiction : {A : Prop} → (¬ (¬ A)) ⇒ A
-- contradiction = impl (λ x → {!!})

-- XXX: Predicate logic
-- XXX: For all introduction
data ForAll (A : Set) (B : A → Prop) : Prop where
  dfun : (∀ (x : A) → (B x)) → (ForAll A B)

elim-ForAll : {A : Set} → (x : A) → {B : A → Prop} → (ForAll A B) → (B x)
elim-ForAll x (dfun x₁) = x₁ x

-- XXX: Exists
data Exists (A : Set) (B : A → Prop) : Prop where
  [_,_] : (x : A) → (B x) → Exists A B

elim1-exists : {A : Prop} → {B : A → Prop} → (Exists A B) → A
elim1-exists [ x , _ ] = x

elim2-exists : {A : Prop} → {B : A → Prop} → (p : Exists A B) → (B (elim1-exists p))
elim2-exists [ _ , x ] = x

-- TODO: Proofs in predicate logic

-- XXX: model-checking depends on this theorem
mthm : {V : Value} → {P : V → Prop} → (Exists V (λ (x : V) → (¬ P x)))
                                   ⇒ (¬ ForAll V P)
mthm = impl (λ x →
            neg (impl (λ x₁ →
                      elim-neg (elim-ForAll (elim1-exists x) x₁) (elim2-exists x))))

pex0 : {X : Set} → {P : X → Prop} → (¬ (Exists X P)) ⇒ (ForAll X (λ x → (¬ P x)))
pex0  = impl (λ x →
             dfun (λ x₁ →
                  neg (impl (λ x₂ →
                            let x1 = elim-neg [ x₁ , x₂ ] x
                            in
                            x1))))

pex0' : {X : Set} → {P : X → Prop} →  (ForAll X (λ x → (¬ P x))) ⇒ (¬ (Exists X P))
pex0' = impl (λ x →
             neg (impl
                 (λ x₁ →
                 let x1 = elim1-exists x₁
                     x1' = elim2-exists x₁
                     x2 = elim-ForAll x1 x
                 in
                 elim-neg x1' x2)))

pex2 : {X Y : Set} → {P : X → Y → Prop} → (Exists Y (λ (y : Y) → (ForAll X (λ (x : X) → P x y))))
                                        ⇒ (ForAll X (λ (x : X) → (Exists Y (λ (y : Y) → P x y))))
pex2 = impl (λ x →
            dfun (λ x₁ →
                 let x1 = elim1-exists x
                     x2 = elim2-exists x
                     x3 = elim-ForAll x₁ x2
                 in
                 [ x1 , x3 ]))

-- TODO: Tautology in first order predicate logic
ptau : {V B : Value} → {A : V → Prop} → (x : V)
                     → (ForAll V (λ _ → (A x) ⇒ B))
                     ⇔ (Exists V (λ _ → (A x) ⇒ B))
ptau a = eq
       (impl (λ x →
             [ a , (impl (λ x₁ →
                            elim-⇒ (elim-ForAll a x) x₁)) ]))
       (impl (λ x → dfun (λ x₁ → impl (λ x₂ →
                                      elim-⇒ (elim2-exists x) x₂))))


module Data.List where

import      Lvl
open import Type

private variable ℓ : Lvl.Level
private variable T : Type{ℓ}

infixr 1000 _⊰_

-- A list is a container/collection of elements.
-- • The elements are in a linear order.
-- • The container allows multiples (non-uniqueness of elements in the container).
data List (T : Type{ℓ}) : Type{ℓ} where
  ∅   : List(T) -- An empty list
  _⊰_ : T → List(T) → List(T) -- Cons
{-# BUILTIN LIST List #-}

private variable l : List(T)
private variable P : List(T) → Type{ℓ}

elim : P(∅) → (∀(x : T)(l : List(T)) → P(l) → P(x ⊰ l)) → ((l : List(T)) → P(l))
elim base next ∅       = base
elim base next (x ⊰ l) = next(x)(l)(elim base next l)


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

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

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

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

open import Rings.Divisible.Definition R
open Ring R
open Setoid S
open import Rings.Units.Definition R

record Prime (x : A) : Set (a ⊔ b) where
  field
    isPrime : (r s : A) → (x ∣ (r * s)) → ((x ∣ r) → False) → (x ∣ s)
    nonzero : (x ∼ 0R) → False
    nonunit : Unit x → False


------------------------------------------------------------------------
-- Some properties about subsets
------------------------------------------------------------------------

module Data.Fin.Subset.Props where

open import Data.Nat
open import Data.Vec hiding (_∈_)
open import Data.Empty
open import Data.Function
open import Data.Fin
open import Data.Fin.Subset
open import Data.Product
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Constructor mangling

drop-there : ∀ {s n x} {p : Subset n} → suc x ∈ s ∷ p → x ∈ p
drop-there (there x∈p) = x∈p

drop-∷-⊆ : ∀ {n s₁ s₂} {p₁ p₂ : Subset n} → s₁ ∷ p₁ ⊆ s₂ ∷ p₂ → p₁ ⊆ p₂
drop-∷-⊆ p₁s₁⊆p₂s₂ x∈p₁ = drop-there $ p₁s₁⊆p₂s₂ (there x∈p₁)

drop-∷-Empty : ∀ {n s} {p : Subset n} → Empty (s ∷ p) → Empty p
drop-∷-Empty ¬¬∅ (x , x∈p) = ¬¬∅ (suc x , there x∈p)

------------------------------------------------------------------------
-- More interesting properties

allInside : ∀ {n} (x : Fin n) → x ∈ all inside
allInside zero    = here
allInside (suc x) = there (allInside x)

allOutside : ∀ {n} (x : Fin n) → x ∉ all outside
allOutside zero    ()
allOutside (suc x) (there x∈) = allOutside x x∈

⊆⊇⟶≡ : ∀ {n} {p₁ p₂ : Subset n} →
       p₁ ⊆ p₂ → p₂ ⊆ p₁ → p₁ ≡ p₂
⊆⊇⟶≡ = helper _ _
  where
  helper : ∀ {n} (p₁ p₂ : Subset n) →
           p₁ ⊆ p₂ → p₂ ⊆ p₁ → p₁ ≡ p₂
  helper []            []             _   _   = refl
  helper (s₁ ∷ p₁)     (s₂ ∷ p₂)      ₁⊆₂ ₂⊆₁ with ⊆⊇⟶≡ (drop-∷-⊆ ₁⊆₂)
                                                        (drop-∷-⊆ ₂⊆₁)
  helper (outside ∷ p) (outside ∷ .p) ₁⊆₂ ₂⊆₁ | refl = refl
  helper (inside  ∷ p) (inside  ∷ .p) ₁⊆₂ ₂⊆₁ | refl = refl
  helper (outside ∷ p) (inside  ∷ .p) ₁⊆₂ ₂⊆₁ | refl with ₂⊆₁ here
  ...                                                | ()
  helper (inside  ∷ p) (outside ∷ .p) ₁⊆₂ ₂⊆₁ | refl with ₁⊆₂ here
  ...                                                | ()

∅⟶allOutside : ∀ {n} {p : Subset n} →
               Empty p → p ≡ all outside
∅⟶allOutside {p = []}     ¬¬∅ = refl
∅⟶allOutside {p = s ∷ ps} ¬¬∅ with ∅⟶allOutside (drop-∷-Empty ¬¬∅)
∅⟶allOutside {p = outside ∷ .(all outside)} ¬¬∅ | refl = refl
∅⟶allOutside {p = inside  ∷ .(all outside)} ¬¬∅ | refl =
  ⊥-elim (¬¬∅ (zero , here))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Pointed.FunExt where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv

open import Cubical.Foundations.Pointed.Base
open import Cubical.Foundations.Pointed.Properties
open import Cubical.Foundations.Pointed.Homotopy

private
  variable
    ℓ ℓ' : Level

module _ {A : Pointed ℓ} {B : typ A → Type ℓ'} {ptB : B (pt A)} where

  -- pointed function extensionality
  funExt∙P : {f g : Π∙ A B ptB} → f ∙∼P g → f ≡ g
  funExt∙P (h , h∙) i .fst x = h x i
  funExt∙P (h , h∙) i .snd = h∙ i

  -- inverse of pointed function extensionality
  funExt∙P⁻ : {f g : Π∙ A B ptB} → f ≡ g → f ∙∼P g
  funExt∙P⁻ p .fst a i = p i .fst a
  funExt∙P⁻ p .snd i = p i .snd

  -- function extensionality is an isomorphism, PathP version
  funExt∙PIso : (f g : Π∙ A B ptB) → Iso (f ∙∼P g) (f ≡ g)
  Iso.fun (funExt∙PIso f g)  = funExt∙P {f = f} {g = g}
  Iso.inv (funExt∙PIso f g) = funExt∙P⁻ {f = f} {g = g}
  Iso.rightInv (funExt∙PIso f g) p i j = p j
  Iso.leftInv (funExt∙PIso f g) h _ = h

  -- transformed to equivalence
  funExt∙P≃ : (f g : Π∙ A B ptB) → (f ∙∼P g) ≃ (f ≡ g)
  funExt∙P≃ f g = isoToEquiv (funExt∙PIso f g)

  -- funExt∙≃ using the other kind of pointed homotopy
  funExt∙≃ : (f g : Π∙ A B ptB) → (f ∙∼ g) ≃ (f ≡ g)
  funExt∙≃ f g = compEquiv (∙∼≃∙∼P f g) (funExt∙P≃ f g)

  -- standard pointed function extensionality and its inverse
  funExt∙ : {f g : Π∙ A B ptB} → f ∙∼ g → f ≡ g
  funExt∙ {f = f} {g = g} = equivFun (funExt∙≃ f g)

  funExt∙⁻ : {f g : Π∙ A B ptB} → f ≡ g → f ∙∼ g
  funExt∙⁻ {f = f} {g = g} = equivFun (invEquiv (funExt∙≃ f g))


-- When defining types by recursion it is sometimes difficult to infer implicit
-- arguments. This module illustrates the problem and shows how to get around
-- it for the example of vectors of a given length.

module DataByRecursion where

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

data Nil : Set where
  nil' : Nil

data Cons (A As : Set) : Set where
  _::'_ : A -> As -> Cons A As

mutual
  Vec' : Set -> Nat -> Set
  Vec' A  zero   = Nil
  Vec' A (suc n) = Cons A (Vec A n)

  data Vec (A : Set)(n : Nat) : Set where
    vec : Vec' A n -> Vec A n

nil : {A : Set} -> Vec A zero
nil = vec nil'

_::_ : {A : Set}{n : Nat} -> A -> Vec A n -> Vec A (suc n)
x :: xs = vec (x ::' xs)

map : {n : Nat}{A B : Set} -> (A -> B) -> Vec A n -> Vec B n
map {zero}  f (vec nil')       = nil
map {suc n} f (vec (x ::' xs)) = f x :: map f xs


module Oscar.Data.Term {𝔣} (FunctionName : Set 𝔣) where

open import Oscar.Data.Equality
open import Oscar.Data.Fin
open import Oscar.Data.Nat
open import Oscar.Data.Vec
open import Oscar.Function
open import Oscar.Relation

mutual

  Terms : Nat → Nat → Set 𝔣
  Terms N m = Vec (Term m) N

  data Term (m : Nat) : Set 𝔣 where
    i : (x : Fin m) → Term m
    leaf : Term m
    _fork_ : (s t : Term m) → Term m
    function : FunctionName → ∀ {N} → Terms N m → Term m


-- This file gives the definition of Gaussian Integers, and common
-- operations on them.

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

module GauInt.Base where

open import Data.Bool using (Bool ; true ; false ; T ; not ; _∧_)
open import Data.Nat using (ℕ ; _≡ᵇ_)
open import Data.Integer renaming (-_ to -ℤ_ ; _-_ to _-ℤ_ ; _+_ to _+ℤ_ ; _*_ to _*ℤ_ ) hiding (NonZero)

infix  4 _==_ -- boolean equality on 𝔾.
infix  4 _==ℤ_ -- boolean equality on ℤ.
infixl 6 _+_ _-_
infixl 7 _*_
infix 8  -_
infixl 9 _ᶜ  -- conjugation on 𝔾.

-- A Gaussian integer is a pair of integers.
infix 5 _+_i
data 𝔾 : Set where
  _+_i : ℤ -> ℤ -> 𝔾

-- Addition.
_+_ : 𝔾 -> 𝔾 -> 𝔾
(a + b i) + (c + d i) = x + y i where
  x = a +ℤ c
  y = b +ℤ d

-- Additive identity.
0𝔾 : 𝔾
0𝔾 = 0ℤ + 0ℤ i

-- Additive inverse.
-_ : 𝔾 -> 𝔾
- (a + b i) = (-ℤ a) + (-ℤ b) i

-- Subtraction.
_-_ : 𝔾 -> 𝔾 -> 𝔾
_-_ x y = x + (- y)

-- Multiplication.
_*_ : 𝔾 -> 𝔾 -> 𝔾
(a + b i) * (c + d i) = x + y i where
  x = a *ℤ c -ℤ b *ℤ d
  y = (a *ℤ d) +ℤ b *ℤ c

-- Multiplicative identity.
1𝔾 : 𝔾
1𝔾 = 1ℤ + 0ℤ i

-- imaginary unit i.
iG : 𝔾
iG = 0ℤ + 1ℤ i

-- Real and imaginary part.
Re : 𝔾 -> ℤ
Re (a + b i) = a

Im : 𝔾 -> ℤ
Im (a + b i) = b

-- Conjugation of complex numbers retricted to Gaussian integers.
_ᶜ : 𝔾 -> 𝔾
_ᶜ (a + b i) = a + (-ℤ b) i

-- Rank.
rank : 𝔾 -> ℕ
rank (a + b i) = ∣ a *ℤ a +ℤ b *ℤ b ∣

-- Boolean equality on ℤ.
_==ℤ_ : ℤ -> ℤ -> Bool
+_ n ==ℤ +_ m = n ≡ᵇ m
+_ n ==ℤ -[1+_] n₁ = false
-[1+_] n ==ℤ +_ n₁ = false
-[1+_] n ==ℤ -[1+_] m = n ≡ᵇ m

-- Boolean equality on 𝔾.
_==_ : 𝔾 -> 𝔾 -> Bool
a + b i == c + d i = (a ==ℤ c) ∧ (b ==ℤ d)

-- NonZero predicate. Intended to use as implicit argument to deal
-- with the zero divisor case.
record NonZero (x : 𝔾) : Set where
  field
    nonZero : T (not ( x == 0𝔾))

-- ----------------------------------------------------------------------
-- Injections

-- I don't have good notation for this.
infix 5 _+0i'
_+0i' : ℤ -> 𝔾
_+0i' n = n + 0ℤ i

-- Injection of naturals are used more often.
infix 5 _+0i
_+0i : ℕ -> 𝔾
_+0i n = + n +0i'


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

open import Setoids.Setoids
open import Functions.Definition
open import Groups.Definition
open import Sets.EquivalenceRelations
open import Groups.Homomorphisms.Definition
open import Groups.Lemmas

module Groups.Homomorphisms.Lemmas {a b c d : _} {A : Set a} {S : Setoid {a} {c} A} {B : Set b} {T : Setoid {b} {d} B} {_+A_ : A → A → A} {_+B_ : B → B → B} {G : Group S _+A_} {H : Group T _+B_} {f : A → B} (hom : GroupHom G H f) where

imageOfIdentityIsIdentity : Setoid._∼_ T (f (Group.0G G)) (Group.0G H)
imageOfIdentityIsIdentity = Equivalence.symmetric (Setoid.eq T) t
  where
    open Group H
    open Setoid T
    id2 : Setoid._∼_ S (Group.0G G) ((Group.0G G) +A (Group.0G G))
    id2 = Equivalence.symmetric (Setoid.eq S) (Group.identRight G)
    r : f (Group.0G G) ∼ f (Group.0G G) +B f (Group.0G G)
    s : 0G +B f (Group.0G G) ∼ f (Group.0G G) +B f (Group.0G G)
    t : 0G ∼ f (Group.0G G)
    t = groupsHaveRightCancellation H (f (Group.0G G)) 0G (f (Group.0G G)) s
    s = Equivalence.transitive (Setoid.eq T) identLeft r
    r = Equivalence.transitive (Setoid.eq T) (GroupHom.wellDefined hom id2) (GroupHom.groupHom hom)

groupHomsCompose : {o t : _} {C : Set o} {U : Setoid {o} {t} C} {_+C_ : C → C → C} {I : Group U _+C_} {g : B → C} (gHom : GroupHom H I g) → GroupHom G I (g ∘ f)
GroupHom.wellDefined (groupHomsCompose {I} {f} gHom) {x} {y} pr = GroupHom.wellDefined gHom (GroupHom.wellDefined hom pr)
GroupHom.groupHom (groupHomsCompose {U = U} {_+C_ = _·C_} {I} {g} gHom) {x} {y} = answer
  where
    open Group I
    answer : (Setoid._∼_ U) ((g ∘ f) (x +A y)) ((g ∘ f) x ·C (g ∘ f) y)
    answer = (Equivalence.transitive (Setoid.eq U)) (GroupHom.wellDefined gHom (GroupHom.groupHom hom {x} {y}) ) (GroupHom.groupHom gHom {f x} {f y})

homRespectsInverse : {x : A} → Setoid._∼_ T (f (Group.inverse G x)) (Group.inverse H (f x))
homRespectsInverse {x} = rightInversesAreUnique H {f x} {f (Group.inverse G x)} (transitive (symmetric (GroupHom.groupHom hom)) (transitive (GroupHom.wellDefined hom (Group.invLeft G)) imageOfIdentityIsIdentity))
  where
    open Setoid T
    open Equivalence eq

zeroImpliesInverseZero : {x : A} → Setoid._∼_ T (f x) (Group.0G H) → Setoid._∼_ T (f (Group.inverse G x)) (Group.0G H)
zeroImpliesInverseZero {x} fx=0 = transitive homRespectsInverse (transitive (inverseWellDefined H fx=0) (invIdent H))
  where
    open Setoid T
    open Equivalence eq

homRespectsInverse' : {a b : A} → Setoid._∼_ T (f (Group.inverse G a) +B f (Group.inverse G b)) (Group.inverse H (f (b +A a)))
homRespectsInverse' {a} {b} = transitive (symmetric (GroupHom.groupHom hom)) (transitive (GroupHom.wellDefined hom (Equivalence.symmetric (Setoid.eq S) (invContravariant G))) (homRespectsInverse))
  where
    open Setoid T
    open Equivalence eq


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

-- Some properties of 'heterogeneous' identity morphisms

module Categories.Morphism.HeterogeneousIdentity.Properties where

open import Level
open import Data.Product using (curry) renaming (_,_ to _,,_)
open import Relation.Binary.PropositionalEquality

open import Categories.Category using (Category; _[_,_]; _[_≈_])
open import Categories.Category.Product
open import Categories.Functor using (Functor) renaming (id to idF)
open import Categories.Functor.Bifunctor
open import Categories.Morphism.HeterogeneousIdentity

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

open Category using (Obj; id)

-- Functor identity laws lifted to heterogeneous identities.

hid-identity : (C : Category o ℓ e) (D : Category o′ ℓ′ e′)
               {F₀ : Obj C → Obj D}
               (F₁ : ∀ {A B} → C [ A , B ] → D [ F₀ A , F₀ B ]) →
               (∀ {A} → D [ F₁ (id C {A}) ≈ id D ]) →
               ∀ {A B} (p : A ≡ B) → D [ F₁ (hid C p) ≈ hid D (cong F₀ p) ]
hid-identity C D F₁ hyp refl = hyp

hid-identity₂ : (C₁ : Category o ℓ e) (C₂ : Category o′ ℓ′ e′)
                (D : Category o″ ℓ″ e″)
                {F₀ : Obj C₁ → Obj C₂ → Obj D}
                (F₁ : ∀ {A₁ A₂ B₁ B₂} → C₁ [ A₁ , B₁ ] → C₂ [ A₂ , B₂ ] →
                      D [ F₀ A₁ A₂ , F₀ B₁ B₂ ]) →
                (∀ {A₁ A₂} → D [ F₁ (id C₁ {A₁}) (id C₂ {A₂}) ≈ id D ]) →
                ∀ {A₁ A₂ B₁ B₂} (p : A₁ ≡ B₁) (q : A₂ ≡ B₂) →
                D [ F₁ (hid C₁ p) (hid C₂ q) ≈ hid D (cong₂ F₀ p q) ]
hid-identity₂ C₁ C₂ D F₁ hyp refl refl = hyp

module _ {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
         (F : Functor C D) where
  open Category D
  open Functor F

  -- functors preserve heterogeneous identities

  F-hid : ∀ {A B} (p : A ≡ B) → F₁ (hid C p) ≈ hid D (cong F₀ p)
  F-hid = hid-identity C D F₁ identity

module _ {C₁ : Category o ℓ e} {C₂ : Category o′ ℓ′ e′}
         {D : Category o″ ℓ″ e″} (F : Bifunctor C₁ C₂ D) where
  open Category D
  open Functor F

  -- bifunctors preserve heterogeneous identities

  BF-hid : ∀ {A₁ A₂ B₁ B₂} (p : A₁ ≡ B₁) (q : A₂ ≡ B₂) →
           F₁ (hid C₁ p ,, hid C₂ q) ≈ hid D (cong₂ (curry F₀) p q)
  BF-hid = hid-identity₂ C₁ C₂ D (curry F₁) identity

module _ (C : Category o ℓ e) (D : Category o′ ℓ′ e′) where
  open Category (Product C D)

  -- products preserve heterogeneous identities

  ×-hid : ∀ {A₁ A₂ B₁ B₂} (p : A₁ ≡ B₁) (q : A₂ ≡ B₂) →
          (hid C p ,, hid D q) ≈ hid (Product C D) (cong₂ _,,_ p q)
  ×-hid p q = BF-hid {C₁ = C} {C₂ = D} (idF ⁂ idF) p q


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bijections
------------------------------------------------------------------------

module Function.Bijection where

open import Data.Product
open import Level
open import Relation.Binary
open import Function.Equality as F
  using (_⟶_; _⟨$⟩_) renaming (_∘_ to _⟪∘⟫_)
open import Function.Injection   as Inj  hiding (id; _∘_)
open import Function.Surjection  as Surj hiding (id; _∘_)
open import Function.LeftInverse as Left hiding (id; _∘_)

-- Bijective functions.

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

  open Surjective surjective public

  left-inverse-of : from LeftInverseOf to
  left-inverse-of x = injective (right-inverse-of (to ⟨$⟩ x))

-- The set of all bijections between two setoids.

record Bijection {f₁ f₂ t₁ t₂}
                 (From : Setoid f₁ f₂) (To : Setoid t₁ t₂) :
                 Set (f₁ ⊔ f₂ ⊔ t₁ ⊔ t₂) where
  field
    to        : From ⟶ To
    bijective : Bijective to

  open Bijective bijective public

  injection : Injection From To
  injection = record
    { to        = to
    ; injective = injective
    }

  surjection : Surjection From To
  surjection = record
    { to         = to
    ; surjective = surjective
    }

  open Surjection surjection public
    using (equivalence; right-inverse; from-to)

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

  open LeftInverse left-inverse public using (to-from)

-- Identity and composition. (Note that these proofs are superfluous,
-- given that Bijection is equivalent to Function.Inverse.Inverse.)

id : ∀ {s₁ s₂} {S : Setoid s₁ s₂} → Bijection S S
id {S = S} = record
  { to        = F.id
  ; bijective = record
    { injective  =  Injection.injective   (Inj.id {S = S})
    ; surjective = Surjection.surjective (Surj.id {S = S})
    }
  }

infixr 9 _∘_

_∘_ : ∀ {f₁ f₂ m₁ m₂ t₁ t₂}
        {F : Setoid f₁ f₂} {M : Setoid m₁ m₂} {T : Setoid t₁ t₂} →
      Bijection M T → Bijection F M → Bijection F T
f ∘ g = record
  { to        = to f ⟪∘⟫ to g
  ; bijective = record
    { injective  =  Injection.injective   (Inj._∘_  (injection f)  (injection g))
    ; surjective = Surjection.surjective (Surj._∘_ (surjection f) (surjection g))
    }
  } where open Bijection


module BTree.Heap {A : Set}(_≤_ : A → A → Set) where

open import BTree {A}

data Heap : BTree → Set where
  leaf : Heap leaf
  single : (x : A)
                   → Heap (node x leaf leaf)
  left : {l r : BTree}{x y : A}
                   → x ≤ y
                   → Heap (node y l r)
                   → Heap (node x (node y l r) leaf)
  right : {l r : BTree}{x y : A}
                   → x ≤ y
                   → Heap (node y l r)
                   → Heap (node x leaf (node y l r))
  both : {l r l' r' : BTree}{x y y' : A}
                   → x ≤ y
                   → x ≤ y'
                   → Heap (node y l r)
                   → Heap (node y' l' r')
                   → Heap (node x (node y l r) (node y' l' r'))


module Identity where

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

elim== : {A : Set}(x : A)(C : (y : A) -> x == y -> Set) ->
         C x refl -> (y : A) -> (p : x == y) -> C y p
elim== x C Cx .x refl = Cx

elim==₁ : {A : Set}(x : A)(C : (y : A) -> x == y -> Set1) ->
	  C x refl -> (y : A) -> (p : x == y) -> C y p
elim==₁ x C Cx .x refl = Cx

sym : {A : Set}{x y : A} -> x == y -> y == x
sym {A}{x}{y} eq = elim== x (\z _ -> z == x) refl y eq

cong : {A B : Set}(f : A -> B){x y : A} -> x == y -> f x == f y
cong {A} f {x}{y} eq = elim== x (\z _ -> f x == f z) refl y eq

subst : {A : Set}{x y : A}(P : A -> Set) -> x == y -> P x -> P y
subst P xy px = elim== _ (\z _ -> P z) px _ xy

subst₁ : {A : Set}{x y : A}(P : A -> Set1) -> x == y -> P x -> P y
subst₁ P xy px = elim==₁ _ (\z _ -> P z) px _ xy

symRef : (A : Set)(x : A) -> sym (refl{A}{x}) == refl
symRef A x = refl

symSym : {A : Set}{x y : A}(p : x == y) -> sym (sym p) == p
symSym {A}{x}{y} p = elim== x (\y q -> sym (sym q) == q) refl y p

-- Proving the symmetric elimination rule is not trivial.
elimS : {A : Set}(x : A)(C : (y : A) -> y == x -> Set) ->
        C x refl -> (y : A) -> (p : y == x) -> C y p
elimS x C r y p = subst (C y) (symSym p) h
  where
    h : C y (sym (sym p))
    h = elim== x (\y p -> C y (sym p)) r y (sym p)

data _==¹_ {A : Set1}(x : A) : {B : Set1} -> B -> Set where
  refl¹ : x ==¹ x

subst¹ : {A : Set1}{x y : A}(P : A -> Set) -> x ==¹ y -> P x -> P y
subst¹ {A} P refl¹ px = px


module Structure.Monoid.Laws where

open import Prelude

record MonoidLaws {a} (A : Set a) {{Mon : Monoid A}} : Set a where
  field
    idLeft  : (x : A)     → mempty <> x ≡ x
    idRight : (x : A)     → x <> mempty ≡ x
    <>assoc : (x y z : A) → x <> (y <> z) ≡ (x <> y) <> z

open MonoidLaws {{...}} public

{-# DISPLAY MonoidLaws.idLeft _ = idLeft   #-}
{-# DISPLAY MonoidLaws.idRight _ = idRight #-}
{-# DISPLAY MonoidLaws.<>assoc _ = <>assoc #-}

instance
  MonoidLawsList : ∀ {a} {A : Set a} → MonoidLaws (List A)
  idLeft  {{MonoidLawsList}} xs       = refl
  idRight {{MonoidLawsList}} []       = refl
  idRight {{MonoidLawsList}} (x ∷ xs) = x ∷_ $≡ idRight xs
  <>assoc {{MonoidLawsList}} []       ys zs = refl
  <>assoc {{MonoidLawsList}} (x ∷ xs) ys zs = x ∷_ $≡ <>assoc xs ys zs

  MonoidLawsMaybe : ∀ {a} {A : Set a} {{_ : Monoid A}} {{_ : MonoidLaws A}} → MonoidLaws (Maybe A)
  idLeft  {{MonoidLawsMaybe}} x     = refl
  idRight {{MonoidLawsMaybe}} nothing  = refl
  idRight {{MonoidLawsMaybe}} (just _) = refl
  <>assoc {{MonoidLawsMaybe}} nothing  y z = refl
  <>assoc {{MonoidLawsMaybe}} (just x) y z = refl

  -- Can't do function lifting because no extentionality.


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

open import Relation.Binary.Core

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

open import Algebra.Core
open import Data.Product

LeftBol : Op₂ A → Set _
LeftBol _∙_ = ∀ x y z → (x ∙ (y ∙ (x ∙ z))) ≈ ((x ∙ (y ∙ z)) ∙ z )

RightBol : Op₂ A → Set _
RightBol _∙_ = ∀ x y z → (((z ∙ x) ∙ y) ∙ x) ≈ (z ∙ ((x ∙ y) ∙ x))

MoufangIdentity₁ : Op₂ A → Set _
MoufangIdentity₁  _∙_  = ∀ x y z → (z ∙ (x ∙ (z ∙ y))) ≈ (((z ∙ x) ∙ z) ∙ y)

MoufangIdentity₂ : Op₂ A → Set _
MoufangIdentity₂ _∙_ = ∀ x y z → (x ∙ (z ∙ (y ∙ z))) ≈ (((x ∙ z) ∙ y) ∙ z)

MoufangIdentity₃ : Op₂ A → Set _
MoufangIdentity₃ _∙_ = ∀ x y z → ((z ∙ x) ∙ (y ∙ z)) ≈ ((z ∙ (x ∙ y)) ∙ z)

MoufangIdentity₄ : Op₂ A → Set _
MoufangIdentity₄ _∙_ = ∀ x y z → ((z ∙ x) ∙ (y ∙ z)) ≈ (z ∙ ((x ∙ y) ∙ z))


------------------------------------------------------------------------------
-- Testing the translation of definitions
------------------------------------------------------------------------------

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

module Definition01d where

infixl 6 _+_
infix  4 _≡_

postulate
  D    : Set
  zero : D
  succ : D → D
  _≡_  : D → D → Set

data N : D → Set where
  zN : N zero
  sN : ∀ {n} → N n → N (succ n)

N-ind : (A : D → Set) →
       A zero →
       (∀ {n} → A n → A (succ n)) →
       ∀ {n} → N n → A n
N-ind A A0 h zN      = A0
N-ind A A0 h (sN Nn) = h (N-ind A A0 h Nn)

postulate
  _+_  : D → D → D
  +-0x : ∀ n → zero + n     ≡ n
  +-Sx : ∀ m n → succ m + n ≡ succ (m + n)
{-# ATP axioms +-0x +-Sx #-}

-- We test the translation of the definition of a unary predicate.

A : D → Set
A i = zero + i ≡ i
{-# ATP definition A #-}

postulate A0 : A zero
{-# ATP prove A0 #-}

postulate is : ∀ {i} → A i → A (succ i)
{-# ATP prove is #-}

+-leftIdentity : ∀ {n} → N n → zero + n ≡ n
+-leftIdentity = N-ind A A0 is


------------------------------------------------------------------------------
-- FOTC list terms properties
------------------------------------------------------------------------------

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

module FOTC.Base.List.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- Congruence properties

∷-leftCong : ∀ {x y xs} → x ≡ y → x ∷ xs ≡ y ∷ xs
∷-leftCong refl = refl

∷-rightCong : ∀ {x xs ys} → xs ≡ ys → x ∷ xs ≡ x ∷ ys
∷-rightCong refl = refl

∷-cong : ∀ {x y xs ys} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
∷-cong refl refl = refl

headCong : ∀ {xs ys} → xs ≡ ys → head₁ xs ≡ head₁ ys
headCong refl = refl

tailCong : ∀ {xs ys} → xs ≡ ys → tail₁ xs ≡ tail₁ ys
tailCong refl = refl

------------------------------------------------------------------------------
-- Injective properties

∷-injective : ∀ {x y xs ys} → x ∷ xs ≡ y ∷ ys → x ≡ y ∧ xs ≡ ys
∷-injective {x} {y} {xs} {ys} h = x≡y , xs≡ys
  where
  x≡y : x ≡ y
  x≡y = x              ≡⟨ sym (head-∷ x xs) ⟩
        head₁ (x ∷ xs) ≡⟨ headCong h ⟩
        head₁ (y ∷ ys) ≡⟨ head-∷ y ys ⟩
        y              ∎

  xs≡ys : xs ≡ ys
  xs≡ys = xs             ≡⟨ sym (tail-∷ x xs) ⟩
          tail₁ (x ∷ xs) ≡⟨ tailCong h ⟩
          tail₁ (y ∷ ys) ≡⟨ tail-∷ y ys ⟩
          ys             ∎


module examplesPaperJFP.StatefulObject where

open import Data.Product
open import Data.String.Base as Str
open import Data.Nat.Base as N
open import Data.Vec as Vec using (Vec; []; _∷_; head; tail)

open import SizedIO.Console hiding (main)
open import Size

open import NativeIO

open import SizedIO.Base

StackStateˢ = ℕ

record Interfaceˢ : Set₁ where
  field  Stateˢ    :  Set
         Methodˢ   :  (s : Stateˢ)  →  Set
         Resultˢ   :  (s : Stateˢ)  →  (m : Methodˢ s)  →  Set
         nextˢ     :  (s : Stateˢ)  →  (m : Methodˢ s)  →  (r : Resultˢ s m) → Stateˢ

open Interfaceˢ public

data StackMethodˢ (A : Set) : (n : StackStateˢ) → Set where
  push  :  ∀ {n}  →  A  →  StackMethodˢ A n
  pop   :  ∀ {n}        →  StackMethodˢ A (suc n)

StackResultˢ                      :  (A : Set) → (s : StackStateˢ) → StackMethodˢ A s → Set
StackResultˢ A _  (push _)  =  Unit
StackResultˢ A _  pop       =  A

stackNextˢ  :  ∀ A n (m : StackMethodˢ A n) (r : StackResultˢ A n m) →  StackStateˢ
stackNextˢ _  n        (push _)  _  =  suc n
stackNextˢ _  (suc n)  pop       _  =  n

StackInterfaceˢ : (A : Set)  →  Interfaceˢ
Stateˢ   (StackInterfaceˢ A)  =  StackStateˢ
Methodˢ  (StackInterfaceˢ A)  =  StackMethodˢ A
Resultˢ  (StackInterfaceˢ A)  =  StackResultˢ A
nextˢ    (StackInterfaceˢ A)  =  stackNextˢ A

record Objectˢ (I : Interfaceˢ) (s : Stateˢ I) : Set where
  coinductive
  field objectMethod :  (m : Methodˢ I s) →
                        Σ[ r ∈ Resultˢ I s m ] Objectˢ I (nextˢ I s m r)
open Objectˢ public

record IOObjectˢ (Iᵢₒ : IOInterface) (I : Interfaceˢ) (s : Stateˢ I) : Set where
  coinductive
  field method :  (m : Methodˢ I s) →
                  IO Iᵢₒ ∞ (Σ[ r ∈ Resultˢ I s m ] IOObjectˢ Iᵢₒ I (nextˢ I s m r))
open IOObjectˢ public

stack  :  ∀{A}{n : ℕ} (as : Vec A n) →  Objectˢ (StackInterfaceˢ A) n
objectMethod (stack as)        (push a)  =  unit  ,  stack (a ∷ as)
objectMethod (stack (a ∷ as))  pop       =  a     ,  stack as


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

open import Categories.Category

-- a zero object is both terminal and initial.
module Categories.Object.Zero {o ℓ e} (C : Category o ℓ e) where

open import Level using (_⊔_)

open import Categories.Object.Terminal C
open import Categories.Object.Initial C

open import Categories.Morphism C

open Category C
open HomReasoning

record Zero : Set (o ⊔ ℓ ⊔ e) where
 field
   zero : Obj
   !    : ∀ {A} → zero ⇒ A
   ¡    : ∀ {A} → A ⇒ zero

 zero⇒ : ∀ {A B : Obj} → A ⇒ B
 zero⇒ {A} = ! ∘ ¡

 field
   !-unique : ∀ {A} (f : zero ⇒ A) → ! ≈ f
   ¡-unique : ∀ {A} (f : A ⇒ zero) → ¡ ≈ f

 ¡-unique₂ : ∀ {A} (f g : A ⇒ zero) → f ≈ g
 ¡-unique₂ f g = ⟺ (¡-unique f) ○ ¡-unique g

 !-unique₂ : ∀ {A} (f g : zero ⇒ A) → f ≈ g
 !-unique₂ f g = ⟺ (!-unique f) ○ !-unique g

 initial : Initial
 initial = record
   { ⊥        = zero
   ; ⊥-is-initial = record
     { !        = !
     ; !-unique = !-unique
     }
   }

 terminal : Terminal
 terminal = record
   { ⊤        = zero
   ; ⊤-is-terminal = record
     { !        = ¡
     ; !-unique = ¡-unique
     }
   }

 module initial  = Initial initial
 module terminal = Terminal terminal

 !-Mono : ∀ {A} → Mono (! {A})
 !-Mono = from-⊤-is-Mono {t = terminal} !

 ¡-Epi : ∀ {A} → Epi (¡ {A})
 ¡-Epi = to-⊥-is-Epi {i = initial} ¡