open import Common.Prelude
open import Common.Reflection
open import Common.Equality

data Dec {a} (A : Set a) : Set a where
  yes : A → Dec A
  no  : Dec A

record Eq {a} (A : Set a) : Set a where
  constructor eqDict
  field
    _==_ : (x y : A) → Dec (x ≡ y)

module M {a} {A : Set a} {{EqA : Eq A}} where
  _==_ : (x y : A) → Dec (x ≡ y)
  _==_ = Eq._==_ EqA

open Eq {{...}}

private
  eqNat : (x y : Nat) → Dec (x ≡ y)
  eqNat zero zero = yes refl
  eqNat zero (suc y) = no
  eqNat (suc x) zero = no
  eqNat (suc x) (suc y) with eqNat x y
  eqNat (suc x) (suc .x) | yes refl = yes refl
  ... | no     = no

  eqBool : (x y : Bool) → Dec (x ≡ y)
  eqBool true true = yes refl
  eqBool true false = no
  eqBool false true = no
  eqBool false false = yes refl

unquoteDecl EqNat = define (iArg EqNat)
  (funDef (def (quote Eq) (vArg (def (quote Nat) []) ∷ []))
          (clause [] (con (quote eqDict) (vArg (def (quote eqNat) []) ∷ [])) ∷ []))

instance
  EqBool : Eq Bool
  unquoteDef EqBool =
    defineFun EqBool (clause [] (con (quote eqDict) (vArg (def (quote eqBool) []) ∷ [])) ∷ [])

id : {A : Set} → A → A
id x = x

tm : QName → Term
tm eq = def (quote id) (vArg (def eq (vArg (lit (nat 0)) ∷ vArg (lit (nat 1)) ∷ [])) ∷ [])

tm₂ : QName → Term
tm₂ eq = def eq (iArg (def (quote EqNat) []) ∷ vArg (lit (nat 0)) ∷ vArg (lit (nat 1)) ∷ [])

_==′_ : ∀ {a} {A : Set a} {{EqA : Eq A}} (x y : A) → Dec (x ≡ y)
_==′_ = _==_

ok₁ : Dec (0 ≡ 1)
ok₁ = unquote (give (tm (quote _==′_)))

ok₂ : Dec (0 ≡ 1)
ok₂ = unquote (give (tm₂ (quote _==_)))

ok₃ : Dec (0 ≡ 1)
ok₃ = unquote (give (tm (quote M._==_)))

ok₄ : Dec (true ≡ false)
ok₄ = true == false

ok₅ : Dec (2 ≡ 2)
ok₅ = 2 == 2

-- Was bad.
bad : Dec (0 ≡ 1)
bad = unquote (give (tm (quote _==_)))


module Testing where

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

{-# BUILTIN NATURAL Nat #-}

plus : Nat -> Nat -> Nat
plus zero n = n
plus (suc m) n = suc (plus m n)

times : Nat -> Nat -> Nat
times zero n = zero
times (suc m) n = plus n (times m n)

data List (A : Set) : Nat -> Set where
    nil : List A 0
    cons : {n : Nat} -> A -> List A n -> List A (suc n)

f : Nat -> (b : Nat) -> (a : Nat) -> Nat
f x = plus

-- Push argument doesn't work with implicit
-- Toggle implicit generates code that the tool can't handle
-- also, want to include {something = x} in language

map : {n : Nat} -> {A : Set} -> {B : Set} -> {renameMe0 : A -> B} -> List A n ->
    List B n
map {renameMe0 = f} nil = nil
map {renameMe0 = f} (cons x xs) = cons (f x) (map {_} {_} {_} {f} xs)

map2 : {n : Nat} -> {A : Set} -> {B : Set} -> (A -> B) -> List A n ->
    List B n
map2 f nil = nil
map2 f (cons x xs) = cons (f x) (map2 f xs)
{-
data Eq {A : Set} (x : A) : A -> Set where
  refl : Eq x x

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

data Foo : Set where
  foo : Foo
  bar : Foo

-- Refactoring to introduce these!
{-# FOREIGN GHC data Foo = Foo | Bar #-}
{-# COMPILE GHC Foo = data Foo (Foo | Bar) #-}
-}


module Issue628 where

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

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN SUC suc #-}
{-# BUILTIN ZERO zero #-}

data _≡_ {A : Set}(x : A) : A → Set where
  refl : x ≡ x

data ⊥ : Set where

0≢1+n : ∀ {n} -> 0 ≡ suc n → ⊥
0≢1+n ()

divSucAux : (k m n j : ℕ) -> ℕ
divSucAux k m zero j = k
divSucAux k m (suc n) zero = divSucAux (suc k) m n m
divSucAux k m (suc n) (suc j) = divSucAux k m n j
{-# BUILTIN NATDIVSUCAUX divSucAux #-}

oh-noes : ⊥
oh-noes = 0≢1+n {divSucAux 0 0 0 1} refl


module Pat (BaseType : Set) where

data Ty : Set where
  ι   : BaseType -> Ty
  _⟶_ : Ty -> Ty -> Ty

data Bwd (A : Set) : Set where
  •   : Bwd A
  _◄_ : Bwd A -> A -> Bwd A

infixl 30 _◄_

Ctx = Bwd Ty

data Take {A : Set} : Bwd A -> A -> Bwd A -> Set where
  hd : forall {x xs} -> Take (xs ◄ x) x xs
  tl : forall {x y xs ys} -> Take xs x ys -> Take (xs ◄ y) x (ys ◄ y)

data Pat : Ctx -> Ctx -> Ty -> Ctx -> Set

data Pats : Ctx -> Ty -> Ctx -> Ty -> Set where
  ε : forall {Θ τ} -> Pats Θ τ Θ τ
  _,_ : forall {Θ₁ Θ₂ Θ₃ ρ σ τ} ->
        Pat • Θ₁ ρ Θ₂ -> Pats Θ₂ σ Θ₃ τ ->
        Pats Θ₁ (ρ ⟶ σ) Θ₃ τ

data Pat where
  ƛ    : forall {Δ Θ Θ' σ τ} -> Pat (Δ ◄ σ) Θ τ Θ' ->
         Pat Δ Θ (σ ⟶ τ) Θ'
  _[_] : forall {Θ Θ' Δ σ τ} ->
         Take Θ σ Θ' -> Pats Δ σ • τ -> Pat Δ Θ τ Θ'


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

open import Categories.Category

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

open import Level
open import Data.Product
open import Relation.Binary

open import Categories.Category.Complete
open import Categories.Category.Complete.Finitely
open import Categories.Category.Construction.Functors
open import Categories.Diagram.Limit as Lim
open import Categories.Diagram.Limit.Properties
open import Categories.Diagram.Equalizer.Limit C
open import Categories.Diagram.Cone.Properties
open import Categories.Object.Product.Limit C
open import Categories.Object.Terminal.Limit C
open import Categories.Functor
open import Categories.Functor.Continuous
open import Categories.Functor.Properties
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.NaturalIsomorphism using (_≃_)

import Categories.Category.Construction.Cones as Co
import Categories.Morphism.Reasoning as MR
import Categories.Morphism as Mor
import Categories.Morphism.Properties as Morₚ

private
  variable
    o′ ℓ′ e′ o″ ℓ″ e″ : Level
  module C = Category C

module _ (Com : Complete o′ ℓ′ e′ C) where

  Complete⇒FinitelyComplete : FinitelyComplete C
  Complete⇒FinitelyComplete = record
    { cartesian = record
      { terminal = limit⇒⊥ (Com (⊥⇒limit-F _ _ _))
      ; products = record
        { product = λ {A B} → limit⇒product (Com (product⇒limit-F _ _ _ A B))
        }
      }
    ; equalizer = λ f g → limit⇒equalizer (Com (equalizer⇒limit-F _ _ _ f g))
    }

module _ {D : Category o′ ℓ′ e′} (Com : Complete o″ ℓ″ e″ D) where
  private
    D^C = Functors C D
    module D^C = Category D^C
    module D   = Category D

    module _ {J : Category o″ ℓ″ e″} (F : Functor J D^C) where
      private
        module J = Category J
        module F = Functor F
        open F
        module F₀ j = Functor (F₀ j)
        module F₁ {a b} (f : a J.⇒ b) = NaturalTransformation (F₁ f)

      F[-,_] : C.Obj → Functor J D
      F[-, X ] = record
        { F₀           = λ j → F₀.₀ j X
        ; F₁           = λ f → F₁.η f X
        ; identity     = identity
        ; homomorphism = homomorphism
        ; F-resp-≈     = λ eq → F-resp-≈ eq -- this application cannot be eta reduced
        }

      F[-,-] : Functor C (Functors J D)
      F[-,-] = record
        { F₀           = F[-,_]
        ; F₁           = λ f → ntHelper record
          { η       = λ j → F₀.₁ j f
          ; commute = λ g → F₁.sym-commute g f
          }
        ; identity     = F₀.identity _
        ; homomorphism = F₀.homomorphism _
        ; F-resp-≈     = λ eq → F₀.F-resp-≈ _ eq
        }

      module F[-,-] = Functor F[-,-]

      module LimFX X = Limit (Com F[-, X ])
      open LimFX hiding (commute)

      K⇒lim : ∀ {X Y} (f : X C.⇒ Y) K → Co.Cones F[-, Y ] [ nat-map-Cone (F[-,-].₁ f) K , limit Y ]
      K⇒lim f K = rep-cone _ (nat-map-Cone (F[-,-].₁ f) K)

      lim⇒lim : ∀ {X Y} (f : X C.⇒ Y) → Co.Cones F[-, Y ] [ nat-map-Cone (F[-,-].₁ f) (limit X) , limit Y ]
      lim⇒lim f = K⇒lim f (limit _)

      module lim⇒lim {X Y} (f : X C.⇒ Y) = Co.Cone⇒ F[-, Y ] (lim⇒lim f)

      module FCone (K : Co.Cone F) where
        open Co.Cone F K public
        module N   = Functor N
        module ψ j = NaturalTransformation (ψ j)

      module FCone⇒ {K K′ : Co.Cone F} (K⇒K′ : Co.Cone⇒ F K K′) where
        open Co.Cone⇒ F K⇒K′ public
        module arr = NaturalTransformation arr

      FXcone : ∀ X → (K : Co.Cone F) → Co.Cone F[-, X ]
      FXcone X K = record
        { N    = N.₀ X
        ; apex = record
          { ψ       = λ j → ψ.η j X
          ; commute = λ f → commute f -- this application cannot be eta reduced
          }
        }
        where open FCone K

      ⊤ : Co.Cone F
      ⊤ = record
        { N    = record
          { F₀           = λ X → apex X
          ; F₁           = λ {A B} f → lim⇒lim.arr f
          ; identity     = λ {X} →
            terminal.!-unique X record
            { arr     = D.id
            ; commute = D.identityʳ ○ ⟺ (elimˡ (F₀.identity _))
            }
          ; homomorphism = λ {X Y Z} {f g} →
            terminal.!-unique₂ Z
              {nat-map-Cone (F[-,-].₁ (g C.∘ f)) (limit X)}
              {terminal.! Z}
              {record { commute = λ {j} →
              begin
                proj Z j ∘ lim⇒lim.arr g ∘ lim⇒lim.arr f
                  ≈⟨ pullˡ (lim⇒lim.commute g) ⟩
                (F₀.₁ j g ∘ proj Y j) ∘ lim⇒lim.arr f
                  ≈⟨ pullʳ (lim⇒lim.commute f) ⟩
                F₀.₁ j g ∘ F₀.₁ j f ∘ proj X j
                  ≈˘⟨ pushˡ (F₀.homomorphism j) ⟩
                F₀.₁ j (g C.∘ f) ∘ proj X j
                  ∎ }}
          ; F-resp-≈     = λ {A B} {f g} eq → terminal.!-unique B record
            { commute = lim⇒lim.commute g ○ ∘-resp-≈ˡ (F₀.F-resp-≈ _ (C.Equiv.sym eq)) }
          }
        ; apex = record
          { ψ       = λ j → ntHelper record
            { η       = λ X → proj X j
            ; commute = λ _ → LimFX.commute _
            }
          ; commute = λ f {X} → limit-commute X f
          }
        }
        where open D
              open D.HomReasoning
              open MR D

      K⇒⊤′ : ∀ X {K} → Co.Cones F [ K , ⊤ ] → Co.Cones F[-, X ] [ FXcone X K , LimFX.limit X ]
      K⇒⊤′ X {K} K⇒⊤ = record
        { arr     = arr.η X
        ; commute = comm
        }
        where open FCone⇒ K⇒⊤ renaming (commute to comm)

      complete : Limit F
      complete = record
        { terminal = record
          { ⊤        = ⊤
          ; !        = λ {K} →
            let module K = FCone K
            in record
            { arr     = ntHelper record
              { η       = λ X → rep X (FXcone X K)
              ; commute = λ {X Y} f →
                terminal.!-unique₂ Y
                  {nat-map-Cone (F[-,-].₁ f) (FXcone X K)}
                  {record { commute = λ {j} →
                  begin
                    proj Y j ∘ rep Y (FXcone Y K) ∘ K.N.₁ f ≈⟨ pullˡ (LimFX.commute Y) ⟩
                    K.ψ.η j Y ∘ K.N.F₁ f                    ≈⟨ K.ψ.commute j f ⟩
                    F₀.₁ j f ∘ K.ψ.η j X                    ∎ }}
                  {record { commute = λ {j} →
                  begin
                    proj Y j ∘ lim⇒lim.arr f ∘ rep X (FXcone X K) ≈⟨ pullˡ (lim⇒lim.commute f) ⟩
                    (F₀.₁ j f ∘ proj X j) ∘ rep X (FXcone X K)    ≈⟨ pullʳ (LimFX.commute X) ⟩
                    F₀.₁ j f ∘ K.ψ.η j X                          ∎ }}
              }
            ; commute = λ {_} {X} → LimFX.commute X
            }
          ; !-unique = λ K⇒⊤ {X} → terminal.!-unique X (K⇒⊤′ X K⇒⊤)
          }
        }
        where open D
              open D.HomReasoning
              open MR D

      ev : C.Obj → Functor D^C D
      ev = evalF C D

      module _ (L : Limit F) (X : C.Obj) where
        private
          module ev = Functor (ev X)
          open Mor D^C
          module DM = Mor D
          open Morₚ D
          open D.HomReasoning
          open MR D

        L′ : Limit (ev X ∘F F)
        L′ = Com (ev X ∘F F)

        Fiso : F[-, X ] ≃ ev X ∘F F
        Fiso = record
          { F⇒G = ntHelper record
            { η       = λ _ → D.id
            ; commute = λ _ → id-comm-sym ○ D.∘-resp-≈ˡ (introʳ (F₀.identity _))
            }
          ; F⇐G = ntHelper record
            { η       = λ _ → D.id
            ; commute = λ _ → D.∘-resp-≈ʳ (elimʳ (F₀.identity _)) ○ id-comm-sym
            }
          ; iso = λ _ → record
            { isoˡ = D.identity²
            ; isoʳ = D.identity²
            }
          }

        apex-iso : Limit.apex L ≅ Limit.apex complete
        apex-iso = up-to-iso F L complete

        apex-iso′ : Limit.apex (Com F[-, X ]) DM.≅ Limit.apex L′
        apex-iso′ = ≃⇒lim≅ Fiso (Com F[-, X ]) L′

        project-iso : Functor.F₀ (Limit.apex L) X DM.≅ Limit.apex L′
        project-iso = record
          { from = ai.from D.∘ from.η X
          ; to   = to.η X D.∘ ai.to
          ; iso  = Iso-∘ (record { isoˡ = isoˡ ; isoʳ = isoʳ }) ai.iso
          }
          where open _≅_ apex-iso
                module from = NaturalTransformation from
                module to   = NaturalTransformation to
                module ai   = DM._≅_ apex-iso′

  Functors-Complete : Complete o″ ℓ″ e″ D^C
  Functors-Complete F = complete F

  evalF-Continuous : ∀ X → Continuous o″ ℓ″ e″ (evalF C D X)
  evalF-Continuous X {J} {F} L = Com (evalF C D X ∘F F) , project-iso F L X


{-# OPTIONS --safe #-}

module Cubical.Categories.Instances.Functors where

open import Cubical.Categories.Category
open import Cubical.Categories.Functor.Base
open import Cubical.Categories.NaturalTransformation.Base
open import Cubical.Categories.NaturalTransformation.Properties
open import Cubical.Categories.Morphism renaming (isIso to isIsoC)
open import Cubical.Foundations.Prelude

private
  variable
    ℓC ℓC' ℓD ℓD' : Level

module _ (C : Category ℓC ℓC') (D : Category ℓD ℓD') where
  open Category
  open NatTrans
  open Functor

  FUNCTOR : Category (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) (ℓ-max (ℓ-max ℓC ℓC') ℓD')
  ob FUNCTOR           = Functor C D
  Hom[_,_] FUNCTOR     = NatTrans
  id FUNCTOR {F}       = idTrans F
  _⋆_ FUNCTOR          = seqTrans
  ⋆IdL FUNCTOR α       = makeNatTransPath λ i x → D .⋆IdL (α .N-ob x) i
  ⋆IdR FUNCTOR α       = makeNatTransPath λ i x → D .⋆IdR (α .N-ob x) i
  ⋆Assoc FUNCTOR α β γ = makeNatTransPath λ i x → D .⋆Assoc (α .N-ob x) (β .N-ob x) (γ .N-ob x) i
  isSetHom FUNCTOR     = isSetNat

  open isIsoC renaming (inv to invC)
  -- componentwise iso is an iso in Functor
  FUNCTORIso : ∀ {F G : Functor C D} (α : F ⇒ G)
             → (∀ (c : C .ob) → isIsoC D (α ⟦ c ⟧))
             → isIsoC FUNCTOR α
  FUNCTORIso α is .invC .N-ob c = (is c) .invC
  FUNCTORIso {F} {G} α is .invC .N-hom {c} {d} f
    = invMoveL areInv-αc
               ( α ⟦ c ⟧ ⋆⟨ D ⟩ (G ⟪ f ⟫ ⋆⟨ D ⟩ is d .invC)
               ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
                 (α ⟦ c ⟧ ⋆⟨ D ⟩ G ⟪ f ⟫) ⋆⟨ D ⟩ is d .invC
               ≡⟨ sym (invMoveR areInv-αd (α .N-hom f)) ⟩
                 F ⟪ f ⟫
               ∎ )
    where
      areInv-αc : areInv _ (α ⟦ c ⟧) ((is c) .invC)
      areInv-αc = isIso→areInv (is c)

      areInv-αd : areInv _ (α ⟦ d ⟧) ((is d) .invC)
      areInv-αd = isIso→areInv (is d)
  FUNCTORIso α is .sec = makeNatTransPath (funExt (λ c → (is c) .sec))
  FUNCTORIso α is .ret = makeNatTransPath (funExt (λ c → (is c) .ret))


{-# OPTIONS --type-in-type #-}
module chu where
open import functors
open import prelude

record Chu : Set where
  constructor _,_!_
  field
    _⁺ _⁻ : Set
    _Ω_ : _⁺ → _⁻ → Set

module _ (A@(A⁺ , A⁻ ! _Ω₁_) B@(B⁺ , B⁻ ! _Ω₂_) : Chu) where
    record Chu[_,_] :  Set where -- Morphisms of chu spaces
      constructor _↔_!_
      field
        to : A⁺ → B⁺
        from : B⁻ → A⁻
        adj : ∀ a⁺ b⁻ → to a⁺ Ω₂ b⁻ ≡ a⁺ Ω₁ from b⁻
module _ {A@(A⁺ , A⁻ ! _Ω₁_)
          B@(B⁺ , B⁻ ! _Ω₂_)
          C@(C⁺ , C⁻ ! _Ω₃_) : Chu}
         (F@(f  ↔ fᵗ ! _†₁_) : Chu[ A , B ])
         (G@(g  ↔ gᵗ ! _†₂_) : Chu[ B , C ]) where
    adj-comp : ∀ a⁺ c⁻ → (g ∘ f) a⁺ Ω₃ c⁻ ≡ a⁺ Ω₁ (fᵗ ∘ gᵗ) c⁻
    adj-comp a⁺ c⁻ = trans (f a⁺ †₂    c⁻)  -- g (f a⁺) Ω₃        c⁻
                           (  a⁺ †₁ gᵗ c⁻)  --    f a⁺  Ω₂     gᵗ c⁻
                                            --      a⁺  Ω₁ fᵗ (gᵗ c⁻)
    chu-comp : Chu[ A , C ]
    chu-comp = (g ∘ f) ↔ (fᵗ ∘ gᵗ) ! adj-comp

instance
    chu-cat : Category Chu[_,_]
    chu-cat = 𝒾: (id ↔ id ! λ _ _ → refl)
              ▸: chu-comp
              𝒾▸: (λ (_ ↔ _ ! _†_) → (λ x → _ ↔ _ ! x) ⟨$⟩
                    extensionality2 λ a⁺ b⁻ → trans-refl (a⁺ † b⁻))
              ▸𝒾: (λ _ → refl)


{-# OPTIONS --guardedness #-}

module Stream where

import      Lvl
open import Data.Boolean
open import Data.List as List using (List)
import      Data.List.Functions as List
import      Data.List.Proofs as List
import      Data.List.Equiv.Id as List
open import Functional
open import Function.Iteration
open import Function.Iteration.Proofs
open import Logic
open import Logic.Propositional
open import Numeral.Natural
open import Relator.Equals
open import Relator.Equals.Proofs
open import Type

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

-- A countably infinite list
record Stream (T : Type{ℓ}) : Type{ℓ} where
  coinductive
  field
    head : T
    tail : Stream(T)
open Stream

module _ where
  -- The n:th element of a stream.
  -- Example: index(2)(0,1,2,…) = 2
  index : Stream(T) → ℕ → T
  index(l)(𝟎)    = head(l)
  index(l)(𝐒(n)) = index(tail(l))(n)

  -- The constant stream, consisting of a single element repeated.
  -- Example: repeat(x) = (x,x,x,..)
  repeat : T → Stream(T)
  head(repeat(x)) = x
  tail(repeat(x)) = repeat(x)

  -- The stream consisting of a list repeated (concatenated infinite many times).
  -- Example: loop(1,2,3) = (1,2,3 , 1,2,3 , 1,2,3 , …)
  loop : (l : List(T)) → (l ≢ List.∅) → Stream(T)
  loop List.∅       p with () ← p [≡]-intro
  head (loop (x List.⊰ l) p) = x
  tail (loop (x List.⊰ l) p) = loop (List.postpend x l) List.[∅]-postpend-unequal

  -- The stream of two interleaved streams.
  -- Example: interleave₂(1,2,3,‥)(a,b,c,…) = (1,a , 2,b , 3,c , …)
  interleave₂ : Stream(T) -> Stream(T) -> Stream(T)
  head(interleave₂(a)(b)) = head(a)
  tail(interleave₂(a)(b)) = interleave₂(b)(tail a)

  -- A stream which skips the first n number of elements from the specified stream.
  -- From the stream of (index 0 l , index 1 l , index 2 l , ..), the stream of (index n l , index (n+1) l , index (n+2) l , ..)
  -- Example: skip(2)(1,2,3,4,…) = (3,4,…)
  skip : ℕ → Stream(T) -> Stream(T)
  head(skip 𝟎      l) = head(l)
  tail(skip 𝟎      l) = tail(l)
  head(skip (𝐒(n)) l) = head(skip n (tail(l)))
  tail(skip (𝐒(n)) l) = tail(skip n (tail(l)))

  -- From the stream of (index 0 l , index 1 l , index 2 l , ..), the stream of (index 0 l , index n l , index (2⋅n) l , ..)
  -- Example: takeMultiples(3)(0,1,2,…) = (0,3,6,…)
  takeMultiples : ℕ → Stream(T) -> Stream(T)
  head(takeMultiples _ l) = head(l)
  tail(takeMultiples n l) = takeMultiples n ((tail ^ n) l)

  -- From the stream of (a,b,c,..), the stream of (x,a,b,c,..)
  _⊰_ : T → Stream(T) -> Stream(T)
  head(x ⊰ _) = x
  tail(_ ⊰ l) = l

  -- Stream of (init , f(init) , f(f(init)) , ..)
  iterated : T -> (T → T) → Stream(T)
  head(iterated init _) = init
  tail(iterated init f) = iterated (f(init)) f

  -- List from the initial part of the stream
  take : ℕ → Stream(T) → List(T)
  take(𝟎)   (l) = List.∅
  take(𝐒(n))(l) = head(l) List.⊰ take(n)(tail(l))

  -- Example: indexIntervals(0,0,2,0,1,2,…)(0,1,2,3,…) = (0,0,2,2,3,5,…)
  indexIntervals : Stream(ℕ) → Stream(T) → Stream(T)
  head (indexIntervals i l) = index l (head i)
  tail (indexIntervals i l) = indexIntervals (tail i) (skip (head i) l)

module _ where
  -- From the stream of (a,b,c,..), the stream of (f(a),f(b),f(c),..)
  map : (A → B) → Stream(A) → Stream(B)
  head(map f(l)) = f(head(l))
  tail(map f(l)) = map f(tail(l))

{- TODO: May not terminate. For example when P = const 𝐹
module _ {ℓ} {A : Type{ℓ}} where
  filter : (A → Bool) → Stream(A) → Stream(A)
  head(filter p(l)) with p(head(l))
  ... | 𝑇 = head(l)
  ... | 𝐹 = head(filter p(tail(l)))
  tail(filter p(l)) = filter p(tail(l))
-}

module _ where
  data _∈_ {T : Type{ℓ}} : T → Stream(T) → Stmt{ℓ} where
    [∈]-head : ∀{l}   → (head(l) ∈ l)
    [∈]-tail : ∀{a l} → (a ∈ tail(l)) → (a ∈ l)

  private variable l : Stream(T)

  index-of-[∈] : (x ∈ l) → ℕ
  index-of-[∈] [∈]-head     = 𝟎
  index-of-[∈] ([∈]-tail p) = 𝐒(index-of-[∈] p)

  index-of-[∈]-correctness : ∀{p : (x ∈ l)} → (index l (index-of-[∈] p) ≡ x)
  index-of-[∈]-correctness {x = .(head l)} {l} {[∈]-head}   = [≡]-intro
  index-of-[∈]-correctness {x = x}         {l} {[∈]-tail p} = index-of-[∈]-correctness {x = x} {tail l} {p}

  _⊆_ : Stream(T) → Stream(T) → Stmt
  _⊆_ l₁ l₂ = ∀{a} → (a ∈ l₁) → (a ∈ l₂)

  [∈]-tails : ((tail ^ n)(l) ⊆ l)
  [∈]-tails {n = 𝟎}   {l = l} {a} tailn = tailn
  [∈]-tails {n = 𝐒 n} {l = l} {a} tailn = [∈]-tail ([∈]-tails {n = n} {l = tail l} {a} ([≡]-substitutionₗ ([^]-inner-value {f = tail}{x = l}{n}) {a ∈_} tailn))

  [∈]-head-tail : (head(tail(l)) ∈ l)
  [∈]-head-tail = [∈]-tail ([∈]-head)

  [∈]-head-tails-membership : (head((tail ^ n)(l)) ∈ l)
  [∈]-head-tails-membership{𝟎}       = [∈]-head
  [∈]-head-tails-membership{𝐒(n)}{l} = [∈]-tails {n = n} ([∈]-head-tail)

  [∈]-disjunction : (x ∈ l) → ((x ≡ head(l)) ∨ (x ∈ tail(l)))
  [∈]-disjunction ([∈]-head)       = [∨]-introₗ [≡]-intro
  [∈]-disjunction ([∈]-tail proof) = [∨]-introᵣ proof

  [∈]-index : (index l n ∈ l)
  [∈]-index {n = 𝟎}    = [∈]-head
  [∈]-index {n = 𝐒(n)} = [∈]-tail ([∈]-index {n = n})

  repeat-[∈] : (x ∈ repeat(a)) ↔ (x ≡ a)
  repeat-[∈] {x = x}{a = a} = [↔]-intro left right where
    left : (x ∈ repeat(a)) ← (x ≡ a)
    left ([≡]-intro) = [∈]-head

    right : (x ∈ repeat(a)) → (x ≡ a)
    right ([∈]-head)       = [≡]-intro
    right ([∈]-tail proof) = right(proof)

  map-[∈] : (x ∈ l) → (f(x) ∈ map f(l))
  map-[∈]         ([∈]-head)       = [∈]-head
  map-[∈] {l = l} ([∈]-tail proof) = [∈]-tail (map-[∈] {l = tail l} (proof))

  [⊰][∈] : (a ∈ (x ⊰ l)) ↔ ((x ≡ a) ∨ (a ∈ l))
  [⊰][∈] {a = a}{x = x}{l = l} = [↔]-intro ll rr where
    ll : (a ∈ (x ⊰ l)) ← ((x ≡ a) ∨ (a ∈ l))
    ll ([∨]-introₗ ([≡]-intro)) = [∈]-head
    ll ([∨]-introᵣ (proof))     = [∈]-tail (proof)

    rr : (a ∈ (x ⊰ l)) → ((x ≡ a) ∨ (a ∈ l))
    rr ([∈]-head)         = [∨]-introₗ ([≡]-intro)
    rr ([∈]-tail (proof)) = [∨]-introᵣ (proof)

  iterated-init-[∈] : (init ∈ iterated(init)(f))
  iterated-init-[∈] = [∈]-head

  iterated-next-[∈] : (x ∈ iterated(init)(f)) → (f(x) ∈ iterated(init)(f))
  iterated-next-[∈] ([∈]-head)       = [∈]-tail ([∈]-head)
  iterated-next-[∈] ([∈]-tail proof) = [∈]-tail (iterated-next-[∈] (proof))
  -- First:
  --   head(iterated(init)(f)) ∈ iterated(init)(f)
  --   init ∈ iterated(init)(f)
  --   ...
  -- Second:
  --   x ∈ tail(iterated(init)(f))
  --   x ∈ iterated (f(init)) f
  --   ...

  iterated-[∈] : ((f ^ n)(init) ∈ iterated(init)(f))
  iterated-[∈] {n = 𝟎}   = iterated-init-[∈]
  iterated-[∈] {n = 𝐒 n} = iterated-next-[∈] (iterated-[∈] {n = n})

-- Stream of (0,1,2,3,..)
[ℕ]-stream : Stream(ℕ)
[ℕ]-stream = iterated(𝟎)(𝐒)

[ℕ]-stream-[∈] : (n ∈ [ℕ]-stream)
[ℕ]-stream-[∈]{𝟎}    = [∈]-head
[ℕ]-stream-[∈]{𝐒(n)} = iterated-next-[∈]([ℕ]-stream-[∈]{n})

-- Stream of (f(0),f(1),f(2),f(3),..)
[ℕ]-function-stream : (ℕ → T) → Stream(T)
[ℕ]-function-stream f = map f([ℕ]-stream)

module _ {ℓ} {T : Type{ℓ}} where
  open import Logic.Predicate
  open import Logic.Predicate.Theorems
  open import Structure.Function.Domain
  open import Type.Size.Countable

  -- This provides another way of proving that a type is countable.
  -- The method is: If a stream can enumerate every object of a certain type, then it is countable.
  countable-equivalence : ∃(l ↦ ∀{x : T} → (x ∈ l)) ↔ Countable(T)
  countable-equivalence = [↔]-intro left right where
    left : ∃(l ↦ ∀{x : T} → (x ∈ l)) ← Countable(T)
    ∃.witness (left ([∃]-intro f ⦃ intro proof ⦄)) = [ℕ]-function-stream f
    ∃.proof   (left ([∃]-intro f ⦃ intro proof ⦄)) {x} with proof{x}
    ... | [∃]-intro n ⦃ [≡]-intro ⦄ = map-[∈] [ℕ]-stream-[∈]

    right : ∃(l ↦ ∀{x : T} → (x ∈ l)) → Countable(T)
    ∃.witness (right ([∃]-intro l ⦃ p ⦄)) = index l
    ∃.witness (Surjective.proof (∃.proof (right ([∃]-intro l ⦃ p ⦄))) {x}) = index-of-[∈] (p{x})
    ∃.proof   (Surjective.proof (∃.proof (right ([∃]-intro l ⦃ p ⦄))) {x}) = index-of-[∈]-correctness {p = p}


{-# OPTIONS --without-K #-}
module Util.Induction.WellFounded where

open import Induction.WellFounded public using
  ( Acc ; acc ; WellFounded ; module Subrelation ; module InverseImage
  ; module TransitiveClosure ; module Lexicographic )

open import Relation.Binary using (Rel)

open import Util.HoTT.FunctionalExtensionality using (funext)
open import Util.HoTT.HLevel using (IsProp ; ∀-IsProp)
open import Util.Prelude

module _ {α β} {A : Set α} {_<_ : Rel A β} where

  Acc-IsProp : ∀ {x} → IsProp (Acc _<_ x)
  Acc-IsProp (acc rs₀) (acc rs₁)
    = cong acc (funext λ y → funext λ y<x → Acc-IsProp _ _)

  WellFounded-IsProp : IsProp (WellFounded _<_)
  WellFounded-IsProp = ∀-IsProp λ _ → Acc-IsProp

  wfInd-acc : ∀ {γ} (P : A → Set γ)
    → (∀ x → (∀ y → y < x → P y) → P x)
    → ∀ x → Acc _<_ x → P x
  wfInd-acc P f x (acc rs) = f x (λ y y<x → wfInd-acc P f y (rs y y<x))

  mutual
    wfIndΣ-acc : ∀ {γ} (P : A → Set γ)
      → (Q : ∀ x y → P x → P y → Set)
      → (f : ∀ x
          → (g : ∀ y → y < x → P y)
          → (∀ y y<x z z<x → Q y z (g y y<x) (g z z<x))
          → P x)
      → (∀ x g g-resp y h h-resp
          → (∀ z z<x z′ z′<y → Q z z′ (g z z<x) (h z′ z′<y))
          → Q x y (f x g g-resp) (f y h h-resp))
      → ∀ x → Acc _<_ x → P x
    wfIndΣ-acc P Q f f-resp x (acc rs)
      = f x
         (λ y y<x → wfIndΣ-acc P Q f f-resp y (rs y y<x))
         (λ y y<x z z<x
            → wfIndΣ-acc-resp P Q f f-resp y (rs y y<x) z (rs z z<x))

    wfIndΣ-acc-resp : ∀ {γ} (P : A → Set γ)
      → (Q : ∀ x y → P x → P y → Set)
      → (f : ∀ x
          → (g : ∀ y → y < x → P y)
          → (∀ y y<x z z<x → Q y z (g y y<x) (g z z<x))
          → P x)
      → (f-resp : ∀ x g g-resp y h h-resp
          → (∀ z z<x z′ z′<y → Q z z′ (g z z<x) (h z′ z′<y))
          → Q x y (f x g g-resp) (f y h h-resp))
      → ∀ x x-acc y y-acc
      → Q x y (wfIndΣ-acc P Q f f-resp x x-acc) (wfIndΣ-acc P Q f f-resp y y-acc)
    wfIndΣ-acc-resp P Q f f-resp x (acc rsx) y (acc rsy)
      = f-resp _ _ _ _ _ _ λ z z<x z′ z′<y
          → wfIndΣ-acc-resp P Q f f-resp z (rsx z z<x) z′ (rsy z′ z′<y)

  module Build (<-wf : WellFounded _<_) where

    wfInd : ∀ {γ} (P : A → Set γ)
      → (∀ x → (∀ y → y < x → P y) → P x)
      → ∀ x → P x
    wfInd P f x = wfInd-acc P f x (<-wf x)

    wfRec : ∀ {γ} {B : Set γ}
      → (∀ x → (∀ y → y < x → B) → B)
      → A → B
    wfRec = wfInd _

    wfInd-unfold : ∀ {γ} (P : A → Set γ)
      → (f : ∀ x → (∀ y → y < x → P y) → P x)
      → (x : A)
      → wfInd P f x ≡ f x (λ y _ → wfInd P f y)
    wfInd-unfold P f x with <-wf x
    ... | acc rs
      = cong (f x)
          (funext λ y → funext λ y<x →
            cong (wfInd-acc P f y) (Acc-IsProp (rs y y<x) (<-wf y)))

    wfRec-unfold : ∀ {γ} {B : Set γ}
      → (f : ∀ x → (∀ y → y < x → B) → B)
      → (x : A)
      → wfRec f x ≡ f x (λ y _ → wfRec f y)
    wfRec-unfold = wfInd-unfold _

    wfInd-ind : ∀ {γ} {P : A → Set γ}
      → (Q : ∀ x → P x → Set)
      → {f : ∀ x → (∀ y → y < x → P y) → P x}
      → (∀ x g
          → (∀ y y<x → Q y (g y y<x))
          → Q x (f x g))
      → {x : A}
      → Q x (wfInd P f x)
    wfInd-ind {P = P} Q {f} f-resp
      = wfInd (λ x → Q x (wfInd P f x))
          (λ x rec → subst (Q x) (sym (wfInd-unfold P f x))
            (f-resp _ _ rec))
          _

    module _ {γ} (P : A → Set γ)
      (Q : ∀ x y → P x → P y → Set)
      (f : ∀ x
        → (g : ∀ y → y < x → P y)
        → (∀ y y<x z z<x → Q y z (g y y<x) (g z z<x))
        → P x)
      (f-resp : ∀ x g g-resp y h h-resp
        → (∀ z z<x z′ z′<y → Q z z′ (g z z<x) (h z′ z′<y))
        → Q x y (f x g g-resp) (f y h h-resp))
      where

      wfIndΣ : Σ[ f ∈ (∀ x → P x) ] (∀ x y → Q x y (f x) (f y))
      wfIndΣ
        = (λ x → wfIndΣ-acc P Q f f-resp x (<-wf x))
        , λ x y → wfIndΣ-acc-resp P Q f f-resp x (<-wf x) y (<-wf y)

      wfIndΣ-unfold : ∀ {x}
        → wfIndΣ .proj₁ x
        ≡ f x (λ y y<x → wfIndΣ .proj₁ y)
            (λ y y<x z z<x → wfIndΣ .proj₂ y z)
      wfIndΣ-unfold {x} with <-wf x
      ... | acc rs
        = go rs (λ y y<x → <-wf y)
        where
          go : (p q : (y : A) → y < x → Acc _<_ y)
            → f x (λ y y<x → wfIndΣ-acc P Q f f-resp y (p y y<x))
                (λ y y<x z z<x
                  → wfIndΣ-acc-resp P Q f f-resp y (p y y<x) z (p z z<x))
            ≡ f x (λ y y<x → wfIndΣ-acc P Q f f-resp y (q y y<x))
                (λ y y<x z z<x
                  → wfIndΣ-acc-resp P Q f f-resp y (q y y<x) z (q z z<x))
          go p q
            rewrite (funext λ y → funext λ y<x → Acc-IsProp (p y y<x) (q y y<x))
            = refl

      wfIndΣ′ : Σ[ g ∈ (∀ x → P x) ]
        Σ[ g-param ∈ (∀ x y → Q x y (g x) (g y)) ]
          (∀ {x} → g x ≡ f x (λ y y<x → g y) (λ y y<x z z<x → g-param y z))
      wfIndΣ′ = wfIndΣ .proj₁ , wfIndΣ .proj₂ , wfIndΣ-unfold

  open Build public

module _ {α β γ δ} {A : Set α} {B : Set β} where

  ×-Rel : Rel A γ → Rel B δ → Rel (A × B) (γ ⊔ℓ δ)
  ×-Rel R S (a , b) (a′ , b′) = R a a′ × S b b′

  ×-wellFounded : {R : Rel A γ} {S : Rel B δ}
    → WellFounded R → WellFounded S → WellFounded (×-Rel R S)
  ×-wellFounded {R} {S} R-wf S-wf (a , b) = ×-acc (R-wf a) (S-wf b)
    where
      ×-acc : ∀ {x y} → Acc R x → Acc S y → Acc (×-Rel R S) (x , y)
      ×-acc (acc rsa) (acc rsb)
        = acc (λ { (a , b) (a<x , b<y) → ×-acc (rsa a a<x) (rsb b b<y) })

-- This is not in Build because the implementation uses wfInd at
-- (×-Rel _<_ _<_), but within Build, we can only use wfInd at
-- _<_.
wfInd-ind₂ : ∀ {α β} {A : Set α} {_<_ : Rel A β}
  → (<-wf : WellFounded _<_)
  → ∀ {γ} {P : A → Set γ}
  → (R : ∀ x y → P x → P y → Set)
  → {f : ∀ x → (∀ y → y < x → P y) → P x}
  → (∀ x x′ g g′
      → (∀ y y′ y<x y′<x → R y y′ (g y y<x) (g′ y′ y′<x))
      → R x x′ (f x g) (f x′ g′))
  → {x x′ : A}
  → R x x′ (wfInd <-wf P f x) (wfInd <-wf P f x′)
wfInd-ind₂ <-wf {P = P} R {f} f-resp
  = wfInd (×-wellFounded <-wf <-wf)
      (λ { (x , x′) → R x x′ (wfInd <-wf P f x) (wfInd <-wf P f x′)})
      (λ where
        (x , y) rec
          → subst₂ (R x y)
              (sym (wfInd-unfold <-wf P f x))
              (sym (wfInd-unfold <-wf P f y))
              (f-resp x y _ _ λ x′ y′ x′<x y′<y → rec (x′ , y′) (x′<x , y′<y)))
      _


module Operator.Equals {ℓ} where

import      Lvl
open import Data.Boolean
open import Functional
open import Relator.Equals{ℓ}
open import Type{ℓ}

-- Type class for run-time checking of equality
record Equals(T : Type) : Type where
  infixl 100 _==_
  field
    _==_ : T → T → Bool
  field
    ⦃ completeness ⦄ : ∀{a b : T} → (a ≡ b) → (a == b ≡ 𝑇)
open Equals ⦃ ... ⦄ using (_==_) public


------------------------------------------------------------------------------
-- Testing subst using an implicit arguments for the propositional function.
------------------------------------------------------------------------------

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

module FOT.FOL.ImplicitArgumentSubst where

infix 7 _≡_

postulate
  D              : Set
  _·_            : D → D → D
  zero succ pred : D

succ₁ : D → D
succ₁ n = succ · n

pred₁ : D → D
pred₁ n = pred · n

-- The identity type on the universe of discourse.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- The propositional function is not an implicit argument.
subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
subst A refl Ax = Ax

-- The propositional formula is an implicit argument.
subst' : {A : D → Set} → ∀ {x y} → x ≡ y → A x → A y
subst' refl Ax = Ax

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

-- Conversion rules.
postulate
  pred-0 : pred₁ zero            ≡ zero
  pred-S : ∀ n → pred₁ (succ₁ n) ≡ n

-- The FOTC natural numbers type.
data N : D → Set where
  nzero :               N zero
  nsucc : ∀ {n} → N n → N (succ₁ n)

-- Works using subst.
pred-N : ∀ {n} → N n → N (pred₁ n)
pred-N nzero          = subst N (sym pred-0) nzero
pred-N (nsucc {n} Nn) = subst N (sym (pred-S n)) Nn

-- Fails using subst'.
pred-N' : ∀ {n} → N n → N (pred₁ n)
pred-N' nzero          = subst' (sym pred-0) nzero
pred-N' (nsucc {n} Nn) = subst' (sym (pred-S n)) Nn


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Sn.Base where

open import Cubical.HITs.Susp
open import Cubical.Foundations.Pointed
open import Cubical.Data.Nat
open import Cubical.Data.NatMinusOne
open import Cubical.Data.Empty
open import Cubical.Foundations.Prelude
open import Cubical.Data.Bool
open import Cubical.HITs.S1

S : ℕ₋₁ → Type₀
S neg1 = ⊥
S (ℕ→ℕ₋₁ n) = Susp (S (-1+ n))

S₊ : ℕ → Type₀
S₊ 0 = Bool
S₊ 1 = S¹
S₊ (suc (suc n)) = Susp (S₊ (suc n))

ptSn : (n : ℕ) → S₊ n
ptSn zero = true
ptSn (suc zero) = base
ptSn (suc (suc n)) = north

-- Pointed version
S₊∙ : (n : ℕ) → Pointed₀
S₊∙ n = (S₊ n) , ptSn n


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

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

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

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

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

open import Categories.Functor
open import Categories.Functor.Construction.Constant
open import Categories.NaturalTransformation.Dinatural
open import Categories.Morphism.Reasoning D

open Functor F

record Wedge : Set (levelOfTerm F) where
  field
    E         : Obj
    dinatural : DinaturalTransformation (const E) F

  module dinatural = DinaturalTransformation dinatural

Wedge-∘ : (W : Wedge) → A ⇒ Wedge.E W → Wedge
Wedge-∘ {A = A} W f = record
  { E         = A
  ; dinatural = extranaturalʳ (λ X → dinatural.α X ∘ f)
                              (⟺ assoc ○ ∘-resp-≈ˡ (extranatural-commʳ dinatural) ○ assoc )
  }
  where open Wedge W

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

  module wedge = Wedge wedge
  open wedge public
  open Wedge

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

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

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


  -- A predicate transformer allowing one to express that
  -- some value definitely does /not/ own some resource
  infixl 9 _◇_
  data _◇_ {p} (P : SPred p) (Φᵢ : Carrier) : SPred (p ⊔ a) where
    ⟪_,_⟫ : ∀ {Φₚ Φ} → P Φₚ → Φᵢ ⊎ Φₚ ≣ Φ → (P ◇ Φᵢ) Φ

  -- | This gives another wand like thing

  module _ {p q} (P : SPred p) (Q : SPred q) where
    infixr 8 _◇─_
    _◇─_ : SPred (p ⊔ q ⊔ a)
    _◇─_ Φᵢ = ∀[ P ◇ Φᵢ ⇒ Q ]

  module _ {p q} {P : SPred p} {Q : SPred q} where
    pair : ε[ P ◇─ (Q ◇─ P ✴ Q) ]
    pair ⟪ px , σ₁ ⟫ ⟪ qx , σ₂ ⟫ rewrite ⊎-id⁻ˡ σ₁ = px ×⟨ σ₂ ⟩ qx

  module _ {p} {P : SPred p} where
    ◇-ε : ∀[ P ◇ ε ⇒ P ]
    ◇-ε ⟪ px , σ ⟫ rewrite ⊎-id⁻ˡ σ = px

    -- pure : ∀ {p q} {P : SPred p} {Q : SPred q} → (P ε → Q Φ) → (P ─✴ Q) Φ
    -- pure f px = {!!}
    -- -- pure = {!!}
    -- a pure wand is a resource-polymorphic function
    -- unwand : ε[ P ─✴ Q ] → ∀[ P ⇒ Q ]
    -- unwand f p = f p ⊎-idˡ

    -- ✴-pure : ∀ {p q} {P : SPred p} {Q : SPred q} → (∀ {Φ} → P Φ → ε ⊎ Φ ≣ Φ → Q Φ) → ε[ P ─✴ Q ]
    -- ✴-pure f px σ rewrite ⊎-id⁻ˡ σ = f px ⊎-idˡ

    -- ✴-flip : ∀ {p q r} {P : SPred p} {Q : SPred q} {R : SPred r} → ε[ (P ─✴ (Q ─✴ R)) ─✴ (Q ─✴ (P ─✴ R)) ]
    -- ✴-flip {P = P} {Q} {R} =
    --   ✴-pure {P = P ─✴ (Q ─✴ R)} {Q = Q ─✴ (P ─✴ R)} λ f σ₁ q σ₂ p σ₃ →
    --   let _ , σ₃ , σ₄ = ⊎-assoc (⊎-comm σ₂) σ₃ in f p σ₄ q (⊎-comm σ₃)

  -- ─[id] : ∀ {p} {P : Pred _ p} → ε[ P ─✴ P ]
  -- ─[id] px σ rewrite ⊎-id⁻ˡ σ = px


-- Minimal logic, PHOAS approach, initial encoding

module Pi.M (Indiv : Set) where

-- Types

data Ty : Set

Pred : Set
Pred = Indiv -> Ty

infixl 2 _&&_
infixl 1 _||_
infixr 0 _=>_
data Ty where
  UNIT   :             Ty
  _=>_   : Ty -> Ty -> Ty
  _&&_   : Ty -> Ty -> Ty
  _||_   : Ty -> Ty -> Ty
  FALSE  :             Ty
  FORALL : Pred     -> Ty
  EXISTS : Pred     -> Ty

infixr 0 _<=>_
_<=>_ : Ty -> Ty -> Ty
a <=> b = (a => b) && (b => a)

NOT : Ty -> Ty
NOT a = a => FALSE

TRUE : Ty
TRUE = FALSE => FALSE

-- Context and truth/individual judgement

data El : Set where
  mkTrue  : Ty    -> El
  mkIndiv : Indiv -> El

Cx : Set1
Cx = El -> Set

isTrue : Ty -> Cx -> Set
isTrue a tc = tc (mkTrue a)

isIndiv : Indiv -> Cx -> Set
isIndiv x tc = tc (mkIndiv x)

-- Terms

module M where
  infixl 2 _$$_
  infixl 1 _$_
  data Tm (tc : Cx) : Ty -> Set where
    var    : forall {a}     -> isTrue a tc                      -> Tm tc a
    lam'   : forall {a b}   -> (isTrue a tc -> Tm tc b)         -> Tm tc (a => b)
    _$_    : forall {a b}   -> Tm tc (a => b)   -> Tm tc a      -> Tm tc b
    pair'  : forall {a b}   -> Tm tc a          -> Tm tc b      -> Tm tc (a && b)
    fst    : forall {a b}   -> Tm tc (a && b)                   -> Tm tc a
    snd    : forall {a b}   -> Tm tc (a && b)                   -> Tm tc b
    left   : forall {a b}   -> Tm tc a                          -> Tm tc (a || b)
    right  : forall {a b}   -> Tm tc b                          -> Tm tc (a || b)
    case'  : forall {a b c} -> Tm tc (a || b)   -> (isTrue a tc -> Tm tc c) -> (isTrue b tc -> Tm tc c) -> Tm tc c
    pi'    : forall {p}     -> (forall {x} -> isIndiv x tc -> Tm tc (p x)) -> Tm tc (FORALL p)
    _$$_   : forall {p x}   -> Tm tc (FORALL p) -> isIndiv x tc -> Tm tc (p x)
    sig'   : forall {p x}   -> isIndiv x tc     -> Tm tc (p x)  -> Tm tc (EXISTS p)
    split' : forall {p x a} -> Tm tc (EXISTS p) -> (isTrue (p x) tc -> Tm tc a) -> Tm tc a

  lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b)
  lam'' f = lam' \x -> f (var x)

  case'' : forall {tc a b c} -> Tm tc (a || b) -> (Tm tc a -> Tm tc c) -> (Tm tc b -> Tm tc c) -> Tm tc c
  case'' xy f g = case' xy (\x -> f (var x)) (\y -> g (var y))

  split'' : forall {tc p x a} -> Tm tc (EXISTS p) -> (Tm tc (p x) -> Tm tc a) -> Tm tc a
  split'' x f = split' x \y -> f (var y)

  syntax lam''   (\a -> b)   = lam a => b
  syntax pair'   x y         = [ x , y ]
  syntax case''  xy (\x -> z1) (\y -> z2) = case xy of x => z1 or y => z2
  syntax pi'     (\x -> px)  = pi x => px
  syntax sig'    x px        = [ x ,, px ]
  syntax split'' x (\y -> z) = split x as y => z

  Thm : Ty -> Set1
  Thm a = forall {tc} -> Tm tc a
open M public


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

open import LogicalFormulae
open import Setoids.Setoids
open import Rings.Definition
open import Rings.IntegralDomains.Definition
open import Vectors
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Definition
open import Sets.EquivalenceRelations

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

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

open import Rings.Units.Definition R
open import Rings.Irreducibles.Definition intDom
open import Rings.Associates.Definition intDom
open import Rings.Primes.Definition intDom
open import Rings.Divisible.Definition R
open import Rings.Divisible.Lemmas R
open import Rings.UniqueFactorisationDomains.Definition intDom
open Ring R
open Setoid S
open Equivalence eq

ufdImpliesUfd' : UFD → UFD'
UFD'.factorisation (ufdImpliesUfd' x) = UFD.factorisation x
Prime.isPrime (UFD'.irreduciblesArePrime (ufdImpliesUfd' ufd) {r} irreducible) a b (s , ab=rs) rNotDivA = {!!}
  where
  -- we can't factorise a, it might be a unit :(
    factA : Factorisation {a} (λ p → rNotDivA (divisibleWellDefined reflexive (symmetric p) (everythingDividesZero r))) {!!}
    factA = UFD.factorisation ufd {a} {!!} {!!}
    fact1 : Factorisation {r} {!!} {!!}
    fact1 = {!!}
    fact2 : Factorisation {r} {!!} {!!}
    fact2 = {!!}
Prime.nonzero (UFD'.irreduciblesArePrime (ufdImpliesUfd' x) irreducible) = Irreducible.nonzero irreducible
Prime.nonunit (UFD'.irreduciblesArePrime (ufdImpliesUfd' x) irreducible) = Irreducible.nonunit irreducible

private
  lemma2 : UFD' → {r : A} → .(nonzero : (r ∼ 0R) → False) .(nonunit : (Unit r) → False) → (f1 f2 : Factorisation {r} nonzero nonunit) → factorisationEquality f1 f2
  lemma2 x nonzero nonunit record { len = lenA ; factorise = factoriseA ; factoriseIsFactorisation = factoriseIsFactorisationA ; factoriseIsIrreducibles = factoriseIsIrreduciblesA ; distinct = distinctA } record { len = lenB ; factorise = factoriseB ; factoriseIsFactorisation = factoriseIsFactorisationB ; factoriseIsIrreducibles = factoriseIsIrreduciblesB ; distinct = distinctB } with ℕDecideEquality lenA lenB
  lemma2 x nonzero nonunit record { len = zero ; factorise = [] ; factoriseIsFactorisation = factoriseIsFactorisationA ; factoriseIsIrreducibles = factoriseIsIrreduciblesA ; distinct = distinctA } record { len = .0 ; factorise = [] ; factoriseIsFactorisation = factoriseIsFactorisationB ; factoriseIsIrreducibles = factoriseIsIrreduciblesB ; distinct = distinctB } | inl refl = record {}
  lemma2 ufd' {r} nonzero nonunit record { len = (succ len) ; factorise = (a1 ,, n1) ,- factoriseA ; factoriseIsFactorisation = factoriseIsFactorisationA ; factoriseIsIrreducibles = factoriseIsIrreduciblesA ; distinct = distinctA } record { len = .(succ len) ; factorise = factoriseB ; factoriseIsFactorisation = factoriseIsFactorisationB ; factoriseIsIrreducibles = factoriseIsIrreduciblesB ; distinct = distinctB } | inl refl = {!!}
    where
      a1Prime : Prime a1
      a1Prime = UFD'.irreduciblesArePrime ufd' (_&&_.fst factoriseIsIrreduciblesA)
      a1DivR : a1 ∣ r
      a1DivR = {!!}

  ... | inr neq = {!!}

ufd'ImpliesUfd : UFD' → UFD
UFD.factorisation (ufd'ImpliesUfd x) = UFD'.factorisation x
UFD.uniqueFactorisation (ufd'ImpliesUfd x) {r} nonzero nonunit f1 f2 = lemma2 x nonzero nonunit f1 f2


------------------------------------------------------------------------------
-- Inductive Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Inductive.Base where

infixl 7 _*_
infixl 6 _+_

------------------------------------------------------------------------------
-- PA universe
open import PA.Inductive.Base.Core public

-- First-order logic (without equality)
--
open import Common.FOL.FOL public hiding ( _,_ ; ∃ )
-- 2012-04-24. Agda bug? Why it is necessary to use the modifier
-- @using@ in the following importation?
open import PA.Inductive.Existential public using ( _,_ ; ∃ )

-- The induction principle on the PA universe
ℕ-ind : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
ℕ-ind A A0 h zero     = A0
ℕ-ind A A0 h (succ n) = h n (ℕ-ind A A0 h n)

-- The identity type on the PA universe
open import PA.Inductive.Relation.Binary.PropositionalEquality public

-- PA primitive recursive functions
_+_ : ℕ → ℕ → ℕ
zero   + n = n
succ m + n = succ (m + n)

_*_ : ℕ → ℕ → ℕ
zero   * n = zero
succ m * n = n + m * n

------------------------------------------------------------------------------
-- ATPs helper
-- We don't traslate the body of functions, only the types. Therefore
-- we need to feed the ATPs with the functions' equations.

-- Addition axioms
+-0x : ∀ n → zero + n ≡ n
+-0x n = refl
-- {-# ATP hint +-0x #-}

+-Sx : ∀ m n → succ m + n ≡ succ (m + n)
+-Sx m n = refl
{-# ATP hint +-Sx #-}

-- Multiplication axioms
*-0x : ∀ n → zero * n ≡ zero
*-0x n = refl
-- {-# ATP hint *-0x #-}

*-Sx : ∀ m n → succ m * n ≡ n + m * n
*-Sx m n = refl
-- {-# ATP hint *-Sx #-}


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

open import lib.Basics
open import lib.types.Sigma
open import lib.types.Bool
open import lib.types.Nat
open import lib.types.Fin

module lib.types.Vec where

infixr 5 _∷_

data Vec {i} (A : Type i) : ℕ → Type i where
  []  : Vec A 0
  _∷_ : ∀ {n} (x : A) (xs : Vec A n) → Vec A (S n)

infix 4 _[_]=_

data _[_]=_ {i} {A : Type i} : ∀ {n} → Vec A n → ℕ → A → Type i where
  here  : ∀ {n}     {x}   {xs : Vec A n} → x ∷ xs [ 0 ]= x
  there : ∀ {n} {m} {x y} {xs : Vec A n}
          (xs[m]=x : xs [ m ]= x) → y ∷ xs [ S m ]= x

module _ {i} {A : Type i} where

  length : ∀ {n} → Vec A n → ℕ
  length {n = n} _ = n

  head : ∀ {n} → Vec A (S n) → A
  head (x ∷ xs) = x

  vtail : ∀ {n} → Vec A (S n) → Vec A n
  vtail (x ∷ xs) = xs

  lookup : ∀ {n} → Vec A n → Fin n → A
  lookup [] ()
  lookup (x ∷ xs) (O , _) = x
  lookup (x ∷ xs) (S n , p) = lookup xs (n , <-cancel-S p)

  updateAt : ∀ {n} → Fin n → (A → A) → Vec A n → Vec A n
  updateAt (_ , _) _ [] = []
  updateAt (O , _) f (x ∷ xs) = (f x) ∷ xs
  updateAt (S n , p) f (x ∷ xs) = x ∷ (updateAt (n , <-cancel-S p) f xs)


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

open import Categories.Category.Core using (Category)

-- Defines BinaryProducts -- for when a Category has all Binary Products

module Categories.Category.BinaryProducts {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level hiding (suc)
open import Data.Product using (uncurry)

open Category 𝒞
open HomReasoning

open import Categories.Object.Product 𝒞
open import Categories.Morphism 𝒞 using (_≅_; module Iso)
open import Categories.Morphism.Reasoning 𝒞 using (pullʳ; pullˡ; elimʳ; cancelˡ)
open import Categories.Category.Monoidal.Core using (Monoidal)

open import Categories.Functor using (Functor) renaming (id to idF)
open import Categories.Functor.Bifunctor using (Bifunctor; appʳ; appˡ)

private
  variable
    A B C D X Y Z : Obj
    f f′ g g′ h i : A ⇒ B

record BinaryProducts : Set (levelOfTerm 𝒞) where

  infixr 7 _×_
  infixr 8 _⁂_
  infix 11 ⟨_,_⟩

  field
    product : ∀ {A B} → Product A B

  private
    module product {A} {B} = Product (product {A} {B})

  _×_ : Obj → Obj → Obj
  A × B = Product.A×B (product {A} {B})

  ×-comm : A × B ≅ B × A
  ×-comm = Commutative product product

  ×-assoc : X × Y × Z ≅ (X × Y) × Z
  ×-assoc = Associative product product product product

  open product hiding (⟨_,_⟩; ∘-distribʳ-⟨⟩) public

  -- define it like this instead of reexporting to redefine fixity
  ⟨_,_⟩ : X ⇒ A → X ⇒ B → X ⇒ A × B
  ⟨_,_⟩ = Product.⟨_,_⟩ product

  _⁂_ : A ⇒ B → C ⇒ D → A × C ⇒ B × D
  f ⁂ g = [ product ⇒ product ] f × g

  assocˡ : (A × B) × C ⇒ A × B × C
  assocˡ = _≅_.to ×-assoc

  assocʳ : A × B × C ⇒ (A × B) × C
  assocʳ = _≅_.from ×-assoc

  assocʳ∘assocˡ : assocʳ {A}{B}{C} ∘ assocˡ {A}{B}{C} ≈ id
  assocʳ∘assocˡ = Iso.isoʳ (_≅_.iso ×-assoc)

  assocˡ∘assocʳ : assocˡ {A}{B}{C} ∘ assocʳ {A}{B}{C} ≈ id
  assocˡ∘assocʳ = Iso.isoˡ (_≅_.iso ×-assoc)

  ⟨⟩-congʳ : f ≈ f′ → ⟨ f , g ⟩ ≈ ⟨ f′ , g ⟩
  ⟨⟩-congʳ pf = ⟨⟩-cong₂ pf Equiv.refl

  ⟨⟩-congˡ : g ≈ g′ → ⟨ f , g ⟩ ≈ ⟨ f , g′ ⟩
  ⟨⟩-congˡ pf = ⟨⟩-cong₂ Equiv.refl pf

  swap : A × B ⇒ B × A
  swap = ⟨ π₂ , π₁ ⟩

  -- TODO: this is probably harder to use than necessary because of this definition. Maybe make a version
  -- that doesn't have an explicit id in it, too?
  first : A ⇒ B → A × C ⇒ B × C
  first f = f ⁂ id

  second : C ⇒ D → A × C ⇒ A × D
  second g = id ⁂ g

  -- Just to make this more obvious
  π₁∘⁂ : π₁ ∘ (f ⁂ g) ≈ f ∘ π₁
  π₁∘⁂ {f = f} {g} = project₁

  π₂∘⁂ : π₂ ∘ (f ⁂ g) ≈ g ∘ π₂
  π₂∘⁂ {f = f} {g} = project₂

  ⁂-cong₂ : f ≈ g → h ≈ i → f ⁂ h ≈ g ⁂ i
  ⁂-cong₂ = [ product ⇒ product ]×-cong₂

  ⁂∘⟨⟩ : (f ⁂ g) ∘ ⟨ f′ , g′ ⟩ ≈ ⟨ f ∘ f′ , g ∘ g′ ⟩
  ⁂∘⟨⟩ = [ product ⇒ product ]×∘⟨⟩

  first∘⟨⟩ : first f ∘ ⟨ f′ , g′ ⟩ ≈ ⟨ f ∘ f′ , g′ ⟩
  first∘⟨⟩ = [ product ⇒ product ]×id∘⟨⟩

  second∘⟨⟩ : second g ∘ ⟨ f′ , g′ ⟩ ≈ ⟨ f′ , g ∘ g′ ⟩
  second∘⟨⟩ = [ product ⇒ product ]id×∘⟨⟩

  ⁂∘⁂ : (f ⁂ g) ∘ (f′ ⁂ g′) ≈ (f ∘ f′) ⁂ (g ∘ g′)
  ⁂∘⁂ = [ product ⇒ product ⇒ product ]×∘×

  ⟨⟩∘ : ⟨ f , g ⟩ ∘ h ≈ ⟨ f ∘ h , g ∘ h ⟩
  ⟨⟩∘ = [ product ]⟨⟩∘

  first∘first : ∀ {C} → first {C = C} f ∘ first g ≈ first (f ∘ g)
  first∘first = [ product ⇒ product ⇒ product ]×id∘×id

  second∘second : ∀ {A} → second {A = A} f ∘ second g ≈ second (f ∘ g)
  second∘second = [ product ⇒ product ⇒ product ]id×∘id×

  first∘second : first f ∘ second g ≈ f ⁂ g
  first∘second {f = f} {g = g} = begin
    first f ∘ second g       ≈⟨ first∘⟨⟩ ⟩
    ⟨ f ∘ id ∘ π₁ , g ∘ π₂ ⟩ ≈⟨ ⟨⟩-congʳ (∘-resp-≈ʳ identityˡ) ⟩
    f ⁂ g                    ∎

  second∘first : second f ∘ first g ≈ g ⁂ f
  second∘first {f = f} {g = g} = begin
    second f ∘ first g ≈⟨ second∘⟨⟩ ⟩
    ⟨ g ∘ π₁ , f ∘ id ∘ π₂ ⟩ ≈⟨ ⟨⟩-congˡ (∘-resp-≈ʳ identityˡ) ⟩
    g ⁂ f ∎

  first↔second : first f ∘ second g ≈ second g ∘ first f
  first↔second = [ product ⇒ product , product ⇒ product ]first↔second

  firstid : ∀ {f : A ⇒ A} (g : A ⇒ C) → first {C = C} f ≈ id → f ≈ id
  firstid {f = f} g eq = begin
    f                    ≈˘⟨ elimʳ project₁ ⟩
    f ∘ π₁ ∘ ⟨ id , g ⟩  ≈⟨ pullˡ fπ₁≈π₁ ⟩
    π₁ ∘ ⟨ id , g ⟩      ≈⟨ project₁ ⟩
    id                   ∎
    where fπ₁≈π₁ = begin
            f ∘ π₁       ≈˘⟨ project₁ ⟩
            π₁ ∘ first f ≈⟨ refl⟩∘⟨ eq ⟩
            π₁ ∘ id      ≈⟨ identityʳ ⟩
            π₁           ∎

  swap∘⟨⟩ : swap ∘ ⟨ f , g ⟩ ≈ ⟨ g , f ⟩
  swap∘⟨⟩ {f = f} {g = g} = begin
    ⟨ π₂ , π₁ ⟩ ∘ ⟨ f , g ⟩             ≈⟨ ⟨⟩∘ ⟩
    ⟨ π₂ ∘ ⟨ f , g ⟩ , π₁ ∘ ⟨ f , g ⟩ ⟩ ≈⟨ ⟨⟩-cong₂ project₂ project₁ ⟩
    ⟨ g , f ⟩                           ∎

  swap∘⁂ : swap ∘ (f ⁂ g) ≈ (g ⁂ f) ∘ swap
  swap∘⁂ {f = f} {g = g} = begin
    swap ∘ (f ⁂ g)      ≈⟨ swap∘⟨⟩ ⟩
    ⟨ g ∘ π₂ , f ∘ π₁ ⟩  ≈˘⟨ ⁂∘⟨⟩ ⟩
    (g ⁂ f) ∘ swap      ∎

  swap∘swap : (swap {A}{B}) ∘ (swap {B}{A}) ≈ id
  swap∘swap = Equiv.trans swap∘⟨⟩ η

  assocʳ∘⟨⟩ : assocʳ ∘ ⟨ f , ⟨ g , h ⟩ ⟩ ≈ ⟨ ⟨ f , g ⟩ , h ⟩
  assocʳ∘⟨⟩ {f = f} {g = g} {h = h} = begin
    assocʳ ∘ ⟨ f , ⟨ g , h ⟩ ⟩ ≈⟨ ⟨⟩∘ ⟩
    ⟨ ⟨ π₁ , π₁ ∘ π₂ ⟩ ∘ ⟨ f , ⟨ g , h ⟩ ⟩
    , (π₂ ∘ π₂) ∘ ⟨ f , ⟨ g , h ⟩ ⟩
    ⟩                          ≈⟨ ⟨⟩-cong₂ ⟨⟩∘ (pullʳ project₂) ⟩
    ⟨ ⟨ π₁        ∘ ⟨ f , ⟨ g , h ⟩ ⟩
      , (π₁ ∘ π₂) ∘ ⟨ f , ⟨ g , h ⟩ ⟩
      ⟩
    , π₂ ∘ ⟨ g , h ⟩
    ⟩                          ≈⟨ ⟨⟩-cong₂ (⟨⟩-cong₂ project₁
                                                     (pullʳ project₂ ○ project₁))
                                           project₂ ⟩
    ⟨ ⟨ f , g ⟩ , h ⟩          ∎

  assocˡ∘⟨⟩ : assocˡ ∘ ⟨ ⟨ f , g ⟩ , h ⟩ ≈ ⟨ f , ⟨ g , h ⟩ ⟩
  assocˡ∘⟨⟩ {f = f} {g = g} {h = h} = begin
    assocˡ ∘ ⟨ ⟨ f , g ⟩ , h ⟩          ≈˘⟨ refl⟩∘⟨ assocʳ∘⟨⟩ ⟩
    assocˡ ∘ assocʳ ∘ ⟨ f , ⟨ g , h ⟩ ⟩ ≈⟨ cancelˡ assocˡ∘assocʳ ⟩
    ⟨ f , ⟨ g , h ⟩ ⟩                   ∎

  assocʳ∘⁂ : assocʳ ∘ (f ⁂ (g ⁂ h)) ≈ ((f ⁂ g) ⁂ h) ∘ assocʳ
  assocʳ∘⁂ {f = f} {g = g} {h = h} =
    begin
      assocʳ ∘ (f ⁂ (g ⁂ h))
    ≈⟨ refl⟩∘⟨ ⟨⟩-congˡ ⟨⟩∘ ⟩
      assocʳ ∘ ⟨ f ∘ π₁ , ⟨ (g ∘ π₁) ∘ π₂ , (h ∘ π₂) ∘ π₂ ⟩ ⟩
    ≈⟨ assocʳ∘⟨⟩ ⟩
      ⟨ ⟨ f ∘ π₁ , (g ∘ π₁) ∘ π₂ ⟩ , (h ∘ π₂) ∘ π₂ ⟩
    ≈⟨ ⟨⟩-cong₂ (⟨⟩-congˡ assoc) assoc ⟩
      ⟨ ⟨ f ∘ π₁ , g ∘ π₁ ∘ π₂ ⟩ , h ∘ π₂ ∘ π₂ ⟩
    ≈˘⟨ ⟨⟩-congʳ ⁂∘⟨⟩ ⟩
      ⟨ (f ⁂ g) ∘ ⟨ π₁ , π₁ ∘ π₂ ⟩ , h ∘ π₂ ∘ π₂ ⟩
    ≈˘⟨ ⁂∘⟨⟩ ⟩
      ((f ⁂ g) ⁂ h) ∘ assocʳ
    ∎

  assocˡ∘⁂ : assocˡ ∘ ((f ⁂ g) ⁂ h) ≈ (f ⁂ (g ⁂ h)) ∘ assocˡ
  assocˡ∘⁂ {f = f} {g = g} {h = h} =
    begin
      assocˡ ∘ ((f ⁂ g) ⁂ h)
    ≈⟨ refl⟩∘⟨ ⟨⟩-congʳ ⟨⟩∘ ⟩
      assocˡ ∘ ⟨ ⟨ (f ∘ π₁) ∘ π₁ , (g ∘ π₂) ∘ π₁ ⟩ , h ∘ π₂ ⟩
    ≈⟨ assocˡ∘⟨⟩ ⟩
      ⟨ (f ∘ π₁) ∘ π₁ , ⟨ (g ∘ π₂) ∘ π₁ , h ∘ π₂ ⟩ ⟩
    ≈⟨ ⟨⟩-cong₂ assoc (⟨⟩-congʳ assoc) ⟩
      ⟨ f ∘ π₁ ∘ π₁ , ⟨ g ∘ π₂ ∘ π₁ , h ∘ π₂ ⟩ ⟩
    ≈˘⟨ ⟨⟩-congˡ ⁂∘⟨⟩ ⟩
      ⟨ f ∘ π₁ ∘ π₁ , (g ⁂ h) ∘ ⟨ π₂ ∘ π₁ , π₂ ⟩ ⟩
    ≈˘⟨ ⁂∘⟨⟩ ⟩
      (f ⁂ (g ⁂ h)) ∘ assocˡ
    ∎

  Δ : ∀ {C} → C ⇒ C × C
  Δ {C} = ⟨ id {C} , id ⟩

  Δ∘ : Δ ∘ f ≈ ⟨ f , f ⟩
  Δ∘ {f = f} = begin
    Δ ∘ f               ≈⟨ ⟨⟩∘ ⟩
    ⟨ id ∘ f , id ∘ f ⟩ ≈⟨ ⟨⟩-cong₂ identityˡ identityˡ ⟩
    ⟨ f , f ⟩           ∎

  ⁂∘Δ : (f ⁂ g) ∘ Δ ≈ ⟨ f , g ⟩
  ⁂∘Δ {f = f} {g = g} = begin
    (f ⁂ g) ∘ Δ         ≈⟨ ⁂∘⟨⟩ ⟩
    ⟨ f ∘ id , g ∘ id ⟩ ≈⟨ ⟨⟩-cong₂ identityʳ identityʳ ⟩
    ⟨ f , g ⟩           ∎

  -×- : Bifunctor 𝒞 𝒞 𝒞
  -×- = record
    { F₀           = uncurry _×_
    ; F₁           = uncurry _⁂_
    ; identity     = id×id product
    ; homomorphism = ⟺ ⁂∘⁂
    ; F-resp-≈     = uncurry [ product ⇒ product ]×-cong₂
    }

  -×_ : Obj → Functor 𝒞 𝒞
  -×_ = appʳ -×-

  _×- : Obj → Functor 𝒞 𝒞
  _×- = appˡ -×-


module FOLsequent where

open import Data.Empty
open import Data.Nat
open import Data.Nat.Properties
open import Data.String using (String)
open import Data.Sum
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; sym; cong; subst)
open import Relation.Nullary
open import Data.List.Base as List using (List; []; _∷_; [_]; _++_)
open import Data.List.Any as LAny
open LAny.Membership-≡

data Term : Set where
  $ : ℕ → Term
  Fun : String → List Term → Term

Const : String -> Term
Const n = Fun n []

data Formula : Set where
  _⟨_⟩ : String → List Term → Formula
  _∧_ : Formula → Formula → Formula
  _∨_ : Formula → Formula → Formula
  _⟶_ : Formula → Formula → Formula
  ~_ : Formula → Formula
  All : (Term → Formula) → Formula
  Ex : (Term → Formula) → Formula

-- data Structure : Set where
--   ∣_∣ : Formula → Structure
--   _,,_ : Structure → Structure → Structure
--   Ø : Structure

Structure = List Formula

mutual
  FVt : Term → List ℕ
  FVt ($ x) = [ x ]
  FVt (Fun _ args) = FVlst args

  FVlst : List Term -> List ℕ
  FVlst [] = []
  FVlst (x ∷ xs) = (FVt x) ++ (FVlst xs)

  FVf : Formula → List ℕ
  FVf (_ ⟨ lst ⟩) = FVlst lst
  FVf (f ∧ f₁) = FVf f ++ FVf f₁
  FVf (f ∨ f₁) = FVf f ++ FVf f₁
  FVf (f ⟶ f₁) = FVf f ++ FVf f₁
  FVf (~ f) = FVf f
  FVf (All x) = FVf (x (Const ""))
  FVf (Ex x) = FVf (x (Const ""))

FV : Structure → List ℕ
FV [] = []
FV (f ∷ l) = FVf f ++ FV l

_#_ : ℕ -> List ℕ -> Set
x # xs = x ∉ xs

∪ : List ℕ -> ℕ
∪ [] = 0
∪ (x ∷ xs) = x ⊔ (∪ xs)

∃# : List ℕ -> ℕ
∃# xs = suc (∪ xs)

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

ℕ-meet-dist : ∀ {x y z : ℕ} -> (x ≤ y) ⊎ (x ≤ z) -> x ≤ y ⊔ z
ℕ-meet-dist {zero} x≤y⊎x≤z = z≤n
ℕ-meet-dist {suc x} {zero} {zero} (inj₁ ())
ℕ-meet-dist {suc x} {zero} {zero} (inj₂ ())
ℕ-meet-dist {suc x} {zero} {suc z} (inj₁ ())
ℕ-meet-dist {suc x} {zero} {suc z} (inj₂ sx≤sz) = sx≤sz
ℕ-meet-dist {suc x} {suc y} {zero} (inj₁ sx≤sy) = sx≤sy
ℕ-meet-dist {suc x} {suc y} {zero} (inj₂ ())
ℕ-meet-dist {suc x} {suc y} {suc z} (inj₁ (s≤s x≤y)) = s≤s (ℕ-meet-dist (inj₁ x≤y))
ℕ-meet-dist {suc x} {suc y} {suc z} (inj₂ (s≤s y≤z)) =
  s≤s (ℕ-meet-dist {_} {y} {z} (inj₂ y≤z))
------------------------------------------------------------------------------------

≤-refl : ∀ {x : ℕ} -> x ≤ x
≤-refl {zero} = z≤n
≤-refl {suc x} = s≤s ≤-refl
------------------------------------------------------------------------------------

∈-cons : ∀ {L} {x y : ℕ} -> x ∈ (y ∷ L) -> ¬(x ≡ y) -> x ∈ L
∈-cons {[]} (here refl) ¬x≡y = ⊥-elim (¬x≡y refl)
∈-cons {[]} (there ()) ¬x≡y
∈-cons {y ∷ L} {x} (here refl) ¬x≡y = ⊥-elim (¬x≡y refl)
∈-cons {y ∷ L} {x} (there x∈L) ¬x≡y = x∈L
------------------------------------------------------------------------------------

∃#-lemma' : ∀ x L -> x ∈ L -> x ≤ ∪ L
∃#-lemma' x [] ()
∃#-lemma' x (y ∷ L) x∈y∷L with x ≟ y
∃#-lemma' x (.x ∷ L) x∈y∷L | yes refl = ℕ-meet-dist {x} {x} (inj₁ ≤-refl)
∃#-lemma' x (y ∷ L) x∈y∷L | no ¬x≡y =
  ℕ-meet-dist {x} {y} (inj₂ (∃#-lemma' x L (∈-cons x∈y∷L ¬x≡y)))
------------------------------------------------------------------------------------

∃#-lemma'' : ∀ x L -> x ∈ L -> ¬ (x ≡ ∃# L)
∃#-lemma'' .(suc (∪ L)) L x∈L refl =
  1+n≰n {∪ L} (∃#-lemma' (suc (∪ L)) L x∈L)
------------------------------------------------------------------------------------

∃#-lemma : ∀ L -> ∃# L ∉ L
∃#-lemma L ∃#L∈L = ∃#-lemma'' (∃# L) L ∃#L∈L refl

data _⊢_ : Structure → Structure → Set where
  I : ∀ {A} → [ A ] ⊢ [ A ]
  Cut : ∀ A {Γ Σ Δ Π} →
    Γ ⊢ (Δ ++ [ A ]) → ([ A ] ++ Σ) ⊢ Π →
    ------------------------------------
            (Γ ++ Σ) ⊢ (Δ ++ Π)
  ∧L₁ : ∀ {Γ Δ A B} → (Γ ++ [ A ]) ⊢ Δ → (Γ ++ [ A ∧ B ]) ⊢ Δ
  ∧L₂ : ∀ {Γ Δ A B} → (Γ ++ [ B ]) ⊢ Δ → (Γ ++ [ A ∧ B ]) ⊢ Δ
  ∧R : ∀ {Γ Σ Δ Π A B} →
    Γ ⊢ ([ A ] ++ Δ) → Σ ⊢ ([ B ] ++ Π) →
    -----------------------------------
    (Γ ++ Σ) ⊢ ([ A ∧ B ] ++ Δ ++ Π)
  ∨R₁ : ∀ {Γ Δ A B} → Γ ⊢ ([ A ] ++ Δ) → Γ ⊢ ([ A ∨ B ] ++ Δ)
  ∨R₂ : ∀ {Γ Δ A B} → Γ ⊢ ([ B ] ++ Δ) → Γ ⊢ ([ A ∨ B ] ++ Δ)
  ∨L :  ∀ {Γ Σ Δ Π A B} →
    (Γ ++ [ A ]) ⊢ Δ → (Σ ++ [ B ]) ⊢ Π →
    -----------------------------------
    (Γ ++ Σ ++ [ A ∨ B ]) ⊢ (Δ ++ Π)
  ⟶L : ∀ {Γ Σ Δ Π A B} →
    Γ ⊢ ([ A ] ++ Δ) → (Σ ++ [ B ]) ⊢ Π →
    ------------------------------------
    (Γ ++ Σ ++ [ A ⟶ B ]) ⊢ (Δ ++ Π)
  ⟶R : ∀ {Γ Δ A B} → (Γ ++ [ A ]) ⊢ ([ B ] ++ Δ) → Γ ⊢ ([ A ⟶ B ] ++ Δ)
  ~L : ∀ {Γ Δ A} → Γ ⊢ ([ A ] ++ Δ) → (Γ ++ [ ~ A ]) ⊢ Δ
  ~R : ∀ {Γ Δ A} → (Γ ++ [ A ]) ⊢ Δ → Γ ⊢ ([ ~ A ] ++ Δ)
  AllL : ∀ {Γ Δ A t} → (Γ ++ [ A t ]) ⊢ Δ → (Γ ++ [ All A ]) ⊢ Δ
  AllR : ∀ {Γ Δ A y} →
    Γ ⊢ ([ A ($ y) ] ++ Δ) → (y-fresh : y # FV (Γ ++ Δ)) →
    ----------------------
    Γ ⊢ ([ All A ] ++ Δ)
  ExL : ∀ {Γ Δ A y} →
    (Γ ++ [ A ($ y) ]) ⊢ Δ → (y-fresh : y # FV (Γ ++ Δ)) →
    ----------------------
    (Γ ++ [ Ex A ]) ⊢ Δ
  ExR : ∀ {Γ Δ A t} → Γ ⊢ ([ A t ] ++ Δ) → Γ ⊢ ([ Ex A ] ++ Δ)
  WL : ∀ {Γ Δ A} → Γ ⊢ Δ → (Γ ++ [ A ]) ⊢ Δ
  WR : ∀ {Γ Δ A} → Γ ⊢ Δ → Γ ⊢ ([ A ] ++ Δ)
  CL : ∀ {Γ Δ A} → (Γ ++ [ A ] ++ [ A ]) ⊢ Δ → (Γ ++ [ A ]) ⊢ Δ
  CR : ∀ {Γ Δ A} → Γ ⊢ ([ A ] ++ [ A ] ++ Δ) → Γ ⊢ ([ A ] ++ Δ)
  PL : ∀ {Γ₁ Γ₂ Δ A B} →
    (Γ₁ ++ [ A ] ++ [ B ] ++ Γ₂) ⊢ Δ →
    ------------------------------------
    (Γ₁ ++ [ B ] ++ [ A ] ++ Γ₂) ⊢ Δ
  PR : ∀ {Γ Δ₁ Δ₂ A B} →
    Γ ⊢ (Δ₁ ++ [ A ] ++ [ B ] ++ Δ₂) →
    ------------------------------------
    Γ ⊢ (Δ₁ ++ [ B ] ++ [ A ] ++ Δ₂)

PL' : ∀ {A B Δ} -> (A ∷ [ B ]) ⊢ Δ → (B ∷ [ A ]) ⊢ Δ
PL' {A} {B} A,B⊢Δ = PL {[]} {[]} {_} {A} {B} A,B⊢Δ

PR' : ∀ {A B Γ} -> Γ ⊢ (A ∷ [ B ]) → Γ ⊢ (B ∷ [ A ])
PR' {A} {B} Γ⊢A,B = PR {_} {[]} {[]} {A} {B} Γ⊢A,B

_>>_ : ∀ {A B : Set} -> (A → B) -> A -> B
A→B >> A = A→B A

open import Data.Product
_>>₂_ : ∀ {A B C : Set} -> (A → B → C) -> A × B -> C
A→B→C >>₂ (A , B) = A→B→C A B

infixr 4 _>>_
infixr 4 _>>₂_

lemma : ∀ {A B C} -> [] ⊢ [ (A ⟶ (B ∨ C)) ⟶ (((B ⟶ (~ A)) ∧ (~ C)) ⟶ (~ A)) ]
lemma {A} {B} {C} = ⟶R >> ⟶R >> PL' >> CR >> ⟶L {[]} {[ (B ⟶ (~ A)) ∧ (~ C) ]} {[ ~ A ]} {[ ~ A ]} >>₂
  (PR' >> ~R >> I) ,
  PL' >> CL {[ B ∨ C ]} {A = (B ⟶ (~ A)) ∧ (~ C)} >> ∧L₂ {(B ∨ C) ∷ [ (B ⟶ (~ A)) ∧ (~ C) ]}
    >> PL {[ B ∨ C ]} {[]} >> ∧L₁ {(B ∨ C) ∷ [ ~ C ]} >> ⟶L {(B ∨ C) ∷ [ ~ C ]} {[]} {[]} >>₂
      (~L {[ B ∨ C ]} >> PR' >> ∨L {[]} {[]} {[ B ]} >>₂ I , I) ,
      I

-- AllR {y = y} (AllL {[]} {t = $ y} I) y-fresh
--   where
--     y = ∃# (FV [ All (λ x → P ⟨ [ x ] ⟩) ])
--     y-fresh = ∃#-lemma (FV [ All (λ x → P ⟨ [ x ] ⟩) ])

AllR# : ∀ {Γ Δ A} → Γ ⊢ ([ A ($ (∃# (FV (Γ ++ Δ)))) ] ++ Δ) → Γ ⊢ ([ All A ] ++ Δ)
AllR# {Γ} {Δ} Γ⊢[y/x]A,Δ = AllR Γ⊢[y/x]A,Δ (∃#-lemma (FV (Γ ++ Δ)))

ExL# : ∀ {Γ Δ A} → (Γ ++ [ A ($ (∃# (FV (Γ ++ Δ)))) ]) ⊢ Δ → (Γ ++ [ Ex A ]) ⊢ Δ
ExL# {Γ} {Δ} Γ,[y/x]A⊢Δ = ExL {Γ} Γ,[y/x]A⊢Δ (∃#-lemma (FV (Γ ++ Δ)))

lemma₁ : ∀ {P} → [ All (λ x → P ⟨ [ x ] ⟩) ] ⊢ [ All (λ y → P ⟨ [ y ] ⟩) ]
lemma₁ {P} = AllR# (AllL {[]} I)

lemma₂ : ∀ {P} →
  [ Ex (λ y → All (λ x → P ⟨ x ∷ [ y ] ⟩)) ] ⊢ [ All (λ x → Ex (λ y → P ⟨ x ∷ [ y ] ⟩)) ]
lemma₂ {P} = AllR# >> ExL# {[]} >> ExR >> AllL {[]} >> I


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

module Cubical.Categories.Sets where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.NaturalTransformation

open Precategory

module _ ℓ where
  SET : Precategory (ℓ-suc ℓ) ℓ
  SET .ob = Σ (Type ℓ) isSet
  SET .Hom[_,_] (A , _) (B , _) = A → B
  SET .id _  = λ x → x
  SET ._⋆_ f g = λ x → g (f x)
  SET .⋆IdL f = refl
  SET .⋆IdR f = refl
  SET .⋆Assoc f g h = refl

module _ {ℓ} where
  isSetExpIdeal : {A B : Type ℓ} → isSet B → isSet (A → B)
  isSetExpIdeal B/set = isSetΠ λ _ → B/set

  isSetLift : {A : Type ℓ} → isSet A → isSet (Lift {ℓ} {ℓ-suc ℓ} A)
  isSetLift = isOfHLevelLift 2

  module _ {A B : SET ℓ .ob} where
    -- monic/surjectiveness
    open import Cubical.Categories.Morphism
    isSurjSET : (f : SET ℓ [ A , B ]) → Type _
    isSurjSET f = ∀ (b : fst B) → Σ[ a ∈ fst A ] f a ≡ b

    -- isMonic→isSurjSET : {f : SET ℓ [ A , B ]}
    --                   → isEpic {C = SET ℓ} {x = A} {y = B} f
    --                   → isSurjSET f
    -- isMonic→isSurjSET ism b = {!!} , {!!}

  instance
    SET-category : isCategory (SET ℓ)
    SET-category .isSetHom {_} {B , B/set} = isSetExpIdeal B/set

private
  variable
    ℓ ℓ' : Level

open Functor

-- Hom functors
_[-,_] : (C : Precategory ℓ ℓ') → (c : C .ob) → ⦃ isCat : isCategory C ⦄ → Functor (C ^op) (SET _)
(C [-, c ]) ⦃ isCat ⦄ .F-ob x = (C [ x , c ]) , isCat .isSetHom
(C [-, c ])           .F-hom f k = f ⋆⟨ C ⟩ k
(C [-, c ])           .F-id = funExt λ _ → C .⋆IdL _
(C [-, c ])           .F-seq _ _ = funExt λ _ → C .⋆Assoc _ _ _

_[_,-] : (C : Precategory ℓ ℓ') → (c : C .ob) → ⦃ isCat : isCategory C ⦄ → Functor C (SET _)
(C [ c ,-]) ⦃ isCat ⦄ .F-ob x = (C [ c , x ]) , isCat .isSetHom
(C [ c ,-])           .F-hom f k = k ⋆⟨ C ⟩ f
(C [ c ,-])           .F-id = funExt λ _ → C .⋆IdR _
(C [ c ,-])           .F-seq _ _ = funExt λ _ → sym (C .⋆Assoc _ _ _)

module _ {C : Precategory ℓ ℓ'} ⦃ _ : isCategory C ⦄ {F : Functor C (SET ℓ')} where
  open NatTrans

  -- natural transformations by pre/post composition
  preComp : {x y : C .ob}
          → (f : C [ x , y ])
          → C [ x ,-] ⇒ F
          → C [ y ,-] ⇒ F
  preComp f α .N-ob c k = (α ⟦ c ⟧) (f ⋆⟨ C ⟩ k)
  preComp f α .N-hom {x = c} {d} k
    = (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ (l ⋆⟨ C ⟩ k)))
    ≡[ i ]⟨ (λ l → (α ⟦ d ⟧) (⋆Assoc C f l k (~ i))) ⟩
      (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ l ⋆⟨ C ⟩ k))
    ≡[ i ]⟨ (λ l → (α .N-hom k) i (f ⋆⟨ C ⟩ l)) ⟩
      (λ l → (F ⟪ k ⟫) ((α ⟦ c ⟧) (f ⋆⟨ C ⟩ l)))
    ∎

-- properties
-- TODO: move to own file
open CatIso renaming (inv to cInv)
open Iso

Iso→CatIso : ∀ {A B : (SET ℓ) .ob}
           → Iso (fst A) (fst B)
           → CatIso {C = SET ℓ} A B
Iso→CatIso is .mor = is .fun
Iso→CatIso is .cInv = is .inv
Iso→CatIso is .sec = funExt λ b → is .rightInv b -- is .rightInv
Iso→CatIso is .ret = funExt λ b → is .leftInv b -- is .rightInv


module FunctionProofs where
open FunctionSet ⦃ signature ⦄

[∃]-unrelatedᵣ-[→]ᵣ-inside-[∀ₛ] : ∀{D : Domain}{P : BinaryRelator} → Proof(∀ₗ(x ↦ ∃ₗ(y ↦ (x ∈ D) ⟶ P(x)(y))) ⟷ ∀ₛ(D)(x ↦ ∃ₗ(y ↦ P(x)(y))))
[∃]-unrelatedᵣ-[→]ᵣ-inside-[∀ₛ] {D}{P} = [↔]-with-[∀] ([∃]-unrelatedᵣ-[→])

[∀ₛ∃!]-to[∀ₛ∃] : ∀{P : BinaryRelator}{D : Domain} → Proof(∀ₛ(D)(x ↦ ∃ₗ!(y ↦ P(x)(y)))) → Proof(∀ₛ(D)(x ↦ ∃ₗ(y ↦ P(x)(y))))
[∀ₛ∃!]-to[∀ₛ∃] proof =
  ([∀ₛ]-intro(\{x} → xinD ↦
    [∧].elimₗ([∀ₛ]-elim proof {x} xinD)
  ))

-- The construction of a meta-function in the meta-logic from a function in the set theory
fnset-witness : ∀{D} → (f : Domain) → ⦃ _ : Proof(Total(D)(f)) ⦄ → Function
fnset-witness f ⦃ proof ⦄ = [∃]-fn-witness ⦃ [↔].elimₗ [∃]-unrelatedᵣ-[→]ᵣ-inside-[∀ₛ] (proof) ⦄

fnset-value : ∀{D} → (f : Domain) → ⦃ proof : Proof(Total(D)(f)) ⦄ → Proof(∀ₛ(D)(x ↦ (x , fnset-witness f(x)) ∈ f))
fnset-value{D} f ⦃ proof ⦄ = [∃]-fn-proof ⦃ [↔].elimₗ [∃]-unrelatedᵣ-[→]ᵣ-inside-[∀ₛ] (proof) ⦄

fnset-proof : ∀{D} → (f : Domain) → ⦃ _ : Proof(FunctionSet(f)) ⦄ → ⦃ total : Proof(Total(D)(f)) ⦄ → Proof(∀ₛ(D)(x ↦ ∀ₗ(y ↦ (fnset-witness{D} f ⦃ total ⦄ x ≡ y) ⟷ ((x , y) ∈ f))))
fnset-proof{D} f ⦃ function ⦄ ⦃ total ⦄ =
  ([∀ₛ]-intro(\{x} → x∈D ↦
    ([∀].intro(\{y} →
      ([↔].intro
        (xy∈f ↦
          ([→].elim
            ([∀].elim([∀].elim([∀].elim function{x}) {fnset-witness f(x)}) {y})
            ([∧].intro
              ([∀ₛ]-elim(fnset-value f) {x} (x∈D))
              (xy∈f)
            )
          )
        )

        (fx≡y ↦
          [≡].elimᵣ (fx≡y) ([∀ₛ]-elim (fnset-value(f)) {x} (x∈D))
        )
      )
    ))
  ))

[→ₛₑₜ]-witness : ∀{A B} → (f : Domain) → ⦃ _ : Proof(f ∈ (A →ₛₑₜ B)) ⦄ → Function
[→ₛₑₜ]-witness f ⦃ proof ⦄ (x) =
  (fnset-witness f
    ⦃ [∧].elimᵣ([∧].elimᵣ([↔].elimᵣ
      ([∀].elim([∀].elim filter-membership))
      (proof)
    )) ⦄
    (x)
  )


module ShowNat where

open import IO
open import Data.Unit
open import Data.Nat.Show
open import Level using (0ℓ)

main = run {0ℓ} (putStrLn (Data.Nat.Show.show 10))


module Numeral.Natural.Oper.Modulo.Proofs.DivisibilityWithRemainder where

open import Data
open import Functional
open import Numeral.Finite
import      Numeral.Finite.Proofs as 𝕟
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Modulo
open import Numeral.Natural.Oper.Modulo.Proofs.Algorithm
open import Numeral.Natural.Relation.DivisibilityWithRemainder hiding (base₀ ; base₊ ; step)
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Relator
open import Syntax.Transitivity

-- The remainder of the divisibility relation is given by the modulo operation.
[mod][∣ᵣₑₘ]-remainder-equality : ∀{x y r}{p : (𝐒(y) ∣ᵣₑₘ x)(r)} → ((x mod 𝐒(y)) ≡ 𝕟-to-ℕ ([∣ᵣₑₘ]-remainder p))
[mod][∣ᵣₑₘ]-remainder-equality {𝟎}             {_}   {𝟎}   {DivRem𝟎} = [≡]-intro
[mod][∣ᵣₑₘ]-remainder-equality {𝐒 .(𝕟-to-ℕ r)} {𝐒 y} {𝐒 r} {DivRem𝟎} = mod'-lesser-dividend {1}{𝐒(y)}{𝕟-to-ℕ r}{y} ([≤]-without-[𝐒] 𝕟.bounded)
[mod][∣ᵣₑₘ]-remainder-equality {𝐒 x}        {𝟎} {𝟎} {DivRem𝐒 p}      = mod'-zero-all-except-dividend {x}
{-# CATCHALL #-}
[mod][∣ᵣₑₘ]-remainder-equality {𝐒 .(x + y)} {y} {r} {DivRem𝐒 {x = x} p} =
  ([ 𝟎 , y ] 𝐒(x + y) mod' y)           🝖[ _≡_ ]-[]
  ([ 𝟎 , y ] (𝐒(x) + y) mod' y)         🝖[ _≡_ ]-[ mod'-sumᵣ-modulo {0}{y}{x}{y} ]
  ([ 𝟎 , y ] x mod' y)                  🝖[ _≡_ ]-[ [mod][∣ᵣₑₘ]-remainder-equality {p = p} ]
  𝕟-to-ℕ ([∣ᵣₑₘ]-remainder p)           🝖[ _≡_ ]-[]
  𝕟-to-ℕ ([∣ᵣₑₘ]-remainder (DivRem𝐒 p)) 🝖-end


{-# OPTIONS --without-K #-}
module Model.Stream where

open import Model.Size as MS using
  ( Size ; Sizes ; _≤_ ; _<_ ; ≤-IsProp ; ≤-trans ; nat )
open import Model.Type.Core
open import Util.HoTT.FunctionalExtensionality
open import Util.HoTT.HLevel
open import Util.Prelude

import Data.Nat.Properties as ℕ

open Size

Colist : Size → Set
Colist n = ∀ m → nat m ≤ n → ℕ

abstract
  Colist-≡⁺ : ∀ {n} {xs ys : Colist n}
    → (∀ m m≤n → xs m m≤n ≡ ys m m≤n)
    → xs ≡ ys
  Colist-≡⁺ eq = funext λ m → funext λ m≤n → eq m m≤n

  Colist-≡⁻ : ∀ {n} {xs ys : Colist n}
    → xs ≡ ys
    → ∀ m m≤n₀ m≤n₁ → xs m m≤n₀ ≡ ys m m≤n₁
  Colist-≡⁻ {xs = xs} refl m m≤n₀ m≤n₁ = cong (xs m) (≤-IsProp _ _)

  Colist-IsSet : ∀ {n} → IsSet (Colist n)
  Colist-IsSet = ∀-IsSet λ m → ∀-IsSet λ m≤n → ℕ.≡-irrelevant

castColist : ∀ {n m} → n ≤ m → Colist m → Colist n
castColist n≤m xs k k≤n = xs k go
  where abstract go = ≤-trans k≤n n≤m

Stream : ⟦Type⟧ Sizes
Stream = record
  { ObjHSet = λ n → HLevel⁺ (Colist n) Colist-IsSet
  ; eqHProp = λ {n} {n′} _ xs ys
      → ∀-HProp ℕ λ m → ∀-HProp (nat m ≤ n) λ m≤n → ∀-HProp (nat m ≤ n′) λ m≤n′
      → HLevel⁺ (xs m m≤n ≡ ys m m≤n′) ℕ.≡-irrelevant
  ; eq-refl = λ x m m≤n m≤n′ → cong (x m) (≤-IsProp _ _)
  }

cons : ∀ {n} → ℕ → (∀ m → m < n → Colist m) → Colist n
cons x xs zero _ = x
cons x xs (suc k) Sk≤n = xs (nat k) go k MS.≤-refl
  where abstract go = MS.Sn≤m→n<m Sk≤n

head : ∀ {n} → Colist n → ℕ
head xs = xs 0 MS.0≤n

tail : ∀ {n} → Colist n → ∀ m → m < n → Colist m
tail xs m m<n k k≤m = xs (suc k) go
  where abstract go = MS.n<m→Sn≤m (MS.≤→<→< k≤m m<n)

abstract
  cons-≡⁺ : ∀ {n n′ i i′ is is′}
    → i ≡ i′
    → (∀ m (m<n : m < n) (m<n′ : m < n′) k k≤m
        → is m m<n k k≤m ≡ is′ m m<n′ k k≤m)
    → ∀ m m<n m<n′
    → cons i is m m<n ≡ cons i′ is′ m m<n′
  cons-≡⁺ i≡i′ is≡is′ zero m<n₀ m<n₁ = i≡i′
  cons-≡⁺ {is′ = is′} i≡i′ is≡is′ (suc m) m<n m<n′
    = trans (is≡is′ (nat m) (MS.Sn≤m→n<m m<n) (MS.Sn≤m→n<m m<n′) m MS.≤-refl)
        (cong (λ p → is′ _ p _ _) (MS.<-IsProp _ _))

  head-≡⁺ : ∀ {n n′ is is′}
    → (∀ m (m≤n : nat m ≤ n) (m≤n′ : nat m ≤ n′) → is m m≤n ≡ is′ m m≤n′)
    → head is ≡ head is′
  head-≡⁺ is≡is′ = is≡is′ 0 MS.0≤n MS.0≤n

  tail-≡⁺ : ∀ {n n′ is is′}
    → (∀ m (m≤n : nat m ≤ n) (m≤n′ : nat m ≤ n′)
        → is m m≤n ≡ is′ m m≤n′)
    → ∀ m m′ m<n m′<n′ k k≤m k≤m′
    → tail is m m<n k k≤m ≡ tail is′ m′ m′<n′ k k≤m′
  tail-≡⁺ {is′ = is′} is≡is′ m m′ m<n m′<n′ k k≤m k≤m′
    = trans (is≡is′ (suc k) _ (MS.n<m→Sn≤m (MS.≤→<→< k≤m′ m′<n′)))
        (cong (is′ (suc k)) (≤-IsProp _ _))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of fresh lists and functions acting on them
------------------------------------------------------------------------

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

module Data.List.Fresh.Properties where

open import Level using (Level; _⊔_; Lift)
open import Data.Product using (_,_)
open import Relation.Nullary
open import Relation.Unary as U using (Pred)
open import Relation.Binary as B using (Rel)

open import Data.List.Fresh

private
  variable
    a b e p r : Level
    A : Set a
    B : Set b

------------------------------------------------------------------------
-- Fresh congruence

module _ {R : Rel A r} {_≈_ : Rel A e} (R≈ : R B.Respectsˡ _≈_) where

  fresh-respectsˡ : ∀ {x y} {xs : List# A R} → x ≈ y → x # xs → y # xs
  fresh-respectsˡ {xs = []}      x≈y x#xs       = _
  fresh-respectsˡ {xs = x ∷# xs} x≈y (r , x#xs) =
    R≈ x≈y r , fresh-respectsˡ x≈y x#xs

------------------------------------------------------------------------
-- Empty and NotEmpty

Empty⇒¬NonEmpty : {R : Rel A r} {xs : List# A R} → Empty xs → ¬ (NonEmpty xs)
Empty⇒¬NonEmpty [] ()

NonEmpty⇒¬Empty : {R : Rel A r} {xs : List# A R} → NonEmpty xs → ¬ (Empty xs)
NonEmpty⇒¬Empty () []

empty? : {R : Rel A r} (xs : List# A R) → Dec (Empty xs)
empty? []       = yes []
empty? (_ ∷# _) = no (λ ())

nonEmpty? : {R : Rel A r} (xs : List# A R) → Dec (NonEmpty xs)
nonEmpty? []             = no (λ ())
nonEmpty? (cons x xs pr) = yes (cons x xs pr)


module ListAppend where

open import Prelude

append : forall {A} -> List A -> List A -> List A
append xs ys = {!!}

appendP1 : forall {x l l'} -> append (cons x l) l' == cons x (append l l')
appendP1 = refl

appendP2 : forall {l} -> append nil l == l
appendP2 = refl


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

module Conaturals where
  open import Basics
  open import Bool
  open import lib.Basics
  open import lib.types.Nat
  open import lib.types.Bool

  {-

  _is-increasing-b : (ℕ → Bool) → Type _
  P is-increasing-b = (n m : ℕ) → n ≤ m → (P n) holds-b → (P m) holds-b

  increasing-b-is-a-prop : (P : ℕ → Bool) → (P is-increasing-b) is-a-prop
  increasing-b-is-a-prop P =
    mp (λ _ → mp (λ x → mp (λ _ → mp (λ _ → (Bool-to-Prop₀ (P x)) holds-is-a-prop ))))
    where mp = mapping-into-prop-is-a-prop

  ℕ∞-prop : SubtypeProp (ℕ → Bool) _
  ℕ∞-prop = _is-increasing-b , increasing-b-is-a-prop

  ℕ∞ : Type₀
  ℕ∞ = Subtype ℕ∞-prop

  -}

  -- I'm having trouble using coinduction =[
  -- The type of conatural numbers
  record ℕ∞ : Type₀ where
    coinductive
    field
      pred∞ : ℕ∞ ⊔ ⊤
    pattern go∞ x = inl x
    pattern stop∞ = inr unit
  open ℕ∞ public

  coO : ℕ∞
  pred∞ coO = stop∞

  co∞ : ℕ∞
  pred∞ co∞ = go∞ co∞

  suc∞ : ℕ∞ → ℕ∞
  pred∞ (suc∞ x) = go∞ x

  ℕ-to-ℕ∞ : ℕ → ℕ∞
  ℕ-to-ℕ∞ O = coO
  ℕ-to-ℕ∞ (S n) = suc∞ (ℕ-to-ℕ∞ n)

  case-pred∞_of_ : {i : ULevel} {A : Type i}
                  (n : ℕ∞) (f :  ℕ∞ ⊔ ⊤ → A)
                  → A
  case-pred∞ n of f = f (pred∞ n)
  {-
    For a paradigmatic use of this function, see below:
  -}

  pred∞-is-coO : ℕ∞ → Bool
  pred∞-is-coO n =
    case-pred∞ n of (λ {
      (go∞ _) → false ;
      stop∞   → true   })

  case∞ : {i : ULevel} {A : Type i}
          (a : A) (f : ℕ∞ → A)
          → ℕ∞ → A
  case∞ a f n = case-pred∞ n of (λ {
                   stop∞ → a       ;
                   (go∞ x) → f x   })

  syntax case∞ a (λ m → t) n = case∞ n of-co0→ a suc∞- m -→ t

  -- ℕ∞-to-ℕ→Prop : ℕ∞ → (ℕ → Bool)
  -- ℕ∞-to-ℕ→Prop n = case∞ n
  --                    of-co0→ (λ _ → true )
  --                    suc∞- m -→ {! λ { O → false ; (S k) → ℕ∞-to-ℕ→Prop m k }!}
  -- previous 4 lines commented by jonas
{- ℕ∞-to-ℕ→Prop n O = pred∞-is-coO n

    ℕ∞-to-ℕ→Prop n (S k) = {!helperS (pred∞ n) k!}
      where
        helperS : ℕ∞ ⊔ ⊤ → ℕ → Bool
        helperS (go∞ pn) O = {!!}
        helperS (go∞ pn) (S k) = {!!}
        helperS stop∞ k = true -}


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

module Light.Library.Relation.Binary.Equality where

open import Light.Library.Relation.Binary using (Binary ; SelfBinary)
open import Light.Library.Relation using (Base)
open import Light.Variable.Levels
open import Light.Level using (Setω)
open import Light.Variable.Sets

-- Binary relation wrapper for equality. (Purely conventional.)
-- (To facilitate instance lookup.)

record Equality ⦃ base : Base ⦄ (𝕒 : Set aℓ) (𝕓 : Set bℓ) : Setω where
      constructor wrap
      field relation : Binary 𝕒 𝕓
      open Binary relation using () renaming (are to _≈_) public

SelfEquality : ∀ ⦃ base : Base ⦄ → Set aℓ → Setω
SelfEquality 𝕒 = Equality 𝕒 𝕒

open Equality ⦃ ... ⦄ using (_≈_) public
private module Eq = Equality ⦃ ... ⦄

relation : ∀ (𝕒 : Set aℓ) (𝕓 : Set bℓ) ⦃ base : Base ⦄ ⦃ equals : Equality 𝕒 𝕓 ⦄ → Binary 𝕒 𝕓
relation _ _ = Eq.relation

self‐relation : ∀ (𝕒 : Set aℓ) ⦃ base : Base ⦄ ⦃ equals : SelfEquality 𝕒 ⦄ → SelfBinary 𝕒
self‐relation _ = Eq.relation


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

open import Categories.Category

module Categories.Functor.Hom.Properties {o ℓ e} (C : Category o ℓ e) where

open import Categories.Functor.Hom.Properties.Covariant C public
open import Categories.Functor.Hom.Properties.Contra C public


module Yoneda where

open import Level
open import Data.Product
open import Relation.Binary
import Relation.Binary.SetoidReasoning as SetR
open Setoid renaming (_≈_ to eqSetoid)

open import Basic
open import Category
import Functor
import Nat

open Category.Category
open Functor.Functor
open Nat.Nat
open Nat.Export

yoneda : ∀{C₀ C₁ ℓ} (C : Category C₀ C₁ ℓ) → Functor.Functor C PSh[ C ]
yoneda C = record {
  fobj = λ x → Hom[ C ][-, x ] ;
  fmapsetoid = λ {A} {B} → record { mapping = λ f → HomNat[ C ][-, f ] ; preserveEq = λ {x} {y} x₁ x₂ → begin⟨ C ⟩
    Map.mapping (component HomNat[ C ][-, x ] _) x₂ ≈⟨ refl-hom C ⟩
    C [ x ∘ x₂ ] ≈⟨ ≈-composite C x₁ (refl-hom C) ⟩
    C [ y ∘ x₂ ] ≈⟨ refl-hom C ⟩
    Map.mapping (component HomNat[ C ][-, y ] _) x₂
  ∎ } ;
  preserveId = λ x → leftId C ;
  preserveComp = λ x → assoc C
  }

YonedaLemma : ∀{C₀ C₁ ℓ} {C : Category C₀ C₁ ℓ} {F : Obj PSh[ C ]} {X : Obj C} → Setoids [ Homsetoid [ op C , Setoids ] (fobj (yoneda C) X) F ≅ LiftSetoid {C₁} {suc (suc ℓ) ⊔ (suc (suc C₁) ⊔ suc C₀)} {ℓ} {C₀ ⊔ C₁ ⊔ ℓ} (fobj F X) ]
YonedaLemma {C₀} {C₁} {ℓ} {C} {F} {X} = record {
  map-→ = nat→obj ;
  map-← = obj→nat ;
  proof = obj→obj≈id , nat→nat≈id }
  where
    nat→obj : Map.Map (Homsetoid [ op C , Setoids ] (fobj (yoneda C) X) F) (LiftSetoid (fobj F X))
    nat→obj = record {
      mapping = λ α → lift (Map.mapping (component α X) (id C)) ;
      preserveEq = λ x≈y → lift (x≈y (id C)) }

    obj→nat : Map.Map (LiftSetoid (fobj F X)) (Homsetoid [ op C , Setoids ] (fobj (yoneda C) X) F)
    obj→nat = record {
      mapping = λ a → record {
        component = component-map a ;
        naturality = λ {c} {d} {f} x → SetR.begin⟨ fobj F d ⟩
          Map.mapping (Setoids [ component-map a d ∘ fmap (fobj (yoneda C) X) f ]) x SetR.≈⟨ refl (fobj F d) ⟩
          Map.mapping (Map.mapping (fmapsetoid F) (C [ x ∘ f ])) (lower a) SetR.≈⟨ (preserveComp F) (lower a) ⟩
          Map.mapping (Map.mapping (fmapsetoid F) f) (Map.mapping (Map.mapping (fmapsetoid F) x) (lower a)) SetR.≈⟨ refl (fobj F d) ⟩
          Map.mapping (Setoids [ fmap F f ∘ component-map a c ]) x
        SetR.∎} ;
      preserveEq = λ {x} {y} x≈y f → SetR.begin⟨ fobj F _ ⟩
        Map.mapping (component-map x _) f SetR.≈⟨ refl (fobj F _) ⟩
        Map.mapping (Map.mapping (fmapsetoid F) f) (lower x) SetR.≈⟨ Map.preserveEq (fmap F f) (lower x≈y) ⟩
        Map.mapping (Map.mapping (fmapsetoid F) f) (lower y) SetR.≈⟨ refl (fobj F _) ⟩
        Map.mapping (component-map y _) f
        SetR.∎}
      where
        component-map = λ a b → record {
          mapping = λ u → Map.mapping (fmap F u) (lower a) ;
          preserveEq = λ {x} {y} x≈y → SetR.begin⟨ fobj F b ⟩
            Map.mapping (fmap F x) (lower a) SetR.≈⟨ (Functor.preserveEq F x≈y) (lower a) ⟩
            Map.mapping (fmap F y) (lower a)
          SetR.∎
          }

    obj→obj≈id : Setoids [ Setoids [ nat→obj ∘ obj→nat ] ≈ id Setoids ]
    obj→obj≈id = λ x → lift (SetR.begin⟨ fobj F X ⟩
      lower (Map.mapping (Setoids [ nat→obj ∘ obj→nat ]) x) SetR.≈⟨ refl (fobj F X) ⟩
      Map.mapping (Map.mapping (fmapsetoid F) (id C)) (lower x) SetR.≈⟨ (preserveId F) (lower x) ⟩
      lower x SetR.≈⟨ refl (fobj F X) ⟩
      lower (Map.mapping {A = LiftSetoid {ℓ′ = ℓ} (fobj F X)} (id Setoids) x)
      SetR.∎)

    nat→nat≈id : Setoids [ Setoids [ obj→nat ∘ nat→obj ] ≈ id Setoids ]
    nat→nat≈id α f = SetR.begin⟨ fobj F _ ⟩
      Map.mapping (component (Map.mapping (Setoids [ obj→nat ∘ nat→obj ]) α) _) f SetR.≈⟨ refl (fobj F _) ⟩
      Map.mapping (Setoids [ fmap F f ∘ component α X ]) (id C) SetR.≈⟨ lemma (id C) ⟩
      Map.mapping (Setoids [ component α (dom C f) ∘ fmap (fobj (yoneda C) X) f ]) (id C) SetR.≈⟨ Map.preserveEq (component α (dom C f)) (leftId C) ⟩
      Map.mapping (component α (dom C f)) f SetR.≈⟨ refl (fobj F _) ⟩
      Map.mapping (component (Map.mapping (id Setoids {Homsetoid [ (op C) , Setoids ] _ _}) α) (dom C f)) f
      SetR.∎
      where
        lemma : Setoids [ Setoids [ fmap F f ∘ component α X ] ≈ Setoids [ component α (dom C f) ∘ fmap (fobj (yoneda C) X) f ] ]
        lemma = sym-hom Setoids {f = Setoids [ component α (dom C f) ∘ fmap (fobj (yoneda C) X) f ]} {g = Setoids [ fmap F f ∘ component α X ]} (naturality α)


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

module Categories.Adjoint.Equivalence where

open import Level

open import Categories.Adjoint
open import Categories.Adjoint.TwoSided
open import Categories.Adjoint.TwoSided.Compose
open import Categories.Category.Core using (Category)
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.NaturalTransformation.NaturalIsomorphism as ≃ using (_≃_)

open import Relation.Binary using (Setoid; IsEquivalence)

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

record ⊣Equivalence (C : Category o ℓ e) (D : Category o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  field
    L    : Functor C D
    R    : Functor D C
    L⊣⊢R : L ⊣⊢ R

  module L    = Functor L
  module R    = Functor R

  open _⊣⊢_ L⊣⊢R public

refl : ⊣Equivalence C C
refl = record
  { L    = idF
  ; R    = idF
  ; L⊣⊢R = id⊣⊢id
  }

sym : ⊣Equivalence C D → ⊣Equivalence D C
sym e = record
  { L    = R
  ; R    = L
  ; L⊣⊢R = op₂
  }
  where open ⊣Equivalence e

trans : ⊣Equivalence C D → ⊣Equivalence D E → ⊣Equivalence C E
trans e e′ = record
  { L    = e′.L ∘F e.L
  ; R    = e.R ∘F e′.R
  ; L⊣⊢R = e.L⊣⊢R ∘⊣⊢ e′.L⊣⊢R
  }
  where module e  = ⊣Equivalence e using (L; R; L⊣⊢R)
        module e′ = ⊣Equivalence e′ using (L; R; L⊣⊢R)

isEquivalence : ∀ {o ℓ e} → IsEquivalence (⊣Equivalence {o} {ℓ} {e})
isEquivalence = record
  { refl  = refl
  ; sym   = sym
  ; trans = trans
  }

setoid : ∀ o ℓ e → Setoid _ _
setoid o ℓ e = record
  { Carrier       = Category o ℓ e
  ; _≈_           = ⊣Equivalence
  ; isEquivalence = isEquivalence
  }


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c}
    {Carrier : Set c}
    (Change : Carrier → Set c)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v)
    (nil : (u : Carrier) → Change u) : Set (c) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u
    -- This corresponds to Lemma 2.3 from the paper.
    update-nil : ∀ v → update v (nil v) ≡ v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c}
    (Carrier : Set c) : Set (suc c) where
  field
    Change : Carrier → Set c
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    -- This generalizes Def. 2.2. from the paper.
    nil : (u : Carrier) → Change u

    isChangeAlgebra : IsChangeAlgebra Change update diff nil

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} {A : Set a} (P : A → Set p): Set (suc p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

-- XXX not clear this is ever used
instance
  change-algebra-family-inst = change-algebra₍_₎

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

RawChange : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  Set (a ⊔ b)
RawChange f = ∀ a (da : Δ a) → Δ (f a)

IsDerivative : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  (df : RawChange f) →
  Set (a ⊔ b)
IsDerivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of IsDerivative for change algebra families.
RawChange₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) → Set (p ⊔ q)
RawChange₍ x , y ₎ f = ∀ px (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)

IsDerivative₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : RawChange₍_,_₎ x y f) →
  Set (p ⊔ q)
IsDerivative₍_,_₎ {P = P} {{CP}} {{CQ}} x y f df = IsDerivative {{change-algebra₍ _ ₎}} {{change-algebra₍ _ ₎}} f df where
  CPx = change-algebra₍_₎ {{CP}} x
  CQy = change-algebra₍_₎ {{CQ}} y

-- Lemma 2.5 appears in Base.Change.Equivalence.

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

-- For non-abelian groups
module PlainGroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isGroup : IsGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsGroup isGroup
      hiding
        ( refl
        ; sym
        )
      renaming
        ( ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    _⊝_ : A → A → A
    v ⊝ u = (u ⁻¹) ⊕ v

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨⟩
               v ⊕ ((v ⁻¹) ⊕ u)
            ≡⟨  sym (assoc _ _ _) ⟩
               (v ⊕ (v ⁻¹)) ⊕ u
            ≡⟨ proj₂ inverse v ⟨⊕⟩ refl ⟩
               ε ⊕ u
            ≡⟨ proj₁ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} (A : Set a) (B : Set b) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b) where
      field
        -- Definition 2.6a
        apply : RawChange f

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    funDiff : (g f : A → B) → FunctionChange f
    funDiff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g (a ⊞ da ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }

    funUpdate : ∀ (f : A → B) (df : FunctionChange f) → A → B
    funUpdate = λ f df a → f a ⊞ apply df a (nil a)

    funNil : (f : A → B) → FunctionChange f
    funNil = λ f → funDiff f f
    private
      -- Realizer for funNil
      funNil-realizer : (f : A → B) → RawChange f
      funNil-realizer f = λ a da → f (a ⊞ da) ⊟ f a
      -- Note that it cannot use nil (f a), that would not be a correct function change!
      funNil-correct : ∀ f a da → funNil-realizer f a da ≡ apply (funNil f) a da
      funNil-correct f a da = refl

    mutual
      -- I have to write the type of funUpdateDiff without using changeAlgebra,
      -- so I just use the underlying implementations.
      funUpdateDiff : ∀ u v → funUpdate v (funDiff u v) ≡ u
      instance
        changeAlgebraFun : ChangeAlgebra (A → B)

      changeAlgebraFun = record
        { Change = FunctionChange
          -- in the paper, update and diff below are in Def. 2.7
        ; update = funUpdate
        ; diff = funDiff
        ; nil = funNil
        ; isChangeAlgebra = record
            -- the proof of update-diff is the second half of what
            -- we have to prove for Theorem 2.8.
          { update-diff = funUpdateDiff
          ; update-nil = λ v → funUpdateDiff v v
          }
        }
      -- XXX remove mutual recursion by inlining the algebra in here?
      funUpdateDiff = λ g f → ext (λ a →
        begin
          f a ⊞ (g (a ⊞ (nil a)) ⊟ f a)
        ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
          f a ⊞ (g a ⊟ f a)
        ≡⟨ update-diff (g a) (f a) ⟩
          g a
        ∎)

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper. However, the derivative of f is just
    -- the apply component of `nil f`, not the full `nil f`, which also includes
    -- a proof. This is not an issue in the paper, which is formulated in a
    -- proof-irrelevant metalanguage.
    nil-is-derivative : ∀ (f : A → B) →
      IsDerivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

    -- Show that any derivative is a valid function change.

    -- In the paper, this is never actually stated. We just prove that nil
    -- changes are derivatives; the paper keeps talking about "the derivative",
    -- suggesting derivatives are unique. If derivatives were unique, we could
    -- say that the nil change is *the* derivative, hence the derivative is the
    -- nil change (hence also a change).
    --
    -- In fact, derivatives are only unique up to change equivalence and
    -- extensional equality; this is proven in Base.Change.Equivalence.derivative-unique.
    --
    Derivative-is-valid : ∀ {f : A → B} df (IsDerivative-f-df : IsDerivative f df) a da →
      f (a ⊞ da) ⊞ (df (a ⊞ da) (nil (a ⊞ da))) ≡ f a ⊞ df a da
    Derivative-is-valid {f} df IsDerivative-f-df a da rewrite IsDerivative-f-df (a ⊞ da) (nil (a ⊞ da)) | update-nil (a ⊞ da) = sym (IsDerivative-f-df a da)

    DerivativeAsChange : ∀ {f : A → B} {df} (IsDerivative-f-df : IsDerivative f df) → Δ f
    DerivativeAsChange {df = df} IsDerivative-f-df = record { apply = df ; correct = Derivative-is-valid df IsDerivative-f-df }
    -- In Equivalence.agda, derivative-is-nil-alternative then proves that a derivative is also a nil change.

-- Reexport a few members with A and B marked as implicit parameters. This
-- matters especially for changeAlgebra, since otherwise it can't be used for
-- instance search.
module _
    {a} {b} {A : Set a} {B : Set b} {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    open FunctionChanges A B {{CA}} {{CB}} public
      using
        ( changeAlgebraFun
        ; apply
        ; correct
        ; incrementalization
        ; DerivativeAsChange
        ; FunctionChange
        ; nil-is-derivative
        )

module BinaryFunctionChanges
    {a} {b} {c} (A : Set a) (B : Set b) (C : Set c) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} {{CC : ChangeAlgebra C}} where
    incrementalization-binary : ∀ (f : A → B → C) df a da b db →
      (f ⊞ df) (a ⊞ da) (b ⊞ db) ≡ f a b ⊞ apply (apply df a da) b db
    incrementalization-binary f df x dx y dy
      rewrite cong (λ □ → □ (y ⊞ dy)) (incrementalization f df x dx)
      = incrementalization (f x) (apply df x dx) y dy

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ Δ pxs  → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ Δ pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff px′ px) (update-diff-all pxs′ pxs)

    instance
      changeAlgebraListChanges : ChangeAlgebraFamily (All P)

    changeAlgebraListChanges = record
      { change-algebra = λ xs → record
        { Change = All′ Δ
        ; update = update-all
        ; diff = diff-all
        ; nil = λ xs → diff-all xs xs
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          ; update-nil = λ xs₁ → update-diff-all xs₁ xs₁
          }
        }
      }


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

open import Cubical.Core.Everything
open import Cubical.Relation.Binary.Raw

module Cubical.Relation.Binary.Reasoning.Equivalence {c ℓ} {A : Type c} (E : Equivalence A ℓ) where

open Equivalence E

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

open import Cubical.Relation.Binary.Reasoning.PartialEquivalence partialEquivalence public
  hiding (_∎⟨_⟩)
open import Cubical.Relation.Binary.Reasoning.Base.Single _≈_ isPreorder public
  using (_∎)


{-# OPTIONS --universe-polymorphism #-}
module Categories.Bifunctor.NaturalTransformation where

open import Level

open import Categories.Category
open import Categories.Bifunctor
open import Categories.Product

open import Categories.NaturalTransformation public

-- just for completeness ...
BiNaturalTransformation : ∀ {o ℓ e} {o′ ℓ′ e′} {o′′ ℓ′′ e′′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {E : Category o′′ ℓ′′ e′′} → Bifunctor C D E → Bifunctor C D E → Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′ ⊔ o′′ ⊔ ℓ′′ ⊔ e′′)
BiNaturalTransformation F G = NaturalTransformation F G

reduceN-× : ∀ {o ℓ e} {o′₁ ℓ′₁ e′₁} {o′₂ ℓ′₂ e′₂} {C : Category o ℓ e} {D₁ : Category o′₁ ℓ′₁ e′₁} {D₂ : Category o′₂ ℓ′₂ e′₂} (H : Bifunctor D₁ D₂ C) {o″₁ ℓ″₁ e″₁} {E₁ : Category o″₁ ℓ″₁ e″₁} {F F′ : Functor E₁ D₁} (φ : NaturalTransformation F F′) {o″₂ ℓ″₂ e″₂} {E₂ : Category o″₂ ℓ″₂ e″₂} {G G′ : Functor E₂ D₂} (γ : NaturalTransformation G G′) → NaturalTransformation (reduce-× {D₁ = D₁} {D₂ = D₂} H F G) (reduce-× {D₁ = D₁} {D₂ = D₂} H F′ G′)
reduceN-× H φ γ = H ∘ˡ (φ ⁂ⁿ γ)

overlapN-× : ∀ {o ℓ e} {o′₁ ℓ′₁ e′₁} {o′₂ ℓ′₂ e′₂} {C : Category o ℓ e} {D₁ : Category o′₁ ℓ′₁ e′₁} {D₂ : Category o′₂ ℓ′₂ e′₂} (H : Bifunctor D₁ D₂ C) {o″ ℓ″ e″} {E : Category o″ ℓ″ e″} {F F′ : Functor E D₁} (φ : NaturalTransformation F F′) {G G′ : Functor E D₂} (γ : NaturalTransformation G G′) → NaturalTransformation (overlap-× {D₁ = D₁} {D₂ = D₂} H F G) (overlap-× {D₁ = D₁} {D₂ = D₂} H F′ G′)
overlapN-× H φ γ = H ∘ˡ (φ ※ⁿ γ)


module plfa-code.Reasoning-legacy where

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

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

_≡⟨_⟩_ : ∀ {A : Set} (x : A) {y z : A}
  → x ≡ y
  → y ≡ z
    -------
  → x ≡ z
x ≡⟨ x≡y ⟩ y≡z  =  trans x≡y y≡z

_∎ : ∀ {A : Set} (x : A)
    ------
  → x ≡ x
x ∎  = refl