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

open import HoTT

module experimental.GlobularTypes where

{- Globular types as a coinductive record -}
record Glob (i : ULevel) : Type (suc i) where
  coinductive
  constructor glob
  field
    Ob : Type i
    Hom : (a b : Ob) → Glob i
open Glob public

{- The terminal globular type -}
Unit-glob : Glob zero
Ob Unit-glob = Unit
Hom Unit-glob _ _ = Unit-glob

{- The tower of identity types -}
Id-glob : ∀ {i} (A : Type i) → Glob zero
Ob (Id-glob A) = A
Hom (Id-glob A) a b = Id-glob (a == b)

{- Bisimulation between globular types -}
record _~_ {i} (G H : Glob i) : Type (suc i) where
  coinductive
  constructor glob~
  field
    Ob= : Ob G == Ob H
    Hom= : {a : Ob G} {a' : Ob H} (p : a == a' [ (λ x → x) ↓ Ob= ])
           {b : Ob G} {b' : Ob H} (q : b == b' [ (λ x → x) ↓ Ob= ])
           → Hom G a b ~ Hom H a' b'
open _~_ public

=-to-~ : ∀ {i} {G H : Glob i} → G == H → G ~ H
Ob= (=-to-~ p) = ap Ob p
Hom= (=-to-~ p) q r =
  =-to-~ (↓-app→cst-out (↓-→-out (apd Hom p)
                                 (↓-ap-out _ Ob p q))
                        (↓-ap-out _ Ob p r))
-- The definition of [Hom= (=-to-~ p) q r] would/should just be
-- [=-to-~ (apd Hom p q r)] in infinite-dimensional type theory, but here we
-- need to add a lot of non-sense to make it type-check.

{-
We postulate that bisimilarity is equality, because this should be true.
-}
postulate
  bisim-is-equiv : ∀ {i} {G H : Glob i} → is-equiv (=-to-~ :> (G == H → G ~ H))

bisim-equiv : ∀ {i} {G H : Glob i} → (G == H) ≃ (G ~ H)
bisim-equiv = (=-to-~ , bisim-is-equiv)

bisim : ∀ {i} {G H : Glob i} → (G ~ H) → G == H
bisim e = <– bisim-equiv e

{-
The type of globular types is the terminal coalgebra of the appropriate thing.
This is proved in the following two lemmas.
-}

Glob-corec : ∀ {i} {A : Type (suc i)} (Ob* : A → Type i)
  (Hom* : (x : A) (a b : Ob* x) → A) → (A → Glob i)
Ob (Glob-corec Ob* Hom* x) = Ob* x
Hom (Glob-corec Ob* Hom* x) a b = Glob-corec Ob* Hom* (Hom* x a b)

eta : ∀ {i} {A : Type (suc i)} (Ob* : A → Type i)
  (Hom* : (x : A) (a b : Ob* x) → A)
  (f g : A → Glob i) (s : (x : A) → f x ~ g x) → f == g
eta Ob* Hom* f g s = funext (λ x → bisim (s x))


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

open import Level
open import Data.Product using (Σ; _,_; Σ-syntax; uncurry; proj₂)

open import Categories.Support.PropositionalEquality

open import Categories.Category
open import Categories.Functor using (Functor; module Functor)
open import Categories.Cones
open import Categories.Object.Terminal as T using (Terminal; module Terminal)
import Categories.Morphisms as Mor
open import Categories.Cone using (module Cone; module ConeOver)

module LimitsOf {o ℓ e} {o′ ℓ′ e′} {C : Category o ℓ e} {J : Category o′ ℓ′ e′} (F : Functor J C) where

  private module L = Terminal

  open Category C
  open Category J using () renaming (Obj to Dot)
  open Functor F
  open Mor C using (_≅_; _≡ⁱ_)
  open Mor (Cones F) using () renaming (_≅_ to _⇿_; _≡ⁱ_ to _≜ⁱ_)
  open Category (Cones F) using () renaming (Obj to Cone; _≡_ to _≜₁_; _∘_ to _▵_; _⇒_ to _⇾_; id to id▵)
  open ConeOver F using (_≜_; ≜-refl; ≜-sym; ≜-trans; heterogenize; homogenize; ConeUnder; tether; untether; _≜′_) renaming (module _≜_ to ≜; module _≜′_ to ≜′)
  open Heterogeneous C

  -- Isomorphic to an terminal object, but worth keeping distinct in case we change its definition
  record Limit : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
    field
      terminal : Terminal (Cones F)

    private module terminal = Terminal terminal
    module Fl = Float F

    {-
    vertex : Obj
    vertex = Cone.N terminal.⊤

    proj : ∀ j → vertex ⇒ F₀ j
    proj = Cone.ψ terminal.⊤

    proj-cone : Cone
    proj-cone = terminal.⊤
    -}

    open terminal public using () renaming (⊤ to proj-cone)
    open Cone proj-cone public using () renaming (N to vertex; ψ to proj)

    rep-cone : (K : Cone) → (K ⇾ proj-cone)
    rep-cone K = terminal.! {K}

    rep : (K : Cone) → (Cone.N K ⇒ vertex)
    rep K = ConeMorphism.f (terminal.! {K})

    unrep : ∀ {X} → (X ⇒ vertex) → Cone
    unrep f = record
      { N = domain f
      ; ψ = λ j → proj j ∘ f
      ; commute = λ l → Equiv.trans (Equiv.sym assoc) (∘-resp-≡ˡ (commute l))
      }
      where
      open Cone proj-cone

    conify : ∀ {X} (f : X ⇒ vertex) → (unrep f ⇾ proj-cone)
    conify f = record { f = f; commute = Equiv.refl }

    unrep-cone : ∀ {K : Cone} → (K ⇾ proj-cone) → Cone
    unrep-cone κ = unrep (ConeMorphism.f κ)

    commute-cone : ∀ {K : Cone} → unrep-cone (rep-cone K) ≜ K
    commute-cone {K} = record
      { N-≣ = ≣-refl
      ; ψ-≡ = λ j → ≡⇒∼ (Equiv.sym (ConeMorphism.commute (rep-cone K)))
      }

    .commute : ∀ K j → proj j ∘ rep K ≡ Cone.ψ K j
    commute K = λ j → Equiv.sym (ConeMorphism.commute (rep-cone K))

    private
      domain▵ : ∀ {X Y} → X ⇾ Y → Cone
      domain▵ {X} _ = X

    .universal-cone : ∀ {K : Cone} {i : K ⇾ proj-cone} → unrep-cone i ≜ K → Cones F [ rep-cone K ≡ i ]
    universal-cone {K} {i} pf = terminal.!-unique i

    .universal : ∀ {K : Cone} {i : Cone.N K ⇒ vertex} → unrep i ≜ K → rep K ≡ i
    universal {K} {i} pf = terminal.!-unique (Fl.floatʳ (heterogenize (homogenize pf ≣-refl)) (conify i))
    -- complicated, isn't it?  but it's necessary in order to make the float
    --   compute enough for the !-unique to typecheck.  by replacing the
    --   N-≣ in pf with ≣-refl we can make it happen!

    g-η-cone₀ : ∀ {K} {κ : K ⇾ proj-cone} → K ≜ unrep-cone κ
    g-η-cone₀ {K} {κ} = record { N-≣ = ≣-refl; ψ-≡ = λ j → ≡⇒∼ (ConeMorphism.commute κ) }

    .g-η-cone : ∀ {K} {κ : K ⇾ proj-cone} → rep-cone (unrep-cone κ) ≜₁ Fl.floatʳ (g-η-cone₀ {κ = κ}) κ
    g-η-cone {κ = κ} = terminal.!-unique (Fl.floatʳ (g-η-cone₀ {κ = κ}) κ)

    .g-η : ∀ {X} {f : X ⇒ vertex} → rep (unrep f) ≡ f
    g-η {f = f} = terminal.!-unique (conify f)

    .η-cone : Cones F [ rep-cone proj-cone ≡ Category.id (Cones F) ]
    η-cone = terminal.⊤-id (rep-cone proj-cone)

    .η : rep proj-cone ≡ id
    η = η-cone

    .rep-cone-cong : ∀ {K₁ K₂} (K₁≜K₂ : K₁ ≜ K₂) → Cones F [ Fl.floatʳ K₁≜K₂ (rep-cone K₁) ≡ rep-cone K₂ ]
    rep-cone-cong {K₁} {K₂} K₁≜K₂ =
      Equiv.sym (terminal.!-unique (Fl.floatʳ K₁≜K₂ (rep-cone K₁)))

    .rep-cong′ : ∀ {N} {K₁ K₂ : ConeUnder N} → K₁ ≜′ K₂ → rep (untether K₁) ≡ rep (untether K₂)
    rep-cong′ {N} {K₁} {K₂} K₁≜′K₂ =
      Equiv.sym (terminal.!-unique (Fl.floatʳ (heterogenize K₁≜′K₂) (rep-cone (untether K₁))))

    rep-cong : ∀ {K₁ K₂} → K₁ ≜ K₂ → rep K₁ ∼ rep K₂
    rep-cong K₁≜K₂ =
      ≡⇒∼ʳ (≜.N-≣ K₁≜K₂) (rep-cone-cong K₁≜K₂)

    .rep-cone∘ : ∀ {K K′} {q : K′ ⇾ K} → Cones F [ Cones F [ rep-cone K ∘ q ] ≡ rep-cone K′ ]
    rep-cone∘ {K} {q = q} = Equiv.sym (terminal.!-unique (rep-cone K ▵ q))

    .rep∘ : ∀ {K K′} {q : K′ ⇾ K} → rep K ∘ ConeMorphism.f q ≡ rep K′
    rep∘ {K} {K′} {q} = rep-cone∘ {K} {K′} {q}

    .rep-cone-self-id : rep-cone proj-cone ≜₁ id▵
    rep-cone-self-id = terminal.!-unique id▵

    .rep-self-id : rep proj-cone ≡ id
    rep-self-id = terminal.!-unique id▵

  open Limit

  -- Properties
  --
  -- These are a little different from the raw ones for Terminal since they
  -- deal with isomorphisms in C instead of in Cones F.

  -- First, a lemma:

  open import Categories.Square

  -- do these lemmas belong in Cones?

  isos-lift-to-cones : ∀ (κ : Cone) {v : Obj} → Cone.N κ ≅ v → Σ[ κ′ ∈ Cone ] κ ⇿ κ′
  isos-lift-to-cones κ {v} κ≅v =
      record
      { N = v
      ; ψ = λ X → (Cone.ψ κ X) ∘ g
      ; commute = λ f' → pullˡ (Cone.commute κ f')
      }
    , record
      { f = record { f = f; commute = Equiv.sym (cancelRight isoˡ) }
      ; g = record { f = g; commute = Equiv.refl }
      ; iso = record { isoˡ = isoˡ; isoʳ = isoʳ }
      }
    where
    open Mor._≅_ κ≅v
    open GlueSquares C

  isos-lower-from-cones : ∀ {κ₁ κ₂ : Cone} → κ₁ ⇿ κ₂ → Cone.N κ₁ ≅ Cone.N κ₂
  isos-lower-from-cones κ₁⇿κ₂ = record
    { f = ConeMorphism.f f
    ; g = ConeMorphism.f g
    ; iso = record { isoˡ = isoˡ; isoʳ = isoʳ }
    }
    where
    open Mor._≅_ κ₁⇿κ₂

  ≜ⁱ⇒≡ⁱ : ∀ {κ₁ κ₂} {i₁ i₂ : κ₁ ⇿ κ₂} → i₁ ≜ⁱ i₂
        → isos-lower-from-cones i₁ ≡ⁱ isos-lower-from-cones i₂
  ≜ⁱ⇒≡ⁱ pf = record { f-≡ = f-≡; g-≡ = g-≡ }
    where open Mor._≡ⁱ_ pf

  up-to-iso-cone : (L₁ L₂ : Limit) → proj-cone L₁ ⇿ proj-cone L₂
  up-to-iso-cone L₁ L₂ = T.up-to-iso (Cones F) (terminal L₁) (terminal L₂)

  up-to-iso : (L₁ L₂ : Limit) → vertex L₁ ≅ vertex L₂
  up-to-iso L₁ L₂ = isos-lower-from-cones (up-to-iso-cone L₁ L₂)

  transport-by-iso-cone : (L : Limit) {κ : Cone} → proj-cone L ⇿ κ → Limit
  transport-by-iso-cone L L⇿κ = record
    { terminal = T.transport-by-iso (Cones F) (terminal L) L⇿κ
    }

  transport-by-iso : (L : Limit) {v : Obj} → vertex L ≅ v → Limit
  transport-by-iso L L≅v = transport-by-iso-cone L (proj₂ p)
    where p = isos-lift-to-cones (proj-cone L) L≅v

  .up-to-iso-cone-unique : ∀ L L′ → (i : proj-cone L ⇿ proj-cone L′) → up-to-iso-cone L L′ ≜ⁱ i
  up-to-iso-cone-unique L L′ i = T.up-to-iso-unique (Cones F) (terminal L) (terminal L′) i

  -- XXX probably not true -- what is?  only the above?
  -- .up-to-iso-unique : ∀ L L′ → (i : vertex L ≅ vertex L′) → up-to-iso L L′ ≡ⁱ i
  -- up-to-iso-unique L L′ i = ≜ⁱ⇒≡ⁱ {!up-to-iso-unique-cone L L′ !}

  .up-to-iso-cone-invˡ : ∀ {L κ} {i : proj-cone L ⇿ κ} → up-to-iso-cone L (transport-by-iso-cone L i) ≜ⁱ i
  up-to-iso-cone-invˡ {L} {i = i} = up-to-iso-cone-unique L (transport-by-iso-cone L i) i

  .up-to-iso-invˡ : ∀ {L X} {i : vertex L ≅ X} → up-to-iso L (transport-by-iso L i) ≡ⁱ i
  up-to-iso-invˡ {L₁} {i = i} = ≜ⁱ⇒≡ⁱ (up-to-iso-cone-invˡ {L₁} {i = proj₂ (isos-lift-to-cones (proj-cone L₁) i)})

  up-to-iso-cone-invʳ : ∀ {L L′} → proj-cone (transport-by-iso-cone L (up-to-iso-cone L L′)) ≜ proj-cone L′
  up-to-iso-cone-invʳ {L} {L′} = ≜-refl

  up-to-iso-invʳ : ∀ {L L′} → vertex (transport-by-iso L (up-to-iso L L′)) ≣ vertex L′
  up-to-iso-invʳ {t} {t′} = ≣-refl


{-

  Generic UARel, DUARel, and SubstRel: the path relation is always univalent

-}
{-# OPTIONS --safe #-}
module Cubical.Displayed.Generic where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport

open import Cubical.Displayed.Base
open import Cubical.Displayed.Subst

private
  variable
    ℓ ℓA ℓA' ℓP ℓ≅A ℓ≅A' ℓB ℓB' ℓ≅B ℓ≅B' ℓC ℓ≅C : Level

-- UARel for an arbitrary type

𝒮-generic : (A : Type ℓA) → UARel A ℓA
UARel._≅_ (𝒮-generic A) = _≡_
UARel.ua (𝒮-generic A) a a' = idEquiv (a ≡ a')

-- DUARel for an arbitrary family

𝒮ᴰ-generic : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) → DUARel 𝒮-A B ℓB
𝒮ᴰ-generic 𝒮-A B .DUARel._≅ᴰ⟨_⟩_ b p b' = PathP (λ i → B (UARel.≅→≡ 𝒮-A p i)) b b'
𝒮ᴰ-generic 𝒮-A B .DUARel.uaᴰ b p b' = idEquiv _

-- SubstRel for an arbitrary family

𝒮ˢ-generic : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (B : A → Type ℓB) → SubstRel 𝒮-A B
𝒮ˢ-generic 𝒮-A B .SubstRel.act p = substEquiv B (UARel.≅→≡ 𝒮-A p)
𝒮ˢ-generic 𝒮-A B .SubstRel.uaˢ p b = refl


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Library.Data.Product where

open import Light.Level using (Level ; Setω)
open import Light.Variable.Sets
open import Light.Variable.Levels
import Light.Library.Data.Both as Both
open import Light.Library.Relation.Binary
      using (SelfTransitive ; SelfSymmetric ; Reflexive)
open import Light.Library.Relation.Binary.Equality.Decidable using (DecidableEquality)

record Dependencies : Setω where

record Library (dependencies : Dependencies) : Setω where
      field
            ℓf : Level → Level → Level
            Σ : ∀ (𝕒 : Set aℓ) → (𝕒 → Set bℓ) → Set (ℓf aℓ bℓ)
            both : ∀ {𝕓 : 𝕒 → Set bℓ} a (b : 𝕓 a) → Σ 𝕒 𝕓
            first : ∀ {𝕓 : 𝕒 → Set bℓ} → Σ 𝕒 𝕓 → 𝕒
            second : ∀ {𝕓 : 𝕒 → Set bℓ} (product : Σ 𝕒 𝕓) → 𝕓 (first product)
            ⦃ equals ⦄ :
                  ∀ ⦃ a‐c‐equals : DecidableEquality 𝕒 𝕔 ⦄ ⦃ b‐d‐equals : DecidableEquality 𝕓 𝕕 ⦄
                  → DecidableEquality (Σ 𝕒 (λ _ → 𝕓)) (Σ 𝕔 (λ _ → 𝕕))

      ∃ : ∀ {𝕒 : Set aℓ} → (𝕒 → Set bℓ) → Set (ℓf aℓ bℓ)
      ∃ = Σ _

      instance both‐library : Both.Library record {}
      both‐library = record
            {
                  Both = λ 𝕒 𝕓 → Σ 𝕒 (λ _ → 𝕓) ;
                  ℓf = ℓf ;
                  both = both ;
                  first = first ;
                  second = second ;
                  equals = equals
            }

open Library ⦃ ... ⦄ public


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.Equiv-Polyn-nPoly where

open import Cubical.Foundations.Everything

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

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Polynomials.Univariate.Base
open import Cubical.Algebra.CommRing.Instances.UnivariatePoly

open import Cubical.Algebra.Polynomials.Multivariate.Base
open import Cubical.Algebra.Polynomials.Multivariate.Properties
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly
open import Cubical.Algebra.Polynomials.Multivariate.Equiv.Poly0-A
open import Cubical.Algebra.Polynomials.Multivariate.Equiv.Poly1-Poly
open import Cubical.Algebra.Polynomials.Multivariate.Equiv.Comp-Poly
open import Cubical.Algebra.Polynomials.Multivariate.Equiv.Induced-Poly

open Nth-Poly-structure
open CommRingEquivs renaming (compCommRingEquiv to _∘-ecr_ ; invCommRingEquiv to inv-ecr)

private variable
  ℓ : Level

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

nPoly : (A' : CommRing ℓ) → (n : ℕ) → CommRing ℓ
nPoly A' zero = A'
nPoly A' (suc n) = UnivariatePoly (nPoly A' n)

Equiv-Polyn-nPoly : (A' : CommRing ℓ) → (n : ℕ) → CommRingEquiv (PolyCommRing A' n) (nPoly A' n)
Equiv-Polyn-nPoly A' zero = CRE-Poly0-A A'
Equiv-Polyn-nPoly A' (suc n) = inv-ecr _ _ (CRE-PolyN∘M-PolyN+M A' 1 n)
                               ∘-ecr (lift-equiv-poly _ _ (Equiv-Polyn-nPoly A' n) 1
                               ∘-ecr CRE-Poly1-Poly: (nPoly A' n))


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

module Math.NumberTheory.Product.Generic where

-- agda-stdlib
open import Algebra

-- agda-misc
open import Math.NumberTheory.Summation.Generic

-- TODO add syntax
module MonoidProduct {c e} (M : Monoid c e) =
  MonoidSummation M
  renaming
  ( Σ< to Π<
  ; Σ≤ to Π≤
  ; Σ<range to Π<range
  ; Σ≤range to Π≤range
  )
  using ()


module IORef where

  data Unit : Set where
    unit : Unit

  data Pair (A B : Set) : Set where
    pair : A -> B -> Pair A B

  fst : {A B : Set} -> Pair A B -> A
  fst (pair a b) = a

  snd : {A B : Set} -> Pair A B -> B
  snd (pair a b) = b

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

  data Fin : Nat -> Set where
    fz : {n : Nat} -> Fin (suc n)
    fs : {n : Nat} -> Fin n -> Fin (suc n)

  infixr 40 _::_
  infixl 20 _!_

  data Vec (A : Set) : Nat -> Set where
    []   : Vec A zero
    _::_ : {n : Nat} -> A -> Vec A n -> Vec A (suc n)

  _!_ : {A : Set}{n : Nat} -> Vec A n -> Fin n -> A
  []	  ! ()
  x :: _  ! fz	   = x
  _ :: xs ! (fs i) = xs ! i

  Loc : Nat -> Set
  Loc = Fin

  -- A universe. IORefs can store data of type el(u), for some u : U
  postulate
    U : Set
    el : U -> Set

  -- Shapes tell you what types live on the heap.
  Shape : Nat -> Set
  Shape n = Vec U n -- Fin n -> U

  -- Shapes can grow as you allocate new memory
  _||_ : {n : Nat} -> Shape n -> U -> Shape (suc n)
  xs || u = u :: xs

  infixl 40 _▻_
  infixl 60 _[_:=_] _[_]

  -- The heap maps locations to elements of the right type.
  data Heap : {n : Nat}(s : Shape n) -> Set where
    ε	: Heap []
    _▻_ : {n : Nat}{s : Shape n}{a : U} -> Heap s -> el a -> Heap (s || a)

--   Heap : {n : Nat} -> Shape n -> Set
--   Heap {n} shape = (k : Fin n) -> el (shape ! k)

  _[_:=_] : {n : Nat}{s : Shape n} -> Heap s -> (l : Loc n) -> el (s ! l) -> Heap s
  ε	  [ ()   := _ ]
  (h ▻ _) [ fz   := x ] = h ▻ x
  (h ▻ y) [ fs i := x ] = h [ i := x ] ▻ y

  _[_] : {n : Nat}{s : Shape n} -> Heap s -> (l : Loc n) -> el (s ! l)
  ε	  [ ()	 ]
  (h ▻ x) [ fz	 ] = x
  (h ▻ _) [ fs i ] = h [ i ]

--   (h [ fz := x ]) fz = x
--   (h [ fz := x ]) (fs i) = h (fs i)
--   (h [ fs i := x ]) fz = h fz
--   _[_:=_] {._}{_ :: s} h (fs i) x (fs j) = _[_:=_] {s = s} (\z -> h (fs z)) i x j

  -- Well-scoped, well-typed IORefs
  data IO (A : Set) : {n m : Nat} -> Shape n -> Shape m -> Set where
    Return : {n : Nat}{s : Shape n} -> A -> IO A s s
    WriteIORef : {n m : Nat}{s : Shape n}{t : Shape m} ->
      (loc : Loc n) -> el (s ! loc) -> IO A s t -> IO A s t
    ReadIORef : {n m : Nat}{s : Shape n}{t : Shape m} ->
      (loc : Loc n) -> (el (s ! loc) -> IO A s t) -> IO A s t
    NewIORef : {n m : Nat}{s : Shape n}{t : Shape m}{u : U} ->
      el u -> IO A (s || u) t -> IO A s t

  -- Running IO programs
  run : {A : Set} -> {n m : Nat} -> {s : Shape n} -> {t : Shape m}
       -> Heap s -> IO A s t -> Pair A (Heap t)
  run heap (Return x) = pair x heap
  run heap (WriteIORef l x io) = run (heap [ l := x ]) io
  run heap (ReadIORef l k) = run heap (k (heap [ l ]))
  run heap (NewIORef x k) = run (heap ▻ x) k

  infixr 10 _>>=_ _>>_

  _>>=_ : {A B : Set}{n₁ n₂ n₃ : Nat}{s₁ : Shape n₁}{s₂ : Shape n₂}{s₃ : Shape n₃} ->
	  IO A s₁ s₂ -> (A -> IO B s₂ s₃) -> IO B s₁ s₃
  Return x	   >>= f = f x
  WriteIORef r x k >>= f = WriteIORef r x (k >>= f)
  ReadIORef r k	   >>= f = ReadIORef r (\x -> k x >>= f)
  NewIORef x k	   >>= f = NewIORef x (k >>= f)

  _>>_ : {A B : Set}{n₁ n₂ n₃ : Nat}{s₁ : Shape n₁}{s₂ : Shape n₂}{s₃ : Shape n₃} ->
	 IO A s₁ s₂ -> IO B s₂ s₃ -> IO B s₁ s₃
  a >> b = a >>= \_ -> b

  -- The operations without CPS

  data IORef : {n : Nat}(s : Shape n) -> U -> Set where
    ioRef : {n : Nat}{s : Shape n}(r : Loc n) -> IORef s (s ! r)

  return : {A : Set}{n : Nat}{s : Shape n} -> A -> IO A s s
  return = Return

  writeIORef : {n : Nat}{s : Shape n}{a : U} ->
	       IORef s a -> el a -> IO Unit s s
  writeIORef (ioRef r) x = WriteIORef r x (Return unit)

  readIORef : {n : Nat}{s : Shape n}{a : U} -> IORef s a -> IO (el a) s s
  readIORef (ioRef r) = ReadIORef r Return

  newIORef : {n : Nat}{s : Shape n}{a : U} -> el a -> IO (IORef (s || a) a) s (s || a)
  newIORef x = NewIORef x (Return (ioRef fz))

  -- Some nice properties

  infix 10 _==_ _≡_

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

  subst : {A : Set}(P : A -> Set){x y : A} -> x == y -> P y -> P x
  subst {A} P refl Px = Px

  cong : {A B : Set}(f : A -> B){x y : A} -> x == y -> f x == f y
  cong {A} f refl = refl

  trans : {A : Set}{x y z : A} -> x == y -> y == z -> x == z
  trans {A} refl p = p

  fsteq : {A B : Set}{x y : A}{z w : B} -> pair x z == pair y w -> x == y
  fsteq {A}{B} refl = refl

  -- Lemmas

  update-lookup : {n : Nat}{s : Shape n}(h : Heap s)(r : Loc n)(x : el (s ! r)) ->
		  h [ r := x ] [ r ] == x
  update-lookup ε	()     _
  update-lookup	(h ▻ _) fz     x = refl
  update-lookup (h ▻ _) (fs i) x = update-lookup h i x

  update-update : {n : Nat}{s : Shape n}(h : Heap s)(r : Loc n)(x y : el (s ! r)) ->
		  h [ r := x ] [ r := y ] == h [ r := y ]
  update-update ε	()     _ _
  update-update (h ▻ _)  fz    x y = refl
  update-update (h ▻ z) (fs i) x y = cong (\ ∙ -> ∙ ▻ z) (update-update h i x y)

  -- Equality of monadic computations

  data _≡_ {A : Set}{n m : Nat}{s : Shape n}{t : Shape m}(io₁ io₂ : IO A s t) : Set where
    eqIO : ((h : Heap s) -> run h io₁ == run h io₂) -> io₁ ≡ io₂

  uneqIO : {A : Set}{n m : Nat}{s : Shape n}{t : Shape m}{io₁ io₂ : IO A s t} ->
	   io₁ ≡ io₂ -> (h : Heap s) -> run h io₁ == run h io₂
  uneqIO (eqIO e) = e

  -- Congruence properties

  cong->> : {A B : Set}{n₁ n₂ n₃ : Nat}{s₁ : Shape n₁}{s₂ : Shape n₂}{s₃ : Shape n₃}
	    {io₁₁ io₁₂ : IO A s₁ s₂}{io₂₁ io₂₂ : A -> IO B s₂ s₃} ->
	    io₁₁ ≡ io₁₂ -> ((x : A) -> io₂₁ x ≡ io₂₂ x) -> io₁₁ >>= io₂₁ ≡ io₁₂ >>= io₂₂
  cong->> {A}{B}{s₁ = s₁}{s₂}{s₃}{io₁₁}{io₁₂}{io₂₁}{io₂₂}(eqIO eq₁) eq₂ =
      eqIO (prf io₁₁ io₁₂ io₂₁ io₂₂ eq₁ eq₂)
    where
      prf : {n₁ n₂ n₃ : Nat}{s₁ : Shape n₁}{s₂ : Shape n₂}{s₃ : Shape n₃}
	    (io₁₁ io₁₂ : IO A s₁ s₂)(io₂₁ io₂₂ : A -> IO B s₂ s₃) ->
	    ((h : Heap s₁) -> run h io₁₁ == run h io₁₂) ->
	    ((x : A) -> io₂₁ x ≡ io₂₂ x) ->
	    (h : Heap s₁) -> run h (io₁₁ >>= io₂₁) == run h (io₁₂ >>= io₂₂)
      prf (Return x) (Return y) k₁ k₂ eq₁ eq₂ h =
	  subst (\ ∙ -> run h (k₁ ∙) == run h (k₂ y)) x=y (uneqIO (eq₂ y) h)
	where
	  x=y : x == y
	  x=y = fsteq (eq₁ h)
      prf (WriteIORef r₁ x₁ k₁) (Return y) k₂ k₃ eq₁ eq₂ h = ?
      -- ... boring proofs

  -- Monad laws

    -- boring...

  -- IO laws

  new-read : {n : Nat}{s : Shape n}{a : U}(x : el a) ->
	     newIORef {s = s} x >>= readIORef ≡
	     newIORef x >> return x
  new-read x = eqIO \h -> refl

  write-read : {n : Nat}{s : Shape n}{a : U}(r : IORef s a)(x : el a) ->
	       writeIORef r x >> readIORef r
	       ≡ writeIORef r x >> return x
  write-read (ioRef r) x =
    eqIO \h -> cong (\ ∙ -> pair ∙ (h [ r := x ]))
		    (update-lookup h r x)

  write-write : {n : Nat}{s : Shape n}{a : U}(r : IORef s a)(x y : el a) ->
		writeIORef r x >> writeIORef r y
		≡ writeIORef r y
  write-write (ioRef r) x y =
    eqIO \h -> cong (\ ∙ -> pair unit ∙) (update-update h r x y)

  -- Some separation properties would be nice


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors defined in terms of the reflexive-transitive closure, Star
------------------------------------------------------------------------

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

module Data.Star.Vec where

open import Data.Star.Nat
open import Data.Star.Fin using (Fin)
open import Data.Star.Decoration
open import Data.Star.Pointer as Pointer hiding (lookup)
open import Data.Star.List using (List)
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Function
open import Data.Unit

-- The vector type. Vectors are natural numbers decorated with extra
-- information (i.e. elements).

Vec : Set → ℕ → Set
Vec A = All (λ _ → A)

-- Nil and cons.

[] : ∀ {A} → Vec A zero
[] = ε

infixr 5 _∷_

_∷_ : ∀ {A n} → A → Vec A n → Vec A (suc n)
x ∷ xs = ↦ x ◅ xs

-- Projections.

head : ∀ {A n} → Vec A (1# + n) → A
head (↦ x ◅ _) = x

tail : ∀ {A n} → Vec A (1# + n) → Vec A n
tail (↦ _ ◅ xs) = xs

-- Append.

infixr 5 _++_

_++_ : ∀ {A m n} → Vec A m → Vec A n → Vec A (m + n)
_++_ = _◅◅◅_

-- Safe lookup.

lookup : ∀ {A n} → Fin n → Vec A n → A
lookup i xs with Pointer.lookup i xs
... | result _ x = x

------------------------------------------------------------------------
-- Conversions

fromList : ∀ {A} → (xs : List A) → Vec A (length xs)
fromList ε        = []
fromList (x ◅ xs) = x ∷ fromList xs

toList : ∀ {A n} → Vec A n → List A
toList = gmap (const tt) decoration


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Equivalence
open import HoTT.Identity.Pi
open import HoTT.Identity.Sigma

module HoTT.Exercises.Chapter2.Exercise11 where

private
  variable
    i j k : Level
    A B C D : 𝒰 i

pullback : (A : 𝒰 i) (B : 𝒰 j) → (A → C) → (B → C) → 𝒰 _
pullback A B ac bc = Σ[ a ∶ A ] Σ[ b ∶ B ] (ac a == bc b)

module Square (ab : A → B) (ac : A → C) (bd : B → D) (cd : C → D)
  where
  IsCommutative = bd ∘ ab ~ cd ∘ ac

  module Commutative (comm : IsCommutative)
    where
    inducedMap : {X : 𝒰 i} → (X → A) → pullback (X → B) (X → C) (bd ∘_) (cd ∘_)
    inducedMap xa = ab ∘ xa , ac ∘ xa , funext (comm ∘ xa)

    IsPullback : ∀ {i} → 𝒰 _
    IsPullback {i} = (X : 𝒰 i) → isequiv (inducedMap {X = X})

  open Commutative public

module _ {ac : A → C} {bc : B → C}
  where
  P = pullback A B ac bc

  open Square.Commutative {A = P} pr₁ (pr₁ ∘ pr₂) ac bc (pr₂ ∘ pr₂)

  prop : IsPullback {i}
  prop X = qinv→isequiv (g , η , ε)
    where
    f = inducedMap
    g : pullback (X → A) (X → B) (ac ∘_) (bc ∘_) → (X → P)
    g (h' , k' , p) x = h' x , k' x , happly p x
    η : g ∘ f ~ id
    η xp = funext λ x → pair⁼ (refl , pair⁼ (refl ,
      happly (=Π-β (pr₂ ∘ pr₂ ∘ xp)) x))
    ε : f ∘ g ~ id
    ε (_ , _ , p) = pair⁼ (refl , pair⁼ (refl , =Π-η p))


------------------------------------------------------------------------
-- The Agda standard library
--
-- An inductive definition of the sublist relation with respect to a
-- setoid. This is a generalisation of what is commonly known as Order
-- Preserving Embeddings (OPE).
------------------------------------------------------------------------

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

open import Relation.Binary using (Setoid; Rel)

module Data.List.Relation.Binary.Sublist.Setoid
  {c ℓ} (S : Setoid c ℓ) where

open import Level using (_⊔_)

open import Data.List.Base using (List; []; _∷_)
import Data.List.Relation.Binary.Equality.Setoid as SetoidEquality
import Data.List.Relation.Binary.Sublist.Heterogeneous as Heterogeneous
import Data.List.Relation.Binary.Sublist.Heterogeneous.Core
  as HeterogeneousCore
import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
  as HeterogeneousProperties
open import Data.Product using (∃; ∃₂; _,_; proj₂)

open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary using (¬_; Dec; yes; no)

open Setoid S renaming (Carrier to A)
open SetoidEquality S

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

infix 4 _⊆_ _⊇_ _⊈_ _⊉_

_⊆_ : Rel (List A) (c ⊔ ℓ)
_⊆_ = Heterogeneous.Sublist _≈_

_⊇_ : Rel (List A) (c ⊔ ℓ)
xs ⊇ ys = ys ⊆ xs

_⊈_ : Rel (List A) (c ⊔ ℓ)
xs ⊈ ys = ¬ (xs ⊆ ys)

_⊉_ : Rel (List A) (c ⊔ ℓ)
xs ⊉ ys = ¬ (xs ⊇ ys)

------------------------------------------------------------------------
-- Re-export definitions and operations from heterogeneous sublists

open HeterogeneousCore _≈_ using ([]; _∷_; _∷ʳ_) public
open Heterogeneous {R = _≈_} hiding (Sublist; []; _∷_; _∷ʳ_) public
  renaming
  (toAny to to∈; fromAny to from∈)

open Disjoint      public using ([])
open DisjointUnion public using ([])

------------------------------------------------------------------------
-- Relational properties holding for Setoid case

⊆-reflexive : _≋_ ⇒ _⊆_
⊆-reflexive = HeterogeneousProperties.fromPointwise

open HeterogeneousProperties.Reflexivity {R = _≈_} refl public using ()
  renaming (refl to ⊆-refl)  -- ⊆-refl : Reflexive _⊆_

open HeterogeneousProperties.Transitivity {R = _≈_} {S = _≈_} {T = _≈_} trans public using ()
  renaming (trans to ⊆-trans)  -- ⊆-trans : Transitive _⊆_

open HeterogeneousProperties.Antisymmetry {R = _≈_} {S = _≈_} (λ x≈y _ → x≈y) public using ()
  renaming (antisym to ⊆-antisym)  -- ⊆-antisym : Antisymmetric _≋_ _⊆_

⊆-isPreorder : IsPreorder _≋_ _⊆_
⊆-isPreorder = record
  { isEquivalence = ≋-isEquivalence
  ; reflexive     = ⊆-reflexive
  ; trans         = ⊆-trans
  }

⊆-isPartialOrder : IsPartialOrder _≋_ _⊆_
⊆-isPartialOrder = record
  { isPreorder = ⊆-isPreorder
  ; antisym    = ⊆-antisym
  }

⊆-preorder : Preorder c (c ⊔ ℓ) (c ⊔ ℓ)
⊆-preorder = record
  { isPreorder = ⊆-isPreorder
  }

⊆-poset : Poset c (c ⊔ ℓ) (c ⊔ ℓ)
⊆-poset = record
  { isPartialOrder = ⊆-isPartialOrder
  }

------------------------------------------------------------------------
-- Raw pushout
--
-- The category _⊆_ does not have proper pushouts.  For instance consider:
--
--   τᵤ : [] ⊆ (u ∷ [])
--   τᵥ : [] ⊆ (v ∷ [])
--
-- Then, there are two unrelated upper bounds (u ∷ v ∷ []) and (v ∷ u ∷ []),
-- since _⊆_ does not include permutations.
--
-- Even though there are no unique least upper bounds, we can merge two
-- extensions of a list, producing a minimial superlist of both.
--
-- For the example, the left-biased merge would produce the pair:
--
--   τᵤ′ : (u ∷ []) ⊆ (u ∷ v ∷ [])
--   τᵥ′ : (v ∷ []) ⊆ (u ∷ v ∷ [])
--
-- We call such a pair a raw pushout.  It is then a weak pushout if the
-- resulting square commutes, i.e.:
--
--   ⊆-trans τᵤ τᵤ′ ~ ⊆-trans τᵥ τᵥ′
--
-- This requires a notion of equality _~_ on sublist morphisms.
--
-- Further, commutation requires a similar commutation property
-- for the underlying equality _≈_, namely
--
--   trans x≈y (sym x≈y) == trans x≈z (sym x≈z)
--
-- for some notion of equality _==_ for equality proofs _≈_.
-- Such a property is given e.g. if _≈_ is proof irrelevant
-- or forms a groupoid.

record RawPushout {xs ys zs : List A} (τ : xs ⊆ ys) (σ : xs ⊆ zs) : Set (c ⊔ ℓ) where
  field
    {upperBound} : List A
    leg₁         : ys ⊆ upperBound
    leg₂         : zs ⊆ upperBound

open RawPushout

------------------------------------------------------------------------
-- Extending corners of a raw pushout square

-- Extending the right upper corner.

infixr 5 _∷ʳ₁_ _∷ʳ₂_

_∷ʳ₁_ : ∀ {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
        (y : A) → RawPushout τ σ → RawPushout (y ∷ʳ τ) σ
y ∷ʳ₁ rpo = record
  { leg₁ = refl ∷ leg₁ rpo
  ; leg₂ = y   ∷ʳ leg₂ rpo
  }

-- Extending the left lower corner.

_∷ʳ₂_ : ∀ {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
        (z : A) → RawPushout τ σ → RawPushout τ (z ∷ʳ σ)
z ∷ʳ₂ rpo = record
  { leg₁ = z   ∷ʳ leg₁ rpo
  ; leg₂ = refl ∷ leg₂ rpo
  }

-- Extending both of these corners with equal elements.

∷-rpo : ∀ {x y z : A} {xs ys zs : List A} {τ : xs ⊆ ys} {σ : xs ⊆ zs} →
        (x≈y : x ≈ y) (x≈z : x ≈ z) → RawPushout τ σ → RawPushout (x≈y ∷ τ) (x≈z ∷ σ)
∷-rpo x≈y x≈z rpo = record
  { leg₁ = sym x≈y ∷ leg₁ rpo
  ; leg₂ = sym x≈z ∷ leg₂ rpo
  }

------------------------------------------------------------------------
-- Left-biased pushout: add elements of left extension first.

⊆-pushoutˡ : ∀ {xs ys zs : List A} →
             (τ : xs ⊆ ys) (σ : xs ⊆ zs) → RawPushout τ σ
⊆-pushoutˡ []        σ         = record { leg₁ = σ ; leg₂ = ⊆-refl }
⊆-pushoutˡ (y  ∷ʳ τ) σ         = y ∷ʳ₁ ⊆-pushoutˡ τ σ
⊆-pushoutˡ τ@(_ ∷ _) (z  ∷ʳ σ) = z ∷ʳ₂ ⊆-pushoutˡ τ σ
⊆-pushoutˡ (x≈y ∷ τ) (x≈z ∷ σ) = ∷-rpo x≈y x≈z (⊆-pushoutˡ τ σ)

-- Join two extensions, returning the upper bound and the diagonal
-- of the pushout square.

⊆-joinˡ : ∀ {xs ys zs : List A} →
          (τ : xs ⊆ ys) (σ : xs ⊆ zs) → ∃ λ us → xs ⊆ us
⊆-joinˡ τ σ = upperBound rpo , ⊆-trans τ (leg₁ rpo)
  where
  rpo = ⊆-pushoutˡ τ σ

------------------------------------------------------------------------
-- Upper bound of two sublists xs,ys ⊆ zs

record UpperBound {xs ys zs} (τ : xs ⊆ zs) (σ : ys ⊆ zs) : Set (c ⊔ ℓ) where
  field
    {theUpperBound} : List A
    sub  : theUpperBound ⊆ zs
    inj₁ : xs ⊆ theUpperBound
    inj₂ : ys ⊆ theUpperBound

open UpperBound

infixr 5 _∷ₗ-ub_ _∷ᵣ-ub_

∷ₙ-ub : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x} →
        UpperBound τ σ → UpperBound (x ∷ʳ τ) (x ∷ʳ σ)
∷ₙ-ub u = record
  { sub  = _ ∷ʳ u .sub
  ; inj₁ = u .inj₁
  ; inj₂ = u .inj₂
  }

_∷ₗ-ub_ : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x y} →
         (x≈y : x ≈ y) → UpperBound τ σ → UpperBound (x≈y ∷ τ) (y ∷ʳ σ)
x≈y ∷ₗ-ub u = record
  { sub = refl ∷ u .sub
  ; inj₁ = x≈y ∷ u .inj₁
  ; inj₂ = _  ∷ʳ u .inj₂
  }

_∷ᵣ-ub_ : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} {x y} →
         (x≈y : x ≈ y) → UpperBound τ σ → UpperBound (y ∷ʳ τ) (x≈y ∷ σ)
x≈y ∷ᵣ-ub u = record
  { sub  = refl ∷ u .sub
  ; inj₁ = _   ∷ʳ u .inj₁
  ; inj₂ = x≈y  ∷ u .inj₂
  }

------------------------------------------------------------------------
-- Disjoint union
--
-- Two non-overlapping sublists τ : xs ⊆ zs and σ : ys ⊆ zs
-- can be joined in a unique way if τ and σ are respected.
--
-- For instance, if τ : [x] ⊆ [x,y,x] and σ : [y] ⊆ [x,y,x]
-- then the union will be [x,y] or [y,x], depending on whether
-- τ picks the first x or the second one.
--
-- NB: If the content of τ and σ were ignored then the union would not
-- be unique.  Expressing uniqueness would require a notion of equality
-- of sublist proofs, which we do not (yet) have for the setoid case
-- (however, for the propositional case).

⊆-disjoint-union : ∀ {xs ys zs} {τ : xs ⊆ zs} {σ : ys ⊆ zs} →
                   Disjoint τ σ → UpperBound τ σ
⊆-disjoint-union []         = record { sub = [] ; inj₁ = [] ; inj₂ = [] }
⊆-disjoint-union (x   ∷ₙ d) = ∷ₙ-ub (⊆-disjoint-union d)
⊆-disjoint-union (x≈y ∷ₗ d) = x≈y ∷ₗ-ub (⊆-disjoint-union d)
⊆-disjoint-union (x≈y ∷ᵣ d) = x≈y ∷ᵣ-ub (⊆-disjoint-union d)


module zfc where

open import Level
open import Relation.Binary
open import Relation.Nullary
open import logic

record IsZFC {n m : Level }
     (ZFSet : Set n)
     (_∋_ : ( A x : ZFSet  ) → Set m)
     (_≈_ : Rel ZFSet m)
     (∅  : ZFSet)
     (Select :  (X : ZFSet  ) → ( ψ : (x : ZFSet ) → Set m ) → ZFSet )
       : Set (suc (n ⊔ suc m)) where
  field
     -- ∀ X [ ∅ ∉ X → (∃ f : X → ⋃ X ) → ∀ A ∈ X ( f ( A ) ∈ A ) ]
     choice-func : (X : ZFSet ) → {x : ZFSet } → ¬ ( x ≈ ∅ ) → ( X ∋ x ) → ZFSet
     choice : (X : ZFSet  ) → {A : ZFSet } → ( X∋A : X ∋ A ) → (not : ¬ ( A ≈ ∅ )) → A ∋ choice-func X not X∋A
  infixr  200 _∈_
  infixr  230 _∩_
  _∈_ : ( A B : ZFSet  ) → Set m
  A ∈ B = B ∋ A
  _∩_ : ( A B : ZFSet  ) → ZFSet
  A ∩ B = Select A (  λ x → ( A ∋ x ) ∧ ( B ∋ x )  )

record ZFC {n m : Level } : Set (suc (n ⊔ suc m)) where
  field
     ZFSet : Set n
     _∋_ : ( A x : ZFSet  ) → Set m
     _≈_ : ( A B : ZFSet  ) → Set m
     ∅  : ZFSet
     Select :  (X : ZFSet  ) → ( ψ : (x : ZFSet ) → Set m ) → ZFSet
     isZFC : IsZFC ZFSet _∋_ _≈_ ∅ Select


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

module AKS.Primality.Base where

open import AKS.Nat using (ℕ; _<_)
open import AKS.Nat.GCD using (_∣_; _∤_)

record IsPrime (p : ℕ) : Set where
  constructor IsPrime✓
  field
    1<p : 1 < p
    ∀i∣p[i≡p] : ∀ {i} → 1 < i → i ∣ p → i ≡ p

record IsComposite (c : ℕ) : Set where
  constructor IsComposite✓
  field
    p : ℕ
    p<c : p < c
    p-isPrime : IsPrime p
    p∣c : p ∣ c

record Prime : Set where
  constructor Prime✓
  field
    prime : ℕ
    isPrime : IsPrime prime

record Composite : Set where
  constructor Composite✓
  field
    composite : ℕ
    isComposite : IsComposite composite

data Compositionality (n : ℕ) : Set where
  Composite✓ : IsComposite n → Compositionality n
  Prime✓ : (∀ {p} → p < n → IsPrime p → p ∤ n) → Compositionality n

data Primality (n : ℕ) : Set where
  Composite✓ : IsComposite n → Primality n
  Prime✓ : IsPrime n → Primality n


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties about integers
------------------------------------------------------------------------

module Data.Integer.Properties where

open import Algebra
import Algebra.FunctionProperties
import Algebra.Morphism as Morphism
import Algebra.Properties.AbelianGroup
open import Algebra.Structures
open import Data.Integer hiding (suc; _≤?_)
import Data.Integer.Addition.Properties as Add
import Data.Integer.Multiplication.Properties as Mul
open import Data.Nat
  using (ℕ; suc; zero; _∸_; _≤?_; _<_; _≥_; _≱_; s≤s; z≤n; ≤-pred)
  renaming (_+_ to _ℕ+_; _*_ to _ℕ*_)
open import Data.Nat.Properties as ℕ using (_*-mono_)
open import Data.Product using (proj₁; proj₂; _,_)
open import Data.Sign as Sign using () renaming (_*_ to _S*_)
import Data.Sign.Properties as SignProp
open import Function using (_∘_; _$_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Negation using (contradiction)

open Algebra.FunctionProperties (_≡_ {A = ℤ})
open CommutativeMonoid Add.commutativeMonoid
  using ()
  renaming ( assoc to +-assoc; comm to +-comm; identity to +-identity
           ; isCommutativeMonoid to +-isCommutativeMonoid
           ; isMonoid to +-isMonoid
           )
open CommutativeMonoid Mul.commutativeMonoid
  using ()
  renaming ( assoc to *-assoc; comm to *-comm; identity to *-identity
           ; isCommutativeMonoid to *-isCommutativeMonoid
           ; isMonoid to *-isMonoid
           )
open CommutativeSemiring ℕ.commutativeSemiring
  using () renaming (zero to *-zero; distrib to *-distrib)
open DecTotalOrder Data.Nat.decTotalOrder
  using () renaming (refl to ≤-refl)
open Morphism.Definitions ℤ ℕ _≡_
open ℕ.SemiringSolver
open ≡-Reasoning

------------------------------------------------------------------------
-- Miscellaneous properties

-- Some properties relating sign and ∣_∣ to _◃_.

sign-◃ : ∀ s n → sign (s ◃ suc n) ≡ s
sign-◃ Sign.- _ = refl
sign-◃ Sign.+ _ = refl

sign-cong : ∀ {s₁ s₂ n₁ n₂} →
            s₁ ◃ suc n₁ ≡ s₂ ◃ suc n₂ → s₁ ≡ s₂
sign-cong {s₁} {s₂} {n₁} {n₂} eq = begin
  s₁                  ≡⟨ sym $ sign-◃ s₁ n₁ ⟩
  sign (s₁ ◃ suc n₁)  ≡⟨ cong sign eq ⟩
  sign (s₂ ◃ suc n₂)  ≡⟨ sign-◃ s₂ n₂ ⟩
  s₂                  ∎

abs-◃ : ∀ s n → ∣ s ◃ n ∣ ≡ n
abs-◃ _      zero    = refl
abs-◃ Sign.- (suc n) = refl
abs-◃ Sign.+ (suc n) = refl

abs-cong : ∀ {s₁ s₂ n₁ n₂} →
           s₁ ◃ n₁ ≡ s₂ ◃ n₂ → n₁ ≡ n₂
abs-cong {s₁} {s₂} {n₁} {n₂} eq = begin
  n₁           ≡⟨ sym $ abs-◃ s₁ n₁ ⟩
  ∣ s₁ ◃ n₁ ∣  ≡⟨ cong ∣_∣ eq ⟩
  ∣ s₂ ◃ n₂ ∣  ≡⟨ abs-◃ s₂ n₂ ⟩
  n₂           ∎

-- ∣_∣ commutes with multiplication.

abs-*-commute : Homomorphic₂ ∣_∣ _*_ _ℕ*_
abs-*-commute i j = abs-◃ _ _

-- If you subtract a natural from itself, then you get zero.

n⊖n≡0 : ∀ n → n ⊖ n ≡ + 0
n⊖n≡0 zero    = refl
n⊖n≡0 (suc n) = n⊖n≡0 n

------------------------------------------------------------------------
-- The integers form a commutative ring

private

  ----------------------------------------------------------------------
  -- Additive abelian group.

  inverseˡ : LeftInverse (+ 0) -_ _+_
  inverseˡ -[1+ n ]  = n⊖n≡0 n
  inverseˡ (+ zero)  = refl
  inverseˡ (+ suc n) = n⊖n≡0 n

  inverseʳ : RightInverse (+ 0) -_ _+_
  inverseʳ i = begin
    i + - i  ≡⟨ +-comm i (- i) ⟩
    - i + i  ≡⟨ inverseˡ i ⟩
    + 0      ∎

  +-isAbelianGroup : IsAbelianGroup _≡_ _+_ (+ 0) -_
  +-isAbelianGroup = record
    { isGroup = record
      { isMonoid = +-isMonoid
      ; inverse  = inverseˡ , inverseʳ
      ; ⁻¹-cong  = cong -_
      }
    ; comm = +-comm
    }

  open Algebra.Properties.AbelianGroup
         (record { isAbelianGroup = +-isAbelianGroup })
    using () renaming (⁻¹-involutive to -‿involutive)

  ----------------------------------------------------------------------
  -- Distributivity

  -- Various lemmas used to prove distributivity.

  sign-⊖-< : ∀ {m n} → m < n → sign (m ⊖ n) ≡ Sign.-
  sign-⊖-< {zero}  (s≤s z≤n) = refl
  sign-⊖-< {suc n} (s≤s m<n) = sign-⊖-< m<n

  sign-⊖-≱ : ∀ {m n} → m ≱ n → sign (m ⊖ n) ≡ Sign.-
  sign-⊖-≱ = sign-⊖-< ∘ ℕ.≰⇒>

  +-⊖-left-cancel : ∀ a b c → (a ℕ+ b) ⊖ (a ℕ+ c) ≡ b ⊖ c
  +-⊖-left-cancel zero    b c = refl
  +-⊖-left-cancel (suc a) b c = +-⊖-left-cancel a b c

  ⊖-swap : ∀ a b → a ⊖ b ≡ - (b ⊖ a)
  ⊖-swap zero    zero    = refl
  ⊖-swap (suc _) zero    = refl
  ⊖-swap zero    (suc _) = refl
  ⊖-swap (suc a) (suc b) = ⊖-swap a b

  -- Lemmas relating _⊖_ and _∸_.

  ∣⊖∣-< : ∀ {m n} → m < n → ∣ m ⊖ n ∣ ≡ n ∸ m
  ∣⊖∣-< {zero}  (s≤s z≤n) = refl
  ∣⊖∣-< {suc n} (s≤s m<n) = ∣⊖∣-< m<n

  ∣⊖∣-≱ : ∀ {m n} → m ≱ n → ∣ m ⊖ n ∣ ≡ n ∸ m
  ∣⊖∣-≱ = ∣⊖∣-< ∘ ℕ.≰⇒>

  ⊖-≥ : ∀ {m n} → m ≥ n → m ⊖ n ≡ + (m ∸ n)
  ⊖-≥ z≤n       = refl
  ⊖-≥ (s≤s n≤m) = ⊖-≥ n≤m

  ⊖-< : ∀ {m n} → m < n → m ⊖ n ≡ - + (n ∸ m)
  ⊖-< {zero}  (s≤s z≤n) = refl
  ⊖-< {suc m} (s≤s m<n) = ⊖-< m<n

  ⊖-≱ : ∀ {m n} → m ≱ n → m ⊖ n ≡ - + (n ∸ m)
  ⊖-≱ = ⊖-< ∘ ℕ.≰⇒>

  -- Lemmas working around the fact that _◃_ pattern matches on its
  -- second argument before its first.

  +‿◃ : ∀ n → Sign.+ ◃ n ≡ + n
  +‿◃ zero    = refl
  +‿◃ (suc _) = refl

  -‿◃ : ∀ n → Sign.- ◃ n ≡ - + n
  -‿◃ zero    = refl
  -‿◃ (suc _) = refl

  -- The main distributivity proof.

  distrib-lemma :
    ∀ a b c → (c ⊖ b) * -[1+ a ] ≡ a ℕ+ b ℕ* suc a ⊖ (a ℕ+ c ℕ* suc a)
  distrib-lemma a b c
    rewrite +-⊖-left-cancel a (b ℕ* suc a) (c ℕ* suc a)
          | ⊖-swap (b ℕ* suc a) (c ℕ* suc a)
    with b ≤? c
  ... | yes b≤c
    rewrite ⊖-≥ b≤c
          | ⊖-≥ (b≤c *-mono (≤-refl {x = suc a}))
          | -‿◃ ((c ∸ b) ℕ* suc a)
          | ℕ.*-distrib-∸ʳ (suc a) c b
          = refl
  ... | no b≰c
    rewrite sign-⊖-≱ b≰c
          | ∣⊖∣-≱ b≰c
          | +‿◃ ((b ∸ c) ℕ* suc a)
          | ⊖-≱ (b≰c ∘ ℕ.cancel-*-right-≤ b c a)
          | -‿involutive (+ (b ℕ* suc a ∸ c ℕ* suc a))
          | ℕ.*-distrib-∸ʳ (suc a) b c
          = refl

  distribʳ : _*_ DistributesOverʳ _+_

  distribʳ (+ zero) y z
    rewrite proj₂ *-zero ∣ y ∣
          | proj₂ *-zero ∣ z ∣
          | proj₂ *-zero ∣ y + z ∣
          = refl

  distribʳ x (+ zero) z
    rewrite proj₁ +-identity z
          | proj₁ +-identity (sign z S* sign x ◃ ∣ z ∣ ℕ* ∣ x ∣)
          = refl

  distribʳ x y (+ zero)
    rewrite proj₂ +-identity y
          | proj₂ +-identity (sign y S* sign x ◃ ∣ y ∣ ℕ* ∣ x ∣)
          = refl

  distribʳ -[1+ a ] -[1+ b ] -[1+ c ] = cong +_ $
    solve 3 (λ a b c → (con 2 :+ b :+ c) :* (con 1 :+ a)
                    := (con 1 :+ b) :* (con 1 :+ a) :+
                       (con 1 :+ c) :* (con 1 :+ a))
            refl a b c

  distribʳ (+ suc a) (+ suc b) (+ suc c) = cong +_ $
    solve 3 (λ a b c → (con 1 :+ b :+ (con 1 :+ c)) :* (con 1 :+ a)
                    := (con 1 :+ b) :* (con 1 :+ a) :+
                       (con 1 :+ c) :* (con 1 :+ a))
          refl a b c

  distribʳ -[1+ a ] (+ suc b) (+ suc c) = cong -[1+_] $
    solve 3 (λ a b c → a :+ (b :+ (con 1 :+ c)) :* (con 1 :+ a)
                     := (con 1 :+ b) :* (con 1 :+ a) :+
                        (a :+ c :* (con 1 :+ a)))
           refl a b c

  distribʳ (+ suc a) -[1+ b ] -[1+ c ] = cong -[1+_] $
    solve 3 (λ a b c → a :+ (con 1 :+ a :+ (b :+ c) :* (con 1 :+ a))
                    := (con 1 :+ b) :* (con 1 :+ a) :+
                       (a :+ c :* (con 1 :+ a)))
           refl a b c

  distribʳ -[1+ a ] -[1+ b ] (+ suc c) = distrib-lemma a b c

  distribʳ -[1+ a ] (+ suc b) -[1+ c ] = distrib-lemma a c b

  distribʳ (+ suc a) -[1+ b ] (+ suc c)
    rewrite +-⊖-left-cancel a (c ℕ* suc a) (b ℕ* suc a)
    with b ≤? c
  ... | yes b≤c
    rewrite ⊖-≥ b≤c
          | +-comm (- (+ (a ℕ+ b ℕ* suc a))) (+ (a ℕ+ c ℕ* suc a))
          | ⊖-≥ (b≤c *-mono ≤-refl {x = suc a})
          | ℕ.*-distrib-∸ʳ (suc a) c b
          | +‿◃ (c ℕ* suc a ∸ b ℕ* suc a)
          = refl
  ... | no b≰c
    rewrite sign-⊖-≱ b≰c
          | ∣⊖∣-≱ b≰c
          | -‿◃ ((b ∸ c) ℕ* suc a)
          | ⊖-≱ (b≰c ∘ ℕ.cancel-*-right-≤ b c a)
          | ℕ.*-distrib-∸ʳ (suc a) b c
          = refl

  distribʳ (+ suc c) (+ suc a) -[1+ b ]
    rewrite +-⊖-left-cancel c (a ℕ* suc c) (b ℕ* suc c)
    with b ≤? a
  ... | yes b≤a
    rewrite ⊖-≥ b≤a
          | ⊖-≥ (b≤a *-mono ≤-refl {x = suc c})
          | +‿◃ ((a ∸ b) ℕ* suc c)
          | ℕ.*-distrib-∸ʳ (suc c) a b
          = refl
  ... | no b≰a
    rewrite sign-⊖-≱ b≰a
          | ∣⊖∣-≱ b≰a
          | ⊖-≱ (b≰a ∘ ℕ.cancel-*-right-≤ b a c)
          | -‿◃ ((b ∸ a) ℕ* suc c)
          | ℕ.*-distrib-∸ʳ (suc c) b a
          = refl

  -- The IsCommutativeSemiring module contains a proof of
  -- distributivity which is used below.

  isCommutativeSemiring : IsCommutativeSemiring _≡_ _+_ _*_ (+ 0) (+ 1)
  isCommutativeSemiring = record
    { +-isCommutativeMonoid = +-isCommutativeMonoid
    ; *-isCommutativeMonoid = *-isCommutativeMonoid
    ; distribʳ              = distribʳ
    ; zeroˡ                 = λ _ → refl
    }

commutativeRing : CommutativeRing _ _
commutativeRing = record
  { Carrier           = ℤ
  ; _≈_               = _≡_
  ; _+_               = _+_
  ; _*_               = _*_
  ; -_                = -_
  ; 0#                = + 0
  ; 1#                = + 1
  ; isCommutativeRing = record
    { isRing = record
      { +-isAbelianGroup = +-isAbelianGroup
      ; *-isMonoid       = *-isMonoid
      ; distrib          = IsCommutativeSemiring.distrib
                             isCommutativeSemiring
      }
    ; *-comm = *-comm
    }
  }

import Algebra.RingSolver.Simple as Solver
import Algebra.RingSolver.AlmostCommutativeRing as ACR
module RingSolver =
  Solver (ACR.fromCommutativeRing commutativeRing) _≟_

------------------------------------------------------------------------
-- More properties

-- Multiplication is right cancellative for non-zero integers.

cancel-*-right : ∀ i j k →
                 k ≢ + 0 → i * k ≡ j * k → i ≡ j
cancel-*-right i j k            ≢0 eq with signAbs k
cancel-*-right i j .(+ 0)       ≢0 eq | s ◂ zero  = contradiction refl ≢0
cancel-*-right i j .(s ◃ suc n) ≢0 eq | s ◂ suc n
  with ∣ s ◃ suc n ∣ | abs-◃ s (suc n) | sign (s ◃ suc n) | sign-◃ s n
...  | .(suc n)      | refl            | .s               | refl =
  ◃-cong (sign-i≡sign-j i j eq) $
         ℕ.cancel-*-right ∣ i ∣ ∣ j ∣ $ abs-cong eq
  where
  sign-i≡sign-j : ∀ i j →
                  sign i S* s ◃ ∣ i ∣ ℕ* suc n ≡
                  sign j S* s ◃ ∣ j ∣ ℕ* suc n →
                  sign i ≡ sign j
  sign-i≡sign-j i              j              eq with signAbs i | signAbs j
  sign-i≡sign-j .(+ 0)         .(+ 0)         eq | s₁ ◂ zero   | s₂ ◂ zero   = refl
  sign-i≡sign-j .(+ 0)         .(s₂ ◃ suc n₂) eq | s₁ ◂ zero   | s₂ ◂ suc n₂
    with ∣ s₂ ◃ suc n₂ ∣ | abs-◃ s₂ (suc n₂)
  ... | .(suc n₂) | refl
    with abs-cong {s₁} {sign (s₂ ◃ suc n₂) S* s} {0} {suc n₂ ℕ* suc n} eq
  ...   | ()
  sign-i≡sign-j .(s₁ ◃ suc n₁) .(+ 0)         eq | s₁ ◂ suc n₁ | s₂ ◂ zero
    with ∣ s₁ ◃ suc n₁ ∣ | abs-◃ s₁ (suc n₁)
  ... | .(suc n₁) | refl
    with abs-cong {sign (s₁ ◃ suc n₁) S* s} {s₁} {suc n₁ ℕ* suc n} {0} eq
  ...   | ()
  sign-i≡sign-j .(s₁ ◃ suc n₁) .(s₂ ◃ suc n₂) eq | s₁ ◂ suc n₁ | s₂ ◂ suc n₂
    with ∣ s₁ ◃ suc n₁ ∣ | abs-◃ s₁ (suc n₁)
       | sign (s₁ ◃ suc n₁) | sign-◃ s₁ n₁
       | ∣ s₂ ◃ suc n₂ ∣ | abs-◃ s₂ (suc n₂)
       | sign (s₂ ◃ suc n₂) | sign-◃ s₂ n₂
  ... | .(suc n₁) | refl | .s₁ | refl | .(suc n₂) | refl | .s₂ | refl =
    SignProp.cancel-*-right s₁ s₂ (sign-cong eq)

-- Multiplication with a positive number is right cancellative (for
-- _≤_).

cancel-*-+-right-≤ : ∀ m n o → m * + suc o ≤ n * + suc o → m ≤ n
cancel-*-+-right-≤ (-[1+ m ]) (-[1+ n ]) o (-≤- n≤m) =
  -≤- (≤-pred (ℕ.cancel-*-right-≤ (suc n) (suc m) o (s≤s n≤m)))
cancel-*-+-right-≤ ℤ.-[1+ _ ] (+ _)      _ _         = -≤+
cancel-*-+-right-≤ (+ 0)      ℤ.-[1+ _ ] _ ()
cancel-*-+-right-≤ (+ suc _)  ℤ.-[1+ _ ] _ ()
cancel-*-+-right-≤ (+ 0)      (+ 0)      _ _         = +≤+ z≤n
cancel-*-+-right-≤ (+ 0)      (+ suc _)  _ _         = +≤+ z≤n
cancel-*-+-right-≤ (+ suc _)  (+ 0)      _ (+≤+ ())
cancel-*-+-right-≤ (+ suc m)  (+ suc n)  o (+≤+ m≤n) =
  +≤+ (ℕ.cancel-*-right-≤ (suc m) (suc n) o m≤n)

-- Multiplication with a positive number is monotone.

*-+-right-mono : ∀ n → (λ x → x * + suc n) Preserves _≤_ ⟶ _≤_
*-+-right-mono _ (-≤+             {n = 0})         = -≤+
*-+-right-mono _ (-≤+             {n = suc _})     = -≤+
*-+-right-mono x (-≤-                         n≤m) =
  -≤- (≤-pred (s≤s n≤m *-mono ≤-refl {x = suc x}))
*-+-right-mono _ (+≤+ {m = 0}     {n = 0}     m≤n) = +≤+ m≤n
*-+-right-mono _ (+≤+ {m = 0}     {n = suc _} m≤n) = +≤+ z≤n
*-+-right-mono _ (+≤+ {m = suc _} {n = 0}     ())
*-+-right-mono x (+≤+ {m = suc _} {n = suc _} m≤n) =
  +≤+ (m≤n *-mono ≤-refl {x = suc x})


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Equivalence
open import HoTT.Identity.Product

module HoTT.Equivalence.Product where

private
  variable
    i : Level
    A A' B B' : 𝒰 i

×-swap : A × B → B × A
×-swap x = pr₂ x , pr₁ x

×-comm : A × B ≃ B × A
×-comm = ×-swap , qinv→isequiv (×-swap , ×-uniq , ×-uniq)

×-equiv₁ : A ≃ A' → A × B ≃ A' × B
×-equiv₁ {A = A} {A' = A'} {B = B} (f₁ , e₁) = f , qinv→isequiv (g , η , ε)
  where
  open qinv (isequiv→qinv e₁) renaming (g to g₁ ; η to η₁ ; ε to ε₁)
  f : A × B → A' × B
  f (a , b) = f₁ a , b
  g : A' × B → A × B
  g (a' , b) = g₁ a' , b
  η : g ∘ f ~ id
  η (a , b) = ×-pair⁼ (η₁ a , refl)
  ε : f ∘ g ~ id
  ε (a' , b) = ×-pair⁼ (ε₁ a' , refl)

×-equiv₂ : B ≃ B' → A × B ≃ A × B'
×-equiv₂ {B = B} {B' = B'} {A = A} (f₂ , e₂) = f , qinv→isequiv (g , η , ε)
  where
  open qinv (isequiv→qinv e₂) renaming (g to g₂ ; η to η₂ ; ε to ε₂)
  f : A × B → A × B'
  f (a , b) = a , f₂ b
  g : A × B' → A × B
  g (a , b') = a , g₂ b'
  η : g ∘ f ~ id
  η (a , b) = ×-pair⁼ (refl , η₂ b)
  ε : f ∘ g ~ id
  ε (a , b') = ×-pair⁼ (refl , ε₂ b')


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

syntax Sum | S

type
  _⊕_ : 2-ary | l30

term
  inl  : α  ->  α ⊕ β
  inr  : β  ->  α ⊕ β
  case : α ⊕ β  α.γ  β.γ  ->  γ

theory
  (lβ) a : α   f : α.γ  g : β.γ |> case (inl(a), x.f[x], y.g[y])      = f[a]
  (rβ) b : β   f : α.γ  g : β.γ |> case (inr(b), x.f[x], y.g[y])      = g[b]
  (cη) s : α ⊕ β  c : (α ⊕ β).γ |> case (s, x.c[inl(x)], y.c[inr(y)]) = c[s]
-}

module Sum.Equality where

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

open import Sum.Signature
open import Sum.Syntax

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

private
  variable
    α β γ τ : ST
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ S) α Γ → (𝔐 ▷ S) α Γ → Set where
  lβ : ⁅ α ⁆ ⁅ α ⊩ γ ⁆ ⁅ β ⊩ γ ⁆̣ ▹ ∅ ⊢   case (inl 𝔞) (𝔟⟨ x₀ ⟩) (𝔠⟨ x₀ ⟩) ≋ₐ 𝔟⟨ 𝔞 ⟩
  rβ : ⁅ β ⁆ ⁅ α ⊩ γ ⁆ ⁅ β ⊩ γ ⁆̣ ▹ ∅ ⊢   case (inr 𝔞) (𝔟⟨ x₀ ⟩) (𝔠⟨ x₀ ⟩) ≋ₐ 𝔠⟨ 𝔞 ⟩
  cη : ⁅ α ⊕ β ⁆ ⁅ (α ⊕ β) ⊩ γ ⁆̣ ▹ ∅ ⊢ case 𝔞 (𝔟⟨ inl x₀ ⟩) (𝔟⟨ inr x₀ ⟩) ≋ₐ 𝔟⟨ 𝔞 ⟩

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


{-
  Copyright 2019 Lisandra Silva

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

open import Prelude

module StateMachineModel where

   -----------------------------------------------------------------------------
   -- State Machine
   -----------------------------------------------------------------------------
  record StateMachine (State : Set) (Event : Set) : Set₁ where
    field
      initial : Pred State 0ℓ
      enabled : Event → State → Set
      action  : ∀ {preState} {event} → enabled event preState → State
  open StateMachine

  data Reachable {State Event} {sm : StateMachine State Event} : State → Set where
    init : ∀ {s₀} → initial sm s₀
           → Reachable s₀
    step : ∀ {st event} → Reachable {sm = sm} st → (enEv : enabled sm event st)
           → Reachable (action sm enEv)

  Invariant : ∀ {State Event} (sm : StateMachine State Event) (P : Pred State 0ℓ) → Set
  Invariant sm P = ∀ {state} (rs : Reachable {sm = sm} state) → P state

  Stable : ∀ {State Event} (sm : StateMachine State Event) (P : Pred State 0ℓ) → Set
  Stable sm P = ∀ {st ev} (enEv : enabled sm ev st)
                → P st
                → P (action sm enEv)

  EventSet : ∀ {Event : Set} → Set₁
  EventSet {Event} = Pred Event 0ℓ

  record System State Event : Set₁ where
    field
      stateMachine : StateMachine State Event
      weakFairness : Pred (EventSet {Event}) 0ℓ
  open System

  enabledSet : ∀ {State Event} → StateMachine State Event
               → EventSet {Event} → State → Set
  enabledSet sm evSet state = ∃[ event ] (event ∈ evSet × enabled sm event state)

  module LeadsTo
    (State : Set) (Event : Set) (sys : System State Event)
    where

   -----------------------------------------------------------------------------
   -- HOARE Triple
   -----------------------------------------------------------------------------
   data [_]_[_] (P : Pred State 0ℓ) (event : Event) (Q : Pred State 0ℓ) : Set where
      hoare : (∀ {st} → P st
                      → (enEv : enabled (stateMachine sys) event st)
                      → Q (action (stateMachine sys) enEv ))
               → [ P ] event [ Q ]

   Z : Set
   Z = ℕ

   -- Auxiliary properties with syntax renaming for better compliance with paper
   -- TODO : Try to make this more generic
   ⋃₁ : ∀ {ℓ ℓ'} {A : Set ℓ'} → (A → Pred State ℓ) → Pred State (ℓ ⊔ ℓ')
   ⋃₁ {A = A} P = λ x → Σ[ i ∈ A ] P i x

   syntax ⋃₁ (λ i → P) = [∃ i ∶ P ]

   ⋃₂ : ∀ {ℓ₁ ℓ₂ ℓ'} {A : Set ℓ'} → (C : Pred A ℓ₁) → (F : A → Pred State ℓ₂) → Pred State _
   ⋃₂ {A = A} C F = λ s → Σ[ i ∈ A ] ( C i × F i s )

   syntax ⋃₂ C (λ x → P) = [∃ x ⇒ C ∶ P ]

   -----------------------------------------------------------------------------
   -- PROOF RULES for liveness
   -----------------------------------------------------------------------------
   infix 1 _l-t_

   data _l-t_ (P : Pred State 0ℓ) (Q : Pred State 0ℓ) : Set₁ where
     viaEvSet  :   (evSet : EventSet) → (weakFairness sys evSet)
                 → (∀ (e : Event) → e ∈ evSet → [ P ] e [ Q ])
                 → (∀ (e : Event) → ¬ (e ∈ evSet) → [ P ] e [ P ∪ Q ])
                 → Invariant (stateMachine sys)
                             (P ⇒ enabledSet (stateMachine sys) evSet)
               → P l-t Q

     viaInv    : Invariant (stateMachine sys) (P ⇒ Q)
                 → P l-t Q

     viaTrans  : ∀ {R} → P l-t R → R l-t Q
                 → P l-t Q

     viaTrans2 : ∀ {R} → P l-t (Q ∪ R) → R l-t Q
                 → P l-t Q

     viaDisj   : ∀ {P₁ P₂} → P ⊆ (P₁ ∪ P₂) → P₁ l-t Q → P₂ l-t Q
                 → P  l-t Q

     viaUseInv : ∀ {R} → Invariant (stateMachine sys) R → (P ∩ R) l-t (R ⇒ Q)
                 → P l-t Q

     viaWFR    : ∀ (F : Z → Pred State 0ℓ)
                 → P l-t (Q ∪ [∃ x ∶ F x ])
                 → (∀ (w : Z) → F w l-t (Q ∪ [∃ x ⇒ _< w ∶ F x ]))
                 → P l-t Q

     viaAllVal : ∀ {A : Set} → {R : A → Pred State 0ℓ}
                 → Invariant (stateMachine sys) [∃ x ∶ R x ]
                 → (∀ (a : A) → (P ∩ R a) l-t Q )
                 → P l-t Q

     viaStable : ∀ {P' Q' S} → Stable (stateMachine sys) S
                 → P l-t P' ∩ S → P' l-t Q' → Q' ∩ S l-t Q
                 → P l-t Q

   P⊆QQ→Inv[P⇒Q] : ∀ {P Q} {sm : StateMachine State Event}
                   → P ⊆ Q
                   → Invariant sm (P ⇒ Q)
   P⊆QQ→Inv[P⇒Q] p⊆q rs pS
     with p⊆q pS
   ... | qS = qS

   invR⇒P-l-t-P∧R : ∀ {P R} {sm : StateMachine State Event}
                    → Invariant (stateMachine sys) R
                    → P l-t P ∩ R
   invR⇒P-l-t-P∧R invR = viaInv (λ rs ps → ps , (invR rs))


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Symmetry

module Oscar.Class.Symmetry.ToSym where

private

  test-class :
    ⦃ _ : ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class _∼_ ⦄
    → ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class _∼_
  test-class = !

  test-class' :
    ∀ {𝔬} {𝔒 : Ø 𝔬} {x : 𝔒} {𝔯} {F : (𝔒 → 𝔒 → Ø 𝔯) → 𝔒 → 𝔒 → Ø 𝔯}
    ⦃ _ : ∀ {S : 𝔒 → 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class (F (S x)) ⦄
    → ∀ {S : 𝔒 → 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class (F (S x))
  test-class' ⦃ ⌶ ⦄ {S} = ⌶ {S} -- FIXME _S _x ≟ _S' _x

  test-class'' :
    ∀ {𝔬} {𝔒 : Ø 𝔬} {x : 𝔒} {𝔯} {F : (𝔒 → 𝔒 → 𝔒 → Ø 𝔯) → 𝔒 → 𝔒 → 𝔒 → Ø 𝔯}
    ⦃ _ : ∀ {S : 𝔒 → 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class (F S x) ⦄
    → ∀ {S : 𝔒 → 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class (F S x)
  test-class'' = !

  test-class''' :
    ∀ {𝔬} {𝔒 : Ø 𝔬} {𝔯} {F : (𝔒 → 𝔒 → 𝔒 → Ø 𝔯) → 𝔒 → 𝔒 → Ø 𝔯}
    ⦃ _ : ∀ {S : 𝔒 → 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class (F S) ⦄
    → ∀ {S : 𝔒 → 𝔒 → 𝔒 → Ø 𝔯} → Symmetry.class (F S)
  test-class''' = !

  test-method-sym : ∀
    {𝔬} {𝔒 : Ø 𝔬}
    {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯}
    ⦃ _ : Symmetry.class _∼_ ⦄
    → _
  test-method-sym {_∼_ = _∼_} = λ {x} {y} → Symmetry.method _∼_ {x} {y}

  test-method-symmetry : ∀
    {𝔬} {𝔒 : Ø 𝔬}
    {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯}
    ⦃ _ : Symmetry.class _∼_ ⦄
    → _
  test-method-symmetry {_∼_ = _∼_} = λ {x} {y} → symmetry[ _∼_ ] {x} {y}


module BTree {A : Set} where

open import Data.List

data BTree : Set where
  leaf : BTree
  node : A → BTree → BTree → BTree

flatten : BTree → List A
flatten leaf = []
flatten (node x l r) = (flatten l) ++ (x ∷ flatten r)


module Main where

import Automaton.DeterministicFinite
import Automaton.NonDeterministicFinite
import Automaton.Pushdown
import Automaton.TuringMachine
import Cardinal
import Cardinal.Finite.Count
import Cardinal.Proofs
import Data
import Data.Any
import Data.Boolean
import Data.Boolean.Stmt
import Data.Boolean.Operators
import Data.Boolean.Proofs
import Data.Either
import Data.List
import Data.List.Computability
import Data.List.Proofs
import Data.List.Relation.Membership.Proofs
import Data.List.Relation.Sublist.Proofs
import Data.List.Relation
import Data.List.Relation.Membership
import Data.List.Relation.Sublist
import Data.ListNonEmpty
import Data.Option
import Data.Proofs
import Data.Tuple
import Data.Tuple.Function
import Data.Tuple.List
import Data.Tuple.Proofs
import Data.Tuple.Raise
import Data.Tuple.Raiseᵣ
import Data.Tuple.Raiseₗ
import FFI.IO   as FFI
import FormalLanguage
import FormalLanguage.ContextFreeGrammar
import FormalLanguage.Proofs
import FormalLanguage.RegularExpression
import Functional
import Function.DomainRaise
import Function.Domains
import Function.Domains.Proofs
import Function.Equals
import Function.Names
import Function.PrimitiveRecursion
import Function.Proofs
import Function.Iteration
import Function.Iteration.Proofs
-- import Geometry.Test
-- import Geometry.Test2
import Geometry.Test3
import Graph
import Lang.Instance
import Lang.Irrelevance
import Logic.Classical
import Logic.Classical.DoubleNegated
import Logic.Classical.Mere
import Logic.Computability
import Logic.Computability.Binary
import Logic.Convenience
import Logic.DiagonalProof
import Logic.LambdaCalculus
import Logic.Predicate
import Logic.Predicate.Theorems
import Logic.Propositional
import Logic.Propositional.Names
import Logic.Propositional.Theorems
import Lvl
import Metalogic.Classical.Propositional.ProofSystem
import Metalogic.Classical.Propositional.Syntax
import Metalogic.Classical.Propositional.TruthSemanticsModel
import Metalogic.Constructive.NaturalDeduction.TreeModel
-- import Metalogic.Constructive.Provability
import Metalogic.Linear.SequentCalculus
import Metalogic.Linear.Syntax
import Numeral.CoordinateVector
import Numeral.FiniteInclusive
import Numeral.Finite
import Numeral.Finite.Bound
import Numeral.Finite.Functions
import Numeral.Finite.Oper
import Numeral.Finite.Oper.Comparisons
import Numeral.Finite.Proofs
import Numeral.Integer
import Numeral.Integer.Function
import Numeral.Integer.Oper
import Numeral.Integer.Proofs
import Numeral.Integer.Relation
import Numeral.Integer.Sign
import Numeral.Matrix
import Numeral.Natural
import Numeral.Natural.Coprime
import Numeral.Natural.Function
import Numeral.Natural.Function.Proofs
-- import Numeral.Natural.GreatestCommonDivisor
import Numeral.Natural.Induction
import Numeral.Natural.Inductions
import Numeral.Natural.Oper
import Numeral.Natural.Oper.Comparisons
import Numeral.Natural.Oper.Comparisons.Proofs
import Numeral.Natural.Oper.Divisibility
import Numeral.Natural.Oper.Modulo
import Numeral.Natural.Oper.Modulo.Proofs
import Numeral.Natural.Oper.Proofs
import Numeral.Natural.Order
import Numeral.Natural.Prime
import Numeral.Natural.Relation
import Numeral.Natural.Relation.Computability
import Numeral.Natural.Relation.Countable
import Numeral.Natural.Relation.Divisibility
import Numeral.Natural.Relation.Order
import Numeral.Natural.Relation.Order.Computability
import Numeral.Natural.Relation.Order.Existence
import Numeral.Natural.Relation.Order.Existence.Proofs
import Numeral.Natural.Relation.Order.Proofs
import Numeral.Natural.Relation.Properties
import Numeral.Natural.TotalOper
import Numeral.Natural.UnclosedOper
import Numeral.PositiveInteger
import Numeral.PositiveInteger.Oper
import Numeral.Rational.AlterAdd
-- import Numeral.Rational.SternBrocot
import Numeral.Real
import Numeral.Real.Properties
import Numeral.Sign
import Numeral.Sign.Oper
import Numeral.Sign.Oper0
import Operator.Equals
import Relator.Bijection
import Relator.Congruence
import Relator.Congruence.Proofs
import Relator.Countable
import Relator.Equals
import Relator.Equals.Proofs
import Relator.Equals.Proofs.Uniqueness
import Structure.Setoid.Uniqueness
import Relator.Finite
import Sets.BoolSet
import Sets.BoolSet.Proofs
import Sets.ETCS
import Sets.IZF
import Sets.PredicateSet
import Sets.PredicateSet.Filter
import Sets.PredicateSet.Finite
import Sets.PredicateSet.Proofs
import Sets.PredicateSet.Relations
import Structure.Setoid
import Structure.Setoid.Proofs
import Stream
import String
import Structure.Arithmetic
-- import Structure.Category
import Structure.Function.Domain
import Structure.Function.Linear
import Structure.Function.Ordering
import Structure.LinearAlgebra
import Structure.Logic.Classical.PredicateBoundedQuantification
import Structure.Logic.Classical.NaturalDeduction
import Structure.Logic.Classical.NaturalDeduction.Proofs
import Structure.Logic.Classical.SetTheory
import Structure.Logic.Classical.SetTheory.SetBoundedQuantification
import Structure.Logic.Classical.SetTheory.Function
import Structure.Logic.Classical.SetTheory.Relation
import Structure.Logic.Classical.SetTheory.ZFC
import Structure.Logic.Classical.SetTheory.ZFC.BinaryRelatorSet
-- import Structure.Logic.Classical.SetTheory.ZFC.Finite
import Structure.Logic.Classical.SetTheory.ZFC.FunctionSet
import Structure.Logic.Classical.SetTheory.ZFC.Proofs
import Structure.Logic.Constructive.Functions.Properties
import Structure.Logic.Constructive.NaturalDeduction
import Structure.Operator.Field
import Structure.Operator.Functions
import Structure.Operator.Group
import Structure.Operator.Group.Proofs
import Structure.Operator.Monoid
import Structure.Operator.Proofs
import Structure.Operator.Properties
import Structure.Operator.SetAlgebra
import Structure.Operator.Vector
import Structure.Real
import Structure.Relator.Equivalence as Eq
import Structure.Relator.Function
import Structure.Relator.Ordering
import Structure.Relator.Ordering.Subsets
import Structure.Relator.Properties
import Structure.Relator.Properties.Proofs
import Syntax.Function
import Syntax.Method
import Syntax.Number
import Type
import Type.Cardinality
import Type.Cardinality.Proofs
import Type.Dependent
import Type.Properties.Empty
import Type.Properties.Empty.Proofs
import Type.Functions
import Type.Functions.Inverse
import Type.Functions.Inverse.Proofs
import Type.Functions.Proofs
import Type.Singleton
import Type.Singleton.Proofs
import Type.Properties.Singleton
import Type.Properties.Singleton.Proofs
import Type.Univalence

main : FFI.IO Data.Unit
main = FFI.printStrLn("Okay")


open import Everything

{-
open import Oscar.Prelude
open import Oscar.Class.HasEquivalence
open import Oscar.Class.Symmetrical
open import Oscar.Data.Term
open import Oscar.Data.Substitunction
open import Oscar.Data.Surjcollation
open import Oscar.Data.Surjextenscollation
open import Oscar.Data.Proposequality
import Oscar.Class.HasEquivalence.ExtensionṖroperty
import Oscar.Class.HasEquivalence.Ṗroperty
import Oscar.Class.Symmetrical.ExtensionalUnifies
import Oscar.Class.Symmetrical.Unifies
import Oscar.Property.Setoid.Proposequality -- FIXME see _∼⁰_ below; comment this out to observe confusing error messages
import Oscar.Property.Functor.SubstitunctionExtensionTerm
import Oscar.Class.Surjection.⋆
-}

module Test.SymmetricalSubstitunction {𝔭} (𝔓 : Ø 𝔭) (ℓ : Ł) where
  open Term 𝔓 using () renaming (
    Term to 𝑩;
    Terms to 𝑩')
  open Substitunction 𝔓 using () renaming (
    Substitunction to 𝑪)

  infix 18 _∼⁰_
  _∼⁰_ = ≡-surjcollation⟦ 𝑪 ⟧ --  ≡-Unifies₀⟦ 𝑪 ⟧ -- FIXME gives a confusing error message
  -- _∼⁰_ = ≡-SymUnifies₀⟦ 𝑪 ⟧ -- FIXME gives a more useful error message

  open Surjextenscollation 𝑪 _≡̇_ renaming (_⟹_ to _∼¹_)

  fact1⋆ : ∀ {𝓃} (𝓈 𝓉 : 𝑩 𝓃) → 𝓈 ∼⁰ 𝓉 ≈ 𝓉 ∼⁰ 𝓈
  fact1⋆ 𝓈 𝓉 = symmetrical 𝓈 𝓉
  -- fact1⋆ 𝓈 𝓉 = symmetrical ⦃ r = Oscar.Class.Symmetrical.Unifies.𝓢ymmetricalUnifies₀ ⦃ ! ⦄ ⦃ ! ⦄ ⦃ Oscar.Property.Setoid.Proposequality.𝓢ymmetryProposequality ⦄ ⦄ 𝓈 𝓉 -- FIXME I wish Agda would tell us that this is how the instances were resolved

  fact1⋆s : ∀ {N 𝓃} (𝓈 𝓉 : 𝑩' N 𝓃) → 𝓈 ∼⁰ 𝓉 ≈ 𝓉 ∼⁰ 𝓈
  fact1⋆s 𝓈 𝓉 = symmetrical 𝓈 𝓉

  fact1 : ∀ {𝓃} (𝓈 𝓉 : 𝑩 𝓃) → 𝓈 ∼¹ 𝓉 ≈ 𝓉 ∼¹ 𝓈
  fact1 𝓈 𝓉 = symmetrical 𝓈 𝓉

  fact1s : ∀ {N 𝓃} (𝓈 𝓉 : 𝑩' N 𝓃) → 𝓈 ∼¹ 𝓉 ≈ 𝓉 ∼¹ 𝓈
  fact1s 𝓈 𝓉 = symmetrical 𝓈 𝓉


------------------------------------------------------------------------
-- Safe modules that use --cubical
------------------------------------------------------------------------

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

module README.Safe.Cubical where

-- A proof of univalence.

import Equality.Path.Univalence

-- A proof of univalence for an arbitrary "equality with J".

import Equality.Path.Isomorphisms.Univalence

-- Very stable booleans.

import Bool.Very-stable

-- Listed finite subsets.

import Finite-subset.Listed

-- An alternative definition of listed finite subsets.

import Finite-subset.Listed.Alternative

-- Kuratowski finite subsets.

import Finite-subset.Kuratowski

-- An example related to Nat.Wrapper, defined in Cubical Agda.

import Nat.Wrapper.Cubical

-- Abstract binding trees, based on Harper's "Practical Foundations
-- for Programming Languages".

import Abstract-binding-tree
import README.Abstract-binding-tree

-- Overview of code related to a paper.

import README.HITs-without-paths


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

open import Categories.Category
open import Categories.Object.Zero

module Categories.Object.Kernel.Properties {o ℓ e} {𝒞 : Category o ℓ e} (𝒞-Zero : Zero 𝒞) where

open import Function using (_$_)

open import Categories.Diagram.Equalizer 𝒞
open import Categories.Diagram.Pullback 𝒞 renaming (glue to glue-pullback; up-to-iso to pullback-up-to-iso)
open import Categories.Diagram.Pullback.Properties 𝒞
open import Categories.Object.Kernel 𝒞-Zero
open import Categories.Object.Terminal 𝒞

open import Categories.Morphism 𝒞
open import Categories.Morphism.Reasoning 𝒞

open Category 𝒞
open HomReasoning
open Equiv

open Zero 𝒞-Zero

private
  variable
    A B : Obj
    f : A ⇒ B

-- We can express kernels as pullbacks along the morphism '! : ⊥ ⇒ A'.
Kernel⇒Pullback : Kernel f → Pullback f !
Kernel⇒Pullback {f = f} kernel = record
  { p₁ = kernel⇒
  ; p₂ = ¡
  ; isPullback = record
    { commute = commute
    ; universal = λ {C} {h₁} {h₂} eq → universal {h = h₁} $ begin
      f ∘ h₁ ≈⟨ eq ⟩
      ! ∘ h₂ ≈˘⟨ refl⟩∘⟨ ¡-unique h₂ ⟩
      zero⇒ ∎
    ; unique = λ {C} {h₁} {h₂} {i} k-eq h-eq → unique $ begin
      h₁ ≈˘⟨ k-eq ⟩
      kernel⇒ ∘ i ∎
    ; p₁∘universal≈h₁ = ⟺ factors
    ; p₂∘universal≈h₂ = ¡-unique₂ _ _
    }
  }
  where
    open Kernel kernel

-- All pullbacks along the morphism '! : ⊥ ⇒ A' are also kernels.
Pullback⇒Kernel : Pullback f ! → Kernel f
Pullback⇒Kernel {f = f} pullback = record
  { kernel⇒ = p₁
  ; isKernel = record
    { commute = begin
      f ∘ p₁ ≈⟨ commute ⟩
      ! ∘ p₂ ≈˘⟨ refl⟩∘⟨ ¡-unique p₂ ⟩
      zero⇒ ∎
    ; universal = λ eq → universal eq
    ; factors = ⟺ p₁∘universal≈h₁
    ; unique = λ eq → unique (⟺ eq) (⟺ (¡-unique _))
    }
  }
  where
    open Pullback pullback

-- We can also express kernels as the equalizer of 'f' and the zero morphism.
Kernel⇒Equalizer : Kernel f → Equalizer f zero⇒
Kernel⇒Equalizer {f = f} kernel = record
  { arr = kernel⇒
  ; isEqualizer = record
    { equality = begin
      f ∘ kernel⇒ ≈⟨ commute ⟩
      zero⇒       ≈⟨ pushʳ (¡-unique (¡ ∘ kernel⇒)) ⟩
      zero⇒ ∘ kernel⇒ ∎
    ; equalize = λ {_} {h} eq → universal (eq ○ pullʳ (⟺ (¡-unique (¡ ∘ h))))
    ; universal = factors
    ; unique = unique
    }
  }
  where
    open Kernel kernel

-- Furthermore, all equalizers of 'f' and the zero morphism are equalizers
Equalizer⇒Kernel : Equalizer f zero⇒ → Kernel f
Equalizer⇒Kernel {f = f} equalizer = record
  { kernel⇒ = arr
  ; isKernel = record
    { commute = begin
      f ∘ arr      ≈⟨ equality ⟩
      zero⇒ ∘ arr ≈⟨ pullʳ (⟺ (¡-unique (¡ ∘ arr))) ⟩
      zero⇒ ∎
    ; universal = λ {_} {h} eq → equalize (eq ○ pushʳ (¡-unique (¡ ∘ h)))
    ; factors = universal
    ; unique = unique
    }
  }
  where
    open Equalizer equalizer

module _ (K : Kernel f) where
  open Kernel K

  Kernel-Mono : Mono kernel⇒
  Kernel-Mono g₁ g₂ eq = begin
    g₁ ≈⟨ unique refl ⟩
    universal universal-∘ ≈˘⟨ unique eq ⟩
    g₂ ∎

module _ (has-kernels : ∀ {A B} → (f : A ⇒ B) → Kernel f) where

  -- The kernel of a kernel is isomorphic to the zero object.
  kernel²-zero : ∀ {A B} {f : A ⇒ B} → Kernel.kernel (has-kernels (Kernel.kernel⇒ (has-kernels f))) ≅ zero
  kernel²-zero {B = B} {f = f} = pullback-up-to-iso kernel-pullback (pullback-mono-mono !-Mono)
    where
      K : Kernel f
      K = has-kernels f

      module K = Kernel K

      K′ : Kernel K.kernel⇒
      K′ = has-kernels K.kernel⇒

      kernel-pullback : Pullback ! !
      kernel-pullback = Pullback-resp-≈ (glue-pullback (Kernel⇒Pullback K) (swap (Kernel⇒Pullback K′))) (!-unique (f ∘ !)) refl

      pullback-mono-mono : ∀ {A B} {f : A ⇒ B} → Mono f → Pullback f f
      pullback-mono-mono mono = record
        { p₁ = id
        ; p₂ = id
        ; isPullback = pullback-self-mono mono
        }


------------------------------------------------------------------------------
-- Abelian group base
------------------------------------------------------------------------------

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

module GroupTheory.AbelianGroup.Base where

-- We use the group theory base
open import GroupTheory.Base public

------------------------------------------------------------------------------
-- Abelian group theory axioms

-- We only need to add the commutativity axiom.
postulate comm : ∀ a b → a · b ≡ b · a
{-# ATP axiom comm #-}


{-

Mayer-Vietoris cofiber sequence:

  Let X be a pointed type, and let a span B ←[f]- X -[g]→ C be given.
  Then the mapping cone of the canonical map (B ⋁ C) → B ⊔_X C is equivalent to Susp X.

The sequence Susp X → (B ⋁ C) → B ⊔_X C therefore induces a long exact sequence in cohomology.
Proof is adapted from Evan Cavallo's master's thesis.

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Homotopy.MayerVietorisCofiber where

open import Cubical.Core.Everything
open import Cubical.Foundations.Everything
open import Cubical.Foundations.Pointed
open import Cubical.Data.Unit
open import Cubical.HITs.MappingCones
open import Cubical.HITs.Pushout
open import Cubical.HITs.Susp
open import Cubical.HITs.Wedge

module _ {ℓX ℓB ℓC} {X : Pointed ℓX} {B : Type ℓB} {C : Type ℓC} (f : X .fst → B) (g : X .fst → C)
  where

  private
    Y : Pointed _
    Y = (B , f (X .snd))

    Z : Pointed _
    Z = (C , g (X .snd))

  wedgeToPushout : Y ⋁ Z → Pushout f g
  wedgeToPushout (inl y) = inl y
  wedgeToPushout (inr z) = inr z
  wedgeToPushout (push _ i) = push (pt X) i

  pushoutToSusp : Pushout f g → Susp (X .fst)
  pushoutToSusp (inl y) = north
  pushoutToSusp (inr z) = south
  pushoutToSusp (push x i) = merid x i

  {-
    Coherence lemma:
    To construct a function f : (c : Cone wedgeToPushout) → D c, we can always
    adjust the definition of (f (spoke (inr z) i)) so that there is a canonical
    choice for (f (spoke (push tt j) i))
  -}
  module Helper {ℓD} {D : Cone wedgeToPushout → Type ℓD}
    (inj* : ∀ w → D (inj w))
    (hub* : D hub)
    (inl* : ∀ y → PathP (λ i → D (spoke (inl y) i)) hub* (inj* (inl y)))
    (inr* : ∀ z → PathP (λ i → D (spoke (inr z) i)) hub* (inj* (inr z)))
    where

    cap : (i j : I) → D (spoke (push tt j) i)
    cap i j =
      fill
        (λ i → D (spoke (push tt j) (~ i)))
        (λ i → λ
          { (j = i0) → inl* (Y .snd) (~ i)
          ; (j = i1) → inr* (Z .snd) (~ i)
          })
        (inS (inj* (push (X .snd) j)))
        (~ i)

    cap0 : (j : I) → D hub
    cap0 = cap i0

    face-i≡0 : (k j : I) → D hub
    face-i≡0 k j =
      hfill
        (λ j → λ
          { (k = i0) → cap0 j
          ; (k = i1) → hub*
          })
        (inS hub*)
        j

    inrFiller : ∀ z → (k i : I) → D (spoke (inr z) i)
    inrFiller z k i =
     hfill
       (λ k → λ
         { (i = i0) → face-i≡0 k i1
         ; (i = i1) → inj* (inr z)
         })
       (inS (inr* z i))
       k

    fun : ∀ c → D c
    fun (inj w) = inj* w
    fun hub = hub*
    fun (spoke (inl y) i) = inl* y i
    fun (spoke (inr z) i) = inrFiller z i1 i
    fun (spoke (push tt j) i) =
      hcomp
        (λ k → λ
          { (i = i0) → face-i≡0 k j
          ; (i = i1) → inj* (push (X .snd) j)
          ; (j = i0) → inl* (Y .snd) i
          })
        (cap i j)

  equiv : Cone wedgeToPushout ≃ Susp (X .fst)
  equiv = isoToEquiv (iso fwd bwd fwdBwd bwdFwd)
    where
    fwd : Cone wedgeToPushout → Susp (X .fst)
    fwd (inj w) = pushoutToSusp w
    fwd hub = north
    fwd (spoke (inl y) i) = north
    fwd (spoke (inr z) i) = merid (X .snd) i
    fwd (spoke (push tt j) i) = merid (X .snd) (i ∧ j)

    bwd : Susp (X .fst) → Cone wedgeToPushout
    bwd north = hub
    bwd south = hub
    bwd (merid x i) =
      hcomp
        (λ k → λ
          { (i = i0) → spoke (inl (f x)) (~ k)
          ; (i = i1) → spoke (inr (g x)) (~ k)
          })
        (inj (push x i))

    bwdPushout : (w : Pushout f g) → bwd (pushoutToSusp w) ≡ inj w
    bwdPushout (inl y) = spoke (inl y)
    bwdPushout (inr z) = spoke (inr z)
    bwdPushout (push x i) k =
      hfill
        (λ k → λ
          { (i = i0) → spoke (inl (f x)) (~ k)
          ; (i = i1) → spoke (inr (g x)) (~ k)
          })
        (inS (inj (push x i)))
        (~ k)

    bwdMeridPt : refl ≡ cong bwd (merid (X .snd))
    bwdMeridPt j i =
      hcomp
        (λ k → λ
          { (i = i0) → spoke (inl (Y .snd)) (~ k)
          ; (i = i1) → spoke (inr (Z .snd)) (~ k)
          ; (j = i0) → spoke (push _ i) (~ k)
          })
        (inj (push (X .snd) i))

    bwdFwd : (c : Cone wedgeToPushout) → bwd (fwd c) ≡ c
    bwdFwd =
      Helper.fun
        bwdPushout
        refl
        (λ y i k → spoke (inl y) (i ∧ k))
        (λ z i k →
          hcomp
            (λ l → λ
              { (i = i0) → hub
              ; (i = i1) → spoke (inr z) k
              ; (k = i0) → bwdMeridPt l i
              ; (k = i1) → spoke (inr z) i
              })
            (spoke (inr z) (i ∧ k)))

    fwdBwd : (s : Susp (X .fst)) → fwd (bwd s) ≡ s
    fwdBwd north = refl
    fwdBwd south = merid (X .snd)
    fwdBwd (merid a i) j =
      fill
        (λ _ → Susp (X .fst))
        (λ j → λ
          { (i = i0) → north
          ; (i = i1) → merid (X .snd) (~ j)
          })
        (inS (merid a i))
        (~ j)


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Reflexivity

module Oscar.Class.Reflexivity.Function where

module _
  {a}
  where

  instance

    𝓡eflexivityFunction : Reflexivity.class Function⟦ a ⟧
    𝓡eflexivityFunction .⋆ = ¡


module Relation.Ternary.Separation.Monad.Identity where

open import Level
open import Function
open import Function using (_∘_; case_of_)
open import Relation.Binary.PropositionalEquality
open import Relation.Unary
open import Relation.Unary.PredicateTransformer hiding (_⊔_)
open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Monad
open import Relation.Ternary.Separation.Morphisms

open import Data.Unit
open Monads

module Identity {ℓ}
  {C : Set ℓ} {u}
  {{r : RawSep C}}
  {{us : IsUnitalSep r u}}
 where

  Id : ∀ {ℓ} → Pt C ℓ
  Id P = P

  instance
    id-monad : Monad ⊤ ℓ (λ _ _ → Id)
    Monad.return id-monad = id
    app (Monad.bind id-monad f) px = app f px


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

module Fragment.Examples.CSemigroup.Arith.Functions where

open import Fragment.Examples.CSemigroup.Arith.Base

-- Fully dynamic associativity

+-dyn-assoc₁ : ∀ {f : ℕ → ℕ} {m n o} → (f m + n) + o ≡ f m + (n + o)
+-dyn-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-dyn-assoc₂ : ∀ {f g : ℕ → ℕ} {m n o p} → ((f m + n) + o) + g p ≡ f m + (n + (o + g p))
+-dyn-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-dyn-assoc₃ : ∀ {f g h : ℕ → ℕ} {m n o p q} → (f m + n) + g o + (p + h q) ≡ f m + (n + g o + p) + h q
+-dyn-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-dyn-assoc₁ : ∀ {f : ℕ → ℕ} {m n o} → (f m * n) * o ≡ f m * (n * o)
*-dyn-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-dyn-assoc₂ : ∀ {f g : ℕ → ℕ} {m n o p} → ((f m * n) * o) * g p ≡ f m * (n * (o * g p))
*-dyn-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-dyn-assoc₃ : ∀ {f g h : ℕ → ℕ} {m n o p q} → (f m * n) * g o * (p * h q) ≡ f m * (n * g o * p) * h q
*-dyn-assoc₃ = fragment CSemigroupFrex *-csemigroup

-- Fully dynamic commutativity

+-dyn-comm₁ : ∀ {f : ℕ → ℕ} {m} → f m + m ≡ m + f m
+-dyn-comm₁ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm₂ : ∀ {f g : ℕ → ℕ} {m n o} → f m + (n + g o) ≡ (g o + n) + f m
+-dyn-comm₂ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm₃ : ∀ {f g h : ℕ → ℕ} {m n o p} → (f m + g n) + (h o + p) ≡ (p + h o) + (g n + f m)
+-dyn-comm₃ = fragment CSemigroupFrex +-csemigroup

*-dyn-comm₁ : ∀ {f : ℕ → ℕ} {m} → f m * m ≡ m * f m
*-dyn-comm₁ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm₂ : ∀ {f g : ℕ → ℕ} {m n o} → f m * (n * g o) ≡ (g o * n) * f m
*-dyn-comm₂ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm₃ : ∀ {f g h : ℕ → ℕ} {m n o p} → (f m * g n) * (h o * p) ≡ (p * h o) * (g n * f m)
*-dyn-comm₃ = fragment CSemigroupFrex *-csemigroup

-- Fully dynamic associavity and commutativity

+-dyn-comm-assoc₁ : ∀ {f : ℕ → ℕ} {m} → (f m + f (f m)) + f (f (f m)) ≡ f (f (f m)) + (f (f m) + f m)
+-dyn-comm-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm-assoc₂ : ∀ {f g : ℕ → ℕ} {m n} → ((f m + f n) + g m) + g n ≡ g m + (f n + (g n + f m))
+-dyn-comm-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-dyn-comm-assoc₃ : ∀ {f : ℕ → ℕ} {m n o p q} → f (m + n) + o + (p + q) ≡ f (m + n) + q + (p + o)
+-dyn-comm-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-dyn-comm-assoc₁ : ∀ {f : ℕ → ℕ} {m} → (f m * f (f m)) * f (f (f m)) ≡ f (f (f m)) * (f (f m) * f m)
*-dyn-comm-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm-assoc₂ : ∀ {f g : ℕ → ℕ} {m n} → ((f m * f n) * g m) * g n ≡ g m * (f n * (g n * f m))
*-dyn-comm-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-dyn-comm-assoc₃ : ∀ {f : ℕ → ℕ} {m n o p q} → f (m + n) * o * (p * q) ≡ f (m + n) * q * (p * o)
*-dyn-comm-assoc₃ = fragment CSemigroupFrex *-csemigroup

-- Partially static associativity

+-sta-assoc₁ : ∀ {f : ℕ → ℕ} {m} → (m + 2) + (3 + f 0) ≡ m + (5 + f 0)
+-sta-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-sta-assoc₂ : ∀ {f g : ℕ → ℕ} {m n o p} → (((f m + g n) + 5) + o) + p ≡ f m + (g n + (2 + (3 + (o + p))))
+-sta-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-sta-assoc₃ : ∀ {f : ℕ → ℕ} {m n o p} → f (n + m) + (n + 2) + (3 + (o + p)) ≡ (((n + 1) + (4 + o)) + p) + f (n + m)
+-sta-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-sta-assoc₁ : ∀ {f : ℕ → ℕ} {m} → (m * 2) * (3 * f 0) ≡ m * (6 * f 0)
*-sta-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-sta-assoc₂ : ∀ {f g : ℕ → ℕ} {m n o p} → (((f m * g n) * 6) * o) * p ≡ f m * (g n * (2 * (3 * (o * p))))
*-sta-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-sta-assoc₃ : ∀ {f : ℕ → ℕ} {m n o p} → f (n + m) * (n * 4) * (3 * (o * p)) ≡ (((n * 2) * (6 * o)) * p) * f (n + m)
*-sta-assoc₃ = fragment CSemigroupFrex *-csemigroup

-- Partially static commutativity

+-sta-comm₁ : ∀ {f g : ℕ → ℕ} {m} → f m + g 1 ≡ g 1 + f m
+-sta-comm₁ = fragment CSemigroupFrex +-csemigroup

+-sta-comm₂ : ∀ {f g : ℕ → ℕ} {m n} → f m + (2 + g n) ≡ (g n + 2) + f m
+-sta-comm₂ = fragment CSemigroupFrex +-csemigroup

+-sta-comm₃ : ∀ {f g h : ℕ → ℕ} {m n o p} → (1 + (f m + g n)) + ((o + p) + h 2) ≡ ((p + o) + h 2) + (1 + (g n + f m))
+-sta-comm₃ = fragment CSemigroupFrex +-csemigroup

*-sta-comm₁ : ∀ {f g : ℕ → ℕ} {m} → f m * g 1 ≡ g 1 * f m
*-sta-comm₁ = fragment CSemigroupFrex *-csemigroup

*-sta-comm₂ : ∀ {f g : ℕ → ℕ} {m n} → f m * (2 * g n) ≡ (g n * 2) * f m
*-sta-comm₂ = fragment CSemigroupFrex *-csemigroup

*-sta-comm₃ : ∀ {f g h : ℕ → ℕ} {m n o p} → (3 * (f m * g n)) * ((o * p) * h 2) ≡ ((p * o) * h 2) * (3 * (g n * f m))
*-sta-comm₃ = fragment CSemigroupFrex *-csemigroup

-- Partially static associavity and commutativity

+-sta-comm-assoc₁ : ∀ {f : ℕ → ℕ} {m n o} → 1 + (f m + n) + f o + 4 ≡ 5 + n + (f m + f o)
+-sta-comm-assoc₁ = fragment CSemigroupFrex +-csemigroup

+-sta-comm-assoc₂ : ∀ {f g : ℕ → ℕ} {m n o p} → 5 + ((f m + n) + o) + g p ≡ g p + ((o + 1) + (n + f m)) + 4
+-sta-comm-assoc₂ = fragment CSemigroupFrex +-csemigroup

+-sta-comm-assoc₃ : ∀ {f g h : ℕ → ℕ} {m n o p q} → (f m + g n + 1) + o + (p + h q + 4) ≡ (2 + h q) + (p + o + g n) + (f m + 3)
+-sta-comm-assoc₃ = fragment CSemigroupFrex +-csemigroup

*-sta-comm-assoc₁ : ∀ {f : ℕ → ℕ} {m n o} → 2 * (f m * n) * f o * 6 ≡ 12 * n * (f m * f o)
*-sta-comm-assoc₁ = fragment CSemigroupFrex *-csemigroup

*-sta-comm-assoc₂ : ∀ {f g : ℕ → ℕ} {m n o p} → 12 * ((f m * n) * o) * g p ≡ g p * ((o * 2) * (n * f m)) * 6
*-sta-comm-assoc₂ = fragment CSemigroupFrex *-csemigroup

*-sta-comm-assoc₃ : ∀ {f g h : ℕ → ℕ} {m n o p q} → (f m * g n * 2) * o * (p * h q * 6) ≡ (4 * h q) * (p * o * g n) * (f m * 3)
*-sta-comm-assoc₃ = fragment CSemigroupFrex *-csemigroup


------------------------------------------------------------------------
-- Some properties related to the const function
------------------------------------------------------------------------

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

open import Equality

module Const
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Logical-equivalence using (_⇔_)
open import Prelude

import Bijection eq as Bijection
open Derived-definitions-and-properties eq
open import Embedding eq
open import Equivalence eq as Eq using (_≃_)
open import Fin eq
open import Function-universe eq
open import H-level eq
open import H-level.Closure eq
open import Injection eq using (Injective)
import Nat eq as Nat
open import Univalence-axiom eq

-- If A is inhabited, then the function const : B → (A → B) is
-- injective.

const-is-injective :
  ∀ {a b} →
  {A : Type a} {B : Type b} →
  A → Injective {B = A → B} const
const-is-injective x {y} {z} =
  const y ≡ const z  ↝⟨ cong (_$ x) ⟩□
  y ≡ z              □

-- Thus, if B is a set, then const is also an embedding (assuming
-- extensionality).

const-is-embedding :
  ∀ {a b} →
  Extensionality (a ⊔ b) (a ⊔ b) →
  {A : Type a} {B : Type b} →
  Is-set B →
  A → Is-embedding {B = A → B} const
const-is-embedding {a} {b} ext B-set x =
  _≃_.to (Injective≃Is-embedding
            ext B-set
            (Π-closure (lower-extensionality b a ext) 2 λ _ →
             B-set)
            const)
    (const-is-injective x)

-- However, if B is not a set, then one can construct a counterexample
-- (assuming extensionality and univalence).
--
-- This example is due to Thierry Coquand. (His proof was not
-- identical to the one below.)

const-is-not-embedding :
  ∀ {a b} →
  Extensionality (a ⊔ b) (lsuc b) →
  Univalence b →
  Univalence (# 0) →
  ¬ ({A : Type a} {B : Type (lsuc b)} →
     A → Is-embedding {B = A → B} const)
const-is-not-embedding {a} {b} ext univ univ₀ hyp =
  from-⊎ (2 Nat.≟ 4) 2≡4
  where
  ext-b : Extensionality b b
  ext-b = lower-extensionality a (lsuc b) ext

  ext-ab₊ : Extensionality a (lsuc b)
  ext-ab₊ = lower-extensionality b lzero ext

  ext₁ : Extensionality (# 0) (# 1)
  ext₁ = lower-extensionality _ (lsuc b) ext

  ext₀ : Extensionality (# 0) (# 0)
  ext₀ = lower-extensionality _ _ ext

  emb : Is-embedding {B = ↑ a (Fin 2) → Type b} const
  emb = hyp (lift true)

  2≡4 : 2 ≡ 4
  2≡4 = _⇔_.to isomorphic-same-size (
    Fin 2                                      ↝⟨ inverse $ [Fin≡Fin]↔Fin! ext₀ univ₀ 2 ⟩
    Fin 2 ≡ Fin 2                              ↔⟨ inverse $ ≡-preserves-≃ ext-b univ univ₀ (Eq.↔⇒≃ Bijection.↑↔) (Eq.↔⇒≃ Bijection.↑↔) ⟩
    ↑ b (Fin 2) ≡ ↑ b (Fin 2)                  ↔⟨ Eq.⟨ _ , emb (↑ b (Fin 2)) (↑ b (Fin 2)) ⟩ ⟩
    const (↑ b (Fin 2)) ≡ const (↑ b (Fin 2))  ↔⟨ inverse $ Eq.extensionality-isomorphism ext-ab₊ ⟩
    (↑ a (Fin 2) → ↑ b (Fin 2) ≡ ↑ b (Fin 2))  ↔⟨ →-cong ext-ab₊ (Eq.↔⇒≃ Bijection.↑↔)
                                                    (≡-preserves-≃ ext-b univ univ₀ (Eq.↔⇒≃ Bijection.↑↔) (Eq.↔⇒≃ Bijection.↑↔)) ⟩
    (Fin 2 → Fin 2 ≡ Fin 2)                    ↝⟨ ∀-cong ext₁ (λ _ → [Fin≡Fin]↔Fin! ext₀ univ₀ 2) ⟩
    (Fin 2 → Fin 2)                            ↝⟨ [Fin→Fin]↔Fin^ ext₀ 2 2 ⟩□
    Fin 4                                      □)


module Data.List.Proofs.Length where

import Lvl
open import Functional
open import Function.Names as Names using (_⊜_)
open import Data.Boolean
open import Data.List as List
open import Data.List.Functions
open import Logic
open import Logic.Propositional
open import Numeral.Finite
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function.Multi
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₑ : Lvl.Level
private variable T A B : Type{ℓ}
private variable l l₁ l₂ : List(T)
private variable a b x : T
private variable n : ℕ
private variable f : A → B
private variable P : List(T) → Stmt{ℓ}

-- TODO: Almost all of these can use Preserving instead

length-[∅] : (length(∅ {T = T}) ≡ 0)
length-[∅] = [≡]-intro

length-singleton : (length{T = T}(singleton(a)) ≡ 1)
length-singleton = [≡]-intro

instance
  length-preserves-prepend : Preserving₁(length)(a ⊰_)(𝐒)
  Preserving.proof (length-preserves-prepend {a = a}) {x} = [≡]-intro

length-postpend : ((length ∘ postpend a) ⊜ (𝐒 ∘ length))
length-postpend {x = l} = List.elim [≡]-intro (\x l → [≡]-with(𝐒) {length(postpend _ l)}{𝐒(length l)}) l

instance
  length-preserves-postpend : Preserving₁(length)(postpend a)(𝐒)
  Preserving.proof (length-preserves-postpend {a = a}) {x} = length-postpend {a = a}{x = x}

length-[++] : (length{T = T}(l₁ ++ l₂) ≡ length(l₁) + length(l₂))
length-[++] {T = T} {l₁ = l₁} {l₂} = List.elim base next l₁ where
  base : length(∅ ++ l₂) ≡ length{T = T}(∅) + length(l₂)
  base = symmetry(_≡_) (identityₗ(_+_)(0))

  next : ∀(x)(l) → (length(l ++ l₂) ≡ length(l) + length(l₂)) → (length((x ⊰ l) ++ l₂) ≡ length(x ⊰ l) + length(l₂))
  next x l stmt =
    length((x ⊰ l) ++ l₂)      🝖[ _≡_ ]-[]
    length(x ⊰ (l ++ l₂))      🝖[ _≡_ ]-[]
    𝐒(length(l ++ l₂))         🝖[ _≡_ ]-[ [≡]-with(𝐒) stmt ]
    𝐒(length(l) + length(l₂))  🝖[ _≡_ ]-[ [+]-stepₗ {length(l)} {length(l₂)} ]
    𝐒(length(l)) + length(l₂)  🝖[ _≡_ ]-[]
    length(x ⊰ l) + length(l₂) 🝖-end

instance
  length-preserves-[++] : Preserving₂(length{T = T})(_++_)(_+_)
  Preserving.proof length-preserves-[++] {l₁} {l₂} = length-[++] {l₁ = l₁} {l₂ = l₂}

length-reverse : ((length{T = T} ∘ reverse) ⊜ length)
length-reverse {x = ∅}     = [≡]-intro
length-reverse {x = x ⊰ l} = length-postpend{a = x}{x = reverse l} 🝖 [≡]-with(𝐒) (length-reverse {x = l})

instance
  length-preserves-reverse : Preserving₁(length{T = T})(reverse)(id)
  Preserving.proof length-preserves-reverse {l} = length-reverse {x = l}

length-repeat : ((length{T = T} ∘ repeat(a)) ⊜ id)
length-repeat{T = T}{x = 𝟎}    = [≡]-intro
length-repeat{T = T}{x = 𝐒(n)} = [≡]-with(𝐒) (length-repeat{T = T}{x = n})

length-tail : ((length{T = T} ∘ tail) ⊜ (𝐏 ∘ length))
length-tail{x = ∅}     = [≡]-intro
length-tail{x = _ ⊰ l} = [≡]-intro

instance
  length-preserves-tail : Preserving₁(length{T = T})(tail)(𝐏)
  Preserving.proof length-preserves-tail {l} = length-tail {x = l}

length-map : ∀{f : A → B} → ((length ∘ map f) ⊜ length)
length-map {f = f}{x = ∅}     = [≡]-intro
length-map {f = f}{x = x ⊰ l} = [≡]-with(𝐒) (length-map {f = f}{x = l})

instance
  length-preserves-map : Preserving₁(length{T = T})(map f)(id)
  Preserving.proof (length-preserves-map {f = f}) {l} = length-map {f = f}{x = l}

length-foldᵣ : ∀{init}{f}{g} → (∀{x}{l} → (length(f x l) ≡ g x (length l))) → (length{T = T}(foldᵣ f init l) ≡ foldᵣ g (length init) l)
length-foldᵣ {l = ∅}                    _ = [≡]-intro
length-foldᵣ {l = x ⊰ l} {init} {f} {g} p =
  length(foldᵣ f init (x ⊰ l))    🝖[ _≡_ ]-[]
  length(f(x) (foldᵣ f init l))   🝖[ _≡_ ]-[ p ]
  g(x) (length(foldᵣ f init l))   🝖[ _≡_ ]-[ [≡]-with(g(x)) (length-foldᵣ {l = l} {init} {f} {g} p) ]
  g(x) (foldᵣ g (length init) l)  🝖[ _≡_ ]-[]
  foldᵣ g (length init) (x ⊰ l)   🝖-end

length-concatMap : ∀{f} → (length{T = T}(concatMap f l) ≡ foldᵣ((_+_) ∘ length ∘ f) 𝟎 l)
length-concatMap {l = l} {f} = length-foldᵣ{l = l}{init = ∅}{f = (_++_) ∘ f} \{x l} → length-[++] {l₁ = f(x)}{l₂ = l}

length-accumulateIterate₀ : ∀{n}{f}{init : T} → (length(accumulateIterate₀ n f init) ≡ n)
length-accumulateIterate₀ {n = 𝟎}      = [≡]-intro
length-accumulateIterate₀ {n = 𝐒 n}{f} = [≡]-with(𝐒) (length-accumulateIterate₀ {n = n}{f})

length-[++^] : (length(l ++^ n) ≡ length(l) ⋅ n)
length-[++^] {l = l}{𝟎}    = [≡]-intro
length-[++^] {l = l}{𝐒(n)} =
  length-[++] {l₁ = l}{l ++^ n}
  🝖 [≡]-with(expr ↦ length(l) + expr) (length-[++^] {l = l}{n})

length-isEmpty : (length(l) ≡ 0) ↔ (isEmpty(l) ≡ 𝑇)
length-isEmpty {l = ∅}     = [↔]-intro (const [≡]-intro) (const [≡]-intro)
length-isEmpty {l = x ⊰ L} = [↔]-intro (\()) (\())

instance
  length-preserves-insert : Preserving₁(length)(insert n x)(𝐒)
  Preserving.proof (length-preserves-insert {n = n}) = proof{n = n} where
    proof : ∀{n} → (length(insert n x l) ≡ 𝐒(length l))
    proof         {l = _}     {n = 𝟎}   = [≡]-intro
    proof         {l = ∅}     {n = 𝐒 n} = [≡]-intro
    proof {x = x} {l = y ⊰ l} {n = 𝐒 n} rewrite proof {x = x} {l = l} {n = n} = [≡]-intro

length-insertIn : ∀{n} → (length(insertIn x l n) ≡ 𝐒(length l))
length-insertIn         {l = _}     {n = 𝟎}   = [≡]-intro
length-insertIn         {l = ∅}     {n = 𝐒 n} = [≡]-intro
length-insertIn {x = x} {l = y ⊰ l} {n = 𝐒 n} rewrite length-insertIn {x = x} {l = l} {n = n} = [≡]-intro


{-# OPTIONS --without-K #-}
module container.m.from-nat where

open import container.m.from-nat.core public
open import container.m.from-nat.cone public
open import container.m.from-nat.coalgebra public
open import container.m.from-nat.bisimulation public


open import Type

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

import      Lvl
open import Graph{ℓ₁}{ℓ₂}(V)
open import Graph.Properties
open import Graph.Walk{ℓ₁}{ℓ₂}{V}
open import Numeral.Natural
open import Syntax.Function
open import Type.Dependent
open import Type.Dependent.Functions

module _ {_⟶_ : Graph} where
  edge : ∀{a b} → (a ⟶ b) → (Walk(_⟶_) a b)
  edge e = prepend e at

  join : ∀{a b c} → (a ⟶ b) → (b ⟶ c) → (Walk(_⟶_) a c)
  join e₁ e₂ = prepend e₁ (edge e₂)

  _++_ : ∀{a b c} → Walk(_⟶_) a b → Walk(_⟶_) b c → Walk(_⟶_) a c
  at            ++ w₂ = w₂
  prepend e₁ w₁ ++ w₂ = prepend e₁ (w₁ ++ w₂)

  postpend : ∀{a b c} → (Walk(_⟶_) a b) → (b ⟶ c) → (Walk(_⟶_) a c)
  postpend at             e₂ = edge e₂
  postpend (prepend e₁ w) e₂ = prepend e₁ (postpend w e₂)

  reverse : ⦃ Undirected(_⟶_) ⦄ → ∀{a b} → Walk(_⟶_) a b → Walk(_⟶_) b a
  reverse at            = at
  reverse (prepend e w) = postpend (reverse w) (undirected-reverse(_⟶_) e)

  prelop : ∀{a c} → (Walk(_⟶_) a c) → Σ(_)(b ↦ Walk(_⟶_) b c)
  prelop at            = intro _ at
  prelop (prepend e w) = intro _ w

  postlop : ∀{a c} → (Walk(_⟶_) a c) → Σ(_)(b ↦ Walk(_⟶_) a b)
  postlop at                          = intro _ at
  postlop (prepend e  at)             = intro _ at
  postlop (prepend e₁ (prepend e₂ w)) = [Σ]-applyᵣ (postlop(prepend e₂ w)) (prepend e₁)

  length : ∀{a b} → (Walk(_⟶_) a b) → ℕ
  length at            = 𝟎
  length (prepend _ w) = 𝐒(length w)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Structures.Action where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Structure
open import Cubical.Functions.FunExtEquiv

open import Cubical.Data.Sigma

open import Cubical.Algebra.Group
open import Cubical.Structures.LeftAction

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Properties

open import Cubical.DStructures.Structures.Constant
open import Cubical.DStructures.Structures.Type
open import Cubical.DStructures.Structures.Group

private
  module _ {ℓ ℓ' : Level} where
    Las : ((G , H) : Group {ℓ} × Group {ℓ'}) → Type (ℓ-max ℓ ℓ')
    Las (G , H) = LeftActionStructure ⟨ G ⟩ ⟨ H ⟩

module _ (ℓ ℓ' : Level) where
  G²Las = Σ[ GH ∈ G² ℓ ℓ' ] Las GH
  GGLas = Σ[ G ∈ Group {ℓ} ] Σ[ H ∈ Group {ℓ'} ] Las (G , H)
  Action = Σ[ ((G , H) , _α_) ∈ G²Las ] (IsGroupAction G H _α_)
  G²LasAct = Σ[ (G , H) ∈ G² ℓ ℓ' ] Σ[ α ∈ Las (G , H) ] IsGroupAction G H α
  GGLasAct = Σ[ G ∈ Group {ℓ} ] Σ[ H ∈ Group {ℓ'} ] Σ[ α ∈ Las (G , H) ] IsGroupAction G H α

  IsoAction : Iso Action GGLasAct
  IsoAction = compIso Σ-assoc-Iso Σ-assoc-Iso

  -- two groups with an action structure, i.e. a map ⟨ G ⟩ → ⟨ H ⟩ → ⟨ H ⟩
  𝒮ᴰ-G²\Las : URGStrᴰ (𝒮-group ℓ ×𝒮 𝒮-group ℓ')
                      (λ GH → Las GH)
                      (ℓ-max ℓ ℓ')
  𝒮ᴰ-G²\Las =
    make-𝒮ᴰ (λ {(G , H)} _α_ (eG , eH) _β_
                   → (g : ⟨ G ⟩) (h : ⟨ H ⟩)
                     → GroupEquiv.eq eH .fst (g α h) ≡ (GroupEquiv.eq eG .fst g) β (GroupEquiv.eq eH .fst h))
                (λ _ _ _ → refl)
                λ (G , H) _α_ → isContrRespectEquiv
                                                       -- (Σ[ _β_ ∈ Las (G , H) ] (_α_ ≡ _β_)
                                                       (Σ-cong-equiv-snd (λ _β_ → invEquiv funExt₂Equiv))
                                                       (isContrSingl _α_)

  𝒮-G²Las : URGStr G²Las (ℓ-max ℓ ℓ')
  𝒮-G²Las = ∫⟨ 𝒮-group ℓ ×𝒮 𝒮-group ℓ' ⟩ 𝒮ᴰ-G²\Las

  open ActionΣTheory

  𝒮ᴰ-G²Las\Action : URGStrᴰ 𝒮-G²Las
                     (λ ((G , H) , _α_) → IsGroupAction G H _α_)
                     ℓ-zero
  𝒮ᴰ-G²Las\Action = Subtype→Sub-𝒮ᴰ (λ ((G , H) , _α_) → IsGroupAction G H _α_ , isPropIsGroupAction G H _α_)
                             𝒮-G²Las

  𝒮-G²LasAction : URGStr Action (ℓ-max ℓ ℓ')
  𝒮-G²LasAction = ∫⟨ 𝒮-G²Las ⟩ 𝒮ᴰ-G²Las\Action

  𝒮-Action = 𝒮-G²LasAction

  𝒮ᴰ-G\GLasAction : URGStrᴰ (𝒮-group ℓ)
                            (λ G → Σ[ H ∈ Group {ℓ'} ] Σ[ α ∈ Las (G , H) ] IsGroupAction G H α)
                            (ℓ-max ℓ ℓ')
  𝒮ᴰ-G\GLasAction =
    splitTotal-𝒮ᴰ (𝒮-group ℓ)
                  (𝒮ᴰ-const (𝒮-group ℓ) (𝒮-group ℓ'))
                  (splitTotal-𝒮ᴰ (𝒮-group ℓ ×𝒮 𝒮-group ℓ')
                                 𝒮ᴰ-G²\Las
                                 𝒮ᴰ-G²Las\Action)


-- Record declarations can now contain arbitrary declarations.
-- These are included in the projection module.
module FancyRecordModule where

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

record Exist {A : Set}(P : A -> Set) : Set where
  field witness : A
  x = witness
  field proof   : P x
  silly : Nat -> Nat
  silly zero = zero
  silly (suc n) = silly n

postulate
  P : Nat -> Set
  e : Exist P

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

test : Exist.silly e (suc zero) == zero
test = refl


-- Andreas, 2012-01-10
-- {-# OPTIONS -v tc.constr.findInScope:50 #-}
module InstanceGuessesMeta2 where

open import Common.Level

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

record takeClass {a}
  (F : Set a → Set a)
  (G : Set a → ℕ → Set a) : Set (lsuc a) where
  field
    take : {A : Set a} → (n : ℕ) → F A → G A n

take : ∀ {a} {A : Set a} {F : Set a → Set a} {G : Set a → ℕ → Set a}
   {{takeA : takeClass F G}} →
   (n : ℕ) → F A → G A n
take {{takeA}} = takeClass.take takeA

postulate
  List : ∀ {a} → Set a → Set a
  BVec : ∀ {a} → Set a → ℕ → Set a
  toList : ∀ {a}{A : Set a}{n : ℕ} → BVec A n → List A
  -- universe polymorphic instance
  takeInstanceList : {a : Level} → takeClass (List {a = a}) BVec

take0 : {A : Set} → List A → BVec A zero
take0 l = take zero l

take1 : {A : Set} → List A → List A
take1 l = toList (take (suc zero) l)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Notation for freely adding extrema to any set
------------------------------------------------------------------------

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

module Relation.Nullary.Construct.Add.Extrema where

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary.Construct.Add.Infimum  as Infimum  using (_₋)
open import Relation.Nullary.Construct.Add.Supremum as Supremum using (_⁺)

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

_± : ∀ {a} → Set a → Set a
A ± = A ₋ ⁺

pattern ⊥±    = Supremum.[ Infimum.⊥₋ ]
pattern [_] k = Supremum.[ Infimum.[ k ] ]
pattern ⊤±    = Supremum.⊤⁺

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

[_]-injective : ∀ {a} {A : Set a} {k l : A} → [ k ] ≡ [ l ] → k ≡ l
[_]-injective refl = refl


module Structure.Category.NaturalTransformation.Equiv where

import      Function.Equals
open        Function.Equals.Dependent
import      Lvl
open import Logic
open import Logic.Predicate
open import Structure.Category
open import Structure.Category.Functor
open import Structure.Category.NaturalTransformation
open import Structure.Setoid
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Type

module _
  {ℓₗₒ ℓₗₘ ℓₗₑ ℓᵣₒ ℓᵣₘ ℓᵣₑ}
  {catₗ : CategoryObject{ℓₗₒ}{ℓₗₘ}{ℓₗₑ}}
  {catᵣ : CategoryObject{ℓᵣₒ}{ℓᵣₘ}{ℓᵣₑ}}
  {F₁ : catₗ →ᶠᵘⁿᶜᵗᵒʳ catᵣ}
  {F₂ : catₗ →ᶠᵘⁿᶜᵗᵒʳ catᵣ}
  where

  _≡ᴺᵀ_ : (F₁ →ᴺᵀ F₂) → (F₁ →ᴺᵀ F₂) → Stmt
  [∃]-intro N₁ ≡ᴺᵀ [∃]-intro N₂ = N₁ ⊜ N₂

  instance
    [≡ᴺᵀ]-reflexivity : Reflexivity(_≡ᴺᵀ_)
    Reflexivity.proof [≡ᴺᵀ]-reflexivity = reflexivity(_⊜_)

  instance
    [≡ᴺᵀ]-symmetry : Symmetry(_≡ᴺᵀ_)
    Symmetry.proof [≡ᴺᵀ]-symmetry = symmetry(_⊜_)

  instance
    [≡ᴺᵀ]-transitivity : Transitivity(_≡ᴺᵀ_)
    Transitivity.proof [≡ᴺᵀ]-transitivity = transitivity(_⊜_)

  instance
    [≡ᴺᵀ]-equivalence : Equivalence(_≡ᴺᵀ_)
    [≡ᴺᵀ]-equivalence = intro

  instance
    [→ᴺᵀ]-equiv : Equiv(F₁ →ᴺᵀ F₂)
    [→ᴺᵀ]-equiv = intro(_≡ᴺᵀ_) ⦃ [≡ᴺᵀ]-equivalence ⦄


------------------------------------------------------------------------------
-- Testing the use of ATP axioms with data constructors
------------------------------------------------------------------------------

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

module DataConstructorsAxioms where

postulate
  D    : Set
  zero : D
  succ : D → D

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

postulate 0-N : N zero
{-# ATP prove 0-N #-}

postulate 1-N : N (succ zero)
{-# ATP prove 1-N #-}